summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org>2017-04-09 20:25:22 +0300
committerSergey Poznyakoff <gray@gnu.org>2017-04-09 20:25:22 +0300
commitcbc5613658f4ccba5e8ccc5bbae07db83a9bf0e4 (patch)
treecfa64a7240d296cd08cc6805ab1cb750dd83344b
parentecbf0d3a1ab03da431257128d66c5a242a0294a5 (diff)
downloadmailutils-cbc5613658f4ccba5e8ccc5bbae07db83a9bf0e4.tar.gz
mailutils-cbc5613658f4ccba5e8ccc5bbae07db83a9bf0e4.tar.bz2
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.
-rw-r--r--NEWS13
-rw-r--r--doc/texinfo/mailutils.texi1
-rw-r--r--doc/texinfo/programs.texi42
-rw-r--r--scheme/Makefile.am30
-rw-r--r--scheme/mimeheader.scm83
-rw-r--r--scheme/numaddr.scm73
-rw-r--r--scheme/redirect.scm59
-rw-r--r--scheme/reject.scm95
-rw-r--r--scheme/sieve-core.scm496
-rw-r--r--scheme/sieve2scm.scmi1090
-rw-r--r--scheme/vacation.scm202
11 files changed, 15 insertions, 2169 deletions
diff --git a/NEWS b/NEWS
index 5041f3040..25aeff6aa 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,4 @@
-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.
See the end of file for copying conditions.
@@ -87,7 +87,16 @@ defined. Instead, the following constants are defined in config.h:
MAILUTILS_VERSION_PATCH Patchlevel number (or 0, for stable releases).
* 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
diff --git a/doc/texinfo/mailutils.texi b/doc/texinfo/mailutils.texi
index 1cdde58dc..b2c6030fe 100644
--- a/doc/texinfo/mailutils.texi
+++ b/doc/texinfo/mailutils.texi
@@ -257,7 +257,6 @@ Reading Mail
@command{sieve}
* sieve interpreter:: A Sieve Interpreter
-* sieve2scm:: A Sieve to Scheme Translator and Filter
A Sieve Interpreter
diff --git a/doc/texinfo/programs.texi b/doc/texinfo/programs.texi
index e479944dc..8e420f9ea 100644
--- a/doc/texinfo/programs.texi
+++ b/doc/texinfo/programs.texi
@@ -5902,14 +5902,11 @@ only the first.
@UNREVISED
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
* sieve interpreter:: A Sieve Interpreter
-* sieve2scm:: A Sieve to Scheme Translator and Filter
@end menu
@node sieve interpreter
@@ -6250,41 +6247,6 @@ source for the required action NAME is not available
@end enumerate
@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
@node guimb
@section @command{guimb} --- A Mailbox Scanning and Processing Language
diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index 91fd00470..1b65f593d 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -15,19 +15,7 @@
## You should have received a copy of the GNU General Public License
## 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
$(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_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,%LIBDIR%,$(sievemoddir),g' >> package.sed
$(AM_V_at)echo 's,%PACKAGE%,$(PACKAGE),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=\
- $(sievemod_DATA)\
- sieve-core.scm\
- sieve2scm.scmi\
guimb.scmi
installcheck-binSCRIPTS: $(bin_SCRIPTS)
diff --git a/scheme/mimeheader.scm b/scheme/mimeheader.scm
deleted file mode 100644
index 113d5f515..000000000
--- a/scheme/mimeheader.scm
+++ /dev/null
@@ -1,83 +0,0 @@
-;;;; 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)))
diff --git a/scheme/numaddr.scm b/scheme/numaddr.scm
deleted file mode 100644
index 48a9f3fda..000000000
--- a/scheme/numaddr.scm
+++ /dev/null
@@ -1,73 +0,0 @@
-;;;; 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))
diff --git a/scheme/redirect.scm b/scheme/redirect.scm
deleted file mode 100644
index d4e6151a8..000000000
--- a/scheme/redirect.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-;;;; 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) '()))
-
-
-
diff --git a/scheme/reject.scm b/scheme/reject.scm
deleted file mode 100644
index ed80aed18..000000000
--- a/scheme/reject.scm
+++ /dev/null
@@ -1,95 +0,0 @@
-;;;; 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) '()))
-
-
-
-
-
diff --git a/scheme/sieve-core.scm b/scheme/sieve-core.scm
deleted file mode 100644
index 862dfdb2f..000000000
--- a/scheme/sieve-core.scm
+++ /dev/null
@@ -1,496 +0,0 @@
-;;;; 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))))
diff --git a/scheme/sieve2scm.scmi b/scheme/sieve2scm.scmi
deleted file mode 100644
index 4bed3