Remove the Scheme implementation of the Sieve language.

* NEWS: Describe the change.
* doc/texinfo/mailutils.texi: Remove description of sieve2scm
* doc/texinfo/programs.texi: Likewise.
* scheme/Makefile.am: Remove sieve2scm.
* scheme/mimeheader.scm: Remove.
* scheme/numaddr.scm: Remove.
* scheme/redirect.scm: Remove.
* scheme/reject.scm: Remove.
* scheme/sieve-core.scm: Remove.
* scheme/sieve2scm.scmi: Remove.
* scheme/vacation.scm: Remove.

-GNU mailutils NEWS -- history of user-visible changes. 2017-04-08
+GNU mailutils NEWS -- history of user-visible changes. 2017-04-09
 Copyright (C) 2002-2017 Free Software Foundation, Inc.
 Copyright (C) 2002-2017 Free Software Foundation, Inc.
 See the end of file for copying conditions.
 See the end of file for copying conditions.
 
 
@@ -88,6 +88,15 @@ defined.  Instead, the following constants are defined in config.h:
 
 
 * movemail: new option --progress-meter
 * movemail: new option --progress-meter
 
 
+* scheme implementation of the Sieve language discontinued
+
+There's no reason to keep two different implementations of the Sieve
+language within the same package.  The principal implementation
+(libmu_sieve) is faster, much more advanced and rich in features than
+the implementation in Scheme.  The decision has therefore been taken to
+discontinue the latter and to concentrate all efforts on the further
+development of the former.
+
 
 
 Version 3.2 - 2017-03-11
 Version 3.2 - 2017-03-11
 
 

@@ -257,7 +257,6 @@ Reading Mail
 @command{sieve}
 @command{sieve}
 
 
 * sieve interpreter::   A Sieve Interpreter
 * sieve interpreter::   A Sieve Interpreter
-* sieve2scm::           A Sieve to Scheme Translator and Filter
 
 
 A Sieve Interpreter
 A Sieve Interpreter
 
 

@@ -5902,14 +5902,11 @@ only the first.
 @UNREVISED
 @UNREVISED
 
 
 Sieve is a language for filtering e-mail messages at time of final
 Sieve is a language for filtering e-mail messages at time of final
-delivery, described in RFC 3028.  GNU Mailutils provides two
-implementations of this language: a stand-alone @dfn{sieve interpreter}
-and a @dfn{sieve translator and filter}.  The following sections describe these
-utilities in detail.
+delivery, described in RFC 3028.  GNU Mailutils contains
+stand-alone @dfn{sieve interpreter}, which is described in detail below.
 
 
 @menu
 @menu
 * sieve interpreter::   A Sieve Interpreter
 * sieve interpreter::   A Sieve Interpreter
-* sieve2scm::           A Sieve to Scheme Translator and Filter
 @end menu
 @end menu
 
 
 @node sieve interpreter
 @node sieve interpreter
@@ -6250,41 +6247,6 @@ source for the required action NAME is not available
 @end enumerate
 @end enumerate
  
  
 @c ***********************************************************************
 @c ***********************************************************************
-
-@page
-@node sieve2scm
-@subsection A Sieve to Scheme Translator and Filter
-@UNREVISED
-
-A Sieve to Scheme Translator @command{sieve2scm} translates a given
-Sieve script into an equivalent Scheme program and optionally executes
-it.  The program itself is written in Scheme and requires presence of
-Guile version 1.8 or newer on the system.  For more information on
-Guile refer to @ref{Top,,Overview,guile,The Guile Reference Manual}.
-
-@table @option
-@item -f @var{filename}
-@itemx --file @var{filename}
-Set input file name.
-
-@item -o @var{filename}
-@itemx --output @var{filename}
-Set output file name
-
-@item -L @var{dirname}
-@itemx --lib-dir @var{dirname}
-Set sieve library directory name
-
-@item -d @var{level}
-@itemx --debug @var{level}
-Set debugging level
-@end table            
-
-The Scheme programs produced by @command{sieve2scm} can be used with
-@command{guimb} or @command{maidag}.
-
-@c ***********************************************************************
-
 @page
 @page
 @node guimb
 @node guimb
 @section @command{guimb} --- A Mailbox Scanning and Processing Language
 @section @command{guimb} --- A Mailbox Scanning and Processing Language

@@ -15,19 +15,7 @@
 ## You should have received a copy of the GNU General Public License
 ## You should have received a copy of the GNU General Public License
 ## along with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>. 
 ## along with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>. 
 
 
-bin_SCRIPTS = sieve2scm guimb
-
-# FIXME: Sieve2scm is temporarly exempted from installchecks because
-# it may fail starting during checks, if libguile-mailutils-v- library
-# has not been previously installed. The proper fix would be to alter
-# %load-path during tests.
-AM_INSTALLCHECK_STD_OPTIONS_EXEMPT=sieve2scm
-
-sievemoddir=@MU_GUILE_SIEVE_MOD_DIR@
-
-sieve2scm: sieve2scm.scmi package.sed
-	$(AM_V_GEN)sed -f package.sed $(srcdir)/sieve2scm.scmi > sieve2scm
-	$(AM_V_at)chmod +w sieve2scm
+bin_SCRIPTS = guimb
 
 
 guimb: guimb.scmi package.sed
 guimb: guimb.scmi package.sed
 	$(AM_V_GEN)sed -f package.sed $(srcdir)/guimb.scmi > guimb
 	$(AM_V_GEN)sed -f package.sed $(srcdir)/guimb.scmi > guimb
