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