Skip to content

John McEleney / mailutils

Go to a project
Toggle navigation
Toggle navigation pinning
Commit 53b92684 53b92684a5ab835cbcf68296ecd4b0a2b8649cd5 by Sergey Poznyakoff
Options

Cleaned up the source.

1 parent f6ff2719
Inline Side-by-side
Showing 1 changed file with 109 additions and 123 deletions
#! %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)
......@@ -374,65 +376,81 @@
;;;;
;;; 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)
(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 '() '()))
;;;; Sieve Tests
;;;; Command parsers
;;; 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)))))))
(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)
......@@ -894,6 +897,10 @@
(newline port)
(display (string-append
"(define sieve-libdir \"" sieve-libdir "\")") port)
(newline port)
(display (string-append
"(load \"" sieve-libdir "/sieve-core.scm\")") port)
(newline port)
(for-each
......@@ -906,40 +913,28 @@
(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,28 +965,21 @@
(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
(cond
((not filename)
(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
(sieve-usage))
((not (file-exists? filename))
(display (string-append
program-name
": Input file " filename " does not exist."))
......@@ -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
......