From 6fab28ed5d7022c5ef248b849996e6296b113d6f Mon Sep 17 00:00:00 2001
From: Sergey Poznyakoff <gray@gnu.org.ua>
Date: Fri, 19 Apr 2002 12:31:22 +0000
Subject: Implements "mimeheader" extension test. The test is similar to
 "header" but works on multipart MIME messages also.

---
 guimb/scm/mimeheader.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 83 insertions(+)
 create mode 100644 guimb/scm/mimeheader.scm

(limited to 'guimb')

diff --git a/guimb/scm/mimeheader.scm b/guimb/scm/mimeheader.scm
new file mode 100644
index 000000000..2f904276a
--- /dev/null
+++ b/guimb/scm/mimeheader.scm
@@ -0,0 +1,83 @@
+;;;; 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]
+;;;;           <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
+			 (append comparator match-type)
+			 (list 'string-list 'string-list)))
-- 
cgit v1.2.1