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