source: project/release/3/formular/trunk/form2wiki.scm @ 13346

Last change on this file since 13346 was 13346, checked in by Ivan Raikov, 11 years ago

Added read-alist option to form2wiki.

File size: 10.0 KB
Line 
1;;
2;;
3;; A program to produce wiki pages 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
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(define s$ string->symbol)
42
43(define parser-error error)
44
45(define (xml:str-handler fragment foll-fragment seed)
46  (if (string-null? foll-fragment) (cons fragment seed)
47      (cons* foll-fragment fragment seed)))
48
49(define (entity-ref->string entity)
50  (case entity
51    ((quot) "\"")
52    ((apos) "'")
53    ((amp)  "&")
54    ((lt)   "<")
55    ((gt)   ">")
56    (else (error 'entity-ref->string "unknown entity " entity))))
57   
58(define (lookup-def k lst . rest)
59  (let-optionals rest ((default #f))
60      (let ((kv (assoc k lst)))
61        (if (not kv) default
62            (match kv ((k v) v) (else (cdr kv)))))))
63
64(define (xml:read-string s)
65  (let loop ((lst (list)) (iport (open-input-string s)))
66    (if (eof-object? (peek-char iport))
67        (string-concatenate (reverse lst))
68        (let-values (((lst token)  (SSAX:read-char-data iport #t xml:str-handler lst)))
69            (match (and (not (eof-object? token )) 
70                        (list (xml-token-kind token) (xml-token-head token)))
71                   (('ENTITY-REF entity) 
72                    (loop (cons (entity-ref->string entity) lst) iport))
73                   (else (loop lst iport)))))))
74
75(define (string-take-alphanumeric str n)
76  (let loop ((i n) (lst (string->list str)) (res (list)))
77    (if (or (null? lst) (zero? i)) (list->string (reverse res))
78        (if (positive? i)
79            (loop (if (or (char-alphabetic? (car lst)) (char-numeric? (car lst))) (- i 1) i)
80                  (cdr lst) (cons (car lst) res))))))
81
82(define (string-drop-alphanumeric str n)
83  (let loop ((i n) (lst (string->list str)))
84    (cond ((null? lst)  #f)
85          ((zero? i)    (list->string lst))
86          ((positive? i)
87           (loop (if (or (char-alphabetic? (car lst)) (char-numeric? (car lst))) (- i 1) i) 
88                 (cdr lst))))))
89
90
91(define (pp-submission/wiki id from-address date-seconds fields . rest)
92  (let-optionals rest ((include-fields #f) (field-limits #f) )
93    (let ((wiki-fields (filter-map identity
94                         (if include-fields
95                           (map (lambda (x) (assoc x fields)) include-fields)
96                           fields))))
97      (print (s+ "== " id " ==\n"))
98      (for-each (lambda (field)
99                  (let ((section-limit (lookup-def (first field) field-limits))
100                        (section-text  ((lambda (x) 
101                                          (print "section-text: x = " x)
102                                          (if (string? x) (xml:read-string x) (->string x)) )
103                                        (second field))))
104                    (print "section-text = " section-text)
105                    (let ((section-title (->string (first field)))
106                          (section-content
107                           ((lambda (x) (string-split  x "\n" #t))
108                            ((lambda (x) (if section-limit (string-take-alphanumeric x section-limit) x))
109                             section-text)))
110                          (section-overlimit
111                           ((lambda (x) (and (string? x) (string-split  x "\n" #t)))
112                            ((lambda (x) (and section-limit (string-drop-alphanumeric x section-limit)))
113                             section-text))))
114                      (print  (s+ "=== " section-title " ==="))
115                      (for-each (lambda (x) 
116                                  (for-each (lambda (x) 
117                                              (let ((x1 (string-trim-both x char-whitespace?)))
118                                                (if (not (string-null? x1)) 
119                                                    (print x1 " <br>"))))
120                                            (string-split x "\n")))
121                                section-content )
122                      (if section-overlimit
123                          (begin
124                            (print  (s+ "==== " section-title " (over character limit)  ===="))
125                            (for-each (lambda (x) 
126                                        (for-each (lambda (x) 
127                                                    (let ((x1 (string-trim-both x char-whitespace?)))
128                                                      (if (not (string-null? x1)) 
129                                                          (print x1 " <br>"))))
130                                                  (string-split x "\n")))
131                                      section-overlimit )))
132                      (print))))
133                wiki-fields))))
134                     
135(define (make-id i width id-prefix idnum )
136  (s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width (num idnum)))) "-" (->string i)))
137
138(define (pp-formular-tree/wiki tree . rest)
139  (let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
140                       (exclude #f) (include #f) (field-limits #f) (skip #f))
141   (let* ((keys  (tree 'list-keys))
142          (order (or id-order (inexact->exact (ceiling (log10 (length keys)))))))
143     ((tree 'foldi)
144      (lambda (from-address lst i)
145        (print "from-address = " from-address)
146        (cond ((and exclude (member (s$ from-address) exclude)) i)
147              ((or (not include) (member (s$ from-address) include))
148               (if (and skip (< i skip)) (+ i 1)
149                   (let loop ((lst lst))
150                     (if (null? lst) i
151                         (match (car lst)
152                                (('submission ('date-seconds date-seconds) ('fields fld1 . fields))
153                                 (let* ((width (if (positive? order) order 1))
154                                        (idnum (inexact->exact (- date-seconds 10e8)))
155                                        (id    (let loop ((i 1) (id (make-id 1 width id-prefix idnum)))
156                                                 (if (file-exists? id) 
157                                                     (loop (+ 1 i) (make-id (+ 1 i) width id-prefix idnum)) id))))
158                                   (print "id = " id)
159
160                                   (if (> (length lst) 1)
161                                       (print "Multiple submissions by " from-address ": using submission from "
162                                              (seconds->string date-seconds)))
163                                   (with-output-to-port (open-output-file id)
164                                     (lambda ()
165                                       (pp-submission/wiki id from-address date-seconds (cons fld1 fields) 
166                                                           include-fields field-limits)))
167                                   (+ i 1)))
168                                (else (loop (cdr lst))))))))
169              (else i)))
170      1))))
171 
172
173(define opt_exclude       #f)
174(define opt_include       #f)
175(define opt_order         3)
176(define opt_mbox-path     "mbox")
177(define opt_title-prefix  "Form Submission")
178(define opt_fields        #f)
179(define opt_field-limits  (list))
180(define opt_alist_input   #f)
181(define opt_skip         #f)
182
183(define opts
184  `(
185    ,(args:make-option (exclude)     (required: "FROM1:FROM2:...")   
186                       (string-append "specify a colon-separated list of entries to exclude (default is none )")
187                       (set! opt_exclude (map s$ (string-split (->string arg) ":"))))
188    ,(args:make-option (include)     (required: "FROM1:FROM2:...")   
189                       (string-append "specify a colon-separated list of entries to include (default is all )")
190                       (set! opt_include (map s$ (string-split (->string arg) ":"))))
191    ,(args:make-option (skip)     (required: "N")   
192                       (string-append "skip first N entries (ordered by submission time))")
193                       (set! opt_skip (inexact->exact (string->number arg))))
194    ,(args:make-option (flimits)     (required: "FIELD1:LIMIT1,...")   
195                       (string-append "specify a comma-separated list of fields and character limits (default is none )")
196                       (set! opt_field-limits
197                             (append
198                              (let loop ((lst (string-split (->string arg) ",")) (field-limits (list)))
199                                (if (null? lst) field-limits
200                                    (match (string-split (car lst) ":")
201                                           ((field limit) 
202                                            (let ((field-sym (s$ field))
203                                                  (limit-num (string->number limit)))
204                                              (if (and (symbol? field-sym) (number? limit-num))
205                                                  (loop (cdr lst) (cons (list field-sym limit-num) field-limits))
206                                                  (error "invalid field:limit pair: " (list field limit)))))
207                                           (else (error "invalid field:limit list " lst)))))
208                              opt_field-limits)))
209
210    ,(args:make-option (fields)     (required: "FIELD1:FIELD2:...")   
211                       (string-append "specify a colon-separated list of fields to process (default is all fields )")
212                       (set! opt_fields (append (map s$ (string-split (->string arg) ":")) 
213                                                (or opt_fields (list)))))
214    ,(args:make-option (mbox-path)     (required: "PATH")   
215                       (string-append "specify path to input mbox (default: " opt_mbox-path ")")
216                       (set! opt_mbox-path (->string arg)))
217    ,(args:make-option (order)     (required: "N")   
218                       (string-append "specify order of form id (default: " (->string opt_order) ")")
219                       (set! opt_order (inexact->exact (string->number arg))))
220    ,(args:make-option (prefix)     (required: "STRING")   
221                       (string-append "specify prefix for wiki page title (default: " opt_title-prefix ")")
222                       (set! opt_title-prefix (->string arg)))
223    ,(args:make-option (read-alist)     (required: "FILE")   
224                       "read an alist representation from FILE"
225                       (set! opt_alist_input  (->string arg)))
226    ,(args:make-option (h help)  #:none               "Print help"
227                       (usage))))
228   
229;; Use args:usage to generate a formatted list of options (from OPTS),
230;; suitable for embedding into help text.
231(define (usage)
232  (print "Usage: form2wiki [options...] operands ")
233  (newline)
234  (print "The following options are recognized: ")
235  (newline)
236  (print (parameterize ((args:indent 2) (args:width 32)) (args:usage opts)))
237  (exit 1))
238
239
240(define args (command-line-arguments))
241
242(set!-values (options operands)  (args:parse args opts))
243
244(define (alist->rb-tree alst)
245  (define (s<= x y) 
246    (cond ((string-ci< x y) -1)
247          ((string-ci= x y) 0)
248          (else 1)))
249  (let* ((tree    (make-rb-tree s<=))
250         (update! (tree 'put!)))
251    (for-each (lambda (x) (let ((k (car x))
252                                (v (cdr x)))
253                            (update! k v)))
254              alst)
255    tree))
256                             
257
258(define (main options operands)
259  (let ((tree  (if opt_alist_input 
260                   (alist->rb-tree (read (open-input-file opt_alist_input)))
261                   (form-stream->tree (mbox->form-stream opt_mbox-path)))))
262
263    (pp-formular-tree/wiki tree
264                           opt_title-prefix
265                           opt_order
266                           opt_fields
267                           opt_exclude
268                           opt_include
269                           opt_field-limits
270                           opt_skip
271                           )))
272
273(main options operands)
Note: See TracBrowser for help on using the repository browser.