sieve.el (sieve-edit-script): Avoid beginning-of-buffer
[gnus] / lisp / sieve.el
1 ;;; sieve.el --- Utilities to manage sieve scripts
2
3 ;; Copyright (C) 2001-2013 Free Software Foundation, Inc.
4
5 ;; Author: 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 3 of the License, or
12 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
21
22 ;;; Commentary:
23
24 ;; This file contain utilities to facilitate upload, download and
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."
67   :version "22.1"
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 (defvar sieve-buffer-script-name nil
102   "The real script name of the buffer.")
103 (make-local-variable 'sieve-buffer-script-name)
104
105 ;; Sieve-manage mode:
106
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     ;; activating
113     (define-key map "m" 'sieve-activate)
114     (define-key map "u" 'sieve-deactivate)
115     (define-key map "\M-\C-?" 'sieve-deactivate-all)
116     ;; navigation keys
117     (define-key map "\C-p" 'sieve-prev-line)
118     (define-key map [up] 'sieve-prev-line)
119     (define-key map "\C-n" 'sieve-next-line)
120     (define-key map [down] 'sieve-next-line)
121     (define-key map " " 'sieve-next-line)
122     (define-key map "n" 'sieve-next-line)
123     (define-key map "p" 'sieve-prev-line)
124     (define-key map "\C-m" 'sieve-edit-script)
125     (define-key map "f" 'sieve-edit-script)
126     (define-key map "o" 'sieve-edit-script-other-window)
127     (define-key map "r" 'sieve-remove)
128     (define-key map "q" 'sieve-bury-buffer)
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)
133   "Keymap for `sieve-manage-mode'.")
134
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
142 (define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage"
143   "Mode used for sieve script management."
144   (buffer-disable-undo (current-buffer))
145   (setq truncate-lines t)
146   (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map))
147
148 (put 'sieve-manage-mode 'mode-class 'special)
149
150 ;; Commands used in sieve-manage mode:
151
152 (defun sieve-manage-quit ()
153   "Quit Manage Sieve and close the connection."
154   (interactive)
155   (sieve-manage-close sieve-manage-buffer)
156   (kill-buffer sieve-manage-buffer)
157   (kill-buffer (current-buffer)))
158
159 (defun sieve-bury-buffer ()
160   "Bury the Manage Sieve buffer without closing the connection."
161   (interactive)
162   (bury-buffer))
163
164 (defun sieve-activate (&optional pos)
165   (interactive "d")
166   (let ((name (sieve-script-at-point)) err)
167     (when (or (null name) (string-equal name sieve-new-script))
168       (error "No sieve script at point"))
169     (message "Activating script %s..." name)
170     (setq err (sieve-manage-setactive name sieve-manage-buffer))
171     (sieve-refresh-scriptlist)
172     (if (sieve-manage-ok-p err)
173         (message "Activating script %s...done" name)
174       (message "Activating script %s...failed: %s" name (nth 2 err)))))
175
176 (defun sieve-deactivate-all (&optional pos)
177   (interactive "d")
178   (let ((name (sieve-script-at-point)) err)
179     (message "Deactivating scripts...")
180     (setq err (sieve-manage-setactive "" sieve-manage-buffer))
181     (sieve-refresh-scriptlist)
182     (if (sieve-manage-ok-p err)
183         (message "Deactivating scripts...done")
184       (message "Deactivating scripts...failed: %s" (nth 2 err)))))
185
186 (defalias 'sieve-deactivate 'sieve-deactivate-all)
187
188 (defun sieve-remove (&optional pos)
189   (interactive "d")
190   (let ((name (sieve-script-at-point)) err)
191     (when (or (null name) (string-equal name sieve-new-script))
192       (error "No sieve script at point"))
193     (message "Removing sieve script %s..." name)
194     (setq err (sieve-manage-deletescript name sieve-manage-buffer))
195     (unless (sieve-manage-ok-p err)
196       (error "Removing sieve script %s...failed: " err))
197     (sieve-refresh-scriptlist)
198     (message "Removing sieve script %s...done" name)))
199
200 (defun sieve-edit-script (&optional pos)
201   (interactive "d")
202   (let ((name (sieve-script-at-point)))
203     (unless name
204       (error "No sieve script at point"))
205     (if (not (string-equal name sieve-new-script))
206         (let ((newbuf (generate-new-buffer name))
207               err)
208           (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer))
209           (switch-to-buffer newbuf)
210           (unless (sieve-manage-ok-p err)
211             (error "Sieve download failed: %s" err)))
212       (switch-to-buffer (get-buffer-create "template.siv"))
213       (insert sieve-template))
214     (sieve-mode)
215     (setq sieve-buffer-script-name name)
216     (goto-char (point-min))
217     (message
218      (substitute-command-keys
219       "Press \\[sieve-upload] to upload script to server."))))
220
221 (defmacro sieve-change-region (&rest body)
222   "Turns off sieve-region before executing BODY, then re-enables it after.
223 Used to bracket operations which move point in the sieve-buffer."
224   `(progn
225      (sieve-highlight nil)
226      ,@body
227      (sieve-highlight t)))
228 (put 'sieve-change-region 'lisp-indent-function 0)
229
230 (defun sieve-next-line (&optional arg)
231   (interactive)
232   (unless arg
233     (setq arg 1))
234   (if (save-excursion
235         (forward-line arg)
236         (sieve-script-at-point))
237       (sieve-change-region
238         (forward-line arg))
239     (message "End of list")))
240
241 (defun sieve-prev-line (&optional arg)
242   (interactive)
243   (unless arg
244     (setq arg -1))
245   (if (save-excursion
246         (forward-line arg)
247         (sieve-script-at-point))
248       (sieve-change-region
249         (forward-line arg))
250     (message "Beginning of list")))
251
252 (defun sieve-help ()
253   "Display help for various sieve commands."
254   (interactive)
255   (if (eq last-command 'sieve-help)
256       ;; would need minor-mode for log-edit-mode
257       (describe-function 'sieve-mode)
258     (message "%s" (substitute-command-keys
259               "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove"))))
260
261 ;; Create buffer:
262
263 (defun sieve-setup-buffer (server port)
264   (setq buffer-read-only nil)
265   (erase-buffer)
266   (buffer-disable-undo)
267   (let* ((port (or port sieve-manage-default-port))
268          (header (format "Server : %s:%s\n\n" server port)))
269     (insert header))
270   (set (make-local-variable 'sieve-buffer-header-end)
271        (point-max)))
272
273 (defun sieve-script-at-point (&optional pos)
274   "Return name of sieve script at point POS, or nil."
275   (interactive "d")
276   (get-char-property (or pos (point)) 'script-name))
277
278 (eval-and-compile
279   (defalias 'sieve-make-overlay (if (featurep 'xemacs)
280                                     'make-extent
281                                   'make-overlay))
282   (defalias 'sieve-overlay-put (if (featurep 'xemacs)
283                                    'set-extent-property
284                                  'overlay-put))
285   (defalias 'sieve-overlays-at (if  (featurep 'xemacs)
286                                    'extents-at
287                                  'overlays-at)))
288
289 (defun sieve-highlight (on)
290   "Turn ON or off highlighting on the current language overlay."
291   (sieve-overlay-put (car (sieve-overlays-at (point)))
292                      'face (if on 'highlight 'default)))
293
294 (defun sieve-insert-scripts (scripts)
295   "Format and insert LANGUAGE-LIST strings into current buffer at point."
296   (while scripts
297     (let ((p (point))
298           (ext nil)
299           (script (pop scripts)))
300       (if (consp script)
301           (insert (format " ACTIVE %s" (cdr script)))
302         (insert (format "        %s" script)))
303       (setq ext (sieve-make-overlay p (point)))
304       (sieve-overlay-put ext 'mouse-face 'highlight)
305       (sieve-overlay-put ext 'script-name (if (consp script)
306                                               (cdr script)
307                                             script))
308       (insert "\n"))))
309
310 (defun sieve-open-server (server &optional port)
311   "Open SERVER (on PORT) and authenticate."
312   (with-current-buffer
313       (or ;; open server
314        (set (make-local-variable 'sieve-manage-buffer)
315             (sieve-manage-open server port))
316        (error "Error opening server %s" server))
317     (sieve-manage-authenticate)))
318
319 (defun sieve-refresh-scriptlist ()
320   (interactive)
321   (with-current-buffer sieve-buffer
322     (setq buffer-read-only nil)
323     (delete-region (or sieve-buffer-header-end (point-max)) (point-max))
324     (goto-char (point-max))
325     ;; get list of script names and print them
326     (let ((scripts (sieve-manage-listscripts sieve-manage-buffer)))
327       (if (null scripts)
328           (insert
329            (substitute-command-keys
330             (format
331              "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n"
332              sieve-new-script)))
333         (insert
334          (substitute-command-keys
335           (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script "
336                           "name edits it, or\npress \\[sieve-edit-script] on %s to create "
337                           "a new script.\n") (length scripts)
338                           (if (eq (length scripts) 1) "" "s")
339                           sieve-new-script))))
340       (save-excursion
341         (sieve-insert-scripts (list sieve-new-script))
342         (sieve-insert-scripts scripts)))
343     (sieve-highlight t)
344     (setq buffer-read-only t)))
345
346 ;;;###autoload
347 (defun sieve-manage (server &optional port)
348   (interactive "sServer: ")
349   (switch-to-buffer (get-buffer-create sieve-buffer))
350   (sieve-manage-mode)
351   (sieve-setup-buffer server port)
352   (if (sieve-open-server server port)
353       (sieve-refresh-scriptlist)
354     (message "Could not open server %s" server)))
355
356 ;;;###autoload
357 (defun sieve-upload (&optional name)
358   (interactive)
359   (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
360     (let ((script (buffer-string)) err)
361       (with-current-buffer (get-buffer sieve-buffer)
362         (setq err (sieve-manage-putscript
363                    (or name sieve-buffer-script-name (buffer-name))
364                    script sieve-manage-buffer))
365         (if (sieve-manage-ok-p err)
366             (message (substitute-command-keys
367                       "Sieve upload done.  Use \\[sieve-manage] to manage scripts."))
368           (message "Sieve upload failed: %s" (nth 2 err)))))))
369
370 ;;;###autoload
371 (defun sieve-upload-and-bury (&optional name)
372   (interactive)
373   (sieve-upload name)
374   (bury-buffer))
375
376 ;;;###autoload
377 (defun sieve-upload-and-kill (&optional name)
378   (interactive)
379   (sieve-upload name)
380   (kill-buffer))
381
382 (provide 'sieve)
383
384 ;; sieve.el ends here