+2001-11-01 Simon Josefsson <jas@extundo.com>
+
+ * gnus-group.el (gnus-group-mode-map): Bind "D u" to
+ `gnus-sieve-update' and "D g" to `gnus-sieve-generate'. (Functions
+ has autoload cookies, so no `require' should be necessary.)
+
+ * sieve.el, sieve-mode.el, sieve-manage.el, gnus-sieve.el: New
+ files.
+
2001-10-31 Simon Josefsson <jas@extundo.com>
* gnus-cus.el (gnus-group-parameters): Support integer `display'
"r" gnus-group-mark-regexp
"U" gnus-group-unmark-all-groups)
+ (gnus-define-keys (gnus-group-sieve-map "D" gnus-group-mode-map)
+ "u" gnus-sieve-update
+ "g" gnus-sieve-generate)
+
(gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map)
"d" gnus-group-make-directory-group
"h" gnus-group-make-help-group
--- /dev/null
+;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Author: NAGY Andras <nagya@inf.elte.hu>,
+;; Simon Josefsson <simon@josefsson.org>
+
+;; This file is not part of GNU Emacs, but the same permissions apply.
+
+;; 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 2, 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; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Gnus glue to generate complete Sieve scripts from Gnus Group
+;; Parameters with "if" test predicates.
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-sum)
+(require 'format-spec)
+(autoload 'sieve-mode "sieve-mode")
+(eval-when-compile
+ (require 'sieve))
+
+;; Variables
+
+(defgroup gnus-sieve nil
+ "Manage sieve scripts in Gnus."
+ :group 'gnus)
+
+(defcustom gnus-sieve-file "~/.sieve"
+ "Path to your Sieve script."
+ :type 'file
+ :group 'gnus-sieve)
+
+(defcustom gnus-sieve-region-start "\n## Begin Gnus Sieve Script\n"
+ "Line indicating the start of the autogenerated region in
+your Sieve script."
+ :type 'string
+ :group 'gnus-sieve)
+
+(defcustom gnus-sieve-region-end "\n## End Gnus Sieve Script\n"
+ "Line indicating the end of the autogenerated region in
+your Sieve script."
+ :type 'string
+ :group 'gnus-sieve)
+
+(defcustom gnus-sieve-select-method nil
+ "Which select method we generate the Sieve script for.
+
+For example: \"nnimap:mailbox\""
+ :group 'gnus-sieve)
+
+(defcustom gnus-sieve-crosspost nil
+ "Whether the generated Sieve script should do crossposting."
+ :type 'bool
+ :group 'gnus-sieve)
+
+(defcustom gnus-sieve-update-shell-command "echo put %f | sieveshell %s"
+ "Shell command to execute after updating your Sieve script. The following
+formatting characters are recognized:
+
+%f Script's file name (gnus-sieve-file)
+%s Server name (from gnus-sieve-select-method)"
+ :type 'string
+ :group 'gnus-sieve)
+
+;;;###autoload
+(defun gnus-sieve-update ()
+ "Update the Sieve script in gnus-sieve-file, by replacing the region
+between gnus-sieve-region-start and gnus-sieve-region-end with
+\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\), then
+execute gnus-sieve-update-shell-command.
+See the documentation for these variables and functions for details."
+ (interactive)
+ (gnus-sieve-generate)
+ (save-buffer)
+ (shell-command
+ (format-spec gnus-sieve-update-shell-command
+ (format-spec-make ?f gnus-sieve-file
+ ?s (or (cadr (gnus-server-get-method
+ nil gnus-sieve-select-method))
+ "")))))
+
+;;;###autoload
+(defun gnus-sieve-generate ()
+ "Generate the Sieve script in gnus-sieve-file, by replacing the region
+between gnus-sieve-region-start and gnus-sieve-region-end with
+\(gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost\).
+See the documentation for these variables and functions for details."
+ (interactive)
+ (require 'sieve)
+ (find-file gnus-sieve-file)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat (regexp-quote gnus-sieve-region-start) "\\(.\\|\n\\)*"
+ (regexp-quote gnus-sieve-region-end)) nil t)
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert sieve-template))
+ (insert gnus-sieve-region-start
+ (gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost)
+ gnus-sieve-region-end)
+ (sieve-mode))
+
+(defun gnus-sieve-guess-rule-for-article ()
+ "Guess a sieve rule based on RFC822 article in buffer.
+Return NIL if no rule could be guessed."
+ (when (message-fetch-field "sender")
+ `(sieve address "sender" ,(regexp-quote (message-fetch-field "sender")))))
+
+(defun gnus-sieve-article-add-rule ()
+ (interactive)
+ (gnus-summary-select-article nil 'force)
+ (with-current-buffer gnus-original-article-buffer
+ (let ((rule (gnus-sieve-guess-rule-for-article))
+ (info (gnus-get-info gnus-newsgroup-name)))
+ (if (null rule)
+ (error "Could not guess rule for article.")
+ (gnus-info-set-params info (cons rule (gnus-info-params info)))
+ (message "Added rule in group %s for article: %s" gnus-newsgroup-name
+ rule)))))
+
+;; Internals
+
+;; FIXME: do proper quoting of " etc
+(defun gnus-sieve-string-list (list)
+ "Convert an elisp string list to a Sieve string list.
+
+For example:
+\(gnus-sieve-string-list '(\"to\" \"cc\"))
+ => \"[\\\"to\\\", \\\"cc\\\"]\"
+"
+ (concat "[\"" (mapconcat 'identity list "\", \"") "\"]"))
+
+(defun gnus-sieve-test-list (list)
+ "Convert an elisp test list to a Sieve test list.
+
+For example:
+\(gnus-sieve-test-list '((address \"sender\" \"boss@company.com\") (size :over 4K)))
+ => \"(address \\\"sender\\\" \\\"boss@company.com\\\", size :over 4K)\""
+ (concat "(" (mapconcat 'gnus-sieve-test list ", ") ")"))
+
+;; FIXME: do proper quoting
+(defun gnus-sieve-test-token (token)
+ "Convert an elisp test token to a Sieve test token.
+
+For example:
+\(gnus-sieve-test-token 'address)
+ => \"address\"
+
+\(gnus-sieve-test-token \"sender\")
+ => \"\\\"sender\\\"\"
+
+\(gnus-sieve-test-token '(\"to\" \"cc\"))
+ => \"[\\\"to\\\", \\\"cc\\\"]\""
+ (cond
+ ((symbolp token) ;; Keyword
+ (symbol-name token))
+
+ ((stringp token) ;; String
+ (concat "\"" token "\""))
+
+ ((and (listp token) ;; String list
+ (stringp (car token)))
+ (gnus-sieve-string-list token))
+
+ ((and (listp token) ;; Test list
+ (listp (car token)))
+ (gnus-sieve-test-list token))))
+
+(defun gnus-sieve-test (test)
+ "Convert an elisp test to a Sieve test.
+
+For example:
+\(gnus-sieve-test '(address \"sender\" \"sieve-admin@extundo.com\"))
+ => \"address \\\"sender\\\" \\\"sieve-admin@extundo.com\\\"\"
+
+\(gnus-sieve-test '(anyof ((header :contains (\"to\" \"cc\") \"my@address.com\")
+ (size :over 100K))))
+ => \"anyof (header :contains [\\\"to\\\", \\\"cc\\\"] \\\"my@address.com\\\",
+ size :over 100K)\""
+ (mapconcat 'gnus-sieve-test-token test " "))
+
+(defun gnus-sieve-script (&optional method crosspost)
+ "Generate a Sieve script based on groups with select method METHOD
+\(or all groups if nil\). Only groups having a `sieve' parameter are
+considered. This parameter should contain an elisp test
+\(see the documentation of gnus-sieve-test for details\). For each
+such group, a Sieve IF control structure is generated, having the
+test as the condition and { fileinto \"group.name\"; } as the body.
+
+If CROSSPOST is non-nil, concatenate these conditionals
+sequencially, otherwsie with `elsif', causing a match on one group the
+other tests to be skipped.
+
+For example: If the INBOX.list.sieve group has the
+
+ (sieve address \"sender\" \"sieve-admin@extundo.com\")
+
+group parameter, (gnus-sieve-script) results in:
+
+ if address \"sender\" \"sieve-admin@extundo.com\" {
+ fileinto \"INBOX.list.sieve\";
+ }
+
+This is returned as a string."
+ (let* ((newsrc (cdr gnus-newsrc-alist))
+ script)
+ (dolist (info newsrc)
+ (when (or (not method)
+ (gnus-server-equal method (gnus-info-method info)))
+ (let* ((group (gnus-info-group info))
+ (spec (gnus-group-find-parameter group 'sieve t)))
+ (when spec
+ (push (concat "if " (gnus-sieve-test spec) " {\n\t"
+ "fileinto \"" (gnus-group-real-name group)
+ "\";\n}")
+ script)))))
+ (mapconcat 'identity script (if crosspost "\n" "\nels"))))
+
+(provide 'gnus-sieve)
+
+;;; gnus-sieve.el ends here
--- /dev/null
+;;; sieve-manage.el --- Implementation of the managesive protocol in elisp
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+
+;; This file is not part of GNU Emacs, but the same permissions apply.
+
+;; 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 2, 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; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This library provides an elisp API for the managesieve network
+;; protocol.
+;;
+;; Currently only the CRAM-MD5 authentication mechanism is supported.
+;;
+;; The API should be fairly obvious for anyone familiar with the
+;; managesieve protocol, interface functions include:
+;;
+;; `sieve-manage-open'
+;; open connection to managesieve server, returning a buffer to be
+;; used by all other API functions.
+;;
+;; `sieve-manage-opened'
+;; check if a server is open or not
+;;
+;; `sieve-manage-close'
+;; close a server connection.
+;;
+;; `sieve-manage-authenticate'
+;; `sieve-manage-listscripts'
+;; performs managesieve protocol actions
+;;
+;; and that's it. Example of a managesieve session in *scratch*:
+;;
+;; (setq my-buf (sieve-manage-open "my.server.com"))
+;; " *sieve* my.server.com:2000*"
+;;
+;; (sieve-manage-authenticate "myusername" "mypassword" my-buf)
+;; 'auth
+;;
+;; (sieve-manage-listscripts my-buf)
+;; ("vacation" "testscript" ("splitmail") "badscript")
+;;
+;; References:
+;;
+;; draft-martin-managesieve-02.txt,
+;; "A Protocol for Remotely Managing Sieve Scripts",
+;; by Tim Martin.
+;;
+;; Release history:
+;;
+;; 2001-10-31 Committed to Oort Gnus.
+;;
+;; $Id: sieve-manage.el,v 1.9 2001/06/30 19:00:00 jas Exp $
+
+;;; Code:
+
+(require 'rfc2104)
+(or (fboundp 'md5)
+ (require 'md5))
+(eval-and-compile
+ (autoload 'starttls-open-stream "starttls"))
+
+;; User customizable variables:
+
+(defgroup sieve-manage nil
+ "Low-level Managesieve protocol issues."
+ :group 'mail
+ :prefix "sieve-")
+
+(defcustom sieve-manage-log "*sieve-manage-log*"
+ "Name of buffer for managesieve session trace."
+ :type 'string)
+
+(defcustom sieve-manage-default-user (user-login-name)
+ "Default username to use."
+ :type 'string)
+
+(defcustom sieve-manage-server-eol "\r\n"
+ "The EOL string sent from the server."
+ :type 'string)
+
+(defcustom sieve-manage-client-eol "\r\n"
+ "The EOL string we send to the server."
+ :type 'string)
+
+(defcustom sieve-manage-streams '(network starttls shell)
+ "Priority of streams to consider when opening connection to server.")
+
+(defcustom sieve-manage-stream-alist
+ '((network sieve-manage-network-p sieve-manage-network-open)
+ (shell sieve-manage-shell-p sieve-manage-shell-open)
+ (starttls sieve-manage-starttls-p sieve-manage-starttls-open))
+ "Definition of network streams.
+
+(NAME CHECK OPEN)
+
+NAME names the stream, CHECK is a function returning non-nil if the
+server support the stream and OPEN is a function for opening the
+stream.")
+
+(defcustom sieve-manage-authenticators '(cram-md5 plain)
+ "Priority of authenticators to consider when authenticating to server.")
+
+(defcustom sieve-manage-authenticator-alist
+ '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth)
+ (plain sieve-manage-plain-p sieve-manage-plain-auth))
+ "Definition of authenticators.
+
+(NAME CHECK AUTHENTICATE)
+
+NAME names the authenticator. CHECK is a function returning non-nil if
+the server support the authenticator and AUTHENTICATE is a function
+for doing the actuall authentification.")
+
+(defcustom sieve-manage-default-port 2000
+ "Default port number for managesieve protocol."
+ :type 'integer)
+
+;; Internal variables:
+
+(defconst sieve-manage-local-variables '(sieve-manage-server
+ sieve-manage-port
+ sieve-manage-auth
+ sieve-manage-stream
+ sieve-manage-username
+ sieve-manage-password
+ sieve-manage-process
+ sieve-manage-client-eol
+ sieve-manage-server-eol
+ sieve-manage-capability))
+(defconst sieve-manage-default-stream 'network)
+(defconst sieve-manage-coding-system-for-read 'binary)
+(defconst sieve-manage-coding-system-for-write 'binary)
+(defvar sieve-manage-stream nil)
+(defvar sieve-manage-auth nil)
+(defvar sieve-manage-server nil)
+(defvar sieve-manage-port nil)
+(defvar sieve-manage-username nil)
+(defvar sieve-manage-password nil)
+(defvar sieve-manage-state 'closed
+ "Managesieve state.
+Valid states are `closed', `initial', `nonauth', and `auth'.")
+(defvar sieve-manage-process nil)
+(defvar sieve-manage-capability nil)
+
+;; Internal utility functions
+
+(defsubst sieve-manage-disable-multibyte ()
+ "Enable multibyte in the current buffer."
+ (when (fboundp 'set-buffer-multibyte)
+ (set-buffer-multibyte nil)))
+
+(defun sieve-manage-read-passwd (prompt &rest args)
+ "Read a password using PROMPT.
+If ARGS, PROMPT is used as an argument to `format'."
+ (let ((prompt (if args
+ (apply 'format prompt args)
+ prompt)))
+ (funcall (if (or (fboundp 'read-passwd)
+ (and (load "subr" t)
+ (fboundp 'read-passwd))
+ (and (load "passwd" t)
+ (fboundp 'read-passwd)))
+ 'read-passwd
+ (autoload 'ange-ftp-read-passwd "ange-ftp")
+ 'ange-ftp-read-passwd)
+ prompt)))
+
+
+;; Uses the dynamically bound `reason' variable.
+(defvar reason)
+(defun sieve-manage-interactive-login (buffer loginfunc)
+ "Login to server in BUFFER.
+LOGINFUNC is passed a username and a password, it should return t if
+it where sucessful authenticating itself to the server, nil otherwise.
+Returns t if login was successful, nil otherwise."
+ (with-current-buffer buffer
+ (make-variable-buffer-local 'sieve-manage-username)
+ (make-variable-buffer-local 'sieve-manage-password)
+ (let (user passwd ret reason)
+ ;; (condition-case ()
+ (while (or (not user) (not passwd))
+ (setq user (or sieve-manage-username
+ (read-from-minibuffer
+ (concat "Managesieve username for "
+ sieve-manage-server ": ")
+ (or user sieve-manage-default-user))))
+ (setq passwd (or sieve-manage-password
+ (sieve-manage-read-passwd
+ (concat "Managesieve password for " user "@"
+ sieve-manage-server ": "))))
+ (when (and user passwd)
+ (if (funcall loginfunc user passwd)
+ (progn
+ (setq ret t
+ sieve-manage-username user)
+ (if (and (not sieve-manage-password)
+ (y-or-n-p "Store password for this session? "))
+ (setq sieve-manage-password passwd)))
+ (if reason
+ (message "Login failed (reason given: %s)..." reason)
+ (message "Login failed..."))
+ (setq reason nil)
+ (setq passwd nil)
+ (sit-for 1))))
+ ;; (quit (with-current-buffer buffer
+ ;; (setq user nil
+ ;; passwd nil)))
+ ;; (error (with-current-buffer buffer
+ ;; (setq user nil
+ ;; passwd nil))))
+ ret)))
+
+(defun sieve-manage-erase (&optional p buffer)
+ (let ((buffer (or buffer (current-buffer))))
+ (and sieve-manage-log
+ (with-current-buffer (get-buffer-create sieve-manage-log)
+ (sieve-manage-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer (with-current-buffer buffer
+ (point-min))
+ (or p (with-current-buffer buffer
+ (point-max)))))))
+ (delete-region (point-min) (or p (point-max))))
+
+(defun sieve-manage-open-1 (buffer)
+ (with-current-buffer buffer
+ (sieve-manage-erase)
+ (setq sieve-manage-state 'initial
+ sieve-manage-process
+ (condition-case ()
+ (funcall (nth 2 (assq sieve-manage-stream
+ sieve-manage-stream-alist))
+ "sieve" buffer sieve-manage-server sieve-manage-port)
+ ((error quit) nil)))
+ (when sieve-manage-process
+ (while (and (eq sieve-manage-state 'initial)
+ (memq (process-status sieve-manage-process) '(open run)))
+ (message "Waiting for response from %s..." sieve-manage-server)
+ (accept-process-output sieve-manage-process 1))
+ (message "Waiting for response from %s...done" sieve-manage-server)
+ (and (memq (process-status sieve-manage-process) '(open run))
+ sieve-manage-process))))
+
+;; Streams
+
+(defun sieve-manage-network-p (buffer)
+ t)
+
+(defun sieve-manage-network-open (name buffer server port)
+ (let* ((port (or port sieve-manage-default-port))
+ (coding-system-for-read sieve-manage-coding-system-for-read)
+ (coding-system-for-write sieve-manage-coding-system-for-write)
+ (process (open-network-stream name buffer server port)))
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-min))
+ (not (sieve-manage-parse-greeting-1)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (sieve-manage-erase nil buffer)
+ (when (memq (process-status process) '(open run))
+ process))))
+
+(defun imap-starttls-p (buffer)
+ ;; (and (imap-capability 'STARTTLS buffer)
+ (condition-case ()
+ (progn
+ (require 'starttls)
+ (call-process "starttls"))
+ (error nil)))
+
+(defun imap-starttls-open (name buffer server port)
+ (let* ((port (or port sieve-manage-default-port))
+ (coding-system-for-read sieve-manage-coding-system-for-read)
+ (coding-system-for-write sieve-manage-coding-system-for-write)
+ (process (starttls-open-stream name buffer server port))
+ done)
+ (when process
+ (while (and (memq (process-status process) '(open run))
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-min))
+ (not (sieve-manage-parse-greeting-1)))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (sieve-manage-erase nil buffer)
+ (sieve-manage-send "STARTTLS")
+ (starttls-negotiate process))
+ (when (memq (process-status process) '(open run))
+ process)))
+
+;; Authenticators
+
+(defun sieve-manage-plain-p (buffer)
+ (sieve-manage-capability "SASL" "PLAIN" buffer))
+
+(defun sieve-manage-plain-auth (buffer)
+ "Login to managesieve server using the PLAIN SASL method."
+ (let* ((done (sieve-manage-interactive-login
+ buffer
+ (lambda (user passwd)
+ (sieve-manage-send (concat "AUTHENTICATE \"PLAIN\" \""
+ (base64-encode-string
+ (concat (char-to-string 0)
+ user
+ (char-to-string 0)
+ passwd))
+ "\""))
+ (let ((rsp (sieve-manage-parse-okno)))
+ (if (sieve-manage-ok-p rsp)
+ t
+ (setq reason (cdr-safe rsp))
+ nil))))))
+ (if done
+ (message "sieve: Authenticating using PLAIN...done")
+ (message "sieve: Authenticating using PLAIN...failed"))))
+
+(defun sieve-manage-cram-md5-p (buffer)
+ (sieve-manage-capability "SASL" "CRAM-MD5" buffer))
+
+(defun sieve-manage-cram-md5-auth (buffer)
+ "Login to managesieve server using the CRAM-MD5 SASL method."
+ (message "sieve: Authenticating using CRAM-MD5...")
+ (let* ((done (sieve-manage-interactive-login
+ buffer
+ (lambda (user passwd)
+ (sieve-manage-send "AUTHENTICATE \"CRAM-MD5\" \"\"")
+ (sieve-manage-send
+ (concat
+ "\""
+ (base64-encode-string
+ (concat
+ user " "
+ (rfc2104-hash 'md5 64 16 passwd
+ (base64-decode-string
+ (prog1
+ (sieve-manage-parse-string)
+ (sieve-manage-erase))))))
+ "\""))
+ (let ((rsp (sieve-manage-parse-okno)))
+ (if (sieve-manage-ok-p rsp)
+ t
+ (setq reason (cdr-safe rsp))
+ nil))))))
+ (if done
+ (message "sieve: Authenticating using CRAM-MD5...done")
+ (message "sieve: Authenticating using CRAM-MD5...failed"))))
+
+;; Managesieve API
+
+(defun sieve-manage-open (server &optional port stream auth buffer)
+ "Open a network connection to a managesieve SERVER (string).
+Optional variable PORT is port number (integer) on remote server.
+Optional variable STREAM is any of `sieve-manage-streams' (a symbol).
+Optional variable AUTH indicates authenticator to use, see
+`sieve-manage-authenticators' for available authenticators. If nil, chooses
+the best stream the server is capable of.
+Optional variable BUFFER is buffer (buffer, or string naming buffer)
+to work in."
+ (setq buffer (or buffer (format " *sieve* %s:%d" server (or port 2000))))
+ (with-current-buffer (get-buffer-create buffer)
+ (mapcar 'make-variable-buffer-local sieve-manage-local-variables)
+ (sieve-manage-disable-multibyte)
+ (buffer-disable-undo)
+ (setq sieve-manage-server (or server sieve-manage-server))
+ (setq sieve-manage-port (or port sieve-manage-port))
+ (setq sieve-manage-stream (or stream sieve-manage-stream))
+ (message "sieve: Connecting to %s..." sieve-manage-server)
+ (if (let ((sieve-manage-stream
+ (or sieve-manage-stream sieve-manage-default-stream)))
+ (sieve-manage-open-1 buffer))
+ ;; Choose stream.
+ (let (stream-changed)
+ (message "sieve: Connecting to %s...done" sieve-manage-server)
+ (when (null sieve-manage-stream)
+ (let ((streams sieve-manage-streams))
+ (while (setq stream (pop streams))
+ (if (funcall (nth 1 (assq stream
+ sieve-manage-stream-alist)) buffer)
+ (setq stream-changed
+ (not (eq (or sieve-manage-stream
+ sieve-manage-default-stream)
+ stream))
+ sieve-manage-stream stream
+ streams nil)))
+ (unless sieve-manage-stream
+ (error "Couldn't figure out a stream for server"))))
+ (when stream-changed
+ (message "sieve: Reconnecting with stream `%s'..."
+ sieve-manage-stream)
+ (sieve-manage-close buffer)
+ (if (sieve-manage-open-1 buffer)
+ (message "sieve: Reconnecting with stream `%s'...done"
+ sieve-manage-stream)
+ (message "sieve: Reconnecting with stream `%s'...failed"
+ sieve-manage-stream))
+ (setq sieve-manage-capability nil))
+ (if (sieve-manage-opened buffer)
+ ;; Choose authenticator
+ (when (and (null sieve-manage-auth)
+ (not (eq sieve-manage-state 'auth)))
+ (let ((auths sieve-manage-authenticators))
+ (while (setq auth (pop auths))
+ (if (funcall (nth 1 (assq
+ auth
+ sieve-manage-authenticator-alist))
+ buffer)
+ (setq sieve-manage-auth auth
+ auths nil)))
+ (unless sieve-manage-auth
+ (error "Couldn't figure out authenticator for server"))))))
+ (message "sieve: Connecting to %s...failed" sieve-manage-server))
+ (when (sieve-manage-opened buffer)
+ (sieve-manage-erase)
+ buffer)))
+
+(defun sieve-manage-opened (&optional buffer)
+ "Return non-nil if connection to managesieve server in BUFFER is open.
+If BUFFER is nil then the current buffer is used."
+ (and (setq buffer (get-buffer (or buffer (current-buffer))))
+ (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (and sieve-manage-process
+ (memq (process-status sieve-manage-process) '(open run))))))
+
+(defun sieve-manage-close (&optional buffer)
+ "Close connection to managesieve server in BUFFER.
+If BUFFER is nil, the current buffer is used."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (sieve-manage-opened)
+ (sieve-manage-send "LOGOUT")
+ (sit-for 1))
+ (when (and sieve-manage-process
+ (memq (process-status sieve-manage-process) '(open run)))
+ (delete-process sieve-manage-process))
+ (setq sieve-manage-process nil)
+ (sieve-manage-erase)
+ t))
+
+(defun sieve-manage-authenticate (&optional user passwd buffer)
+ "Authenticate to server in BUFFER, using current buffer if nil.
+It uses the authenticator specified when opening the server. If the
+authenticator requires username/passwords, they are queried from the
+user and optionally stored in the buffer. If USER and/or PASSWD is
+specified, the user will not be questioned and the username and/or
+password is remembered in the buffer."
+ (with-current-buffer (or buffer (current-buffer))
+ (if (not (eq sieve-manage-state 'nonauth))
+ (eq sieve-manage-state 'auth)
+ (make-variable-buffer-local 'sieve-manage-username)
+ (make-variable-buffer-local 'sieve-manage-password)
+ (if user (setq sieve-manage-username user))
+ (if passwd (setq sieve-manage-password passwd))
+ (if (funcall (nth 2 (assq sieve-manage-auth
+ sieve-manage-authenticator-alist)) buffer)
+ (setq sieve-manage-state 'auth)))))
+
+(defun sieve-manage-capability (&optional name value buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (if (null name)
+ sieve-manage-capability
+ (if (null value)
+ (nth 1 (assoc name sieve-manage-capability))
+ (when (string-match value (nth 1 (assoc name sieve-manage-capability)))
+ (nth 1 (assoc name sieve-manage-capability)))))))
+
+(defun sieve-manage-listscripts (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send "LISTSCRIPTS")
+ (sieve-manage-parse-listscripts)))
+
+(defun sieve-manage-havespace (name size &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "HAVESPACE \"%s\" %s" name size))
+ (sieve-manage-parse-okno)))
+
+(defun sieve-string-bytes (str)
+ (if (fboundp 'string-bytes)
+ (string-bytes str)
+ (length str)))
+
+(defun sieve-manage-putscript (name content &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name
+ (sieve-string-bytes content)
+ sieve-manage-client-eol content))
+ (sieve-manage-parse-okno)))
+
+(defun sieve-manage-getscript (name output-buffer &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "GETSCRIPT \"%s\"" name))
+ (let ((script (sieve-manage-parse-string)))
+ (sieve-manage-parse-crlf)
+ (with-current-buffer output-buffer
+ (insert script))
+ (sieve-manage-parse-okno))))
+
+(defun sieve-manage-setactive (name &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "SETACTIVE \"%s\"" name))
+ (sieve-manage-parse-okno)))
+
+;; Protocol parsing routines
+
+(defun sieve-manage-ok-p (rsp)
+ (string= (downcase (or (car-safe rsp) "")) "ok"))
+
+(defsubst sieve-manage-forward ()
+ (or (eobp) (forward-char)))
+
+(defun sieve-manage-is-okno ()
+ (when (looking-at (concat
+ "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?"
+ sieve-manage-server-eol))
+ (list (match-string 1) (match-string 3) (match-string 5))))
+
+(defun sieve-manage-parse-okno ()
+ (let (rsp)
+ (while (null rsp)
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min))
+ (setq rsp (sieve-manage-is-okno)))
+ (sieve-manage-erase)
+ rsp))
+
+(defun sieve-manage-parse-capability-1 ()
+ "Accept a managesieve greeting."
+ (let (str)
+ (while (setq str (sieve-manage-is-string))
+ (if (eq (char-after) ? )
+ (progn
+ (sieve-manage-forward)
+ (push (list str (sieve-manage-is-string))
+ sieve-manage-capability))
+ (push (list str) sieve-manage-capability))
+ (forward-line)))
+ (when (re-search-forward (concat "^OK" sieve-manage-server-eol) nil t)
+ (setq sieve-manage-state 'nonauth)))
+
+(defalias 'sieve-manage-parse-greeting-1 'sieve-manage-parse-capability-1)
+
+(defun sieve-manage-is-string ()
+ (cond ((looking-at "\"\\([^\"]+\\)\"")
+ (prog1
+ (match-string 1)
+ (goto-char (match-end 0))))
+ ((looking-at (concat "{\\([0-9]+\\)}" sieve-manage-server-eol))
+ (let ((pos (match-end 0))
+ (len (string-to-number (match-string 1))))
+ (if (< (point-max) (+ pos len))
+ nil
+ (goto-char (+ pos len))
+ (buffer-substring pos (+ pos len)))))))
+
+(defun sieve-manage-parse-string ()
+ (let (rsp)
+ (while (null rsp)
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min))
+ (setq rsp (sieve-manage-is-string)))
+ (sieve-manage-erase (point))
+ rsp))
+
+(defun sieve-manage-parse-crlf ()
+ (when (looking-at sieve-manage-server-eol)
+ (sieve-manage-erase (match-end 0))))
+
+(defun sieve-manage-parse-listscripts ()
+ (let (tmp rsp data)
+ (while (null rsp)
+ (while (null (or (setq rsp (sieve-manage-is-okno))
+ (setq tmp (sieve-manage-is-string))))
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min)))
+ (when tmp
+ (while (not (looking-at (concat "\\( ACTIVE\\)?"
+ sieve-manage-server-eol)))
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min)))
+ (if (match-string 1)
+ (push (cons 'active tmp) data)
+ (push tmp data))
+ (goto-char (match-end 0))
+ (setq tmp nil)))
+ (sieve-manage-erase)
+ (if (sieve-manage-ok-p rsp)
+ data
+ rsp)))
+
+(defun sieve-manage-send (cmdstr)
+ (setq cmdstr (concat cmdstr sieve-manage-client-eol))
+ (and sieve-manage-log
+ (with-current-buffer (get-buffer-create sieve-manage-log)
+ (sieve-manage-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert cmdstr)))
+ (process-send-string sieve-manage-process cmdstr))
+
+(provide 'sieve-manage)
+
+;; sieve-manage.el ends here
--- /dev/null
+;;; sieve-mode.el --- Sieve code editing commands for Emacs
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+
+;; This file is not part of GNU Emacs, but the same permissions apply.
+
+;; 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 2, 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; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This file contain editing mode functions and font-lock support for
+;; editing Sieve scripts. It sets up C-mode with support for
+;; sieve-style #-comments and a lightly hacked syntax table. It was
+;; strongly influenced by awk-mode.el.
+;;
+;; Put something similar to the following in your .emacs to use this file:
+;;
+;; (load "~/lisp/sieve")
+;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist))
+;;
+;; References:
+;;
+;; RFC 3028,
+;; "Sieve: A Mail Filtering Language",
+;; by Tim Showalter.
+;;
+;; Release history:
+;;
+;; 2001-03-02 version 1.0 posted to gnu.emacs.sources
+;; version 1.1 change file extension into ".siv" (official one)
+;; added keymap and menubar to hook into sieve-manage
+;; 2001-10-31 version 1.2 committed to Oort Gnus
+;;
+;; $Id: sieve-mode.el,v 1.7 2001/03/07 17:47:23 jas Exp $
+
+;;; Code:
+
+(autoload 'sieve-manage "sieve-manage")
+(autoload 'sieve-upload "sieve-manage")
+(require 'easymenu)
+(eval-when-compile
+ (require 'font-lock))
+
+(defgroup sieve nil
+ "Sieve."
+ :group 'languages)
+
+(defcustom sieve-mode-hook nil
+ "Hook run in sieve mode buffers."
+ :group 'sieve
+ :type 'hook)
+
+;; Font-lock
+
+(defconst sieve-font-lock-keywords
+ (eval-when-compile
+ (list
+ ;; control commands
+ (cons (regexp-opt '("require" "if" "else" "elsif" "stop"))
+ 'font-lock-keyword-face)
+ ;; action commands
+ (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard"))
+ 'font-lock-keyword-face)
+ ;; test commands
+ (cons (regexp-opt '("address" "allof" "anyof" "exists" "false"
+ "true" "header" "not" "size" "envelope"))
+ 'font-lock-builtin-face)
+ (cons "\\Sw+:\\sw+" 'font-lock-constant-face))))
+
+;; Syntax table
+
+(defvar sieve-mode-syntax-table nil
+ "Syntax table in use in sieve-mode buffers.")
+
+(if sieve-mode-syntax-table
+ ()
+ (setq sieve-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\\ "\\" sieve-mode-syntax-table)
+ (modify-syntax-entry ?\n "> " sieve-mode-syntax-table)
+ (modify-syntax-entry ?\f "> " sieve-mode-syntax-table)
+ (modify-syntax-entry ?\# "< " sieve-mode-syntax-table)
+ (modify-syntax-entry ?/ "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?* "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?+ "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?- "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?= "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?% "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?< "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?> "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?& "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?| "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?_ "_" sieve-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" sieve-mode-syntax-table))
+
+;; Key map definition
+
+(defvar sieve-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-l" 'sieve-upload)
+ (define-key map "\C-c\C-m" 'sieve-manage)
+ map)
+ "Key map used in sieve mode.")
+
+;; Menu definition
+
+(defvar sieve-mode-menu nil
+ "Menubar used in sieve mode.")
+
+;; Code for Sieve editing mode.
+
+;;;###autoload
+(define-derived-mode sieve-mode c-mode "Sieve"
+ "Major mode for editing Sieve code.
+This is much like C mode except for the syntax of comments. Its keymap
+inherits from C mode's and it has the same variables for customizing
+indentation. It has its own abbrev table and its own syntax table.
+
+Turning on Sieve mode runs `sieve-mode-hook'."
+ (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'comment-start) "#")
+ (set (make-local-variable 'comment-end) "")
+ ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *")
+ (set (make-local-variable 'comment-start-skip) "#+ *")
+ (set (make-local-variable 'font-lock-defaults)
+ '(sieve-font-lock-keywords nil nil ((?_ . "w"))))
+ (easy-menu-add-item nil nil sieve-mode-menu))
+
+;; Menu
+
+(easy-menu-define sieve-mode-menu sieve-mode-map
+ "Sieve Menu."
+ '("Sieve"
+ ["Upload script" sieve-upload t]
+ ["Manage scripts on server" sieve-manage t]))
+
+(provide 'sieve-mode)
+
+;; sieve-mode.el ends here
--- /dev/null
+;;; sieve.el --- Utilities to manage sieve scripts
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+
+;; This file is not part of GNU Emacs, but the same permissions apply.
+
+;; 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 2, 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; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; 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.
+;;
+;; $Id: sieve.el,v 1.15 2001/08/17 11:20:15 jas Exp $
+;;
+;; 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 'easy-mmode)
+(require 'sieve-manage)
+(require 'sieve-mode)
+
+;; User customizable variables:
+
+(defgroup sieve nil
+ "Manage sieve scripts."
+ :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 [mouse-2] 'sieve-edit-script)
+ (define-key sieve-manage-mode-map [(down-mouse-3)] 'sieve-menu))
+
+(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))
+
+(put 'sieve-manage-mode 'mode-class 'special)
+
+(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]))
+
+;; 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)
+ (unless name
+ (error "No sieve script at point"))
+ (setq err (sieve-manage-setactive name sieve-manage-buffer))
+ (if (sieve-manage-ok-p err)
+ (message "Script %s activated." name)
+ (message "Failed to activate script %s: %s" name (nth 2 err)))
+ (sieve-refresh-scriptlist)))
+
+(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.")))
+
+(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 (substitute-command-keys
+ "`\\[sieve-help]':help `\\[cvs-mode-add]':add `\\[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))
+
+(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)
+
+(eval-and-compile
+ (defalias 'sieve-make-overlay (if (fboundp 'make-overlay)
+ 'make-overlay
+ 'make-extent))
+ (defalias 'sieve-overlay-put (if (fboundp 'overlay-put)
+ 'overlay-put
+ 'set-extent-property))
+ (defalias 'sieve-overlays-at (if (fboundp 'overlays-at)
+ 'overlays-at
+ 'extents-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)))))))
+
+(provide 'sieve)
+
+;; sieve.el ends here
projects / gnus / commitdiff