emacs/lisp/gnus/sieve.el

;;; sieve.el --- Utilities to manage sieve scripts

;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

;; Author: Simon Josefsson <simon@josefsson.org>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This file contain utilities to facilate upload, download and
;; general management of sieve scripts.  Currently only the
;; Managesieve protocol is supported (using sieve-manage.el), but when
;; (useful) alternatives become available, they might be supported as
;; well.
;;
;; The cursor navigation was inspired by biff-mode by Franklin Lee.
;;
;; Release history:
;;
;; 2001-10-31 Committed to Oort Gnus.
;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode.  Fix menubar
;;            in manage-mode.  Change some messages.  Added sieve-deactivate*,
;;            sieve-remove.  Fixed help text in manage-mode.  Suggested by
;;            Ned Ludd.
;;
;; Todo:
;;
;; * Namespace?  This file contains `sieve-manage' and
;;   `sieve-manage-mode', but there is a sieve-manage.el file as well.
;;   Can't think of a good solution though, this file need a *-mode,
;;   and naming it `sieve-mode' would collide with sieve-mode.el.  One
;;   solution would be to come up with some better name that this file
;;   can use that doesn't have the managesieve specific "manage" in
;;   it.  sieve-dired?  i dunno.  we could copy all off sieve.el into
;;   sieve-manage.el too, but I'd like to separate the interface from
;;   the protocol implementation since the backends are likely to
;;   change (well).
;;
;; * Define servers?  We could have a customize buffer to create a server,
;;   with authentication/stream/etc parameters, much like Gnus, and then
;;   only use names of defined servers when interacting with M-x sieve-*.
;;   Right now you can't use STARTTLS, which sieve-manage.el provides

;;; Code:

(require 'sieve-manage)
(require 'sieve-mode)

;; User customizable variables:

(defgroup sieve nil
  "Manage sieve scripts."
  :version "22.1"
  :group 'tools)

(defcustom sieve-new-script "<new script>"
  "Name of name script indicator."
  :type 'string
  :group 'sieve)

(defcustom sieve-buffer "*sieve*"
  "Name of sieve management buffer."
  :type 'string
  :group 'sieve)

(defcustom sieve-template "\
require \"fileinto\";

# Example script (remove comment character '#' to make it effective!):
#
# if header :contains \"from\" \"coyote\" {
#   discard;
# } elsif header :contains [\"subject\"] [\"$$$\"] {
#   discard;
# } else {
#  fileinto \"INBOX\";
# }
"
  "Template sieve script."
  :type 'string
  :group 'sieve)

;; Internal variables:

(defvar sieve-manage-buffer nil)
(defvar sieve-buffer-header-end nil)

;; Sieve-manage mode:

(defvar sieve-manage-mode-map nil
  "Keymap for `sieve-manage-mode'.")

