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

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

Bug fixes.

File size: 7.2 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-2009 Ivan Raikov and the Okinawa Institute of
7;; Science and 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 utf8)
24(require-extension utf8-srfi-13)
25(require-extension utf8-srfi-14)
26
27(require-extension srfi-1)
28(require-extension args)
29(require-extension posix)
30(require-extension utils)
31(require-extension stream-ext)
32(require-extension ssax-core)
33(require-extension fmt)
34(require-extension rb-tree)
35(require-extension formular)
36
37(foreign-declare "#include <math.h>")
38(define log10 (foreign-lambda double "log10" double))
39
40(define s+ string-append)
41
42(define parser-error error)
43
44(define (xml:str-handler fragment foll-fragment seed)
45  (if (string-null? foll-fragment) (cons fragment seed)
46      (cons* foll-fragment fragment seed)))
47
48(define (entity-ref->string entity)
49  (case entity
50    ((quot) "\"")
51    ((apos) "'")
52    ((amp)  "&")
53    ((lt)   "<")
54    ((gt)   ">")
55    (else (error 'entity-ref->string "unknown entity " entity))))
56
57(define (alist->rb-tree alst)
58  (define (s<= x y) 
59    (cond ((string-ci< x y) -1)
60          ((string-ci= x y) 0)
61          (else 1)))
62  (let* ((tree    (make-rb-tree s<=))
63         (update! (tree 'put!)))
64    (for-each (lambda (x) (let ((k (car x))
65                                (v (cdr x)))
66                            (update! k v)))
67              alst)
68    tree))
69                             
70
71
72(define (xml:read-string s)
73  (let loop ((lst (list)) (iport  (open-input-string s)))
74    (if (eof-object? (peek-char iport))
75        (string-concatenate (reverse lst))
76        (let-values (((lst token)  (SSAX:read-char-data iport #t xml:str-handler lst)))
77            (match (and (not (eof-object? token )) 
78                        (list (xml-token-kind token) (xml-token-head token)))
79                   (('ENTITY-REF entity) 
80                    (loop (cons (entity-ref->string entity) lst) iport))
81                   (else (loop lst iport)))))))
82
83(define (pp-submission/text id from-address date-seconds fields . rest)
84  (let-optionals rest ((include-fields #f))
85    (let ((text-fields (filter-map identity
86                        (if include-fields
87                            (map (lambda (x) (assoc x fields)) include-fields)
88                            fields))))
89      (print id)
90      (for-each (lambda (field)
91                  (let ((section-title (->string (first field)))
92                        (section-content (string-split (second field) "\n")))
93                    (display  (s+ section-title ": "))
94                    (for-each (lambda (x) 
95                                (for-each (lambda (x) 
96                                            (let ((x1 (string-chomp x " ")))
97                                              (if (not (string-null? x1)) 
98                                                  (print x1))))
99                                          (string-split x "\n")))
100                              (map xml:read-string section-content ))
101                    (print)))
102                text-fields))))
103                     
104(define (make-id i width id-prefix idnum )
105  (s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width (num idnum)))) "-" (->string i)))
106
107(define (pp-formular-tree/text tree . rest)
108  (let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
109                       (exclude #f))
110   (let* ((id-list   (list))
111          (keys     (tree 'list-keys))
112          (order    (or id-order (inexact->exact (ceiling (log10 (length keys)))))))
113     ((tree 'foldi)
114      (lambda (from-address lst i)
115        (cond ((and exclude (member (string->symbol from-address) exclude)) i)
116              (else
117               (let loop ((lst lst))
118                 (if (null? lst) i
119                     (match (car lst)
120                            (('submission ('date-seconds date-seconds) ('fields fld1 . fields))
121                             (let* ((width (if (positive? order) order 1))
122                                    (idnum (inexact->exact (- date-seconds 10e8)))
123                                    (id    (let loop ((v 0) (id (make-id 1 width id-prefix idnum)))
124                                             (let ((hv (member id id-list)))
125                                               (if hv (loop (+ v 1) (make-id (+ 1 v) width id-prefix idnum))
126                                                   (begin
127                                                     (set! id-list (cons id id-list))
128                                                     id))))))
129                               (if (> (length lst) 1)
130                                   (print "Multiple submissions by " from-address ": using submission from "
131                                          (seconds->string date-seconds)))
132                               (pp-submission/text id from-address date-seconds (cons fld1 fields) include-fields))
133                             (+ i 1))
134                            (else (loop (cdr lst)))))))))
135      1))))
136 
137
138(define opt_exclude       #f)
139(define opt_order         3)
140(define opt_mbox-path     "mbox")
141(define opt_prefix        "Form Submission")
142(define opt_fields        #f)
143(define opt_alist_output  #f)
144(define opt_alist_input   #f)
145
146(define opts
147  `(
148    ,(args:make-option (exclude)     (required: "FROM1:FROM2:...")   
149                       (string-append "specify a colon-separated list of entries to exclude (default is none )")
150                       (set! opt_exclude (map string->symbol (string-split (->string arg) ":"))))
151    ,(args:make-option (fields)     (required: "FIELD1:FIELD2:...")   
152                       (string-append "specify a colon-separated list of fields to process (default is all fields )")
153                       (set! opt_fields (append (map string->symbol (string-split (->string arg) ":"))
154                                                (or opt_fields (list)))))
155    ,(args:make-option (mbox-path)     (required: "PATH")   
156                       (string-append "specify path to input mbox (default: " opt_mbox-path ")")
157                       (set! opt_mbox-path (->string arg)))
158    ,(args:make-option (order)     (required: "N")   
159                       (string-append "specify order of form id (default: " (->string opt_order) ")")
160                       (set! opt_order (inexact->exact (string->number arg))))
161    ,(args:make-option (prefix)     (required: "STRING")   
162                       (string-append "specify prefix for text page title (default: " opt_prefix ")")
163                       (set! opt_prefix (->string arg)))
164    ,(args:make-option (write-alist)     (required: "FILE")   
165                       "write an alist representation to FILE"
166                       (set! opt_alist_output  (->string arg)))
167    ,(args:make-option (read-alist)     (required: "FILE")   
168                       "read an alist representation from FILE"
169                       (set! opt_alist_input  (->string arg)))
170    ,(args:make-option (h help)  #:none               "Print help"
171                       (usage))))
172   
173;; Use args:usage to generate a formatted list of options (from OPTS),
174;; suitable for embedding into help text.
175(define (usage)
176  (print "Usage: form2txt [options...] operands ")
177  (newline)
178  (print "The following options are recognized: ")
179  (newline)
180  (print (parameterize ((args:indent 5)) (args:usage opts)))
181  (exit 1))
182
183
184(define args (command-line-arguments))
185
186(set!-values (options operands)  (args:parse args opts))
187
188(define (main options operands)
189  (let ((tree  (if opt_alist_input 
190                   (alist->rb-tree (read (open-input-file opt_alist_input)))
191                   (form-stream->tree (mbox->form-stream opt_mbox-path)))))
192
193    (if opt_alist_output
194        (let ((oport (open-output-file opt_alist_output)))
195          (display "(" oport) 
196          ((tree 'for-each-ascending) (lambda (x) (write x oport)))
197          (display ")" oport) ))
198         
199    (pp-formular-tree/text tree
200                           opt_prefix
201                           opt_order
202                           opt_fields
203                           opt_exclude
204                           )))
205
206
207(main options operands)
Note: See TracBrowser for help on using the repository browser.