Rewrite as module. Change

initialization of the syntax tables.
(handle-exception,sieve-verbose-print): New macro
(action-fileinto,action-keep,action-stop,action-discard): Produce
verbose diagnostics if required.
(sieve-run): Take thunk as an argument. Report implicit keep if it
returns #t and the verbose mode is on.
(sieve-main): Take thunk as an argument.

@@ -17,23 +17,66 @@
 
 
 ;;;; This module provides core functionality for the sieve scripts.
 ;;;; This module provides core functionality for the sieve scripts.
 
 
-(set! %load-path (append %load-path (list sieve-libdir)))
-(use-modules (mailutils))
+(define-module (mailutils sieve-core))
+
+(use-modules (mailutils mailutils))
+
+;;; Set to #t when parsing 
+(define-public sieve-parser #f)
+
+;;; Name of the input source
+(define-public sieve-source "UNKNOWN")
 
 
 ;;; The email address for originator of error messages. Should be <>
 ;;; The email address for originator of error messages. Should be <>
 ;;; but current mailutils API is unable to parse and handle it.
 ;;; but current mailutils API is unable to parse and handle it.
 ;;; Site administrators are supposed to replace it with the
 ;;; Site administrators are supposed to replace it with the
 ;;; actual value.
 ;;; actual value.
-(define sieve-daemon-email "MAILER-DAEMON@localhost")
+(define-public sieve-daemon-email "MAILER-DAEMON@localhost")
 
 
 ;;; The email address of the user whose mailbox is being processed.
 ;;; The email address of the user whose mailbox is being processed.
 ;;; If #f, it will be set by sieve-main
 ;;; If #f, it will be set by sieve-main
-(define sieve-my-email #f)
+(define-public sieve-my-email #f)
 
 
 (define SIEVE-WARNING "Warning")
 (define SIEVE-WARNING "Warning")
 (define SIEVE-ERROR "Error")
 (define SIEVE-ERROR "Error")
 (define SIEVE-NOTICE "Notice")
 (define SIEVE-NOTICE "Notice")
 
 
+(defmacro handle-exception (. expr)
+  `(catch 'mailutils-error
+	  (lambda () ,@expr)
+	  (lambda (key . args)
+	    (runtime-message SIEVE-ERROR
+			     "In function " (car args) ": "
+			     (apply format #f
+				    (list-ref args 1) (list-ref args 2))
+			     (let ((error-code
+				    (car (list-ref args (1- (length args))))))
+			       (if (= error-code 0)
+				   ""
+				   (string-append
+				    "; Error code: "
+				    (number->string error-code)
+				    " - "
+				    (mu-strerror error-code))))))))
+
+;;; Set to #t if verbose action listing is requested
+(define-public sieve-verbose #f)
+
+(defmacro sieve-verbose-print (action . rest)
+  `(if sieve-verbose
+       (let ((uid (false-if-exception
+		   (mu-message-get-uid sieve-current-message))))
+	 (display ,action)
+	 (display " on msg uid ")
+	 (display uid)
+	 (let ((args (list ,@rest)))
+	   (cond ((not (null? args))
+		  (display ": ")
+		  (for-each
+		   display
+		   args))))
+	 (newline))))
+
 ;;; List of open mailboxes.
 ;;; List of open mailboxes.
 ;;; Each entry is: (list MAILBOX-NAME OPEN-FLAGS MBOX)
 ;;; Each entry is: (list MAILBOX-NAME OPEN-FLAGS MBOX)
 (define sieve-mailbox-list '())
 (define sieve-mailbox-list '())
@@ -46,7 +89,7 @@
   (let ((slot (assoc name sieve-mailbox-list)))
   (let ((slot (assoc name sieve-mailbox-list)))
     (if slot
     (if slot
 	(list-ref slot 2)
 	(list-ref slot 2)
-      (let ((mbox (mu-mailbox-open name flags)))
+      (let ((mbox (false-if-exception (mu-mailbox-open name flags))))
 	(if mbox
 	(if mbox
 	    (set! sieve-mailbox-list (append
 	    (set! sieve-mailbox-list (append
 				      sieve-mailbox-list
 				      sieve-mailbox-list
@@ -78,14 +121,14 @@
 	    filename)))))
 	    filename)))))
 
 
 ;;; Comparators
 ;;; Comparators
-(cond
- (sieve-parser
-  (sieve-register-comparator "i;octet" string=?)
-  (sieve-register-comparator "i;ascii-casemap" string-ci=?)))
+(define-public sieve-standard-comparators 
+  (list (list "i;octet" string=?)
+	(list "i;ascii-casemap" string-ci=?)))
 
 
 ;;; Stop statement
 ;;; Stop statement
 
 
-(define (sieve-stop)
+(define-public (sieve-stop)
+  (sieve-verbose-print "STOP")
   (throw 'sieve-stop))
   (throw 'sieve-stop))
 
 
 ;;; Basic five actions:
 ;;; Basic five actions:
@@ -94,14 +137,16 @@
 
 
 ;;; fileinto
 ;;; fileinto
 
 
-(define (action-fileinto filename)
+(define-public (action-fileinto filename)
   (let ((name (sieve-expand-filename filename)))
   (let ((name (sieve-expand-filename filename)))
+    (sieve-verbose-print "FILEINTO" "delivering into " name)
     (if (string? name)
     (if (string? name)
 	(let ((outbox (sieve-mailbox-open name "cw")))
 	(let ((outbox (sieve-mailbox-open name "cw")))
 	  (cond
 	  (cond
 	   (outbox
 	   (outbox
+	    (handle-exception
 	     (mu-mailbox-append-message outbox sieve-current-message)
 	     (mu-mailbox-append-message outbox sieve-current-message)
-	    (mu-message-delete sieve-current-message))
+	     (mu-message-delete sieve-current-message)))
 	   (else
 	   (else
 	    (runtime-message SIEVE-ERROR
 	    (runtime-message SIEVE-ERROR
 			     "Could not open mailbox " name))))
 			     "Could not open mailbox " name))))
@@ -112,20 +157,23 @@
 
 
 ;;; keep -- does nothing worth mentioning :^)
 ;;; keep -- does nothing worth mentioning :^)
 
 
-(define (action-keep)
-  (mu-message-delete sieve-current-message #f))
+(define-public (action-keep)
+  (sieve-verbose-print "KEEP")
+  (handle-exception
+   (mu-message-delete sieve-current-message #f)))
 
 
 ;;; discard
 ;;; discard
 
 
-(define (action-discard)
-  (mu-message-delete sieve-current-message))
+(define-public (action-discard)
+  (sieve-verbose-print "DISCARD" "marking as deleted")
+  (handle-exception
+   (mu-message-delete sieve-current-message)))
 
 
 ;;; Register standard actions
 ;;; Register standard actions
-(cond
- (sieve-parser
-  (sieve-register-action "keep" action-keep '() '())
-  (sieve-register-action "discard" action-discard '() '())
-  (sieve-register-action "fileinto" action-fileinto (list 'string) '())))
+(define-public sieve-standard-actions
+  (list (list "keep" action-keep '() '())
+	(list "discard" action-discard '() '())
+	(list "fileinto" action-fileinto (list 'string) '())))
 
 
 ;;; Some utilities.
 ;;; Some utilities.
 
 
@@ -225,7 +273,7 @@
 
 
 ;;;; Standard tests:
 ;;;; Standard tests:
 
 
-(define (test-address header-list key-list . opt-args)
+(define-public (test-address header-list key-list . opt-args)
   (let ((comp (find-comp opt-args))
   (let ((comp (find-comp opt-args))
 	(match (find-match opt-args))
 	(match (find-match opt-args))
 	(part (cond
 	(part (cond
@@ -275,7 +323,7 @@
 	key-list)
 	key-list)
        #f))))
        #f))))
 
 
-(define (test-size key-size . comp)
+(define-public (test-size key-size . comp)
   (let ((size (mu-message-get-size sieve-current-message)))
   (let ((size (mu-message-get-size sieve-current-message)))
     (cond
     (cond
      ((null? comp)       ;; An extension.
      ((null? comp)       ;; An extension.
@@ -287,7 +335,7 @@
      (else
      (else
       (runtime-message SIEVE-ERROR  "test-size: unknown comparator " comp)))))
       (runtime-message SIEVE-ERROR  "test-size: unknown comparator " comp)))))
 
 
-(define (test-envelope part-list key-list . opt-args)
+(define-public (test-envelope part-list key-list . opt-args)
   (let ((comp (find-comp opt-args))
   (let ((comp (find-comp opt-args))
 	(match (find-match opt-args)))
 	(match (find-match opt-args)))
     (call-with-current-continuation
     (call-with-current-continuation
@@ -309,7 +357,7 @@
 	part-list)
 	part-list)
        #f))))
        #f))))
 
 
-(define (test-exists header-list)
+(define-public (test-exists header-list)
   (call-with-current-continuation
   (call-with-current-continuation
    (lambda (exit)
    (lambda (exit)
      (for-each (lambda (hdr)
      (for-each (lambda (hdr)
@@ -319,7 +367,7 @@
 	       header-list)
 	       header-list)
      #t)))
      #t)))
 
 
-(define (test-header header-list key-list . opt-args)
+(define-public (test-header header-list key-list . opt-args)
   (let ((comp (find-comp opt-args))
   (let ((comp (find-comp opt-args))
 	(match (find-match opt-args)))
 	(match (find-match opt-args)))
     (call-with-current-continuation
     (call-with-current-continuation
@@ -360,45 +408,46 @@
 			   (cons "over" #f)))
 			   (cons "over" #f)))
 (define comparator   (list (cons "comparator" 'string)))
 (define comparator   (list (cons "comparator" 'string)))
 
 
-(cond
- (sieve-parser
-  (sieve-register-test "address"
+(define-public sieve-standard-tests
+  (list
+   (list "address"
 	 test-address
 	 test-address
 	 (list 'string-list 'string-list)
 	 (list 'string-list 'string-list)
 	 (append address-part comparator match-type))
 	 (append address-part comparator match-type))
-  (sieve-register-test "size"
+   (list "size"
 	 test-size
 	 test-size
 	 (list 'number)
 	 (list 'number)
 	 size-comp)
 	 size-comp)
-  (sieve-register-test "envelope"
+   (list "envelope"
 	 test-envelope
 	 test-envelope
 	 (list 'string-list 'string-list)
 	 (list 'string-list 'string-list)
 	 (append comparator address-part match-type))
 	 (append comparator address-part match-type))
-  (sieve-register-test "exists"
+   (list "exists"
 	 test-exists
 	 test-exists
 	 (list 'string-list) 
 	 (list 'string-list) 
 	 '())
 	 '())
-  (sieve-register-test "header"
+   (list "header"
 	 test-header
 	 test-header
 	 (list 'string-list 'string-list)
 	 (list 'string-list 'string-list)
 	 (append comparator match-type))
 	 (append comparator match-type))
-  (sieve-register-test "false" #f '() '())
-  (sieve-register-test "true"  #t '() '())))
+   (list "false" #f '() '())
+   (list "true"  #t '() '())))
 
 
 ;;; runtime-message
 ;;; runtime-message
 
 
-(define (runtime-message level . text)
+(define-public (runtime-message level . text)
   (let ((msg (apply string-append
   (let ((msg (apply string-append
 		    (map (lambda (x)
 		    (map (lambda (x)
 			   (format #f "~A" x))
 			   (format #f "~A" x))
 			 (append
 			 (append
 			  (list "(in " sieve-source ") ")
 			  (list "(in " sieve-source ") ")
 			  text)))))
 			  text)))))
+    (if sieve-current-message
 	(mu-message-set-header sieve-current-message
 	(mu-message-set-header sieve-current-message
 			       (string-append "X-Sieve-" level)
 			       (string-append "X-Sieve-" level)
-			   msg)
-       (if (isatty? (current-output-port))
-	   (display (string-append level ": " msg "\n")))))
+			       msg))
+    (if (isatty? (current-error-port))
+	(display (string-append level ": " msg "\n") (current-error-port)))))
 
 
 (define (guimb?)
 (define (guimb?)
   (catch #t
   (catch #t
@@ -411,7 +460,7 @@
 (define sieve-mailbox #f)
 (define sieve-mailbox #f)
 (define sieve-current-message #f)
 (define sieve-current-message #f)
 
 
-(define (sieve-run)
+(define (sieve-run thunk)
   (if (not sieve-my-email)
   (if (not sieve-my-email)
       (set! sieve-my-email (mu-username->email)))
       (set! sieve-my-email (mu-username->email)))
 ;  (DEBUG 1 "Mailbox: " sieve-mailbox)
 ;  (DEBUG 1 "Mailbox: " sieve-mailbox)
@@ -421,10 +470,11 @@
 	((> n count) #f)
 	((> n count) #f)
 	(set! sieve-current-message
 	(set! sieve-current-message
 	      (mu-mailbox-get-message sieve-mailbox n))
 	      (mu-mailbox-get-message sieve-mailbox n))
-	(catch 'sieve-stop
-	       sieve-process-message
+	(and (catch 'sieve-stop
+		    thunk
 		    (lambda args
 		    (lambda args
-		 #f)))
+		      #f))
+	     (sieve-verbose-print "IMPLICIT KEEP")))
     (sieve-close-mailboxes)))
     (sieve-close-mailboxes)))
 
 
 (define (sieve-command-line)
 (define (sieve-command-line)
@@ -434,7 +484,8 @@
 	     (append (list "<temp-file>") args)))
 	     (append (list "<temp-file>") args)))
 	 (lambda args (command-line))))
 	 (lambda args (command-line))))
 
 
-(define (sieve-main)
+(define-public (sieve-main thunk) 
+  (handle-exception
    (cond
    (cond
     ((not (guimb?))
     ((not (guimb?))
      (let* ((cl (sieve-command-line))
      (let* ((cl (sieve-command-line))
@@ -443,13 +494,12 @@
 		      (cadr cl)
 		      (cadr cl)
 		      (string-append (mu-mail-directory) "/"
 		      (string-append (mu-mail-directory) "/"
 				     (passwd:name (mu-getpwuid (getuid)))))))
 				     (passwd:name (mu-getpwuid (getuid)))))))
-;      (DEBUG 2 "mailbox name " name)
+
        (set! sieve-mailbox (mu-mailbox-open name "rw"))
        (set! sieve-mailbox (mu-mailbox-open name "rw"))
-      (sieve-run)
+       (sieve-run thunk)
        (mu-mailbox-expunge sieve-mailbox)
        (mu-mailbox-expunge sieve-mailbox)
        (mu-mailbox-close sieve-mailbox)))
        (mu-mailbox-close sieve-mailbox)))
     (else
     (else
-;    (DEBUG 1 "Using current-mailbox")
      (set! sieve-mailbox current-mailbox)
      (set! sieve-mailbox current-mailbox)
-    (sieve-run))))
+     (sieve-run thunk)))))