lisp/gnus/sieve.el

   1 ;;; sieve.el --- Utilities to manage sieve scripts
   2
   3 ;; Copyright (C) 2001-2012 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     (define-key map "q" 'kill-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)
 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."
 154   (interactive)
 155   (kill-buffer (current-buffer)))
 156
 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)
 208     (setq sieve-buffer-script-name name)
 209     (message
 210      (substitute-command-keys
 211       "Press \\[sieve-upload] to upload script to server."))))
 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)
 250     (message "%s" (substitute-command-keys
 251               "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove"))))
 252
 253 ;; Create buffer:
 254
 255 (defun sieve-setup-buffer (server port)
 256   (setq buffer-read-only nil)
 257   (erase-buffer)
 258   (buffer-disable-undo)
 259   (insert "\
 260 Server  : " server ":" (or port "2000") "
 261
 262 ")
 263   (set (make-local-variable 'sieve-buffer-header-end)
 264        (point-max)))
 265
 266 (defun sieve-script-at-point (&optional pos)
 267   "Return name of sieve script at point POS, or nil."
 268   (interactive "d")
 269   (get-char-property (or pos (point)) 'script-name))
 270
 271 (eval-and-compile
 272   (defalias 'sieve-make-overlay (if (featurep 'xemacs)
 273                                     'make-extent
 274                                   'make-overlay))
 275   (defalias 'sieve-overlay-put (if (featurep 'xemacs)
 276                                    'set-extent-property
 277                                  'overlay-put))
 278   (defalias 'sieve-overlays-at (if  (featurep 'xemacs)
 279                                    'extents-at
 280                                  'overlays-at)))
 281
 282 (defun sieve-highlight (on)
 283   "Turn ON or off highlighting on the current language overlay."
 284   (sieve-overlay-put (car (sieve-overlays-at (point)))
 285                      'face (if on 'highlight 'default)))
 286
 287 (defun sieve-insert-scripts (scripts)
 288   "Format and insert LANGUAGE-LIST strings into current buffer at point."
 289   (while scripts
 290     (let ((p (point))
 291           (ext nil)
 292           (script (pop scripts)))
 293       (if (consp script)
 294           (insert (format " ACTIVE %s" (cdr script)))
 295         (insert (format "        %s" script)))
 296       (setq ext (sieve-make-overlay p (point)))
 297       (sieve-overlay-put ext 'mouse-face 'highlight)
 298       (sieve-overlay-put ext 'script-name (if (consp script)
 299                                               (cdr script)
 300                                             script))
 301       (insert "\n"))))
 302
 303 (defun sieve-open-server (server &optional port)
 304   "Open SERVER (on PORT) and authenticate."
 305   (with-current-buffer
 306       (or ;; open server
 307        (set (make-local-variable 'sieve-manage-buffer)
 308             (sieve-manage-open server))
 309        (error "Error opening server %s" server))
 310     (sieve-manage-authenticate)))
 311
 312 (defun sieve-refresh-scriptlist ()
 313   (interactive)
 314   (with-current-buffer sieve-buffer
 315     (setq buffer-read-only nil)
 316     (delete-region (or sieve-buffer-header-end (point-max)) (point-max))
 317     (goto-char (point-max))
 318     ;; get list of script names and print them
 319     (let ((scripts (sieve-manage-listscripts sieve-manage-buffer)))
 320       (if (null scripts)
 321           (insert
 322            (substitute-command-keys
 323             (format
 324              "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n"
 325              sieve-new-script)))
 326         (insert
 327          (substitute-command-keys
 328           (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script "
 329                           "name edits it, or\npress \\[sieve-edit-script] on %s to create "
 330                           "a new script.\n") (length scripts)
 331                           (if (eq (length scripts) 1) "" "s")
 332                           sieve-new-script))))
 333       (save-excursion
 334         (sieve-insert-scripts (list sieve-new-script))
 335         (sieve-insert-scripts scripts)))
 336     (sieve-highlight t)
 337     (setq buffer-read-only t)))
 338
 339 ;;;###autoload
 340 (defun sieve-manage (server &optional port)
 341   (interactive "sServer: ")
 342   (switch-to-buffer (get-buffer-create sieve-buffer))
 343   (sieve-manage-mode)
 344   (sieve-setup-buffer server port)
 345   (if (sieve-open-server server port)
 346       (sieve-refresh-scriptlist)
 347     (message "Could not open server %s" server)))
 348
 349 ;;;###autoload
 350 (defun sieve-upload (&optional name)
 351   (interactive)
 352   (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
 353     (let ((script (buffer-string)) err)
 354       (with-current-buffer (get-buffer sieve-buffer)
 355         (setq err (sieve-manage-putscript
 356                    (or name sieve-buffer-script-name (buffer-name))
 357                    script sieve-manage-buffer))
 358         (if (sieve-manage-ok-p err)
 359             (message (substitute-command-keys
 360                       "Sieve upload done.  Use \\[sieve-manage] to manage scripts."))
 361           (message "Sieve upload failed: %s" (nth 2 err)))))))
 362
 363 ;;;###autoload
 364 (defun sieve-upload-and-bury (&optional name)
 365   (interactive)
 366   (sieve-upload name)
 367   (bury-buffer))
 368
 369 ;;;###autoload
 370 (defun sieve-upload-and-kill (&optional name)
 371   (interactive)
 372   (sieve-upload name)
 373   (kill-buffer))
 374
 375 (provide 'sieve)
 376
 377 ;; sieve.el ends here