diff lisp/gnus/gnus-sieve.el @ 56927:55fd4f77387a after-merge-gnus-5_10

Revision: [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-523 Merge from emacs--gnus--5.10, gnus--rel--5.10 Patches applied: * [e-mail]--gnu-2004/emacs--gnus--5.10--base-0 tag of [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-464 * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-1 Import from CVS branch gnus-5_10-branch * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-2 Merge from [e-mail]--2004/emacs--multi-tty--0, emacs--cvs-trunk--0 * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-3 Merge from gnus--rel--5.10 * [e-mail]--gnu-2004/emacs--gnus--5.10--patch-4 Merge from gnus--rel--5.10 * [e-mail]--gnu-2004/gnus--rel--5.10--patch-18 Update from CVS * [e-mail]--gnu-2004/gnus--rel--5.10--patch-19 Remove autoconf-generated files from archive * [e-mail]--gnu-2004/gnus--rel--5.10--patch-20 Update from CVS

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/gnus/gnus-sieve.el	Sat Sep 04 13:13:48 2004 +0000
@@ -0,0 +1,240 @@
+;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
+;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
+
+;; Author: NAGY Andras <[e-mail]>,
+;;	Simon Josefsson <[e-mail]>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Gnus glue to generate complete Sieve scripts from Gnus Group
+;; Parameters with "if" test predicates.
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-sum)
+(require 'format-spec)
+(autoload 'sieve-mode "sieve-mode")
+(eval-when-compile
+  (require 'sieve))
+
+;; Variables
+
+(defgroup gnus-sieve nil
+  "Manage sieve scripts in Gnus."
+  :group 'gnus)
+
+(defcustom gnus-sieve-file "~/.sieve"
+  "Path to your Sieve script."
+  :type 'file
+  :group 'gnus-sieve)
+
+(defcustom gnus-sieve-region-start "\n## Begin Gnus Sieve Script\n"
+  "Line indicating the start of the autogenerated region in
+your Sieve script."
+  :type 'string
+  :group 'gnus-sieve)
+
+(defcustom gnus-sieve-region-end "\n## End Gnus Sieve Script\n"
+  "Line indicating the end of the autogenerated region in
+your Sieve script."
+  :type 'string
+  :group 'gnus-sieve)
+
+(defcustom gnus-sieve-select-method nil
+  "Which select method we generate the Sieve script for.
+
+For example: \"nnimap:mailbox\""
+  :group 'gnus-sieve)
+
+(defcustom gnus-sieve-crosspost t
+  "Whether the generated Sieve script should do crossposting."
+  :type 'boolean
+  :group 'gnus-sieve)
+
+(defcustom gnus-sieve-update-shell-command "echo put %f | sieveshell %s"
+  "Shell command to execute after updating your Sieve script.  The following
+formatting characters are recognized:
+
+%f    Script's file name (gnus-sieve-file)
+%s    Server name (from gnus-sieve-select-method)"
+  :type 'string
+  :group 'gnus-sieve)
+
+;;;###autoload
+(defun gnus-sieve-update ()
+  "Update the Sieve script in gnus-sieve-file, by replacing the region
+between gnus-sieve-region-start and gnus-sieve-region-end with
+\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\), then
+execute gnus-sieve-update-shell-command.
+See the documentation for these variables and functions for details."
+  (interactive)
+  (gnus-sieve-generate)
+  (save-buffer)
+  (shell-command
+   (format-spec gnus-sieve-update-shell-command
+		(format-spec-make ?f gnus-sieve-file
+				  ?s (or (cadr (gnus-server-get-method
+						nil gnus-sieve-select-method))
+					 "")))))
+
+;;;###autoload
+(defun gnus-sieve-generate ()
+  "Generate the Sieve script in gnus-sieve-file, by replacing the region
+between gnus-sieve-region-start and gnus-sieve-region-end with
+\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\).
+See the documentation for these variables and functions for details."
+  (interactive)
+  (require 'sieve)
+  (find-file gnus-sieve-file)
+  (goto-char (point-min))
+  (if (re-search-forward (regexp-quote gnus-sieve-region-start) nil t)
+      (delete-region (match-end 0)
+		     (or (re-search-forward (regexp-quote
+					     gnus-sieve-region-end) nil t)
+			 (point)))
+    (insert sieve-template))
+  (insert gnus-sieve-region-start
+	  (gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost)
+	  gnus-sieve-region-end))
+
+(defun gnus-sieve-guess-rule-for-article ()
+  "Guess a sieve rule based on RFC822 article in buffer.
+Return nil if no rule could be guessed."
+  (when (message-fetch-field "sender")
+    `(sieve address "sender" ,(message-fetch-field "sender"))))
+
+;;;###autoload
+(defun gnus-sieve-article-add-rule ()
+  (interactive)
+  (gnus-summary-select-article nil 'force)
+  (with-current-buffer gnus-original-article-buffer
+    (let ((rule (gnus-sieve-guess-rule-for-article))
+	  (info (gnus-get-info gnus-newsgroup-name)))
+      (if (null rule)
+	  (error "Could not guess rule for article.")
+	(gnus-info-set-params info (cons rule (gnus-info-params info)))
+	(message "Added rule in group %s for article: %s" gnus-newsgroup-name
+		 rule)))))
+
+;; Internals
+
+;; FIXME: do proper quoting of " etc
+(defun gnus-sieve-string-list (list)
+  "Convert an elisp string list to a Sieve string list.
+
+For example:
+\(gnus-sieve-string-list '(\"to\" \"cc\"))
+  => \"[\\\"to\\\", \\\"cc\\\"]\"
+"
+  (concat "[\"" (mapconcat 'identity list "\", \"") "\"]"))
+
+(defun gnus-sieve-test-list (list)
+  "Convert an elisp test list to a Sieve test list.
+
+For example:
+\(gnus-sieve-test-list '((address \"sender\" \"[e-mail]\") (size :over 4K)))
+  => \"(address \\\"sender\\\" \\\"[e-mail]\\\", size :over 4K)\""
+  (concat "(" (mapconcat 'gnus-sieve-test list ", ") ")"))
+
+;; FIXME: do proper quoting
+(defun gnus-sieve-test-token (token)
+  "Convert an elisp test token to a Sieve test token.
+
+For example:
+\(gnus-sieve-test-token 'address)
+  => \"address\"
+
+\(gnus-sieve-test-token \"sender\")
+  => \"\\\"sender\\\"\"
+
+\(gnus-sieve-test-token '(\"to\" \"cc\"))
+  => \"[\\\"to\\\", \\\"cc\\\"]\""
+  (cond
+   ((symbolp token)            ;; Keyword
+    (symbol-name token))
+
+   ((stringp token)            ;; String
+    (concat "\"" token "\""))
+
+   ((and (listp token)         ;; String list
+	 (stringp (car token)))
+    (gnus-sieve-string-list token))
+
+   ((and (listp token)         ;; Test list
+	 (listp (car token)))
+    (gnus-sieve-test-list token))))
+
+(defun gnus-sieve-test (test)
+  "Convert an elisp test to a Sieve test.
+
+For example:
+\(gnus-sieve-test '(address \"sender\" \"[e-mail]\"))
+  => \"address \\\"sender\\\" \\\"[e-mail]\\\"\"
+
+\(gnus-sieve-test '(anyof ((header :contains (\"to\" \"cc\") \"[e-mail]\")
+			  (size :over 100K))))
+  => \"anyof (header :contains [\\\"to\\\", \\\"cc\\\"] \\\"[e-mail]\\\",
+	     size :over 100K)\""
+  (mapconcat 'gnus-sieve-test-token test " "))
+
+(defun gnus-sieve-script (&optional method crosspost)
+  "Generate a Sieve script based on groups with select method METHOD
+\(or all groups if nil\).  Only groups having a `sieve' parameter are
+considered.  This parameter should contain an elisp test
+\(see the documentation of gnus-sieve-test for details\).  For each
+such group, a Sieve IF control structure is generated, having the
+test as the condition and { fileinto \"group.name\"; } as the body.
+
+If CROSSPOST is nil, each conditional body contains a \"stop\" command
+which stops execution after a match is found.
+
+For example: If the INBOX.list.sieve group has the
+
+  (sieve address \"sender\" \"[e-mail]\")
+
+group parameter, (gnus-sieve-script) results in:
+
+  if address \"sender\" \"[e-mail]\" {
+          fileinto \"INBOX.list.sieve\";
+  }
+
+This is returned as a string."
+  (let* ((newsrc (cdr gnus-newsrc-alist))
+	 script)
+    (dolist (info newsrc)
+      (when (or (not method)
+		(gnus-server-equal method (gnus-info-method info)))
+	(let* ((group (gnus-info-group info))
+	       (spec (gnus-group-find-parameter group 'sieve t)))
+	  (when spec
+	    (push (concat "if " (gnus-sieve-test spec) " {\n"
+			  "\tfileinto \"" (gnus-group-real-name group) "\";\n"
+			  (if crosspost
+			      ""
+			    "\tstop;\n")
+			  "}")
+		  script)))))
+    (mapconcat 'identity script "\n")))
+
+(provide 'gnus-sieve)
+
+;;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3
+;;; gnus-sieve.el ends here