@@ -37,26 +25,12 @@ package.sed: Makefile
 	$(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > package.sed
 	$(AM_V_GEN)echo 's,%GUILE_BINDIR%,@GUILE_BINDIR@,g' > package.sed
 	$(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> package.sed
 	$(AM_V_at)echo 's,%BINDIR%,$(bindir),g' >> package.sed
 	$(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> package.sed
 	$(AM_V_at)echo 's,%GUILE_SITE%,$(GUILE_SITE),g' >> package.sed
-	$(AM_V_at)echo 's,%LIBDIR%,$(sievemoddir),g' >> package.sed
 	$(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> package.sed
 	$(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),g' >> package.sed
 	$(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> package.sed
 	$(AM_V_at)echo 's,%VERSION%,$(VERSION),g' >> package.sed
 
 
-CLEANFILES = sieve2scm guimb package.sed
-
-sitedir=@GUILE_SITE@/$(PACKAGE)
-site_DATA=sieve-core.scm
-
-sievemod_DATA=\
- mimeheader.scm\
- numaddr.scm\
- redirect.scm\
- reject.scm\
- vacation.scm
+CLEANFILES = guimb package.sed
 
 
 EXTRA_DIST=\
 EXTRA_DIST=\
- $(sievemod_DATA)\
- sieve-core.scm\
- sieve2scm.scmi\
  guimb.scmi
  guimb.scmi
 
 
 installcheck-binSCRIPTS: $(bin_SCRIPTS)
 installcheck-binSCRIPTS: $(bin_SCRIPTS)

-;;;; GNU Mailutils -- a suite of utilities for electronic mail
-;;;; Copyright (C) 1999-2001, 2007, 2010-2012, 2014-2017 Free Software
-;;;; Foundation, Inc.
-;;;;
-;;;; GNU Mailutils is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 3, or (at your option)
-;;;; any later version.
-;;;; 
-;;;; GNU Mailutils is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU General Public License along
-;;;; with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>.
-
-;;;; This module provides GNU extension test "mimeheader".
-
-;;;; Syntax:   mimeheader [COMPARATOR] [MATCH-TYPE]
-;;;;           <header-names: string-list> <key-list: string-list>
-;;;;
-;;;; The "mimeheader" test evaluates to true if in any part of the
-;;;; multipart MIME message a header name from <header-names> list
-;;;; matches any key from <key-list>. If the message is not multipart,
-;;;; "mimeheader" test is equivalent to "header" test.
-;;;;
-;;;; The arguments to "mimeheader" test are the same as to "header" test.
-
-;;;; Example:
-;;;;
-;;;; require [ "mimeheader", "reject"];
-;;;; if mimeheader :matches "Content-Type" "*application/msword;*" {
-;;;;     reject "Please do not send data in a proprietary format.";
-;;;; }
-
-(define (test-mimeheader header-list key-list . opt-args)
-  (if (mu-message-multipart? sieve-current-message)
-      (let ((mime-count (mu-message-get-num-parts sieve-current-message))
-	    (comp (find-comp opt-args))
-	    (match (find-match opt-args)))
-	(call-with-current-continuation
-	 (lambda (exit)
-	   (do ((n 1 (1+ n)))
-	       ((> n mime-count) #f)
-	     (let ((msg (mu-message-get-part sieve-current-message n)))
-	       (if msg
-		   (for-each
-		    (lambda (key)
-		      (let ((header-fields (mu-message-get-header-fields
-					    msg
-					    header-list))
-			    (rx (if (eq? match #:matches)
-				    (make-regexp (sieve-regexp-to-posix key)
-						 (if (eq? comp string-ci=?)
-						     regexp/icase
-						     '()))
-				    #f)))
-			(for-each
-			 (lambda (h)
-			   (let ((hdr (cdr h)))
-			     (if hdr
-				 (case match
-				   ((#:is)
-				    (if (comp hdr key)
-					(exit #t)))
-				   ((#:contains)
-				    (if (sieve-str-str hdr key comp)
-					(exit #t)))
-				   ((#:matches)
-				    (if (regexp-exec rx hdr)
-					(exit #t)))))))
-			 header-fields)))
-		    key-list)
-		   #f))))))
-      (apply test-header header-list key-list opt-args)))
-
-;;; Register the test at compile time
-(if sieve-parser
-    (sieve-register-test "mimeheader"
-			 test-mimeheader
-			 (list 'string-list 'string-list)
-			 (append comparator match-type)))

-;;;; GNU Mailutils -- a suite of utilities for electronic mail
-;;;; Copyright (C) 1999-2001, 2007, 2010-2012, 2014-2017 Free Software
-;;;; Foundation, Inc.
-;;;;
-;;;; GNU Mailutils is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 3, or (at your option)
-;;;; any later version.
-;;;; 
-;;;; GNU Mailutils is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU General Public License along
-;;;; with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>. 
-
-;;;; This module provides GNU extension test "numaddr".
-
-;;;; Syntax:   numaddr [":over" / ":under"] <header-names: string-list>
-;;;;           <limit: number>
-;;;; The "numaddr" test counts Internet addresses in structured headers
-;;;; that contain addresses.  It returns true if the total number of
-;;;; addresses satisfies the requested relation:
-;;;;
-;;;; If the argument is ":over" and the number of addresses is greater than
-;;;; the number provided, the test is true; otherwise, it is false.
-;;;;
-;;;; If the argument is ":under" and the number of addresses is less than
-;;;; the number provided, the test is true; otherwise, it is false.
-;;;;
-;;;; If the argument is empty, ":over" is assumed.
-
-;;;; Example:
-;;;;
-;;;; require [ "numaddr" ];
-;;;; if numaddr :over [ "To", "Cc" ] 50 { discard; }
-
-(define (test-numaddr header-list count . comp)
-  (let ((total-count 0)
-	(header-fields (mu-message-get-header-fields
-			sieve-current-message
-			header-list))
-	(compfun (cond
-		  ((or (null? (car comp)) (eq? (car comp) #:over))
-		   (lambda (val lim)
-		     (> val lim)))
-		  ((eq? (car comp) #:under)
-		   (lambda (val lim)
-		     (< val lim)))
-		  (else
-		   (runtime-message SIEVE-ERROR
-                                  "test-numaddr: unknown comparator "
-				  comp)))))
-    (call-with-current-continuation
-     (lambda (exit)
-       (for-each
-	(lambda (h)
-	  (let ((hdr (cdr h)))
-	    (if hdr
-		(let ((naddr (mu-address-get-count hdr)))
-		  (set! total-count (+ total-count naddr))
-		  (if (compfun total-count count)
-		      (exit #t))))))
-	header-fields)
-       #f))))
-
-;;; Register the test at compile time
-(if sieve-parser
-    (sieve-register-test "numaddr"
-			 test-numaddr
-			 (list 'string-list 'number)
-			 size-comp))

-;;;; GNU Mailutils -- a suite of utilities for electronic mail
-;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
-;;;; Software Foundation, Inc.
-;;;;
-;;;; GNU Mailutils is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 3, or (at your option)
-;;;; any later version.
-;;;; 
-;;;; GNU Mailutils is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU General Public License along
-;;;; with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>.
-
-;;;; This module provides sieve's "redirect" action.
-
-;;; rfc3028 says: 
-;;; "Implementations SHOULD take measures to implement loop control,"
-;;; We do this by appending an "X-Sender" header to each message
-;;; being redirected. If one of the "X-Sender" headers of the message
-;;; contains our email address, we assume it is a loop and bail out.
-
-(define (sent-from-me? msg)
-  (call-with-current-continuation
-   (lambda (exit)
-     (for-each
-      (lambda (hdr)
-	(if (and (string-ci=? (car hdr) "X-Sender")
-		 (string-ci=? (mu-address-get-email (cdr hdr))
-			   sieve-my-email))
-	    (exit #t))) 
-      (mu-message-get-header-fields sieve-current-message))
-     #f)))
-
-;;; redirect action
-(define (action-redirect address)
-  (sieve-verbose-print "REDIRECT" "to address " address)
-  (handle-exception
-   (if sieve-my-email
-       (cond
-	((sent-from-me? sieve-current-message)
-	 (runtime-message SIEVE-WARNING "Redirection loop detected"))
-	(else
-	 (let ((out-msg (mu-message-copy sieve-current-message))
-	       (sender (mu-message-get-sender sieve-current-message)))
-	   (mu-message-set-header out-msg "X-Sender" sieve-my-email)
-	   (mu-message-send out-msg #f sender address)
-	   (mu-message-destroy out-msg))
-	 (mu-message-delete sieve-current-message))))))
-
-;;; Register action
-(if sieve-parser
-    (sieve-register-action "redirect" action-redirect (list 'string) '()))
-
-
-

-;;;; GNU Mailutils -- a suite of utilities for electronic mail
-;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
-;;;; Software Foundation, Inc.
-;;;;
-;;;; GNU Mailutils is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 3, or (at your option)
-;;;; any later version.
-;;;; 
-;;;; GNU Mailutils is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU General Public License along
-;;;; with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>.
-
-;;;; This module provides sieve's "reject" action.
-
-(define sieve-option-quote #t)
-
-(define (action-reject reason)
-  (sieve-verbose-print "REJECT")
-  (handle-exception
-   (let ((mime (mu-mime-create 0))
-	 (datestr (strftime "%a, %b %d %H:%M:%S %Y %Z"
-			    (localtime (current-time))))
-	 (sender (mu-message-get-sender sieve-current-message)))
-     (let* ((mesg (mu-message-create))
-	    (port (mu-message-get-port mesg "w")))
-       
-       (display "The original message was received at " port)
-       (display datestr port)
-       (newline port)
-       (display "from " port)
-       (display sender port)
-       (display ".\n" port)
-       
-       (display "Message was refused by recipient's mail filtering program.\n"
-		port)
-       (display "Reason given was as follows:\n" port)
-       (newline port)
-       (display reason port)
-
-       (close-output-port port)
-       (mu-mime-add-part mime mesg))
-
-     ;; message/delivery-status
-     (let* ((mesg (mu-message-create))
-	    (port (mu-message-get-port mesg "w")))
-       (mu-message-set-header mesg "Content-Type" "message/delivery-status")
-       
-       (display (string-append "Reporting-UA: sieve; "
-			       mu-package-string "\n") port)
-       (display (string-append "Arrival-Date: " datestr "\n") port)
-       (newline port)
-       
-       (display (string-append "Final-Recipient: RFC822; " sieve-my-email "\n")
-		port)
-       
-       (display "Action: deleted\n" port);
-       (display "Disposition: automatic-action/MDN-sent-automatically;deleted\n"
-		port)
-       (display (string-append
-		 "Last-Attempt-Date: " datestr "\n") port)
-       
-       (close-output-port port)
-       (mu-mime-add-part mime mesg))
-     
-     ;; Quote original message
-     (let* ((mesg (mu-message-create))
-	    (port (mu-message-get-port mesg "w"))
-	    (in-port (mu-message-get-port sieve-current-message "r" #t)))
-       (mu-message-set-header mesg "Content-Type" "message/rfc822")
-       
-       (do ((line (read-line in-port) (read-line in-port)))
-	   ((eof-object? line) #f)
-	 (display line port)
-	 (newline port))
-       
-       (close-input-port in-port)
-       (close-output-port port)
-       (mu-mime-add-part mime mesg))
-     
-     (mu-message-send (mu-mime-get-message mime) #f sieve-daemon-email sender)
-     (mu-message-delete sieve-current-message))))
-
-;;; Register action
-(if sieve-parser
-    (sieve-register-action "reject" action-reject (list 'string) '()))
-      
-      
-
-      
-    

-;;;; GNU Mailutils -- a suite of utilities for electronic mail
-;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
-;;;; Software Foundation, Inc.
-;;;;
-;;;; GNU Mailutils is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 3, or (at your option)
-;;;; any later version.
-;;;; 
-;;;; GNU Mailutils is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU General Public License along
-;;;; with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>.
-
-;;;; This module provides core functionality for the sieve scripts.
-
-(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 <>
-;;; but current mailutils API is unable to parse and handle it.
-;;; Site administrators are supposed to replace it with the
-;;; actual value.
-(define-public sieve-daemon-email "MAILER-DAEMON@localhost")
-
-;;; The email address of the user whose mailbox is being processed.
-;;; If #f, it will be set by sieve-main
-(define-public sieve-my-email #f)
-
-(define SIEVE-WARNING "Warning")
-(define SIEVE-ERROR "Error")
-(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.
-;;; Each entry is: (list MAILBOX-NAME OPEN-FLAGS MBOX)
-(define sieve-mailbox-list '())
-
-;;; Cached mailbox open: Lookup in the list first, if not found,
-;;; call mu-mailbox-open and append to the list.
-;;; NOTE: second element of each slot (OPEN-FLAGS) is not currently
-;;; used, sinse all the mailboxes are open with "cw".
-(define (sieve-mailbox-open name flags)
-  (let ((slot (assoc name sieve-mailbox-list)))
-    (if slot
-	(list-ref slot 2)
-      (let ((mbox (false-if-exception (mu-mailbox-open name flags))))
-	(if mbox
-	    (set! sieve-mailbox-list (append
-				      sieve-mailbox-list
-				      (list
-				       (list name flags mbox)))))
-	mbox))))
-
-;;; Close all open mailboxes.
-(define (sieve-close-mailboxes)
-  (for-each
-   (lambda (slot)
-     (cond
-      ((list-ref slot 2)
-       => (lambda (mbox)
-	    (mu-mailbox-close mbox)))))
-   sieve-mailbox-list)
-  (set! sieve-mailbox-list '()))
-
-(define (sieve-expand-filename filename)
-  (case (string-ref filename 0)
-    ((#\/ #\% #\~ #\+ #\=)
-      filename)
-    (else
-     (let ((pw (getpwuid (geteuid))))
-	(if (vector? pw)
-	    (string-append (vector-ref pw 5)
-			   "/"
-			   filename)
-	    filename)))))
-
-;;; Comparators
-(define-public sieve-standard-comparators 
-  (list (list "i;octet" string=?)
-	(list "i;ascii-casemap" string-ci=?)))
-
-;;; Stop statement
-
-(define-public (sieve-stop)
-  (sieve-verbose-print "STOP")
-  (throw 'sieve-stop))
-
-;;; Basic five actions:
-
-;;; reject is defined in reject.scm
-
-;;; fileinto
-
-(define-public (action-fileinto filename)
-  (let ((name (sieve-expand-filename filename)))
-    (sieve-verbose-print "FILEINTO" "delivering into " name)
-    (if (string? name)
-	(let ((outbox (sieve-mailbox-open name "cw")))
-	  (cond
-	   (outbox
-	    (handle-exception
-	     (mu-mailbox-append-message outbox sieve-current-message)
-	     (mu-message-delete sieve-current-message)))
-	   (else
-	    (runtime-message SIEVE-ERROR
-			     "Could not open mailbox " name))))
-	(runtime-message SIEVE-ERROR
-			 "Could not expand mailbox name " filename))))
-
-;;; redirect is defined in redirect.scm
-
-;;; keep -- does nothing worth mentioning :^)
-
-(define-public (action-keep)
-  (sieve-verbose-print "KEEP")
-  (handle-exception
-   (mu-message-delete sieve-current-message #f)))
-
-;;; discard
-
-(define-public (action-discard)
-  (sieve-verbose-print "DISCARD" "marking as deleted")
-  (handle-exception
-   (mu-message-delete sieve-current-message)))
-
-;;; Register standard actions
-(define-public sieve-standard-actions
-  (list (list "keep" action-keep '() '())
-	(list "discard" action-discard '() '())
-	(list "fileinto" action-fileinto (list 'string) '())))
-
-;;; Some utilities.
-
-(define (sieve-get-opt-arg opt-args tag default)
-  (cond
-   ((member tag opt-args) =>
-    (lambda (x)
-      (car (cdr x))))
-   (else
-    default)))
-
-(define (find-comp opt-args)
-  (sieve-get-opt-arg opt-args #:comparator string-ci=?))
-
-(define (find-match opt-args)
-  (cond
-   ((member #:is opt-args)
-    #:is)
-   ((member #:contains opt-args)
-    #:contains)
-   ((member #:matches opt-args)
-    #:matches)
-   ((member #:regex opt-args)
-    #:regex)
-   (else
-    #:is)))
-
-(define (sieve-str-str str key comp)
-  (if (string-null? key)
-      ;; rfc3028:
-      ;;   If a header listed in the header-names argument exists, it contains
-      ;;   the null key ("").  However, if the named header is not present, it
-      ;;   does not contain the null key.
-      ;; This function gets called only if the header was present. So:
-      #t
-    (let* ((char (string-ref key 0))
-	   (str-len (string-length str))
-	   (key-len (string-length key))
-	   (limit (- str-len key-len)))
-      (if (< limit 0)
-	  #f
-	(call-with-current-continuation
-	 (lambda (xx)
-	   (do ((index 0 (1+ index)))
-	       ((cond
-		 ((> index limit)
-		  #t)
-		 ;; FIXME: This is very inefficient, but I have to use this
-		 ;; provided (string-index str (string-ref key 0)) may not
-		 ;; work...
-		 ((comp (substring str index (+ index key-len))
-			key)
-		  (xx #t))
-		 (else
-		  #f)) #f))
-	   #f))))))
-
-;;; Convert sieve-style regexps to POSIX:
-
-(define (sieve-regexp-to-posix regexp)
-  (let ((length (string-length regexp)))
-    (do ((cl '())
-	 (escape #f)
-	 (i 0 (1+ i)))
-	((= i length) (list->string (reverse cl)))
-      (let ((ch (string-ref regexp i)))
-	(cond
-	 (escape
-	  (set! cl (append (list ch) cl))
-	  (set! escape #f))
-	 ((char=? ch #\\)
-	  (set! escape #t))
-	 ((char=? ch #\?)
-	  (set! cl (append (list #\.) cl)))
-	 ((char=? ch #\*)
-	  (set! cl (append (list #\* #\.) cl)))
-	 ((member ch (list #\. #\$ #\^ #\[ #\]))
-	  (set! cl (append (list ch #\\) cl)))
-	 (else
-	  (set! cl (append (list ch) cl))))))))
-
-
-(define (get-regex match key comp)
-  (case match
-    ((#:matches)
-     (make-regexp (sieve-regexp-to-posix key)
-		  (if (eq? comp string-ci=?)
-		      regexp/icase
-		      '())))
-    ((#:regex)
-     (make-regexp key
-		  (if (eq? comp string-ci=?)
-		      regexp/icase
-		      '())))
-    (else
-     #f)))
-
-;;;; Standard tests:
-
-(define-public (test-address header-list key-list . opt-args)
-  (let ((comp (find-comp opt-args))
-	(match (find-match opt-args))
-	(part (cond
-	       ((member #:localpart opt-args)
-		#:localpart)
-	       ((member #:domain opt-args)
-		#:domain)
-	       (else
-		#:all))))
-    (call-with-current-continuation
-     (lambda (exit)
-       (for-each
-	(lambda (key)
-	  (let ((header-fields (mu-message-get-header-fields
-				sieve-current-message
-				header-list))
-		(rx (get-regex match key comp)))
-	    (for-each
-	     (lambda (h)
-	       (let ((hdr (cdr h)))
-		 (if hdr
-		     (let ((naddr (mu-address-get-count hdr)))
-		       (do ((n 1 (1+ n)))
-			   ((> n naddr) #f)
-			 (let ((addr (case part
-				       ((#:all)
-					(mu-address-get-email hdr n))
-				       ((#:localpart)
-					(mu-address-get-local hdr n))
-				       ((#:domain)
-					(mu-address-get-domain hdr n)))))
-			   (if addr
-			       (case match
-				 ((#:is)
-				  (if (comp addr key)
-				      (exit #t)))
-				 ((#:contains)
-				  (if (sieve-str-str addr key comp)
-				      (exit #t)))
-				 ((#:matches #:regex)
-				  (if (regexp-exec rx addr)
-				      (exit #t))))
-			       (runtime-message SIEVE-NOTICE
-				"Can't get address parts for message "
-				sieve-current-message))))))))
-	     header-fields)))
-	key-list)
-       #f))))
-
-(define-public (test-size key-size . comp)
-  (let ((size (mu-message-get-size sieve-current-message)))
-    (cond
-     ((null? comp)       ;; An extension.
-      (= size key-size)) 
-     ((eq? (car comp) #:over)
-      (> size key-size))
-     ((eq? (car comp) #:under)
-      (< size key-size))
-     (else
-      (runtime-message SIEVE-ERROR  "test-size: unknown comparator " comp)))))
-
-(define-public (test-envelope part-list key-list . opt-args)
-  (let ((comp (find-comp opt-args))
-	(match (find-match opt-args)))
-    (call-with-current-continuation
-     (lambda (exit)
-       (for-each
-	(lambda (part)
-	  (cond
-	   ((string-ci=? part "From")
-	    (let ((sender (mu-message-get-sender sieve-current-message)))
-	      (for-each
-	       (lambda (key)
-		 (if (comp key sender)
-		     (exit #t)))
-	       key-list)))
-	   (else
-	    (runtime-message SIEVE-ERROR
-			     "Envelope part " part " not supported")
-	    #f)))
-	part-list)
-       #f))))
-
-(define-public (test-exists header-list)
-  (call-with-current-continuation
-   (lambda (exit)
-     (for-each (lambda (hdr)
-		 (let ((val (mu-message-get-header sieve-current-message hdr)))
-                   (if (or (not val) (= (string-length val) 0))
-		     (exit #f))))
-	       header-list)
-     #t)))
-
-(define-public (test-header header-list key-list . opt-args)
-  (let ((comp (find-comp opt-args))
-	(match (find-match opt-args)))
-    (call-with-current-continuation
-     (lambda (exit)
-       (for-each
-	(lambda (key)
-	  (let ((header-fields (mu-message-get-header-fields
-				sieve-current-message
-				header-list))
-		(rx (get-regex match key comp)))
-	    (for-each
-	     (lambda (h)
-	       (let ((hdr (cdr h)))
-		 (if hdr
-		     (case match
-		       ((#:is)
-			(if (comp hdr key)
-			    (exit #t)))
-		       ((#:contains)
-			(if (sieve-str-str hdr key comp)
-			    (exit #t)))
-		       ((#:matches #:regex)
-			(if (regexp-exec rx hdr)
-			    (exit #t)))))))
-	     header-fields)))
-	key-list)
-       #f))))
-
-;;; Register tests:
-(define address-part (list (cons "localpart" #f)
-               		   (cons "domain" #f)
-			   (cons "all" #f)))
-(define match-type   (list (cons "is" #f)
-			   (cons "contains" #f)
-			   (cons "matches" #f)
-			   (cons "regex" #f)))
-(define size-comp    (list (cons "under" #f)
-			   (cons "over" #f)))
-(define comparator   (list (cons "comparator" 'string)))
-
-(define-public sieve-standard-tests
-  (list
-   (list "address"
-	 test-address
-	 (list 'string-list 'string-list)
-	 (append address-part comparator match-type))
-   (list "size"
-	 test-size
-	 (list 'number)
-	 size-comp)
-   (list "envelope"
-	 test-envelope
-	 (list 'string-list 'string-list)
-	 (append comparator address-part match-type))
-   (list "exists"
-	 test-exists
-	 (list 'string-list) 
-	 '())
-   (list "header"
-	 test-header
-	 (list 'string-list 'string-list)
-	 (append comparator match-type))
-   (list "false" #f '() '())
-   (list "true"  #t '() '())))
-
-;;; runtime-message
-
-(define-public (runtime-message level . text)
-  (let ((msg (apply string-append
-		    (map (lambda (x)
-			   (format #f "~A" x))
-			 (append
-			  (list "(in " sieve-source ") ")
-			  text)))))
-    (if sieve-current-message
-	(mu-message-set-header sieve-current-message
-			       (string-append "X-Sieve-" level)
-			       msg))
-    (if (isatty? (current-error-port))
-	(display (string-append level ": " msg "\n") (current-error-port)))))
-
-;;; Sieve-main
-(define-public sieve-mailbox #f)
-(define-public sieve-current-message #f)
-
-(define-public (sieve-run-current-message thunk)
-  (and (catch 'sieve-stop
-	      thunk
-	      (lambda args
-		#f))
-       (sieve-verbose-print "IMPLICIT KEEP")))
-
-(define (sieve-run thunk)
-  (if (not sieve-my-email)
-      (set! sieve-my-email (mu-username->email)))
-;  (DEBUG 1 "Mailbox: " sieve-mailbox)
-
-  (let msg-loop ((msg (mu-mailbox-first-message sieve-mailbox)))
-    (if (not (eof-object? msg))
-	(begin
-	  (set! sieve-current-message msg)
-	  (sieve-run-current-message thunk)
-	  (msg-loop (mu-mailbox-next-message sieve-mailbox)))))
-
-  (sieve-close-mailboxes))
-
-(define (sieve-command-line)
-  (catch #t
-	 (lambda ()
-	   (let ((args sieve-script-args))
-	     (append (list "<temp-file>") args)))
-	 (lambda args (command-line))))
-
-(define-public (sieve-main thunk) 
-  (handle-exception
-   (let* ((cl (sieve-command-line))
-	  (name (if (and (not (null? (cdr cl)))
-			 (string? (cadr cl)))
-		    (cadr cl)
-		    (mu-user-mailbox-url
-		     (passwd:name (mu-getpwuid (getuid)))))))
-
-     (set! sieve-mailbox (mu-mailbox-open name "rw"))
-     (sieve-run thunk)
-     (mu-mailbox-expunge sieve-mailbox)
-     (mu-mailbox-close sieve-mailbox))))

-#! %GUILE_BINDIR%/guile -s
-# Emacs, it's -*- scheme -*-
-!#
-;;;; GNU Mailutils -- a suite of utilities for electronic mail
-;;;; Copyright (C) 1999-2001, 2006-2007, 2009-2012, 2014-2017 Free
-;;;; Software Foundation, Inc.
-;;;;
-;;;; GNU Mailutils is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 3, or (at your option)
-;;;; any later version.
-;;;; 
-;;;; GNU Mailutils is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU General Public License along
-;;;; with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>.
-;;;;
-
-;;;; This is a Sieve to Scheme translator.
-;;;;
-;;;; To convert a sieve script into equivalent Scheme program, run:
-;;;;
-;;;;  guile -s sieve2scm.scm --file <sieve-script-name> --output <output-file-name>
-;;;;
-;;;; To compile and execute a sieve script upon a mailbox, run:
-;;;;
-;;;;  guile -s sieve2scm.scm --file <sieve-script-name> [mailbox-name]
-;;;;
-(if (not (member "%GUILE_SITE%" %load-path))
-    (set! %load-path (cons "%GUILE_SITE%" %load-path)))
-(use-modules (ice-9 getopt-long)
-	     (ice-9 rdelim)
-	     (mailutils sieve-core))
-
-(set! sieve-parser #t)
-
-(define sieve-debug 0)
-(define sieve-libdir "%LIBDIR%")
-(define sieve-load-files '())
-(define sieve-script-args '())
-(define request-verbose #f)
-
-(define error-count 0)
-(define current-token #f)
-(define putback-list '())
-(define input-port #f)
-(define input-file "")
-(define input-line-number 0)
-(define input-line "")
-(define input-index 0)
-(define input-length 0)
-(define nesting-level 0)
-(define recovery-line-number -1)
-(define recovery-index -1)
-
-(define (DEBUG level . rest)
-  (if (>= sieve-debug level)
-      (begin
-	(display "DEBUG(")
-	(display level)
-	(display "):")
-	(for-each (lambda (x)
-		    (display x))
-		  rest)
-	(newline))))
-
-;;;; Lexical scanner
-(define (delimiter? c)
-  (or (member c (list #\[ #\] #\{ #\} #\, #\; #\( #\)))
-      (char-whitespace? c)))
-
-(define (lex-error . rest)
-  (set! error-count (1+ error-count))
-  (with-output-to-port
-      (current-error-port)
-    (lambda ()
-      (display input-file)
-      (display ":")
-      (display input-line-number)
-      (display ": ")
-      (for-each (lambda (x)
-		  (display x))
-		rest)
-      (newline)))
-  #t)
-
-(define (syntax-error . rest)
-  (set! error-count (1+ error-count))
-  (with-output-to-port
-      (current-error-port)
-    (lambda ()
-      (display input-file)
-      (display ":")
-      (display input-line-number)
-      (display ": ")
-      (for-each (lambda (x)
-		  (display x))
-		rest)
-      (newline)))
-  (throw 'syntax-error))
-
-;;; If current input position points to end of line or to a start of
-;;; # comment, return #f. Otherwise return cons whose car contains
-;;; token type and cdr contains token itself (string). 
-(define (next-token)
-  (let ((start (do ((i input-index (1+ i)))
-		   ((or (>= i input-length)
-			(not (char-whitespace? (string-ref input-line i))))
-		    i))))
-;    (DEBUG 100 "START " start ": " (substring input-line start)) 
-    (if (< start input-length)
-	(let ((char (string-ref input-line start)))
-	  (DEBUG 100 "CHAR " char)
-	  (case char
-	    ((#\#)
-	     (set! input-index input-length)
-	     #f)
-	    ((#\[ #\] #\{ #\} #\( #\) #\, #\;)
-	     (set! input-index (1+ start))
-	     (cons 'delimiter char))
-	    ((#\")
-	     (let ((end (do ((end (1+ start) (1+ end)))
-			    ((or (>= end input-length)
-				 (char=? (string-ref input-line end) #\"))
-			     end))))
-	       (if (>= end input-length)
-		   (lex-error "Unterminated string constant"))
-		  (set! input-index (1+ end))
-		  (cons 'string (substring input-line (1+ start) end))))
-	    (else
-	     (DEBUG 100 "MATCH else")
-	     (cond
-	      ((and (char=? (string-ref input-line start) #\/)
-		    (< (1+ start) input-length)
-		    (char=? (string-ref input-line (1+ start)) #\*))
-	       (set! input-index (+ start 2))
-	       (cons 'bracket-comment "/*"))
-	      ((char-numeric? char)
-	       (let* ((end (do ((end start (1+ end)))
-			       ((or
-				 (>= end (1- input-length))
-				 (not (char-numeric?
-				       (string-ref input-line end))))
-
-				(cond
-				 ((char-numeric? (string-ref input-line end))
-				  (1+ end))
-				 (else
-				  end)))))
-		      (num (string->number (substring input-line start end))) 
-		      (q (if (< end input-length)
-			     (string-ref input-line end)
-			 #f))
-		      (k 1))
-		 (case q
-		   ((#f) #f) ;; nothing
-		   ((#\K)
-		    (set! end (1+ end))
-		    (set! k 1024))
-		   ((#\M)
-		    (set! end (1+ end))
-		    (set! k 1048576))
-		   ((#\G)
-		    (set! end (1+ end))
-		    (set! k 1073741824))
-		   (else
-		    (if (not (delimiter? q))
-		      (lex-error "Unknown qualifier (" q ")"))))
-		 (set! input-index end)
-		 (cons 'number (* num k))))
-	      (else
-	       (let ((end (do ((end start (1+ end)))
-			      ((or (>= end input-length)
-				   (delimiter? (string-ref input-line end)))
-			       end))))
-		 (DEBUG 100 "END " end)
-		 (set! input-index end)
-		 (cond
-		  ((char=? char #\:)
-		   (cons 'tag (substring input-line (1+ start) end)))
-		  (else
-		   (cons 'identifier (substring input-line start end))))))))))
-	#f)))
-
-(define (end-of-line?)
-  (do ((i input-index (1+ i)))
-      ((or (>= i input-length)
-	   (not (char-whitespace? (string-ref input-line i))))
-       (>= i input-length))))
-
-(define (read-input-line port)
-  (set! input-line (read-line port))
-  (if (not (eof-object? input-line))
-      (begin
-	(set! input-line-number (1+ input-line-number))
-	(set! input-length (string-length input-line))
-	(set! input-index 0)))
-  input-line)
-
-(define (next-token-from-port port)
-  (let ((tok (or (next-token)
-		 (begin
-		   (DEBUG 100 "2nd")
-		   (set! input-line (read-line port))
-		   (if (not (eof-object? input-line))
-		       (begin
-                         (set! input-line-number (1+ input-line-number))
-			 (set! input-length (string-length input-line))
-			 (set! input-index 0)
-			 (next-token))
-		       input-line)))))
-    (cond
-     ((or (not tok) (eof-object? tok))
-      tok)
-     ((and (eq? (car tok) 'identifier)
-	   (string=? (cdr tok) "text:")
-	   (end-of-line?))
-      (let ((text "")
-	    (string-start input-line-number))
-	(do ((line (read-line port) (read-line port)))
-	    ((or (and
-		  (eof-object? line)
-		  (lex-error
-		   "Unexpected end of file in multiline string started on line "
-		   string-start)
-		  (throw 'end-of-file))
-		 (let ((len (string-length line)))
-		   (and (> len 0)
-			(char=? (string-ref line 0) #\.)
-			(do ((i 1 (1+ i)))
-			    ((or (>= i len)
-				 (not
-				  (char-whitespace?
-				   (string-ref line i))))
-			     (>= i len))))))
-	     #f)
-          (set! input-line-number (1+ input-line-number))
-	  (if (and (not (string-null? line))
-                   (char=? (string-ref line 0) #\.)
-		   (char=? (string-ref line 1) #\.))
-	      (set! line (substring line 1)))
-	  (set! text (string-append text "\n" line)))
-	(set! input-length 0)
-	(set! input-index 0)
-	(cons 'string text)))
-     ((eq? (car tok) 'bracket-comment)
-      (let ((comment-start input-line-number))
-	(set! input-length (- input-length input-index))
-	   (if (> input-length 0)
-	       (begin
-		 (set! input-line
-		       (substring input-line input-index input-length))
-		 (set! input-index 0))
-	       (read-input-line port))
-	   (do ()
-	       ((> input-index 0) #f)
-	     (cond
-	      ((eof-object? input-line)
-	       (lex-error
-		"Unexpected end of file in comment started on line "
-		comment-start)
-	       (throw 'end-of-file))
-	      (else
-	       (let ((t (string-index input-line #\*)))
-		 (if (and t
-			  (< (1+ t) input-length)
-			  (char=? (string-ref input-line (1+ t)) #\/))
-		     (set! input-index (+ t 2))
-		     (read-input-line port))))))))
-     (else
-	tok))))
-
-(define (delimiter token c)
-  (and (pair? token)
-       (eq? (car token) 'delimiter)
-       (char=? (cdr token) c)))
-
-(define (identifier token c)
-  (and (eq? (car token) 'identifier)
-       (string=? (cdr token) c)))
-
-(define (putback-token)
-  (set! putback-list (append (list current-token)
-			     putback-list)))
-
-(define (read-token)
-  (cond
-   ((not (null? putback-list))
-    (set! current-token (car putback-list))
-    (set! putback-list (cdr putback-list)))
-   (else
-    (set! current-token (do ((token (next-token-from-port input-port)
-				    (next-token-from-port input-port)))
-			    (token token)))))
-  current-token)
-
-(define (require-semicolon . read)
-  (if (null? read)
-      (read-token))
-  (if (or (eof-object? current-token)
-	  (not (delimiter current-token #\;)))
-      (syntax-error "Missing ;")
-      current-token))
-
-(define (require-tag . read)
-  (if (null? read)
-      (read-token))
-  (cond
-   ((eof-object? current-token)
-    (syntax-error "Expected tag but found " current-token))
-   ((not (eq? (car current-token) 'tag))
-    (syntax-error "Expected tag but found " (car current-token))))
-  current-token)
-
-(define (require-string . read)
-  (if (null? read)
-      (read-token))
-  (cond
-   ((eof-object? current-token)
-    (syntax-error "Expected string but found " current-token))
-   ((not (eq? (car current-token) 'string))
-    (syntax-error "Expected string but found " (car current-token))))
-  current-token)
-
-(define (require-number . read)
-  (if (null? read)
-      (read-token))
-  (cond
-   ((eof-object? current-token)
-    (syntax-error "Expected number but found " current-token))
-   ((not (eq? (car current-token) 'number))
-    (syntax-error "Expected number but found " (car current-token))))
-  current-token)
-
-(define (require-string-list . read)
-  (if (null? read)
-      (read-token))
-  (cond
-   ((eof-object? current-token)
-    (syntax-error "Expected string-list but found " current-token))
-   ((eq? (car current-token) 'string)
-    (list 'string-list (cdr current-token)))
-   ((not (eq? (car current-token) 'delimiter))
-    (syntax-error "Expected string-list but found " (car current-token)))
-   ((char=? (cdr current-token) #\[)
-    (do ((slist '())
-	 (token (read-token) (read-token)))
-	((if (not (eq? (car token) 'string))
-	     (begin
-	       (syntax-error "Expected string but found " (car token))
-	       #t)
-	     (begin
-	       (set! slist (append slist (list (cdr token))))
-	       (read-token)
-	       (cond
-		((eof-object? current-token)
-		 (syntax-error "Unexpected end of file in string list")
-		 #t) ;; break;
-		((eq? (car current-token) 'delimiter)
-		 (cond
-		  ((char=? (cdr current-token) #\,) #f) ;; continue
-		  ((char=? (cdr current-token) #\]) #t) ;; break
-		  (else
-		   (lex-error "Expected ',' or ']' but found "
-			      (cdr current-token))
-		   #t)))
-		(else
-		 (lex-error "Expected delimiter but found "
-			    (car current-token))
-		 #t))))
-	 (cons 'string-list slist))))
-   (else
-    (syntax-error "Expected '[' but found " (car current-token)))))
-  
-(define (require-identifier . read)
-  (if (null? read)
-      (read-token))
-  (cond
-   ((eof-object? current-token)
-    (syntax-error "1. Expected identifier but found " current-token))
-   ((not (eq? (car current-token) 'identifier))
-    (syntax-error "2. Expected identifier but found " (car current-token))))
-  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)
-  (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)))))))
-   
-;;;;
-
-(defmacro do-for-all (fun rest)
-  `(for-each
-    (lambda (x)
-      (apply ,fun x))
-    ,rest))
-
-
-;;;; Available syntax tables.
-
-;;;; Comparators
-
-;;; 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)
-  (sieve-syntax-table-add sieve-comparator-table name function '() '()))
-
-;;; Register standard comparators
-(do-for-all sieve-register-comparator sieve-standard-comparators)
-
-;;;; Sieve Tests
-
-;;; 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)
-  (sieve-syntax-table-add sieve-test-table name function
-			  req-arg-list opt-arg-list))
-
-;;; Register standard tests
-(do-for-all sieve-register-test sieve-standard-tests) 
-
-;;;; 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))
-
-;;; Register standard actions
-(do-for-all sieve-register-action sieve-standard-actions)
-
-;;;;
-
-;;;; 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
-;;; a list of the rest of the arguments.
-;;;
-;;; arguments = *argument [test / test-list]
-;;; argument = string-list / number / tag
-
-(define (sieve-preprocess-arguments tag-gram)
-  (do ((opt-list '())   ;; List of optional arguments (tags)
-       (arg-list '())   ;; List of positional arguments
-       (last-tag #f)    ;; Description of the last tag from tag-gram
-       (state 'opt)     ;; 'opt when scanning optional arguments,
-                        ;; 'arg when scanning positional arguments
-       (token (read-token) (read-token))) ;; Obtain next token
-      ((cond
-	((eof-object? token)
-	 (syntax-error "Expected argument but found " token))
-	((eq? (car token) 'tag)
-	 (if (not (eq? state 'opt))
-	     (syntax-error "Misplaced tag: :" (cdr token)))
-	 (set! last-tag (assoc (cdr token) tag-gram))
-	 (if (not last-tag)
-	     (syntax-error
-	      "Tag :" (cdr token) " is not allowed in this context"))
-	 (set! opt-list (append opt-list (list token)))
-	 #f)
-	((or (eq? (car token) 'number)
-	     (eq? (car token) 'string))
-	 (cond
-	  ((and (eq? state 'opt) (pair? last-tag))
-	   (cond
-	    ((cdr last-tag)
-	     (if (not (eq? (cdr last-tag) (car token)))
-		 (syntax-error
-		  "Tag :" (car last-tag) " takes " (cdr last-tag) " argument"))
-	     (cond
-	      ((string=? (car last-tag) "comparator")
-	       (let ((comp (sieve-find-comparator (cdr token))))
-		 (if (not comp)
-		     (syntax-error "Undefined comparator: " (cdr token)))
-		 (set-cdr! token (car comp)))))
-	     (set! opt-list (append opt-list (list token)))
-	     (set! last-tag #f))
-	    (else
-	     (set! state 'arg)
-	     (set! arg-list (append arg-list (list token))))))
-	  (else
-	   (set! arg-list (append arg-list (list token)))))
-	 #f)
-	((delimiter token #\[) 
-	 (putback-token)
-	 (cond
-	  ((and (eq? state 'opt) (pair? last-tag))
-	   (cond
-	    ((cdr last-tag)
-	     (if (not (eq? (cdr last-tag) 'string-list))
-		 (syntax-error
-		  "Tag :" (car last-tag) " takes string list argument"))
-	     (set! opt-list (append opt-list (list (require-string-list))))
-	     (set! last-tag #f))
-	    (else
-	     (set! state 'arg)
-	     (set! arg-list (append arg-list (list (require-string-list)))))))
-	  (else
-	   (set! arg-list (append arg-list (list (require-string-list))))))
- 	 #f)
-	(else
-	 #t)) 
-       (cons opt-list arg-list))))
-
-;;; sieve-parse-arguments: Parse the arguments to a test or an action.
-;;; ENTRY is the syntax table entry to guide the parsing
-;;;
-(define (sieve-parse-arguments ident entry)
-  (DEBUG 100 "sieve-parse-arguments" entry)
-  (let ((arg-list (sieve-preprocess-arguments (car (cdr entry)))))
-    ;; Process positional arguments
-    (do ((expect (car (cdr (cdr entry))) (cdr expect))
-	 (argl (cdr arg-list) (cdr argl))
-	 (n 1 (1+ n)))
-	((cond
-	  ((null? expect)
-	   (if (not (null? argl))
-	       (syntax-error
-		"Too many positional arguments for " ident
-		" (bailed out at " (car argl) ")"))
-	   #t)
-	  ((null? argl)
-	   (if (not (null? expect))
-	       (syntax-error
-		"Too few positional arguments for " ident))
-	   #t)
-	  (else #f)) #f)
-      (let ((expect-type (car expect))
-	    (arg (car argl)))
-	(cond
-	 ((and (eq? expect-type 'string-list)
-	       (eq? (car arg) 'string))
-	  ;; Coerce string to string-list
-	  (sieve-exp-append (list 'list (cdr arg))))
-	 ((eq? expect-type (car arg))
-	  (if (eq? expect-type 'string-list)
-	      (sieve-exp-append (append (list 'list) (cdr arg)))
-	      (sieve-exp-append (cdr arg))))
-	 (else
-	  (syntax-error
-	   "Type mismatch in argument " n " to " (cdr ident)
-	   "; expected " expect-type ", but got " (car arg))))))
-    ;; Process optional arguments (tags).
-    ;; They have already been tested
-    (for-each
-     (lambda (tag)
-       (sieve-exp-append (cond
-			  ((eq? (car tag) 'tag)
-			   (symbol->keyword
-			    (string->symbol (cdr tag))))
-			  ((eq? (car tag) 'string-list)
-			   (append (list 'list) (cdr tag)))
-			  (else
-			   (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)))
-      ((cond
-	((delimiter token #\))
-	 #t) ;; break;
-	((delimiter token #\,)
-	 #f) ;; continue
-	((eof-object? token)
-	 (syntax-error "Unexpected end of file in test-list")
-	 #t) ;; break
-	(else
-	 (syntax-error "Expected ',' or ')' but found " (cdr token))
-	 #t)) ;; break
-       (read-token))))
-	
-;;; test = identifier arguments
-(define (sieve-parse-test)
-  (let ((ident (require-identifier)))
-    (cond
-     ((string=? (cdr ident) "not")
-      (sieve-exp-begin)
-      (sieve-exp-append 'not)
-      (sieve-parse-test)
-      (sieve-exp-finish))
-     (else
-      (read-token)
-      (cond
-       ((eof-object? current-token)
-	(syntax-error "Unexpected end of file in conditional"))
-       ((delimiter current-token #\()
-	(sieve-exp-begin)
-	(cond
-	 ((string=? (cdr ident) "allof")
-	  (sieve-exp-append 'and))
-	 ((string=? (cdr ident) "anyof")
-	  (sieve-exp-append 'or))
-	 (else
-	  (syntax-error "Unexpected '('")))
-	(sieve-parse-test-list)
-	(sieve-exp-finish))
-       (else
-	(let ((test (sieve-find-test (cdr ident))))
-	  (if (not test)
-	      (syntax-error "Unknown test name: " (cdr ident)))
-	  (cond
-	   ((procedure? (car test))
-	    (putback-token)
-	    (sieve-exp-begin)
-	    (sieve-exp-append (car test))
-	    (sieve-parse-arguments (cdr ident) test)
-	    (sieve-exp-finish))
-	   (else
-	    (sieve-exp-append (car test))))))))))
-  current-token)
-
-(define (sieve-parse-block . read)
-  (if (not (null? read))
-      (read-token))
-  (if (delimiter current-token #\{)
-      (begin
-	(set! nesting-level (1+ nesting-level))
-	(do ((token (read-token) (read-token)))
-	    ((cond
-	      ((eof-object? token)
-	       (syntax-error "Unexpected end of file in block")
-	       #t)
-	      ((delimiter token #\})
-	       #t)
-	      (else
-	       (putback-token)
-	       (sieve-parse-command)
-	       #f))) #f)
-	(set! nesting-level (1- nesting-level)))
-      (require-semicolon 'dont-read)))
-
-;;; if <test1: test> <block1: block>
-(define (sieve-parse-if-internal)
-  (DEBUG 10 "sieve-parse-if-internal" current-token)
-  (sieve-exp-begin)
-  
-  (sieve-parse-test)
-  
-  (sieve-parse-block)
-  (sieve-exp-finish)
-  
-  (read-token)
-  (cond
-   ((eof-object? current-token) )
-   ((identifier current-token "elsif")
-    (sieve-parse-if-internal))
-   ((identifier current-token "else")
-    (sieve-exp-begin 'else)
-    (sieve-parse-block 'read)
-    (sieve-exp-finish))
-   (else
-    (putback-token))))
-
-(define (sieve-parse-if)
-  (sieve-exp-begin 'cond)
-  (sieve-parse-if-internal)
-  (sieve-exp-finish))
-
-(define (sieve-parse-else)
-  (syntax-error "else without if"))
-
-(define (sieve-parse-elsif)
-  (syntax-error "elsif without if"))
-
-;;; require <capabilities: string-list>
-(define (sieve-parse-require)
-  (for-each
-   (lambda (capability)
-     (if (not
-	  (cond
-	   ((and
-	     (>= (string-length capability) 5)
-	     (string=? (substring capability 0 5) "test-"))
-	    (sieve-find-test (substring capability 5)))
-	   ((and
-	     (>= (string-length capability) 11)
-	     (string=? (substring capability 0 11) "comparator-"))
-	    (sieve-find-comparator (substring capability 11)))
-	   (else
-	    (sieve-find-action capability))))
-	 (let ((name (string-append sieve-libdir
-				    "/" capability ".scm")))
-	   (set! sieve-load-files (append sieve-load-files (list name)))
-	   (catch #t
-		  (lambda ()
-		    (load name))
-		  (lambda args
-		    (lex-error "Can't load required capability "
-			       capability)
-		    args)))))
-   (cdr (require-string-list)))
-  (require-semicolon))
-
-;;; stop
-(define (sieve-parse-stop)
-  (sieve-exp-begin sieve-stop)
-  (sieve-exp-finish)
-  (require-semicolon))
-
-;;;;
-
-;;;; Parser functions for actions
-
-(define (sieve-parse-action)
-  (let* ((name (cdr current-token))
-	 (descr (sieve-find-action name)))
-    (cond
-     (descr
-      (cond
-       ((car descr)
-	(sieve-exp-begin 'reg-action)
-	(sieve-exp-finish)
-	(sieve-exp-begin (car descr))
-	(sieve-parse-arguments name descr)
-	(require-semicolon 'dont-read)
-	(sieve-exp-finish))
-       (else
-	(require-semicolon))))
-     (else
-      (syntax-error "Unknown identifier: " name)))))
-
-;;;;
-
-;;;; The parser
-
-(define (sieve-parse-command)
-  (DEBUG 10 "sieve-parse-command" current-token)
-  (catch 'syntax-error
-   (lambda ()
-     (read-token)
-     (cond
-      ((or (not current-token)
-	   (eof-object? current-token))) ;; Skip comments and #<eof>
-      ((eq? (car current-token) 'identifier)
-       ;; Process a command
-       (let ((elt (assoc (string->symbol (cdr current-token))
-			 (list
-			  (cons 'if sieve-parse-if)
-			  (cons 'elsif sieve-parse-elsif)
-			  (cons 'else sieve-parse-else)
-		          (cons 'require sieve-parse-require)
-		          (cons 'stop sieve-parse-stop)))))
-	 (if (not elt)
-	     (sieve-parse-action)
-	     (apply (cdr elt) '()))))
-      (else
-       (syntax-error "3. Expected identifier but found "
-		     (cdr current-token)))))
-   (lambda args
-     ;; Error recovery: skip until we find a ';' or '}'.
-     (if (and (= input-line-number recovery-line-number)
-	      (= input-index recovery-index))
-	 (begin
-	   (lex-error "ERROR RECOVERY: Skipping to end of file")
-	   (throw 'end-of-file)))
-     (set! recovery-line-number input-line-number)
-     (set! recovery-index input-index)
-
-     (if (or (delimiter current-token #\})
-	     (delimiter current-token #\;))
-	 (read-token))
-     (DEBUG 50 "ERROR RECOVERY at " current-token)
-     (do ((token current-token (read-token)))
-	 ((cond
-	   ((eof-object? token)
-	    (throw 'end-of-file))
-	   ((delimiter token #\;)
-	    #t)
-	   ((delimiter token #\})
-	    (cond
-	     ((> nesting-level 0)
-	      (putback-token)
-	      #t)
-	     (else
-	      #f)))
-	   ((delimiter token #\{)
-	    (sieve-skip-block)
-	    (putback-token)
-	    #f)
-	   (else
-	    #f)) #f))
-     (DEBUG 50 "ERROR RECOVERY FINISHED AT " current-token)))
-  current-token)
-
-(define (sieve-skip-block)
-  (do ((token (read-token) (read-token)))
-      ((cond
-	((eof-object? token)
-	 (throw 'end-of-file))
-	((delimiter token #\{)
-	 (sieve-skip-block)
-	 #f)
-	((delimiter token #\})
-	 #t)
-	(else
-	 #f)) #f)))
-
-(define (sieve-parse-from-port port)
-  (set! input-port port)
-  (do ((token (sieve-parse-command) (sieve-parse-command)))
-      ((eof-object? token) #f)) )
-
-(define (sieve-parse filename)
-  (if (file-exists? filename)
-      (catch 'end-of-file 
-        (lambda ()
-	  (set! error-count 0)
-	  (set! current-token #f)
-	  (set! input-file filename)
-	  (set! input-line-number 0)
-	  (set! putback-list '())
-	  (call-with-input-file filename sieve-parse-from-port))
-	(lambda args args))))
-
-;;;;
-
-;;;; Code generator
-
-(define sieve-exp '())  ;; Expression currently being built
-(define sieve-exp-stack '())
-(define sieve-code-list '())  ;; Resulting scheme code
-
-(define (sieve-exp-begin . exp)
-  (set! sieve-exp-stack (append (list sieve-exp) sieve-exp-stack))
-  (set! sieve-exp exp))
-
-(define (sieve-exp-append exp)
-  (set! sieve-exp (append sieve-exp (list exp))))
-
-(define (sieve-exp-finish)
-  (set! sieve-exp (append (car sieve-exp-stack) (list sieve-exp)))
-  (set! sieve-exp-stack (cdr sieve-exp-stack)))
-
-(define (sieve-code-begin)
-  (set! sieve-exp-stack '())
-  (set! sieve-exp '()))
-
-(define (sieve-code-prologue code-list)
-  (sieve-exp-begin (car code-list))
-  (let loop ((code-list (cdr code-list)))
-    (for-each
-     (lambda (elt)
-       (cond
-	((and (list? elt) (not (null? elt)))
-	 (sieve-exp-begin (car elt))
-	 (loop (cdr elt))
-	 (sieve-exp-finish))
-	(else
-	 (sieve-exp-append elt))))
-     code-list)))
-		 
-(define (sieve-code-finish)
-  (if (not (null? sieve-exp))
-      (set! sieve-code-list (append sieve-code-list sieve-exp))))
-
-;;; Print the program
-
-(define (sieve-code-print-list exp)
-  (display "(")
-  (for-each
-   (lambda (x)
-     (cond
-      ((procedure? x)
-       (display (procedure-name x)))
-      ((list? x)
-       (sieve-code-print-list x))
-      (else
-       (write x)))
-     (display " "))
-   exp)
-  (display ")"))
-
-;;; Save the program
-
-(define (sieve-save-program outfile)
-  (with-output-to-file
-      outfile
-    (lambda ()
-      (display "#! ")
-      (display "/bin/sh\n\
-# aside from this initial boilerplate, this is actually -*- scheme -*- code\n\
-exec ${GUILE-guile} -l $0 -c '(mailutils-main)'\n")
-      (display (string-append
-		"# This Guile mailbox parser was made from " filename))
-      (newline) 
-      (display "# by sieve.scm, GNU %PACKAGE% %VERSION%\n!#")
-      (newline)
-      
-      (display 
-       "(if (not (member \"%GUILE_SITE%\" %load-path))\n
-           (set! %load-path (cons \"%GUILE_SITE%\" %load-path)))\n")
-      
-      (display "(use-modules (mailutils sieve-core))\n")
-      (display (string-append
-		"(set! sieve-source \"" filename "\")"))
-      (newline)
-      
-      (for-each
-       (lambda (file)
-	 (display (string-append
-		   "(load \"" file "\")"))
-	 (newline))
-       sieve-load-files)
-      (newline)
-      (if request-verbose
-	  (display "(set! sieve-verbose #t)\n"))
-      (display "(define (sieve-filter-thunk) ")
-      
-      (sieve-code-print-list (car sieve-code-list))
-      (display ")\n\n")
-
-      (display "(define (mailutils-main . rest)\n")
-      (display "  (sieve-main sieve-filter-thunk))\n\n")
-
-      (display "(define (mailutils-check-message msg)\n\
-  (set! sieve-current-message msg)\n\
-  (sieve-run-current-message sieve-filter-thunk))\n")
-      
-      (display "\n\
-;;;; Local Variables:\n\
-;;;; buffer-read-only: t\n\
-;;;; End:\n"))))
-
-;;;;
-
-;;;; Main
-
-(define filename #f)
-(define output #f)
-
-(define (sieve-usage)
-  (display "usage: sieve2scm [OPTIONS] [mailbox]\n")
-  (display "GNU sieve2scm -- compile a Sieve program into Scheme code\n\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 "       --version            Show program version\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-version)
-  (format #t "sieve2scm (~A) ~A~%" mu-package mu-version)
-  (exit 0))
-
-;;; Parse command line 
-
-(define grammar
-  `((file   (single-char #\f)
-            (value #t))
-    (output (single-char #\o)
-	    (value #t))
-    (debug  (single-char #\d)
-	    (value #t))
-    (lib-dir (single-char #\L)
-	     (value #t))
-    (version)
-    (verbose (single-char #\v))
-    (help   (single-char #\h))))
-
-(define program-name (car (command-line)))
-
-(for-each
- (lambda (x)
-   (cond
-    ((pair? x)
-     (case (car x)
-       ((debug)
-	(set! sieve-debug (string->number (cdr x))))
-       ((file)
-	(set! filename (cdr x)))
-       ((lib-dir)
-	(set! sieve-libdir (cdr x)))
-       ((output)
-	(set! output (cdr x)))
-       ((version)
-	(sieve-version))
-       ((verbose)
-	(set! request-verbose #t))
-       ((help)
-	(sieve-usage))
-       ('()
-	(set! sieve-script-args (cdr x)))))))
- (getopt-long (command-line) grammar))
-
-(cond
- ((not filename)
-  (format (current-error-port) "~A: missing input filename~%" program-name)
-  (sieve-usage))
- ((not (file-exists? filename))
-  (format (current-error-port) "~A: Input file ~A does not exist~%" filename)
-  (exit 0)))
-	
-(if (not sieve-libdir)
-    (set! sieve-libdir
-	    (let ((myname (car (command-line))))
-	      (if (not (char=? (string-ref myname 0) #\/))
-		  (set! myname (string-append (getcwd) "/" myname)))
-	      (let ((slash (string-rindex myname #\/)))
-		(substring myname 0 slash)))))
-
-(sieve-code-prologue
- '(letrec
-      ((implicit-keep #t)
-       (reg-action (lambda () (set! implicit-keep #f))))))
-
-(sieve-parse filename)
-(sieve-exp-append 'implicit-keep)
-(sieve-exp-finish)
-(sieve-code-finish)
-
-(cond
- ((> error-count 0)
-  (display error-count)
-  (display " errors.")
-  (newline)
-  (exit 1))
- (output
-  (sieve-save-program output))
- (else
-  (let ((temp-file (tmpnam))
-	(saved-umask (umask #o077)))
-    (sieve-save-program temp-file)
-    (catch #t
-	   (lambda ()
-	     (set-cdr! (command-line) sieve-script-args)
-	     (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
-
-
-

-;;;; GNU Mailutils -- a suite of utilities for electronic mail
-;;;; Copyright (C) 1999-2001, 2006-2007, 2010-2012, 2014-2017 Free
-;;;; Software Foundation, Inc.
-;;;;
-;;;; GNU Mailutils is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 3, or (at your option)
-;;;; any later version.
-;;;; 
-;;;; GNU Mailutils is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;;; GNU General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU General Public License along
-;;;; with GNU Mailutils.  If not, see <http://www.gnu.org/licenses/>.
-
-;;;; This module provides "vacation" extension
-
-;;; vacation example:
-;;; vacation :days 18
-;;;          :aliases ["gray@gnu.org", "gray@mirddin.farlep.net"]
-;;;          :addresses ["bug-mailutils@gnu.org","bug-inetutils@gnu.org"]
-;;;          :subject "I'm on vacation"
-;;;          :mime
-;;;          text:
-;;;   I am on vacation until July 22. I'll attend your message as soon
-;;;   as I'm back.
-;;; .
-;;;
-;;; Additionally, the :sender flag may be used to debug the script.
-
-;; Debugging flag
-(define vacation-debug #f)
-
-;; Each entry is (cons SENDER DATE), where SENDER is the sender email
-;; address (lowercase) and DATE is the date where the first message
-;; from this sender was received.
-(define vacation-db '())
-
-(define (vacation-downcase name)
-  (let ((len (string-length name)))
-    (do ((i 0 (1+ i)))
-	((= i len) name)
-      (string-set! name i (char-downcase (string-ref name i))))))
-
-(define (vacation-db-name)
-  (let ((pwd (mu-getpwuid (getuid))))
-    (string-append (vector-ref pwd 5) "/.vacation.db")))
-
-(define (vacation-db-load)
-  (catch #t
-	 (lambda ()
-	   (call-with-input-file (vacation-db-name)
-	     (lambda (port)
-	       (set! vacation-db (read port)))))
-	 (lambda args args)))
-
-(define (vacation-db-save)
-  (catch #t
-	 (lambda ()
-	   (let ((mask (umask #o077)))
-	     (call-with-output-file (vacation-db-name)
-	       (lambda (port)
-		 (display ";; Vacation database file\n" port)
-		 (display ";; Generated automatically. Please do not edit\n"
-			  port)
-		 (write vacation-db port)))
-	     (umask mask)))
-	 (lambda args args)))
-
-(define (vacation-db-lookup sender days)
-  (vacation-db-load)  
-  (let ((val (assoc (vacation-downcase sender) vacation-db)))
-    (cond
-     (val
-      (cond
-       ((and days (> days 0))
-	(<= (- (car (gettimeofday)) (cdr val)) (* days 86400)))
-       (else
-	#t)))
-     (else
-      #f))))
-
-(define (vacation-db-update msg)
-  (let* ((sender (vacation-downcase (mu-message-get-sender msg)))
-	 (date (car (gettimeofday)))
-	 (val (assoc sender vacation-db)))
-    (cond
-     (val
-      (set-cdr! val date))
-     (else
-      (set! vacation-db (append vacation-db (list
-					     (cons sender date)))))))
-  (vacation-db-save))
-
-(define vacation-noreply-senders
-  (list
-   ".*-REQUEST@.*"
-   ".*-RELAY@.*"
-   ".*-OWNER@.*"
-   "OWNER-.*"
-   "postmaster@.*"
-   "UUCP@.*"
-   "MAILER@.*"
-   "MAILER-DAEMON@.*"))
-
-(define (vacation-reply? msg aliases addresses days)
-  (let ((sender (mu-message-get-sender msg)))
-    (and
-     ;; No message will be sent unless an alias is part of either
-     ;; the "To:" or "Cc:" headers of the mail.
-     (call-with-current-continuation
-      (lambda (exit)
-	(for-each
-	 (lambda (hdr)
-	   (cond
-	    (hdr
-	     (let ((count (mu-address-get-count hdr)))
-	       (do ((i 1 (1+ i)))
-		   ((> i count) #f)
-		 (let ((email (mu-address-get-email hdr i)))
-		   (for-each
-		    (lambda (alias)
-		      (if (string-ci=? alias email)
-			  (exit #t)))
-		    aliases)))))))
-	 (list (mu-message-get-header msg "To")
-	       (mu-message-get-header msg "Cc")))
-	#f))
-
-     ;; Messages sent from one of the vacation-noreply-senders are not
-     ;; responded to
-     (call-with-current-continuation
-      (lambda (exit)
-	(do ((explist (append vacation-noreply-senders addresses)
-		      (cdr explist)))
-	    ((null? explist) #t)
-	  (let ((rx (make-regexp (car explist) regexp/icase)))
-	    (if (regexp-exec rx sender)
-		(exit #f))))))
-
-     ;; Messages with Precedence: bulk or junk are not responded to
-     (let ((prec (mu-message-get-header msg "Precedence")))
-       (not (and prec (or (string-ci=? prec "bulk")
-			  (string-ci=? prec "junk")))))
-
-     ;; Senders already in the database get no response
-     (not (vacation-db-lookup sender days)))))
-
-(define (vacation-send-reply subject text sender)
-  (let ((sender "root@localhost")
-	(mesg (mu-message-create)))
-    (let ((port (mu-message-get-port mesg "w")))
-      (display text port)
-      (close-output-port port))
-    (mu-message-set-header mesg "X-Sender"
-			   (string-append "vacation.scm, " mu-package-string)
-			   #t)
-    (mu-message-send mesg #f #f sender)))
-
-(define (action-vacation text . opt)
-  (sieve-verbose-print "VACATION")
-  (set! vacation-debug (member #:debug opt))
-  (if vacation-debug
-      (begin
-	(display sieve-current-message)(display ": ")))
-  (cond
-   ((vacation-reply? sieve-current-message
-		     (append (list sieve-my-email)
-			     (sieve-get-opt-arg opt #:aliases '()))
-		     (sieve-get-opt-arg opt #:addresses '())
-		     (sieve-get-opt-arg opt #:days #f))
-    (vacation-send-reply (sieve-get-opt-arg
-			  opt #:subject
-			  (string-append "Re: "
-					 (mu-message-get-header
-					  sieve-current-message
-					  "Subject")))
-			 text
-			 (sieve-get-opt-arg
-			  opt #:sender
-			  (mu-message-get-sender sieve-current-message)))
-    (vacation-db-update sieve-current-message)
-    (if vacation-debug
-	(display "WILL REPLY\n")))
-   (vacation-debug
-    (display "WILL NOT REPLY\n"))))
-
-;;; Register action
-(if sieve-parser
-    (sieve-register-action "vacation"
-			   action-vacation
-			   (list 'string)
-			   (list (cons "days" 'number)
-				 (cons "addresses" 'string-list)
-				 (cons "aliases" 'string-list)
-				 (cons "subject" 'string)
-				 (cons "sender" 'string)
-				 (cons "mime" #f)
-				 (cons "debug" #f))))
-