1;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus 2 3;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 4 5;; Author: NAGY Andras <nagya@inf.elte.hu>, 6;; Simon Josefsson <simon@josefsson.org> 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to the 22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; Boston, MA 02110-1301, USA. 24 25;;; Commentary: 26 27;; Gnus glue to generate complete Sieve scripts from Gnus Group 28;; Parameters with "if" test predicates. 29 30;;; Code: 31 32(require 'gnus) 33(require 'gnus-sum) 34(require 'format-spec) 35(autoload 'sieve-mode "sieve-mode") 36(eval-when-compile 37 (require 'sieve)) 38 39;; Variables 40 41(defgroup gnus-sieve nil 42 "Manage sieve scripts in Gnus." 43 :group 'gnus) 44 45(defcustom gnus-sieve-file "~/.sieve" 46 "Path to your Sieve script." 47 :type 'file 48 :group 'gnus-sieve) 49 50(defcustom gnus-sieve-region-start "\n## Begin Gnus Sieve Script\n" 51 "Line indicating the start of the autogenerated region in 52your Sieve script." 53 :type 'string 54 :group 'gnus-sieve) 55 56(defcustom gnus-sieve-region-end "\n## End Gnus Sieve Script\n" 57 "Line indicating the end of the autogenerated region in 58your Sieve script." 59 :type 'string 60 :group 'gnus-sieve) 61 62(defcustom gnus-sieve-select-method nil 63 "Which select method we generate the Sieve script for. 64 65For example: \"nnimap:mailbox\"" 66 :group 'gnus-sieve) 67 68(defcustom gnus-sieve-crosspost t 69 "Whether the generated Sieve script should do crossposting." 70 :type 'boolean 71 :group 'gnus-sieve) 72 73(defcustom gnus-sieve-update-shell-command "echo put %f | sieveshell %s" 74 "Shell command to execute after updating your Sieve script. The following 75formatting characters are recognized: 76 77%f Script's file name (gnus-sieve-file) 78%s Server name (from gnus-sieve-select-method)" 79 :type 'string 80 :group 'gnus-sieve) 81 82;;;###autoload 83(defun gnus-sieve-update () 84 "Update the Sieve script in gnus-sieve-file, by replacing the region 85between gnus-sieve-region-start and gnus-sieve-region-end with 86\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\), then 87execute gnus-sieve-update-shell-command. 88See the documentation for these variables and functions for details." 89 (interactive) 90 (gnus-sieve-generate) 91 (save-buffer) 92 (shell-command 93 (format-spec gnus-sieve-update-shell-command 94 (format-spec-make ?f gnus-sieve-file 95 ?s (or (cadr (gnus-server-get-method 96 nil gnus-sieve-select-method)) 97 ""))))) 98 99;;;###autoload 100(defun gnus-sieve-generate () 101 "Generate the Sieve script in gnus-sieve-file, by replacing the region 102between gnus-sieve-region-start and gnus-sieve-region-end with 103\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\). 104See the documentation for these variables and functions for details." 105 (interactive) 106 (require 'sieve) 107 (find-file gnus-sieve-file) 108 (goto-char (point-min)) 109 (if (re-search-forward (regexp-quote gnus-sieve-region-start) nil t) 110 (delete-region (match-beginning 0) 111 (or (re-search-forward (regexp-quote 112 gnus-sieve-region-end) nil t) 113 (point))) 114 (insert sieve-template)) 115 (insert gnus-sieve-region-start 116 (gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost) 117 gnus-sieve-region-end)) 118 119(defun gnus-sieve-guess-rule-for-article () 120 "Guess a sieve rule based on RFC822 article in buffer. 121Return nil if no rule could be guessed." 122 (when (message-fetch-field "sender") 123 `(sieve address "sender" ,(message-fetch-field "sender")))) 124 125;;;###autoload 126(defun gnus-sieve-article-add-rule () 127 (interactive) 128 (gnus-summary-select-article nil 'force) 129 (with-current-buffer gnus-original-article-buffer 130 (let ((rule (gnus-sieve-guess-rule-for-article)) 131 (info (gnus-get-info gnus-newsgroup-name))) 132 (if (null rule) 133 (error "Could not guess rule for article") 134 (gnus-info-set-params info (cons rule (gnus-info-params info))) 135 (message "Added rule in group %s for article: %s" gnus-newsgroup-name 136 rule))))) 137 138;; Internals 139 140;; FIXME: do proper quoting of " etc 141(defun gnus-sieve-string-list (list) 142 "Convert an elisp string list to a Sieve string list. 143 144For example: 145\(gnus-sieve-string-list '(\"to\" \"cc\")) 146 => \"[\\\"to\\\", \\\"cc\\\"]\" 147" 148 (concat "[\"" (mapconcat 'identity list "\", \"") "\"]")) 149 150(defun gnus-sieve-test-list (list) 151 "Convert an elisp test list to a Sieve test list. 152 153For example: 154\(gnus-sieve-test-list '((address \"sender\" \"boss@company.com\") (size :over 4K))) 155 => \"(address \\\"sender\\\" \\\"boss@company.com\\\", size :over 4K)\"" 156 (concat "(" (mapconcat 'gnus-sieve-test list ", ") ")")) 157 158;; FIXME: do proper quoting 159(defun gnus-sieve-test-token (token) 160 "Convert an elisp test token to a Sieve test token. 161 162For example: 163\(gnus-sieve-test-token 'address) 164 => \"address\" 165 166\(gnus-sieve-test-token \"sender\") 167 => \"\\\"sender\\\"\" 168 169\(gnus-sieve-test-token '(\"to\" \"cc\")) 170 => \"[\\\"to\\\", \\\"cc\\\"]\"" 171 (cond 172 ((symbolp token) ;; Keyword 173 (symbol-name token)) 174 175 ((stringp token) ;; String 176 (concat "\"" token "\"")) 177 178 ((and (listp token) ;; String list 179 (stringp (car token))) 180 (gnus-sieve-string-list token)) 181 182 ((and (listp token) ;; Test list 183 (listp (car token))) 184 (gnus-sieve-test-list token)))) 185 186(defun gnus-sieve-test (test) 187 "Convert an elisp test to a Sieve test. 188 189For example: 190\(gnus-sieve-test '(address \"sender\" \"sieve-admin@extundo.com\")) 191 => \"address \\\"sender\\\" \\\"sieve-admin@extundo.com\\\"\" 192 193\(gnus-sieve-test '(anyof ((header :contains (\"to\" \"cc\") \"my@address.com\") 194 (size :over 100K)))) 195 => \"anyof (header :contains [\\\"to\\\", \\\"cc\\\"] \\\"my@address.com\\\", 196 size :over 100K)\"" 197 (mapconcat 'gnus-sieve-test-token test " ")) 198 199(defun gnus-sieve-script (&optional method crosspost) 200 "Generate a Sieve script based on groups with select method METHOD 201\(or all groups if nil\). Only groups having a `sieve' parameter are 202considered. This parameter should contain an elisp test 203\(see the documentation of gnus-sieve-test for details\). For each 204such group, a Sieve IF control structure is generated, having the 205test as the condition and { fileinto \"group.name\"; } as the body. 206 207If CROSSPOST is nil, each conditional body contains a \"stop\" command 208which stops execution after a match is found. 209 210For example: If the INBOX.list.sieve group has the 211 212 (sieve address \"sender\" \"sieve-admin@extundo.com\") 213 214group parameter, (gnus-sieve-script) results in: 215 216 if address \"sender\" \"sieve-admin@extundo.com\" { 217 fileinto \"INBOX.list.sieve\"; 218 } 219 220This is returned as a string." 221 (let* ((newsrc (cdr gnus-newsrc-alist)) 222 script) 223 (dolist (info newsrc) 224 (when (or (not method) 225 (gnus-server-equal method (gnus-info-method info))) 226 (let* ((group (gnus-info-group info)) 227 (spec (gnus-group-find-parameter group 'sieve t))) 228 (when spec 229 (push (concat "if " (gnus-sieve-test spec) " {\n" 230 "\tfileinto \"" (gnus-group-real-name group) "\";\n" 231 (if crosspost 232 "" 233 "\tstop;\n") 234 "}") 235 script))))) 236 (mapconcat 'identity script "\n"))) 237 238(provide 'gnus-sieve) 239 240;;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3 241;;; gnus-sieve.el ends here 242