source: project/release/3/formular/tags/1.12/form2txt.scm @ 13401

;;
;; 
;; A program to produce plain text output from email form submissions
;; generated by the FormMail.pl script.
;;
;; Copyright 2008-2009 Ivan Raikov and the Okinawa Institute of
;; Science and Technology.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;

(require-extension utf8)
(require-extension utf8-srfi-13)
(require-extension utf8-srfi-14)

(require-extension srfi-1)
(require-extension args)
(require-extension posix)
(require-extension utils)
(require-extension stream-ext)
(require-extension ssax-core)
(require-extension fmt)
(require-extension rb-tree)
(require-extension formular)

(foreign-declare "#include <math.h>")
(define log10 (foreign-lambda double "log10" double))

(define s+ string-append)

(define parser-error error)

(define (xml:str-handler fragment foll-fragment seed)
  (if (string-null? foll-fragment) (cons fragment seed)
      (cons* foll-fragment fragment seed)))

(define (entity-ref->string entity)
  (case entity
    ((quot) "\"")
    ((apos) "'")
    ((amp)  "&")
    ((lt)   "<")
    ((gt)   ">")
    (else (error 'entity-ref->string "unknown entity " entity))))

(define (alist->rb-tree alst)
  (define (s<= x y) 
    (cond ((string-ci< x y) -1)
          ((string-ci= x y) 0)
          (else 1)))
  (let* ((tree    (make-rb-tree s<=))
         (update! (tree 'put!)))
    (for-each (lambda (x) (let ((k (car x))
                                (v (cdr x)))
                            (update! k v)))
              alst)
    tree))
                             


(define (xml:read-string s)
  (let loop ((lst (list)) (iport  (open-input-string s)))
    (if (eof-object? (peek-char iport))
        (string-concatenate (reverse lst))
        (let-values (((lst token)  (SSAX:read-char-data iport #t xml:str-handler lst)))
            (match (and (not (eof-object? token )) 
                        (list (xml-token-kind token) (xml-token-head token)))
                   (('ENTITY-REF entity) 
                    (loop (cons (entity-ref->string entity) lst) iport))
                   (else (loop lst iport)))))))

(define (pp-submission/text id from-address date-seconds fields . rest)
  (let-optionals rest ((include-fields #f))
    (let ((text-fields (filter-map identity
                        (if include-fields
                            (map (lambda (x) (assoc x fields)) include-fields)
                            fields))))
      (print id)
      (for-each (lambda (field)
                  (let ((section-title (->string (first field)))
                        (section-content (string-split (second field) "\n")))
                    (display  (s+ section-title ": "))
                    (for-each (lambda (x) 
                                (for-each (lambda (x) 
                                            (let ((x1 (string-chomp x " ")))
                                              (if (not (string-null? x1)) 
                                                  (print x1))))
                                          (string-split x "\n")))
                              (map xml:read-string section-content ))
                    (print)))
                text-fields))))
                      
(define (make-id i width id-prefix idnum )
  (s+ id-prefix " " (fmt #f (pad-char #\0 (fit/left width (num idnum)))) "-" (->string i)))

(define (pp-formular-tree/text tree . rest)
  (let-optionals rest ((id-prefix "Form Submission") (id-order #f) (include-fields #f)
                       (exclude #f) (after-date #f))
   (let* ((id-list   (list))
          (keys     (tree 'list-keys))
          (order    (or id-order (inexact->exact (ceiling (log10 (length keys)))))))
     ((tree 'foldi)
      (lambda (from-address lst i)
        (cond ((and exclude (member (string->symbol from-address) exclude)) i)
              (else
               (let loop ((lst lst))
                 (if (null? lst) i
                     (match (car lst)
                            (('submission ('date-seconds date-seconds) ('fields fld1 . fields))
                             (if (or (not after-date) (> date-seconds after-date))
                                 (let* ((width (if (positive? order) order 1))
                                        (idnum (inexact->exact (- date-seconds 10e8)))
                                        (id    (let loop ((v 0) (id (make-id 1 width id-prefix idnum)))
                                                 (let ((hv (member id id-list)))
                                                   (if hv (loop (+ v 1) (make-id (+ 1 v) width id-prefix idnum))
                                                       (begin 
                                                         (set! id-list (cons id id-list))
                                                         id))))))
                                   (if (> (length lst) 1)
                                       (print "Multiple submissions by " from-address ": using submission from "
                                              (seconds->string date-seconds)))
                                   (pp-submission/text id from-address date-seconds (cons fld1 fields) include-fields)))
                             (+ i 1))
                            (else (loop (cdr lst)))))))))
      1))))
 

(define opt_exclude       #f)
(define opt_order         3)
(define opt_mbox-path     "mbox")
(define opt_prefix        "Form Submission")
(define opt_fields        #f)
(define opt_alist_output  #f)
(define opt_alist_input   #f)
(define opt_after_date    #f)

(define opts
  `(
    ,(args:make-option (exclude)     (required: "FROM1:FROM2:...")    
                       (string-append "specify a colon-separated list of entries to exclude (default is none )")
                       (set! opt_exclude (map string->symbol (string-split (->string arg) ":"))))
    ,(args:make-option (after-date)     (required: "N")    
                       (string-append "omit entries before given date (in seconds)")
                       (set! opt_after_date (string->number arg)))
    ,(args:make-option (fields)     (required: "FIELD1:FIELD2:...")    
                       (string-append "specify a colon-separated list of fields to process (default is all fields )")
                       (set! opt_fields (append (map string->symbol (string-split (->string arg) ":"))
                                                (or opt_fields (list)))))
    ,(args:make-option (mbox-path)     (required: "PATH")    
                       (string-append "specify path to input mbox (default: " opt_mbox-path ")")
                       (set! opt_mbox-path (->string arg)))
    ,(args:make-option (order)     (required: "N")    
                       (string-append "specify order of form id (default: " (->string opt_order) ")")
                       (set! opt_order (inexact->exact (string->number arg))))
    ,(args:make-option (prefix)     (required: "STRING")    
                       (string-append "specify prefix for text page title (default: " opt_prefix ")")
                       (set! opt_prefix (->string arg)))
    ,(args:make-option (write-alist)     (required: "FILE")    
                       "write an alist representation to FILE"
                       (set! opt_alist_output  (->string arg)))
    ,(args:make-option (read-alist)     (required: "FILE")    
                       "read an alist representation from FILE"
                       (set! opt_alist_input  (->string arg)))
    ,(args:make-option (h help)  #:none               "Print help"
                       (usage))))
    
;; Use args:usage to generate a formatted list of options (from OPTS),
;; suitable for embedding into help text.
(define (usage)
  (print "Usage: form2txt [options...] operands ")
  (newline)
  (print "The following options are recognized: ")
  (newline)
  (print (parameterize ((args:indent 5)) (args:usage opts)))
  (exit 1))


(define args (command-line-arguments))

(set!-values (options operands)  (args:parse args opts))

(define (main options operands)
  (let ((tree  (if opt_alist_input 
                   (alist->rb-tree (read (open-input-file opt_alist_input)))
                   (form-stream->tree (mbox->form-stream opt_mbox-path)))))

    (if opt_alist_output
        (let ((oport (open-output-file opt_alist_output)))
          (display "(" oport) 
          ((tree 'for-each-ascending) (lambda (x) (write x oport)))
          (display ")" oport) ))
          
    (pp-formular-tree/text tree
                           opt_prefix
                           opt_order
                           opt_fields
                           opt_exclude
                           opt_after_date
                           )))


(main options operands)