1 files changed, 372 insertions, 0 deletions
diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el
new file mode 100644
index 00000000000..2046e53697d
--- /dev/null
+++ b/lisp/net/sieve.el
@@ -0,0 +1,372 @@
+;;; sieve.el --- Utilities to manage sieve scripts
+
+;; Copyright (C) 2001-2016 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 facilitate 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)
+(defvar sieve-buffer-script-name nil
+  "The real script name of the buffer.")
+(make-local-variable 'sieve-buffer-script-name)
+
+;; Sieve-manage mode:
+
+(defvar sieve-manage-mode-map
+  (let ((map (make-sparse-keymap)))
+    ;; various
+    (define-key map "?" 'sieve-help)
+    (define-key map "h" 'sieve-help)
+    ;; activating
+    (define-key map "m" 'sieve-activate)
+    (define-key map "u" 'sieve-deactivate)
+    (define-key map "\M-\C-?" 'sieve-deactivate-all)
+    ;; navigation keys
+    (define-key map "\C-p" 'sieve-prev-line)
+    (define-key map [up] 'sieve-prev-line)
+    (define-key map "\C-n" 'sieve-next-line)
+    (define-key map [down] 'sieve-next-line)
+    (define-key map " " 'sieve-next-line)
+    (define-key map "n" 'sieve-next-line)
+    (define-key map "p" 'sieve-prev-line)
+    (define-key map "\C-m" 'sieve-edit-script)
+    (define-key map "f" 'sieve-edit-script)
+    (define-key map "o" 'sieve-edit-script-other-window)
+    (define-key map "r" 'sieve-remove)
+    (define-key map "q" 'sieve-bury-buffer)
+    (define-key map "Q" 'sieve-manage-quit)
+    (define-key map [(down-mouse-2)] 'sieve-edit-script)
+    (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu)
+    map)
+  "Keymap for `sieve-manage-mode'.")
+
+(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-manage"
+  "Mode used for sieve script management."
+  (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)
+
+;; Commands used in sieve-manage mode:
+
+(defun sieve-manage-quit ()
+  "Quit Manage Sieve and close the connection."
+  (interactive)
+  (sieve-manage-close sieve-manage-buffer)
+  (kill-buffer sieve-manage-buffer)
+  (kill-buffer (current-buffer)))
+
+(defun sieve-bury-buffer ()
+  "Bury the Manage Sieve buffer without closing the connection."
+  (interactive)
+  (bury-buffer))
+
+(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)
+    (setq sieve-buffer-script-name name)
+    (goto-char (point-min))
+    (message
+     (substitute-command-keys
+      "Press \\[sieve-upload] 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"))))
+
+;; Create buffer:
+
+(defun sieve-setup-buffer (server port)
+  (setq buffer-read-only nil)
+  (erase-buffer)
+  (buffer-disable-undo)
+  (let* ((port (or port sieve-manage-default-port))
+         (header (format "Server : %s:%s\n\n" server port)))
+    (insert header))
+  (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))
+
+(defun sieve-highlight (on)
+  "Turn ON or off highlighting on the current language overlay."
+  (overlay-put (car (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 (make-overlay p (point)))
+      (overlay-put ext 'mouse-face 'highlight)
+      (overlay-put ext 'script-name (if (consp script)
+					(cdr script)
+				      script))
+      (insert "\n"))))
+
+(defun sieve-open-server (server &optional port)
+  "Open SERVER (on PORT) and authenticate."
+  (with-current-buffer
+      (or ;; open server
+       (set (make-local-variable 'sieve-manage-buffer)
+	    (sieve-manage-open server port))
+       (error "Error opening server %s" server))
+    (sieve-manage-authenticate)))
+
+(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
+           (substitute-command-keys
+            (format
+             "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n"
+             sieve-new-script)))
+	(insert
+         (substitute-command-keys
+          (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script "
+                          "name edits it, or\npress \\[sieve-edit-script] 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)
+  (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
+                   (or name sieve-buffer-script-name (buffer-name))
+                   script sieve-manage-buffer))
+	(if (sieve-manage-ok-p err)
+	    (message (substitute-command-keys
+		      "Sieve upload done.  Use \\[sieve-manage] 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))
+
+;;;###autoload
+(defun sieve-upload-and-kill (&optional name)
+  (interactive)
+  (sieve-upload name)
+  (kill-buffer))
+
+(provide 'sieve)
+
+;; sieve.el ends here