Mercurial > emacs
comparison lisp/gnus/sieve.el @ 56927:55fd4f77387a after-merge-gnus-5_10
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Merge from emacs--gnus--5.10, gnus--rel--5.10
Patches applied:
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0
tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1
Import from CVS branch gnus-5_10-branch
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2
Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18
Update from CVS
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19
Remove autoconf-generated files from archive
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20
Update from CVS
author | Miles Bader <miles@gnu.org> |
---|---|
date | Sat, 04 Sep 2004 13:13:48 +0000 |
parents | |
children | df80d19d7a2e |
comparison
equal
deleted
inserted
replaced
56926:f8e248e9a717 | 56927:55fd4f77387a |
---|---|
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 |