(if sieve-manage-mode-map
    ()
  (setq sieve-manage-mode-map (make-sparse-keymap))
  (suppress-keymap sieve-manage-mode-map)
  ;; various
  (define-key sieve-manage-mode-map "?" 'sieve-help)
  (define-key sieve-manage-mode-map "h" 'sieve-help)
  (define-key sieve-manage-mode-map "q" 'sieve-bury-buffer)
  ;; activating
  (define-key sieve-manage-mode-map "m" 'sieve-activate)
  (define-key sieve-manage-mode-map "u" 'sieve-deactivate)
  (define-key sieve-manage-mode-map "\M-\C-?" 'sieve-deactivate-all)
  ;; navigation keys
  (define-key sieve-manage-mode-map "\C-p" 'sieve-prev-line)
  (define-key sieve-manage-mode-map [up] 'sieve-prev-line)
  (define-key sieve-manage-mode-map "\C-n" 'sieve-next-line)
  (define-key sieve-manage-mode-map [down] 'sieve-next-line)
  (define-key sieve-manage-mode-map " " 'sieve-next-line)
  (define-key sieve-manage-mode-map "n" 'sieve-next-line)
  (define-key sieve-manage-mode-map "p" 'sieve-prev-line)
  (define-key sieve-manage-mode-map "\C-m" 'sieve-edit-script)
  (define-key sieve-manage-mode-map "f" 'sieve-edit-script)
  (define-key sieve-manage-mode-map "o" 'sieve-edit-script-other-window)
  (define-key sieve-manage-mode-map "r" 'sieve-remove)
  (define-key sieve-manage-mode-map [(down-mouse-2)] 'sieve-edit-script)
  (define-key sieve-manage-mode-map [(down-mouse-3)] 'sieve-manage-mode-menu))

(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map
  "Sieve Menu."
  '("Manage Sieve"
    ["Edit script" sieve-edit-script t]
    ["Activate script" sieve-activate t]
    ["Deactivate script" sieve-deactivate t]))

(define-derived-mode sieve-manage-mode fundamental-mode "SIEVE"
  "Mode used for sieve script management."
  (setq mode-name "SIEVE")
  (buffer-disable-undo (current-buffer))
  (setq truncate-lines t)
  (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map))

(put 'sieve-manage-mode 'mode-class 'special)

;; This is necessary to allow correct handling of \\[cvs-mode-diff-map]
;; in substitute-command-keys.
;(fset 'sieve-manage-mode-map sieve-manage-mode-map)

;; Commands used in sieve-manage mode:

(defun sieve-activate (&optional pos)
  (interactive "d")
  (let ((name (sieve-script-at-point)) err)
    (when (or (null name) (string-equal name sieve-new-script))
      (error "No sieve script at point"))
    (message "Activating script %s..." name)
    (setq err (sieve-manage-setactive name sieve-manage-buffer))
    (sieve-refresh-scriptlist)
    (if (sieve-manage-ok-p err)
	(message "Activating script %s...done" name)
      (message "Activating script %s...failed: %s" name (nth 2 err)))))

(defun sieve-deactivate-all (&optional pos)
  (interactive "d")
  (let ((name (sieve-script-at-point)) err)
    (message "Deactivating scripts...")
    (setq err (sieve-manage-setactive "" sieve-manage-buffer))
    (sieve-refresh-scriptlist)
    (if (sieve-manage-ok-p err)
	(message "Deactivating scripts...done")
      (message "Deactivating scripts...failed: %s" (nth 2 err)))))

(defalias 'sieve-deactivate 'sieve-deactivate-all)

(defun sieve-remove (&optional pos)
  (interactive "d")
  (let ((name (sieve-script-at-point)) err)
    (when (or (null name) (string-equal name sieve-new-script))
      (error "No sieve script at point"))
    (message "Removing sieve script %s..." name)
    (setq err (sieve-manage-deletescript name sieve-manage-buffer))
    (unless (sieve-manage-ok-p err)
      (error "Removing sieve script %s...failed: " err))
    (sieve-refresh-scriptlist)
    (message "Removing sieve script %s...done" name)))

(defun sieve-edit-script (&optional pos)
  (interactive "d")
  (let ((name (sieve-script-at-point)))
    (unless name
      (error "No sieve script at point"))
    (if (not (string-equal name sieve-new-script))
	(let ((newbuf (generate-new-buffer name))
	      err)
	  (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer))
	  (switch-to-buffer newbuf)
	  (unless (sieve-manage-ok-p err)
	    (error "Sieve download failed: %s" err)))
      (switch-to-buffer (get-buffer-create "template.siv"))
      (insert sieve-template))
    (sieve-mode)
    (message "Press C-c C-l to upload script to server.")))

(defmacro sieve-change-region (&rest body)
  "Turns off sieve-region before executing BODY, then re-enables it after.
Used to bracket operations which move point in the sieve-buffer."
  `(progn
     (sieve-highlight nil)
     ,@body
     (sieve-highlight t)))
(put 'sieve-change-region 'lisp-indent-function 0)

(defun sieve-next-line (&optional arg)
  (interactive)
  (unless arg
    (setq arg 1))
  (if (save-excursion
	(forward-line arg)
	(sieve-script-at-point))
      (sieve-change-region
	(forward-line arg))
    (message "End of list")))

(defun sieve-prev-line (&optional arg)
  (interactive)
  (unless arg
    (setq arg -1))
  (if (save-excursion
	(forward-line arg)
	(sieve-script-at-point))
      (sieve-change-region
	(forward-line arg))
    (message "Beginning of list")))

(defun sieve-help ()
  "Display help for various sieve commands."
  (interactive)
  (if (eq last-command 'sieve-help)
      ;; would need minor-mode for log-edit-mode
      (describe-function 'sieve-mode)
    (message "%s" (substitute-command-keys
	      "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove"))))

(defun sieve-bury-buffer (buf &optional mainbuf)
  "Hide the buffer BUF that was temporarily popped up.
BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
  (interactive (list (current-buffer)))
  (save-current-buffer
    (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
		 (get-buffer-window buf t))))
      (when win
	(if (window-dedicated-p win)
	    (condition-case ()
		(delete-window win)
	      (error (iconify-frame (window-frame win))))
	  (if (and mainbuf (get-buffer-window mainbuf))
	      (delete-window win)))))
    (with-current-buffer buf
      (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
				(not (window-dedicated-p (selected-window))))
		     buf)))
    (when mainbuf
      (let ((mainwin (or (get-buffer-window mainbuf)
			 (get-buffer-window mainbuf 'visible))))
	(when mainwin (select-window mainwin))))))

;; Create buffer:

(defun sieve-setup-buffer (server port)
  (setq buffer-read-only nil)
  (erase-buffer)
  (buffer-disable-undo)
  (insert "\
Server  : " server ":" (or port "2000") "

")
  (set (make-local-variable 'sieve-buffer-header-end)
       (point-max)))

(defun sieve-script-at-point (&optional pos)
  "Return name of sieve script at point POS, or nil."
  (interactive "d")
  (get-char-property (or pos (point)) 'script-name))

(eval-and-compile
  (defalias 'sieve-make-overlay (if (featurep 'xemacs)
				    'make-extent
				  'make-overlay))
  (defalias 'sieve-overlay-put (if (featurep 'xemacs)
				   'set-extent-property
				 'overlay-put))
  (defalias 'sieve-overlays-at (if  (featurep 'xemacs)
				   'extents-at
				 'overlays-at)))

(defun sieve-highlight (on)
  "Turn ON or off highlighting on the current language overlay."
  (sieve-overlay-put (car (sieve-overlays-at (point)))
		     'face (if on 'highlight 'default)))

(defun sieve-insert-scripts (scripts)
  "Format and insert LANGUAGE-LIST strings into current buffer at point."
  (while scripts
    (let ((p (point))
	  (ext nil)
	  (script (pop scripts)))
      (if (consp script)
	  (insert (format " ACTIVE %s" (cdr script)))
	(insert (format "        %s" script)))
      (setq ext (sieve-make-overlay p (point)))
      (sieve-overlay-put ext 'mouse-face 'highlight)
      (sieve-overlay-put ext 'script-name (if (consp script)
					      (cdr script)
					    script))
      (insert "\n"))))

(defun sieve-open-server (server &optional port)
  ;; open server
  (set (make-local-variable 'sieve-manage-buffer)
       (sieve-manage-open server))
  ;; authenticate
  (sieve-manage-authenticate nil nil sieve-manage-buffer))

(defun sieve-refresh-scriptlist ()
  (interactive)
  (with-current-buffer sieve-buffer
    (setq buffer-read-only nil)
    (delete-region (or sieve-buffer-header-end (point-max)) (point-max))
    (goto-char (point-max))
    ;; get list of script names and print them
    (let ((scripts (sieve-manage-listscripts sieve-manage-buffer)))
      (if (null scripts)
	  (insert (format (concat "No scripts on server, press RET on %s to "
				  "create a new script.\n") sieve-new-script))
	(insert (format (concat "%d script%s on server, press RET on a script "
				"name edits it, or\npress RET on %s to create "
				"a new script.\n") (length scripts)
				(if (eq (length scripts) 1) "" "s")
				sieve-new-script)))
      (save-excursion
	(sieve-insert-scripts (list sieve-new-script))
	(sieve-insert-scripts scripts)))
    (sieve-highlight t)
    (setq buffer-read-only t)))

;;;###autoload
(defun sieve-manage (server &optional port)
  (interactive "sServer: ")
  (switch-to-buffer (get-buffer-create sieve-buffer))
  (sieve-manage-mode)
  (sieve-setup-buffer server port)
  (if (sieve-open-server server port)
      (sieve-refresh-scriptlist)
    (message "Could not open server %s" server)))

;;;###autoload
(defun sieve-upload (&optional name)
  (interactive)
  (unless name
    (setq name (buffer-name)))
  (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
    (let ((script (buffer-string)) err)
      (with-current-buffer (get-buffer sieve-buffer)
	(setq err (sieve-manage-putscript name script sieve-manage-buffer))
	(if (sieve-manage-ok-p err)
	    (message (concat
		      "Sieve upload done.  Use `C-c RET' to manage scripts."))
	  (message "Sieve upload failed: %s" (nth 2 err)))))))

;;;###autoload
(defun sieve-upload-and-bury (&optional name)
  (interactive)
  (sieve-upload name)
  (bury-buffer))

(provide 'sieve)

;; arch-tag: 7f6a6d94-94e1-4654-ab9a-aee21b9b8a94
;; sieve.el ends here