1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
;;;; GNU Mailutils -- a suite of utilities for electronic mail
;;;; Copyright (C) 1999-2001, 2007, 2010-2012 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)))
|
