/[mailutils]/mailutils/guimb/scm/sieve.scm.in
ViewVC logotype

Diff of /mailutils/guimb/scm/sieve.scm.in

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by gray, Sun Oct 13 20:32:27 2002 UTC revision 1.4 by gray, Mon Oct 14 17:47:46 2002 UTC
# Line 1  Line 1 
1  #! %BINDIR%/guimb --source  #! %GUILE_BINDIR%/guile -s
2  # Emacs, its -*- scheme -*-  # Emacs, its -*- scheme -*-
3  !#  !#
4  ;;;; GNU mailutils - a suite of utilities for electronic mail  ;;;; GNU mailutils - a suite of utilities for electronic mail
# Line 21  Line 21 
21    
22  ;;;; This is a Sieve to Scheme translator.  ;;;; This is a Sieve to Scheme translator.
23  ;;;;  ;;;;
24  ;;;; To convert a sieve script into equivalent Scheme program, executable  ;;;; To convert a sieve script into equivalent Scheme program, run:
 ;;;; by guimb, run:  
25  ;;;;  ;;;;
26  ;;;;  guile -s sieve.scm --file <sieve-script-name> --output <output-file-name>  ;;;;  guile -s sieve.scm --file <sieve-script-name> --output <output-file-name>
27  ;;;;  ;;;;
28  ;;;; To compile and execute a sieve script upon a mailbox, run:  ;;;; To compile and execute a sieve script upon a mailbox, run:
29  ;;;;  ;;;;
30  ;;;;  guimb -f sieve.scm -{ --file <sieve-script-name> -} --mailbox ~/mbox  ;;;;  guile -s sieve.scm --file <sieve-script-name> [mailbox-name]
31    ;;;; or
32    ;;;;  guimb [--mailbox mailbox-name] -s sieve.scm --file <sieve-script-name>
33    
34  (define sieve-debug 0)  (define sieve-debug 0)
35  (define sieve-parser #t)  (define sieve-parser #t)
36  (define sieve-libdir "%LIBDIR%")  (define sieve-libdir "%LIBDIR%")
37  (define sieve-load-files '())  (define sieve-load-files '())
38    (define sieve-script-args '())
39    
40  (define error-count 0)  (define error-count 0)
41  (define current-token #f)  (define current-token #f)
# Line 373  Line 375 
375    current-token)    current-token)
376    
377  ;;;;  ;;;;
378    
379    ;;; Syntax tables.
380    ;;; A syntax table is a list of
381    ;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
382    ;;; NAME is a string representing the input language keyword,
383    ;;; FUNCTION is a corresponding function:
384    ;;;       (define (foo [arg [arg...]] . opt-args)
385    ;;; OPT-ARG-LIST is a list of optional arguments (tags),
386    ;;; REQ-ARG-LIST is a list of required (positional) arguments
387    
388  (define (sieve-syntax-table-lookup table name)  (define (sieve-syntax-table-lookup table name)
389      (call-with-current-continuation    (let ((entry (assoc name table)))
390          (lambda (exit)      (if entry
391            (for-each (lambda (x)          (cdr entry)
392                        (if (string=? (car x) name)          #f)))
393                            (exit (cdr x))))  
394                      table)  (define-macro (sieve-syntax-table-add table name function req-arg-list opt-arg-list)
395            #f)))    `(cond
396        ((not (list? ,opt-arg-list))
397         (lex-error "sieve-syntax-table-add: opt-arg-list must be a list"))
398        ((not (list? ,req-arg-list))
399         (lex-error "sieve-syntax-table-add: req-arg-list must be a list"))
400        ((not (or (eq? ,function #f)
401                  (eq? ,function #t)
402                  (procedure? ,function)))
403         (lex-error "sieve-syntax-table-add: bad type for function" ,function))
404        (else
405         (set! ,table
406               (append ,table
407                       (list
408                        (list ,name ,function ,opt-arg-list ,req-arg-list)))))))
409      
410    ;;;;
411    
412    ;;;; Available syntax tables.
413    
414  ;;;; Comparators  ;;;; Comparators
415    
416  ;;; Each entry is (list COMP-NAME COMP-FUNCTION)  ;;; Syntax table for comparators. The opt-arg-list and req-arg-list have
417    ;;; no meaning for comparators, so they are ignored. The handler function
418    ;;; names must start with "comparator-"
419  (define sieve-comparator-table '())  (define sieve-comparator-table '())
420    
421  (define (sieve-find-comparator name)  (define (sieve-find-comparator name)
422    (sieve-syntax-table-lookup sieve-comparator-table name))    (sieve-syntax-table-lookup sieve-comparator-table name))
423    
424  (define (sieve-register-comparator name function)  (define (sieve-register-comparator name function)
425    (if (not (or (eq? function #f)    (sieve-syntax-table-add sieve-comparator-table name function '() '()))
                (eq? function #t)  
                (procedure? function)))  
       (lex-error "sieve-register-comparator: bad type for function"  
                   function))  
   (set! sieve-comparator-table  
         (append sieve-comparator-table (list  
                                         (cons name function)))))  
         
426    
427  ;;;; Command parsers  ;;;; Sieve Tests
428    
429  ;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)  ;;; Syntax table for tests. Function names must start with "test-"
 ;;; OPT-ARG-LIST is a list of optional arguments (aka keywords, tags).  
 ;;; It consists of conses: (cons TAG-NAME FLAG) where FLAG is #t  
 ;;; if the tag requires an argument (e.g. :comparator <comp-name>),  
 ;;; and is #f otherwise.  
 ;;; REQ-ARG-LIST is a list of required (positional) arguments. It  
 ;;; is a list of argument types.  
430  (define sieve-test-table '())  (define sieve-test-table '())
431    
432  (define (sieve-find-test name)  (define (sieve-find-test name)
433    (sieve-syntax-table-lookup sieve-test-table name))    (sieve-syntax-table-lookup sieve-test-table name))
434    
435  (define (sieve-register-test name function req-arg-list  opt-arg-list)  (define (sieve-register-test name function req-arg-list opt-arg-list)
436    (DEBUG 100 "sieve-register-test" name req-arg-list opt-arg-list)    (sieve-syntax-table-add sieve-test-table name function
437    (cond                            req-arg-list opt-arg-list))
438     ((not (list? opt-arg-list))  
439      (lex-error "sieve-register-test: opt-arg-list must be a list"))  ;;;; Sieve Actions
440     ((not (list? req-arg-list))  
441      (lex-error "sieve-register-test: req-arg-list must be a list"))  ;;; Syntax table for actions. Function names start with "action-"
442     ((not (or (eq? function #f)  (define sieve-action-table '())
443               (eq? function #t)  
444               (procedure? function)))  (define (sieve-find-action name)
445      (lex-error "sieve-register-test: bad type for function" function))    (sieve-syntax-table-lookup sieve-action-table name))
446     (else  
447      (set! sieve-test-table  (define (sieve-register-action name function req-arg-list opt-arg-list)
448            (append sieve-test-table    (sieve-syntax-table-add sieve-action-table name function
449                    (list                            req-arg-list opt-arg-list))
450                     (list name function opt-arg-list req-arg-list)))))))  
451      ;;;;
452    
453    ;;;; Command parsers
454    
455  ;;; sieve-preprocess-arguments: Preprocess and group the arguments. Returns  ;;; sieve-preprocess-arguments: Preprocess and group the arguments. Returns
456  ;;; a cons whose car is a list of all optional arguments, and the cdr is  ;;; a cons whose car is a list of all optional arguments, and the cdr is
# Line 555  Line 573 
573                             (cdr tag)))))                             (cdr tag)))))
574       (car arg-list))))       (car arg-list))))
575    
576    ;;;;
577    
578    ;;;; Parser functions for tests
579    
580  ;;; test-list = "(" test *("," test) ")"  ;;; test-list = "(" test *("," test) ")"
581  (define (sieve-parse-test-list)  (define (sieve-parse-test-list)
582    (do ((token (sieve-parse-test) (sieve-parse-test)))    (do ((token (sieve-parse-test) (sieve-parse-test)))
# Line 692  Line 714 
714    (sieve-exp-finish)    (sieve-exp-finish)
715    (require-semicolon))    (require-semicolon))
716    
717  ;;; Actions  ;;;;
718    
719  ;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)  ;;;; Parser functions for actions
 ;;; NAME is a string representing the action name,  
 ;;; FUNCTION is a corresponding function:  
 ;;;       (define (action-foo [arg [arg...]] . opt-args)  
 ;;; notice, that its name must begin with "action-"  
 ;;; OPT-ARG-LIST is a list of optional arguments (tags),  
 ;;; REQ-ARG-LIST is a list of required (positional) arguments  
 (define sieve-action-table '())  
   
 (define (sieve-find-action name)  
   (sieve-syntax-table-lookup sieve-action-table name))  
   
 (define (sieve-register-action name function req-arg-list opt-arg-list)  
   (cond  
    ((not (list? opt-arg-list))  
     (lex-error "sieve-register-action: opt-arg-list must be a list"))  
    ((not (list? req-arg-list))  
     (lex-error "sieve-register-action: req-arg-list must be a list"))  
    ((not (or (eq? function #f)  
              (eq? function #t)  
              (procedure? function)))  
     (lex-error "sieve-register-action: bad type for function" function))  
    (else  
     (set! sieve-action-table  
           (append sieve-action-table  
                   (list  
                    (list name function opt-arg-list req-arg-list)))))))  
720    
721  (define (sieve-parse-action)  (define (sieve-parse-action)
722    (let* ((name (cdr current-token))    (let* ((name (cdr current-token))
# Line 738  Line 734 
734       (else       (else
735        (syntax-error "Unknown identifier: " name)))))        (syntax-error "Unknown identifier: " name)))))
736    
737  ;;;; Parser  ;;;;
738    
739    ;;;; The parser
740    
741  (define (sieve-parse-command)  (define (sieve-parse-command)
742    (DEBUG 10 "sieve-parse-command" current-token)    (DEBUG 10 "sieve-parse-command" current-token)
# Line 829  Line 827 
827            (call-with-input-file filename sieve-parse-from-port))            (call-with-input-file filename sieve-parse-from-port))
828          (lambda args args))))          (lambda args args))))
829    
830    ;;;;
831    
832  ;;;; Code generator  ;;;; Code generator
833    
834  (define sieve-exp '())  ;; Expression currently being built  (define sieve-exp '())  ;; Expression currently being built
# Line 876  Line 876 
876    
877  ;;; Save the program  ;;; Save the program
878    
879  (define (sieve-save-program outfile)  (define (sieve-save-program outfile guimb-header)
880    (call-with-output-file    (call-with-output-file
881     outfile     outfile
882     (lambda (port)     (lambda (port)
883       (display "#! /home/gray/mailutils/guimb/guimb --source\n!#\n" port)       (display "#! " port)
884         (if guimb-header
885             (display "%BINDIR%/guimb -s\n" port)
886             (display "%GUILE_BINDIR%/guile -s\n" port))
887       (display (string-append       (display (string-append
888                 ";;;; A Guile mailbox parser made from " filename) port)                 "# Guile mailbox parser made from " filename) port)
889       (newline port)       (newline port)
890       (display ";;;; by sieve.scm, GNU %PACKAGE% %VERSION%" port)       (display "# by sieve.scm, GNU %PACKAGE% %VERSION%\n!#" port)
891       (newline port)       (newline port)
892            
893       (display "(define sieve-parser #f)" port)       (display "(define sieve-parser #f)" port)
# Line 892  Line 895 
895       (display (string-append       (display (string-append
896                 "(define sieve-source \"" filename "\")") port)                 "(define sieve-source \"" filename "\")") port)
897       (newline port)       (newline port)
898    
899         (display (string-append
900                   "(define sieve-libdir \"" sieve-libdir "\")") port)
901         (newline port)
902            
903       (display (string-append       (display (string-append
904                 "(load \"" sieve-libdir "/sieve-core.scm\")") port)                 "(load \"" sieve-libdir "/sieve-core.scm\")") port)
# Line 905  Line 912 
912       (sieve-code-print-list sieve-code-list port)       (sieve-code-print-list sieve-code-list port)
913       (newline port)       (newline port)
914       (display "(sieve-main)" port))))       (display "(sieve-main)" port))))
915        
916    ;;;;
917    
918  ;;;; Main  ;;;; Main
919    
920  (define filename #f)  (define filename #f)
921  (define output #f)  (define output #f)
922    (define guimb-header #f)
923    
924  (define (sieve-usage)  (define (sieve-usage)
925    (display "usage: sieve.scm [OPTIONS]\n")    (display "usage: sieve.scm [OPTIONS][mailbox]\n")
926    (display "GNU sieve.scm -- compile a Sieve program into Scheme code\n")    (display "GNU sieve.scm -- compile a Sieve program into Scheme code\n")
927    (display "Options are:\n")    (display "Options are:\n")
928    (display "   -f, --file FILENAME      Set input file name\n")    (display "   -f, --file FILENAME      Set input file name\n")
929    (display "   -o, --output FILENAME    Set output file name\n")    (display "   -o, --output FILENAME    Set output file name\n")
930    (display "   -L, --lib-dir DIRNAME    Set sieve library directory name\n")    (display "   -L, --lib-dir DIRNAME    Set sieve library directory name\n")
931    (display "   -d, --debug LEVEL        Set debugging level\n")    (display "   -g, --guimb              Make output file executable for guimb\n")
932      (display "   -d, --debug LEVEL        Set debugging level\n\n")
933      (display "If -o option is not given, the compiled program is executed\n")
934      (display "immediately. It operates on the user system mailbox unless\n")
935      (display "mailbox is given in the command line.\n")
936    (exit 0))    (exit 0))
937    
 (define (sieve-expand-filename name)  
   (let ((index (string-index name #\%)))  
     (if (or (not index) (= index (string-length name)))  
         name  
       (let ((ch (string-ref name (1+ index))))  
         (string-append  
          (make-shared-substring name 0 index)  
          (case ch  
            ((#\%)  
             "%")  
            ((#\u)  
             user-name)  
            ((#\h)  
             (passwd:dir (getpwnam user-name)))  
            (else  
             (make-shared-substring name index 2)))  
          (sieve-expand-filename  
           (make-shared-substring name (+ index 2))))))))  
   
938  ;;; Parse command line  ;;; Parse command line
939    
940  (use-modules (ice-9 getopt-long))  (use-modules (ice-9 getopt-long))
# Line 952  Line 947 
947              (value #t))              (value #t))
948      (lib-dir (single-char #\L)      (lib-dir (single-char #\L)
949               (value #t))               (value #t))
950        (guimb  (single-char #\g))
951      (help   (single-char #\h))))      (help   (single-char #\h))))
952    
953  (define program-name (car (command-line)))  (define program-name (car (command-line)))
# Line 969  Line 965 
965          (set! sieve-libdir (cdr x)))          (set! sieve-libdir (cdr x)))
966         ((output)         ((output)
967          (set! output (cdr x)))          (set! output (cdr x)))
968           ((guimb)
969            (set! guimb-header #t))
970         ((help)         ((help)
971          (sieve-usage))))))          (sieve-usage))
972           ('()
973            (set! sieve-script-args (cdr x)))))))
974   (getopt-long (command-line) grammar))   (getopt-long (command-line) grammar))
975    
976  (if (not filename)  (cond
977      (begin   ((not filename)
978       (display program-name)    (display program-name)
979       (display ": missing input filename")    (display ": missing input filename")
980       (newline)    (newline)
981       (sieve-usage)))    (sieve-usage))
982     ((not (file-exists? filename))
983  (define guimb? (catch #t    (display (string-append
984                        (lambda ()              program-name
985                          (let ((package mu-package))              ": Input file " filename " does not exist."))
986                            package))    (newline)
987                        (lambda args #f)))    (exit 0)))
   
 (if (and guimb? (string? user-name))  
     (set! filename (sieve-expand-filename filename)))  
   
 (if (not (file-exists? filename))  
     (begin  
       (display (string-append  
                 program-name  
                 ": Input file " filename " does not exist."))  
       (newline)  
       (exit 0)))  
988                    
989  (if (not sieve-libdir)  (if (not sieve-libdir)
990      (set! sieve-libdir      (set! sieve-libdir
# Line 1019  Line 1008 
1008    (newline)    (newline)
1009    (exit 1))    (exit 1))
1010   (output   (output
1011    (sieve-save-program output))    (sieve-save-program output guimb-header))
  ((not guimb?)  
   (display program-name)  
   (display ": Either use guimb to compile and execute the script")  
   (newline)  
   (display "or use --output option to save the Scheme program.")  
   (newline)  
   (exit 1))  
1012   (else   (else
1013    (let ((temp-file (tmpnam))    (let ((temp-file (tmpnam))
1014          (saved-umask (umask #o077)))          (saved-umask (umask #o077)))
1015      (sieve-save-program temp-file)      (sieve-save-program temp-file)
1016      (load temp-file)      (catch #t
1017               (lambda ()
1018                 (load temp-file))
1019               (lambda (key . args)
1020                 (apply display-error the-last-stack (current-error-port) args)))
1021      (delete-file temp-file)          (delete-file temp-file)    
1022      (umask saved-umask))))      (umask saved-umask))))
1023    
1024    ;;;; End of sieve.scm
1025    
1026    
1027    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26