source: project/release/3/formular/trunk/form2txt.scm @ 10243

Last change on this file since 10243 was 10243, checked in by Ivan Raikov, 12 years ago

Moved formmail to formular.

File size: 6.1 KB
Line 
1;;
2;;
3;; A program to produce plain text output from email form submissions
4;; generated by the FormMail.pl script.
5;;
6;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and
7;; Technology.
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22
23(require-extension srfi-1)
24(require-extension args)
25(require-extension posix)
26(require-extension utils)
27(require-extension stream-ext)
28(require-extension ssax-core)
29(require-extension fmt)
30(require-extension utf8)
31
32(require-extension formular)
33
34(foreign-declare "#include <math.h>")
35(define log10 (foreign-lambda double "log10" double))
36
37(define s+ string-append)
38
39(define parser-error error)
40
41(define (xml:str-handler fragment foll-fragment seed)
42  (if (string-null? foll-fragment) (cons fragment seed)
43      (cons* foll-fragment fragment seed)))
44
45(define (entity-ref->string entity)
46  (case entity
47    ((quot) "\"")
48    ((apos) "'")
49    ((amp)  "&")
50    ((lt)   "<")
51    ((gt)   ">")
52    (else (error 'entity-ref->string "unknown entity " entity))))
53   
54
55(define (xml:read-string s)
56  (let loop ((lst (list)) (iport  (open-input-string s)))
57    (if (eof-object? (peek-char iport))
58        (string-concatenate (reverse lst))
59        (let-values (((lst token)  (SSAX:read-char-data iport #t xml:str-handler lst)))
60            (match (and (not (eof-object? token )) 
61                        (list (xml-token-kind token) (xml-token-head token)))
62                   (('ENTITY-REF entity) 
63                    (loop (cons (entity-ref->string entity) lst) iport))
64                   (else (loop lst iport)))))))
65
66(define (pp-submission/text id from-address date-seconds fields . rest)
67  (let-optionals rest ((include-fields #f))
68    (let ((text-fields (filter-map identity
69                        (if include-fields
70                            (map (lambda (x) (assoc x fields)) include-fields)
71                            fields))))
72      (print id)
73      (for-each (lambda (field)
74                  (let ((section-title (->string (first field)))
75                        (section-content (string-split (second field) "\n")))
76                    (display  (s+ section-title ": "))
77                    (for-each (lambda (x) 
78                                (for-each (lambda (x) 
79                                            (let ((x1 (string-chomp x " ")))
80                                              (if (not (string-null? x1)) 
81                                                  (print x1))))
82                                          (string-split x "\n")))
83                              (map xml:read-string section-content ))
84                    (print)))
85                text-fields))))
86                     
87(define (make-id i width id-prefix idnum )
88  (s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width (num idnum)))) "-" (->string i)))
89
90(define (pp-formular-tree/text tree . rest)
91  (let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
92                       (exclude #f))
93   (let* ((id-list   (list))
94          (keys     (tree 'list-keys))
95          (order    (or id-order (inexact->exact (ceiling (log10 (length keys)))))))
96     ((tree 'foldi)
97      (lambda (from-address lst i)
98        (cond ((and exclude (member (string->symbol from-address) exclude)) i)
99              (else
100               (let loop ((lst lst))
101                 (if (null? lst) i
102                     (match (car lst)
103                            (('submission ('date-seconds date-seconds) ('fields fld1 . fields))
104                             (let* ((width (if (positive? order) order 1))
105                                    (idnum (inexact->exact (- date-seconds 10e8)))
106                                    (id    (let loop ((v 0) (id (make-id 1 width id-prefix idnum)))
107                                             (let ((hv (member id id-list)))
108                                               (if hv (loop (+ v 1) (make-id (+ 1 v) width id-prefix idnum))
109                                                   (begin
110                                                     (set! id-list (cons id id-list))
111                                                     id))))))
112                               (if (> (length lst) 1)
113                                   (print "Multiple submissions by " from-address ": using submission from "
114                                          (seconds->string date-seconds)))
115                               (pp-submission/text id from-address date-seconds (cons fld1 fields) include-fields))
116                             (+ i 1))
117                            (else (loop (cdr lst)))))))))
118      1))))
119 
120
121(define opt_exclude       #f)
122(define opt_order         3)
123(define opt_mbox-path     "mbox")
124(define opt_prefix        "Form Submission")
125(define opt_fields        #f)
126
127(define opts
128  `(
129    ,(args:make-option (exclude)     (required: "FROM1:FROM2:...")   
130                       (string-append "specify a colon-separated list of entries to exclude (default is none )")
131                       (set! opt_exclude (map string->symbol (string-split (->string arg) ":"))))
132    ,(args:make-option (fields)     (required: "FIELD1:FIELD2:...")   
133                       (string-append "specify a colon-separated list of fields to process (default is all fields )")
134                       (set! opt_fields (append (map string->symbol (string-split (->string arg) ":"))
135                                                (or opt_fields (list)))))
136    ,(args:make-option (mbox-path)     (required: "PATH")   
137                       (string-append "specify path to input mbox (default: " opt_mbox-path ")")
138                       (set! opt_mbox-path (->string arg)))
139    ,(args:make-option (order)     (required: "N")   
140                       (string-append "specify order of form id (default: " (->string opt_order) ")")
141                       (set! opt_order (inexact->exact (string->number arg))))
142    ,(args:make-option (prefix)     (required: "STRING")   
143                       (string-append "specify prefix for text page title (default: " opt_prefix ")")
144                       (set! opt_prefix (->string arg)))
145    ,(args:make-option (h help)  #:none               "Print help"
146                       (usage))))
147   
148;; Use args:usage to generate a formatted list of options (from OPTS),
149;; suitable for embedding into help text.
150(define (usage)
151  (print "Usage: form2txt [options...] operands ")
152  (newline)
153  (print "The following options are recognized: ")
154  (newline)
155  (print (parameterize ((args:indent 5)) (args:usage opts)))
156  (exit 1))
157
158
159(define args (command-line-arguments))
160
161(set!-values (options operands)  (args:parse args opts))
162
163(define (main options operands)
164  (let ((forms (mbox->form-stream opt_mbox-path)))
165    (pp-formular-tree/text (form-stream->tree forms)
166                           opt_prefix
167                           opt_order
168                           opt_fields
169                           opt_exclude
170                           )))
171
172
173(main options operands)
Note: See TracBrowser for help on using the repository browser.