summaryrefslogtreecommitdiff
path: root/guimb
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2002-10-14 17:47:46 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2002-10-14 17:47:46 +0000
commit53b92684a5ab835cbcf68296ecd4b0a2b8649cd5 (patch)
tree59d755984515f9b8781c1eaf895fab194068fafc /guimb
parentf6ff2719115f145de1fb1fa3c1133edd7450cf91 (diff)
downloadmailutils-53b92684a5ab835cbcf68296ecd4b0a2b8649cd5.tar.gz
mailutils-53b92684a5ab835cbcf68296ecd4b0a2b8649cd5.tar.bz2
Cleaned up the source.
Diffstat (limited to 'guimb')
-rw-r--r--guimb/scm/sieve.scm.in258
1 files changed, 122 insertions, 136 deletions
diff --git a/guimb/scm/sieve.scm.in b/guimb/scm/sieve.scm.in
index 9fc4be1af..226fc9ae5 100644
--- a/guimb/scm/sieve.scm.in
+++ b/guimb/scm/sieve.scm.in
@@ -1,4 +1,4 @@
-#! %BINDIR%/guimb --source
+#! %GUILE_BINDIR%/guile -s
# Emacs, its -*- scheme -*-
!#
;;;; GNU mailutils - a suite of utilities for electronic mail
@@ -21,19 +21,21 @@
;;;; This is a Sieve to Scheme translator.
;;;;
-;;;; To convert a sieve script into equivalent Scheme program, executable
-;;;; by guimb, run:
+;;;; To convert a sieve script into equivalent Scheme program, run:
;;;;
;;;; guile -s sieve.scm --file <sieve-script-name> --output <output-file-name>
;;;;
;;;; To compile and execute a sieve script upon a mailbox, run:
;;;;
-;;;; guimb -f sieve.scm -{ --file <sieve-script-name> -} --mailbox ~/mbox
+;;;; guile -s sieve.scm --file <sieve-script-name> [mailbox-name]
+;;;; or
+;;;; guimb [--mailbox mailbox-name] -s sieve.scm --file <sieve-script-name>
(define sieve-debug 0)
(define sieve-parser #t)
(define sieve-libdir "%LIBDIR%")
(define sieve-load-files '())
+(define sieve-script-args '())
(define error-count 0)
(define current-token #f)
@@ -373,66 +375,82 @@
current-token)
;;;;
+
+;;; Syntax tables.
+;;; A syntax table is a list of
+;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
+;;; NAME is a string representing the input language keyword,
+;;; FUNCTION is a corresponding function:
+;;; (define (foo [arg [arg...]] . opt-args)
+;;; OPT-ARG-LIST is a list of optional arguments (tags),
+;;; REQ-ARG-LIST is a list of required (positional) arguments
(define (sieve-syntax-table-lookup table name)
- (call-with-current-continuation
- (lambda (exit)
- (for-each (lambda (x)
- (if (string=? (car x) name)
- (exit (cdr x))))
- table)
- #f)))
+ (let ((entry (assoc name table)))
+ (if entry
+ (cdr entry)
+ #f)))
+
+(define-macro (sieve-syntax-table-add table name function req-arg-list opt-arg-list)
+ `(cond
+ ((not (list? ,opt-arg-list))
+ (lex-error "sieve-syntax-table-add: opt-arg-list must be a list"))
+ ((not (list? ,req-arg-list))
+ (lex-error "sieve-syntax-table-add: req-arg-list must be a list"))
+ ((not (or (eq? ,function #f)
+ (eq? ,function #t)
+ (procedure? ,function)))
+ (lex-error "sieve-syntax-table-add: bad type for function" ,function))
+ (else
+ (set! ,table
+ (append ,table
+ (list
+ (list ,name ,function ,opt-arg-list ,req-arg-list)))))))
+
+;;;;
+
+;;;; Available syntax tables.
;;;; Comparators
-;;; Each entry is (list COMP-NAME COMP-FUNCTION)
+;;; Syntax table for comparators. The opt-arg-list and req-arg-list have
+;;; no meaning for comparators, so they are ignored. The handler function
+;;; names must start with "comparator-"
(define sieve-comparator-table '())
(define (sieve-find-comparator name)
(sieve-syntax-table-lookup sieve-comparator-table name))
(define (sieve-register-comparator name function)
- (if (not (or (eq? function #f)
- (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)))))
-
+ (sieve-syntax-table-add sieve-comparator-table name function '() '()))
-;;;; Command parsers
+;;;; Sieve Tests
-;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
-;;; 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.
+;;; Syntax table for tests. Function names must start with "test-"
(define sieve-test-table '())
(define (sieve-find-test name)
(sieve-syntax-table-lookup sieve-test-table name))
-(define (sieve-register-test name function req-arg-list opt-arg-list)
- (DEBUG 100 "sieve-register-test" name req-arg-list opt-arg-list)
- (cond
- ((not (list? opt-arg-list))
- (lex-error "sieve-register-test: opt-arg-list must be a list"))
- ((not (list? req-arg-list))
- (lex-error "sieve-register-test: req-arg-list must be a list"))
- ((not (or (eq? function #f)
- (eq? function #t)
- (procedure? function)))
- (lex-error "sieve-register-test: bad type for function" function))
- (else
- (set! sieve-test-table
- (append sieve-test-table
- (list
- (list name function opt-arg-list req-arg-list)))))))
-
+(define (sieve-register-test name function req-arg-list opt-arg-list)
+ (sieve-syntax-table-add sieve-test-table name function
+ req-arg-list opt-arg-list))
+
+;;;; Sieve Actions
+
+;;; Syntax table for actions. Function names start with "action-"
+(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)
+ (sieve-syntax-table-add sieve-action-table name function
+ req-arg-list opt-arg-list))
+
+;;;;
+
+;;;; Command parsers
;;; sieve-preprocess-arguments: Preprocess and group the arguments. Returns
;;; a cons whose car is a list of all optional arguments, and the cdr is
@@ -555,6 +573,10 @@
(cdr tag)))))
(car arg-list))))
+;;;;
+
+;;;; Parser functions for tests
+
;;; test-list = "(" test *("," test) ")"
(define (sieve-parse-test-list)
(do ((token (sieve-parse-test) (sieve-parse-test)))
@@ -692,35 +714,9 @@
(sieve-exp-finish)
(require-semicolon))
-;;; Actions
-
-;;; Each entry is: (list NAME FUNCTION OPT-ARG-LIST REQ-ARG-LIST)
-;;; 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)))))))
+;;;;
+
+;;;; Parser functions for actions
(define (sieve-parse-action)
(let* ((name (cdr current-token))
@@ -738,7 +734,9 @@
(else
(syntax-error "Unknown identifier: " name)))))
-;;;; Parser
+;;;;
+
+;;;; The parser
(define (sieve-parse-command)
(DEBUG 10 "sieve-parse-command" current-token)
@@ -829,6 +827,8 @@
(call-with-input-file filename sieve-parse-from-port))
(lambda args args))))
+;;;;
+
;;;; Code generator
(define sieve-exp '()) ;; Expression currently being built
@@ -876,15 +876,18 @@
;;; Save the program
-(define (sieve-save-program outfile)
+(define (sieve-save-program outfile guimb-header)
(call-with-output-file
outfile
(lambda (port)
- (display "#! /home/gray/mailutils/guimb/guimb --source\n!#\n" port)
+ (display "#! " port)
+ (if guimb-header
+ (display "%BINDIR%/guimb -s\n" port)
+ (display "%GUILE_BINDIR%/guile -s\n" port))
(display (string-append
- ";;;; A Guile mailbox parser made from " filename) port)
+ "# Guile mailbox parser made from " filename) port)
(newline port)
- (display ";;;; by sieve.scm, GNU %PACKAGE% %VERSION%" port)
+ (display "# by sieve.scm, GNU %PACKAGE% %VERSION%\n!#" port)
(newline port)
(display "(define sieve-parser #f)" port)
@@ -892,6 +895,10 @@
(display (string-append
"(define sieve-source \"" filename "\")") port)
(newline port)
+
+ (display (string-append
+ "(define sieve-libdir \"" sieve-libdir "\")") port)
+ (newline port)
(display (string-append
"(load \"" sieve-libdir "/sieve-core.scm\")") port)
@@ -905,41 +912,29 @@
(sieve-code-print-list sieve-code-list port)
(newline port)
(display "(sieve-main)" port))))
-
+
+;;;;
+
;;;; Main
(define filename #f)
(define output #f)
+(define guimb-header #f)
(define (sieve-usage)
- (display "usage: sieve.scm [OPTIONS]\n")
+ (display "usage: sieve.scm [OPTIONS][mailbox]\n")
(display "GNU sieve.scm -- compile a Sieve program into Scheme code\n")
(display "Options are:\n")
(display " -f, --file FILENAME Set input file name\n")
(display " -o, --output FILENAME Set output file name\n")
(display " -L, --lib-dir DIRNAME Set sieve library directory name\n")
- (display " -d, --debug LEVEL Set debugging level\n")
+ (display " -g, --guimb Make output file executable for guimb\n")
+ (display " -d, --debug LEVEL Set debugging level\n\n")
+ (display "If -o option is not given, the compiled program is executed\n")
+ (display "immediately. It operates on the user system mailbox unless\n")
+ (display "mailbox is given in the command line.\n")
(exit 0))
-(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))))))))
-
;;; Parse command line
(use-modules (ice-9 getopt-long))
@@ -952,6 +947,7 @@
(value #t))
(lib-dir (single-char #\L)
(value #t))
+ (guimb (single-char #\g))
(help (single-char #\h))))
(define program-name (car (command-line)))
@@ -969,33 +965,26 @@
(set! sieve-libdir (cdr x)))
((output)
(set! output (cdr x)))
+ ((guimb)
+ (set! guimb-header #t))
((help)
- (sieve-usage))))))
+ (sieve-usage))
+ ('()
+ (set! sieve-script-args (cdr x)))))))
(getopt-long (command-line) grammar))
-(if (not filename)
- (begin
- (display program-name)
- (display ": missing input filename")
- (newline)
- (sieve-usage)))
-
-(define guimb? (catch #t
- (lambda ()
- (let ((package mu-package))
- package))
- (lambda args #f)))
-
-(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)))
+(cond
+ ((not filename)
+ (display program-name)
+ (display ": missing input filename")
+ (newline)
+ (sieve-usage))
+ ((not (file-exists? filename))
+ (display (string-append
+ program-name
+ ": Input file " filename " does not exist."))
+ (newline)
+ (exit 0)))
(if (not sieve-libdir)
(set! sieve-libdir
@@ -1019,23 +1008,20 @@
(newline)
(exit 1))
(output
- (sieve-save-program output))
- ((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))
+ (sieve-save-program output guimb-header))
(else
(let ((temp-file (tmpnam))
(saved-umask (umask #o077)))
(sieve-save-program temp-file)
- (load temp-file)
+ (catch #t
+ (lambda ()
+ (load temp-file))
+ (lambda (key . args)
+ (apply display-error the-last-stack (current-error-port) args)))
(delete-file temp-file)
(umask saved-umask))))
-
+;;;; End of sieve.scm

Return to:

Send suggestions and report system problems to the System administrator.