;;;; GNU mailutils - a suite of utilities for electronic mail ;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. ;;;; ;;;; This program 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 2, or (at your option) ;;;; any later version. ;;;; ;;;; This program 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 this program; if not, write to the Free Software ;;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; This module provides GNU extension test "mimeheader". ;;;; Syntax: mimeheader [COMPARATOR] [MATCH-TYPE] ;;;; ;;;; ;;;; The "mimeheader" test evaluates to true if in any part of the ;;;; multipart MIME message a header name from list ;;;; matches any key from . 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 (append comparator match-type) (list 'string-list 'string-list)))