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

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

Added option --after-date to form2txt; formular version set to 1.12

File size: 7.5 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) (after-date #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                             (if (or (not after-date) (> date-seconds after-date))
122                                 (let* ((width (if (positive? order) order 1))
123                                        (idnum (inexact->exact (- date-seconds 10e8)))
124                                        (id    (let loop ((v 0) (id (make-id 1 width id-prefix idnum)))
125                                                 (let ((hv (member id id-list)))
126                                                   (if hv (loop (+ v 1) (make-id (+ 1 v) width id-prefix idnum))
127                                                       (begin
128                                                         (set! id-list (cons id id-list))
129                                                         id))))))
130                                   (if (> (length lst) 1)
131                                       (print "Multiple submissions by " from-address ": using submission from "
132                                              (seconds->string date-seconds)))
133                                   (pp-submission/text id from-address date-seconds (cons fld1 fields) include-fields)))
134                             (+ i 1))
135                            (else (loop (cdr lst)))))))))
136      1))))
137 
138
139(define opt_exclude       #f)
140(define opt_order         3)
141(define opt_mbox-path     "mbox")
142(define opt_prefix        "Form Submission")
143(define opt_fields        #f)
144(define opt_alist_output  #f)
145(define opt_alist_input   #f)
146(define opt_after_date    #f)
147
148(define opts
149  `(
150    ,(args:make-option (exclude)     (required: "FROM1:FROM2:...")   
151                       (string-append "specify a colon-separated list of entries to exclude (default is none )")
152                       (set! opt_exclude (map string->symbol (string-split (->string arg) ":"))))
153    ,(args:make-option (after-date)     (required: "N")   
154                       (string-append "omit entries before given date (in seconds)")
155                       (set! opt_after_date (string->number arg)))
156    ,(args:make-option (fields)     (required: "FIELD1:FIELD2:...")   
157                       (string-append "specify a colon-separated list of fields to process (default is all fields )")
158                       (set! opt_fields (append (map string->symbol (string-split (->string arg) ":"))
159                                                (or opt_fields (list)))))
160    ,(args:make-option (mbox-path)     (required: "PATH")   
161                       (string-append "specify path to input mbox (default: " opt_mbox-path ")")
162                       (set! opt_mbox-path (->string arg)))
163    ,(args:make-option (order)     (required: "N")   
164                       (string-append "specify order of form id (default: " (->string opt_order) ")")
165                       (set! opt_order (inexact->exact (string->number arg))))
166    ,(args:make-option (prefix)     (required: "STRING")   
167                       (string-append "specify prefix for text page title (default: " opt_prefix ")")
168                       (set! opt_prefix (->string arg)))
169    ,(args:make-option (write-alist)     (required: "FILE")   
170                       "write an alist representation to FILE"
171                       (set! opt_alist_output  (->string arg)))
172    ,(args:make-option (read-alist)     (required: "FILE")   
173                       "read an alist representation from FILE"
174                       (set! opt_alist_input  (->string arg)))
175    ,(args:make-option (h help)  #:none               "Print help"
176                       (usage))))
177   
178;; Use args:usage to generate a formatted list of options (from OPTS),
179;; suitable for embedding into help text.
180(define (usage)
181  (print "Usage: form2txt [options...] operands ")
182  (newline)
183  (print "The following options are recognized: ")
184  (newline)
185  (print (parameterize ((args:indent 5)) (args:usage opts)))
186  (exit 1))
187
188
189(define args (command-line-arguments))
190
191(set!-values (options operands)  (args:parse args opts))
192
193(define (main options operands)
194  (let ((tree  (if opt_alist_input 
195                   (alist->rb-tree (read (open-input-file opt_alist_input)))
196                   (form-stream->tree (mbox->form-stream opt_mbox-path)))))
197
198    (if opt_alist_output
199        (let ((oport (open-output-file opt_alist_output)))
200          (display "(" oport) 
201          ((tree 'for-each-ascending) (lambda (x) (write x oport)))
202          (display ")" oport) ))
203         
204    (pp-formular-tree/text tree
205                           opt_prefix
206                           opt_order
207                           opt_fields
208                           opt_exclude
209                           opt_after_date
210                           )))
211
212
213(main options operands)
Note: See TracBrowser for help on using the repository browser.