/[emacs]/emacs/lisp/gnus/gnus-sieve.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-sieve.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by schwab, Thu Jul 22 16:45:48 2004 UTC revision 1.2 by miles, Sat Sep 4 13:13:43 2004 UTC
# Line 0  Line 1 
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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26