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 |
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) |
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 |
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))) |
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)) |
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) |
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 |
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) |
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) |
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)) |
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))) |
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 |
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 |
|
|