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

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

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

revision 1.1 by schwab, Thu Jul 22 16:45:51 2004 UTC revision 1.2 by miles, Sat Sep 4 13:13:43 2004 UTC
# Line 0  Line 1 
1    ;;; sieve.el --- Utilities to manage sieve scripts
2    ;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
3    
4    ;; Author: Simon Josefsson <simon@josefsson.org>
5    
6    ;; This file is part of GNU Emacs.
7    
8    ;; GNU Emacs is free software; you can redistribute it and/or modify
9    ;; it under the terms of the GNU General Public License as published by
10    ;; the Free Software Foundation; either version 2, or (at your option)
11    ;; any later version.
12    
13    ;; GNU Emacs is distributed in the hope that it will be useful,
14    ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15    ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16    ;; GNU General Public License for more details.
17    
18    ;; You should have received a copy of the GNU General Public License
19    ;; along with GNU Emacs; see the file COPYING.  If not, write to the
20    ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21    ;; Boston, MA 02111-1307, USA.
22    
23    ;;; Commentary:
24    
25    ;; This file contain utilities to facilate upload, download and
26    ;; general management of sieve scripts.  Currently only the
27    ;; Managesieve protocol is supported (using sieve-manage.el), but when
28    ;; (useful) alternatives become available, they might be supported as
29    ;; well.
30    ;;
31    ;; The cursor navigation was inspired by biff-mode by Franklin Lee.
32    ;;
33    ;; Release history:
34    ;;
35    ;; 2001-10-31 Committed to Oort Gnus.
36    ;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode.  Fix menubar
37    ;;            in manage-mode.  Change some messages.  Added sieve-deactivate*,
38    ;;            sieve-remove.  Fixed help text in manage-mode.  Suggested by
39    ;;            Ned Ludd.
40    ;;
41    ;; Todo:
42    ;;
43    ;; * Namespace?  This file contains `sieve-manage' and
44    ;;   `sieve-manage-mode', but there is a sieve-manage.el file as well.
45    ;;   Can't think of a good solution though, this file need a *-mode,
46    ;;   and naming it `sieve-mode' would collide with sieve-mode.el.  One
47    ;;   solution would be to come up with some better name that this file
48    ;;   can use that doesn't have the managesieve specific "manage" in
49    ;;   it.  sieve-dired?  i dunno.  we could copy all off sieve.el into
50    ;;   sieve-manage.el too, but I'd like to separate the interface from
51    ;;   the protocol implementation since the backends are likely to
52    ;;   change (well).
53    ;;
54    ;; * Define servers?  We could have a customize buffer to create a server,
55    ;;   with authentication/stream/etc parameters, much like Gnus, and then
56    ;;   only use names of defined servers when interacting with M-x sieve-*.
57    ;;   Right now you can't use STARTTLS, which sieve-manage.el provides
58    
59    ;;; Code:
60    
61    (require 'sieve-manage)
62    (require 'sieve-mode)
63    
64    ;; User customizable variables:
65    
66    (defgroup sieve nil
67      "Manage sieve scripts."
68      :group 'tools)
69    
70    (defcustom sieve-new-script "<new script>"
71      "Name of name script indicator."
72      :type 'string
73      :group 'sieve)
74    
75    (defcustom sieve-buffer "*sieve*"
76      "Name of sieve management buffer."
77      :type 'string
78      :group 'sieve)
79    
80    (defcustom sieve-template "\
81    require \"fileinto\";
82    
83    # Example script (remove comment character '#' to make it effective!):
84    #
85    # if header :contains \"from\" \"coyote\" {
86    #   discard;
87    # } elsif header :contains [\"subject\"] [\"$$$\"] {
88    #   discard;
89    # } else {
90    #  fileinto \"INBOX\";
91    # }
92    "
93      "Template sieve script."
94      :type 'string
95      :group 'sieve)
96    
97    ;; Internal variables:
98    
99    (defvar sieve-manage-buffer nil)
100    (defvar sieve-buffer-header-end nil)
101    
102    ;; Sieve-manage mode:
103    
104    (defvar sieve-manage-mode-map nil
105      "Keymap for `sieve-manage-mode'.")
106    
107    (if sieve-manage-mode-map
108        ()
109      (setq sieve-manage-mode-map (make-sparse-keymap))
110      (suppress-keymap sieve-manage-mode-map)
111      ;; various
112      (define-key sieve-manage-mode-map "?" 'sieve-help)
113      (define-key sieve-manage-mode-map "h" 'sieve-help)
114      (define-key sieve-manage-mode-map "q" 'sieve-bury-buffer)
115      ;; activating
116      (define-key sieve-manage-mode-map "m" 'sieve-activate)
117      (define-key sieve-manage-mode-map "u" 'sieve-deactivate)
118      (define-key sieve-manage-mode-map "\M-\C-?" 'sieve-deactivate-all)
119      ;; navigation keys
120      (define-key sieve-manage-mode-map "\C-p" 'sieve-prev-line)
121      (define-key sieve-manage-mode-map [up] 'sieve-prev-line)
122      (define-key sieve-manage-mode-map "\C-n" 'sieve-next-line)
123      (define-key sieve-manage-mode-map [down] 'sieve-next-line)
124      (define-key sieve-manage-mode-map " " 'sieve-next-line)
125      (define-key sieve-manage-mode-map "n" 'sieve-next-line)
126      (define-key sieve-manage-mode-map "p" 'sieve-prev-line)
127      (define-key sieve-manage-mode-map "\C-m" 'sieve-edit-script)
128      (define-key sieve-manage-mode-map "f" 'sieve-edit-script)
129      (define-key sieve-manage-mode-map "o" 'sieve-edit-script-other-window)
130      (define-key sieve-manage-mode-map "r" 'sieve-remove)
131      (define-key sieve-manage-mode-map [(down-mouse-2)] 'sieve-edit-script)
132      (define-key sieve-manage-mode-map [(down-mouse-3)] 'sieve-manage-mode-menu))
133    
134    (easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map
135      "Sieve Menu."
136      '("Manage Sieve"
137        ["Edit script" sieve-edit-script t]
138        ["Activate script" sieve-activate t]
139        ["Deactivate script" sieve-deactivate t]))
140    
141    (define-derived-mode sieve-manage-mode fundamental-mode "SIEVE"
142      "Mode used for sieve script management."
143      (setq mode-name "SIEVE")
144      (buffer-disable-undo (current-buffer))
145      (setq truncate-lines t)
146      (easy-menu-add-item nil nil sieve-manage-mode-menu))
147    
148    (put 'sieve-manage-mode 'mode-class 'special)
149    
150    ;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
151    ;; in substitute-command-keys.
152    ;(fset 'sieve-manage-mode-map sieve-manage-mode-map)
153    
154    ;; Commands used in sieve-manage mode:
155    
156    (defun sieve-activate (&optional pos)
157      (interactive "d")
158      (let ((name (sieve-script-at-point)) err)
159        (when (or (null name) (string-equal name sieve-new-script))
160          (error "No sieve script at point"))
161        (message "Activating script %s..." name)
162        (setq err (sieve-manage-setactive name sieve-manage-buffer))
163        (sieve-refresh-scriptlist)
164        (if (sieve-manage-ok-p err)
165            (message "Activating script %s...done" name)
166          (message "Activating script %s...failed: %s" name (nth 2 err)))))
167    
168    (defun sieve-deactivate-all (&optional pos)
169      (interactive "d")
170      (let ((name (sieve-script-at-point)) err)
171        (message "Deactivating scripts...")
172        (setq err (sieve-manage-setactive "" sieve-manage-buffer))
173        (sieve-refresh-scriptlist)
174        (if (sieve-manage-ok-p err)
175            (message "Deactivating scripts...done")
176          (message "Deactivating scripts...failed: %s" (nth 2 err)))))
177    
178    (defalias 'sieve-deactivate 'sieve-deactivate-all)
179    
180    (defun sieve-remove (&optional pos)
181      (interactive "d")
182      (let ((name (sieve-script-at-point)) err)
183        (when (or (null name) (string-equal name sieve-new-script))
184          (error "No sieve script at point"))
185        (message "Removing sieve script %s..." name)
186        (setq err (sieve-manage-deletescript name sieve-manage-buffer))
187        (unless (sieve-manage-ok-p err)
188          (error "Removing sieve script %s...failed: " err))
189        (sieve-refresh-scriptlist)
190        (message "Removing sieve script %s...done" name)))
191    
192    (defun sieve-edit-script (&optional pos)
193      (interactive "d")
194      (let ((name (sieve-script-at-point)))
195        (unless name
196          (error "No sieve script at point"))
197        (if (not (string-equal name sieve-new-script))
198            (let ((newbuf (generate-new-buffer name))
199                  err)
200              (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer))
201              (switch-to-buffer newbuf)
202              (unless (sieve-manage-ok-p err)
203                (error "Sieve download failed: %s" err)))
204          (switch-to-buffer (get-buffer-create "template.siv"))
205          (insert sieve-template))
206        (sieve-mode)
207        (message "Press C-c C-l to upload script to server.")))
208    
209    (defmacro sieve-change-region (&rest body)
210      "Turns off sieve-region before executing BODY, then re-enables it after.
211    Used to bracket operations which move point in the sieve-buffer."
212      `(progn
213         (sieve-highlight nil)
214         ,@body
215         (sieve-highlight t)))
216    (put 'sieve-change-region 'lisp-indent-function 0)
217    
218    (defun sieve-next-line (&optional arg)
219      (interactive)
220      (unless arg
221        (setq arg 1))
222      (if (save-excursion
223            (forward-line arg)
224            (sieve-script-at-point))
225          (sieve-change-region
226            (forward-line arg))
227        (message "End of list")))
228    
229    (defun sieve-prev-line (&optional arg)
230      (interactive)
231      (unless arg
232        (setq arg -1))
233      (if (save-excursion
234            (forward-line arg)
235            (sieve-script-at-point))
236          (sieve-change-region
237            (forward-line arg))
238        (message "Beginning of list")))
239    
240    (defun sieve-help ()
241      "Display help for various sieve commands."
242      (interactive)
243      (if (eq last-command 'sieve-help)
244          ;; would need minor-mode for log-edit-mode
245          (describe-function 'sieve-mode)
246        (message (substitute-command-keys
247                  "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove"))))
248    
249    (defun sieve-bury-buffer (buf &optional mainbuf)
250      "Hide the buffer BUF that was temporarily popped up.
251    BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
252      (interactive (list (current-buffer)))
253      (save-current-buffer
254        (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
255                     (get-buffer-window buf t))))
256          (when win
257            (if (window-dedicated-p win)
258                (condition-case ()
259                    (delete-window win)
260                  (error (iconify-frame (window-frame win))))
261              (if (and mainbuf (get-buffer-window mainbuf))
262                  (delete-window win)))))
263        (with-current-buffer buf
264          (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
265                                    (not (window-dedicated-p (selected-window))))
266                         buf)))
267        (when mainbuf
268          (let ((mainwin (or (get-buffer-window mainbuf)
269                             (get-buffer-window mainbuf 'visible))))
270            (when mainwin (select-window mainwin))))))
271    
272    ;; Create buffer:
273    
274    (defun sieve-setup-buffer (server port)
275      (setq buffer-read-only nil)
276      (erase-buffer)
277      (buffer-disable-undo)
278      (insert "\
279    Server  : " server ":" (or port "2000") "
280    
281    ")
282      (set (make-local-variable 'sieve-buffer-header-end)
283           (point-max)))
284    
285    (defun sieve-script-at-point (&optional pos)
286      "Return name of sieve script at point POS, or nil."
287      (interactive "d")
288      (get-char-property (or pos (point)) 'script-name))
289    
290    (eval-and-compile
291      (defalias 'sieve-make-overlay (if (fboundp 'make-overlay)
292                                        'make-overlay
293                                      'make-extent))
294      (defalias 'sieve-overlay-put (if (fboundp 'overlay-put)
295                                       'overlay-put
296                                     'set-extent-property))
297      (defalias 'sieve-overlays-at (if (fboundp 'overlays-at)
298                                       'overlays-at
299                                     'extents-at)))
300    
301    (defun sieve-highlight (on)
302      "Turn ON or off highlighting on the current language overlay."
303      (sieve-overlay-put (car (sieve-overlays-at (point)))
304                         'face (if on 'highlight 'default)))
305    
306    (defun sieve-insert-scripts (scripts)
307      "Format and insert LANGUAGE-LIST strings into current buffer at point."
308      (while scripts
309        (let ((p (point))
310              (ext nil)
311              (script (pop scripts)))
312          (if (consp script)
313              (insert (format " ACTIVE %s" (cdr script)))
314            (insert (format "        %s" script)))
315          (setq ext (sieve-make-overlay p (point)))
316          (sieve-overlay-put ext 'mouse-face 'highlight)
317          (sieve-overlay-put ext 'script-name (if (consp script)
318                                                  (cdr script)
319                                                script))
320          (insert "\n"))))
321    
322    (defun sieve-open-server (server &optional port)
323      ;; open server
324      (set (make-local-variable 'sieve-manage-buffer)
325           (sieve-manage-open server))
326      ;; authenticate
327      (sieve-manage-authenticate nil nil sieve-manage-buffer))
328    
329    (defun sieve-refresh-scriptlist ()
330      (interactive)
331      (with-current-buffer sieve-buffer
332        (setq buffer-read-only nil)
333        (delete-region (or sieve-buffer-header-end (point-max)) (point-max))
334        (goto-char (point-max))
335        ;; get list of script names and print them
336        (let ((scripts (sieve-manage-listscripts sieve-manage-buffer)))
337          (if (null scripts)
338              (insert (format (concat "No scripts on server, press RET on %s to "
339                                      "create a new script.\n") sieve-new-script))
340            (insert (format (concat "%d script%s on server, press RET on a script "
341                                    "name edits it, or\npress RET on %s to create "
342                                    "a new script.\n") (length scripts)
343                                    (if (eq (length scripts) 1) "" "s")
344                                    sieve-new-script)))
345          (save-excursion
346            (sieve-insert-scripts (list sieve-new-script))
347            (sieve-insert-scripts scripts)))
348        (sieve-highlight t)
349        (setq buffer-read-only t)))
350    
351    ;;;###autoload
352    (defun sieve-manage (server &optional port)
353      (interactive "sServer: ")
354      (switch-to-buffer (get-buffer-create sieve-buffer))
355      (sieve-manage-mode)
356      (sieve-setup-buffer server port)
357      (if (sieve-open-server server port)
358          (sieve-refresh-scriptlist)
359        (message "Could not open server %s" server)))
360    
361    ;;;###autoload
362    (defun sieve-upload (&optional name)
363      (interactive)
364      (unless name
365        (setq name (buffer-name)))
366      (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
367        (let ((script (buffer-string)) err)
368          (with-current-buffer (get-buffer sieve-buffer)
369            (setq err (sieve-manage-putscript name script sieve-manage-buffer))
370            (if (sieve-manage-ok-p err)
371                (message (concat
372                          "Sieve upload done.  Use `C-c RET' to manage scripts."))
373              (message "Sieve upload failed: %s" (nth 2 err)))))))
374    
375    ;;;###autoload
376    (defun sieve-upload-and-bury (&optional name)
377      (interactive)
378      (sieve-upload name)
379      (bury-buffer))
380    
381    (provide 'sieve)
382    
383    ;;; arch-tag: 7f6a6d94-94e1-4654-ab9a-aee21b9b8a94
384    ;; 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