lisp/gnus/sieve.el

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