diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2001-08-04 14:37:11 +0000 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2001-08-04 14:37:11 +0000 |
commit | 5d08ab372a36030d239ff5aeb2729ec49bfd2e21 (patch) | |
tree | ec57e720d7e8dba5863f87e0dc77bb9001da772f /guimb/scm/sieve-core.scm | |
parent | eec35c747ccb29d6b2b204814df2e36d9c4deaf2 (diff) | |
download | mailutils-5d08ab372a36030d239ff5aeb2729ec49bfd2e21.tar.gz mailutils-5d08ab372a36030d239ff5aeb2729ec49bfd2e21.tar.bz2 |
Changed action-keep: it couldn't be just #f.
Fixed and tested action-stop, action-redirect and test-exists.
Fixed handling of null-length keys in sieve-str-str.
test-address and test-header: use mu-message-get-header-fields to speed
the things up.
Implemented "envelope" test.
Diffstat (limited to 'guimb/scm/sieve-core.scm')
-rw-r--r-- | guimb/scm/sieve-core.scm | 105 |
1 files changed, 74 insertions, 31 deletions
diff --git a/guimb/scm/sieve-core.scm b/guimb/scm/sieve-core.scm index 6e1247bd0..7cb6c92ca 100644 --- a/guimb/scm/sieve-core.scm +++ b/guimb/scm/sieve-core.scm @@ -26,13 +26,13 @@ ;;; Stop statement (define (sieve-stop) - (exit)) + (throw 'sieve-stop)) ;;; Basic five actions: ;;; reject -(define sieve-option-quote #f) +(define sieve-option-quote #t) (define sieve-indent-prefix "\t") (define (action-reject reason) @@ -40,18 +40,20 @@ (outbody (mu-message-get-body out-msg)) (inbody (mu-message-get-body sieve-current-message))) (mu-message-set-header out-msg "To" - (mu-message-get-header in-msg "From")) + (mu-message-get-header sieve-current-message + "From")) (mu-message-set-header out-msg "Cc" - (mu-message-get-header in-msg "Cc")) + (mu-message-get-header sieve-current-message "Cc")) (mu-message-set-header out-msg "Subject" (string-append "Re: " - (mu-message-get-header in-msg "Subject"))) + (mu-message-get-header sieve-current-message + "Subject"))) (mu-body-write outbody reason) (cond (sieve-option-quote - (mu-body-write outbody "\n\nOriginal message:\n") + (mu-body-write outbody "\n\nThe rejected message follows:\n") (do ((hdr (mu-message-get-header-fields sieve-current-message) (cdr hdr))) ((null? hdr) #f) @@ -59,12 +61,13 @@ (mu-body-write outbody (string-append sieve-indent-prefix (car s) ": " (cdr s) "\n")))) - (mu-body-write outbody (string-append indent-prefix "\n")) + (mu-body-write outbody (string-append sieve-indent-prefix "\n")) (do ((line (mu-body-read-line inbody) (mu-body-read-line inbody))) ((eof-object? line) #f) (mu-body-write outbody (string-append sieve-indent-prefix line))))) - (mu-message-send out-msg))) + (mu-message-send out-msg)) + (mu-message-delete sieve-current-message)) ;;; fileinto @@ -80,6 +83,9 @@ ;;; keep -- does nothing worth mentioning :^) +(define (action-keep) + #f) + ;;; discard (define (action-discard) @@ -88,7 +94,7 @@ ;;; Register standard actions (cond (sieve-parser - (sieve-register-action "keep" #f) + (sieve-register-action "keep" action-keep) (sieve-register-action "discard" action-discard) (sieve-register-action "reject" action-reject 'string) (sieve-register-action "fileinto" action-fileinto 'string))) @@ -116,12 +122,19 @@ #:is))) (define (sieve-str-str str key comp) - (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 + (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))) @@ -136,7 +149,7 @@ (xx #t)) (else #f)) #f)) - #f))))) + #f)))))) ;;; Convert sieve-style regexps to POSIX: @@ -177,7 +190,10 @@ (lambda (exit) (for-each (lambda (key) - (let ((rx (if (eq? match #:matches) + (let ((header-fields (mu-message-get-header-fields + sieve-current-message + header-list)) + (rx (if (eq? match #:matches) (make-regexp (sieve-regexp-to-posix key) (if (eq? comp string-ci=?) regexp/icase @@ -185,7 +201,7 @@ #f))) (for-each (lambda (h) - (let ((hdr (mu-message-get-header sieve-current-message h))) + (let ((hdr (cdr h))) (if hdr (let ((naddr (mu-address-get-count hdr))) (do ((n 1 (1+ n))) @@ -211,7 +227,7 @@ (runtime-error LOG_NOTICE "Can't get address parts for message " sieve-current-message)))))))) - header-list))) + header-fields))) key-list) #f)))) @@ -227,15 +243,35 @@ (else (runtime-error LOG_CRIT "test-size: unknown comparator " comp))))) -(define (test-envelope part key-list . opt-list) - #f) +(define (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 + ;; Should we issue a warning? + ;;(runtime-error LOG_ERR "Envelope part " part " not supported") + #f))) + part-list) + #f)))) (define (test-exists header-list) (call-with-current-continuation (lambda (exit) (for-each (lambda (hdr) - (if (not (mu-message-get-header sieve-current-message hdr)) - (exit #f))) + (let ((val (mu-message-get-header sieve-current-message hdr))) + (if (or (not val) (= (string-length val) 0)) + (exit #f)))) header-list) #t))) @@ -246,7 +282,10 @@ (lambda (exit) (for-each (lambda (key) - (let ((rx (if (eq? match #:matches) + (let ((header-fields (mu-message-get-header-fields + sieve-current-message + header-list)) + (rx (if (eq? match #:matches) (make-regexp (sieve-regexp-to-posix key) (if (eq? comp string-ci=?) regexp/icase @@ -254,7 +293,7 @@ #f))) (for-each (lambda (h) - (let ((hdr (mu-message-get-header sieve-current-message h))) + (let ((hdr (cdr h))) (if hdr (case match ((#:is) @@ -266,7 +305,7 @@ ((#:matches) (if (regexp-exec rx hdr) (exit #t))))))) - header-list))) + header-fields))) key-list) #f)))) @@ -291,10 +330,10 @@ test-size size-comp (list 'number)) -; (sieve-register-test "envelope" -; test-envelope -; (append comparator address-part match-type) -; (list 'string-list 'string-list)) + (sieve-register-test "envelope" + test-envelope + (append comparator address-part match-type) + (list 'string-list 'string-list)) (sieve-register-test "exists" test-exists '() @@ -307,6 +346,7 @@ (sieve-register-test "true" #t '() '()))) ;;; runtime-error + (define (runtime-error level . text) (display (string-append "RUNTIME ERROR in " sieve-source ": ")) (for-each @@ -323,4 +363,7 @@ ((> n count) #f) (set! sieve-current-message (mu-mailbox-get-message current-mailbox n)) - (sieve-process-message)))) + (catch 'sieve-stop + sieve-process-message + (lambda args + #f))))) |