--- /dev/null
+;;; canlock-om.el --- Mule 2 specific functions for canlock
+;; Copyright (C) 2001 Katsumi Yamaoka
+
+;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: mule, cancel-lock
+
+;; This program 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.
+
+;; This program 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 this program; 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 program is used to make canlock.el work with Mule 2.3 based on
+;; Emacs 19.34. See README.ja in the canlock distribution for details.
+
+;;; Code:
+
+(eval-and-compile
+ (cond ((and (boundp 'emacs-major-version)
+ (> emacs-major-version 19))
+ (error "\
+Error: You should never use canlock-om.el(c) for this environment"))
+ ((and (boundp 'MULE)
+ (boundp 'emacs-major-version)
+ (= emacs-major-version 19)
+ (>= emacs-minor-version 29)))
+ (t
+ (error "Error: Canlock does not support this version of Emacs"))))
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'custom)
+(eval-and-compile
+ (unless (fboundp 'custom-declare-variable)
+ (error "Error: Canlock requires new custom")))
+
+(eval-when-compile
+ (unless (fboundp 'byte-compile-file-form-custom-declare-variable)
+ (defun byte-compile-file-form-custom-declare-variable (form)
+ ;; Bind defcustom'ed variables.
+ (if (memq 'free-vars byte-compile-warnings)
+ (setq byte-compile-bound-variables
+ (cons (nth 1 (nth 1 form)) byte-compile-bound-variables)))
+ (if (memq ':version (nthcdr 4 form))
+ ;; Make the variable uncustomizable.
+ `(defvar ,(nth 1 (nth 1 form)) ,(nth 1 (nth 2 form))
+ ,(substring (nth 3 form)
+ (if (string-match "^[\t *]+" (nth 3 form))
+ (match-end 0)
+ 0)))
+ ;; Ignore unsupported keyword(s).
+ (if (memq ':set-after (nthcdr 4 form))
+ (let ((newform (list (car form) (nth 1 form)
+ (nth 2 form) (nth 3 form)))
+ (args (nthcdr 4 form)))
+ (while args
+ (or (eq (car args) ':set-after)
+ (setq newform (nconc newform (list (car args)
+ (car (cdr args))))))
+ (setq args (cdr (cdr args))))
+ newform)
+ form)))
+ (put 'custom-declare-variable 'byte-hunk-handler
+ 'byte-compile-file-form-custom-declare-variable))
+
+ (define-compiler-macro with-temp-buffer (&whole form &rest forms)
+ (let ((def (if (fboundp 'with-temp-buffer)
+ (symbol-function 'with-temp-buffer))))
+ (if (and def
+ (consp def)
+ (or (eq (car def) 'macro)
+ (and (eq (car def) 'autoload)
+ (memq (nth 4 def) '(macro t)))))
+ form
+ ;; The function definition is imported from APEL.
+ `(let ((obuffer (current-buffer))
+ (buffer (generate-new-buffer " *temp*")))
+ (unwind-protect
+ (progn
+ (set-buffer buffer)
+ ,@forms)
+ (if (buffer-name buffer)
+ (kill-buffer buffer))
+ (if (buffer-live-p obuffer)
+ (set-buffer obuffer))))))))
+
+(autoload 'base64-encode "base64")
+
+(defcustom canlock-base64-encode-function 'base64-encode-string
+ "Function to call to base64 encode a string."
+ :type '(radio (function-item base64-encode-string)
+ (function-item base64-encode)
+ (function-item canlock-base64-encode-string-with-mmencode)
+ (function :tag "Other"))
+ :group 'canlock)
+
+(defcustom canlock-mmencode-program "mmencode"
+ "Name of mmencode program."
+ :type 'string
+ :group 'canlock)
+
+(defcustom canlock-mmencode-args-for-encoding nil
+ "Arguments passed to mmencode program for encoding."
+ :type 'sexp
+ :group 'canlock)
+
+(defun canlock-base64-encode-string-with-mmencode (string)
+ "Base64 encode a string using mmencode."
+ (with-temp-buffer
+ (setq mc-flag nil)
+ (insert string)
+ (let ((default-process-coding-system (cons *iso-2022-jp*dos *noconv*))
+ program-coding-system-alist selective-display)
+ (apply 'call-process-region (point-min) (point-max)
+ canlock-mmencode-program t t nil
+ canlock-mmencode-args-for-encoding))
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (buffer-substring (point-min) (point))))
+
+;; The following macros will only be used to byte-compile canlock.el.
+(eval-when-compile
+ (define-compiler-macro base64-encode-string
+ (&whole form string &optional no-line-break)
+ (if (and (string-equal (buffer-name) " *Compiler Input*")
+ (string-equal ";;; canlock.el"
+ (buffer-substring (point-min)
+ (min (+ (point-min) 14)
+ (point-max)))))
+ (if no-line-break
+ `(let ((string ,string))
+ (if ,no-line-break
+ (with-temp-buffer
+ (insert (funcall canlock-base64-encode-function string))
+ (goto-char (point-min))
+ (while (search-forward "\n" nil t)
+ (delete-char -1))
+ (buffer-string))
+ (funcall canlock-base64-encode-function string)))
+ `(funcall canlock-base64-encode-function ,string))
+ form))
+
+ (define-compiler-macro split-string (&whole form string &optional pattern)
+ (if (and (string-equal (buffer-name) " *Compiler Input*")
+ (string-equal ";;; canlock.el"
+ (buffer-substring (point-min)
+ (min (+ (point-min) 14)
+ (point-max)))))
+ ;; The function definition is imported from APEL.
+ (if pattern
+ `(let ((string ,string)
+ (pattern ,pattern)
+ (start 0)
+ parts)
+ (while (string-match pattern string start)
+ (setq parts (cons (substring string
+ start (match-beginning 0))
+ parts)
+ start (match-end 0)))
+ (nreverse (cons (substring string start) parts)))
+ `(let ((string ,string)
+ (start 0)
+ parts)
+ (while (string-match "[ \f\t\n\r\v]+" string start)
+ (setq parts (cons (substring string
+ start (match-beginning 0))
+ parts)
+ start (match-end 0)))
+ (nreverse (cons (substring string start) parts))))
+ form)))
+
+;; The following variables might not be bound if the old version of
+;; canlock.el(c) exists.
+(eval-when-compile
+ (defvar canlock-openssl-args)
+ (defvar canlock-openssl-program))
+
+(defun canlock-om-sha1-with-openssl (message)
+ "Make a SHA-1 digest of MESSAGE using OpenSSL."
+ (with-temp-buffer
+ (setq mc-flag nil)
+ (insert message)
+ (let ((default-process-coding-system (cons *iso-2022-jp*dos *noconv*))
+ program-coding-system-alist selective-display)
+ (apply 'call-process-region (point-min) (point-max)
+ canlock-openssl-program t t nil canlock-openssl-args))
+ (goto-char (point-min))
+ (insert "\"")
+ (while (re-search-forward "\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t)
+ (replace-match "\\\\x\\1"))
+ (insert "\"")
+ (goto-char (point-min))
+ (read (current-buffer))))
+
+;; Override the original function.
+(eval-after-load "canlock"
+ '(defalias 'canlock-sha1-with-openssl 'canlock-om-sha1-with-openssl))
+
+(provide 'canlock-om)
+
+(require 'canlock)
+
+;;; canlock-om.el ends here
--- /dev/null
+;;; canlock.el --- functions for Cancel-Lock feature
+
+;; Copyright (C) 1998, 1999, 2001, 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: news, cancel-lock, hmac, sha1, rfc2104
+
+;; This program 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.
+
+;; This program 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 this program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Canlock is a library for generating and verifying Cancel-Lock and/or
+;; Cancel-Key header in news articles. This is used to protect articles
+;; from rogue cancel, supersede or replace attacks. The method is based
+;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November
+;; 3rd 1998. For instance, you can add Cancel-Lock (and possibly Cancel-
+;; Key) header in a news article by using a hook which will be evaluated
+;; just before sending an article as follows:
+;;
+;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t)
+;;
+;; Verifying Cancel-Lock is mainly a function of news servers, however,
+;; you can verify your own article using the command `canlock-verify' in
+;; the (raw) article buffer. You will be prompted for the password for
+;; each time if the option `canlock-password' or `canlock-password-for-
+;; verify' is nil. Note that setting these options is a bit unsafe.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(autoload 'sha1-binary "sha1-el")
+(autoload 'base64-encode-string "base64")
+(autoload 'mail-fetch-field "mail-utils")
+(defvar mail-header-separator)
+
+(defgroup canlock nil
+ "The Cancel-Lock feature."
+ :group 'applications)
+
+(defcustom canlock-sha1-function 'sha1-binary
+ "Function to call to make a SHA-1 message digest."
+ :type '(radio (function-item sha1-binary)
+ (function-item canlock-sha1-with-openssl)
+ (function :tag "Other"))
+ :group 'canlock)
+
+(defcustom canlock-sha1-function-for-verify canlock-sha1-function
+ "Function to call to make a SHA-1 message digest for verifying."
+ :type '(radio (function-item sha1-binary)
+ (function-item canlock-sha1-with-openssl)
+ (function :tag "Other"))
+ :group 'canlock)
+
+(defcustom canlock-openssl-program "openssl"
+ "Name of OpenSSL program."
+ :type 'string
+ :group 'canlock)
+
+(defcustom canlock-openssl-args '("sha1")
+ "Arguments passed to the OpenSSL program."
+ :type 'sexp
+ :group 'canlock)
+
+(defcustom canlock-ignore-errors nil
+ "If non-nil, ignore any error signals."
+ :type 'boolean
+ :group 'canlock)
+
+(defcustom canlock-password nil
+ "Password to use when signing a Cancel-Lock or a Cancel-Key header."
+ :type 'string
+ :group 'canlock)
+
+(defcustom canlock-password-for-verify canlock-password
+ "Password to use when verifying a Cancel-Lock or a Cancel-Key header."
+ :type 'string
+ :group 'canlock)
+
+(defcustom canlock-force-insert-header nil
+ "If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the
+buffer does not look like a news message."
+ :type 'boolean
+ :group 'canlock)
+
+(defun canlock-sha1-with-openssl (message)
+ "Make a SHA-1 digest of MESSAGE using OpenSSL."
+ (let (default-enable-multibyte-characters)
+ (with-temp-buffer
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ selective-display
+ (case-fold-search t))
+ (insert message)
+ (apply 'call-process-region (point-min) (point-max)
+ canlock-openssl-program t t nil canlock-openssl-args)
+ (goto-char (point-min))
+ (insert "\"")
+ (while (re-search-forward "\\([0-9a-f][0-9a-f]\\)" nil t)
+ (replace-match "\\\\x\\1"))
+ (insert "\"")
+ (goto-char (point-min))
+ (read (current-buffer))))))
+
+(eval-when-compile
+ (defmacro canlock-string-as-unibyte (string)
+ "Return a unibyte string with the same individual bytes as STRING."
+ (if (fboundp 'string-as-unibyte)
+ (list 'string-as-unibyte string)
+ string)))
+
+(defun canlock-sha1 (message)
+ "Make a SHA-1 digest of MESSAGE as a unibyte string of length 20 bytes."
+ (canlock-string-as-unibyte (funcall canlock-sha1-function message)))
+
+(defun canlock-make-cancel-key (message-id password)
+ "Make a Cancel-Key header."
+ (when (> (length password) 20)
+ (setq password (canlock-sha1 password)))
+ (setq password (concat password (make-string (- 64 (length password)) 0)))
+ (let ((ipad (mapconcat (lambda (byte)
+ (char-to-string (logxor 54 byte)))
+ password ""))
+ (opad (mapconcat (lambda (byte)
+ (char-to-string (logxor 92 byte)))
+ password "")))
+ (base64-encode-string
+ (canlock-sha1
+ (concat opad
+ (canlock-sha1
+ (concat ipad (canlock-string-as-unibyte message-id))))))))
+
+(defun canlock-narrow-to-header ()
+ "Narrow the buffer to the head of the message."
+ (let (case-fold-search)
+ (narrow-to-region
+ (goto-char (point-min))
+ (goto-char (if (re-search-forward
+ (format "^$\\|^%s$"
+ (regexp-quote mail-header-separator))
+ nil t)
+ (match-beginning 0)
+ (point-max))))))
+
+(defun canlock-delete-headers ()
+ "Delete Cancel-Key or Cancel-Lock headers in the narrowed buffer."
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t)
+ (delete-region (match-beginning 0)
+ (if (re-search-forward "^[^\t ]" nil t)
+ (goto-char (match-beginning 0))
+ (point-max))))))
+
+(defun canlock-fetch-fields (&optional key)
+ "Return a list of the values of Cancel-Lock header.
+If KEY is non-nil, look for a Cancel-Key header instead. The buffer
+is expected to be narrowed to just the headers of the message."
+ (let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock")))
+ fields rest
+ (case-fold-search t))
+ (when field
+ (setq fields (split-string field "[\t\n\r ,]+"))
+ (while fields
+ (when (string-match "^sha1:" (setq field (pop fields)))
+ (push (substring field 5) rest)))
+ (nreverse rest))))
+
+(defun canlock-fetch-id-for-key ()
+ "Return a Message-ID in Cancel, Supersedes or Replaces header.
+The buffer is expected to be narrowed to just the headers of the
+message."
+ (or (let ((cancel (mail-fetch-field "Control")))
+ (and cancel
+ (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
+ cancel)
+ (match-string 1 cancel)))
+ (mail-fetch-field "Supersedes")
+ (mail-fetch-field "Replaces")))
+
+;;;###autoload
+(defun canlock-insert-header (&optional id-for-key id-for-lock password)
+ "Insert a Cancel-Key and/or a Cancel-Lock header if possible."
+ (let (news control key-for-key key-for-lock)
+ (save-excursion
+ (save-restriction
+ (canlock-narrow-to-header)
+ (when (setq news (or canlock-force-insert-header
+ (mail-fetch-field "Newsgroups")))
+ (unless id-for-key
+ (setq id-for-key (canlock-fetch-id-for-key)))
+ (if (and (setq control (mail-fetch-field "Control"))
+ (string-match
+ "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
+ control))
+ (setq id-for-lock nil)
+ (unless id-for-lock
+ (setq id-for-lock (mail-fetch-field "Message-ID"))))
+ (canlock-delete-headers)
+ (goto-char (point-max))))
+ (when news
+ (if (not (or id-for-key id-for-lock))
+ (message "There are no Message-ID(s)")
+ (unless password
+ (setq password (or canlock-password
+ (read-passwd
+ "Password for Canlock: "))))
+ (if (or (not (stringp password)) (zerop (length password)))
+ (message "Password for Canlock is bad")
+ (setq key-for-key (when id-for-key
+ (canlock-make-cancel-key
+ id-for-key password))
+ key-for-lock (when id-for-lock
+ (canlock-make-cancel-key
+ id-for-lock password)))
+ (if (not (or key-for-key key-for-lock))
+ (message "Couldn't insert Canlock header")
+ (when key-for-key
+ (insert "Cancel-Key: sha1:" key-for-key "\n"))
+ (when key-for-lock
+ (insert "Cancel-Lock: sha1:"
+ (base64-encode-string (canlock-sha1 key-for-lock))
+ "\n")))))))))
+
+;;;###autoload
+(defun canlock-verify (&optional buffer)
+ "Verify Cancel-Lock or Cancel-Key in BUFFER.
+If BUFFER is nil, the current buffer is assumed. Signal an error if
+it fails. You can modify the behavior of this function to return non-
+nil instead of to signal an error by setting the option
+`canlock-ignore-errors' to non-nil."
+ (interactive)
+ (let ((canlock-sha1-function (or canlock-sha1-function-for-verify
+ canlock-sha1-function))
+ keys locks errmsg id-for-key id-for-lock password
+ key-for-key key-for-lock match)
+ (save-excursion
+ (when buffer
+ (set-buffer buffer))
+ (save-restriction
+ (widen)
+ (canlock-narrow-to-header)
+ (setq keys (canlock-fetch-fields 'key)
+ locks (canlock-fetch-fields))
+ (if (not (or keys locks))
+ (setq errmsg
+ "There are neither Cancel-Lock nor Cancel-Key headers")
+ (setq id-for-key (canlock-fetch-id-for-key)
+ id-for-lock (mail-fetch-field "Message-ID"))
+ (or id-for-key id-for-lock
+ (setq errmsg "There are no Message-ID(s)")))))
+
+ (if errmsg
+ (if canlock-ignore-errors
+ errmsg
+ (error "%s" errmsg))
+
+ (setq password (or canlock-password-for-verify
+ (read-passwd "Password for Canlock: ")))
+ (if (or (not (stringp password)) (zerop (length password)))
+ (progn
+ (setq errmsg "Password for Canlock is bad")
+ (if canlock-ignore-errors
+ errmsg
+ (error "%s" errmsg)))
+
+ (when keys
+ (when id-for-key
+ (setq key-for-key (canlock-make-cancel-key id-for-key password))
+ (while (and keys (not match))
+ (setq match (string-equal key-for-key (pop keys)))))
+ (setq keys (if match "good" "bad")))
+ (setq match nil)
+
+ (when locks
+ (when id-for-lock
+ (setq key-for-lock
+ (base64-encode-string
+ (canlock-sha1 (canlock-make-cancel-key id-for-lock
+ password))))
+ (when (and locks (not match))
+ (setq match (string-equal key-for-lock (pop locks)))))
+ (setq locks (if match "good" "bad")))
+
+ (prog1
+ (when (member "bad" (list keys locks))
+ "bad")
+ (cond ((and keys locks)
+ (message "Cancel-Key is %s, Cancel-Lock is %s" keys locks))
+ (locks
+ (message "Cancel-Lock is %s" locks))
+ (keys
+ (message "Cancel-Key is %s" keys))))))))
+
+(provide 'canlock)
+
+;;; canlock.el ends here
--- /dev/null
+;;; compface.el --- functions for converting X-Face headers
+;; Copyright (C) 2002 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: news
+
+;; 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 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:
+
+;;; Code:
+
+;;;###
+(defun uncompface (face)
+ "Convert FACE to pbm.
+Requires the external programs `uncompface', and `icontopbm'. On a
+GNU/Linux system these might be in packages with names like `compface'
+or `faces-xface' and `netpbm' or `libgr-progs', for instance."
+ (with-temp-buffer
+ (insert face)
+ (and (eq 0 (apply 'call-process-region (point-min) (point-max)
+ "uncompface"
+ 'delete '(t nil) nil))
+ (progn
+ (goto-char (point-min))
+ (insert "/* Width=48, Height=48 */\n")
+ ;; I just can't get "icontopbm" to work correctly on its
+ ;; own in XEmacs. And Emacs doesn't understand un-raw pbm
+ ;; files.
+ (if (not (featurep 'xemacs))
+ (eq 0 (call-process-region (point-min) (point-max)
+ "icontopbm"
+ 'delete '(t nil)))
+ (shell-command-on-region (point-min) (point-max)
+ "icontopbm | pnmnoraw"
+ (current-buffer) t)
+ t))
+ (buffer-string))))
+
+(provide 'compface)
+
+;;; compface.el ends here
--- /dev/null
+;;; deuglify.el --- deuglify broken Outlook (Express) articles
+
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002 Raymond Scholz
+
+;; Author: Raymond Scholz <rscholz@zonix.de>
+;; Thomas Steffen (unwrapping algorithm,
+;; based on an idea of Stefan Monnier)
+;; Keywords: mail, news
+
+;; 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 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 enables Gnus to repair broken citations produced by
+;; common user agents like MS Outlook (Express). It may repair
+;; articles of other user agents too.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; Outlook sometimes wraps cited lines before sending a message as
+;; seen in this example:
+;;
+;; Example #1
+;; ----------
+;;
+;; John Doe wrote:
+;;
+;; > This sentence no verb. This sentence no verb. This sentence
+;; no
+;; > verb. This sentence no verb. This sentence no verb. This
+;; > sentence no verb.
+;;
+;; The function `gnus-article-outlook-unwrap-lines' tries to recognize those
+;; erroneously wrapped lines and will unwrap them. I.e. putting the
+;; wrapped parts ("no" in this example) back where they belong (at the
+;; end of the cited line above).
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Note that some people not only use broken user agents but also
+;; practice a bad citation style by omitting blank lines between the
+;; cited text and their own text.
+;:
+;; Example #2
+;; ----------
+;;
+;; John Doe wrote:
+;;
+;; > This sentence no verb. This sentence no verb. This sentence no
+;; You forgot in all your sentences.
+;; > verb. This sentence no verb. This sentence no verb. This
+;; > sentence no verb.
+;;
+;; Unwrapping "You forgot in all your sentences." would be illegal as
+;; this part wasn't intended to be cited text.
+;; `gnus-article-outlook-unwrap-lines' will only unwrap lines if the resulting
+;; citation line will be of a certain maximum length. You can control
+;; this by adjusting `gnus-outlook-deuglify-unwrap-max'. Also
+;; unwrapping will only be done if the line above the (possibly)
+;; wrapped line has a minimum length of `gnus-outlook-deuglify-unwrap-min'.
+;;
+;; Furthermore no unwrapping will be undertaken if the last character
+;; is one of the chars specified in
+;; `gnus-outlook-deuglify-unwrap-stop-chars'. Setting this to ".?!"
+;; inhibits unwrapping if the cited line ends with a full stop,
+;; question mark or exclamation mark. Note that this variable
+;; defaults to `nil', triggering a few false positives but generally
+;; giving you better results.
+;;
+;; Unwrapping works on every level of citation. Thus you will be able
+;; repair broken citations of broken user agents citing broken
+;; citations of broken user agents citing broken citations...
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Citations are commonly introduced with an attribution line
+;; indicating who wrote the cited text. Outlook adds superfluous
+;; information that can be found in the header of the message to this
+;; line and often wraps it.
+;;
+;; If that weren't enough, lots of people write their own text above
+;; the cited text and cite the complete original article below.
+;;
+;; Example #3
+;; ----------
+;;
+;; Hey, John. There's no in all your sentences!
+;;
+;; John Doe <john.doe@some.domain> wrote in message
+;; news:a87usw8$dklsssa$2@some.news.server...
+;; > This sentence no verb. This sentence no verb. This sentence
+;; no
+;; > verb. This sentence no verb. This sentence no verb. This
+;; > sentence no verb.
+;; >
+;; > Bye, John
+;;
+;; Repairing the attribution line will be done by function
+;; `gnus-article-outlook-repair-attribution which calls other function that
+;; try to recognize and repair broken attribution lines. See variable
+;; `gnus-outlook-deuglify-attrib-cut-regexp' for stuff that should be
+;; cut off from the beginning of an attribution line and variable
+;; `gnus-outlook-deuglify-attrib-verb-regexp' for the verbs that are
+;; required to be found in an attribution line. These function return
+;; the point where the repaired attribution line starts.
+;;
+;; Rearranging the article so that the cited text appears above the
+;; new text will be done by function
+;; `gnus-article-outlook-rearrange-citation'. This function calls
+;; `gnus-article-outlook-repair-attribution to find and repair an attribution
+;; line.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Well, and that's what the message will look like after applying
+;; deuglification:
+;;
+;; Example #3 (deuglified)
+;; -----------------------
+;;
+;; John Doe <john.doe@some.domain> wrote:
+;;
+;; > This sentence no verb. This sentence no verb. This sentence no
+;; > verb. This sentence no verb. This sentence no verb. This
+;; > sentence no verb.
+;; >
+;; > Bye, John
+;;
+;; Hey, John. There's no in all your sentences!
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Usage
+;; -----
+;;
+;; Press `W k' in the Summary Buffer.
+;;
+;; Non recommended usage :-)
+;; ---------------------
+;;
+;; To automatically invoke deuglification on every article you read,
+;; put something like that in your .gnus:
+;;
+;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-unwrap-lines)
+;;
+;; or _one_ of the following lines:
+;;
+;; ;; repair broken attribution lines
+;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-repair-attribution)
+;;
+;; ;; repair broken attribution lines and citations
+;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-rearrange-citation)
+;;
+;; Note that there always may be some false positives, so I suggest
+;; using the manual invocation. After deuglification you may want to
+;; refill the whole article using `W w'.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Limitations
+;; -----------
+;;
+;; As I said before there may (or will) be a few false positives on
+;; unwrapping cited lines with `gnus-article-outlook-unwrap-lines'.
+;;
+;; `gnus-article-outlook-repair-attribution will only fix the first
+;; attribution line found in the article. Furthermore it fixed to
+;; certain kinds of attributions. And there may be horribly many
+;; false positives, vanishing lines and so on -- so don't trust your
+;; eyes. Again I recommend manual invocation.
+;;
+;; `gnus-article-outlook-rearrange-citation' carries all the limitations of
+;; `gnus-article-outlook-repair-attribution.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; See ChangeLog for other changes.
+;;
+;; Revision 1.5 2002/01/27 14:39:17 rscholz
+;; * New variable `gnus-outlook-deuglify-no-wrap-chars' to inhibit
+;; unwrapping if one these chars is first in the possibly wrapped line.
+;; * Improved rearranging of the article.
+;; * New function `gnus-outlook-repair-attribution-block' for repairing
+;; those big "Original Message (following some headers)" attributions.
+;;
+;; Revision 1.4 2002/01/03 14:05:00 rscholz
+;; Renamed `gnus-outlook-deuglify-article' to
+;; `gnus-article-outlook-deuglify-article'.
+;; Made it easier to deuglify the article while being in Gnus' Article
+;; Edit Mode. (suggested by Phil Nitschke)
+;;
+;;
+;; Revision 1.3 2002/01/02 23:35:54 rscholz
+;; Fix a bug that caused succeeding long attribution lines to be
+;; unwrapped. Minor doc fixes and regular expression tuning.
+;;
+;; Revision 1.2 2001/12/30 20:14:34 rscholz
+;; Clean up source.
+;;
+;; Revision 1.1 2001/12/30 20:13:32 rscholz
+;; Initial revision
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Code:
+
+(require 'gnus-art)
+(require 'gnus-sum)
+
+(defconst gnus-outlook-deuglify-version "1.5 Gnus version"
+ "Version of gnus-outlook-deuglify.")
+
+;;; User Customizable Variables:
+
+(defgroup gnus-outlook-deuglify nil
+ "Deuglify articles generated by broken user agents like MS Outlook (Express).")
+
+;;;###autoload
+(defcustom gnus-outlook-deuglify-unwrap-min 45
+ "Minimum length of the cited line above the (possibly) wrapped line."
+ :type 'number
+ :group 'gnus-outlook-deuglify)
+
+;;;###autoload
+(defcustom gnus-outlook-deuglify-unwrap-max 95
+ "Maximum length of the cited line after unwrapping."
+ :type 'number
+ :group 'gnus-outlook-deuglify)
+
+(defcustom gnus-outlook-deuglify-cite-marks ">|#%"
+ "Characters that indicate cited lines."
+ :type 'string
+ :group 'gnus-outlook-deuglify)
+
+(defcustom gnus-outlook-deuglify-unwrap-stop-chars nil ;; ".?!" or nil
+ "Characters that inhibit unwrapping if they are the last one on the cited line above the possible wrapped line."
+ :type 'string
+ :group 'gnus-outlook-deuglify)
+
+(defcustom gnus-outlook-deuglify-no-wrap-chars "`"
+ "Characters that inhibit unwrapping if they are the first one in the possibly wrapped line."
+ :type 'string
+ :group 'gnus-outlook-deuglify)
+
+(defcustom gnus-outlook-deuglify-attrib-cut-regexp
+ "\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, "
+ "Regular expression matching the beginning of an attribution line that should be cut off."
+ :type 'string
+ :group 'gnus-outlook-deuglify)
+
+(defcustom gnus-outlook-deuglify-attrib-verb-regexp
+ "wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a écrit\\|schreef\\|escribió"
+ "Regular expression matching the verb used in an attribution line."
+ :type 'string
+ :group 'gnus-outlook-deuglify)
+
+(defcustom gnus-outlook-deuglify-attrib-end-regexp
+ ": *\\|\\.\\.\\."
+ "Regular expression matching the end of an attribution line."
+ :type 'string
+ :group 'gnus-outlook-deuglify)
+
+;;;###autoload
+(defcustom gnus-outlook-display-hook nil
+ "A hook called after an deuglified article has been prepared.
+It is run after `gnus-article-prepare-hook'."
+ :type 'hook
+ :group 'gnus-outlook-deuglify)
+
+;; Functions
+
+(defun gnus-outlook-display-article-buffer ()
+ "Redisplay current buffer or article buffer."
+ (with-current-buffer (or gnus-article-buffer (current-buffer))
+ ;; "Emulate" `gnus-article-prepare-display' without calling
+ ;; it. Calling `gnus-article-prepare-display' on an already
+ ;; prepared article removes all MIME parts. I'm unsure whether
+ ;; this is a bug or not.
+ (gnus-article-highlight t)
+ (gnus-treat-article nil)
+ (gnus-run-hooks 'gnus-article-prepare-hook
+ 'gnus-outlook-display-hook)))
+
+;;;###autoload
+(defun gnus-article-outlook-unwrap-lines (&optional nodisplay)
+ "Unwrap lines that appear to be wrapped citation lines.
+You can control what lines will be unwrapped by frobbing
+`gnus-outlook-deuglify-unwrap-min' and `gnus-outlook-deuglify-unwrap-max',
+indicating the miminum and maximum length of an unwrapped citation line. If
+NODISPLAY is non-nil, don't redisplay the article buffer."
+ (interactive "P")
+ (save-excursion
+ (let ((case-fold-search nil)
+ (inhibit-read-only t)
+ (cite-marks gnus-outlook-deuglify-cite-marks)
+ (no-wrap gnus-outlook-deuglify-no-wrap-chars)
+ (stop-chars gnus-outlook-deuglify-unwrap-stop-chars))
+ (gnus-with-article-buffer
+ (article-goto-body)
+ (while (re-search-forward
+ (concat
+ "^\\([ \t" cite-marks "]*\\)"
+ "\\([" cite-marks "].*[^\n " stop-chars "]\\)[ \t]?\n"
+ "\\1\\([^\n " cite-marks no-wrap "]+.*\\)$")
+ nil t)
+ (let ((len12 (- (match-end 2) (match-beginning 1)))
+ (len3 (- (match-end 3) (match-beginning 3))))
+ (if (and (> len12 gnus-outlook-deuglify-unwrap-min)
+ (< (+ len12 len3) gnus-outlook-deuglify-unwrap-max))
+ (progn
+ (replace-match "\\1\\2 \\3")
+ (goto-char (match-beginning 0)))))))))
+ (unless nodisplay (gnus-outlook-display-article-buffer)))
+
+(defun gnus-outlook-rearrange-article (attr-start)
+ "Put the text from `attr-start' to the end of buffer at the top of the article buffer."
+ (save-excursion
+ (let ((inhibit-read-only t)
+ (cite-marks gnus-outlook-deuglify-cite-marks))
+ (gnus-with-article-buffer
+ (article-goto-body)
+ ;; article does not start with attribution
+ (unless (= (point) attr-start)
+ (gnus-kill-all-overlays)
+ (let ((cur (point))
+ ;; before signature or end of buffer
+ (to (if (gnus-article-search-signature)
+ (point)
+ (point-max))))
+ ;; handle the case where the full quote is below the
+ ;; signature
+ (if (< to attr-start)
+ (setq to (point-max)))
+ (transpose-regions cur attr-start attr-start to)))))))
+
+;; John Doe <john.doe@some.domain> wrote in message
+;; news:a87usw8$dklsssa$2@some.news.server...
+
+(defun gnus-outlook-repair-attribution-outlook ()
+ "Repair a broken attribution line (Outlook)."
+ (save-excursion
+ (let ((case-fold-search nil)
+ (inhibit-read-only t)
+ (cite-marks gnus-outlook-deuglify-cite-marks))
+ (gnus-with-article-buffer
+ (article-goto-body)
+ (if (re-search-forward
+ (concat "^\\([^" cite-marks "].+\\)"
+ "\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\)"
+ "\\(.*\n?[^\n" cite-marks "].*\\)?"
+ "\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$")
+ nil t)
+ (progn
+ (gnus-kill-all-overlays)
+ (replace-match "\\1\\2\\4")
+ (match-beginning 0)))))))
+
+
+;; ----- Original Message -----
+;; From: "John Doe" <john.doe@some.domain>
+;; To: "Doe Foundation" <info@doefnd.org>
+;; Sent: Monday, November 19, 2001 12:13 PM
+;; Subject: More Doenuts
+
+(defun gnus-outlook-repair-attribution-block ()
+ "Repair a big broken attribution block."
+ (save-excursion
+ (let ((case-fold-search nil)
+ (inhibit-read-only t)
+ (cite-marks gnus-outlook-deuglify-cite-marks))
+ (gnus-with-article-buffer
+ (article-goto-body)
+ (if (re-search-forward
+ (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n"
+ "[^\n:]+:[ \t]*\\([^\n]+\\)\n"
+ "\\([^\n:]+:[ \t]*[^\n]+\n\\)+")
+ nil t)
+ (progn
+ (gnus-kill-all-overlays)
+ (replace-match "\\1 wrote:\n")
+ (match-beginning 0)))))))
+
+;; On Wed, 16 Jan 2002 23:23:30 +0100, John Doe <john.doe@some.domain> wrote:
+
+(defun gnus-outlook-repair-attribution-other ()
+ "Repair a broken attribution line (other user agents than Outlook)."
+ (save-excursion
+ (let ((case-fold-search nil)
+ (inhibit-read-only t)
+ (cite-marks gnus-outlook-deuglify-cite-marks))
+ (gnus-with-article-buffer
+ (article-goto-body)
+ (if (re-search-forward
+ (concat "^\\("gnus-outlook-deuglify-attrib-cut-regexp"\\)?"
+ "\\([^" cite-marks "].+\\)\n\\([^\n" cite-marks "].*\\)?"
+ "\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\).*"
+ "\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$")
+ nil t)
+ (progn
+ (gnus-kill-all-overlays)
+ (replace-match "\\4 \\5\\6\\7")
+ (match-beginning 0)))))))
+
+;;;###autoload
+(defun gnus-article-outlook-repair-attribution (&optional nodisplay)
+ "Repair a broken attribution line.
+If NODISPLAY is non-nil, don't redisplay the article buffer."
+ (interactive "P")
+ (let ((attrib-start
+ (or
+ (gnus-outlook-repair-attribution-other)
+ (gnus-outlook-repair-attribution-block)
+ (gnus-outlook-repair-attribution-outlook))))
+ (unless nodisplay (gnus-outlook-display-article-buffer))
+ attrib-start))
+
+(defun gnus-article-outlook-rearrange-citation (&optional nodisplay)
+ "Repair broken citations.
+If NODISPLAY is non-nil, don't redisplay the article buffer."
+ (interactive "P")
+ (let ((attrib-start (gnus-article-outlook-repair-attribution 'nodisplay)))
+ ;; rearrange citations if an attribution line has been recognized
+ (if attrib-start
+ (gnus-outlook-rearrange-article attrib-start)))
+ (unless nodisplay (gnus-outlook-display-article-buffer)))
+
+;;;###autoload
+(defun gnus-outlook-deuglify-article (&optional nodisplay)
+ "Full deuglify of broken Outlook (Express) articles.
+Treat dumbquotes, unwrap lines, repair attribution and rearrange citation. If
+NODISPLAY is non-nil, don't redisplay the article buffer."
+ (interactive "P")
+ ;; apply treatment of dumb quotes
+ (gnus-article-treat-dumbquotes)
+ ;; repair wrapped cited lines
+ (gnus-article-outlook-unwrap-lines 'nodisplay)
+ ;; repair attribution line and rearrange citation.
+ (gnus-article-outlook-rearrange-citation 'nodisplay)
+ (unless nodisplay (gnus-outlook-display-article-buffer)))
+
+;;;###autoload
+(defun gnus-article-outlook-deuglify-article ()
+ "Deuglify broken Outlook (Express) articles and redisplay."
+ (interactive)
+ (gnus-outlook-deuglify-article nil))
+
+(provide 'deuglify)
+
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
+;;; deuglify.el ends here
--- /dev/null
+;;; dig.el --- Domain Name System dig interface
+;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Keywords: DNS BIND dig
+
+;; 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 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 provide an interface for "dig".
+;;
+;; For interactive use, try M-x dig and type a hostname. Use `q' to quit
+;; dig buffer.
+;;
+;; For use in elisp programs, call `dig-invoke' and use
+;; `dig-extract-rr' to extract resource records.
+
+;;; Release history:
+
+;; 2000-10-28 posted on gnu.emacs.sources
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defgroup dig nil
+ "Dig configuration.")
+
+(defcustom dig-program "dig"
+ "Name of dig (domain information groper) binary."
+ :type 'file
+ :group 'dig)
+
+(defcustom dig-dns-server nil
+ "DNS server to query.
+If nil, use system defaults."
+ :type '(choice (const :tag "System defaults")
+ string)
+ :group 'dig)
+
+(defcustom dig-font-lock-keywords
+ '(("^;; [A-Z]+ SECTION:" 0 font-lock-keyword-face)
+ ("^;;.*" 0 font-lock-comment-face)
+ ("^; <<>>.*" 0 font-lock-type-face)
+ ("^;.*" 0 font-lock-function-name-face))
+ "Default expressions to highlight in dig mode."
+ :type 'sexp
+ :group 'dig)
+
+(defun dig-invoke (domain &optional
+ query-type query-class query-option
+ dig-option server)
+ "Call dig with given arguments and return buffer containing output.
+DOMAIN is a string with a DNS domain. QUERY-TYPE is an optional string
+with a DNS type. QUERY-CLASS is an optional string with a DNS class.
+QUERY-OPTION is an optional string with dig \"query options\".
+DIG-OPTIONS is an optional string with parameters for the dig program.
+SERVER is an optional string with a domain name server to query.
+
+Dig is an external program found in the BIND name server distribution,
+and is a commonly available debugging tool."
+ (let (buf cmdline)
+ (setq buf (generate-new-buffer "*dig output*"))
+ (if dig-option (push dig-option cmdline))
+ (if query-option (push query-option cmdline))
+ (if query-class (push query-class cmdline))
+ (if query-type (push query-type cmdline))
+ (push domain cmdline)
+ (if server (push (concat "@" server) cmdline)
+ (if dig-dns-server (push (concat "@" dig-dns-server) cmdline)))
+ (apply 'call-process dig-program nil buf nil cmdline)
+ buf))
+
+(defun dig-extract-rr (domain &optional type class)
+ "Extract resource records for DOMAIN, TYPE and CLASS from buffer.
+Buffer should contain output generated by `dig-invoke'."
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat domain "\\.?[\t ]+[0-9wWdDhHmMsS]+[\t ]+"
+ (upcase (or class "IN")) "[\t ]+" (upcase (or type "A")))
+ nil t)
+ (let (b e)
+ (end-of-line)
+ (setq e (point))
+ (beginning-of-line)
+ (setq b (point))
+ (when (search-forward " (" e t)
+ (search-forward " )"))
+ (end-of-line)
+ (setq e (point))
+ (buffer-substring b e))
+ (and (re-search-forward (concat domain "\\.?[\t ]+[0-9wWdDhHmMsS]+[\t ]+"
+ (upcase (or class "IN"))
+ "[\t ]+CNAME[\t ]+\\(.*\\)$") nil t)
+ (dig-extract-rr (match-string 1) type class)))))
+
+(defun dig-rr-get-pkix-cert (rr)
+ (let (b e str)
+ (string-match "[^\t ]+[\t ]+[0-9wWdDhHmMsS]+[\t ]+IN[\t ]+CERT[\t ]+\\(1\\|PKIX\\)[\t ]+[0-9]+[\t ]+[0-9]+[\t ]+(?" rr)
+ (setq b (match-end 0))
+ (string-match ")" rr)
+ (setq e (match-beginning 0))
+ (setq str (substring rr b e))
+ (while (string-match "[\t \n\r]" str)
+ (setq str (replace-match "" nil nil str)))
+ str))
+
+;; XEmacs does it like this. For Emacs, we have to set the
+;; `font-lock-defaults' buffer-local variable.
+(put 'dig-mode 'font-lock-defaults '(dig-font-lock-keywords t))
+
+(put 'dig-mode 'mode-class 'special)
+
+(defvar dig-mode-map nil)
+(unless dig-mode-map
+ (setq dig-mode-map (make-sparse-keymap))
+ (suppress-keymap dig-mode-map)
+
+ (define-key dig-mode-map "q" 'dig-exit))
+
+(defun dig-mode ()
+ "Major mode for displaying dig output."
+ (interactive)
+ (kill-all-local-variables)
+ (setq mode-name "dig")
+ (setq major-mode 'dig-mode)
+ (use-local-map dig-mode-map)
+ (buffer-disable-undo)
+ (unless (featurep 'xemacs)
+ (set (make-local-variable 'font-lock-defaults)
+ '(dig-font-lock-keywords t)))
+ (when (featurep 'font-lock)
+ (font-lock-set-defaults)))
+
+(defun dig-exit ()
+ "Quit dig output buffer."
+ (interactive)
+ (kill-buffer (current-buffer)))
+
+(defun dig (domain &optional
+ query-type query-class query-option dig-option server)
+ "Query addresses of a DOMAIN using dig, by calling `dig-invoke'.
+Optional arguments are passed to `dig-invoke'."
+ (interactive "sHost: ")
+ (switch-to-buffer
+ (dig-invoke domain query-type query-class query-option dig-option server))
+ (goto-char (point-min))
+ (and (search-forward ";; ANSWER SECTION:" nil t)
+ (forward-line))
+ (dig-mode)
+ (setq buffer-read-only t)
+ (set-buffer-modified-p nil))
+
+;; named for consistency with query-dns in dns.el
+(defun query-dig (domain &optional
+ query-type query-class query-option dig-option server)
+ "Query addresses of a DOMAIN using dig.
+It works by calling `dig-invoke' and `dig-extract-rr'. Optional
+arguments are passed to `dig-invoke' and `dig-extract-rr'. Returns
+nil for domain/class/type queries that results in no data."
+(let ((buffer (dig-invoke domain query-type query-class
+ query-option dig-option server)))
+ (when buffer
+ (switch-to-buffer buffer)
+ (let ((digger (dig-extract-rr domain query-type query-class)))
+ (kill-buffer buffer)
+ digger))))
+
+(provide 'dig)
+
+;;; dig.el ends here
--- /dev/null
+;;; dns.el --- Domain Name Service lookups
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: network
+
+;; 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 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:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'mm-util)
+
+(defvar dns-timeout 5
+ "How many seconds to wait when doing DNS queries.")
+
+(defvar dns-servers nil
+ "Which DNS servers to query.
+If nil, /etc/resolv.conf will be consulted.")
+
+;;; Internal code:
+
+(defvar dns-query-types
+ '((A 1)
+ (NS 2)
+ (MD 3)
+ (MF 4)
+ (CNAME 5)
+ (SOA 6)
+ (MB 7)
+ (MG 8)
+ (MR 9)
+ (NULL 10)
+ (WKS 11)
+ (PRT 12)
+ (HINFO 13)
+ (MINFO 14)
+ (MX 15)
+ (TXT 16)
+ (AXFR 252)
+ (MAILB 253)
+ (MAILA 254)
+ (* 255))
+ "Names of query types and their values.")
+
+(defvar dns-classes
+ '((IN 1)
+ (CS 2)
+ (CH 3)
+ (HS 4))
+ "Classes of queries.")
+
+(defun dns-write-bytes (value &optional length)
+ (let (bytes)
+ (dotimes (i (or length 1))
+ (push (% value 256) bytes)
+ (setq value (/ value 256)))
+ (dolist (byte bytes)
+ (insert byte))))
+
+(defun dns-read-bytes (length)
+ (let ((value 0))
+ (dotimes (i length)
+ (setq value (logior (* value 256) (following-char)))
+ (forward-char 1))
+ value))
+
+(defun dns-get (type spec)
+ (cadr (assq type spec)))
+
+(defun dns-inverse-get (value spec)
+ (let ((found nil))
+ (while (and (not found)
+ spec)
+ (if (eq value (cadr (car spec)))
+ (setq found (caar spec))
+ (pop spec)))
+ found))
+
+(defun dns-write-name (name)
+ (dolist (part (split-string name "\\."))
+ (dns-write-bytes (length part))
+ (insert part))
+ (dns-write-bytes 0))
+
+(defun dns-read-string-name (string buffer)
+ (mm-with-unibyte-buffer
+ (insert string)
+ (goto-char (point-min))
+ (dns-read-name buffer)))
+
+(defun dns-read-name (&optional buffer)
+ (let ((ended nil)
+ (name nil)
+ length)
+ (while (not ended)
+ (setq length (dns-read-bytes 1))
+ (if (= 192 (logand length (lsh 3 6)))
+ (let ((offset (+ (* (logand 63 length) 256)
+ (dns-read-bytes 1))))
+ (save-excursion
+ (when buffer
+ (set-buffer buffer))
+ (goto-char (1+ offset))
+ (setq ended (dns-read-name buffer))))
+ (if (zerop length)
+ (setq ended t)
+ (push (buffer-substring (point)
+ (progn (forward-char length) (point)))
+ name))))
+ (if (stringp ended)
+ (if (null name)
+ ended
+ (concat (mapconcat 'identity (nreverse name) ".") "." ended))
+ (mapconcat 'identity (nreverse name) "."))))
+
+(defun dns-write (spec &optional tcp-p)
+ "Write a DNS packet according to SPEC.
+If TCP-P, the first two bytes of the package with be the length field."
+ (with-temp-buffer
+ (dns-write-bytes (dns-get 'id spec) 2)
+ (dns-write-bytes
+ (logior
+ (lsh (if (dns-get 'response-p spec) 1 0) -7)
+ (lsh
+ (cond
+ ((eq (dns-get 'opcode spec) 'query) 0)
+ ((eq (dns-get 'opcode spec) 'inverse-query) 1)
+ ((eq (dns-get 'opcode spec) 'status) 2)
+ (t (error "No such opcode: %s" (dns-get 'opcode spec))))
+ -3)
+ (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
+ (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
+ (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
+ (dns-write-bytes
+ (cond
+ ((eq (dns-get 'response-code spec) 'no-error) 0)
+ ((eq (dns-get 'response-code spec) 'format-error) 1)
+ ((eq (dns-get 'response-code spec) 'server-failure) 2)
+ ((eq (dns-get 'response-code spec) 'name-error) 3)
+ ((eq (dns-get 'response-code spec) 'not-implemented) 4)
+ ((eq (dns-get 'response-code spec) 'refused) 5)
+ (t 0)))
+ (dns-write-bytes (length (dns-get 'queries spec)) 2)
+ (dns-write-bytes (length (dns-get 'answers spec)) 2)
+ (dns-write-bytes (length (dns-get 'authorities spec)) 2)
+ (dns-write-bytes (length (dns-get 'additionals spec)) 2)
+ (dolist (query (dns-get 'queries spec))
+ (dns-write-name (car query))
+ (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
+ dns-query-types)) 2)
+ (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
+ dns-classes)) 2))
+ (dolist (slot '(answers authorities additionals))
+ (dolist (resource (dns-get slot spec))
+ (dns-write-name (car resource))
+ (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
+ 2)
+ (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
+ 2)
+ (dns-write-bytes (dns-get 'ttl resource) 4)
+ (dns-write-bytes (length (dns-get 'data resource)) 2)
+ (insert (dns-get 'data resource))))
+ (when tcp-p
+ (goto-char (point-min))
+ (dns-write-bytes (buffer-size) 2))
+ (buffer-string)))
+
+(defun dns-read (packet)
+ (mm-with-unibyte-buffer
+ (let ((spec nil)
+ queries answers authorities additionals)
+ (insert packet)
+ (goto-char (point-min))
+ (push (list 'id (dns-read-bytes 2)) spec)
+ (let ((byte (dns-read-bytes 1)))
+ (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
+ spec)
+ (let ((opcode (logand byte (lsh 7 3))))
+ (push (list 'opcode
+ (cond ((eq opcode 0) 'query)
+ ((eq opcode 1) 'inverse-query)
+ ((eq opcode 2) 'status)))
+ spec))
+ (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
+ nil t)) spec)
+ (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
+ spec)
+ (push (list 'recursion-desired-p
+ (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
+ (let ((rc (logand (dns-read-bytes 1) 15)))
+ (push (list 'response-code
+ (cond
+ ((eq rc 0) 'no-error)
+ ((eq rc 1) 'format-error)
+ ((eq rc 2) 'server-failure)
+ ((eq rc 3) 'name-error)
+ ((eq rc 4) 'not-implemented)
+ ((eq rc 5) 'refused)))
+ spec))
+ (setq queries (dns-read-bytes 2))
+ (setq answers (dns-read-bytes 2))
+ (setq authorities (dns-read-bytes 2))
+ (setq additionals (dns-read-bytes 2))
+ (let ((qs nil))
+ (dotimes (i queries)
+ (push (list (dns-read-name)
+ (list 'type (dns-inverse-get (dns-read-bytes 2)
+ dns-query-types))
+ (list 'class (dns-inverse-get (dns-read-bytes 2)
+ dns-classes)))
+ qs))
+ (push (list 'queries qs) spec))
+ (dolist (slot '(answers authorities additionals))
+ (let ((qs nil)
+ type)
+ (dotimes (i (symbol-value slot))
+ (push (list (dns-read-name)
+ (list 'type
+ (setq type (dns-inverse-get (dns-read-bytes 2)
+ dns-query-types)))
+ (list 'class (dns-inverse-get (dns-read-bytes 2)
+ dns-classes))
+ (list 'ttl (dns-read-bytes 4))
+ (let ((length (dns-read-bytes 2)))
+ (list 'data
+ (dns-read-type
+ (buffer-substring
+ (point)
+ (progn (forward-char length) (point)))
+ type))))
+ qs))
+ (push (list slot qs) spec)))
+ (nreverse spec))))
+
+(defun dns-read-type (string type)
+ (let ((buffer (current-buffer))
+ (point (point)))
+ (prog1
+ (mm-with-unibyte-buffer
+ (insert string)
+ (goto-char (point-min))
+ (cond
+ ((eq type 'A)
+ (let ((bytes nil))
+ (dotimes (i 4)
+ (push (dns-read-bytes 1) bytes))
+ (mapconcat 'number-to-string (nreverse bytes) ".")))
+ ((eq type 'NS)
+ (dns-read-string-name string buffer))
+ ((eq type 'CNAME)
+ (dns-read-string-name string buffer))
+ (t string)))
+ (goto-char point))))
+
+(defun dns-parse-resolv-conf ()
+ (when (file-exists-p "/etc/resolv.conf")
+ (with-temp-buffer
+ (insert-file-contents "/etc/resolv.conf")
+ (goto-char (point-min))
+ (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
+ (push (match-string 1) dns-servers))
+ (setq dns-servers (nreverse dns-servers)))))
+
+;;; Interface functions.
+
+(autoload 'gnus-xmacs-open-network-stream "gnus-xmas" nil nil 'macro)
+
+(defmacro dns-make-network-process (server)
+ (if (featurep 'xemacs)
+ `(let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (gnus-xmas-open-network-stream "dns" (current-buffer)
+ ,server "domain" 'udp))
+ `(let ((server ,server)
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (default-process-coding-system '(binary . binary))
+ program-coding-system-alist)
+ (if (fboundp 'make-network-process)
+ (make-network-process
+ :name "dns"
+ :coding 'binary
+ :buffer (current-buffer)
+ :host server
+ :service "domain"
+ :type 'datagram)
+ ;; Older versions of Emacs doesn't have
+ ;; `make-network-process', so we fall back on opening a TCP
+ ;; connection to the DNS server.
+ (open-network-stream "dns" (current-buffer) server "domain")))))
+
+(defun query-dns (name &optional type fullp)
+ "Query a DNS server for NAME of TYPE.
+If FULLP, return the entire record returned."
+ (setq type (or type 'A))
+ (unless dns-servers
+ (dns-parse-resolv-conf)
+ (unless dns-servers
+ (error "No DNS server configuration found")))
+ (mm-with-unibyte-buffer
+ (let ((process (condition-case ()
+ (dns-make-network-process (car dns-servers))
+ (error
+ (message "dns: Got an error while trying to talk to %s"
+ (car dns-servers))
+ nil)))
+ (tcp-p (and (not (fboundp 'make-network-process))
+ (not (featurep 'xemacs))))
+ (step 100)
+ (times (* dns-timeout 1000))
+ (id (random 65000)))
+ (when process
+ (process-send-string
+ process
+ (dns-write `((id ,id)
+ (opcode query)
+ (queries ((,name (type ,type))))
+ (recursion-desired-p t))
+ tcp-p))
+ (while (and (zerop (buffer-size))
+ (> times 0))
+ (accept-process-output process 0 step)
+ (decf times step))
+ (ignore-errors
+ (delete-process process))
+ (when tcp-p
+ (goto-char (point-min))
+ (delete-region (point) (+ (point) 2)))
+ (unless (zerop (buffer-size))
+ (let ((result (dns-read (buffer-string))))
+ (if fullp
+ result
+ (let ((answer (car (dns-get 'answers result))))
+ (when (eq type (dns-get 'type answer))
+ (dns-get 'data answer))))))))))
+
+(provide 'dns)
+
+;;; dns.el ends here
--- /dev/null
+;;; gnus-delay.el --- Delayed posting of articles
+
+;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Kai Großjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>
+;; Keywords: mail, news, extensions
+
+;; 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 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:
+
+;; Provide delayed posting of articles.
+
+;;; Todo:
+
+;; * `gnus-delay-send-queue' barfs when group does not exist.
+;; * Integrate gnus-delay.el into the rest of Gnus automatically. How
+;; should this be done? Basically, we need to do what
+;; `gnus-delay-initialize' does. But in which files?
+
+;;; Code:
+
+(require 'nndraft)
+(require 'gnus-draft)
+
+;;;###autoload
+(defgroup gnus-delay nil
+ "Arrange for sending postings later."
+ :group 'gnus)
+
+(defcustom gnus-delay-group "delayed"
+ "Group name for storing delayed articles."
+ :type 'string
+ :group 'gnus-delay)
+
+(defcustom gnus-delay-header "X-Gnus-Delayed"
+ "Header name for storing info about delayed articles."
+ :type 'string
+ :group 'gnus-delay)
+
+(defcustom gnus-delay-default-delay "3d"
+ "*Default length of delay."
+ :type 'string
+ :group 'gnus-delay)
+
+(defcustom gnus-delay-default-hour 8
+ "*If deadline is given as date, then assume this time of day."
+ :type 'integer
+ :group 'gnus-delay)
+
+;;;###autoload
+(defun gnus-delay-article (delay)
+ "Delay this article by some time.
+DELAY is a string, giving the length of the time. Possible values are:
+
+* <digits><units> for <units> in minutes (`m'), hours (`h'), days (`d'),
+ weeks (`w'), months (`M'), or years (`Y');
+
+* YYYY-MM-DD for a specific date. The time of day is given by the
+ variable `gnus-delay-default-hour', minute and second are zero.
+
+* hh:mm for a specific time. Use 24h format. If it is later than this
+ time, then the deadline is tomorrow, else today."
+ (interactive
+ (list (read-string
+ "Target date (YYYY-MM-DD) or length of delay (units in [mhdwMY]): "
+ gnus-delay-default-delay)))
+ (let (num unit days year month day hour minute deadline)
+ (cond ((string-match
+ "\\([0-9][0-9][0-9]?[0-9]?\\)-\\([0-9]+\\)-\\([0-9]+\\)"
+ delay)
+ (setq year (string-to-number (match-string 1 delay))
+ month (string-to-number (match-string 2 delay))
+ day (string-to-number (match-string 3 delay)))
+ (setq deadline
+ (message-make-date
+ (encode-time 0 0 ; second and minute
+ gnus-delay-default-hour
+ day month year))))
+ ((string-match "\\([0-9]+\\):\\([0-9]+\\)" delay)
+ (setq hour (string-to-number (match-string 1 delay))
+ minute (string-to-number (match-string 2 delay)))
+ ;; Use current time, except...
+ (setq deadline (apply 'vector (decode-time (current-time))))
+ ;; ... for minute and hour.
+ (aset deadline 1 minute)
+ (aset deadline 2 hour)
+ ;; Convert to seconds.
+ (setq deadline (time-to-seconds (apply 'encode-time
+ (append deadline nil))))
+ ;; If this time has passed already, add a day.
+ (when (< deadline (time-to-seconds (current-time)))
+ (setq deadline (+ 3600 deadline))) ;3600 secs/day
+ ;; Convert seconds to date header.
+ (setq deadline (message-make-date
+ (seconds-to-time deadline))))
+ ((string-match "\\([0-9]+\\)\\s-*\\([mhdwMY]\\)" delay)
+ (setq num (match-string 1 delay))
+ (setq unit (match-string 2 delay))
+ ;; Start from seconds, then multiply into needed units.
+ (setq num (string-to-number num))
+ (cond ((string= unit "Y")
+ (setq delay (* num 60 60 24 365)))
+ ((string= unit "M")
+ (setq delay (* num 60 60 24 30)))
+ ((string= unit "w")
+ (setq delay (* num 60 60 24 7)))
+ ((string= unit "d")
+ (setq delay (* num 60 60 24)))
+ ((string= unit "h")
+ (setq delay (* num 60 60)))
+ (t
+ (setq delay (* num 60))))
+ (setq deadline (message-make-date
+ (seconds-to-time (+ (time-to-seconds (current-time))
+ delay)))))
+ (t (error "Malformed delay `%s'" delay)))
+ (message-add-header (format "%s: %s" gnus-delay-header deadline)))
+ (set-buffer-modified-p t)
+ ;; If group does not exist, create it.
+ (let ((group (format "nndraft:%s" gnus-delay-group)))
+ (gnus-agent-queue-setup gnus-delay-group))
+ (message-disassociate-draft)
+ (nndraft-request-associate-buffer gnus-delay-group)
+ (save-buffer 0)
+ (kill-buffer (current-buffer))
+ (message-do-actions message-postpone-actions))
+
+;;;###autoload
+(defun gnus-delay-send-queue ()
+ "Send all the delayed messages that are due now."
+ (interactive)
+ (save-excursion
+ (let* ((group (format "nndraft:%s" gnus-delay-group))
+ (message-send-hook (copy-sequence message-send-hook))
+ articles
+ article deadline)
+ (when (gnus-gethash group gnus-newsrc-hashtb)
+ (gnus-activate-group group)
+ (add-hook 'message-send-hook
+ '(lambda ()
+ (message-remove-header gnus-delay-header)))
+ (setq articles (nndraft-articles))
+ (while (setq article (pop articles))
+ (gnus-request-head article group)
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote gnus-delay-header) ":\\s-+")
+ nil t)
+ (progn
+ (setq deadline (nnheader-header-value))
+ (setq deadline (apply 'encode-time
+ (parse-time-string deadline)))
+ (setq deadline (time-since deadline))
+ (when (and (>= (nth 0 deadline) 0)
+ (>= (nth 1 deadline) 0))
+ (message "Sending delayed article %d" article)
+ (gnus-draft-send article group)
+ (message "Sending delayed article %d...done" article)))
+ (message "Delay header missing for article %d" article)))))))
+
+;;;###autoload
+(defun gnus-delay-initialize (&optional no-keymap no-check)
+ "Initialize the gnus-delay package.
+This sets up a key binding in `message-mode' to delay a message.
+This tells Gnus to look for delayed messages after getting new news.
+
+The optional arg NO-KEYMAP is ignored.
+Checking delayed messages is skipped if optional arg NO-CHECK is non-nil."
+ (unless no-check
+ (add-hook 'gnus-get-new-news-hook 'gnus-delay-send-queue)))
+
+(provide 'gnus-delay)
+
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
+;;; gnus-delay.el ends here
--- /dev/null
+;;; gnus-diary.el --- Wrapper around the NNDiary Gnus backend
+
+;; Copyright (c) 2001, 2002, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001 Didier Verna.
+
+;; Author: Didier Verna <didier@xemacs.org>
+;; Maintainer: Didier Verna <didier@xemacs.org>
+;; Created: Tue Jul 20 10:42:55 1999
+;; Keywords: calendar mail news
+
+;; 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 2 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 this program; if not, write to the Free Software
+;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;; Commentary:
+
+;; Contents management by FCM version 0.1.
+
+;; Description:
+;; ===========
+
+;; Gnus-Diary is a wrapper around the NNDiary Gnus backend. It is here to
+;; make your nndiary-user life easier in different ways. So, you don't have
+;; to use it if you don't want to. But, really, you should.
+
+;; Gnus-Diary offers the following features on top of the NNDiary backend:
+
+;; - A nice summary line format:
+;; Displaying diary messages in standard summary line format (usually
+;; something like "<From Joe>: <Subject>") is pretty useless. Most of the
+;; time, you're the one who wrote the message, and you mostly want to see
+;; the event's date. Gnus-Diary offers you a nice summary line format
+;; which will do this. By default, a summary line will appear like this:
+;;
+;; <Event Date>: <Subject> <Remaining time>
+;;
+;; for example, here's how Joe's birthday is displayed in my
+;; "nndiary:birhdays" summary buffer (the message is expirable, but will
+;; never be deleted, as it specifies a regular event):
+;;
+;; E Sat, Sep 22 01, 12:00: Joe's birthday (in 6 months, 1 week)
+
+;; - More article sorting functions:
+;; Gnus-Diary adds a new sorting function called
+;; `gnus-summary-sort-by-schedule'. This function lets you organize your
+;; diary summary buffers from the closest event to the farthest one.
+
+;; - Automatic generation of diary group parameters:
+;; When you create a new diary group, or visit one, Gnus-Diary checks your
+;; group parameters, and if needed, sets the summary line format to the
+;; diary-specific value, adds the diary-specific sorting functions, and
+;; also adds the different `X-Diary-*' headers to the group's
+;; posting-style. It is then easier to send a diary message, because if
+;; you use `C-u a' or `C-u m' on a diary group to prepare a message, these
+;; headers will be inserted automatically (but not filled with proper
+;; values yet).
+
+;; - An interactive mail-to-diary convertion function:
+;; The function `gnus-diary-check-message' ensures that the current message
+;; contains all the required diary headers, and prompts you for values /
+;; correction if needed. This function is hooked in the nndiary backend so
+;; that moving an article to an nndiary group will trigger it
+;; automatically. It is also bound to `C-c D c' in message-mode and
+;; article-edit-mode in order to ease the process of converting a usual
+;; mail to a diary one. This function takes a prefix argument which will
+;; force prompting of all diary headers, regardless of their
+;; presence/validity. That way, you can very easily reschedule a diary
+;; message for instance.
+
+
+;; Usage:
+;; =====
+
+;; 0/ Don't use any `gnus-user-format-function-[d|D]'. Gnus-Diary provides
+;; both of these (sorry if you used them before).
+;; 1/ Add '(require 'gnus-diary) to your gnusrc file.
+;; 2/ Customize your gnus-diary options to suit your needs.
+
+
+
+;; Bugs / Todo:
+;; ===========
+
+
+;;; Code:
+
+(require 'nndiary)
+(require 'message)
+(require 'gnus-art)
+
+(defgroup gnus-diary nil
+ "Utilities on top of the nndiary backend for Gnus.")
+
+(defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n"
+ "*Summary line format for nndiary groups."
+ :type 'string
+ :group 'gnus-diary
+ :group 'gnus-summary-format)
+
+(defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M"
+ "*Time format to display appointements in nndiary summary buffers.
+Please refer to `format-time-string' for information on possible values."
+ :type 'string
+ :group 'gnus-diary)
+
+(defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english
+ "*Function called to format a diary delay string.
+It is passed two arguments. The first one is non nil if the delay is in
+the past. The second one is of the form ((NUM . UNIT) ...) where NUM is
+an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute.
+It should return strings like \"In 2 months, 3 weeks\", \"3 hours,
+1 minute ago\" and so on.
+
+There are currently two built-in format functions:
+`gnus-diary-delay-format-english' (the default)
+`gnus-diary-delay-format-french'"
+ :type '(choice (const :tag "english" gnus-diary-delay-format-english)
+ (const :tag "french" gnus-diary-delay-format-french)
+ (symbol :tag "other"))
+ :group 'gnus-diary)
+
+(defconst gnus-diary-version nndiary-version
+ "Current Diary backend version.")
+
+
+;; Compatibility functions ==================================================
+
+(eval-and-compile
+ (if (fboundp 'kill-entire-line)
+ (defalias 'gnus-diary-kill-entire-line 'kill-entire-line)
+ (defun gnus-diary-kill-entire-line ()
+ (beginning-of-line)
+ (let ((kill-whole-line t))
+ (kill-line)))))
+
+
+;; Summary line format ======================================================
+
+(defun gnus-diary-delay-format-french (past delay)
+ (if (null delay)
+ "maintenant!"
+ ;; Keep only a precision of two degrees
+ (and (> (length delay) 1) (setcdr (cdr delay) nil))
+ (concat (if past "il y a " "dans ")
+ (let ((str "")
+ del)
+ (while (setq del (pop delay))
+ (setq str (concat str
+ (int-to-string (car del)) " "
+ (cond ((eq (cdr del) 'year)
+ "an")
+ ((eq (cdr del) 'month)
+ "mois")
+ ((eq (cdr del) 'week)
+ "semaine")
+ ((eq (cdr del) 'day)
+ "jour")
+ ((eq (cdr del) 'hour)
+ "heure")
+ ((eq (cdr del) 'minute)
+ "minute"))
+ (unless (or (eq (cdr del) 'month)
+ (= (car del) 1))
+ "s")
+ (if delay ", "))))
+ str))))
+
+
+(defun gnus-diary-delay-format-english (past delay)
+ (if (null delay)
+ "now!"
+ ;; Keep only a precision of two degrees
+ (and (> (length delay) 1) (setcdr (cdr delay) nil))
+ (concat (unless past "in ")
+ (let ((str "")
+ del)
+ (while (setq del (pop delay))
+ (setq str (concat str
+ (int-to-string (car del)) " "
+ (symbol-name (cdr del))
+ (and (> (car del) 1) "s")
+ (if delay ", "))))
+ str)
+ (and past " ago"))))
+
+
+(defun gnus-diary-header-schedule (headers)
+ ;; Same as `nndiary-schedule', but given a set of headers HEADERS
+ (mapcar
+ (lambda (elt)
+ (let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt)))
+ headers))))
+ (when head
+ (nndiary-parse-schedule-value head (cadr elt) (caddr elt)))))
+ nndiary-headers))
+
+;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any
+;; message, with all fields set to nil here. I don't know what it is for, and
+;; I just ignore it.
+(defun gnus-user-format-function-d (header)
+ ;; Returns an aproximative delay string for the next occurence of this
+ ;; message. The delay is given only in the first non zero unit.
+ ;; Code partly stolen from article-make-date-line
+ (let* ((extras (mail-header-extra header))
+ (sched (gnus-diary-header-schedule extras))
+ (occur (nndiary-next-occurence sched (current-time)))
+ (now (current-time))
+ (real-time (subtract-time occur now)))
+ (if (null real-time)
+ "?????"
+ (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time)))
+ (past (< sec 0))
+ delay)
+ (and past (setq sec (- sec)))
+ (unless (zerop sec)
+ ;; This is a bit convoluted, but basically we go through the time
+ ;; units for years, weeks, etc, and divide things to see whether
+ ;; that results in positive answers.
+ (let ((units `((year . ,(* 365.25 24 3600))
+ (month . ,(* 31 24 3600))
+ (week . ,(* 7 24 3600))
+ (day . ,(* 24 3600))
+ (hour . 3600)
+ (minute . 60)))
+ unit num)
+ (while (setq unit (pop units))
+ (unless (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ (setq delay (append delay `((,(floor num) . ,(car unit))))))
+ (setq sec (- sec (* num (cdr unit)))))))
+ (funcall gnus-diary-delay-format-function past delay)))
+ ))
+
+;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any
+;; message, with all fields set to nil here. I don't know what it is for, and
+;; I just ignore it.
+(defun gnus-user-format-function-D (header)
+ ;; Returns a formatted time string for the next occurence of this message.
+ (let* ((extras (mail-header-extra header))
+ (sched (gnus-diary-header-schedule extras))
+ (occur (nndiary-next-occurence sched (current-time))))
+ (format-time-string gnus-diary-time-format occur)))
+
+
+;; Article sorting functions ================================================
+
+(defun gnus-article-sort-by-schedule (h1 h2)
+ (let* ((now (current-time))
+ (e1 (mail-header-extra h1))
+ (e2 (mail-header-extra h2))
+ (s1 (gnus-diary-header-schedule e1))
+ (s2 (gnus-diary-header-schedule e2))
+ (o1 (nndiary-next-occurence s1 now))
+ (o2 (nndiary-next-occurence s2 now)))
+ (if (and (= (car o1) (car o2)) (= (cadr o1) (cadr o2)))
+ (< (mail-header-number h1) (mail-header-number h2))
+ (time-less-p o1 o2))))
+
+
+(defun gnus-thread-sort-by-schedule (h1 h2)
+ (gnus-article-sort-by-schedule (gnus-thread-header h1)
+ (gnus-thread-header h2)))
+
+(defun gnus-summary-sort-by-schedule (&optional reverse)
+ "Sort nndiary summary buffers by schedule of appointements.
+Optional prefix (or REVERSE argument) means sort in reverse order."
+ (interactive "P")
+ (gnus-summary-sort 'schedule reverse))
+
+(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
+;; The function `easy-menu-add-item' is not available under Emacs
+;; versions prior to 20.3. Could anyone try to emulate it?
+(if (eval-when-compile
+ (require 'easymenu)
+ (or (fboundp 'easy-menu-add-item)
+ (progn
+ (defalias 'easy-menu-add-item 'ignore)
+ nil)))
+(add-hook 'gnus-summary-menu-hook
+ (lambda ()
+ (easy-menu-add-item gnus-summary-misc-menu
+ '("Sort")
+ ["Sort by schedule"
+ gnus-summary-sort-by-schedule
+ (eq (car (gnus-find-method-for-group
+ gnus-newsgroup-name))
+ 'nndiary)]
+ "Sort by number")))
+ )
+
+
+
+;; Group parameters autosetting =============================================
+
+(defun gnus-diary-update-group-parameters (group)
+ ;; Ensure that nndiary groups have convenient group parameters:
+ ;; - a posting style containing X-Diary headers
+ ;; - a nice summary line format
+ ;; - NNDiary specific sorting by schedule functions
+ ;; In general, try not to mess with what the user might have modified.
+ (let ((posting-style (gnus-group-get-parameter group 'posting-style t)))
+ ;; Posting style:
+ (mapcar (lambda (elt)
+ (let ((header (format "X-Diary-%s" (car elt))))
+ (unless (assoc header posting-style)
+ (setq posting-style (append posting-style
+ `((,header "*")))))
+ ))
+ nndiary-headers)
+ (gnus-group-set-parameter group 'posting-style posting-style)
+ ;; Summary line format:
+ (unless (gnus-group-get-parameter group 'gnus-summary-line-format t)
+ (gnus-group-set-parameter group 'gnus-summary-line-format
+ `(,gnus-diary-summary-line-format)))
+ ;; Sorting by schedule:
+ (unless (gnus-group-get-parameter group 'gnus-article-sort-functions)
+ (gnus-group-set-parameter group 'gnus-article-sort-functions
+ '((append gnus-article-sort-functions
+ (list
+ 'gnus-article-sort-by-schedule)))))
+ (unless (gnus-group-get-parameter group 'gnus-thread-sort-functions)
+ (gnus-group-set-parameter group 'gnus-thread-sort-functions
+ '((append gnus-thread-sort-functions
+ (list
+ 'gnus-thread-sort-by-schedule)))))
+ ))
+
+;; Called when a group is subscribed. This is needed because groups created
+;; because of mail splitting are *not* created with the backend function.
+;; Thus, `nndiary-request-create-group-hooks' is inoperative.
+(defun gnus-diary-maybe-update-group-parameters (group)
+ (when (eq (car (gnus-find-method-for-group group)) 'nndiary)
+ (gnus-diary-update-group-parameters group)))
+
+(add-hook 'nndiary-request-create-group-hooks
+ 'gnus-diary-update-group-parameters)
+;; Now that we have `gnus-subscribe-newsgroup-hooks', this is not needed
+;; anymore. Maybe I should remove this completely.
+(add-hook 'nndiary-request-update-info-hooks
+ 'gnus-diary-update-group-parameters)
+(add-hook 'gnus-subscribe-newsgroup-hooks
+ 'gnus-diary-maybe-update-group-parameters)
+
+
+;; Diary Message Checking ===================================================
+
+(defvar gnus-diary-header-value-history nil
+ ;; History variable for header value prompting
+ )
+
+(defun gnus-diary-narrow-to-headers ()
+ "Narrow the current buffer to the header part.
+Point is left at the beginning of the region.
+The buffer is assumed to contain a message, but the format is unknown."
+ (cond ((eq major-mode 'message-mode)
+ (message-narrow-to-headers))
+ (t
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil t)
+ (narrow-to-region (point-min) (- (point) 1))
+ (goto-char (point-min))))
+ ))
+
+(defun gnus-diary-add-header (str)
+ "Add a header to the current buffer.
+The buffer is assumed to contain a message, but the format is unknown."
+ (cond ((eq major-mode 'message-mode)
+ (message-add-header str))
+ (t
+ (save-restriction
+ (gnus-diary-narrow-to-headers)
+ (goto-char (point-max))
+ (if (string-match "\n$" str)
+ (insert str)
+ (insert str ?\n))))
+ ))
+
+(defun gnus-diary-check-message (arg)
+ "Ensure that the current message is a valid for NNDiary.
+This function checks that all NNDiary required headers are present and
+valid, and prompts for values / correction otherwise.
+
+If ARG (or prefix) is non-nil, force prompting for all fields."
+ (interactive "P")
+ (save-excursion
+ (mapcar
+ (lambda (head)
+ (let ((header (concat "X-Diary-" (car head)))
+ (ask arg)
+ value invalid)
+ ;; First, try to find the header, and checks for validity:
+ (save-restriction
+ (gnus-diary-narrow-to-headers)
+ (when (re-search-forward (concat "^" header ":") nil t)
+ (unless (eq (char-after) ? )
+ (insert " "))
+ (setq value (buffer-substring (point) (gnus-point-at-eol)))
+ (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value)
+ (setq value (match-string 1 value)))
+ (condition-case ()
+ (nndiary-parse-schedule-value value
+ (nth 1 head) (nth 2 head))
+ (t
+ (setq invalid t)))
+ ;; #### NOTE: this (along with the `gnus-diary-add-header'
+ ;; function) could be rewritten in a better way, in particular
+ ;; not to blindly remove an already present header and reinsert
+ ;; it somewhere else afterwards.
+ (when (or ask invalid)
+ (gnus-diary-kill-entire-line))
+ ))
+ ;; Now, loop until a valid value is provided:
+ (while (or ask (not value) invalid)
+ (let ((prompt (concat (and invalid
+ (prog1 "(current value invalid) "
+ (beep)))
+ header ": ")))
+ (setq value
+ (if (listp (nth 1 head))
+ (completing-read prompt (cons '("*" nil) (nth 1 head))
+ nil t value
+ gnus-diary-header-value-history)
+ (read-string prompt value
+ gnus-diary-header-value-history))))
+ (setq ask nil)
+ (setq invalid nil)
+ (condition-case ()
+ (nndiary-parse-schedule-value value
+ (nth 1 head) (nth 2 head))
+ (t
+ (setq invalid t))))
+ (gnus-diary-add-header (concat header ": " value))
+ ))
+ nndiary-headers)
+ ))
+
+(add-hook 'nndiary-request-accept-article-hooks
+ (lambda () (gnus-diary-check-message nil)))
+
+(define-key message-mode-map "\C-cDc" 'gnus-diary-check-message)
+(define-key gnus-article-edit-mode-map "\C-cDc" 'gnus-diary-check-message)
+
+
+;; The end ==================================================================
+
+(defun gnus-diary-version ()
+ "Current Diary backend version."
+ (interactive)
+ (message "NNDiary version %s" nndiary-version))
+
+(define-key message-mode-map "\C-cDv" 'gnus-diary-version)
+(define-key gnus-article-edit-mode-map "\C-cDv" 'gnus-diary-version)
+
+
+(provide 'gnus-diary)
+
+;;; gnus-diary.el ends here
--- /dev/null
+;;; gnus-dired.el --- utility functions where gnus and dired meet
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003
+;; Free Software Foundation, Inc.
+
+;; Authors: Benjamin Rutt <brutt@bloomington.in.us>,
+;; Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Keywords: mail, news, extensions
+
+;; 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 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 package provides utility functions for intersections of gnus
+;; and dired. To enable the gnus-dired-mode minor mode which will
+;; have the effect of installing keybindings in dired-mode, place the
+;; following in your ~/.gnus:
+
+;; (require 'gnus-dired) ;, isn't needed due to autoload cookies
+;; (add-hook 'dired-mode-hook 'turn-on-gnus-dired-mode)
+
+;; Note that if you visit dired buffers before your ~/.gnus file has
+;; been read, those dired buffers won't have the keybindings in
+;; effect. To get around that problem, you may want to add the above
+;; statements to your ~/.emacs instead.
+
+;;; Code:
+
+(require 'dired)
+(require 'gnus-ems)
+(require 'gnus-msg)
+(require 'gnus-util)
+(require 'message)
+(require 'mm-encode)
+(require 'mml)
+
+(defvar gnus-dired-mode nil
+ "Minor mode for intersections of gnus and dired.")
+
+(defvar gnus-dired-mode-map nil)
+
+(unless gnus-dired-mode-map
+ (setq gnus-dired-mode-map (make-sparse-keymap))
+
+ (gnus-define-keys gnus-dired-mode-map
+ "\C-c\C-a" gnus-dired-attach
+ "\C-c\C-l" gnus-dired-find-file-mailcap
+ "\C-cP" gnus-dired-print))
+
+(defun gnus-dired-mode (&optional arg)
+ "Minor mode for intersections of gnus and dired.
+
+\\{gnus-dired-mode-map}"
+ (interactive "P")
+ (when (eq major-mode 'dired-mode)
+ (set (make-local-variable 'gnus-dired-mode)
+ (if (null arg) (not gnus-dired-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (when gnus-dired-mode
+ (gnus-add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map)
+ (gnus-run-hooks 'gnus-dired-mode-hook))))
+
+;;;###autoload
+(defun turn-on-gnus-dired-mode ()
+ "Convenience method to turn on gnus-dired-mode."
+ (gnus-dired-mode 1))
+
+;; Method to attach files to a gnus composition.
+(defun gnus-dired-attach (files-to-attach)
+ "Attach dired's marked files to a gnus message composition.
+If called non-interactively, FILES-TO-ATTACH should be a list of
+filenames."
+ (interactive
+ (list
+ (delq nil
+ (mapcar
+ ;; don't attach directories
+ (lambda (f) (if (file-directory-p f) nil f))
+ (nreverse (dired-map-over-marks (dired-get-filename) nil))))))
+ (let ((destination nil)
+ (files-str nil)
+ (bufs nil))
+ ;; warn if user tries to attach without any files marked
+ (if (null files-to-attach)
+ (error "No files to attach")
+ (setq files-str
+ (mapconcat
+ (lambda (f) (file-name-nondirectory f))
+ files-to-attach ", "))
+ (setq bufs (message-buffers))
+
+ ;; set up destination message buffer
+ (if (and bufs
+ (y-or-n-p "Attach files to existing message buffer? "))
+ (setq destination
+ (if (= (length bufs) 1)
+ (get-buffer (car bufs))
+ (completing-read "Attach to which message buffer: "
+ (mapcar
+ (lambda (b)
+ (cons b (get-buffer b)))
+ bufs)
+ nil t)))
+ ;; setup a new gnus message buffer
+ (gnus-setup-message 'message (message-mail))
+ (setq destination (current-buffer)))
+
+ ;; set buffer to destination buffer, and attach files
+ (set-buffer destination)
+ (goto-char (point-max)) ;attach at end of buffer
+ (while files-to-attach
+ (mml-attach-file (car files-to-attach)
+ (or (mm-default-file-encoding (car files-to-attach))
+ "application/octet-stream") nil)
+ (setq files-to-attach (cdr files-to-attach)))
+ (message "Attached file(s) %s" files-str))))
+
+(autoload 'mailcap-parse-mailcaps "mailcap" "" t)
+
+(defun gnus-dired-find-file-mailcap (&optional file-name arg)
+ "In dired, visit FILE-NAME according to the mailcap file.
+If ARG is non-nil, open it in a new buffer."
+ (interactive (list
+ (file-name-sans-versions (dired-get-filename) t)
+ current-prefix-arg))
+ (mailcap-parse-mailcaps)
+ (if (file-exists-p file-name)
+ (let (mime-type method)
+ (if (and (not arg)
+ (not (file-directory-p file-name))
+ (string-match "\\.[^\\.]+$" file-name)
+ (setq mime-type
+ (mailcap-extension-to-mime
+ (match-string 0 file-name)))
+ (stringp
+ (setq method
+ (cdr (assoc 'viewer
+ (car (mailcap-mime-info mime-type
+ 'all)))))))
+ (let ((view-command (mm-mailcap-command method file-name nil)))
+ (message "viewing via %s" view-command)
+ (start-process "*display*"
+ nil
+ shell-file-name
+ shell-command-switch
+ view-command))
+ (find-file file-name)))
+ (if (file-symlink-p file-name)
+ (error "File is a symlink to a nonexistent target")
+ (error "File no longer exists; type `g' to update Dired buffer"))))
+
+(defun gnus-dired-print (&optional file-name print-to)
+ "In dired, print FILE-NAME according to the mailcap file.
+
+If there is no print command, print in a PostScript image. If the
+optional argument PRINT-TO is nil, send the image to the printer. If
+PRINT-TO is a string, save the PostScript image in a file with that
+name. If PRINT-TO is a number, prompt the user for the name of the
+file to save in."
+ (interactive (list
+ (file-name-sans-versions (dired-get-filename) t)
+ (ps-print-preprint current-prefix-arg)))
+ (mailcap-parse-mailcaps)
+ (cond
+ ((file-directory-p file-name)
+ (error "Can't print a directory"))
+ ((file-exists-p file-name)
+ (let (mime-type method)
+ (if (and (string-match "\\.[^\\.]+$" file-name)
+ (setq mime-type
+ (mailcap-extension-to-mime
+ (match-string 0 file-name)))
+ (stringp
+ (setq method (mailcap-mime-info mime-type "print"))))
+ (call-process shell-file-name nil
+ (generate-new-buffer " *mm*")
+ nil
+ shell-command-switch
+ (mm-mailcap-command method file-name mime-type))
+ (with-temp-buffer
+ (insert-file-contents file-name)
+ (gnus-print-buffer))
+ (ps-despool print-to))))
+ ((file-symlink-p file-name)
+ (error "File is a symlink to a nonexistent target"))
+ (t
+ (error "File no longer exists; type `g' to update Dired buffer"))))
+
+(provide 'gnus-dired)
+
+;;; gnus-dired.el ends here
--- /dev/null
+;;; gnus-fun.el --- various frivolous extension functions to Gnus
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: news
+
+;; 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 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:
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl)
+ (require 'mm-util))
+
+(defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory)
+ "*Directory where X-Face PBM files are stored."
+ :group 'gnus-fun
+ :type 'directory)
+
+(defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface"
+ "Command for converting a PBM to an X-Face."
+ :group 'gnus-fun
+ :type 'string)
+
+(defcustom gnus-convert-image-to-x-face-command "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface"
+ "Command for converting an image to an X-Face.
+By default it takes a GIF filename and output the X-Face header data
+on stdout."
+ :group 'gnus-fun
+ :type 'string)
+
+(defcustom gnus-convert-image-to-face-command "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng"
+ "Command for converting an image to an Face.
+By default it takes a JPEG filename and output the Face header data
+on stdout."
+ :group 'gnus-fun
+ :type 'string)
+
+(defun gnus-shell-command-to-string (command)
+ "Like `shell-command-to-string' except not mingling ERROR."
+ (with-output-to-string
+ (call-process shell-file-name nil (list standard-output nil)
+ nil shell-command-switch command)))
+
+(defun gnus-shell-command-on-region (start end command)
+ "A simplified `shell-command-on-region'.
+Output to the current buffer, replace text, and don't mingle error."
+ (call-process-region start end shell-file-name t
+ (list (current-buffer) nil)
+ nil shell-command-switch command))
+
+;;;###autoload
+(defun gnus-random-x-face ()
+ "Return X-Face header data chosen randomly from `gnus-x-face-directory'."
+ (interactive)
+ (when (file-exists-p gnus-x-face-directory)
+ (let* ((files (directory-files gnus-x-face-directory t "\\.pbm$"))
+ (file (nth (random (length files)) files)))
+ (when file
+ (gnus-shell-command-to-string
+ (format gnus-convert-pbm-to-x-face-command
+ (shell-quote-argument file)))))))
+
+;;;###autoload
+(defun gnus-insert-random-x-face-header ()
+ "Insert a random X-Face header from `gnus-x-face-directory'."
+ (interactive)
+ (let ((data (gnus-random-x-face)))
+ (save-excursion
+ (message-goto-eoh)
+ (if data
+ (insert "X-Face: " data)
+ (message
+ "No face returned by `gnus-random-x-face'. Does %s/*.pbm exist?"
+ gnus-x-face-directory)))))
+
+;;;###autoload
+(defun gnus-x-face-from-file (file)
+ "Insert an X-Face header based on an image file."
+ (interactive "fImage file name (by default GIF): ")
+ (when (file-exists-p file)
+ (gnus-shell-command-to-string
+ (format gnus-convert-image-to-x-face-command
+ (shell-quote-argument (expand-file-name file))))))
+
+;;;###autoload
+(defun gnus-face-from-file (file)
+ "Return an Face header based on an image file."
+ (interactive "fImage file name (by default JPEG): ")
+ (when (file-exists-p file)
+ (let ((done nil)
+ (attempt "")
+ (quant 16))
+ (while (and (not done)
+ (> quant 1))
+ (setq attempt
+ (let ((coding-system-for-read 'binary))
+ (gnus-shell-command-to-string
+ (format gnus-convert-image-to-face-command
+ (shell-quote-argument (expand-file-name file))
+ quant))))
+ (if (> (length attempt) 726)
+ (progn
+ (setq quant (- quant 2))
+ (message "Length %d; trying quant %d"
+ (length attempt) quant))
+ (setq done t)))
+ (if done
+ (mm-with-unibyte-buffer
+ (insert attempt)
+ (gnus-face-encode))
+ nil))))
+
+(defun gnus-face-encode ()
+ (let ((step 72))
+ (base64-encode-region (point-min) (point-max))
+ (goto-char (point-min))
+ (while (search-forward "\n" nil t)
+ (replace-match ""))
+ (goto-char (point-min))
+ (while (> (- (point-max) (point))
+ step)
+ (forward-char step)
+ (insert "\n ")
+ (setq step 76))
+ (buffer-string)))
+
+;;;###autoload
+(defun gnus-convert-face-to-png (face)
+ "Convert FACE (which is base64-encoded) to a PNG.
+The PNG is returned as a string."
+ (mm-with-unibyte-buffer
+ (insert face)
+ (ignore-errors
+ (base64-decode-region (point-min) (point-max)))
+ (buffer-string)))
+
+;;;###autoload
+(defun gnus-convert-png-to-face (file)
+ "Convert FILE to a Face.
+FILE should be a PNG file that's 48x48 and smaller than or equal to
+726 bytes."
+ (mm-with-unibyte-buffer
+ (insert-file-contents file)
+ (when (> (buffer-size) 726)
+ (error "The file is %d bytes long, which is too long"
+ (buffer-size)))
+ (gnus-face-encode)))
+
+(defface gnus-x-face '((t (:foreground "black" :background "white")))
+ "Face to show X-Face.
+The colors from this face are used as the foreground and background
+colors of the displayed X-Faces."
+ :group 'gnus-article-headers)
+
+(defun gnus-display-x-face-in-from (data)
+ "Display the X-Face DATA in the From header."
+ (let ((default-enable-multibyte-characters nil)
+ pbm)
+ (when (or (gnus-image-type-available-p 'xface)
+ (and (gnus-image-type-available-p 'pbm)
+ (setq pbm (uncompface data))))
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (gnus-article-goto-header "from")
+ (when (bobp)
+ (insert "From: [no `from' set]\n")
+ (forward-char -17))
+ (gnus-add-image
+ 'xface
+ (gnus-put-image
+ (if (gnus-image-type-available-p 'xface)
+ (gnus-create-image
+ (concat "X-Face: " data)
+ 'xface t :ascent 'center :face 'gnus-x-face)
+ (gnus-create-image
+ pbm 'pbm t :ascent 'center :face 'gnus-x-face))))
+ (gnus-add-wash-type 'xface))))))
+
+(defun gnus-grab-cam-x-face ()
+ "Grab a picture off the camera and make it into an X-Face."
+ (interactive)
+ (shell-command "xawtv-remote snap ppm")
+ (let ((file nil))
+ (while (null (setq file (directory-files "/tftpboot/sparky/tmp"
+ t "snap.*ppm")))
+ (sleep-for 1))
+ (setq file (car file))
+ (with-temp-buffer
+ (shell-command
+ (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>/dev/null | pnmscale -width 48 | ppmtopgm | pgmtopbm -threshold -value 0.92 | pbmtoxbm | compface"
+ file)
+ (current-buffer))
+ ;;(sleep-for 3)
+ (delete-file file)
+ (buffer-string))))
+
+(defun gnus-grab-cam-face ()
+ "Grab a picture off the camera and make it into an X-Face."
+ (interactive)
+ (shell-command "xawtv-remote snap ppm")
+ (let ((file nil)
+ result)
+ (while (null (setq file (directory-files "/tftpboot/sparky/tmp"
+ t "snap.*ppm")))
+ (sleep-for 1))
+ (setq file (car file))
+ (shell-command
+ (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm > /tmp/gnus.face.ppm"
+ file))
+ (let ((gnus-convert-image-to-face-command
+ (format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng"
+ (gnus-fun-ppm-change-string))))
+ (setq result (gnus-face-from-file "/tmp/gnus.face.ppm")))
+ (delete-file file)
+ ;;(delete-file "/tmp/gnus.face.ppm")
+ result))
+
+(defun gnus-fun-ppm-change-string ()
+ (let* ((possibilites '("%02x0000" "00%02x00" "0000%02x"
+ "%02x%02x00" "00%02x%02x" "%02x00%02x"))
+ (format (concat "'#%02x%02x%02x' '#"
+ (nth (random 6) possibilites)
+ "'"))
+ (values nil))
+ (dotimes (i 255)
+ (push (format format i i i i i i)
+ values))
+ (mapconcat 'identity values " ")))
+
+(provide 'gnus-fun)
+
+;;; gnus-fun.el ends here
--- /dev/null
+;;; gnus-namazu.el --- Search mail with Namazu -*- coding: iso-2022-7bit; -*-
+
+;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
+
+;; Author: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
+;; Keywords: mail searching namazu
+
+;; This file is a part of Semi-Gnus.
+
+;; This program 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.
+
+;; This program 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 this program; if not, you can either send email to this
+;; program's maintainer or write to: The Free Software Foundation,
+;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
+
+
+;;; Commentary:
+
+;; This file defines the command to search mails and persistent
+;; articles with Namazu and to browse its results with Gnus.
+;;
+;; Namazu is a full-text search engine intended for easy use. For
+;; more detail about Namazu, visit the following page:
+;;
+;; http://namazu.org/
+
+
+;;; Quick Start:
+
+;; If this module has already been installed, only 3 steps are
+;; required to search articles with this module.
+;;
+;; (1) Install Namazu.
+;; (2) Start Gnus and type M-x gnus-namazu-create-index RET to make
+;; index of articles.
+;; (3) In group buffer or in summary buffer, type C-c C-n query RET.
+
+
+;;; Install:
+
+;; Before installing this module, you must install Namazu.
+;;
+;; This file is a part of T-gnus but is not *YET* a part of Gnus.
+;; When you would like to use this module in Gnus (not T-gnus), put
+;; this file into the lisp/ directory in the Gnus source tree and run
+;; `make install'. And then, put the following expression into your
+;; ~/.gnus.
+;;
+;; (require 'gnus-namazu)
+;; (gnus-namazu-insinuate)
+;;
+;; In order to make index of articles with Namazu before using this
+;; module, type M-x gnus-namazu-create-index RET. Otherwise, you can
+;; create index by yourself with the following commands:
+;;
+;; % mkdir ~/News/namazu
+;; % mknmz -a -h -O ~/News/namazu ~/Mail ~/News/cache
+;;
+;; The first command makes the directory for index files, and the
+;; second command generates index files of mails and persistent
+;; articles.
+;;
+;; In order to update indices for incoming articles, this module
+;; automatically runs mknmz, the indexer of Namazu, at an interval of
+;; 3 days; this period is set to `gnus-namazu-index-update-interval'.
+;;
+;; Indices will be updated when `gnus-namazu-search' is called. If
+;; you want to update indices everywhen Gnus is started, you can put
+;; the following expression to your ~/.gnus.
+;;
+;; (add-hook 'gnus-startup-hook 'gnus-namazu-update-all-indices)
+;;
+;; In order to control mknmz closely, disable the automatic updating
+;; feature and run mknmz by yourself. In this case, set nil to the
+;; above option.
+;;
+;; (setq gnus-namazu-index-update-interval nil)
+;;
+;; When your index is put into the directory other than the default
+;; one (~/News/namazu), it is necessary to set its place to
+;; `gnus-namazu-index-directories' as follows:
+;;
+;; (setq gnus-namazu-index-directories
+;; (list (expand-file-name "~/namazu")))
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'nnoo)
+(require 'nnheader)
+(require 'nnmail)
+(require 'gnus-sum)
+
+;; It is required for Mule 2.3. See the file Mule23@1934.en.
+(eval-and-compile
+ (autoload 'regexp-opt "regexp-opt"))
+
+;; To suppress byte-compile warning.
+(eval-when-compile
+ (defvar nnml-directory)
+ (defvar nnmh-directory))
+
+
+(defgroup gnus-namazu nil
+ "Search nnmh and nnml groups in Gnus with Namazu."
+ :group 'namazu
+ :group 'gnus
+ :prefix "gnus-namazu-")
+
+(defconst gnus-namazu-default-index-directory
+ (expand-file-name "namazu" gnus-directory)
+ "Default place of Namazu index files.")
+
+(defcustom gnus-namazu-index-directories
+ (list
+ (or (and (boundp 'gnus-namazu-index-directory)
+ (symbol-value 'gnus-namazu-index-directory))
+ (and (boundp 'nnir-namazu-index-directory)
+ (symbol-value 'nnir-namazu-index-directory))
+ gnus-namazu-default-index-directory))
+ "*Places of Namazu index files."
+ :type '(repeat directory)
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-command
+ (or (and (boundp 'namazu-command)
+ (symbol-value 'namazu-command))
+ (and (boundp 'nnir-namazu-program)
+ (symbol-value 'nnir-namazu-program))
+ "namazu")
+ "*Name of the executable file of Namazu."
+ :type 'string
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-additional-arguments nil
+ "*Additional arguments of Namazu.
+The options `-q', `-a', and `-l' are always used, very few other
+options make any sense in this context."
+ :type '(repeat string)
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-index-update-interval
+ 259200 ; 3 days == 259200 seconds.
+ "*Number of seconds between running the indexer of Namazu."
+ :type '(choice (const :tag "Never run the indexer" nil)
+ (integer :tag "Number of seconds"))
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-make-index-command "mknmz"
+ "*Name of the executable file of the indexer of Namazu."
+ :type 'string
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-make-index-arguments
+ (nconc
+ (list "--all" "--mailnews" "--deny=^.*[^0-9].*$")
+ (when (or (and (boundp 'current-language-environment)
+ (string= "Japanese"
+ (symbol-value 'current-language-environment)))
+ (boundp 'MULE))
+ (list "--indexing-lang=ja")))
+ "*Arguments of the indexer of Namazu."
+ :type '(repeat string)
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-field-keywords
+ '("date" "from" "newsgroups" "size" "subject" "summary" "to" "uri")
+ "*List of keywords to do field-search."
+ :type '(repeat string)
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-coding-system
+ (if (memq system-type '(windows-nt OS/2 emx))
+ (if (boundp 'MULE) '*sjis* 'shift_jis)
+ (if (boundp 'MULE) '*euc-japan* 'euc-japan))
+ "*Coding system for Namazu process."
+ :type 'coding-system
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-need-path-normalization
+ (and (memq system-type '(windows-nt OS/2 emx)) t)
+ "*Non-nil means that outputs of namazu may contain drive letters."
+ :type 'boolean
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-case-sensitive-filesystem
+ (not (eq system-type 'windows-nt))
+ "*Non-nil means that the using file system distinguishes cases of characters."
+ :type 'boolean
+ :group 'gnus-namazu)
+
+(defcustom gnus-namazu-query-highlight t
+ "Non-nil means that queried words is highlighted."
+ :type 'boolean
+ :group 'gnus-namazu)
+
+(defface gnus-namazu-query-highlight-face
+ '((((type tty pc) (class color))
+ (:background "magenta4" :foreground "cyan1"))
+ (((class color) (background light))
+ (:background "magenta4" :foreground "lightskyblue1"))
+ (((class color) (background dark))
+ (:background "palevioletred2" :foreground "brown4"))
+ (t (:inverse-video t)))
+ "Face used for namazu query matching words."
+ :group 'gnus-namazu)
+
+;;; Internal Variable:
+(defconst gnus-namazu/group-name-regexp "\\`nnvirtual:namazu-search\\?")
+
+;; Multibyte group name:
+(and
+ (fboundp 'gnus-group-decoded-name)
+ (let ((gnus-group-name-charset-group-alist
+ (list (cons gnus-namazu/group-name-regexp gnus-namazu-coding-system)))
+ (query (decode-coding-string
+ (string 27 36 66 52 65 59 122 27 40 66)
+ (if (boundp 'MULE) '*iso-2022-jp* 'iso-2022-7bit))))
+ (not (string-match query
+ (gnus-summary-buffer-name
+ (encode-coding-string
+ (concat "nnvirtual:namazu-search?query=" query)
+ gnus-namazu-coding-system)))))
+ (let (current-load-list)
+ (defadvice gnus-summary-buffer-name
+ (before gnus-namazu-summary-buffer-name activate compile)
+ "Advised by `gnus-namazu' to handle encoded group names."
+ (ad-set-arg 0 (gnus-group-decoded-name (ad-get-arg 0))))))
+
+(defmacro gnus-namazu/make-article (group number)
+ `(cons ,group ,number))
+(defmacro gnus-namazu/article-group (x) `(car ,x))
+(defmacro gnus-namazu/article-number (x) `(cdr ,x))
+
+(defsubst gnus-namazu/indexed-servers ()
+ "Choice appropriate servers from opened ones, and return thier list."
+ (append
+ (gnus-servers-using-backend 'nnml)
+ (gnus-servers-using-backend 'nnmh)))
+
+(defsubst gnus-namazu/default-index-directory ()
+ (if (member gnus-namazu-default-index-directory
+ gnus-namazu-index-directories)
+ gnus-namazu-default-index-directory
+ (car gnus-namazu-index-directories)))
+
+(defun gnus-namazu/setup ()
+ (and (boundp 'gnus-group-name-charset-group-alist)
+ (not (member (cons gnus-namazu/group-name-regexp
+ gnus-namazu-coding-system)
+ gnus-group-name-charset-group-alist))
+ (let ((pair (assoc gnus-namazu/group-name-regexp
+ gnus-group-name-charset-group-alist)))
+ (if pair
+ (setcdr pair gnus-namazu-coding-system)
+ (push (cons gnus-namazu/group-name-regexp
+ gnus-namazu-coding-system)
+ gnus-group-name-charset-group-alist))))
+ (gnus-namazu-update-all-indices))
+
+(defun gnus-namazu/server-directory (server)
+ "Return the top directory of the server SERVER."
+ (and (memq (car server) '(nnml nnmh))
+ (nnoo-change-server (car server) (nth 1 server) (nthcdr 2 server))
+ (file-name-as-directory
+ (expand-file-name (if (eq 'nnml (car server))
+ nnml-directory
+ nnmh-directory)))))
+
+;;; Functions to call Namazu.
+(defsubst gnus-namazu/normalize-results ()
+ "Normalize file names returned by Namazu in this current buffer."
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (looking-at "file://")
+ (delete-region (point) (match-end 0)))
+ (when (if gnus-namazu-need-path-normalization
+ (or (not (looking-at "/\\(.\\)|/"))
+ (replace-match "\\1:/"))
+ (eq ?~ (char-after (point))))
+ (insert (expand-file-name
+ (buffer-substring (gnus-point-at-bol) (gnus-point-at-eol))))
+ (delete-region (point) (gnus-point-at-eol)))
+ (forward-line 1)))
+
+(defsubst gnus-namazu/call-namazu (query)
+ (let ((coding-system-for-read gnus-namazu-coding-system)
+ (coding-system-for-write gnus-namazu-coding-system)
+ (input-coding-system gnus-namazu-coding-system)
+ (output-coding-system gnus-namazu-coding-system)
+ (default-process-coding-system
+ (cons gnus-namazu-coding-system gnus-namazu-coding-system))
+ program-coding-system-alist
+ (file-name-coding-system gnus-namazu-coding-system)
+ (pathname-coding-system gnus-namazu-coding-system))
+ (apply 'call-process
+ `(,gnus-namazu-command
+ nil ; input from /dev/null
+ t ; output
+ nil ; don't redisplay
+ "-q" ; don't be verbose
+ "-a" ; show all matches
+ "-l" ; use list format
+ ,@gnus-namazu-additional-arguments
+ ,query
+ ,@gnus-namazu-index-directories))))
+
+(defsubst gnus-namazu/group-prefixed-name (group method)
+ "Return the whole name from GROUP and METHOD."
+ (if gnus-namazu-case-sensitive-filesystem
+ (gnus-group-prefixed-name group method)
+ (let* ((orig (gnus-group-prefixed-name group method))
+ (name (downcase orig)))
+ (catch 'found-group
+ (mapatoms (lambda (sym)
+ (when (string= name (downcase (symbol-name sym)))
+ (throw 'found-group (symbol-name sym))))
+ gnus-newsrc-hashtb)
+ orig))))
+
+(defun gnus-namazu/real-group-name (cond str)
+ "Generate the real group name from the partial path, STR."
+ (if cond
+ str
+ (catch 'found-group
+ (dolist (group (gnus-namazu/possible-real-groups
+ (nnheader-replace-chars-in-string str ?/ ?.)))
+ (when (gnus-gethash group gnus-newsrc-hashtb)
+ (throw 'found-group group))))))
+
+(defun gnus-namazu/possible-real-groups (str)
+ "Regard the string STR as the partial path of the cached article and
+generate possible group names from it."
+ (if (string-match "_\\(_\\(_\\)?\\)?" str)
+ (let ((prefix (substring str 0 (match-beginning 0)))
+ (suffix (substring str (match-end 0))))
+ (cond
+ ((match-beginning 2) ;; The number of discoverd underscores = 3
+ (nconc
+ (gnus-namazu/possible-real-groups (concat prefix "/__" suffix))
+ (gnus-namazu/possible-real-groups (concat prefix ".._" suffix))))
+ ((match-beginning 1) ;; The number of discoverd underscores = 2
+ (nconc
+ (gnus-namazu/possible-real-groups (concat prefix "//" suffix))
+ (gnus-namazu/possible-real-groups (concat prefix ".." suffix))))
+ (t ;; The number of discoverd underscores = 1
+ (gnus-namazu/possible-real-groups (concat prefix "/" suffix)))))
+ (if (string-match "\\." str)
+ ;; Handle the first occurence of period.
+ (list (concat (substring str 0 (match-beginning 0))
+ ":"
+ (substring str (match-end 0)))
+ str)
+ (list str))))
+
+(defun gnus-namazu/search (groups query)
+ (with-temp-buffer
+ (let ((exit-status (gnus-namazu/call-namazu query)))
+ (unless (zerop exit-status)
+ (error "Namazu finished abnormally: %d" exit-status))
+ (let* ((articles)
+ (server-alist
+ (delq nil
+ (let (dir)
+ (mapcar
+ (lambda (s)
+ (when (setq dir (gnus-namazu/server-directory s))
+ (cons (file-name-as-directory dir) s)))
+ (gnus-namazu/indexed-servers)))))
+ (topdir-regexp (regexp-opt (mapcar 'car server-alist)))
+ (cache-regexp (concat
+ (regexp-quote
+ (file-name-as-directory
+ (expand-file-name gnus-cache-directory)))
+ "\\(.*\\)/\\([0-9]+\\)$"))
+ (agent-regexp (concat
+ (regexp-quote
+ (file-name-as-directory
+ (expand-file-name gnus-agent-directory)))
+ "\\(.*\\)/\\([0-9]+\\)$")))
+ (gnus-namazu/normalize-results)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let (server group file)
+ (and (or
+ ;; Check the discoverd file is the persistent article.
+ (and (looking-at cache-regexp)
+ (setq file (match-string-no-properties 2)
+ group (gnus-namazu/real-group-name
+ (gnus-use-long-file-name 'not-cache)
+ (match-string-no-properties 1))))
+ ;; Check the discoverd file is covered by the agent.
+ (and (looking-at agent-regexp)
+ (setq file (match-string-no-properties 2)
+ group (gnus-namazu/real-group-name
+ nnmail-use-long-file-names
+ (match-string-no-properties 1))))
+ ;; Check the discovered file is managed by Gnus servers.
+ (and (looking-at topdir-regexp)
+ (setq file (buffer-substring-no-properties
+ (match-end 0) (gnus-point-at-eol))
+ server (cdr (assoc (match-string-no-properties 0)
+ server-alist)))
+ ;; Check validity of the file name.
+ (string-match "/\\([0-9]+\\)\\'" file)
+ (progn
+ (setq group (substring file 0 (match-beginning 0))
+ file (match-string 1 file))
+ (setq group
+ (gnus-namazu/group-prefixed-name
+ (if nnmail-use-long-file-names
+ group
+ (nnheader-replace-chars-in-string group
+ ?/ ?.))
+ server)))))
+ (or (not groups)
+ (member group groups))
+ (push (gnus-namazu/make-article group (string-to-number file))
+ articles)))
+ (forward-line 1))
+ (nreverse articles)))))
+
+
+;;; User Interface:
+(defun gnus-namazu/get-target-groups ()
+ (cond
+ ((eq major-mode 'gnus-group-mode)
+ ;; In Group buffer.
+ (cond
+ (current-prefix-arg
+ (gnus-group-process-prefix current-prefix-arg))
+ (gnus-group-marked
+ (prog1 gnus-group-marked (gnus-group-unmark-all-groups)))))
+ ((eq major-mode 'gnus-summary-mode)
+ ;; In Summary buffer.
+ (if current-prefix-arg
+ (list (gnus-read-group "Group: "))
+ (if (and
+ (gnus-ephemeral-group-p gnus-newsgroup-name)
+ (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name))
+ (cadr (assq 'gnus-namazu-target-groups
+ (gnus-info-method (gnus-get-info gnus-newsgroup-name))))
+ (list gnus-newsgroup-name))))))
+
+(defun gnus-namazu/get-current-query ()
+ (and (eq major-mode 'gnus-summary-mode)
+ (gnus-ephemeral-group-p gnus-newsgroup-name)
+ (string-match gnus-namazu/group-name-regexp gnus-newsgroup-name)
+ (cadr (assq 'gnus-namazu-current-query
+ (gnus-info-method (gnus-get-info gnus-newsgroup-name))))))
+
+(defvar gnus-namazu/read-query-original-buffer nil)
+(defvar gnus-namazu/read-query-prompt nil)
+(defvar gnus-namazu/read-query-history nil)
+
+(defun gnus-namazu/get-current-subject ()
+ (and gnus-namazu/read-query-original-buffer
+ (bufferp gnus-namazu/read-query-original-buffer)
+ (with-current-buffer gnus-namazu/read-query-original-buffer
+ (when (eq major-mode 'gnus-summary-mode)
+ (let ((s (gnus-summary-article-subject)))
+ ;; Remove typically prefixes of mailing lists.
+ (when (string-match
+ "^\\(\\[[^]]*[0-9]+\\]\\|([^)]*[0-9]+)\\)\\s-*" s)
+ (setq s (substring s (match-end 0))))
+ (when (string-match
+ "^\\(Re\\(\\^?\\([0-9]+\\|\\[[0-9]+\\]\\)\\)?:\\s-*\\)+" s)
+ (setq s (substring s (match-end 0))))
+ (when (string-match "\\s-*(\\(re\\|was\\)\\b" s)
+ (setq s (substring s 0 (match-beginning 0))))
+ s)))))
+
+(defun gnus-namazu/get-current-from ()
+ (and gnus-namazu/read-query-original-buffer
+ (bufferp gnus-namazu/read-query-original-buffer)
+ (with-current-buffer gnus-namazu/read-query-original-buffer
+ (when (eq major-mode 'gnus-summary-mode)
+ (cadr (mail-extract-address-components
+ (mail-header-from
+ (gnus-summary-article-header))))))))
+
+(defun gnus-namazu/get-current-to ()
+ (and gnus-namazu/read-query-original-buffer
+ (bufferp gnus-namazu/read-query-original-buffer)
+ (with-current-buffer gnus-namazu/read-query-original-buffer
+ (when (eq major-mode 'gnus-summary-mode)
+ (cadr (mail-extract-address-components
+ (cdr (assq 'To (mail-header-extra
+ (gnus-summary-article-header))))))))))
+
+(defmacro gnus-namazu/minibuffer-prompt-end ()
+ (if (fboundp 'minibuffer-prompt-end)
+ '(minibuffer-prompt-end)
+ '(point-min)))
+
+(defun gnus-namazu/message (string &rest arguments)
+ (let* ((s1 (concat
+ gnus-namazu/read-query-prompt
+ (buffer-substring (gnus-namazu/minibuffer-prompt-end)
+ (point-max))))
+ (s2 (apply (function format) string arguments))
+ (w (- (window-width)
+ (string-width s1)
+ (string-width s2)
+ 1)))
+ (message (if (>= w 0)
+ (concat s1 (make-string w ?\ ) s2)
+ s2))
+ (if (sit-for 0.3) (message s1))
+ s2))
+
+(defun gnus-namazu/complete-query ()
+ (interactive)
+ (let ((pos (point)))
+ (cond
+ ((and (re-search-backward "\\+\\([-a-z]*\\)" nil t)
+ (= pos (match-end 0)))
+ (let* ((partial (match-string 1))
+ (completions
+ (all-completions
+ partial
+ (mapcar 'list gnus-namazu-field-keywords))))
+ (cond
+ ((null completions)
+ (gnus-namazu/message "No completions of %s" partial))
+ ((= 1 (length completions))
+ (goto-char (match-beginning 1))
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert (car completions) ":")
+ (setq pos (point))
+ (gnus-namazu/message "Completed"))
+ (t
+ (let ((x (try-completion partial (mapcar 'list completions))))
+ (if (string= x partial)
+ (if (and (eq last-command
+ 'gnus-namazu/field-keyword-completion)
+ completion-auto-help)
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list completions))
+ (gnus-namazu/message "Sole completion"))
+ (goto-char (match-beginning 1))
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert x)
+ (setq pos (point))))))))
+ ((and (looking-at "\\+subject:")
+ (= pos (match-end 0)))
+ (let ((s (gnus-namazu/get-current-subject)))
+ (when s
+ (goto-char pos)
+ (insert "\"" s "\"")
+ (setq pos (point)))))
+ ((and (looking-at "\\+from:")
+ (= pos (match-end 0)))
+ (let ((f (gnus-namazu/get-current-from)))
+ (when f
+ (goto-char pos)
+ (insert "\"" f "\"")
+ (setq pos (point)))))
+ ((and (looking-at "\\+to:")
+ (= pos (match-end 0)))
+ (let ((to (gnus-namazu/get-current-to)))
+ (when to
+ (goto-char pos)
+ (insert "\"" to "\"")
+ (setq pos (point))))))
+ (goto-char pos)))
+
+(defvar gnus-namazu/read-query-map
+ (let ((keymap (copy-keymap minibuffer-local-map)))
+ (define-key keymap "\t" 'gnus-namazu/complete-query)
+ keymap))
+
+(defun gnus-namazu/read-query (prompt &optional initial)
+ (let ((gnus-namazu/read-query-original-buffer (current-buffer))
+ (gnus-namazu/read-query-prompt prompt))
+ (unless initial
+ (when (setq initial (gnus-namazu/get-current-query))
+ (setq initial (cons initial 0))))
+ (read-from-minibuffer prompt initial gnus-namazu/read-query-map nil
+ 'gnus-namazu/read-query-history)))
+
+(defun gnus-namazu/highlight-words (query)
+ (with-temp-buffer
+ (insert " " query)
+ ;; Remove tokens for NOT search
+ (goto-char (point-min))
+ (while (re-search-forward "[\e$B!!\e(B \t\r\f\n]+not[\e$B!!\e(B \t\r\f\n]+\
+\\([^\e$B!!\e(B \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Remove tokens for Field search
+ (goto-char (point-min))
+ (while (re-search-forward "[\e$B!!\e(B \t\r\f\n]+\\+[^\e$B!!\e(B \t\r\f\n:]+:\
+\\([^\e$B!!\e(B \t\r\f\n\"{(/]+\\|\"[^\"]+\"\\|{[^}]+}\\|([^)]+)\\|/[^/]+/\\)+" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Remove tokens for Regexp search
+ (goto-char (point-min))
+ (while (re-search-forward "/[^/]+/" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Remove brackets, double quote, asterisk and operators
+ (goto-char (point-min))
+ (while (re-search-forward "\\([(){}\"*]\\|\\b\\(and\\|or\\)\\b\\)" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Collect all keywords
+ (setq query nil)
+ (goto-char (point-min))
+ (while (re-search-forward "[^\e$B!!\e(B \t\r\f\n]+" nil t)
+ (push (match-string 0) query))
+ (when query
+ (let (en ja)
+ (dolist (q query)
+ (if (string-match "\\cj" q)
+ (push q ja)
+ (push q en)))
+ (append
+ (when en
+ (list (list (concat "\\b\\(" (regexp-opt en) "\\)\\b")
+ 0 0 'gnus-namazu-query-highlight-face)))
+ (when ja
+ (list (list (regexp-opt ja)
+ 0 0 'gnus-namazu-query-highlight-face))))))))
+
+(defun gnus-namazu/truncate-article-list (articles)
+ (let ((hit (length articles)))
+ (when (and gnus-large-newsgroup
+ (> hit gnus-large-newsgroup))
+ (let* ((cursor-in-echo-area nil)
+ (input (read-from-minibuffer
+ (format "\
+Too many articles were retrieved. How many articles (max %d): "
+ hit)
+ (cons (number-to-string gnus-large-newsgroup) 0))))
+ (unless (string-match "\\`[ \t]*\\'" input)
+ (setcdr (nthcdr (min (1- (string-to-number input)) hit) articles)
+ nil)))))
+ articles)
+
+;;;###autoload
+(defun gnus-namazu-search (groups query)
+ "Search QUERY through GROUPS with Namazu,
+and make a virtual group contains its results."
+ (interactive
+ (list
+ (gnus-namazu/get-target-groups)
+ (gnus-namazu/read-query "Enter query: ")))
+ (gnus-namazu/setup)
+ (let ((articles (gnus-namazu/search groups query)))
+ (if articles
+ (let ((real-groups groups)
+ (vgroup
+ (apply (function format)
+ "nnvirtual:namazu-search?query=%s&groups=%s&id=%d%d%d"
+ query
+ (if groups (mapconcat 'identity groups ",") "ALL")
+ (current-time))))
+ (gnus-namazu/truncate-article-list articles)
+ (unless real-groups
+ (dolist (a articles)
+ (add-to-list 'real-groups (gnus-namazu/article-group a))))
+ ;; Generate virtual group which includes all results.
+ (when (fboundp 'gnus-group-decoded-name)
+ (setq vgroup
+ (encode-coding-string vgroup gnus-namazu-coding-system)))
+ (setq vgroup
+ (gnus-group-read-ephemeral-group
+ vgroup
+ `(nnvirtual ,vgroup
+ (nnvirtual-component-groups ,real-groups)
+ (gnus-namazu-target-groups ,groups)
+ (gnus-namazu-current-query ,query))
+ t (cons (current-buffer) (current-window-configuration)) t))
+ (when gnus-namazu-query-highlight
+ (gnus-group-set-parameter vgroup 'highlight-words
+ (gnus-namazu/highlight-words query)))
+ ;; Generate new summary buffer which contains search results.
+ (gnus-group-read-group
+ t t vgroup
+ (sort (delq nil ;; Ad-hoc fix, to avoid wrong-type-argument error.
+ (mapcar
+ (lambda (a)
+ (nnvirtual-reverse-map-article
+ (gnus-namazu/article-group a)
+ (gnus-namazu/article-number a)))
+ articles))
+ '<)))
+ (message "No entry."))))
+
+(defmacro gnus-namazu/lock-file-name (&optional directory)
+ `(expand-file-name "NMZ.lock2" ,directory))
+
+(defmacro gnus-namazu/status-file-name (&optional directory)
+ `(expand-file-name "NMZ.status" ,directory))
+
+(defmacro gnus-namazu/index-file-name (&optional directory)
+ `(expand-file-name "NMZ.i" ,directory))
+
+(defun gnus-namazu/mknmz-cleanup (directory)
+ (let ((lockfile (gnus-namazu/lock-file-name directory)))
+ (when (file-exists-p lockfile)
+ (delete-file lockfile)
+ (dolist (tmpfile (directory-files directory t "\\`NMZ\\..*\\.tmp\\'" t))
+ (delete-file tmpfile)))))
+
+;;;###autoload
+(defun gnus-namazu-create-index (directory &optional target-directories force)
+ "Create index under DIRECTORY."
+ (interactive
+ (list
+ (if (and current-prefix-arg (> (length gnus-namazu-index-directories) 1))
+ (completing-read "Directory: "
+ (mapcar 'list gnus-namazu-index-directories) nil t)
+ (gnus-namazu/default-index-directory))
+ nil t))
+ (setq directory (file-name-as-directory (expand-file-name directory)))
+ (unless target-directories
+ (setq target-directories
+ (delq nil
+ (mapcar (lambda (dir)
+ (when (file-directory-p dir) dir))
+ (append
+ (mapcar 'gnus-namazu/server-directory
+ (gnus-namazu/indexed-servers))
+ (list
+ (expand-file-name gnus-cache-directory)
+ (expand-file-name gnus-agent-directory)))))))
+ (if (file-exists-p (gnus-namazu/lock-file-name directory))
+ (when force
+ (error "Found lock file: %s" (gnus-namazu/lock-file-name directory)))
+ (with-current-buffer
+ (get-buffer-create (concat " *mknmz*" directory))
+ (erase-buffer)
+ (unless (file-directory-p directory)
+ (make-directory directory t))
+ (setq default-directory directory)
+ (let ((args (append gnus-namazu-make-index-arguments
+ target-directories)))
+ (insert "% " gnus-namazu-make-index-command " "
+ (mapconcat 'identity args " ") "\n")
+ (goto-char (point-max))
+ (when force
+ (pop-to-buffer (current-buffer)))
+ (message "Make index at %s..." directory)
+ (unwind-protect
+ (apply 'call-process gnus-namazu-make-index-command nil t t args)
+ (gnus-namazu/mknmz-cleanup directory))
+ (message "Make index at %s...done" directory)
+ (unless force
+ (kill-buffer (current-buffer)))))))
+
+(defun gnus-namazu/lapse-seconds (start end)
+ "Return lapse seconds from START to END.
+START and END are lists which represent time in Emacs-style."
+ (+ (* (- (car end) (car start)) 65536)
+ (cadr end)
+ (- (cadr start))))
+
+(defun gnus-namazu/index-old-p (directory)
+ "Return non-nil value when the index under the DIRECTORY is older
+than the period that is set to `gnus-namazu-index-update-interval'"
+ (let ((file (gnus-namazu/index-file-name directory)))
+ (or (not (file-exists-p file))
+ (and (integerp gnus-namazu-index-update-interval)
+ (>= (gnus-namazu/lapse-seconds
+ (nth 5 (file-attributes file))
+ (current-time))
+ gnus-namazu-index-update-interval)))))
+
+(defvar gnus-namazu/update-directories nil)
+(defvar gnus-namazu/update-process nil)
+
+(defun gnus-namazu/update-p (directory &optional force)
+ "Return the DIRECTORY when the index undef the DIRECTORY should be updated."
+ (setq directory (file-name-as-directory (expand-file-name directory)))
+ (labels ((error-message (format &rest args)
+ (apply (if force 'error 'message) format args)
+ nil))
+ (if gnus-namazu/update-process
+ (error-message "%s" "Can not run two update processes simultaneously")
+ (and (or force
+ (gnus-namazu/index-old-p directory))
+ (let ((status-file (gnus-namazu/status-file-name directory)))
+ (or (file-exists-p status-file)
+ (error-message "Can not find status file: %s" status-file)))
+ (let ((lock-file (gnus-namazu/lock-file-name directory)))
+ (or (not (file-exists-p lock-file))
+ (error-message "Found lock file: %s" lock-file)))
+ directory))))
+
+;;;###autoload
+(defun gnus-namazu-update-index (directory &optional force)
+ "Update the index under the DIRECTORY."
+ (interactive
+ (list
+ (if (and current-prefix-arg (> (length gnus-namazu-index-directories) 1))
+ (completing-read "Directory: "
+ (mapcar 'list gnus-namazu-index-directories) nil t)
+ (gnus-namazu/default-index-directory))
+ t))
+ (when (setq directory (gnus-namazu/update-p directory force))
+ (with-current-buffer (get-buffer-create (concat " *mknmz*" directory))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (unless (file-directory-p directory)
+ (make-directory directory t))
+ (setq default-directory directory)
+ (let ((proc (start-process gnus-namazu-make-index-command
+ (current-buffer)
+ gnus-namazu-make-index-command
+ (format "--update=%s" directory))))
+ (if (processp proc)
+ (prog1 (setq gnus-namazu/update-process proc)
+ (process-kill-without-query proc)
+ (set-process-sentinel proc 'gnus-namazu/update-sentinel)
+ (add-hook 'kill-emacs-hook 'gnus-namazu-stop-update)
+ (message "Update index at %s..." directory))
+ (goto-char (point-min))
+ (if (re-search-forward "^ERROR:.*$" nil t)
+ (progn
+ (pop-to-buffer (current-buffer))
+ (funcall (if force 'error 'message)
+ "Update index at %s...%s" directory (match-string 0)))
+ (kill-buffer (current-buffer))
+ (funcall (if force 'error 'message)
+ "Can not start %s" gnus-namazu-make-index-command))
+ nil)))))
+
+;;;###autoload
+(defun gnus-namazu-update-all-indices (&optional directories force)
+ "Update all indices which is set to `gnus-namazu-index-directories'."
+ (interactive (list nil t))
+ (when (setq directories
+ (delq nil (mapcar
+ (lambda (d) (gnus-namazu/update-p d force))
+ (or directories gnus-namazu-index-directories))))
+ (setq gnus-namazu/update-directories (cdr directories))
+ (gnus-namazu-update-index (car directories))))
+
+(defun gnus-namazu/update-sentinel (process event)
+ (let ((buffer (process-buffer process)))
+ (when (buffer-name buffer)
+ (with-current-buffer buffer
+ (gnus-namazu/mknmz-cleanup default-directory)
+ (goto-char (point-min))
+ (cond
+ ((re-search-forward "^ERROR:.*$" nil t)
+ (pop-to-buffer (current-buffer))
+ (message "Update index at %s...%s"
+ default-directory (match-string 0))
+ (setq gnus-namazu/update-directories nil))
+ ((and (eq 'exit (process-status process))
+ (zerop (process-exit-status process)))
+ (message "Update index at %s...done" default-directory)
+ (unless (or debug-on-error debug-on-quit)
+ (kill-buffer buffer)))))))
+ (setq gnus-namazu/update-process nil)
+ (when gnus-namazu/update-directories
+ (gnus-namazu-update-all-indices gnus-namazu/update-directories)))
+
+;;;###autoload
+(defun gnus-namazu-stop-update ()
+ "Stop the running indexer of Namazu."
+ (interactive)
+ (setq gnus-namazu/update-directories nil)
+ (and gnus-namazu/update-process
+ (processp gnus-namazu/update-process)
+ (kill-process gnus-namazu/update-process)))
+
+(let (current-load-list)
+ (defadvice gnus-offer-save-summaries
+ (before gnus-namazu-kill-summary-buffers activate compile)
+ "Advised by `gnus-namazu'.
+In order to avoid annoying questions, kill summary buffers which
+generated by `gnus-namazu' itself before `gnus-offer-save-summaries'
+is called."
+ (let ((buffers (buffer-list)))
+ (while buffers
+ (when (with-current-buffer (car buffers)
+ (and (eq major-mode 'gnus-summary-mode)
+ (gnus-ephemeral-group-p gnus-newsgroup-name)
+ (string-match gnus-namazu/group-name-regexp
+ gnus-newsgroup-name)))
+ (kill-buffer (car buffers)))
+ (setq buffers (cdr buffers))))))
+
+;;;###autoload
+(defun gnus-namazu-insinuate ()
+ (add-hook
+ 'gnus-group-mode-hook
+ (lambda ()
+ (define-key gnus-group-mode-map "\C-c\C-n" 'gnus-namazu-search)))
+ (add-hook
+ 'gnus-summary-mode-hook
+ (lambda ()
+ (define-key gnus-summary-mode-map "\C-c\C-n" 'gnus-namazu-search))))
+
+(provide 'gnus-namazu)
+
+;; gnus-namazu.el ends here.
--- /dev/null
+;;; gnus-registry.el --- article registry for Gnus
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: news
+
+;; 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 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:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'gnus)
+(require 'gnus-int)
+(require 'gnus-sum)
+(require 'nnmail)
+
+(defgroup gnus-registry nil
+ "The Gnus registry."
+ :group 'gnus)
+
+(defvar gnus-registry-hashtb nil
+ "*The article registry by Message ID.")
+
+(defvar gnus-registry-headers-hashtb nil
+ "*The article header registry by Message ID. Unused for now.")
+
+(defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
+ "List of groups that gnus-registry-split-fancy-with-parent won't follow.
+The group names are matched, they don't have to be fully qualified."
+ :group 'gnus-registry
+ :type '(repeat string))
+
+(defcustom gnus-registry-unregistered-group-regex "^nntp"
+ "Group name regex that gnus-registry-register-message-ids won't process."
+ :group 'gnus-registry
+ :type 'regexp)
+
+;; Function(s) missing in Emacs 20
+(when (memq nil (mapcar 'fboundp '(puthash)))
+ (require 'cl)
+ (unless (fboundp 'puthash)
+ ;; alias puthash is missing from Emacs 20 cl-extra.el
+ (defalias 'puthash 'cl-puthash)))
+
+(defun gnus-registry-translate-to-alist ()
+ (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb)))
+
+(defun gnus-registry-translate-from-alist ()
+ (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
+
+(defun alist-to-hashtable (alist)
+ "Build a hashtable from the values in ALIST."
+ (let ((ht (make-hash-table
+ :size 4096
+ :test 'equal)))
+ (mapc
+ (lambda (kv-pair)
+ (puthash (car kv-pair) (cdr kv-pair) ht))
+ alist)
+ ht))
+
+(defun hashtable-to-alist (hash)
+ "Build an alist from the values in HASH."
+ (let ((list nil))
+ (maphash
+ (lambda (key value)
+ (setq list (cons (cons key value) list)))
+ hash)
+ list))
+
+(defun gnus-register-action (action data-header from &optional to method)
+ (let* ((id (mail-header-id data-header))
+ (from (gnus-group-guess-full-name from))
+ (to (if to (gnus-group-guess-full-name to) nil))
+ (to-name (if to to "the Bit Bucket"))
+ (old-entry (gethash id gnus-registry-hashtb)))
+ (gnus-message 5 "Registry: article %s %s from %s to %s"
+ id
+ (if method "respooling" "going")
+ from
+ to)
+
+ ;; All except copy will need a delete
+ (gnus-registry-delete-group id from)
+
+ (when (equal 'copy action)
+ (gnus-registry-add-group id from)) ; undo the delete
+
+ (gnus-registry-add-group id to)))
+
+(defun gnus-register-spool-action (id group)
+ ;; do not process the draft IDs
+; (unless (string-match "totally-fudged-out-message-id" id)
+; (let ((group (gnus-group-guess-full-name group)))
+ (when (string-match "\r$" id)
+ (setq id (substring id 0 -1)))
+ (gnus-message 5 "Registry: article %s spooled to %s"
+ id
+ group)
+ (gnus-registry-add-group id group))
+;)
+
+;; Function for nn{mail|imap}-split-fancy: look up all references in
+;; the cache and if a match is found, return that group.
+(defun gnus-registry-split-fancy-with-parent ()
+ "Split this message into the same group as its parent. The parent
+is obtained from the registry. This function can be used as an entry
+in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
+this: (: gnus-registry-split-fancy-with-parent)
+
+For a message to be split, it looks for the parent message in the
+References or In-Reply-To header and then looks in the registry to
+see which group that message was put in. This group is returned.
+
+See the Info node `(gnus)Fancy Mail Splitting' for more details."
+ (let ((refstr (or (message-fetch-field "references")
+ (message-fetch-field "in-reply-to")))
+ (references nil)
+ (res nil))
+ (when refstr
+ (setq references (nreverse (gnus-split-references refstr)))
+ (mapcar (lambda (x)
+ (setq res (or (gnus-registry-fetch-group x) res))
+ (when (or (gnus-registry-grep-in-list
+ res
+ gnus-registry-unfollowed-groups)
+ (gnus-registry-grep-in-list
+ res
+ nnmail-split-fancy-with-parent-ignore-groups))
+ (setq res nil)))
+ references)
+ (gnus-message
+ 5
+ "gnus-registry-split-fancy-with-parent traced %s to group %s"
+ refstr (if res res "nil"))
+ res)))
+
+(defun gnus-registry-register-message-ids ()
+ "Register the Message-ID of every article in the group"
+ (unless (and gnus-registry-unregistered-group-regex
+ (string-match gnus-registry-unregistered-group-regex gnus-newsgroup-name))
+ (dolist (article gnus-newsgroup-articles)
+ (let ((id (gnus-registry-fetch-message-id-fast article)))
+ (unless (gnus-registry-fetch-group id)
+ (gnus-message 9 "Registry: Registering article %d with group %s"
+ article gnus-newsgroup-name)
+ (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article)
+ gnus-newsgroup-name))))))
+
+(defun gnus-registry-fetch-message-id-fast (article)
+ "Fetch the Message-ID quickly, using the internal gnus-data-list function"
+ (if (and (numberp article)
+ (assoc article (gnus-data-list nil)))
+ (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
+ nil))
+
+(defun gnus-registry-grep-in-list (word list)
+ (when word
+ (memq nil
+ (mapcar 'not
+ (mapcar
+ (lambda (x)
+ (string-match x word))
+ list)))))
+
+(defun gnus-registry-fetch-group (id)
+ "Get the group of a message, based on the message ID.
+Returns the first place where the trail finds a spool action."
+ (when id
+ (let ((trail (gethash id gnus-registry-hashtb)))
+ (if trail
+ (car trail)
+ nil))))
+
+(defun gnus-registry-delete-group (id group)
+ "Get the group of a message, based on the message ID.
+Returns the first place where the trail finds a spool action."
+ (when group
+ (when id
+ (let ((trail (gethash id gnus-registry-hashtb))
+ (group (gnus-group-short-name group)))
+ (puthash id (if trail
+ (delete group trail)
+ nil)
+ gnus-registry-hashtb))
+ ;; now, clear the entry if it's empty
+ (unless (gethash id gnus-registry-hashtb)
+ (remhash id gnus-registry-hashtb)))))
+
+(defun gnus-registry-add-group (id group)
+ "Get the group of a message, based on the message ID.
+Returns the first place where the trail finds a spool action."
+ ;; make sure there are no duplicate entries
+ (when group
+ (when id
+ (let ((group (gnus-group-short-name group)))
+ (gnus-registry-delete-group id group)
+ (let ((trail (gethash id gnus-registry-hashtb)))
+ (puthash id (if trail
+ (cons group trail)
+ (list group))
+ gnus-registry-hashtb))))))
+
+(defun gnus-registry-clear ()
+ "Clear the Gnus registry."
+ (interactive)
+ (setq gnus-registry-alist nil
+ gnus-registry-headers-alist nil)
+ (gnus-registry-translate-from-alist))
+
+; also does copy, respool, and crosspost
+(add-hook 'gnus-summary-article-move-hook 'gnus-register-action)
+(add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
+(add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
+(add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
+
+(add-hook 'gnus-save-newsrc-hook 'gnus-registry-translate-to-alist)
+(add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-translate-from-alist)
+
+(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
+
+;; TODO: a lot of things
+
+(provide 'gnus-registry)
+
+;;; gnus-registry.el ends here
--- /dev/null
+;;; gnus-sieve.el --- Utilities to manage sieve scripts for Gnus
+;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
+
+;; Author: NAGY Andras <nagya@inf.elte.hu>,
+;; 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 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 t
+ "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 (regexp-quote gnus-sieve-region-start) nil t)
+ (delete-region (match-end 0)
+ (or (re-search-forward (regexp-quote
+ gnus-sieve-region-end) nil t)
+ (point)))
+ (insert sieve-template))
+ (insert gnus-sieve-region-start
+ (gnus-sieve-script gnus-sieve-select-method gnus-sieve-crosspost)
+ gnus-sieve-region-end))
+
+(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" ,(message-fetch-field "sender"))))
+
+;;;###autoload
+(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 nil, each conditional body contains a \"stop\" command
+which stops execution after a match is found.
+
+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"
+ "\tfileinto \"" (gnus-group-real-name group) "\";\n"
+ (if crosspost
+ ""
+ "\tstop;\n")
+ "}")
+ script)))))
+ (mapconcat 'identity script "\n")))
+
+(provide 'gnus-sieve)
+
+;;; gnus-sieve.el ends here
--- /dev/null
+;;; hex-util.el --- Functions to encode/decode hexadecimal string.
+
+;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: data
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; This program 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.
+
+;; This program 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 this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile
+ (defmacro hex-char-to-num (chr)
+ (` (let ((chr (, chr)))
+ (cond
+ ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
+ ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
+ ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
+ (t (error "Invalid hexadecimal digit `%c'" chr))))))
+ (defmacro num-to-hex-char (num)
+ (` (aref "0123456789abcdef" (, num)))))
+
+(defun decode-hex-string (string)
+ "Decode hexadecimal STRING to octet string."
+ (let* ((len (length string))
+ (dst (make-string (/ len 2) 0))
+ (idx 0)(pos 0))
+ (while (< pos len)
+;;; logior and lsh are not byte-coded.
+;;; (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4)
+;;; (hex-char-to-num (aref string (1+ pos)))))
+ (aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16)
+ (hex-char-to-num (aref string (1+ pos)))))
+ (setq idx (1+ idx)
+ pos (+ 2 pos)))
+ dst))
+
+(defun encode-hex-string (string)
+ "Encode octet STRING to hexadecimal string."
+ (let* ((len (length string))
+ (dst (make-string (* len 2) 0))
+ (idx 0)(pos 0))
+ (while (< pos len)
+;;; logand and lsh are not byte-coded.
+;;; (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15)))
+ (aset dst idx (num-to-hex-char (/ (aref string pos) 16)))
+ (setq idx (1+ idx))
+;;; (aset dst idx (num-to-hex-char (logand (aref string pos) 15)))
+ (aset dst idx (num-to-hex-char (% (aref string pos) 16)))
+ (setq idx (1+ idx)
+ pos (1+ pos)))
+ dst))
+
+(provide 'hex-util)
+
+;;; hex-util.el ends here
--- /dev/null
+;;; html2text.el --- a simple html to plain text converter
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Joakim Hove <hove@phys.ntnu.no>
+
+;; 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 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:
+
+;; These functions provide a simple way to wash/clean html infected
+;; mails. Definitely do not work in all cases, but some improvement
+;; in readability is generally obtained. Formatting is only done in
+;; the buffer, so the next time you enter the article it will be
+;; "re-htmlized".
+;;
+;; The main function is "html2text"
+
+;;; Code:
+
+;;
+;; <Global variables>
+;;
+
+(eval-when-compile
+ (require 'cl))
+
+(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr)))
+
+(defvar html2text-replace-list
+ '((" " . " ") (">" . ">") ("<" . "<") (""" . "\""))
+ "The map of entity to text.
+
+This is an alist were each element is a dotted pair consisting of an
+old string, and a replacement string. This replacement is done by the
+function \"html2text-substitute\" which basically performs a
+replace-string operation for every element in the list. This is
+completely verbatim - without any use of REGEXP.")
+
+(defvar html2text-remove-tag-list
+ '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta")
+ "A list of removable tags.
+
+This is a list of tags which should be removed, without any
+formatting. Observe that if you the tags in the list are presented
+*without* any \"<\" or \">\". All occurences of a tag appearing in
+this list are removed, irrespective of whether it is a closing or
+opening tag, or if the tag has additional attributes. The actual
+deletion is done by the function \"html2text-remove-tags\".
+
+For instance the text:
+
+\"Here comes something <font size\"+3\" face=\"Helvetica\"> big </font>.\"
+
+will be reduced to:
+
+\"Here comes something big.\"
+
+If this list contains the element \"font\".")
+
+(defvar html2text-format-tag-list
+ '(("b" . html2text-clean-bold)
+ ("u" . html2text-clean-underline)
+ ("i" . html2text-clean-italic)
+ ("blockquote" . html2text-clean-blockquote)
+ ("a" . html2text-clean-anchor)
+ ("ul" . html2text-clean-ul)
+ ("ol" . html2text-clean-ol)
+ ("dl" . html2text-clean-dl)
+ ("center" . html2text-clean-center))
+ "An alist of tags and processing functions.
+
+This is an alist where each dotted pair consists of a tag, and then
+the name of a function to be called when this tag is found. The
+function is called with the arguments p1, p2, p3 and p4. These are
+demontrated below:
+
+\"<b> This is bold text </b>\"
+ ^ ^ ^ ^
+ | | | |
+p1 p2 p3 p4
+
+Then the called function will typically format the text somewhat and
+remove the tags.")
+
+(defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta")
+ "Another list of removable tags.
+
+This is a list of tags which are removed similarly to the list
+`html2text-remove-tag-list' - but these tags are retained for the
+formatting, and then moved afterward.")
+
+;;
+;; </Global variables>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Utility functions>
+;;
+
+(defun html2text-buffer-head ()
+ (if (string= mode-name "Article")
+ (beginning-of-buffer)
+ (beginning-of-buffer)
+ )
+ )
+
+(defun html2text-replace-string (from-string to-string p1 p2)
+ (goto-char p1)
+ (let ((delta (- (string-width to-string) (string-width from-string)))
+ (change 0))
+ (while (search-forward from-string p2 t)
+ (replace-match to-string)
+ (setq change (+ change delta))
+ )
+ change
+ )
+ )
+
+;;
+;; </Utility functions>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Functions related to attributes> i.e. <font size=+3>
+;;
+
+(defun html2text-attr-value (attr-list attr)
+ (nth 1 (assoc attr attr-list))
+ )
+
+(defun html2text-get-attr (p1 p2 tag)
+ (goto-char p1)
+ (re-search-forward " +[^ ]" p2 t)
+ (let* ((attr-string (buffer-substring-no-properties (1- (point)) (1- p2)))
+ (tmp-list (split-string attr-string))
+ (attr-list)
+ (counter 0)
+ (prev (car tmp-list))
+ (this (nth 1 tmp-list))
+ (next (nth 2 tmp-list))
+ (index 1))
+
+ (cond
+ ;; size=3
+ ((string-match "[^ ]=[^ ]" prev)
+ (let ((attr (nth 0 (split-string prev "=")))
+ (value (nth 1 (split-string prev "="))))
+ (setq attr-list (cons (list attr value) attr-list))
+ )
+ )
+ ;; size= 3
+ ((string-match "[^ ]=\\'" prev)
+ (setq attr-list (cons (list (substring prev 0 -1) this) attr-list))
+ )
+ )
+
+ (while (< index (length tmp-list))
+ (cond
+ ;; size=3
+ ((string-match "[^ ]=[^ ]" this)
+ (let ((attr (nth 0 (split-string this "=")))
+ (value (nth 1 (split-string this "="))))
+ (setq attr-list (cons (list attr value) attr-list))
+ )
+ )
+ ;; size =3
+ ((string-match "\\`=[^ ]" this)
+ (setq attr-list (cons (list prev (substring this 1)) attr-list)))
+
+ ;; size= 3
+ ((string-match "[^ ]=\\'" this)
+ (setq attr-list (cons (list (substring this 0 -1) next) attr-list))
+ )
+
+ ;; size = 3
+ ((string= "=" this)
+ (setq attr-list (cons (list prev next) attr-list))
+ )
+ )
+ (setq index (1+ index))
+ (setq prev this)
+ (setq this next)
+ (setq next (nth (1+ index) tmp-list))
+ )
+
+ ;;
+ ;; Tags with no accompanying "=" i.e. value=nil
+ ;;
+ (setq prev (car tmp-list))
+ (setq this (nth 1 tmp-list))
+ (setq next (nth 2 tmp-list))
+ (setq index 1)
+
+ (if (not (string-match "=" prev))
+ (progn
+ (if (not (string= (substring this 0 1) "="))
+ (setq attr-list (cons (list prev nil) attr-list))
+ )
+ )
+ )
+
+ (while (< index (1- (length tmp-list)))
+ (if (not (string-match "=" this))
+ (if (not (or (string= (substring next 0 1) "=")
+ (string= (substring prev -1) "=")))
+ (setq attr-list (cons (list this nil) attr-list))
+ )
+ )
+ (setq index (1+ index))
+ (setq prev this)
+ (setq this next)
+ (setq next (nth (1+ index) tmp-list))
+ )
+
+ (if this
+ (progn
+ (if (not (string-match "=" this))
+ (progn
+ (if (not (string= (substring prev -1) "="))
+ (setq attr-list (cons (list this nil) attr-list))
+ )
+ )
+ )
+ )
+ )
+ attr-list ;; return - value
+ )
+ )
+
+;;
+;; </Functions related to attributes>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Functions to be called to format a tag-pair>
+;;
+(defun html2text-clean-list-items (p1 p2 list-type)
+ (goto-char p1)
+ (let ((item-nr 0)
+ (items 0))
+ (while (re-search-forward "<li>" p2 t)
+ (setq items (1+ items)))
+ (goto-char p1)
+ (while (< item-nr items)
+ (setq item-nr (1+ item-nr))
+ (re-search-forward "<li>" (point-max) t)
+ (cond
+ ((string= list-type "ul") (insert " o "))
+ ((string= list-type "ol") (insert (format " %s: " item-nr)))
+ (t (insert " x ")))
+ )
+ )
+ )
+
+(defun html2text-clean-dtdd (p1 p2)
+ (goto-char p1)
+ (let ((items 0)
+ (item-nr 0))
+ (while (re-search-forward "<dt>" p2 t)
+ (setq items (1+ items)))
+ (goto-char p1)
+ (while (< item-nr items)
+ (setq item-nr (1+ item-nr))
+ (re-search-forward "<dt>\\([ ]*\\)" (point-max) t)
+ (when (match-string 1)
+ (delete-region (point) (- (point) (string-width (match-string 1)))))
+ (let ((def-p1 (point))
+ (def-p2 0))
+ (re-search-forward "\\([ ]*\\)\\(</dt>\\|<dd>\\)" (point-max) t)
+ (if (match-string 1)
+ (progn
+ (let* ((mw1 (string-width (match-string 1)))
+ (mw2 (string-width (match-string 2)))
+ (mw (+ mw1 mw2)))
+ (goto-char (- (point) mw))
+ (delete-region (point) (+ (point) mw1))
+ (setq def-p2 (point))))
+ (setq def-p2 (- (point) (string-width (match-string 2)))))
+ (put-text-property def-p1 def-p2 'face 'bold)))))
+
+(defun html2text-delete-tags (p1 p2 p3 p4)
+ (delete-region p1 p2)
+ (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1))))
+
+(defun html2text-delete-single-tag (p1 p2)
+ (delete-region p1 p2))
+
+(defun html2text-clean-hr (p1 p2)
+ (html2text-delete-single-tag p1 p2)
+ (goto-char p1)
+ (newline 1)
+ (insert (make-string fill-column ?-))
+ )
+
+(defun html2text-clean-ul (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul")
+ )
+
+(defun html2text-clean-ol (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol")
+ )
+
+(defun html2text-clean-dl (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (html2text-clean-dtdd p1 (- p3 (- p1 p2)))
+ )
+
+(defun html2text-clean-center (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (center-region p1 (- p3 (- p2 p1)))
+ )
+
+(defun html2text-clean-bold (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'bold)
+ (html2text-delete-tags p1 p2 p3 p4)
+ )
+
+(defun html2text-clean-title (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'bold)
+ (html2text-delete-tags p1 p2 p3 p4)
+ )
+
+(defun html2text-clean-underline (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'underline)
+ (html2text-delete-tags p1 p2 p3 p4)
+ )
+
+(defun html2text-clean-italic (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'italic)
+ (html2text-delete-tags p1 p2 p3 p4)
+ )
+
+(defun html2text-clean-font (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ )
+
+(defun html2text-clean-blockquote (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ )
+
+(defun html2text-clean-anchor (p1 p2 p3 p4)
+ ;; If someone can explain how to make the URL clickable I will
+ ;; surely improve upon this.
+ (let* ((attr-list (html2text-get-attr p1 p2 "a"))
+ (href (html2text-attr-value attr-list "href")))
+ (delete-region p1 p4)
+ (when href
+ (goto-char p1)
+ (insert (substring href 1 -1 ))
+ (put-text-property p1 (point) 'face 'bold))))
+
+;;
+;; </Functions to be called to format a tag-pair>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Functions to be called to fix up paragraphs>
+;;
+
+(defun html2text-fix-paragraph (p1 p2)
+ (goto-char p1)
+ (let ((has-br-line)
+ (refill-start)
+ (refill-stop))
+ (if (re-search-forward "<br>$" p2 t)
+ (setq has-br-line t)
+ )
+ (if has-br-line
+ (progn
+ (goto-char p1)
+ (if (re-search-forward ".+[^<][^b][^r][^>]$" p2 t)
+ (progn
+ (beginning-of-line)
+ (setq refill-start (point))
+ (goto-char p2)
+ (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t)
+ (next-line 1)
+ (end-of-line)
+ ;; refill-stop should ideally be adjusted to
+ ;; accomodate the "<br>" strings which are removed
+ ;; between refill-start and refill-stop. Can simply
+ ;; be returned from my-replace-string
+ (setq refill-stop (+ (point)
+ (html2text-replace-string
+ "<br>" ""
+ refill-start (point))))
+ ;; (message "Point = %s refill-stop = %s" (point) refill-stop)
+ ;; (sleep-for 4)
+ (fill-region refill-start refill-stop)
+ )
+ )
+ )
+ )
+ )
+ (html2text-replace-string "<br>" "" p1 p2)
+ )
+
+;;
+;; This one is interactive ...
+;;
+(defun html2text-fix-paragraphs ()
+ "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook
+fashion, quite close to pure guess-work. It does work in some cases though."
+ (interactive)
+ (html2text-buffer-head)
+ (replace-regexp "^<br>$" "")
+ ;; Removing lonely <br> on a single line, if they are left intact we
+ ;; dont have any paragraphs at all.
+ (html2text-buffer-head)
+ (while (not (eobp))
+ (let ((p1 (point)))
+ (forward-paragraph 1)
+ ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5)
+ (html2text-fix-paragraph p1 (1- (point)))
+ (goto-char p1)
+ (when (not (eobp))
+ (forward-paragraph 1)))))
+
+;;
+;; </Functions to be called to fix up paragraphs>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Interactive functions>
+;;
+
+(defun html2text-remove-tags (tag-list)
+ "Removes the tags listed in the list \"html2text-remove-tag-list\".
+See the documentation for that variable."
+ (interactive)
+ (dolist (tag tag-list)
+ (html2text-buffer-head)
+ (while (re-search-forward (format "\\(</?%s[^>]*>\\)" tag) (point-max) t)
+ (let ((p1 (point)))
+ (search-backward "<")
+ (delete-region (point) p1)))))
+
+(defun html2text-format-tags ()
+ "See the variable \"html2text-format-tag-list\" for documentation"
+ (interactive)
+ (dolist (tag-and-function html2text-format-tag-list)
+ (let ((tag (car tag-and-function))
+ (function (cdr tag-and-function)))
+ (html2text-buffer-head)
+ (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
+ (point-max) t)
+ (let ((p1)
+ (p2 (point))
+ (p3) (p4)
+ (attr (match-string 1)))
+ (search-backward "<" (point-min) t)
+ (setq p1 (point))
+ (re-search-forward (format "</%s>" tag) (point-max) t)
+ (setq p4 (point))
+ (search-backward "</" (point-min) t)
+ (setq p3 (point))
+ (funcall function p1 p2 p3 p4)
+ (goto-char p1)
+ )
+ )
+ )
+ )
+ )
+
+(defun html2text-substitute ()
+ "See the variable \"html2text-replace-list\" for documentation"
+ (interactive)
+ (dolist (e html2text-replace-list)
+ (html2text-buffer-head)
+ (let ((old-string (car e))
+ (new-string (cdr e)))
+ (html2text-replace-string old-string new-string (point-min) (point-max))
+ )
+ )
+ )
+
+(defun html2text-format-single-elements ()
+ ""
+ (interactive)
+ (dolist (tag-and-function html2text-format-single-element-list)
+ (let ((tag (car tag-and-function))
+ (function (cdr tag-and-function)))
+ (html2text-buffer-head)
+ (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
+ (point-max) t)
+ (let ((p1)
+ (p2 (point)))
+ (search-backward "<" (point-min) t)
+ (setq p1 (point))
+ (funcall function p1 p2)
+ )
+ )
+ )
+ )
+ )
+
+;;
+;; Main function
+;;
+
+;;;###autoload
+(defun html2text ()
+ "Convert HTML to plain text in the current buffer."
+ (interactive)
+ (save-excursion
+ (let ((case-fold-search t)
+ (buffer-read-only))
+ (html2text-remove-tags html2text-remove-tag-list)
+ (html2text-format-tags)
+ (html2text-remove-tags html2text-remove-tag-list2)
+ (html2text-substitute)
+ (html2text-format-single-elements)
+ (html2text-fix-paragraphs))))
+
+;;
+;; </Interactive functions>
+;;
+
+;;; html2text.el ends here
--- /dev/null
+;;; mail-header.el --- Mail header parsing, merging, formatting
+
+;; Copyright (C) 1996 by Free Software Foundation, Inc.
+
+;; Author: Erik Naggum <erik@arcana.naggum.no>
+;; Keywords: tools, mail, news
+
+;; 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 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 package provides an abstraction to RFC822-style messages, used in
+;; mail news, and some other systems. The simple syntactic rules for such
+;; headers, such as quoting and line folding, are routinely reimplemented
+;; in many individual packages. This package removes the need for this
+;; redundancy by representing message headers as association lists,
+;; offering functions to extract the set of headers from a message, to
+;; parse individual headers, to merge sets of headers, and to format a set
+;; of headers.
+
+;; The car of each element in the message-header alist is a symbol whose
+;; print name is the name of the header, in all lower-case. The cdr of an
+;; element depends on the operation. After extracting headers from a
+;; message, it is a string, the value of the header. An extracted set of
+;; headers may be parsed further, which may turn it into a list, whose car
+;; is the original value and whose subsequent elements depend on the
+;; header. For formatting, it is evaluated to obtain the strings to be
+;; inserted. For merging, one set of headers consists of strings, while
+;; the other set will be evaluated with the symbols in the first set of
+;; headers bound to their respective values.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;; Make the byte-compiler shut up.
+(defvar headers)
+
+(defun mail-header-extract ()
+ "Extract headers from current buffer after point.
+Returns a header alist, where each element is a cons cell (name . value),
+where NAME is a symbol, and VALUE is the string value of the header having
+that name."
+ (let ((message-headers ()) (top (point))
+ start end)
+ (while (and (setq start (point))
+ (> (skip-chars-forward "^\0- :") 0)
+ (eq (char-after) ?:)
+ (setq end (point))
+ (progn (forward-char)
+ (> (skip-chars-forward " \t") 0)))
+ (let ((header (intern (downcase (buffer-substring start end))))
+ (value (list (buffer-substring
+ (point) (progn (end-of-line) (point))))))
+ (while (progn (forward-char) (> (skip-chars-forward " \t") 0))
+ (push (buffer-substring (point) (progn (end-of-line) (point)))
+ value))
+ (push (if (cdr value)
+ (cons header (mapconcat #'identity (nreverse value) " "))
+ (cons header (car value)))
+ message-headers)))
+ (goto-char top)
+ (nreverse message-headers)))
+
+(defun mail-header-extract-no-properties ()
+ "Extract headers from current buffer after point, without properties.
+Returns a header alist, where each element is a cons cell (name . value),
+where NAME is a symbol, and VALUE is the string value of the header having
+that name."
+ (mapcar
+ (lambda (elt)
+ (set-text-properties 0 (length (cdr elt)) nil (cdr elt))
+ elt)
+ (mail-header-extract)))
+
+(defun mail-header-parse (parsing-rules headers)
+ "Apply PARSING-RULES to HEADERS.
+PARSING-RULES is an alist whose keys are header names (symbols) and whose
+value is a parsing function. The function takes one argument, a string,
+and return a list of values, which will destructively replace the value
+associated with the key in HEADERS, after being prepended with the original
+value."
+ (dolist (rule parsing-rules)
+ (let ((header (assq (car rule) headers)))
+ (when header
+ (if (consp (cdr header))
+ (setf (cddr header) (funcall (cdr rule) (cadr header)))
+ (setf (cdr header)
+ (cons (cdr header) (funcall (cdr rule) (cdr header))))))))
+ headers)
+
+(defsubst mail-header (header &optional header-alist)
+ "Return the value associated with header HEADER in HEADER-ALIST.
+If the value is a string, it is the original value of the header. If the
+value is a list, its first element is the original value of the header,
+with any subsequent elements being the result of parsing the value.
+If HEADER-ALIST is nil, the dynamically bound variable `headers' is used."
+ (cdr (assq header (or header-alist headers))))
+
+(defun mail-header-set (header value &optional header-alist)
+ "Set the value associated with header HEADER to VALUE in HEADER-ALIST.
+HEADER-ALIST defaults to the dynamically bound variable `headers' if nil.
+See `mail-header' for the semantics of VALUE."
+ (let* ((alist (or header-alist headers))
+ (entry (assq header alist)))
+ (if entry
+ (setf (cdr entry) value)
+ (nconc alist (list (cons header value)))))
+ value)
+
+(defsetf mail-header (header &optional header-alist) (value)
+ `(mail-header-set ,header ,value ,header-alist))
+
+(defun mail-header-merge (merge-rules headers)
+ "Return a new header alist with MERGE-RULES applied to HEADERS.
+MERGE-RULES is an alist whose keys are header names (symbols) and whose
+values are forms to evaluate, the results of which are the new headers. It
+should be a string or a list of string. The first element may be nil to
+denote that the formatting functions must use the remaining elements, or
+skip the header altogether if there are no other elements.
+ The macro `mail-header' can be used to access headers in HEADERS."
+ (mapcar
+ (lambda (rule)
+ (cons (car rule) (eval (cdr rule))))
+ merge-rules))
+
+(defvar mail-header-format-function
+ (lambda (header value)
+ "Function to format headers without a specified formatting function."
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")))
+
+(defun mail-header-format (format-rules headers)
+ "Use FORMAT-RULES to format HEADERS and insert into current buffer.
+FORMAT-RULES is an alist whose keys are header names (symbols), and whose
+values are functions that format the header, the results of which are
+inserted, unless it is nil. The function takes two arguments, the header
+symbol, and the value of that header. If the function itself is nil, the
+default action is to insert the value of the header, unless it is nil.
+The headers are inserted in the order of the FORMAT-RULES.
+A key of t represents any otherwise unmentioned headers.
+A key of nil has as its value a list of defaulted headers to ignore."
+ (let ((ignore (append (cdr (assq nil format-rules))
+ (mapcar #'car format-rules))))
+ (dolist (rule format-rules)
+ (let* ((header (car rule))
+ (value (mail-header header)))
+ (cond ((null header) 'ignore)
+ ((eq header t)
+ (dolist (defaulted headers)
+ (unless (memq (car defaulted) ignore)
+ (let* ((header (car defaulted))
+ (value (cdr defaulted)))
+ (if (cdr rule)
+ (funcall (cdr rule) header value)
+ (funcall mail-header-format-function header value))))))
+ (value
+ (if (cdr rule)
+ (funcall (cdr rule) header value)
+ (funcall mail-header-format-function header value))))))
+ (insert "\n")))
+
+(provide 'mailheader)
+
+;;; mail-header.el ends here
--- /dev/null
+;;; mm-extern.el --- showing message/external-body
+;; Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc.
+
+;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Keywords: message external-body
+
+;; 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 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:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'mm-util)
+(require 'mm-decode)
+(require 'mm-url)
+
+(defvar mm-extern-function-alist
+ '((local-file . mm-extern-local-file)
+ (url . mm-extern-url)
+ (anon-ftp . mm-extern-anon-ftp)
+ (ftp . mm-extern-ftp)
+;;; (tftp . mm-extern-tftp)
+ (mail-server . mm-extern-mail-server)
+;;; (afs . mm-extern-afs))
+ ))
+
+(defvar mm-extern-anonymous "anonymous")
+
+(defun mm-extern-local-file (handle)
+ (erase-buffer)
+ (let ((name (cdr (assq 'name (cdr (mm-handle-type handle)))))
+ (coding-system-for-read mm-binary-coding-system))
+ (unless name
+ (error "The filename is not specified"))
+ (mm-disable-multibyte-mule4)
+ (if (file-exists-p name)
+ (mm-insert-file-contents name nil nil nil nil t)
+ (error (format "File %s is gone" name)))))
+
+(defun mm-extern-url (handle)
+ (erase-buffer)
+ (let ((url (cdr (assq 'url (cdr (mm-handle-type handle)))))
+ (name buffer-file-name)
+ (coding-system-for-read mm-binary-coding-system))
+ (unless url
+ (error "URL is not specified"))
+ (mm-with-unibyte-current-buffer-mule4
+ (mm-url-insert-file-contents url))
+ (mm-disable-multibyte-mule4)
+ (setq buffer-file-name name)))
+
+(defun mm-extern-anon-ftp (handle)
+ (erase-buffer)
+ (let* ((params (cdr (mm-handle-type handle)))
+ (name (cdr (assq 'name params)))
+ (site (cdr (assq 'site params)))
+ (directory (cdr (assq 'directory params)))
+ (mode (cdr (assq 'mode params)))
+ (path (concat "/" (or mm-extern-anonymous
+ (read-string (format "ID for %s: " site)))
+ "@" site ":" directory "/" name))
+ (coding-system-for-read mm-binary-coding-system))
+ (unless name
+ (error "The filename is not specified"))
+ (mm-disable-multibyte-mule4)
+ (mm-insert-file-contents path nil nil nil nil t)))
+
+(defun mm-extern-ftp (handle)
+ (let (mm-extern-anonymous)
+ (mm-extern-anon-ftp handle)))
+
+(defun mm-extern-mail-server (handle)
+ (require 'message)
+ (let* ((params (cdr (mm-handle-type handle)))
+ (server (cdr (assq 'server params)))
+ (subject (or (cdr (assq 'subject params)) "none"))
+ (buf (current-buffer))
+ info)
+ (if (y-or-n-p (format "Send a request message to %s?" server))
+ (save-window-excursion
+ (message-mail server subject)
+ (message-goto-body)
+ (delete-region (point) (point-max))
+ (insert-buffer-substring buf)
+ (message "Requesting external body...")
+ (message-send-and-exit)
+ (setq info "Request is sent.")
+ (message info))
+ (setq info "Request is not sent."))
+ (goto-char (point-min))
+ (insert "[" info "]\n\n")))
+
+;;;###autoload
+(defun mm-inline-external-body (handle &optional no-display)
+ "Show the external-body part of HANDLE.
+This function replaces the buffer of HANDLE with a buffer contains
+the entire message.
+If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
+ (let* ((access-type (cdr (assq 'access-type
+ (cdr (mm-handle-type handle)))))
+ (func (cdr (assq (intern
+ (downcase
+ (or access-type
+ (error "Couldn't find access type"))))
+ mm-extern-function-alist)))
+ gnus-displaying-mime buf
+ handles)
+ (unless (mm-handle-cache handle)
+ (unless func
+ (error (format "Access type (%s) is not supported" access-type)))
+ (with-temp-buffer
+ (mm-insert-part handle)
+ (goto-char (point-max))
+ (insert "\n\n")
+ (setq handles (mm-dissect-buffer t)))
+ (unless (bufferp (car handles))
+ (mm-destroy-parts handles)
+ (error "Multipart external body is not supported"))
+ (save-excursion ;; single part
+ (set-buffer (setq buf (mm-handle-buffer handles)))
+ (let (good)
+ (unwind-protect
+ (progn
+ (funcall func handle)
+ (setq good t))
+ (unless good
+ (mm-destroy-parts handles))))
+ (mm-handle-set-cache handle handles))
+ (setq gnus-article-mime-handles
+ (mm-merge-handles gnus-article-mime-handles handles)))
+ (unless no-display
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (gnus-display-mime (mm-handle-cache handle))
+ (mm-handle-set-undisplayer
+ handle
+ `(lambda ()
+ (let (buffer-read-only)
+ (condition-case nil
+ ;; This is only valid on XEmacs.
+ (mapcar (lambda (prop)
+ (remove-specifier
+ (face-property 'default prop) (current-buffer)))
+ '(background background-pixmap foreground))
+ (error nil))
+ (delete-region ,(point-min-marker) ,(point-max-marker))))))))))
+
+(provide 'mm-extern)
+
+;;; mm-extern.el ends here
--- /dev/null
+;;; mm-url.el --- a wrapper of url functions/commands for Gnus
+;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
+
+;; 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 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:
+
+;; Some codes are stolen from w3 and url packages. Some are moved from
+;; nnweb.
+
+;; TODO: Support POST, cookie.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'mm-util)
+(require 'gnus)
+
+(eval-and-compile
+ (autoload 'exec-installed-p "path-util"))
+
+(eval-when-compile
+ (require 'timer))
+
+(defgroup mm-url nil
+ "A wrapper of url package and external url command for Gnus."
+ :group 'gnus)
+
+(defcustom mm-url-use-external (not
+ (condition-case nil
+ (require 'url)
+ (error nil)))
+ "*If non-nil, use external grab program `mm-url-program'."
+ :type 'boolean
+ :group 'mm-url)
+
+(defvar mm-url-predefined-programs
+ '((wget "wget" "-q" "-O" "-")
+ (w3m "w3m" "-dump_source")
+ (lynx "lynx" "-source")
+ (curl "curl")))
+
+(defcustom mm-url-program
+ (cond
+ ((exec-installed-p "wget") 'wget)
+ ((exec-installed-p "w3m") 'w3m)
+ ((exec-installed-p "lynx") 'lynx)
+ ((exec-installed-p "curl") 'curl)
+ (t "GET"))
+ "The url grab program.
+Likely values are `wget', `w3m', `lynx' and `curl'."
+ :type '(choice
+ (symbol :tag "wget" wget)
+ (symbol :tag "w3m" w3m)
+ (symbol :tag "lynx" lynx)
+ (symbol :tag "curl" curl)
+ (string :tag "other"))
+ :group 'mm-url)
+
+(defcustom mm-url-arguments nil
+ "The arguments for `mm-url-program'."
+ :type '(repeat string)
+ :group 'mm-url)
+
+\f
+;;; Internal variables
+
+(defvar mm-url-package-name
+ (gnus-replace-in-string
+ (gnus-replace-in-string gnus-version " v.*$" "")
+ " " "-"))
+
+(defvar mm-url-package-version gnus-version-number)
+
+;; Stolen from w3.
+(defvar mm-url-html-entities
+ '(
+ ;;(excl . 33)
+ (quot . 34)
+ ;;(num . 35)
+ ;;(dollar . 36)
+ ;;(percent . 37)
+ (amp . 38)
+ (rsquo . 39) ; should be U+8217
+ ;;(apos . 39)
+ ;;(lpar . 40)
+ ;;(rpar . 41)
+ ;;(ast . 42)
+ ;;(plus . 43)
+ ;;(comma . 44)
+ ;;(period . 46)
+ ;;(colon . 58)
+ ;;(semi . 59)
+ (lt . 60)
+ ;;(equals . 61)
+ (gt . 62)
+ ;;(quest . 63)
+ ;;(commat . 64)
+ ;;(lsqb . 91)
+ ;;(rsqb . 93)
+ (uarr . 94) ; should be U+8593
+ ;;(lowbar . 95)
+ (lsquo . 96) ; should be U+8216
+ (lcub . 123)
+ ;;(verbar . 124)
+ (rcub . 125)
+ (tilde . 126)
+ (nbsp . 160)
+ (iexcl . 161)
+ (cent . 162)
+ (pound . 163)
+ (curren . 164)
+ (yen . 165)
+ (brvbar . 166)
+ (sect . 167)
+ (uml . 168)
+ (copy . 169)
+ (ordf . 170)
+ (laquo . 171)
+ (not . 172)
+ (shy . 173)
+ (reg . 174)
+ (macr . 175)
+ (deg . 176)
+ (plusmn . 177)
+ (sup2 . 178)
+ (sup3 . 179)
+ (acute . 180)
+ (micro . 181)
+ (para . 182)
+ (middot . 183)
+ (cedil . 184)
+ (sup1 . 185)
+ (ordm . 186)
+ (raquo . 187)
+ (frac14 . 188)
+ (frac12 . 189)
+ (frac34 . 190)
+ (iquest . 191)
+ (Agrave . 192)
+ (Aacute . 193)
+ (Acirc . 194)
+ (Atilde . 195)
+ (Auml . 196)
+ (Aring . 197)
+ (AElig . 198)
+ (Ccedil . 199)
+ (Egrave . 200)
+ (Eacute . 201)
+ (Ecirc . 202)
+ (Euml . 203)
+ (Igrave . 204)
+ (Iacute . 205)
+ (Icirc . 206)
+ (Iuml . 207)
+ (ETH . 208)
+ (Ntilde . 209)
+ (Ograve . 210)
+ (Oacute . 211)
+ (Ocirc . 212)
+ (Otilde . 213)
+ (Ouml . 214)
+ (times . 215)
+ (Oslash . 216)
+ (Ugrave . 217)
+ (Uacute . 218)
+ (Ucirc . 219)
+ (Uuml . 220)
+ (Yacute . 221)
+ (THORN . 222)
+ (szlig . 223)
+ (agrave . 224)
+ (aacute . 225)
+ (acirc . 226)
+ (atilde . 227)
+ (auml . 228)
+ (aring . 229)
+ (aelig . 230)
+ (ccedil . 231)
+ (egrave . 232)
+ (eacute . 233)
+ (ecirc . 234)
+ (euml . 235)
+ (igrave . 236)
+ (iacute . 237)
+ (icirc . 238)
+ (iuml . 239)
+ (eth . 240)
+ (ntilde . 241)
+ (ograve . 242)
+ (oacute . 243)
+ (ocirc . 244)
+ (otilde . 245)
+ (ouml . 246)
+ (divide . 247)
+ (oslash . 248)
+ (ugrave . 249)
+ (uacute . 250)
+ (ucirc . 251)
+ (uuml . 252)
+ (yacute . 253)
+ (thorn . 254)
+ (yuml . 255)
+
+ ;; Special handling of these
+ (frac56 . "5/6")
+ (frac16 . "1/6")
+ (frac45 . "4/5")
+ (frac35 . "3/5")
+ (frac25 . "2/5")
+ (frac15 . "1/5")
+ (frac23 . "2/3")
+ (frac13 . "1/3")
+ (frac78 . "7/8")
+ (frac58 . "5/8")
+ (frac38 . "3/8")
+ (frac18 . "1/8")
+
+ ;; The following 5 entities are not mentioned in the HTML 2.0
+ ;; standard, nor in any other HTML proposed standard of which I
+ ;; am aware. I am not even sure they are ISO entity names. ***
+ ;; Hence, some arrangement should be made to give a bad HTML
+ ;; message when they are seen.
+ (ndash . 45)
+ (mdash . 45)
+ (emsp . 32)
+ (ensp . 32)
+ (sim . 126)
+ (le . "<=")
+ (agr . "alpha")
+ (rdquo . "''")
+ (ldquo . "``")
+ (trade . "(TM)")
+ ;; To be done
+ ;; (shy . ????) ; soft hyphen
+ )
+ "*An assoc list of entity names and how to actually display them.")
+
+(defconst mm-url-unreserved-chars
+ '(
+ ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
+ ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
+ ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+ ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
+ "A list of characters that are _NOT_ reserved in the URL spec.
+This is taken from RFC 2396.")
+
+(defun mm-url-load-url ()
+ "Load `url-insert-file-contents'."
+ (unless (condition-case ()
+ (require 'url-handlers)
+ (error nil))
+ ;; w3-4.0pre0.46 or earlier version.
+ (require 'w3-vars)
+ (require 'url)))
+
+(defun mm-url-insert-file-contents (url)
+ (if mm-url-use-external
+ (progn
+ (if (string-match "^file:/+" url)
+ (insert-file-contents (substring url (1- (match-end 0))))
+ (mm-url-insert-file-contents-external url))
+ (goto-char (point-min))
+ (if (fboundp 'url-generic-parse-url)
+ (setq url-current-object
+ (url-generic-parse-url url)))
+ (list url (buffer-size)))
+ (mm-url-load-url)
+ (let ((name buffer-file-name)
+ (url-request-extra-headers (list (cons "Connection" "Close")))
+ (url-package-name (or mm-url-package-name
+ url-package-name))
+ (url-package-version (or mm-url-package-version
+ url-package-version))
+ result)
+ (setq result (url-insert-file-contents url))
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "\r 1000\r ?" nil t)
+ (replace-match "")))
+ (setq buffer-file-name name)
+ (if (and (fboundp 'url-generic-parse-url)
+ (listp result))
+ (setq url-current-object (url-generic-parse-url
+ (car result))))
+ result)))
+
+(defun mm-url-insert-file-contents-external (url)
+ (let (program args)
+ (if (symbolp mm-url-program)
+ (let ((item (cdr (assq mm-url-program mm-url-predefined-programs))))
+ (setq program (car item)
+ args (append (cdr item) (list url))))
+ (setq program mm-url-program
+ args (append mm-url-arguments (list url))))
+ (apply 'call-process program nil t nil args)))
+
+(defvar mm-url-timeout 30
+ "The number of seconds before timing out an URL fetch.")
+
+(defvar mm-url-retries 10
+ "The number of retries after timing out when fetching an URL.")
+
+(defun mm-url-insert (url &optional follow-refresh)
+ "Insert the contents from an URL in the current buffer.
+If FOLLOW-REFRESH is non-nil, redirect refresh url in META."
+ (let ((times mm-url-retries)
+ (done nil)
+ (first t)
+ result)
+ (while (and (not (zerop (decf times)))
+ (not done))
+ (with-timeout (mm-url-timeout)
+ (unless first
+ (message "Trying again (%s)..." (- mm-url-retries times)))
+ (setq first nil)
+ (if follow-refresh
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mm-url-insert-file-contents url)
+ (goto-char (point-min))
+ (when (re-search-forward
+ "<meta[ \t\r\n]*http-equiv=\"Refresh\"[^>]*URL=\\([^\"]+\\)\"" nil t)
+ (let ((url (match-string 1)))
+ (delete-region (point-min) (point-max))
+ (setq result (mm-url-insert url t)))))
+ (setq result (mm-url-insert-file-contents url)))
+ (setq done t)))
+ result))
+
+(defun mm-url-decode-entities ()
+ "Decode all HTML entities."
+ (goto-char (point-min))
+ (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+\\);" nil t)
+ (let ((elem (if (eq (aref (match-string 1) 0) ?\#)
+ (let ((c
+ (string-to-number (substring
+ (match-string 1) 1))))
+ (if (mm-char-or-char-int-p c) c 32))
+ (or (cdr (assq (intern (match-string 1))
+ mm-url-html-entities))
+ ?#))))
+ (unless (stringp elem)
+ (setq elem (char-to-string elem)))
+ (replace-match elem t t))))
+
+(defun mm-url-decode-entities-nbsp ()
+ "Decode all HTML entities and to a space."
+ (let ((mm-url-html-entities (cons '(nbsp . 32) mm-url-html-entities)))
+ (mm-url-decode-entities)))
+
+(defun mm-url-decode-entities-string (string)
+ (with-temp-buffer
+ (insert string)
+ (mm-url-decode-entities)
+ (buffer-string)))
+
+(defun mm-url-form-encode-xwfu (chunk)
+ "Escape characters in a string for application/x-www-form-urlencoded.
+Blasphemous crap because someone didn't think %20 was good enough for encoding
+spaces. Die Die Die."
+ ;; This will get rid of the 'attributes' specified by the file type,
+ ;; which are useless for an application/x-www-form-urlencoded form.
+ (if (consp chunk)
+ (setq chunk (cdr chunk)))
+
+ (mapconcat
+ (lambda (char)
+ (cond
+ ((= char ? ) "+")
+ ((memq char mm-url-unreserved-chars) (char-to-string char))
+ (t (upcase (format "%%%02x" char)))))
+ ;; Fixme: Should this actually be accepting multibyte? Is there a
+ ;; better way in XEmacs?
+ (if (featurep 'mule)
+ (encode-coding-string chunk
+ (if (fboundp 'find-coding-systems-string)
+ (car (find-coding-systems-string chunk))
+ (static-if (boundp 'MULE)
+ file-coding-system
+ buffer-file-coding-system)))
+ chunk)
+ ""))
+
+(defun mm-url-encode-www-form-urlencoded (pairs)
+ "Return PAIRS encoded for forms."
+ (mapconcat
+ (lambda (data)
+ (concat (mm-url-form-encode-xwfu (car data)) "="
+ (mm-url-form-encode-xwfu (cdr data))))
+ pairs "&"))
+
+(defun mm-url-fetch-form (url pairs)
+ "Fetch a form from URL with PAIRS as the data using the POST method."
+ (mm-url-load-url)
+ (let ((url-request-data (mm-url-encode-www-form-urlencoded pairs))
+ (url-request-method "POST")
+ (url-request-extra-headers
+ '(("Content-type" . "application/x-www-form-urlencoded"))))
+ (url-insert-file-contents url)
+ (setq buffer-file-name nil))
+ t)
+
+(defun mm-url-fetch-simple (url content)
+ (mm-url-load-url)
+ (let ((url-request-data content)
+ (url-request-method "POST")
+ (url-request-extra-headers
+ '(("Content-type" . "application/x-www-form-urlencoded"))))
+ (url-insert-file-contents url)
+ (setq buffer-file-name nil))
+ t)
+
+(defun mm-url-remove-markup ()
+ "Remove all HTML markup, leaving just plain text."
+ (goto-char (point-min))
+ (while (search-forward "<!--" nil t)
+ (delete-region (match-beginning 0)
+ (or (search-forward "-->" nil t)
+ (point-max))))
+ (goto-char (point-min))
+ (while (re-search-forward "<[^>]+>" nil t)
+ (replace-match "" t t)))
+
+(provide 'mm-url)
+
+;;; mm-url.el ends here
--- /dev/null
+;;; mml-sec.el --- A package with security functions for MML documents
+;; Copyright (C) 2000, 2001, 2002, 2003 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 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:
+
+;;; Code:
+
+(require 'mml-smime)
+(eval-when-compile (require 'cl))
+(autoload 'mml2015-sign "mml2015")
+(autoload 'mml2015-encrypt "mml2015")
+(autoload 'mml1991-sign "mml1991")
+(autoload 'mml1991-encrypt "mml1991")
+(autoload 'message-goto-body "message")
+(autoload 'mml-insert-tag "mml")
+
+(defvar mml-sign-alist
+ '(("smime" mml-smime-sign-buffer mml-smime-sign-query)
+ ("pgp" mml-pgp-sign-buffer list)
+ ("pgpauto" mml-pgpauto-sign-buffer list)
+ ("pgpmime" mml-pgpmime-sign-buffer list))
+ "Alist of MIME signer functions.")
+
+(defvar mml-default-sign-method (caar mml-sign-alist)
+ "Default sign method.")
+
+(defvar mml-encrypt-alist
+ '(("smime" mml-smime-encrypt-buffer mml-smime-encrypt-query)
+ ("pgp" mml-pgp-encrypt-buffer list)
+ ("pgpauto" mml-pgpauto-sign-buffer list)
+ ("pgpmime" mml-pgpmime-encrypt-buffer list))
+ "Alist of MIME encryption functions.")
+
+(defvar mml-default-encrypt-method (caar mml-encrypt-alist)
+ "Default encryption method.")
+
+(defcustom mml-signencrypt-style-alist
+ '(("smime" separate)
+ ("pgp" separate)
+ ("pgpauto" separate)
+ ("pgpmime" separate))
+ "Alist specifying if `signencrypt' results in two separate operations or not.
+The first entry indicates the MML security type, valid entries include
+the strings \"smime\", \"pgp\", and \"pgpmime\". The second entry is
+a symbol `separate' or `combined' where `separate' means that MML signs
+and encrypt messages in a two step process, and `combined' means that MML
+signs and encrypt the message in one step.
+Note that the `combined' mode is NOT supported by all OpenPGP implementations,
+in particular PGP version 2 does not support it!"
+ :type '(repeat (list (choice (const :tag "S/MIME" "smime")
+ (const :tag "PGP" "pgp")
+ (const :tag "PGP/MIME" "pgpmime")
+ (string :tag "User defined"))
+ (choice (const :tag "Separate" separate)
+ (const :tag "Combined" combined)))))
+
+;;; Configuration/helper functions
+
+(defun mml-signencrypt-style (method &optional style)
+ "Function for setting/getting the signencrypt-style used. Takes two
+arguments, the method (e.g. \"pgp\") and optionally the mode
+\(e.g. combined). If the mode is omitted, the current value is returned.
+
+For example, if you prefer to use combined sign & encrypt with
+smime, putting the following in your Gnus startup file will
+enable that behavior:
+
+\(mml-set-signencrypt-style \"smime\" combined)
+
+You can also customize or set `mml-signencrypt-style-alist' instead."
+ (let ((style-item (assoc method mml-signencrypt-style-alist)))
+ (if style-item
+ (if (or (eq style 'separate)
+ (eq style 'combined))
+ ;; valid style setting?
+ (setf (second style-item) style)
+ ;; otherwise, just return the current value
+ (second style-item))
+ (gnus-message 3 "Warning, attempt to set invalid signencrypt-style"))))
+
+;;; Security functions
+
+(defun mml-smime-sign-buffer (cont)
+ (or (mml-smime-sign cont)
+ (error "Signing failed... inspect message logs for errors")))
+
+(defun mml-smime-encrypt-buffer (cont &optional sign)
+ (when sign
+ (message "Combined sign and encrypt S/MIME not support yet")
+ (sit-for 1))
+ (or (mml-smime-encrypt cont)
+ (error "Encryption failed... inspect message logs for errors")))
+
+(defun mml-pgp-sign-buffer (cont)
+ (or (mml1991-sign cont)
+ (error "Signing failed... inspect message logs for errors")))
+
+(defun mml-pgp-encrypt-buffer (cont &optional sign)
+ (or (mml1991-encrypt cont sign)
+ (error "Encryption failed... inspect message logs for errors")))
+
+(defun mml-pgpmime-sign-buffer (cont)
+ (or (mml2015-sign cont)
+ (error "Signing failed... inspect message logs for errors")))
+
+(defun mml-pgpmime-encrypt-buffer (cont &optional sign)
+ (or (mml2015-encrypt cont sign)
+ (error "Encryption failed... inspect message logs for errors")))
+
+(defun mml-pgpauto-sign-buffer (cont)
+ (message-goto-body)
+ (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
+ (mml2015-sign cont)
+ (mml1991-sign cont))
+ (error "Encryption failed... inspect message logs for errors")))
+
+(defun mml-pgpauto-encrypt-buffer (cont &optional sign)
+ (message-goto-body)
+ (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
+ (mml2015-encrypt cont sign)
+ (mml1991-encrypt cont sign))
+ (error "Encryption failed... inspect message logs for errors")))
+
+(defun mml-secure-part (method &optional sign)
+ (save-excursion
+ (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
+ mml-encrypt-alist))))))
+ (cond ((re-search-backward
+ "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
+ (goto-char (match-end 0))
+ (insert (if sign " sign=" " encrypt=") method)
+ (while tags
+ (let ((key (pop tags))
+ (value (pop tags)))
+ (when value
+ ;; Quote VALUE if it contains suspicious characters.
+ (when (string-match "[\"'\\~/*;() \t\n]" value)
+ (setq value (prin1-to-string value)))
+ (insert (format " %s=%s" key value))))))
+ ((or (re-search-backward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
+ (goto-char (match-end 0))
+ (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
+ (cons method tags))))
+ (t (error "The message is corrupted. No mail header separator"))))))
+
+(defun mml-secure-sign-pgp ()
+ "Add MML tags to PGP sign this MML part."
+ (interactive)
+ (mml-secure-part "pgp" 'sign))
+
+(defun mml-secure-sign-pgpauto ()
+ "Add MML tags to PGP-auto sign this MML part."
+ (interactive)
+ (mml-secure-part "pgpauto" 'sign))
+
+(defun mml-secure-sign-pgpmime ()
+ "Add MML tags to PGP/MIME sign this MML part."
+ (interactive)
+ (mml-secure-part "pgpmime" 'sign))
+
+(defun mml-secure-sign-smime ()
+ "Add MML tags to S/MIME sign this MML part."
+ (interactive)
+ (mml-secure-part "smime" 'sign))
+
+(defun mml-secure-encrypt-pgp ()
+ "Add MML tags to PGP encrypt this MML part."
+ (interactive)
+ (mml-secure-part "pgp"))
+
+(defun mml-secure-encrypt-pgpmime ()
+ "Add MML tags to PGP/MIME encrypt this MML part."
+ (interactive)
+ (mml-secure-part "pgpmime"))
+
+(defun mml-secure-encrypt-smime ()
+ "Add MML tags to S/MIME encrypt this MML part."
+ (interactive)
+ (mml-secure-part "smime"))
+
+;; defuns that add the proper <#secure ...> tag to the top of the message body
+(defun mml-secure-message (method &optional modesym)
+ (let ((mode (prin1-to-string modesym))
+ insert-loc)
+ (mml-unsecure-message)
+ (save-excursion
+ (goto-char (point-min))
+ (cond ((re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (goto-char (setq insert-loc (match-end 0)))
+ (unless (looking-at "<#secure")
+ (mml-insert-tag
+ 'secure 'method method 'mode mode)))
+ (t (error
+ "The message is corrupted. No mail header separator"))))
+ (when (eql insert-loc (point))
+ (forward-line 1))))
+
+(defun mml-unsecure-message ()
+ "Remove security related MML tags from message."
+ (interactive)
+ (save-excursion
+ (goto-char (point-max))
+ (when (re-search-backward "^<#secure.*>\n" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))))
+
+(defun mml-secure-message-sign-smime ()
+ "Add MML tag to encrypt/sign the entire message."
+ (interactive)
+ (mml-secure-message "smime" 'sign))
+
+(defun mml-secure-message-sign-pgp ()
+ "Add MML tag to encrypt/sign the entire message."
+ (interactive)
+ (mml-secure-message "pgp" 'sign))
+
+(defun mml-secure-message-sign-pgpmime ()
+ "Add MML tag to encrypt/sign the entire message."
+ (interactive)
+ (mml-secure-message "pgpmime" 'sign))
+
+(defun mml-secure-message-sign-pgpauto ()
+ "Add MML tag to encrypt/sign the entire message."
+ (interactive)
+ (mml-secure-message "pgpauto" 'sign))
+
+(defun mml-secure-message-encrypt-smime (&optional dontsign)
+ "Add MML tag to encrypt and sign the entire message.
+If called with a prefix argument, only encrypt (do NOT sign)."
+ (interactive "P")
+ (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt)))
+
+(defun mml-secure-message-encrypt-pgp (&optional dontsign)
+ "Add MML tag to encrypt and sign the entire message.
+If called with a prefix argument, only encrypt (do NOT sign)."
+ (interactive "P")
+ (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt)))
+
+(defun mml-secure-message-encrypt-pgpmime (&optional dontsign)
+ "Add MML tag to encrypt and sign the entire message.
+If called with a prefix argument, only encrypt (do NOT sign)."
+ (interactive "P")
+ (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt)))
+
+(defun mml-secure-message-encrypt-pgpauto (&optional dontsign)
+ "Add MML tag to encrypt and sign the entire message.
+If called with a prefix argument, only encrypt (do NOT sign)."
+ (interactive "P")
+ (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt)))
+
+(provide 'mml-sec)
+
+;;; mml-sec.el ends here
--- /dev/null
+;;; mml-smime.el --- S/MIME support for MML
+;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Keywords: Gnus, MIME, S/MIME, MML
+
+;; 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 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:
+
+;;; Code:
+
+(require 'smime)
+(require 'mm-decode)
+
+(defun mml-smime-sign (cont)
+ (when (null smime-keys)
+ (customize-variable 'smime-keys)
+ (error "No S/MIME keys configured, use customize to add your key"))
+ (smime-sign-buffer (cdr (assq 'keyfile cont)))
+ (goto-char (point-max)))
+
+(defun mml-smime-encrypt (cont)
+ (let (certnames certfiles tmp file tmpfiles)
+ ;; xxx tmp files are always an security issue
+ (while (setq tmp (pop cont))
+ (if (and (consp tmp) (eq (car tmp) 'certfile))
+ (push (cdr tmp) certnames)))
+ (while (setq tmp (pop certnames))
+ (if (not (and (not (file-exists-p tmp))
+ (get-buffer tmp)))
+ (push tmp certfiles)
+ (setq file (mm-make-temp-file (expand-file-name "mml."
+ mm-tmp-directory)))
+ (with-current-buffer tmp
+ (write-region (point-min) (point-max) file))
+ (push file certfiles)
+ (push file tmpfiles)))
+ (if (smime-encrypt-buffer certfiles)
+ (progn
+ (while (setq tmp (pop tmpfiles))
+ (delete-file tmp))
+ t)
+ (while (setq tmp (pop tmpfiles))
+ (delete-file tmp))
+ nil))
+ (goto-char (point-max)))
+
+(defun mml-smime-sign-query ()
+ ;; query information (what certificate) from user when MML tag is
+ ;; added, for use later by the signing process
+ (when (null smime-keys)
+ (customize-variable 'smime-keys)
+ (error "No S/MIME keys configured, use customize to add your key"))
+ (list 'keyfile
+ (if (= (length smime-keys) 1)
+ (cadar smime-keys)
+ (or (let ((from (cadr (funcall gnus-extract-address-components
+ (or (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "from")))
+ "")))))
+ (and from (smime-get-key-by-email from)))
+ (smime-get-key-by-email
+ (completing-read "Sign this part with what signature? "
+ smime-keys nil nil
+ (and (listp (car-safe smime-keys))
+ (caar smime-keys))))))))
+
+(defun mml-smime-get-file-cert ()
+ (ignore-errors
+ (list 'certfile (read-file-name
+ "File with recipient's S/MIME certificate: "
+ smime-certificate-directory nil t ""))))
+
+(defun mml-smime-get-dns-cert ()
+ ;; todo: deal with comma separated multiple recipients
+ (let (result who bad cert)
+ (condition-case ()
+ (while (not result)
+ (setq who (read-from-minibuffer
+ (format "%sLookup certificate for: " (or bad ""))
+ (cadr (funcall gnus-extract-address-components
+ (or (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "to")))
+ "")))))
+ (if (setq cert (smime-cert-by-dns who))
+ (setq result (list 'certfile (buffer-name cert)))
+ (setq bad (format "`%s' not found. " who))))
+ (quit))
+ result))
+
+(defun mml-smime-encrypt-query ()
+ ;; todo: add ldap support (xemacs ldap api?)
+ ;; todo: try dns/ldap automatically first, before prompting user
+ (let (certs done)
+ (while (not done)
+ (ecase (read (gnus-completing-read-with-default
+ "dns" "Fetch certificate from"
+ '(("dns") ("file")) nil t))
+ (dns (setq certs (append certs
+ (mml-smime-get-dns-cert))))
+ (file (setq certs (append certs
+ (mml-smime-get-file-cert)))))
+ (setq done (not (y-or-n-p "Add more recipients? "))))
+ certs))
+
+(defun mml-smime-verify (handle ctl)
+ (with-temp-buffer
+ (insert-buffer-substring (mm-handle-multipart-original-buffer ctl))
+ (goto-char (point-min))
+ (insert (format "Content-Type: %s; " (mm-handle-media-type ctl)))
+ (insert (format "protocol=\"%s\"; "
+ (mm-handle-multipart-ctl-parameter ctl 'protocol)))
+ (insert (format "micalg=\"%s\"; "
+ (mm-handle-multipart-ctl-parameter ctl 'micalg)))
+ (insert (format "boundary=\"%s\"\n\n"
+ (mm-handle-multipart-ctl-parameter ctl 'boundary)))
+ (when (get-buffer smime-details-buffer)
+ (kill-buffer smime-details-buffer))
+ (let ((buf (current-buffer))
+ (good-signature (smime-noverify-buffer))
+ (good-certificate (and (or smime-CA-file smime-CA-directory)
+ (smime-verify-buffer)))
+ addresses openssl-output)
+ (setq openssl-output (with-current-buffer smime-details-buffer
+ (buffer-string)))
+ (if (not good-signature)
+ (progn
+ ;; we couldn't verify message, fail with openssl output as message
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (concat "OpenSSL failed to verify message integrity:\n"
+ "-------------------------------------------\n"
+ openssl-output)))
+ ;; verify mail addresses in mail against those in certificate
+ (when (and (smime-pkcs7-region (point-min) (point-max))
+ (smime-pkcs7-certificates-region (point-min) (point-max)))
+ (with-temp-buffer
+ (insert-buffer-substring buf)
+ (goto-char (point-min))
+ (while (re-search-forward "-----END CERTIFICATE-----" nil t)
+ (when (smime-pkcs7-email-region (point-min) (point))
+ (setq addresses (append (smime-buffer-as-string-region
+ (point-min) (point)) addresses)))
+ (delete-region (point-min) (point)))
+ (setq addresses (mapcar 'downcase addresses))))
+ (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Sender address forged")
+ (if good-certificate
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Ok (sender authenticated)")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Ok (sender not trusted)")))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n"
+ (if addresses
+ (concat "Addresses in certificate: "
+ (mapconcat 'identity addresses ", "))
+ "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)")
+ "\n" "\n"
+ "OpenSSL output:\n"
+ "---------------\n" openssl-output "\n"
+ "Certificate(s) inside S/MIME signature:\n"
+ "---------------------------------------\n"
+ (buffer-string) "\n")))))
+ handle)
+
+(defun mml-smime-verify-test (handle ctl)
+ smime-openssl-program)
+
+(provide 'mml-smime)
+
+;;; mml-smime.el ends here
--- /dev/null
+;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
+;; Copyright (C) 1998, 1999, 2000, 2001, 2003 Free Software Foundation, Inc.
+
+;; Author: Sascha Ldecke <sascha@meta-x.de>,
+;; Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
+;; Keywords PGP
+
+;; 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 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:
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl)
+ (require 'mm-util))
+
+(autoload 'quoted-printable-decode-region "qp")
+(autoload 'quoted-printable-encode-region "qp")
+
+(defvar mml1991-use mml2015-use
+ "The package used for PGP.")
+
+(defvar mml1991-function-alist
+ '((mailcrypt mml1991-mailcrypt-sign
+ mml1991-mailcrypt-encrypt)
+ (gpg mml1991-gpg-sign
+ mml1991-gpg-encrypt)
+ (pgg mml1991-pgg-sign
+ mml1991-pgg-encrypt))
+ "Alist of PGP functions.")
+
+;;; mailcrypt wrapper
+
+(eval-and-compile
+ (autoload 'mc-sign-generic "mc-toplev"))
+
+(defvar mml1991-decrypt-function 'mailcrypt-decrypt)
+(defvar mml1991-verify-function 'mailcrypt-verify)
+
+(defun mml1991-mailcrypt-sign (cont)
+ (let ((text (current-buffer))
+ headers signature
+ (result-buffer (get-buffer-create "*GPG Result*")))
+ ;; Save MIME Content[^ ]+: headers from signing
+ (goto-char (point-min))
+ (while (looking-at "^Content[^ ]+:") (forward-line))
+ (unless (bobp)
+ (setq headers (buffer-string))
+ (delete-region (point-min) (point)))
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (quoted-printable-decode-region (point-min) (point-max))
+ (with-temp-buffer
+ (setq signature (current-buffer))
+ (insert-buffer-substring text)
+ (unless (mc-sign-generic (message-options-get 'message-sender)
+ nil nil nil nil)
+ (unless (> (point-max) (point-min))
+ (pop-to-buffer result-buffer)
+ (error "Sign error")))
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (quoted-printable-encode-region (point-min) (point-max))
+ (set-buffer text)
+ (delete-region (point-min) (point-max))
+ (if headers (insert headers))
+ (insert "\n")
+ (insert-buffer-substring signature)
+ (goto-char (point-max)))))
+
+(defun mml1991-mailcrypt-encrypt (cont &optional sign)
+ (let ((text (current-buffer))
+ (mc-pgp-always-sign
+ (or mc-pgp-always-sign
+ sign
+ (eq t (or (message-options-get 'message-sign-encrypt)
+ (message-options-set
+ 'message-sign-encrypt
+ (or (y-or-n-p "Sign the message? ")
+ 'not))))
+ 'never))
+ cipher
+ (result-buffer (get-buffer-create "*GPG Result*")))
+ ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
+ (goto-char (point-min))
+ (while (looking-at "^Content[^ ]+:") (forward-line))
+ (unless (bobp)
+ (delete-region (point-min) (point)))
+ (mm-with-unibyte-current-buffer-mule4
+ (with-temp-buffer
+ (setq cipher (current-buffer))
+ (insert-buffer-substring text)
+ (unless (mc-encrypt-generic
+ (or
+ (message-options-get 'message-recipients)
+ (message-options-set 'message-recipients
+ (read-string "Recipients: ")))
+ nil
+ (point-min) (point-max)
+ (message-options-get 'message-sender)
+ 'sign)
+ (unless (> (point-max) (point-min))
+ (pop-to-buffer result-buffer)
+ (error "Encrypt error")))
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (set-buffer text)
+ (delete-region (point-min) (point-max))
+ ;;(insert "Content-Type: application/pgp-encrypted\n\n")
+ ;;(insert "Version: 1\n\n")
+ (insert "\n")
+ (insert-buffer-substring cipher)
+ (goto-char (point-max))))))
+
+;;; gpg wrapper
+
+(eval-and-compile
+ (autoload 'gpg-sign-cleartext "gpg"))
+
+(defun mml1991-gpg-sign (cont)
+ (let ((text (current-buffer))
+ headers signature
+ (result-buffer (get-buffer-create "*GPG Result*")))
+ ;; Save MIME Content[^ ]+: headers from signing
+ (goto-char (point-min))
+ (while (looking-at "^Content[^ ]+:") (forward-line))
+ (unless (bobp)
+ (setq headers (buffer-string))
+ (delete-region (point-min) (point)))
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (quoted-printable-decode-region (point-min) (point-max))
+ (with-temp-buffer
+ (unless (gpg-sign-cleartext text (setq signature (current-buffer))
+ result-buffer
+ nil
+ (message-options-get 'message-sender))
+ (unless (> (point-max) (point-min))
+ (pop-to-buffer result-buffer)
+ (error "Sign error")))
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (quoted-printable-encode-region (point-min) (point-max))
+ (set-buffer text)
+ (delete-region (point-min) (point-max))
+ (if headers (insert headers))
+ (insert "\n")
+ (insert-buffer-substring signature)
+ (goto-char (point-max)))))
+
+(defun mml1991-gpg-encrypt (cont &optional sign)
+ (let ((text (current-buffer))
+ cipher
+ (result-buffer (get-buffer-create "*GPG Result*")))
+ ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
+ (goto-char (point-min))
+ (while (looking-at "^Content[^ ]+:") (forward-line))
+ (unless (bobp)
+ (delete-region (point-min) (point)))
+ (mm-with-unibyte-current-buffer-mule4
+ (with-temp-buffer
+ (flet ((gpg-encrypt-func
+ (sign plaintext ciphertext result recipients &optional
+ passphrase sign-with-key armor textmode)
+ (if sign
+ (gpg-sign-encrypt
+ plaintext ciphertext result recipients passphrase
+ sign-with-key armor textmode)
+ (gpg-encrypt
+ plaintext ciphertext result recipients passphrase
+ armor textmode))))
+ (unless (gpg-encrypt-func
+ sign
+ text (setq cipher (current-buffer))
+ result-buffer
+ (split-string
+ (or
+ (message-options-get 'message-recipients)
+ (message-options-set 'message-recipients
+ (read-string "Recipients: ")))
+ "[ \f\t\n\r\v,]+")
+ nil
+ (message-options-get 'message-sender)
+ t t) ; armor & textmode
+ (unless (> (point-max) (point-min))
+ (pop-to-buffer result-buffer)
+ (error "Encrypt error"))))
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (set-buffer text)
+ (delete-region (point-min) (point-max))
+ ;;(insert "Content-Type: application/pgp-encrypted\n\n")
+ ;;(insert "Version: 1\n\n")
+ (insert "\n")
+ (insert-buffer-substring cipher)
+ (goto-char (point-max))))))
+
+;; pgg wrapper
+
+(defvar pgg-output-buffer)
+(defvar pgg-errors-buffer)
+
+(defun mml1991-pgg-sign (cont)
+ (let (headers)
+ ;; Don't sign headers.
+ (goto-char (point-min))
+ (while (not (looking-at "^$"))
+ (forward-line))
+ (unless (eobp) ;; no headers?
+ (setq headers (buffer-substring (point-min) (point)))
+ (forward-line) ;; skip header/body separator
+ (delete-region (point-min) (point)))
+ (quoted-printable-decode-region (point-min) (point-max))
+ (unless (let ((pgg-default-user-id
+ (or (message-options-get 'message-sender)
+ pgg-default-user-id)))
+ (pgg-sign-region (point-min) (point-max) t))
+ (pop-to-buffer pgg-errors-buffer)
+ (error "Encrypt error"))
+ (delete-region (point-min) (point-max))
+ (insert-buffer-substring pgg-output-buffer)
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (quoted-printable-encode-region (point-min) (point-max))
+ (goto-char (point-min))
+ (if headers (insert headers))
+ (insert "\n")
+ t))
+
+(defun mml1991-pgg-encrypt (cont &optional sign)
+ (let (headers)
+ ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
+ (goto-char (point-min))
+ (while (looking-at "^Content[^ ]+:") (forward-line))
+ (unless (bobp)
+ (delete-region (point-min) (point)))
+ (unless (pgg-encrypt-region
+ (point-min) (point-max)
+ (split-string
+ (or
+ (message-options-get 'message-recipients)
+ (message-options-set 'message-recipients
+ (read-string "Recipients: ")))
+ "[ \f\t\n\r\v,]+")
+ sign)
+ (pop-to-buffer pgg-errors-buffer)
+ (error "Encrypt error"))
+ (delete-region (point-min) (point-max))
+ ;;(insert "Content-Type: application/pgp-encrypted\n\n")
+ ;;(insert "Version: 1\n\n")
+ (insert "\n")
+ (insert-buffer-substring pgg-output-buffer)
+ t))
+
+;;;###autoload
+(defun mml1991-encrypt (cont &optional sign)
+ (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
+ (if func
+ (funcall func cont sign)
+ (error "Cannot find encrypt function"))))
+
+;;;###autoload
+(defun mml1991-sign (cont)
+ (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
+ (if func
+ (funcall func cont)
+ (error "Cannot find sign function"))))
+
+(provide 'mml1991)
+
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
+;;; mml1991.el ends here
--- /dev/null
+;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
+;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Keywords: PGP MIME MML
+
+;; 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 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:
+
+;; RFC 2015 is updated by RFC 3156, this file should be compatible
+;; with both.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(eval-when-compile (require 'gnus-clfns))
+(require 'mm-decode)
+(require 'mm-util)
+
+(defvar mml2015-use (or
+ (progn
+ (ignore-errors
+ (require 'pgg))
+ (and (fboundp 'pgg-sign-region)
+ 'pgg))
+ (progn
+ (ignore-errors
+ (require 'gpg))
+ (and (fboundp 'gpg-sign-detached)
+ 'gpg))
+ (progn (ignore-errors
+ (load "mc-toplev"))
+ (and (fboundp 'mc-encrypt-generic)
+ (fboundp 'mc-sign-generic)
+ (fboundp 'mc-cleanup-recipient-headers)
+ 'mailcrypt)))
+ "The package used for PGP/MIME.")
+
+;; Something is not RFC2015.
+(defvar mml2015-function-alist
+ '((mailcrypt mml2015-mailcrypt-sign
+ mml2015-mailcrypt-encrypt
+ mml2015-mailcrypt-verify
+ mml2015-mailcrypt-decrypt
+ mml2015-mailcrypt-clear-verify
+ mml2015-mailcrypt-clear-decrypt)
+ (gpg mml2015-gpg-sign
+ mml2015-gpg-encrypt
+ mml2015-gpg-verify
+ mml2015-gpg-decrypt
+ mml2015-gpg-clear-verify
+ mml2015-gpg-clear-decrypt)
+ (pgg mml2015-pgg-sign
+ mml2015-pgg-encrypt
+ mml2015-pgg-verify
+ mml2015-pgg-decrypt
+ mml2015-pgg-clear-verify
+ mml2015-pgg-clear-decrypt))
+ "Alist of PGP/MIME functions.")
+
+(defvar mml2015-result-buffer nil)
+
+(defcustom mml2015-unabbrev-trust-alist
+ '(("TRUST_UNDEFINED" . nil)
+ ("TRUST_NEVER" . nil)
+ ("TRUST_MARGINAL" . t)
+ ("TRUST_FULLY" . t)
+ ("TRUST_ULTIMATE" . t))
+ "Map GnuPG trust output values to a boolean saying if you trust the key."
+ :type '(repeat (cons (regexp :tag "GnuPG output regexp")
+ (boolean :tag "Trust key"))))
+
+;;; mailcrypt wrapper
+
+(eval-and-compile
+ (autoload 'mailcrypt-decrypt "mailcrypt")
+ (autoload 'mailcrypt-verify "mailcrypt")
+ (autoload 'mc-pgp-always-sign "mailcrypt")
+ (autoload 'mc-encrypt-generic "mc-toplev")
+ (autoload 'mc-cleanup-recipient-headers "mc-toplev")
+ (autoload 'mc-sign-generic "mc-toplev"))
+
+(eval-when-compile
+ (defvar mc-default-scheme)
+ (defvar mc-schemes))
+
+(defvar mml2015-decrypt-function 'mailcrypt-decrypt)
+(defvar mml2015-verify-function 'mailcrypt-verify)
+
+(defun mml2015-format-error (err)
+ (if (stringp (cadr err))
+ (cadr err)
+ (format "%S" (cdr err))))
+
+(defun mml2015-mailcrypt-decrypt (handle ctl)
+ (catch 'error
+ (let (child handles result)
+ (unless (setq child (mm-find-part-by-type
+ (cdr handle)
+ "application/octet-stream" nil t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (with-temp-buffer
+ (mm-insert-part child)
+ (setq result
+ (condition-case err
+ (funcall mml2015-decrypt-function)
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil)))
+ (unless (car result)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (throw 'error handle))
+ (setq handles (mm-dissect-buffer t)))
+ (mm-destroy-parts handle)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (concat "OK"
+ (let ((sig (with-current-buffer mml2015-result-buffer
+ (mml2015-gpg-extract-signature-details))))
+ (concat ", Signer: " sig))))
+ (if (listp (car handles))
+ handles
+ (list handles)))))
+
+(defun mml2015-mailcrypt-clear-decrypt ()
+ (let (result)
+ (setq result
+ (condition-case err
+ (funcall mml2015-decrypt-function)
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil)))
+ (if (car result)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed"))))
+
+(defun mml2015-fix-micalg (alg)
+ (and alg
+ ;; Mutt/1.2.5i has seen sending micalg=php-sha1
+ (upcase (if (string-match "^p[gh]p-" alg)
+ (substring alg (match-end 0))
+ alg))))
+
+(defun mml2015-mailcrypt-verify (handle ctl)
+ (catch 'error
+ (let (part)
+ (unless (setq part (mm-find-raw-part-by-type
+ ctl (or (mm-handle-multipart-ctl-parameter
+ ctl 'protocol)
+ "application/pgp-signature")
+ t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (with-temp-buffer
+ (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
+ (insert (format "Hash: %s\n\n"
+ (or (mml2015-fix-micalg
+ (mm-handle-multipart-ctl-parameter
+ ctl 'micalg))
+ "SHA1")))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert part "\n")
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "^-")
+ (insert "- "))
+ (forward-line)))
+ (unless (setq part (mm-find-part-by-type
+ (cdr handle) "application/pgp-signature" nil t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mm-insert-part part)
+ (goto-char (point-min))
+ (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
+ (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
+ (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
+ (replace-match "-----END PGP SIGNATURE-----" t t)))
+ (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
+ (unless (condition-case err
+ (prog1
+ (funcall mml2015-verify-function)
+ (if (get-buffer " *mailcrypt stderr temp")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (with-current-buffer " *mailcrypt stderr temp"
+ (buffer-string))))
+ (if (get-buffer " *mailcrypt stdout temp")
+ (kill-buffer " *mailcrypt stdout temp"))
+ (if (get-buffer " *mailcrypt stderr temp")
+ (kill-buffer " *mailcrypt stderr temp"))
+ (if (get-buffer " *mailcrypt status temp")
+ (kill-buffer " *mailcrypt status temp"))
+ (if (get-buffer mc-gpg-debug-buffer)
+ (kill-buffer mc-gpg-debug-buffer)))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (throw 'error handle))))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK")
+ handle)))
+
+(defun mml2015-mailcrypt-clear-verify ()
+ (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
+ (if (condition-case err
+ (prog1
+ (funcall mml2015-verify-function)
+ (if (get-buffer " *mailcrypt stderr temp")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (with-current-buffer " *mailcrypt stderr temp"
+ (buffer-string))))
+ (if (get-buffer " *mailcrypt stdout temp")
+ (kill-buffer " *mailcrypt stdout temp"))
+ (if (get-buffer " *mailcrypt stderr temp")
+ (kill-buffer " *mailcrypt stderr temp"))
+ (if (get-buffer " *mailcrypt status temp")
+ (kill-buffer " *mailcrypt status temp"))
+ (if (get-buffer mc-gpg-debug-buffer)
+ (kill-buffer mc-gpg-debug-buffer)))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed"))))
+
+(defun mml2015-mailcrypt-sign (cont)
+ (mc-sign-generic (message-options-get 'message-sender)
+ nil nil nil nil)
+ (let ((boundary
+ (funcall mml-boundary-function (incf mml-multipart-number)))
+ hash point)
+ (goto-char (point-min))
+ (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
+ (error "Cannot find signed begin line"))
+ (goto-char (match-beginning 0))
+ (forward-line 1)
+ (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
+ (error "Cannot not find PGP hash"))
+ (setq hash (match-string 1))
+ (unless (re-search-forward "^$" nil t)
+ (error "Cannot not find PGP message"))
+ (forward-line 1)
+ (delete-region (point-min) (point))
+ (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
+ boundary))
+ (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
+ (downcase hash)))
+ (insert (format "\n--%s\n" boundary))
+ (setq point (point))
+ (goto-char (point-max))
+ (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
+ (error "Cannot find signature part"))
+ (replace-match "-----END PGP MESSAGE-----" t t)
+ (goto-char (match-beginning 0))
+ (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
+ nil t)
+ (error "Cannot find signature part"))
+ (replace-match "-----BEGIN PGP MESSAGE-----" t t)
+ (goto-char (match-beginning 0))
+ (save-restriction
+ (narrow-to-region point (point))
+ (goto-char point)
+ (while (re-search-forward "^- -" nil t)
+ (replace-match "-" t t))
+ (goto-char (point-max)))
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/pgp-signature\n\n")
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max))))
+
+(defun mml2015-mailcrypt-encrypt (cont &optional sign)
+ (let ((mc-pgp-always-sign
+ (or mc-pgp-always-sign
+ sign
+ (eq t (or (message-options-get 'message-sign-encrypt)
+ (message-options-set
+ 'message-sign-encrypt
+ (or (y-or-n-p "Sign the message? ")
+ 'not))))
+ 'never)))
+ (mm-with-unibyte-current-buffer-mule4
+ (mc-encrypt-generic
+ (or (message-options-get 'message-recipients)
+ (message-options-set 'message-recipients
+ (mc-cleanup-recipient-headers
+ (read-string "Recipients: "))))
+ nil nil nil
+ (message-options-get 'message-sender))))
+ (goto-char (point-min))
+ (unless (looking-at "-----BEGIN PGP MESSAGE-----")
+ (error "Fail to encrypt the message"))
+ (let ((boundary
+ (funcall mml-boundary-function (incf mml-multipart-number))))
+ (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
+ boundary))
+ (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/pgp-encrypted\n\n")
+ (insert "Version: 1\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/octet-stream\n\n")
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max))))
+
+;;; gpg wrapper
+
+(eval-and-compile
+ (autoload 'gpg-decrypt "gpg")
+ (autoload 'gpg-verify "gpg")
+ (autoload 'gpg-verify-cleartext "gpg")
+ (autoload 'gpg-sign-detached "gpg")
+ (autoload 'gpg-sign-encrypt "gpg")
+ (autoload 'gpg-encrypt "gpg")
+ (autoload 'gpg-passphrase-read "gpg"))
+
+(defun mml2015-gpg-passphrase ()
+ (or (message-options-get 'gpg-passphrase)
+ (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
+
+(defun mml2015-gpg-decrypt-1 ()
+ (let ((cipher (current-buffer)) plain result)
+ (if (with-temp-buffer
+ (prog1
+ (gpg-decrypt cipher (setq plain (current-buffer))
+ mml2015-result-buffer nil)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (with-current-buffer mml2015-result-buffer
+ (buffer-string)))
+ (set-buffer cipher)
+ (erase-buffer)
+ (insert-buffer-substring plain)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))))
+ '(t)
+ ;; Some wrong with the return value, check plain text buffer.
+ (if (> (point-max) (point-min))
+ '(t)
+ nil))))
+
+(defun mml2015-gpg-decrypt (handle ctl)
+ (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
+ (mml2015-mailcrypt-decrypt handle ctl)))
+
+(defun mml2015-gpg-clear-decrypt ()
+ (let (result)
+ (setq result (mml2015-gpg-decrypt-1))
+ (if (car result)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed"))))
+
+(defun mml2015-gpg-pretty-print-fpr (fingerprint)
+ (let* ((result "")
+ (fpr-length (string-width fingerprint))
+ (n-slice 0)
+ slice)
+ (setq fingerprint (string-to-list fingerprint))
+ (while fingerprint
+ (setq fpr-length (- fpr-length 4))
+ (setq slice (butlast fingerprint fpr-length))
+ (setq fingerprint (nthcdr 4 fingerprint))
+ (setq n-slice (1+ n-slice))
+ (setq result
+ (concat
+ result
+ (case n-slice
+ (1 slice)
+ (otherwise (concat " " slice))))))
+ result))
+
+(defun mml2015-gpg-extract-signature-details ()
+ (goto-char (point-min))
+ (let* ((expired (re-search-forward
+ "^\\[GNUPG:\\] SIGEXPIRED$"
+ nil t))
+ (signer (and (re-search-forward
+ "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
+ nil t)
+ (cons (match-string 1) (match-string 2))))
+ (fprint (and (re-search-forward
+ "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
+ nil t)
+ (match-string 1)))
+ (trust (and (re-search-forward
+ "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
+ nil t)
+ (match-string 1)))
+ (trust-good-enough-p
+ (cdr (assoc trust mml2015-unabbrev-trust-alist))))
+ (cond ((and signer fprint)
+ (concat (cdr signer)
+ (unless trust-good-enough-p
+ (concat "\nUntrusted, Fingerprint: "
+ (mml2015-gpg-pretty-print-fpr fprint)))
+ (when expired
+ (format "\nWARNING: Signature from expired key (%s)"
+ (car signer)))))
+ ((re-search-forward
+ "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
+ (match-string 2))
+ (t
+ "From unknown user"))))
+
+(defun mml2015-gpg-verify (handle ctl)
+ (catch 'error
+ (let (part message signature info-is-set-p)
+ (unless (setq part (mm-find-raw-part-by-type
+ ctl (or (mm-handle-multipart-ctl-parameter
+ ctl 'protocol)
+ "application/pgp-signature")
+ t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (with-temp-buffer
+ (setq message (current-buffer))
+ (insert part)
+ ;; Convert <LF> to <CR><LF> in verify mode. Sign and
+ ;; clearsign use --textmode. The conversion is not necessary.
+ ;; In clearverify, the conversion is not necessary either.
+ (goto-char (point-min))
+ (end-of-line)
+ (while (not (eobp))
+ (unless (eq (char-before) ?\r)
+ (insert "\r"))
+ (forward-line)
+ (end-of-line))
+ (with-temp-buffer
+ (setq signature (current-buffer))
+ (unless (setq part (mm-find-part-by-type
+ (cdr handle) "application/pgp-signature" nil t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (mm-insert-part part)
+ (unless (condition-case err
+ (prog1
+ (gpg-verify message signature mml2015-result-buffer)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (with-current-buffer mml2015-result-buffer
+ (buffer-string))))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Error.")
+ (setq info-is-set-p t)
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Quit.")
+ (setq info-is-set-p t)
+ nil))
+ (unless info-is-set-p
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed"))
+ (throw 'error handle)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (with-current-buffer mml2015-result-buffer
+ (mml2015-gpg-extract-signature-details))))
+ handle)))
+
+(defun mml2015-gpg-clear-verify ()
+ (if (condition-case err
+ (prog1
+ (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (with-current-buffer mml2015-result-buffer
+ (buffer-string))))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (with-current-buffer mml2015-result-buffer
+ (mml2015-gpg-extract-signature-details)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")))
+
+(defun mml2015-gpg-sign (cont)
+ (let ((boundary
+ (funcall mml-boundary-function (incf mml-multipart-number)))
+ (text (current-buffer)) signature)
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (with-temp-buffer
+ (unless (gpg-sign-detached text (setq signature (current-buffer))
+ mml2015-result-buffer
+ nil
+ (message-options-get 'message-sender)
+ t t) ; armor & textmode
+ (unless (> (point-max) (point-min))
+ (pop-to-buffer mml2015-result-buffer)
+ (error "Sign error")))
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (set-buffer text)
+ (goto-char (point-min))
+ (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
+ boundary))
+ ;;; FIXME: what is the micalg?
+ (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
+ (insert (format "\n--%s\n" boundary))
+ (goto-char (point-max))
+ (insert (format "\n--%s\n" boundary))
+ (insert "Content-Type: application/pgp-signature\n\n")
+ (insert-buffer-substring signature)
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max)))))
+
+(defun mml2015-gpg-encrypt (cont &optional sign)
+ (let ((boundary
+ (funcall mml-boundary-function (incf mml-multipart-number)))
+ (text (current-buffer))
+ cipher)
+ (mm-with-unibyte-current-buffer-mule4
+ (with-temp-buffer
+ ;; set up a function to call the correct gpg encrypt routine
+ ;; with the right arguments. (FIXME: this should be done
+ ;; differently.)
+ (flet ((gpg-encrypt-func
+ (sign plaintext ciphertext result recipients &optional
+ passphrase sign-with-key armor textmode)
+ (if sign
+ (gpg-sign-encrypt
+ plaintext ciphertext result recipients passphrase
+ sign-with-key armor textmode)
+ (gpg-encrypt
+ plaintext ciphertext result recipients passphrase
+ armor textmode))))
+ (unless (gpg-encrypt-func
+ sign ; passed in when using signencrypt
+ text (setq cipher (current-buffer))
+ mml2015-result-buffer
+ (split-string
+ (or
+ (message-options-get 'message-recipients)
+ (message-options-set 'message-recipients
+ (read-string "Recipients: ")))
+ "[ \f\t\n\r\v,]+")
+ nil
+ (message-options-get 'message-sender)
+ t t) ; armor & textmode
+ (unless (> (point-max) (point-min))
+ (pop-to-buffer mml2015-result-buffer)
+ (error "Encrypt error"))))
+ (goto-char (point-min))
+ (while (re-search-forward "\r+$" nil t)
+ (replace-match "" t t))
+ (set-buffer text)
+ (delete-region (point-min) (point-max))
+ (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
+ boundary))
+ (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/pgp-encrypted\n\n")
+ (insert "Version: 1\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/octet-stream\n\n")
+ (insert-buffer-substring cipher)
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max))))))
+
+;;; pgg wrapper
+
+(eval-when-compile
+ (defvar pgg-errors-buffer)
+ (defvar pgg-output-buffer))
+
+(eval-and-compile
+ (autoload 'pgg-decrypt-region "pgg")
+ (autoload 'pgg-verify-region "pgg")
+ (autoload 'pgg-sign-region "pgg")
+ (autoload 'pgg-encrypt-region "pgg"))
+
+(defun mml2015-pgg-decrypt (handle ctl)
+ (catch 'error
+ (let ((pgg-errors-buffer mml2015-result-buffer)
+ child handles result decrypt-status)
+ (unless (setq child (mm-find-part-by-type
+ (cdr handle)
+ "application/octet-stream" nil t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ (throw 'error handle))
+ (with-temp-buffer
+ (mm-insert-part child)
+ (if (condition-case err
+ (prog1
+ (pgg-decrypt-region (point-min) (point-max))
+ (setq decrypt-status
+ (with-current-buffer mml2015-result-buffer
+ (buffer-string)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ decrypt-status))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil))
+ (with-current-buffer pgg-output-buffer
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))
+ (setq handles (mm-dissect-buffer t))
+ (mm-destroy-parts handle)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK")
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (concat decrypt-status
+ (when (stringp (car handles))
+ "\n" (mm-handle-multipart-ctl-parameter
+ handles 'gnus-details))))
+ (if (listp (car handles))
+ handles
+ (list handles)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")
+ (throw 'error handle))))))
+
+(defun mml2015-pgg-clear-decrypt ()
+ (let ((pgg-errors-buffer mml2015-result-buffer))
+ (if (prog1
+ (pgg-decrypt-region (point-min) (point-max))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (with-current-buffer mml2015-result-buffer
+ (buffer-string))))
+ (progn
+ (erase-buffer)
+ (insert-buffer-substring pgg-output-buffer)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "OK"))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed"))))
+
+(defun mml2015-pgg-verify (handle ctl)
+ (let ((pgg-errors-buffer mml2015-result-buffer)
+ signature-file part signature)
+ (if (or (null (setq part (mm-find-raw-part-by-type
+ ctl (or (mm-handle-multipart-ctl-parameter
+ ctl 'protocol)
+ "application/pgp-signature")
+ t)))
+ (null (setq signature (mm-find-part-by-type
+ (cdr handle) "application/pgp-signature" nil t))))
+ (progn
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Corrupted")
+ handle)
+ (with-temp-buffer
+ (insert part)
+ ;; Convert <LF> to <CR><LF> in verify mode. Sign and
+ ;; clearsign use --textmode. The conversion is not necessary.
+ ;; In clearverify, the conversion is not necessary either.
+ (goto-char (point-min))
+ (end-of-line)
+ (while (not (eobp))
+ (unless (eq (char-before) ?\r)
+ (insert "\r"))
+ (forward-line)
+ (end-of-line))
+ (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
+ (mm-insert-part signature))
+ (if (condition-case err
+ (prog1
+ (pgg-verify-region (point-min) (point-max)
+ signature-file t)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (concat (with-current-buffer pgg-output-buffer
+ (buffer-string))
+ (with-current-buffer pgg-errors-buffer
+ (buffer-string)))))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil))
+ (progn
+ (delete-file signature-file)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (with-current-buffer pgg-errors-buffer
+ (mml2015-gpg-extract-signature-details))))
+ (delete-file signature-file)
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed")))))
+ handle)
+
+(defun mml2015-pgg-clear-verify ()
+ (let ((pgg-errors-buffer mml2015-result-buffer)
+ (text (buffer-string))
+ (coding-system buffer-file-coding-system))
+ (if (condition-case err
+ (prog1
+ (mm-with-unibyte-buffer
+ (insert (encode-coding-string text coding-system))
+ (pgg-verify-region (point-min) (point-max) nil t))
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" t t))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details
+ (concat (with-current-buffer pgg-output-buffer
+ (buffer-string))
+ (with-current-buffer pgg-errors-buffer
+ (buffer-string)))))
+ (error
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details (mml2015-format-error err))
+ nil)
+ (quit
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-details "Quit.")
+ nil))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info
+ (with-current-buffer pgg-errors-buffer
+ (mml2015-gpg-extract-signature-details)))
+ (mm-set-handle-multipart-parameter
+ mm-security-handle 'gnus-info "Failed"))))
+
+(defun mml2015-pgg-sign (cont)
+ (let ((pgg-errors-buffer mml2015-result-buffer)
+ (boundary (funcall mml-boundary-function (incf mml-multipart-number)))
+ (pgg-default-user-id (or (message-options-get 'mml-sender)
+ pgg-default-user-id)))
+ (unless (pgg-sign-region (point-min) (point-max))
+ (pop-to-buffer mml2015-result-buffer)
+ (error "Sign error"))
+ (goto-char (point-min))
+ (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
+ boundary))
+ ;;; FIXME: what is the micalg?
+ (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
+ (insert (format "\n--%s\n" boundary))
+ (goto-char (point-max))
+ (insert (format "\n--%s\n" boundary))
+ (insert "Content-Type: application/pgp-signature\n\n")
+ (insert-buffer-substring pgg-output-buffer)
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max))))
+
+(defun mml2015-pgg-encrypt (cont &optional sign)
+ (let ((pgg-errors-buffer mml2015-result-buffer)
+ (boundary (funcall mml-boundary-function (incf mml-multipart-number))))
+ (unless (pgg-encrypt-region (point-min) (point-max)
+ (split-string
+ (or
+ (message-options-get 'message-recipients)
+ (message-options-set 'message-recipients
+ (read-string "Recipients: ")))
+ "[ \f\t\n\r\v,]+")
+ sign)
+ (pop-to-buffer mml2015-result-buffer)
+ (error "Encrypt error"))
+ (delete-region (point-min) (point-max))
+ (goto-char (point-min))
+ (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
+ boundary))
+ (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/pgp-encrypted\n\n")
+ (insert "Version: 1\n\n")
+ (insert (format "--%s\n" boundary))
+ (insert "Content-Type: application/octet-stream\n\n")
+ (insert-buffer-substring pgg-output-buffer)
+ (goto-char (point-max))
+ (insert (format "--%s--\n" boundary))
+ (goto-char (point-max))))
+
+;;; General wrapper
+
+(defun mml2015-clean-buffer ()
+ (if (gnus-buffer-live-p mml2015-result-buffer)
+ (with-current-buffer mml2015-result-buffer
+ (erase-buffer)
+ t)
+ (setq mml2015-result-buffer
+ (gnus-get-buffer-create "*MML2015 Result*"))
+ nil))
+
+(defsubst mml2015-clear-decrypt-function ()
+ (nth 6 (assq mml2015-use mml2015-function-alist)))
+
+(defsubst mml2015-clear-verify-function ()
+ (nth 5 (assq mml2015-use mml2015-function-alist)))
+
+;;;###autoload
+(defun mml2015-decrypt (handle ctl)
+ (mml2015-clean-buffer)
+ (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
+ (if func
+ (funcall func handle ctl)
+ handle)))
+
+;;;###autoload
+(defun mml2015-decrypt-test (handle ctl)
+ mml2015-use)
+
+;;;###autoload
+(defun mml2015-verify (handle ctl)
+ (mml2015-clean-buffer)
+ (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
+ (if func
+ (funcall func handle ctl)
+ handle)))
+
+;;;###autoload
+(defun mml2015-verify-test (handle ctl)
+ mml2015-use)
+
+;;;###autoload
+(defun mml2015-encrypt (cont &optional sign)
+ (mml2015-clean-buffer)
+ (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
+ (if func
+ (funcall func cont sign)
+ (error "Cannot find encrypt function"))))
+
+;;;###autoload
+(defun mml2015-sign (cont)
+ (mml2015-clean-buffer)
+ (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
+ (if func
+ (funcall func cont)
+ (error "Cannot find sign function"))))
+
+;;;###autoload
+(defun mml2015-self-encrypt ()
+ (mml2015-encrypt nil))
+
+(provide 'mml2015)
+
+;;; mml2015.el ends here
--- /dev/null
+;;; netrc.el --- .netrc parsing functionality
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
+;; Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Modularizer: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: news
+
+;; 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 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:
+
+;; Just the .netrc parsing functionality, abstracted so other packages
+;; besides Gnus can use it.
+
+;;; Code:
+
+;;;
+;;; .netrc and .authinforc parsing
+;;;
+
+(eval-and-compile
+ (defalias 'netrc-point-at-eol
+ (if (fboundp 'point-at-eol)
+ 'point-at-eol
+ 'line-end-position)))
+
+(defun netrc-parse (file)
+ "Parse FILE and return an list of all entries in the file."
+ (when (file-exists-p file)
+ (with-temp-buffer
+ (let ((tokens '("machine" "default" "login"
+ "password" "account" "macdef" "force"
+ "port"))
+ alist elem result pair)
+ (insert-file-contents file)
+ (goto-char (point-min))
+ ;; Go through the file, line by line.
+ (while (not (eobp))
+ (narrow-to-region (point) (netrc-point-at-eol))
+ ;; For each line, get the tokens and values.
+ (while (not (eobp))
+ (skip-chars-forward "\t ")
+ ;; Skip lines that begin with a "#".
+ (if (eq (char-after) ?#)
+ (goto-char (point-max))
+ (unless (eobp)
+ (setq elem
+ (if (= (following-char) ?\")
+ (read (current-buffer))
+ (buffer-substring
+ (point) (progn (skip-chars-forward "^\t ")
+ (point)))))
+ (cond
+ ((equal elem "macdef")
+ ;; We skip past the macro definition.
+ (widen)
+ (while (and (zerop (forward-line 1))
+ (looking-at "$")))
+ (narrow-to-region (point) (point)))
+ ((member elem tokens)
+ ;; Tokens that don't have a following value are ignored,
+ ;; except "default".
+ (when (and pair (or (cdr pair)
+ (equal (car pair) "default")))
+ (push pair alist))
+ (setq pair (list elem)))
+ (t
+ ;; Values that haven't got a preceding token are ignored.
+ (when pair
+ (setcdr pair elem)
+ (push pair alist)
+ (setq pair nil)))))))
+ (when alist
+ (push (nreverse alist) result))
+ (setq alist nil
+ pair nil)
+ (widen)
+ (forward-line 1))
+ (nreverse result)))))
+
+(defun netrc-machine (list machine &optional port defaultport)
+ "Return the netrc values from LIST for MACHINE or for the default entry.
+If PORT specified, only return entries with matching port tokens.
+Entries without port tokens default to DEFAULTPORT."
+ (let ((rest list)
+ result)
+ (while list
+ (when (equal (cdr (assoc "machine" (car list))) machine)
+ (push (car list) result))
+ (pop list))
+ (unless result
+ ;; No machine name matches, so we look for default entries.
+ (while rest
+ (when (assoc "default" (car rest))
+ (push (car rest) result))
+ (pop rest)))
+ (when result
+ (setq result (nreverse result))
+ (while (and result
+ (not (equal (or port defaultport "nntp")
+ (or (netrc-get (car result) "port")
+ defaultport "nntp"))))
+ (pop result))
+ (car result))))
+
+(defun netrc-get (alist type)
+ "Return the value of token TYPE from ALIST."
+ (cdr (assoc type alist)))
+
+(provide 'netrc)
+
+;;; netrc.el ends here
--- /dev/null
+;;; nndiary.el --- A diary backend for Gnus
+
+;; Copyright (C) 1999, 2000, 2001, 2003
+;; Free Software Foundation, Inc.
+
+;; Author: Didier Verna <didier@xemacs.org>
+;; Maintainer: Didier Verna <didier@xemacs.org>
+;; Created: Fri Jul 16 18:55:42 1999
+;; Keywords: calendar mail news
+
+;; 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 2 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 this program; if not, write to the Free Software
+;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;; Commentary:
+
+;; Contents management by FCM version 0.1.
+
+;; Description:
+;; ===========
+
+;; This package implements NNDiary, a diary backend for Gnus. NNDiary is a
+;; mail backend, pretty similar to nnml in its functionnning (it has all the
+;; features of nnml, actually), but in which messages are treated as event
+;; reminders.
+
+;; Here is a typical scenario:
+;; - You've got a date with Andy Mc Dowell or Bruce Willis (select according
+;; to your sexual preference) in one month. You don't want to forget it.
+;; - Send a (special) diary message to yourself (see below).
+;; - Forget all about it and keep on getting and reading new mail, as usual.
+;; - From time to time, as you type `g' in the group buffer and as the date
+;; is getting closer, the message will pop up again, just like if it were
+;; new and unread.
+;; - Read your "new" messages, this one included, and start dreaming of the
+;; night you're gonna have.
+;; - Once the date is over (you actually fell asleep just after dinner), the
+;; message will be automatically deleted if it is marked as expirable.
+
+;; Some more notes on the diary backend:
+;; - NNDiary is a *real* mail backend. You *really* send real diary
+;; messsages. This means for instance that you can give appointements to
+;; anybody (provided they use Gnus and NNDiary) by sending the diary message
+;; to them as well.
+;; - However, since NNDiary also has a 'request-post method, you can also
+;; `C-u a' instead of `C-u m' on a diary group and the message won't actually
+;; be sent; just stored in the group.
+;; - The events you want to remember need not be punctual. You can set up
+;; reminders for regular dates (like once each week, each monday at 13:30
+;; and so on). Diary messages of this kind will never be deleted (unless
+;; you do it explicitely). But that, you guessed.
+
+
+;; Usage:
+;; =====
+
+;; 1/ NNDiary has two modes of operation: traditional (the default) and
+;; autonomous.
+;; a/ In traditional mode, NNDiary does not get new mail by itself. You
+;; have to move mails from your primary mail backend to nndiary
+;; groups.
+;; b/ In autonomous mode, NNDiary retrieves its own mail and handles it
+;; independantly of your primary mail backend. To use NNDiary in
+;; autonomous mode, you have several things to do:
+;; i/ Put (setq nndiary-get-new-mail t) in your gnusrc file.
+;; ii/ Diary messages contain several `X-Diary-*' special headers.
+;; You *must* arrange that these messages be split in a private
+;; folder *before* Gnus treat them. You need this because Gnus
+;; is not able yet to manage multiple backends for mail
+;; retrieval. Getting them from a separate source will
+;; compensate this misfeature to some extent, as we will see.
+;; As an example, here's my procmailrc entry to store diary files
+;; in ~/.nndiary (the default nndiary mail source file):
+;;
+;; :0 HD :
+;; * ^X-Diary
+;; .nndiary
+;; iii/ Customize the variables `nndiary-mail-sources' and
+;; `nndiary-split-methods'. These are replacements for the usual
+;; mail sources and split methods which, and will be used in
+;; autonomous mode. `nndiary-mail-sources' defaults to
+;; '(file :path "~/.nndiary").
+;; 2/ Install nndiary somewhere Emacs / Gnus can find it. Normally, you
+;; *don't* have to '(require 'nndiary) anywhere. Gnus will do so when
+;; appropriate as long as nndiary is somewhere in the load path.
+;; 3/ Now, customize the rest of nndiary. In particular, you should
+;; customize `nndiary-reminders', the list of times when you want to be
+;; reminded of your appointements (e.g. 3 weeks before, then 2 days
+;; before, then 1 hour before and that's it).
+;; 4/ You *must* use the group timestamp feature of Gnus. This adds a
+;; timestamp to each groups' parameters (please refer to the Gnus
+;; documentation ("Group Timestamp" info node) to see how it's done.
+;; 5/ Once you have done this, you may add a permanent nndiary virtual server
+;; (something like '(nndiary "")) to your `gnus-secondary-select-methods'.
+;; Yes, this server will be able to retrieve mails and split them when you
+;; type `g' in the group buffer, just as if it were your only mail backend.
+;; This is the benefit of using a private folder.
+;; 6/ Hopefully, almost everything (see the TODO section below) will work as
+;; expected when you restart Gnus: in the group buffer, `g' and `M-g' will
+;; also get your new diary mails, `F' will find your new diary groups etc.
+
+
+;; How to send diary messages:
+;; ==========================
+
+;; There are 7 special headers in diary messages. These headers are of the
+;; form `X-Diary-<something>', the <something> being one of `Minute', `Hour',
+;; `Dom', `Month', `Year', `Time-Zone' and `Dow'. `Dom' means "Day of Month",
+;; and `dow' means "Day of Week". These headers actually behave like crontab
+;; specifications and define the event date(s).
+
+;; For all headers but the `Time-Zone' one, a header value is either a
+;; star (meaning all possible values), or a list of fields (separated by a
+;; comma). A field is either an integer, or a range. A range is two integers
+;; separated by a dash. Possible integer values are 0-59 for `Minute', 0-23
+;; for `Hour', 1-31 for `Dom', `1-12' for Month, above 1971 for `Year' and 0-6
+;; for `Dow' (0 = sunday). As a special case, a star in either `Dom' or `Dow'
+;; doesn't mean "all possible values", but "use only the other field". Note
+;; that if both are star'ed, the use of either one gives the same result :-),
+
+;; The `Time-Zone' header is special in that it can have only one value (you
+;; bet ;-).
+;; A star doesn't mean "all possible values" (because it has no sense), but
+;; "the current local time zone".
+
+;; As an example, here's how you would say "Each Monday and each 1st of month,
+;; at 12:00, 20:00, 21:00, 22:00, 23:00 and 24:00, from 1999 to 2010" (I let
+;; you find what to do then):
+;;
+;; X-Diary-Minute: 0
+;; X-Diary-Hour: 12, 20-24
+;; X-Diary-Dom: 1
+;; X-Diary-Month: *
+;; X-Diary-Year: 1999-2010
+;; X-Diary-Dow: 1
+;; X-Diary-Time-Zone: *
+;;
+;;
+;; Sending a diary message is not different from sending any other kind of
+;; mail, except that such messages are identified by the presence of these
+;; special headers.
+
+
+
+;; Bugs / Todo:
+;; ===========
+
+;; * Respooling doesn't work because contrary to the request-scan function,
+;; Gnus won't allow me to override the split methods when calling the
+;; respooling backend functions.
+;; * There's a bug in the time zone mechanism with variable TZ locations.
+;; * We could allow a keyword like `ask' in X-Diary-* headers, that would mean
+;; "ask for value upon reception of the message".
+;; * We could add an optional header X-Diary-Reminders to specify a special
+;; reminders value for this message. Suggested by Jody Klymak.
+;; * We should check messages validity in other circumstances than just
+;; moving an article from sonwhere else (request-accept). For instance, when
+;; editing / saving and so on.
+
+
+;; Remarks:
+;; =======
+
+;; * nnoo.
+;; NNDiary is very similar to nnml. This makes the idea of using nnoo (to
+;; derive nndiary from nnml) natural. However, my experience with nnoo is
+;; that for reasonably complex backends like this one, noo is a burden
+;; rather than an help. It's tricky to use, not everything can be
+;; inherited, what can be inherited and when is not very clear, and you've
+;; got to be very careful because a little mistake can fuck up your your
+;; other backends, especially because their variables will be use instead of
+;; your real ones. Finally, I found it easier to just clone the needed
+;; parts of nnml, and tracking nnml updates is not a big deal.
+
+;; IMHO, nnoo is actually badly designed. A much simpler, and yet more
+;; powerful one would be to make *real* functions and variables for a new
+;; backend based on another. Lisp is a reflexive language so that's a very
+;; easy thing to do: inspect the function's form, replace occurences of
+;; <nnfrom> (even in strings) with <nnto>, and you're done.
+
+;; * nndiary-get-new-mail, nndiary-mail-source and nndiary-split-methods:
+;; NNDiary has some experimental parts, in the sense Gnus normally uses only
+;; one mail backends for mail retreival and splitting. This backend is also
+;; an attempt to make it behave differently. For Gnus developpers: as you
+;; can see if you snarf into the code, that was not a very difficult thing
+;; to do. Something should be done about the respooling breakage though.
+
+
+;;; Code:
+
+(require 'nnoo)
+(require 'nnheader)
+(require 'nnmail)
+(eval-when-compile (require 'cl))
+
+(require 'gnus-start)
+(require 'gnus-sum)
+
+;; Compatibility Functions =================================================
+
+(eval-and-compile
+ (if (fboundp 'signal-error)
+ (defun nndiary-error (&rest args)
+ (apply #'signal-error 'nndiary args))
+ (defun nndiary-error (&rest args)
+ (apply #'error args))))
+
+
+;; Backend behavior customization ===========================================
+
+(defgroup nndiary nil
+ "The Gnus Diary backend."
+ :group 'gnus-diary)
+
+(defcustom nndiary-mail-sources
+ `((file :path ,(expand-file-name "~/.nndiary")))
+ "*NNDiary specific mail sources.
+This variable is used by nndiary in place of the standard `mail-sources'
+variable when `nndiary-get-new-mail' is set to non-nil. These sources
+must contain diary messages ONLY."
+ :group 'nndiary
+ :group 'mail-source
+ :type 'sexp)
+
+(defcustom nndiary-split-methods '(("diary" ""))
+ "*NNDiary specific split methods.
+This variable is used by nndiary in place of the standard
+`nnmail-split-methods' variable when `nndiary-get-new-mail' is set to
+non-nil."
+ :group 'nndiary
+ :group 'nnmail-split
+ :type '(choice (repeat :tag "Alist" (group (string :tag "Name") regexp))
+ (function-item nnmail-split-fancy)
+ (function :tag "Other")))
+
+
+(defcustom nndiary-reminders '((0 . day))
+ "*Different times when you want to be reminded of your appointements.
+Diary articles will appear again, as if they'd been just received.
+
+Entries look like (3 . day) which means something like \"Please
+Hortense, would you be so kind as to remind me of my appointments 3 days
+before the date, thank you very much. Anda, hmmm... by the way, are you
+doing anything special tonight ?\".
+
+The units of measure are 'minute 'hour 'day 'week 'month and 'year (no,
+not 'century, sorry).
+
+NOTE: the units of measure actually express dates, not durations: if you
+use 'week, messages will pop up on Sundays at 00:00 (or Mondays if
+`nndiary-week-starts-on-monday' is non nil) and *not* 7 days before the
+appointement, if you use 'month, messages will pop up on the first day of
+each months, at 00:00 and so on.
+
+If you really want to specify a duration (like 24 hours exactly), you can
+use the equivalent in minutes (the smallest unit). A fuzz of 60 seconds
+maximum in the reminder is not that painful, I think. Although this
+scheme might appear somewhat weird at a first glance, it is very powerful.
+In order to make this clear, here are some examples:
+
+- '(0 . day): this is the default value of `nndiary-reminders'. It means
+ pop up the appointements of the day each morning at 00:00.
+
+- '(1 . day): this means pop up the appointements the day before, at 00:00.
+
+- '(6 . hour): for an appointement at 18:30, this would pop up the
+ appointement message at 12:00.
+
+- '(360 . minute): for an appointement at 18:30 and 15 seconds, this would
+ pop up the appointement message at 12:30."
+ :group 'nndiary
+ :type '(repeat (cons :format "%v\n"
+ (integer :format "%v")
+ (choice :format "%[%v(s)%] before...\n"
+ :value day
+ (const :format "%v" minute)
+ (const :format "%v" hour)
+ (const :format "%v" day)
+ (const :format "%v" week)
+ (const :format "%v" month)
+ (const :format "%v" year)))))
+
+(defcustom nndiary-week-starts-on-monday nil
+ "*Whether a week starts on monday (otherwise, sunday)."
+ :type 'boolean
+ :group 'nndiary)
+
+
+(defcustom nndiary-request-create-group-hooks nil
+ "*Hooks to run after `nndiary-request-create-group' is executed.
+The hooks will be called with the full group name as argument."
+ :group 'nndiary
+ :type 'hook)
+
+(defcustom nndiary-request-update-info-hooks nil
+ "*Hooks to run after `nndiary-request-update-info-group' is executed.
+The hooks will be called with the full group name as argument."
+ :group 'nndiary
+ :type 'hook)
+
+(defcustom nndiary-request-accept-article-hooks nil
+ "*Hooks to run before accepting an article.
+Executed near the beginning of `nndiary-request-accept-article'.
+The hooks will be called with the article in the current buffer."
+ :group 'nndiary
+ :type 'hook)
+
+(defcustom nndiary-check-directory-twice t
+ "*If t, check directories twice to avoid NFS failures."
+ :group 'nndiary
+ :type 'boolean)
+
+
+;; Backend declaration ======================================================
+
+;; Well, most of this is nnml clonage.
+
+(nnoo-declare nndiary)
+
+(defvoo nndiary-directory (nnheader-concat gnus-directory "diary/")
+ "Spool directory for the nndiary backend.")
+
+(defvoo nndiary-active-file
+ (expand-file-name "active" nndiary-directory)
+ "Active file for the nndiary backend.")
+
+(defvoo nndiary-newsgroups-file
+ (expand-file-name "newsgroups" nndiary-directory)
+ "Newsgroups description file for the nndiary backend.")
+
+(defvoo nndiary-get-new-mail nil
+ "Whether nndiary gets new mail and split it.
+Contrary to traditional mail backends, this variable can be set to t
+even if your primary mail backend also retreives mail. In such a case,
+NDiary uses its own mail-sources and split-methods.")
+
+(defvoo nndiary-nov-is-evil nil
+ "If non-nil, Gnus will never use nov databases for nndiary groups.
+Using nov databases will speed up header fetching considerably.
+This variable shouldn't be flipped much. If you have, for some reason,
+set this to t, and want to set it to nil again, you should always run
+the `nndiary-generate-nov-databases' command. The function will go
+through all nnml directories and generate nov databases for them
+all. This may very well take some time.")
+
+(defvoo nndiary-prepare-save-mail-hook nil
+ "*Hook run narrowed to an article before saving.")
+
+(defvoo nndiary-inhibit-expiry nil
+ "If non-nil, inhibit expiry.")
+
+\f
+
+(defconst nndiary-version "0.2-b14"
+ "Current Diary backend version.")
+
+(defun nndiary-version ()
+ "Current Diary backend version."
+ (interactive)
+ (message "NNDiary version %s" nndiary-version))
+
+(defvoo nndiary-nov-file-name ".overview")
+
+(defvoo nndiary-current-directory nil)
+(defvoo nndiary-current-group nil)
+(defvoo nndiary-status-string "" )
+(defvoo nndiary-nov-buffer-alist nil)
+(defvoo nndiary-group-alist nil)
+(defvoo nndiary-active-timestamp nil)
+(defvoo nndiary-article-file-alist nil)
+
+(defvoo nndiary-generate-active-function 'nndiary-generate-active-info)
+(defvoo nndiary-nov-buffer-file-name nil)
+(defvoo nndiary-file-coding-system nnmail-file-coding-system)
+
+(defconst nndiary-headers
+ '(("Minute" 0 59)
+ ("Hour" 0 23)
+ ("Dom" 1 31)
+ ("Month" 1 12)
+ ("Year" 1971)
+ ("Dow" 0 6)
+ ("Time-Zone" (("Y" -43200)
+
+ ("X" -39600)
+
+ ("W" -36000)
+
+ ("V" -32400)
+
+ ("U" -28800)
+ ("PST" -28800)
+
+ ("T" -25200)
+ ("MST" -25200)
+ ("PDT" -25200)
+
+ ("S" -21600)
+ ("CST" -21600)
+ ("MDT" -21600)
+
+ ("R" -18000)
+ ("EST" -18000)
+ ("CDT" -18000)
+
+ ("Q" -14400)
+ ("AST" -14400)
+ ("EDT" -14400)
+
+ ("P" -10800)
+ ("ADT" -10800)
+
+ ("O" -7200)
+
+ ("N" -3600)
+
+ ("Z" 0)
+ ("GMT" 0)
+ ("UT" 0)
+ ("UTC" 0)
+ ("WET" 0)
+
+ ("A" 3600)
+ ("CET" 3600)
+ ("MET" 3600)
+ ("MEZ" 3600)
+ ("BST" 3600)
+ ("WEST" 3600)
+
+ ("B" 7200)
+ ("EET" 7200)
+ ("CEST" 7200)
+ ("MEST" 7200)
+ ("MESZ" 7200)
+
+ ("C" 10800)
+
+ ("D" 14400)
+
+ ("E" 18000)
+
+ ("F" 21600)
+
+ ("G" 25200)
+
+ ("H" 28800)
+
+ ("I" 32400)
+ ("JST" 32400)
+
+ ("K" 36000)
+ ("GST" 36000)
+
+ ("L" 39600)
+
+ ("M" 43200)
+ ("NZST" 43200)
+
+ ("NZDT" 46800))))
+ ;; List of NNDiary headers that specify the time spec. Each header name is
+ ;; followed by either two integers (specifying a range of possible values
+ ;; for this header) or one list (specifying all the possible values for this
+ ;; header). In the latter case, the list does NOT include the unspecifyed
+ ;; spec (*).
+ ;; For time zone values, we have symbolic time zone names associated with
+ ;; the (relative) number of seconds ahead GMT.
+ )
+
+(defsubst nndiary-schedule ()
+ (let (head)
+ (condition-case arg
+ (mapcar
+ (lambda (elt)
+ (setq head (nth 0 elt))
+ (nndiary-parse-schedule (nth 0 elt) (nth 1 elt) (nth 2 elt)))
+ nndiary-headers)
+ (t
+ (nnheader-report 'nndiary "X-Diary-%s header parse error: %s."
+ head (cdr arg))
+ nil))
+ ))
+
+;;; Interface functions =====================================================
+
+(nnoo-define-basics nndiary)
+
+(deffoo nndiary-retrieve-headers (sequence &optional group server fetch-old)
+ (when (nndiary-possibly-change-directory group server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let* ((file nil)
+ (number (length sequence))
+ (count 0)
+ (file-name-coding-system nnmail-pathname-coding-system)
+ beg article
+ (nndiary-check-directory-twice
+ (and nndiary-check-directory-twice
+ ;; To speed up, disable it in some case.
+ (or (not (numberp nnmail-large-newsgroup))
+ (<= number nnmail-large-newsgroup)))))
+ (if (stringp (car sequence))
+ 'headers
+ (if (nndiary-retrieve-headers-with-nov sequence fetch-old)
+ 'nov
+ (while sequence
+ (setq article (car sequence))
+ (setq file (nndiary-article-to-file article))
+ (when (and file
+ (file-exists-p file)
+ (not (file-directory-p file)))
+ (insert (format "221 %d Article retrieved.\n" article))
+ (setq beg (point))
+ (nnheader-insert-head file)
+ (goto-char beg)
+ (if (search-forward "\n\n" nil t)
+ (forward-char -1)
+ (goto-char (point-max))
+ (insert "\n\n"))
+ (insert ".\n")
+ (delete-region (point) (point-max)))
+ (setq sequence (cdr sequence))
+ (setq count (1+ count))
+ (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)
+ (zerop (% count 20))
+ (nnheader-message 6 "nndiary: Receiving headers... %d%%"
+ (/ (* count 100) number))))
+
+ (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)
+ (nnheader-message 6 "nndiary: Receiving headers...done"))
+
+ (nnheader-fold-continuation-lines)
+ 'headers))))))
+
+(deffoo nndiary-open-server (server &optional defs)
+ (nnoo-change-server 'nndiary server defs)
+ (when (not (file-exists-p nndiary-directory))
+ (ignore-errors (make-directory nndiary-directory t)))
+ (cond
+ ((not (file-exists-p nndiary-directory))
+ (nndiary-close-server)
+ (nnheader-report 'nndiary "Couldn't create directory: %s"
+ nndiary-directory))
+ ((not (file-directory-p (file-truename nndiary-directory)))
+ (nndiary-close-server)
+ (nnheader-report 'nndiary "Not a directory: %s" nndiary-directory))
+ (t
+ (nnheader-report 'nndiary "Opened server %s using directory %s"
+ server nndiary-directory)
+ t)))
+
+(deffoo nndiary-request-regenerate (server)
+ (nndiary-possibly-change-directory nil server)
+ (nndiary-generate-nov-databases server)
+ t)
+
+(deffoo nndiary-request-article (id &optional group server buffer)
+ (nndiary-possibly-change-directory group server)
+ (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ path gpath group-num)
+ (if (stringp id)
+ (when (and (setq group-num (nndiary-find-group-number id))
+ (cdr
+ (assq (cdr group-num)
+ (nnheader-article-to-file-alist
+ (setq gpath
+ (nnmail-group-pathname
+ (car group-num)
+ nndiary-directory))))))
+ (setq path (concat gpath (int-to-string (cdr group-num)))))
+ (setq path (nndiary-article-to-file id)))
+ (cond
+ ((not path)
+ (nnheader-report 'nndiary "No such article: %s" id))
+ ((not (file-exists-p path))
+ (nnheader-report 'nndiary "No such file: %s" path))
+ ((file-directory-p path)
+ (nnheader-report 'nndiary "File is a directory: %s" path))
+ ((not (save-excursion (let ((nnmail-file-coding-system
+ nndiary-file-coding-system))
+ (nnmail-find-file path))))
+ (nnheader-report 'nndiary "Couldn't read file: %s" path))
+ (t
+ (nnheader-report 'nndiary "Article %s retrieved" id)
+ ;; We return the article number.
+ (cons (if group-num (car group-num) group)
+ (string-to-int (file-name-nondirectory path)))))))
+
+(deffoo nndiary-request-group (group &optional server dont-check)
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (cond
+ ((not (nndiary-possibly-change-directory group server))
+ (nnheader-report 'nndiary "Invalid group (no such directory)"))
+ ((not (file-exists-p nndiary-current-directory))
+ (nnheader-report 'nndiary "Directory %s does not exist"
+ nndiary-current-directory))
+ ((not (file-directory-p nndiary-current-directory))
+ (nnheader-report 'nndiary "%s is not a directory"
+ nndiary-current-directory))
+ (dont-check
+ (nnheader-report 'nndiary "Group %s selected" group)
+ t)
+ (t
+ (nnheader-re-read-dir nndiary-current-directory)
+ (nnmail-activate 'nndiary)
+ (let ((active (nth 1 (assoc group nndiary-group-alist))))
+ (if (not active)
+ (nnheader-report 'nndiary "No such group: %s" group)
+ (nnheader-report 'nndiary "Selected group %s" group)
+ (nnheader-insert "211 %d %d %d %s\n"
+ (max (1+ (- (cdr active) (car active))) 0)
+ (car active) (cdr active) group)))))))
+
+(deffoo nndiary-request-scan (&optional group server)
+ ;; Use our own mail sources and split methods while Gnus doesn't let us have
+ ;; multiple backends for retrieving mail.
+ (let ((mail-sources nndiary-mail-sources)
+ (nnmail-split-methods nndiary-split-methods))
+ (setq nndiary-article-file-alist nil)
+ (nndiary-possibly-change-directory group server)
+ (nnmail-get-new-mail 'nndiary 'nndiary-save-nov nndiary-directory group)))
+
+(deffoo nndiary-close-group (group &optional server)
+ (setq nndiary-article-file-alist nil)
+ t)
+
+(deffoo nndiary-request-create-group (group &optional server args)
+ (nndiary-possibly-change-directory nil server)
+ (nnmail-activate 'nndiary)
+ (cond
+ ((assoc group nndiary-group-alist)
+ t)
+ ((and (file-exists-p (nnmail-group-pathname group nndiary-directory))
+ (not (file-directory-p (nnmail-group-pathname
+ group nndiary-directory))))
+ (nnheader-report 'nndiary "%s is a file"
+ (nnmail-group-pathname group nndiary-directory)))
+ (t
+ (let (active)
+ (push (list group (setq active (cons 1 0)))
+ nndiary-group-alist)
+ (nndiary-possibly-create-directory group)
+ (nndiary-possibly-change-directory group server)
+ (let ((articles (nnheader-directory-articles nndiary-current-directory)))
+ (when articles
+ (setcar active (apply 'min articles))
+ (setcdr active (apply 'max articles))))
+ (nnmail-save-active nndiary-group-alist nndiary-active-file)
+ (run-hook-with-args 'nndiary-request-create-group-hooks
+ (gnus-group-prefixed-name group
+ (list "nndiary" server)))
+ t))
+ ))
+
+(deffoo nndiary-request-list (&optional server)
+ (save-excursion
+ (let ((nnmail-file-coding-system nnmail-active-file-coding-system)
+ (file-name-coding-system nnmail-pathname-coding-system))
+ (nnmail-find-file nndiary-active-file))
+ (setq nndiary-group-alist (nnmail-get-active))
+ t))
+
+(deffoo nndiary-request-newgroups (date &optional server)
+ (nndiary-request-list server))
+
+(deffoo nndiary-request-list-newsgroups (&optional server)
+ (save-excursion
+ (nnmail-find-file nndiary-newsgroups-file)))
+
+(deffoo nndiary-request-expire-articles (articles group &optional server force)
+ (nndiary-possibly-change-directory group server)
+ (let ((active-articles
+ (nnheader-directory-articles nndiary-current-directory))
+ article rest number)
+ (nnmail-activate 'nndiary)
+ ;; Articles not listed in active-articles are already gone,
+ ;; so don't try to expire them.
+ (setq articles (gnus-intersection articles active-articles))
+ (while articles
+ (setq article (nndiary-article-to-file (setq number (pop articles))))
+ (if (and (nndiary-deletable-article-p group number)
+ ;; Don't use nnmail-expired-article-p. Our notion of expiration
+ ;; is a bit peculiar ...
+ (or force (nndiary-expired-article-p article)))
+ (progn
+ ;; Allow a special target group.
+ (unless (eq nnmail-expiry-target 'delete)
+ (with-temp-buffer
+ (nndiary-request-article number group server (current-buffer))
+ (let ((nndiary-current-directory nil))
+ (nnmail-expiry-target-group nnmail-expiry-target group)))
+ (nndiary-possibly-change-directory group server))
+ (nnheader-message 5 "Deleting article %s in %s" number group)
+ (condition-case ()
+ (funcall nnmail-delete-file-function article)
+ (file-error (push number rest)))
+ (setq active-articles (delq number active-articles))
+ (nndiary-nov-delete-article group number))
+ (push number rest)))
+ (let ((active (nth 1 (assoc group nndiary-group-alist))))
+ (when active
+ (setcar active (or (and active-articles
+ (apply 'min active-articles))
+ (1+ (cdr active)))))
+ (nnmail-save-active nndiary-group-alist nndiary-active-file))
+ (nndiary-save-nov)
+ (nconc rest articles)))
+
+(deffoo nndiary-request-move-article
+ (article group server accept-form &optional last)
+ (let ((buf (get-buffer-create " *nndiary move*"))
+ result)
+ (nndiary-possibly-change-directory group server)
+ (nndiary-update-file-alist)
+ (and
+ (nndiary-deletable-article-p group article)
+ (nndiary-request-article article group server)
+ (let (nndiary-current-directory
+ nndiary-current-group
+ nndiary-article-file-alist)
+ (save-excursion
+ (set-buffer buf)
+ (insert-buffer-substring nntp-server-buffer)
+ (setq result (eval accept-form))
+ (kill-buffer (current-buffer))
+ result))
+ (progn
+ (nndiary-possibly-change-directory group server)
+ (condition-case ()
+ (funcall nnmail-delete-file-function
+ (nndiary-article-to-file article))
+ (file-error nil))
+ (nndiary-nov-delete-article group article)
+ (when last
+ (nndiary-save-nov)
+ (nnmail-save-active nndiary-group-alist nndiary-active-file))))
+ result))
+
+(deffoo nndiary-request-accept-article (group &optional server last)
+ (nndiary-possibly-change-directory group server)
+ (nnmail-check-syntax)
+ (run-hooks 'nndiary-request-accept-article-hooks)
+ (when (nndiary-schedule)
+ (let (result)
+ (when nnmail-cache-accepted-message-ids
+ (nnmail-cache-insert (nnmail-fetch-field "message-id") group))
+ (if (stringp group)
+ (and
+ (nnmail-activate 'nndiary)
+ (setq result
+ (car (nndiary-save-mail
+ (list (cons group (nndiary-active-number group))))))
+ (progn
+ (nnmail-save-active nndiary-group-alist nndiary-active-file)
+ (and last (nndiary-save-nov))))
+ (and
+ (nnmail-activate 'nndiary)
+ (if (and (not (setq result
+ (nnmail-article-group 'nndiary-active-number)))
+ (yes-or-no-p "Moved to `junk' group; delete article? "))
+ (setq result 'junk)
+ (setq result (car (nndiary-save-mail result))))
+ (when last
+ (nnmail-save-active nndiary-group-alist nndiary-active-file)
+ (when nnmail-cache-accepted-message-ids
+ (nnmail-cache-close))
+ (nndiary-save-nov))))
+ result))
+ )
+
+(deffoo nndiary-request-post (&optional server)
+ (nnmail-do-request-post 'nndiary-request-accept-article server))
+
+(deffoo nndiary-request-replace-article (article group buffer)
+ (nndiary-possibly-change-directory group)
+ (save-excursion
+ (set-buffer buffer)
+ (nndiary-possibly-create-directory group)
+ (let ((chars (nnmail-insert-lines))
+ (art (concat (int-to-string article) "\t"))
+ headers)
+ (when (ignore-errors
+ (nnmail-write-region
+ (point-min) (point-max)
+ (or (nndiary-article-to-file article)
+ (expand-file-name (int-to-string article)
+ nndiary-current-directory))
+ nil (if (nnheader-be-verbose 5) nil 'nomesg))
+ t)
+ (setq headers (nndiary-parse-head chars article))
+ ;; Replace the NOV line in the NOV file.
+ (save-excursion
+ (set-buffer (nndiary-open-nov group))
+ (goto-char (point-min))
+ (if (or (looking-at art)
+ (search-forward (concat "\n" art) nil t))
+ ;; Delete the old NOV line.
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point)))
+ ;; The line isn't here, so we have to find out where
+ ;; we should insert it. (This situation should never
+ ;; occur, but one likes to make sure...)
+ (while (and (looking-at "[0-9]+\t")
+ (< (string-to-int
+ (buffer-substring
+ (match-beginning 0) (match-end 0)))
+ article)
+ (zerop (forward-line 1)))))
+ (beginning-of-line)
+ (nnheader-insert-nov headers)
+ (nndiary-save-nov)
+ t)))))
+
+(deffoo nndiary-request-delete-group (group &optional force server)
+ (nndiary-possibly-change-directory group server)
+ (when force
+ ;; Delete all articles in GROUP.
+ (let ((articles
+ (directory-files
+ nndiary-current-directory t
+ (concat nnheader-numerical-short-files
+ "\\|" (regexp-quote nndiary-nov-file-name) "$")))
+ article)
+ (while articles
+ (setq article (pop articles))
+ (when (file-writable-p article)
+ (nnheader-message 5 "Deleting article %s in %s..." article group)
+ (funcall nnmail-delete-file-function article))))
+ ;; Try to delete the directory itself.
+ (ignore-errors (delete-directory nndiary-current-directory)))
+ ;; Remove the group from all structures.
+ (setq nndiary-group-alist
+ (delq (assoc group nndiary-group-alist) nndiary-group-alist)
+ nndiary-current-group nil
+ nndiary-current-directory nil)
+ ;; Save the active file.
+ (nnmail-save-active nndiary-group-alist nndiary-active-file)
+ t)
+
+(deffoo nndiary-request-rename-group (group new-name &optional server)
+ (nndiary-possibly-change-directory group server)
+ (let ((new-dir (nnmail-group-pathname new-name nndiary-directory))
+ (old-dir (nnmail-group-pathname group nndiary-directory)))
+ (when (ignore-errors
+ (make-directory new-dir t)
+ t)
+ ;; We move the articles file by file instead of renaming
+ ;; the directory -- there may be subgroups in this group.
+ ;; One might be more clever, I guess.
+ (let ((files (nnheader-article-to-file-alist old-dir)))
+ (while files
+ (rename-file
+ (concat old-dir (cdar files))
+ (concat new-dir (cdar files)))
+ (pop files)))
+ ;; Move .overview file.
+ (let ((overview (concat old-dir nndiary-nov-file-name)))
+ (when (file-exists-p overview)
+ (rename-file overview (concat new-dir nndiary-nov-file-name))))
+ (when (<= (length (directory-files old-dir)) 2)
+ (ignore-errors (delete-directory old-dir)))
+ ;; That went ok, so we change the internal structures.
+ (let ((entry (assoc group nndiary-group-alist)))
+ (when entry
+ (setcar entry new-name))
+ (setq nndiary-current-directory nil
+ nndiary-current-group nil)
+ ;; Save the new group alist.
+ (nnmail-save-active nndiary-group-alist nndiary-active-file)
+ t))))
+
+(deffoo nndiary-set-status (article name value &optional group server)
+ (nndiary-possibly-change-directory group server)
+ (let ((file (nndiary-article-to-file article)))
+ (cond
+ ((not (file-exists-p file))
+ (nnheader-report 'nndiary "File %s does not exist" file))
+ (t
+ (with-temp-file file
+ (nnheader-insert-file-contents file)
+ (nnmail-replace-status name value))
+ t))))
+
+\f
+;;; Interface optional functions ============================================
+
+(deffoo nndiary-request-update-info (group info &optional server)
+ (nndiary-possibly-change-directory group)
+ (let ((timestamp (gnus-group-parameter-value (gnus-info-params info)
+ 'timestamp t)))
+ (if (not timestamp)
+ (nnheader-report 'nndiary "Group %s doesn't have a timestamp" group)
+ ;; else
+ ;; Figure out which articles should be re-new'ed
+ (let ((articles (nndiary-flatten (gnus-info-read info) 0))
+ article file unread buf)
+ (save-excursion
+ (setq buf (nnheader-set-temp-buffer " *nndiary update*"))
+ (while (setq article (pop articles))
+ (setq file (concat nndiary-current-directory
+ (int-to-string article)))
+ (and (file-exists-p file)
+ (nndiary-renew-article-p file timestamp)
+ (push article unread)))
+ ;;(message "unread: %s" unread)
+ (sit-for 1)
+ (kill-buffer buf))
+ (setq unread (sort unread '<))
+ (and unread
+ (gnus-info-set-read info (gnus-update-read-articles
+ (gnus-info-group info) unread t)))
+ ))
+ (run-hook-with-args 'nndiary-request-update-info-hooks
+ (gnus-info-group info))
+ t))
+
+
+\f
+;;; Internal functions ======================================================
+
+(defun nndiary-article-to-file (article)
+ (nndiary-update-file-alist)
+ (let (file)
+ (if (setq file (cdr (assq article nndiary-article-file-alist)))
+ (expand-file-name file nndiary-current-directory)
+ ;; Just to make sure nothing went wrong when reading over NFS --
+ ;; check once more.
+ (if nndiary-check-directory-twice
+ (when (file-exists-p
+ (setq file (expand-file-name (number-to-string article)
+ nndiary-current-directory)))
+ (nndiary-update-file-alist t)
+ file)))))
+
+(defun nndiary-deletable-article-p (group article)
+ "Say whether ARTICLE in GROUP can be deleted."
+ (let (path)
+ (when (setq path (nndiary-article-to-file article))
+ (when (file-writable-p path)
+ (or (not nnmail-keep-last-article)
+ (not (eq (cdr (nth 1 (assoc group nndiary-group-alist)))
+ article)))))))
+
+;; Find an article number in the current group given the Message-ID.
+(defun nndiary-find-group-number (id)
+ (save-excursion
+ (set-buffer (get-buffer-create " *nndiary id*"))
+ (let ((alist nndiary-group-alist)
+ number)
+ ;; We want to look through all .overview files, but we want to
+ ;; start with the one in the current directory. It seems most
+ ;; likely that the article we are looking for is in that group.
+ (if (setq number (nndiary-find-id nndiary-current-group id))
+ (cons nndiary-current-group number)
+ ;; It wasn't there, so we look through the other groups as well.
+ (while (and (not number)
+ alist)
+ (or (string= (caar alist) nndiary-current-group)
+ (setq number (nndiary-find-id (caar alist) id)))
+ (or number
+ (setq alist (cdr alist))))
+ (and number
+ (cons (caar alist) number))))))
+
+(defun nndiary-find-id (group id)
+ (erase-buffer)
+ (let ((nov (expand-file-name nndiary-nov-file-name
+ (nnmail-group-pathname group
+ nndiary-directory)))
+ number found)
+ (when (file-exists-p nov)
+ (nnheader-insert-file-contents nov)
+ (while (and (not found)
+ (search-forward id nil t)) ; We find the ID.
+ ;; And the id is in the fourth field.
+ (if (not (and (search-backward "\t" nil t 4)
+ (not (search-backward"\t" (gnus-point-at-bol) t))))
+ (forward-line 1)
+ (beginning-of-line)
+ (setq found t)
+ ;; We return the article number.
+ (setq number
+ (ignore-errors (read (current-buffer))))))
+ number)))
+
+(defun nndiary-retrieve-headers-with-nov (articles &optional fetch-old)
+ (if (or gnus-nov-is-evil nndiary-nov-is-evil)
+ nil
+ (let ((nov (expand-file-name nndiary-nov-file-name
+ nndiary-current-directory)))
+ (when (file-exists-p nov)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (nnheader-insert-file-contents nov)
+ (if (and fetch-old
+ (not (numberp fetch-old)))
+ t ; Don't remove anything.
+ (nnheader-nov-delete-outside-range
+ (if fetch-old (max 1 (- (car articles) fetch-old))
+ (car articles))
+ (car (last articles)))
+ t))))))
+
+(defun nndiary-possibly-change-directory (group &optional server)
+ (when (and server
+ (not (nndiary-server-opened server)))
+ (nndiary-open-server server))
+ (if (not group)
+ t
+ (let ((pathname (nnmail-group-pathname group nndiary-directory))
+ (file-name-coding-system nnmail-pathname-coding-system))
+ (when (not (equal pathname nndiary-current-directory))
+ (setq nndiary-current-directory pathname
+ nndiary-current-group group
+ nndiary-article-file-alist nil))
+ (file-exists-p nndiary-current-directory))))
+
+(defun nndiary-possibly-create-directory (group)
+ (let ((dir (nnmail-group-pathname group nndiary-directory)))
+ (unless (file-exists-p dir)
+ (make-directory (directory-file-name dir) t)
+ (nnheader-message 5 "Creating mail directory %s" dir))))
+
+(defun nndiary-save-mail (group-art)
+ "Called narrowed to an article."
+ (let (chars headers)
+ (setq chars (nnmail-insert-lines))
+ (nnmail-insert-xref group-art)
+ (run-hooks 'nnmail-prepare-save-mail-hook)
+ (run-hooks 'nndiary-prepare-save-mail-hook)
+ (goto-char (point-min))
+ (while (looking-at "From ")
+ (replace-match "X-From-Line: ")
+ (forward-line 1))
+ ;; We save the article in all the groups it belongs in.
+ (let ((ga group-art)
+ first)
+ (while ga
+ (nndiary-possibly-create-directory (caar ga))
+ (let ((file (concat (nnmail-group-pathname
+ (caar ga) nndiary-directory)
+ (int-to-string (cdar ga)))))
+ (if first
+ ;; It was already saved, so we just make a hard link.
+ (funcall nnmail-crosspost-link-function first file t)
+ ;; Save the article.
+ (nnmail-write-region (point-min) (point-max) file nil
+ (if (nnheader-be-verbose 5) nil 'nomesg))
+ (setq first file)))
+ (setq ga (cdr ga))))
+ ;; Generate a nov line for this article. We generate the nov
+ ;; line after saving, because nov generation destroys the
+ ;; header.
+ (setq headers (nndiary-parse-head chars))
+ ;; Output the nov line to all nov databases that should have it.
+ (let ((ga group-art))
+ (while ga
+ (nndiary-add-nov (caar ga) (cdar ga) headers)
+ (setq ga (cdr ga))))
+ group-art))
+
+(defun nndiary-active-number (group)
+ "Compute the next article number in GROUP."
+ (let ((active (cadr (assoc group nndiary-group-alist))))
+ ;; The group wasn't known to nndiary, so we just create an active
+ ;; entry for it.
+ (unless active
+ ;; Perhaps the active file was corrupt? See whether
+ ;; there are any articles in this group.
+ (nndiary-possibly-create-directory group)
+ (nndiary-possibly-change-directory group)
+ (unless nndiary-article-file-alist
+ (setq nndiary-article-file-alist
+ (sort
+ (nnheader-article-to-file-alist nndiary-current-directory)
+ 'car-less-than-car)))
+ (setq active
+ (if nndiary-article-file-alist
+ (cons (caar nndiary-article-file-alist)
+ (caar (last nndiary-article-file-alist)))
+ (cons 1 0)))
+ (push (list group active) nndiary-group-alist))
+ (setcdr active (1+ (cdr active)))
+ (while (file-exists-p
+ (expand-file-name (int-to-string (cdr active))
+ (nnmail-group-pathname group nndiary-directory)))
+ (setcdr active (1+ (cdr active))))
+ (cdr active)))
+
+(defun nndiary-add-nov (group article headers)
+ "Add a nov line for the GROUP base."
+ (save-excursion
+ (set-buffer (nndiary-open-nov group))
+ (goto-char (point-max))
+ (mail-header-set-number headers article)
+ (nnheader-insert-nov headers)))
+
+(defsubst nndiary-header-value ()
+ (buffer-substring (match-end 0) (progn (end-of-line) (point))))
+
+(defun nndiary-parse-head (chars &optional number)
+ "Parse the head of the current buffer."
+ (save-excursion
+ (save-restriction
+ (unless (zerop (buffer-size))
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t) (1- (point)) (point-max))))
+ (let ((headers (nnheader-parse-naked-head)))
+ (mail-header-set-chars headers chars)
+ (mail-header-set-number headers number)
+ headers))))
+
+(defun nndiary-open-nov (group)
+ (or (cdr (assoc group nndiary-nov-buffer-alist))
+ (let ((buffer (get-buffer-create (format " *nndiary overview %s*"
+ group))))
+ (save-excursion
+ (set-buffer buffer)
+ (set (make-local-variable 'nndiary-nov-buffer-file-name)
+ (expand-file-name
+ nndiary-nov-file-name
+ (nnmail-group-pathname group nndiary-directory)))
+ (erase-buffer)
+ (when (file-exists-p nndiary-nov-buffer-file-name)
+ (nnheader-insert-file-contents nndiary-nov-buffer-file-name)))
+ (push (cons group buffer) nndiary-nov-buffer-alist)
+ buffer)))
+
+(defun nndiary-save-nov ()
+ (save-excursion
+ (while nndiary-nov-buffer-alist
+ (when (buffer-name (cdar nndiary-nov-buffer-alist))
+ (set-buffer (cdar nndiary-nov-buffer-alist))
+ (when (buffer-modified-p)
+ (nnmail-write-region 1 (point-max) nndiary-nov-buffer-file-name
+ nil 'nomesg))
+ (set-buffer-modified-p nil)
+ (kill-buffer (current-buffer)))
+ (setq nndiary-nov-buffer-alist (cdr nndiary-nov-buffer-alist)))))
+
+;;;###autoload
+(defun nndiary-generate-nov-databases (&optional server)
+ "Generate NOV databases in all nndiary directories."
+ (interactive (list (or (nnoo-current-server 'nndiary) "")))
+ ;; Read the active file to make sure we don't re-use articles
+ ;; numbers in empty groups.
+ (nnmail-activate 'nndiary)
+ (unless (nndiary-server-opened server)
+ (nndiary-open-server server))
+ (setq nndiary-directory (expand-file-name nndiary-directory))
+ ;; Recurse down the directories.
+ (nndiary-generate-nov-databases-1 nndiary-directory nil t)
+ ;; Save the active file.
+ (nnmail-save-active nndiary-group-alist nndiary-active-file))
+
+(defun nndiary-generate-nov-databases-1 (dir &optional seen no-active)
+ "Regenerate the NOV database in DIR."
+ (interactive "DRegenerate NOV in: ")
+ (setq dir (file-name-as-directory dir))
+ ;; Only scan this sub-tree if we haven't been here yet.
+ (unless (member (file-truename dir) seen)
+ (push (file-truename dir) seen)
+ ;; We descend recursively
+ (let ((dirs (directory-files dir t nil t))
+ dir)
+ (while (setq dir (pop dirs))
+ (when (and (not (string-match "^\\." (file-name-nondirectory dir)))
+ (file-directory-p dir))
+ (nndiary-generate-nov-databases-1 dir seen))))
+ ;; Do this directory.
+ (let ((files (sort (nnheader-article-to-file-alist dir)
+ 'car-less-than-car)))
+ (if (not files)
+ (let* ((group (nnheader-file-to-group
+ (directory-file-name dir) nndiary-directory))
+ (info (cadr (assoc group nndiary-group-alist))))
+ (when info
+ (setcar info (1+ (cdr info)))))
+ (funcall nndiary-generate-active-function dir)
+ ;; Generate the nov file.
+ (nndiary-generate-nov-file dir files)
+ (unless no-active
+ (nnmail-save-active nndiary-group-alist nndiary-active-file))))))
+
+(eval-when-compile (defvar files))
+(defun nndiary-generate-active-info (dir)
+ ;; Update the active info for this group.
+ (let* ((group (nnheader-file-to-group
+ (directory-file-name dir) nndiary-directory))
+ (entry (assoc group nndiary-group-alist))
+ (last (or (caadr entry) 0)))
+ (setq nndiary-group-alist (delq entry nndiary-group-alist))
+ (push (list group
+ (cons (or (caar files) (1+ last))
+ (max last
+ (or (let ((f files))
+ (while (cdr f) (setq f (cdr f)))
+ (caar f))
+ 0))))
+ nndiary-group-alist)))
+
+(defun nndiary-generate-nov-file (dir files)
+ (let* ((dir (file-name-as-directory dir))
+ (nov (concat dir nndiary-nov-file-name))
+ (nov-buffer (get-buffer-create " *nov*"))
+ chars file headers)
+ (save-excursion
+ ;; Init the nov buffer.
+ (set-buffer nov-buffer)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (set-buffer nntp-server-buffer)
+ ;; Delete the old NOV file.
+ (when (file-exists-p nov)
+ (funcall nnmail-delete-file-function nov))
+ (while files
+ (unless (file-directory-p (setq file (concat dir (cdar files))))
+ (erase-buffer)
+ (nnheader-insert-file-contents file)
+ (narrow-to-region
+ (goto-char (point-min))
+ (progn
+ (search-forward "\n\n" nil t)
+ (setq chars (- (point-max) (point)))
+ (max 1 (1- (point)))))
+ (unless (zerop (buffer-size))
+ (goto-char (point-min))
+ (setq headers (nndiary-parse-head chars (caar files)))
+ (save-excursion
+ (set-buffer nov-buffer)
+ (goto-char (point-max))
+ (nnheader-insert-nov headers)))
+ (widen))
+ (setq files (cdr files)))
+ (save-excursion
+ (set-buffer nov-buffer)
+ (nnmail-write-region 1 (point-max) nov nil 'nomesg)
+ (kill-buffer (current-buffer))))))
+
+(defun nndiary-nov-delete-article (group article)
+ (save-excursion
+ (set-buffer (nndiary-open-nov group))
+ (when (nnheader-find-nov-line article)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (when (bobp)
+ (let ((active (cadr (assoc group nndiary-group-alist)))
+ num)
+ (when active
+ (if (eobp)
+ (setf (car active) (1+ (cdr active)))
+ (when (and (setq num (ignore-errors (read (current-buffer))))
+ (numberp num))
+ (setf (car active) num)))))))
+ t))
+
+(defun nndiary-update-file-alist (&optional force)
+ (when (or (not nndiary-article-file-alist)
+ force)
+ (setq nndiary-article-file-alist
+ (nnheader-article-to-file-alist nndiary-current-directory))))
+
+
+(defun nndiary-string-to-int (str min &optional max)
+ ;; Like `string-to-int' but barf if STR is not exactly an integer, and not
+ ;; within the specified bounds.
+ ;; Signals are caught by `nndiary-schedule'.
+ (if (not (string-match "^[ \t]*[0-9]+[ \t]*$" str))
+ (nndiary-error "not an integer value")
+ ;; else
+ (let ((val (string-to-int str)))
+ (and (or (< val min)
+ (and max (> val max)))
+ (nndiary-error "value out of range"))
+ val)))
+
+(defun nndiary-parse-schedule-value (str min-or-values max)
+ ;; Parse the schedule string STR, or signal an error.
+ ;; Signals are caught by `nndary-schedule'.
+ (if (string-match "[ \t]*\\*[ \t]*" str)
+ ;; unspecifyed
+ nil
+ ;; specifyed
+ (if (listp min-or-values)
+ ;; min-or-values is values
+ ;; #### NOTE: this is actually only a hack for time zones.
+ (let ((val (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" str)
+ (match-string 1 str))))
+ (if (and val (setq val (assoc val min-or-values)))
+ (list (cadr val))
+ (nndiary-error "invalid syntax")))
+ ;; min-or-values is min
+ (mapcar
+ (lambda (val)
+ (let ((res (split-string val "-")))
+ (cond
+ ((= (length res) 1)
+ (nndiary-string-to-int (car res) min-or-values max))
+ ((= (length res) 2)
+ ;; don't know if crontab accepts this, but ensure
+ ;; that BEG is <= END
+ (let ((beg (nndiary-string-to-int (car res) min-or-values max))
+ (end (nndiary-string-to-int (cadr res) min-or-values max)))
+ (cond ((< beg end)
+ (cons beg end))
+ ((= beg end)
+ beg)
+ (t
+ (cons end beg)))))
+ (t
+ (nndiary-error "invalid syntax")))
+ ))
+ (split-string str ",")))
+ ))
+
+;; ### FIXME: remove this function if it's used only once.
+(defun nndiary-parse-schedule (head min-or-values max)
+ ;; Parse the cron-like value of header X-Diary-HEAD in current buffer.
+ ;; - Returns nil if `*'
+ ;; - Otherwise returns a list of integers and/or ranges (BEG . END)
+ ;; The exception is the Timze-Zone value which is always of the form (STR).
+ ;; Signals are caught by `nndary-schedule'.
+ (let ((header (format "^X-Diary-%s: \\(.*\\)$" head)))
+ (goto-char (point-min))
+ (if (not (re-search-forward header nil t))
+ (nndiary-error "header missing")
+ ;; else
+ (nndiary-parse-schedule-value (match-string 1) min-or-values max))
+ ))
+
+(defun nndiary-max (spec)
+ ;; Returns the max of specification SPEC, or nil for permanent schedules.
+ (unless (null spec)
+ (let ((elts spec)
+ (max 0)
+ elt)
+ (while (setq elt (pop elts))
+ (if (integerp elt)
+ (and (> elt max) (setq max elt))
+ (and (> (cdr elt) max) (setq max (cdr elt)))))
+ max)))
+
+(defun nndiary-flatten (spec min &optional max)
+ ;; flatten the spec by expanding ranges to all possible values.
+ (let (flat n)
+ (cond ((null spec)
+ ;; this happens when I flatten something else than one of my
+ ;; schedules (a list of read articles for instance).
+ (unless (null max)
+ (setq n min)
+ (while (<= n max)
+ (push n flat)
+ (setq n (1+ n)))))
+ (t
+ (let ((elts spec)
+ elt)
+ (while (setq elt (pop elts))
+ (if (integerp elt)
+ (push elt flat)
+ ;; else
+ (setq n (car elt))
+ (while (<= n (cdr elt))
+ (push n flat)
+ (setq n (1+ n))))))))
+ flat))
+
+(defun nndiary-unflatten (spec)
+ ;; opposite of flatten: build ranges if possible
+ (setq spec (sort spec '<))
+ (let (min max res)
+ (while (setq min (pop spec))
+ (setq max min)
+ (while (and (car spec) (= (car spec) (1+ max)))
+ (setq max (1+ max))
+ (pop spec))
+ (if (= max min)
+ (setq res (append res (list min)))
+ (setq res (append res (list (cons min max))))))
+ res))
+
+(defun nndiary-compute-reminders (date)
+ ;; Returns a list of times corresponding to the reminders of date DATE.
+ ;; See the comment in `nndiary-reminders' about rounding.
+ (let* ((reminders nndiary-reminders)
+ (date-elts (decode-time date))
+ ;; ### NOTE: out-of-range values are accepted by encode-time. This
+ ;; makes our life easier.
+ (monday (- (nth 3 date-elts)
+ (if nndiary-week-starts-on-monday
+ (if (zerop (nth 6 date-elts))
+ 6
+ (- (nth 6 date-elts) 1))
+ (nth 6 date-elts))))
+ reminder res)
+ ;; remove the DOW and DST entries
+ (setcdr (nthcdr 5 date-elts) (nthcdr 8 date-elts))
+ (while (setq reminder (pop reminders))
+ (push
+ (cond ((eq (cdr reminder) 'minute)
+ (subtract-time
+ (apply 'encode-time 0 (nthcdr 1 date-elts))
+ (seconds-to-time (* (car reminder) 60.0))))
+ ((eq (cdr reminder) 'hour)
+ (subtract-time
+ (apply 'encode-time 0 0 (nthcdr 2 date-elts))
+ (seconds-to-time (* (car reminder) 3600.0))))
+ ((eq (cdr reminder) 'day)
+ (subtract-time
+ (apply 'encode-time 0 0 0 (nthcdr 3 date-elts))
+ (seconds-to-time (* (car reminder) 86400.0))))
+ ((eq (cdr reminder) 'week)
+ (subtract-time
+ (apply 'encode-time 0 0 0 monday (nthcdr 4 date-elts))
+ (seconds-to-time (* (car reminder) 604800.0))))
+ ((eq (cdr reminder) 'month)
+ (subtract-time
+ (apply 'encode-time 0 0 0 1 (nthcdr 4 date-elts))
+ (seconds-to-time (* (car reminder) 18748800.0))))
+ ((eq (cdr reminder) 'year)
+ (subtract-time
+ (apply 'encode-time 0 0 0 1 1 (nthcdr 5 date-elts))
+ (seconds-to-time (* (car reminder) 400861056.0)))))
+ res))
+ (sort res 'time-less-p)))
+
+(defun nndiary-last-occurence (sched)
+ ;; Returns the last occurence of schedule SCHED as an Emacs time struct, or
+ ;; nil for permanent schedule or errors.
+ (let ((minute (nndiary-max (nth 0 sched)))
+ (hour (nndiary-max (nth 1 sched)))
+ (year (nndiary-max (nth 4 sched)))
+ (time-zone (or (and (nth 6 sched) (car (nth 6 sched)))
+ (current-time-zone))))
+ (when year
+ (or minute (setq minute 59))
+ (or hour (setq hour 23))
+ ;; I'll just compute all possible values and test them by decreasing
+ ;; order until one succeeds. This is probably quide rude, but I got
+ ;; bored in finding a good algorithm for doing that ;-)
+ ;; ### FIXME: remove identical entries.
+ (let ((dom-list (nth 2 sched))
+ (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) '>))
+ (year-list (sort (nndiary-flatten (nth 4 sched) 1971) '>))
+ (dow-list (nth 5 sched)))
+ ;; Special case: an asterisk in one of the days specifications means
+ ;; that only the other should be taken into account. If both are
+ ;; unspecified, you would get all possible days in both.
+ (cond ((null dow-list)
+ ;; this gets all days if dom-list is nil
+ (setq dom-list (nndiary-flatten dom-list 1 31)))
+ ((null dom-list)
+ ;; this also gets all days if dow-list is nil
+ (setq dow-list (nndiary-flatten dow-list 0 6)))
+ (t
+ (setq dom-list (nndiary-flatten dom-list 1 31))
+ (setq dow-list (nndiary-flatten dow-list 0 6))))
+ (or
+ (catch 'found
+ (while (setq year (pop year-list))
+ (let ((months month-list)
+ month)
+ (while (setq month (pop months))
+ ;; Now we must merge the Dows with the Doms. To do that, we
+ ;; have to know which day is the 1st one for this month.
+ ;; Maybe there's simpler, but decode-time(encode-time) will
+ ;; give us the answer.
+ (let ((first (nth 6 (decode-time
+ (encode-time 0 0 0 1 month year
+ time-zone))))
+ (max (cond ((= month 2)
+ (if (date-leap-year-p year) 29 28))
+ ((<= month 7)
+ (if (zerop (% month 2)) 30 31))
+ (t
+ (if (zerop (% month 2)) 31 30))))
+ (doms dom-list)
+ (dows dow-list)
+ day days)
+ ;; first, review the doms to see if they are valid.
+ (while (setq day (pop doms))
+ (and (<= day max)
+ (push day days)))
+ ;; second add all possible dows
+ (while (setq day (pop dows))
+ ;; days start at 1.
+ (setq day (1+ (- day first)))
+ (and (< day 0) (setq day (+ 7 day)))
+ (while (<= day max)
+ (push day days)
+ (setq day (+ 7 day))))
+ ;; Finally, if we have some days, they are valid
+ (when days
+ (sort days '>)
+ (throw 'found
+ (encode-time 0 minute hour
+ (car days) month year time-zone)))
+ )))))
+ ;; There's an upper limit, but we didn't find any last occurence.
+ ;; This means that the schedule is undecidable. This can happen if
+ ;; you happen to say something like "each Feb 31 until 2038".
+ (progn
+ (nnheader-report 'nndiary "Undecidable schedule")
+ nil))
+ ))))
+
+(defun nndiary-next-occurence (sched now)
+ ;; Returns the next occurence of schedule SCHED, starting from time NOW.
+ ;; If there's no next occurence, returns the last one (if any) which is then
+ ;; in the past.
+ (let* ((today (decode-time now))
+ (this-minute (nth 1 today))
+ (this-hour (nth 2 today))
+ (this-day (nth 3 today))
+ (this-month (nth 4 today))
+ (this-year (nth 5 today))
+ (minute-list (sort (nndiary-flatten (nth 0 sched) 0 59) '<))
+ (hour-list (sort (nndiary-flatten (nth 1 sched) 0 23) '<))
+ (dom-list (nth 2 sched))
+ (month-list (sort (nndiary-flatten (nth 3 sched) 1 12) '<))
+ (years (if (nth 4 sched)
+ (sort (nndiary-flatten (nth 4 sched) 1971) '<)
+ t))
+ (dow-list (nth 5 sched))
+ (year (1- this-year))
+ (time-zone (or (and (nth 6 sched) (car (nth 6 sched)))
+ (current-time-zone))))
+ ;; Special case: an asterisk in one of the days specifications means that
+ ;; only the other should be taken into account. If both are unspecified,
+ ;; you would get all possible days in both.
+ (cond ((null dow-list)
+ ;; this gets all days if dom-list is nil
+ (setq dom-list (nndiary-flatten dom-list 1 31)))
+ ((null dom-list)
+ ;; this also gets all days if dow-list is nil
+ (setq dow-list (nndiary-flatten dow-list 0 6)))
+ (t
+ (setq dom-list (nndiary-flatten dom-list 1 31))
+ (setq dow-list (nndiary-flatten dow-list 0 6))))
+ ;; Remove past years.
+ (unless (eq years t)
+ (while (and (car years) (< (car years) this-year))
+ (pop years)))
+ (if years
+ ;; Because we might not be limited in years, we must guard against
+ ;; infinite loops. Appart from cases like Feb 31, there are probably
+ ;; other ones, (no monday XXX 2nd etc). I don't know any algorithm to
+ ;; decide this, so I assume that if we reach 10 years later, the
+ ;; schedule is undecidable.
+ (or
+ (catch 'found
+ (while (if (eq years t)
+ (and (setq year (1+ year))
+ (<= year (+ 10 this-year)))
+ (setq year (pop years)))
+ (let ((months month-list)
+ month)
+ ;; Remove past months for this year.
+ (and (= year this-year)
+ (while (and (car months) (< (car months) this-month))
+ (pop months)))
+ (while (setq month (pop months))
+ ;; Now we must merge the Dows with the Doms. To do that, we
+ ;; have to know which day is the 1st one for this month.
+ ;; Maybe there's simpler, but decode-time(encode-time) will
+ ;; give us the answer.
+ (let ((first (nth 6 (decode-time
+ (encode-time 0 0 0 1 month year
+ time-zone))))
+ (max (cond ((= month 2)
+ (if (date-leap-year-p year) 29 28))
+ ((<= month 7)
+ (if (zerop (% month 2)) 30 31))
+ (t
+ (if (zerop (% month 2)) 31 30))))
+ (doms dom-list)
+ (dows dow-list)
+ day days)
+ ;; first, review the doms to see if they are valid.
+ (while (setq day (pop doms))
+ (and (<= day max)
+ (push day days)))
+ ;; second add all possible dows
+ (while (setq day (pop dows))
+ ;; days start at 1.
+ (setq day (1+ (- day first)))
+ (and (< day 0) (setq day (+ 7 day)))
+ (while (<= day max)
+ (push day days)
+ (setq day (+ 7 day))))
+ ;; Aaaaaaall right. Now we have a valid list of DAYS for
+ ;; this month and this year.
+ (when days
+ (setq days (sort days '<))
+ ;; Remove past days for this year and this month.
+ (and (= year this-year)
+ (= month this-month)
+ (while (and (car days) (< (car days) this-day))
+ (pop days)))
+ (while (setq day (pop days))
+ (let ((hours hour-list)
+ hour)
+ ;; Remove past hours for this year, this month and
+ ;; this day.
+ (and (= year this-year)
+ (= month this-month)
+ (= day this-day)
+ (while (and (car hours)
+ (< (car hours) this-hour))
+ (pop hours)))
+ (while (setq hour (pop hours))
+ (let ((minutes minute-list)
+ minute)
+ ;; Remove past hours for this year, this month,
+ ;; this day and this hour.
+ (and (= year this-year)
+ (= month this-month)
+ (= day this-day)
+ (= hour this-hour)
+ (while (and (car minutes)
+ (< (car minutes) this-minute))
+ (pop minutes)))
+ (while (setq minute (pop minutes))
+ ;; Ouch! Here, we've got a complete valid
+ ;; schedule. It's a good one if it's in the
+ ;; future.
+ (let ((time (encode-time 0 minute hour day
+ month year
+ time-zone)))
+ (and (time-less-p now time)
+ (throw 'found time)))
+ ))))
+ ))
+ )))
+ ))
+ (nndiary-last-occurence sched))
+ ;; else
+ (nndiary-last-occurence sched))
+ ))
+
+(defun nndiary-expired-article-p (file)
+ (with-temp-buffer
+ (if (nnheader-insert-head file)
+ (let ((sched (nndiary-schedule)))
+ ;; An article has expired if its last schedule (if any) is in the
+ ;; past. A permanent schedule never expires.
+ (and sched
+ (setq sched (nndiary-last-occurence sched))
+ (time-less-p sched (current-time))))
+ ;; else
+ (nnheader-report 'nndiary "Could not read file %s" file)
+ nil)
+ ))
+
+(defun nndiary-renew-article-p (file timestamp)
+ (erase-buffer)
+ (if (nnheader-insert-head file)
+ (let ((now (current-time))
+ (sched (nndiary-schedule)))
+ ;; The article should be re-considered as unread if there's a reminder
+ ;; between the group timestamp and the current time.
+ (when (and sched (setq sched (nndiary-next-occurence sched now)))
+ (let ((reminders ;; add the next occurence itself at the end.
+ (append (nndiary-compute-reminders sched) (list sched))))
+ (while (and reminders (time-less-p (car reminders) timestamp))
+ (pop reminders))
+ ;; The reminders might be empty if the last date is in the past,
+ ;; or we've got at least the next occurence itself left. All past
+ ;; dates are renewed.
+ (or (not reminders)
+ (time-less-p (car reminders) now)))
+ ))
+ ;; else
+ (nnheader-report 'nndiary "Could not read file %s" file)
+ nil))
+
+;; The end... ===============================================================
+
+(mapcar
+ (lambda (elt)
+ (let ((header (intern (format "X-Diary-%s" (car elt)))))
+ ;; Required for building NOV databases and some other stuff
+ (add-to-list 'gnus-extra-headers header)
+ (add-to-list 'nnmail-extra-headers header)))
+ nndiary-headers)
+
+(unless (assoc "nndiary" gnus-valid-select-methods)
+ (gnus-declare-backend "nndiary" 'post-mail 'respool 'address))
+
+(provide 'nndiary)
+
+
+;;; nndiary.el ends here
--- /dev/null
+;;; nnir.el --- search mail with various search engines
+;; Copyright (C) 1998 Kai Großjohann
+
+;; Author: Kai Großjohann <grossjohann@ls6.cs.uni-dortmund.de>
+;; Keywords: news, mail, searching, ir, glimpse, wais
+
+;; This file is not part of GNU Emacs.
+
+;; This 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:
+
+;; The most recent version of this can always be fetched from the
+;; following FTP site:
+;; ls6-ftp.cs.uni-dortmund.de:/pub/src/emacs
+
+;; This code is still in the development stage but I'd like other
+;; people to have a look at it. Please do not hesitate to contact me
+;; with your ideas.
+
+;; What does it do? Well, it allows you to index your mail using some
+;; search engine (freeWAIS-sf and Glimpse are currently supported),
+;; then type `G G' in the Group buffer and issue a query to the search
+;; engine. You will then get a buffer which shows all articles
+;; matching the query, sorted by Retrieval Status Value (score).
+
+;; When looking at the retrieval result (in the Summary buffer) you
+;; can type `G T' (aka M-x gnus-summary-nnir-goto-thread RET) on an
+;; article. You will be teleported into the group this article came
+;; from, showing the thread this article is part of. (See below for
+;; restrictions.)
+
+;; The Lisp installation is simple: just put this file on your
+;; load-path, byte-compile it, and load it from ~/.gnus or something.
+;; This will install a new command `G G' in your Group buffer for
+;; searching your mail. Note that you also need to configure a number
+;; of variables, as described below.
+
+;; Restrictions:
+;;
+;; * Currently, this expects that you use nnml or another
+;; one-file-per-message backend.
+;; * It can only search one mail backend.
+;; * There are restrictions to the Glimpse setup.
+;; * There are restrictions to the Wais setup.
+;; * gnus-summary-nnir-goto-thread: Fetches whole group first, before
+;; limiting to the right articles. This is much too slow, of
+;; course. May issue a query for number of articles to fetch; you
+;; must accept the default of all articles at this point or things
+;; may break.
+
+;; The Lisp setup involves setting a few variables and setting up the
+;; search engine. The first variable to set is `nnir-mail-backend'.
+;; For me, `gnus-secondary-select-methods' contains just one select
+;; method, and this is also what I put in `nnir-mail-backend'. Type
+;; `C-h v nnir-mail-backend RET' for more information -- the variable
+;; documentation includes more details and a few examples. The second
+;; variable to set is `nnir-search-engine'. Choose one of the engines
+;; listed in `nnir-engines'. (Actually `nnir-engines' is an alist,
+;; type `C-h v nnir-engines RET' for more information; this includes
+;; examples for setting `nnir-search-engine', too.)
+
+;; You must also set up a search engine. I'll tell you about the two
+;; search engines currently supported:
+
+;; 1. freeWAIS-sf
+;;
+;; As always with freeWAIS-sf, you need a so-called `format file'. I
+;; use the following file:
+;;
+;; ,-----
+;; | # Kai's format file for freeWAIS-sf for indexing mails.
+;; | # Each mail is in a file, much like the MH format.
+;; |
+;; | # Document separator should never match -- each file is a document.
+;; | record-sep: /^@this regex should never match@$/
+;; |
+;; | # Searchable fields specification.
+;; |
+;; | region: /^[sS]ubject:/ /^[sS]ubject: */
+;; | subject "Subject header" stemming TEXT BOTH
+;; | end: /^[^ \t]/
+;; |
+;; | region: /^([tT][oO]|[cC][cC]):/ /^([tT][oO]|[cC][cC]): */
+;; | to "To and Cc headers" SOUNDEX BOTH
+;; | end: /^[^ \t]/
+;; |
+;; | region: /^[fF][rR][oO][mM]:/ /^[fF][rR][oO][mM]: */
+;; | from "From header" SOUNDEX BOTH
+;; | end: /^[^ \t]/
+;; |
+;; | region: /^$/
+;; | stemming TEXT GLOBAL
+;; | end: /^@this regex should never match@$/
+;; `-----
+;;
+;; 1998-07-22: waisindex would dump core on me for large articles with
+;; the above settings. I used /^$/ as the end regex for the global
+;; field. That seemed to work okay.
+
+;; There is a Perl module called `WAIS.pm' which is available from
+;; CPAN as well as ls6-ftp.cs.uni-dortmund.de:/pub/wais/Perl. This
+;; module comes with a nifty tool called `makedb', which I use for
+;; indexing. Here's my `makedb.conf':
+;;
+;; ,-----
+;; | # Config file for makedb
+;; |
+;; | # Global options
+;; | waisindex = /usr/local/bin/waisindex
+;; | wais_opt = -stem -t fields
+;; | # `-stem' option necessary when `stemming' is specified for the
+;; | # global field in the *.fmt file
+;; |
+;; | # Own variables
+;; | homedir = /home/kai
+;; |
+;; | # The mail database.
+;; | database = mail
+;; | files = `find $homedir/Mail -name \*[0-9] -print`
+;; | dbdir = $homedir/.wais
+;; | limit = 100
+;; `-----
+;;
+;; The Lisp setup involves the `nnir-wais-*' variables. The most
+;; difficult to understand variable is probably
+;; `nnir-wais-remove-prefix'. Here's what it does: the output of
+;; `waissearch' basically contains the file name and the (full)
+;; directory name. As Gnus works with group names rather than
+;; directory names, the directory name is transformed into a group
+;; name as follows: first, a prefix is removed from the (full)
+;; directory name, then all `/' are replaced with `.'. The variable
+;; `nnir-wais-remove-prefix' should contain a regex matching exactly
+;; this prefix. It defaults to `$HOME/Mail/' (note the trailing
+;; slash).
+
+;; 2. Glimpse
+;;
+;; The code expects you to have one Glimpse index which contains all
+;; your mail files. The Lisp setup involves setting the
+;; `nnir-glimpse-*' variables. The most difficult to understand
+;; variable is probably `nnir-glimpse-remove-prefix', it corresponds
+;; to `nnir-wais-remove-prefix', see above. The `nnir-glimpse-home'
+;; variable should be set to the value of the `-H' option which allows
+;; one to search this Glimpse index. I have indexed my whole home
+;; directory with Glimpse, so I assume a default of `$HOME'.
+
+;; 3. Namazu
+;;
+;; The Namazu backend requires you to have one directory containing all
+;; index files, this is controlled by the `nnir-namazu-index-directory'
+;; variable. To function the `nnir-namazu-remove-prefix' variable must
+;; also be correct, see the documentation for `nnir-wais-remove-prefix'
+;; above.
+;;
+;; It is particularly important not to pass any any switches to namazu
+;; that will change the output format. Good switches to use include
+;; `--sort', `--ascending', `--early' and `--late'. Refer to the Namazu
+;; documentation for further information on valid switches.
+;;
+;; To index my mail with the `mknmz' program I use the following
+;; configuration file:
+;;
+;; ,----
+;; | package conf; # Don't remove this line!
+;; |
+;; | # Paths which will not be indexed. Don't use `^' or `$' anchors.
+;; | $EXCLUDE_PATH = "spam|sent";
+;; |
+;; | # Header fields which should be searchable. case-insensitive
+;; | $REMAIN_HEADER = "from|date|message-id|subject";
+;; |
+;; | # Searchable fields. case-insensitive
+;; | $SEARCH_FIELD = "from|date|message-id|subject";
+;; |
+;; | # The max length of a word.
+;; | $WORD_LENG_MAX = 128;
+;; |
+;; | # The max length of a field.
+;; | $MAX_FIELD_LENGTH = 256;
+;; `----
+;;
+;; My mail is stored in the directories ~/Mail/mail/, ~/Mail/lists/ and
+;; ~/Mail/archive/, so to index them I go to the directory set in
+;; `nnir-namazu-index-directory' and issue the following command.
+;;
+;; mknmz --mailnews ~/Mail/archive/ ~/Mail/mail/ ~/Mail/lists/
+;;
+;; For maximum searching efficiency I have a cron job set to run this
+;; command every four hours.
+
+;; Developer information:
+
+;; I have tried to make the code expandable. Basically, it is divided
+;; into two layers. The upper layer is somewhat like the `nnvirtual'
+;; or `nnkiboze' backends: given a specification of what articles to
+;; show from another backend, it creates a group containing exactly
+;; those articles. The lower layer issues a query to a search engine
+;; and produces such a specification of what articles to show from the
+;; other backend.
+
+;; The interface between the two layers consists of the single
+;; function `nnir-run-query', which just selects the appropriate
+;; function for the search engine one is using. The input to
+;; `nnir-run-query' is a string, representing the query as input by
+;; the user. The output of `nnir-run-query' is supposed to be a
+;; vector, each element of which should in turn be a three-element
+;; vector. The first element should be group name of the article, the
+;; second element should be the article number, and the third element
+;; should be the Retrieval Status Value (RSV) as returned from the
+;; search engine. An RSV is the score assigned to the document by the
+;; search engine. For Boolean search engines like Glimpse, the RSV is
+;; always 1000 (or 1 or 100, or whatever you like).
+
+;; The sorting order of the articles in the summary buffer created by
+;; nnir is based on the order of the articles in the above mentioned
+;; vector, so that's where you can do the sorting you'd like. Maybe
+;; it would be nice to have a way of displaying the search result
+;; sorted differently?
+
+;; So what do you need to do when you want to add another search
+;; engine? You write a function that executes the query. Temporary
+;; data from the search engine can be put in `nnir-tmp-buffer'. This
+;; function should return the list of articles as a vector, as
+;; described above. Then, you need to register this backend in
+;; `nnir-engines'. Then, users can choose the backend by setting
+;; `nnir-search-engine'.
+
+;; Todo, or future ideas:
+
+;; * Make it so that Glimpse can also be called without `-F'.
+;;
+;; * It should be possible to restrict search to certain groups.
+;;
+;; * There is currently no error checking.
+;;
+;; * The summary buffer display is currently really ugly, with all the
+;; added information in the subjects. How could I make this
+;; prettier?
+;;
+;; * A function which can be called from an nnir summary buffer which
+;; teleports you into the group the current article came from and
+;; shows you the whole thread this article is part of.
+;; Implementation suggestions?
+;; (1998-07-24: There is now a preliminary implementation, but
+;; it is much too slow and quite fragile.)
+;;
+;; * Support other mail backends. In particular, probably quite a few
+;; people use nnfolder. How would one go about searching nnfolders
+;; and producing the right data needed? The group name and the RSV
+;; are simple, but what about the article number?
+;;
+;; * Support compressed mail files. Probably, just stripping off the
+;; `.gz' or `.Z' file name extension is sufficient.
+;;
+;; * Support a find/grep combination.
+;;
+;; * At least for imap, the query is performed twice.
+;;
+;; * Support multiple mail backends. The information that is needed
+;; by nnir could be put in the server parameters. (Use sensible
+;; default values, though: include the name of the backend in the
+;; default value such that people do not have to mess with the
+;; server parameters if they don't want to.) It is not clear how to
+;; do the user interface, though. Hm. Maybe offer the user a
+;; completable list of backends to search? Or use the
+;; process-marked groups to find out which backends to search? Or
+;; always search all backends?
+;;
+
+;; Have you got other ideas?
+
+;;; Setup Code:
+
+(defconst nnir-version "1.72"
+ "Version of NNIR.")
+
+(require 'cl)
+(require 'nnoo)
+(require 'gnus-group)
+(require 'gnus-sum)
+(eval-and-compile
+ (require 'gnus-util))
+
+(nnoo-declare nnir)
+(nnoo-define-basics nnir)
+
+(gnus-declare-backend "nnir" 'mail)
+
+;;; Developer Extension Variable:
+
+(defvar nnir-engines
+ '((glimpse nnir-run-glimpse
+ ((group . "Group spec: ")))
+ (wais nnir-run-waissearch
+ ())
+ (excite nnir-run-excite-search
+ ())
+ (imap nnir-run-imap
+ ())
+ (swish++ nnir-run-swish++
+ ((group . "Group spec: ")))
+ (swish-e nnir-run-swish-e
+ ((group . "Group spec: ")))
+ (namazu nnir-run-namazu
+ ()))
+"Alist of supported search engines.
+Each element in the alist is a three-element list (ENGINE FUNCTION ARGS).
+ENGINE is a symbol designating the searching engine. FUNCTION is also
+a symbol, giving the function that does the search. The third element
+ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query,
+the FUNCTION will issue a query for each of the PARAMs, using PROMPT.
+
+The value of `nnir-search-engine' must be one of the ENGINE symbols.
+For example, use the following line for searching using freeWAIS-sf:
+ (setq nnir-search-engine 'wais)
+Use the following line if you read your mail via IMAP and your IMAP
+server supports searching:
+ (setq nnir-search-engine 'imap)
+Note that you have to set additional variables for most backends. For
+example, the `wais' backend needs the variables `nnir-wais-program',
+`nnir-wais-database' and `nnir-wais-remove-prefix'.
+
+Add an entry here when adding a new search engine.")
+
+;;; User Customizable Variables:
+
+(defgroup nnir nil
+ "Search nnmh and nnml groups in Gnus with Glimpse, freeWAIS-sf, or EWS.")
+
+;; Mail backend.
+
+;; TODO:
+;; If `nil', use server parameters to find out which server to search. CCC
+;;
+(defcustom nnir-mail-backend '(nnml "")
+ "*Specifies which backend should be searched.
+More precisely, this is used to determine from which backend to fetch the
+messages found.
+
+This must be equal to an existing server, so maybe it is best to use
+something like the following:
+ (setq nnir-mail-backend (nth 0 gnus-secondary-select-methods))
+The above line works fine if the mail backend you want to search is
+the first element of gnus-secondary-select-methods (`nth' starts counting
+at zero)."
+ :type '(sexp)
+ :group 'nnir)
+
+;; Search engine to use.
+
+(defcustom nnir-search-engine 'wais
+ "*The search engine to use. Must be a symbol.
+See `nnir-engines' for a list of supported engines, and for example
+settings of `nnir-search-engine'."
+ :type '(sexp)
+ :group 'nnir)
+
+;; Glimpse engine.
+
+(defcustom nnir-glimpse-program "glimpse"
+ "*Name of Glimpse executable."
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-glimpse-home (getenv "HOME")
+ "*Value of `-H' glimpse option.
+`~' and environment variables must be expanded, see the functions
+`expand-file-name' and `substitute-in-file-name'."
+ :type '(directory)
+ :group 'nnir)
+
+(defcustom nnir-glimpse-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "*The prefix to remove from each file name returned by Glimpse
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+For example, suppose that Glimpse returns file names such as
+\"/home/john/Mail/mail/misc/42\". For this example, use the following
+setting: (setq nnir-glimpse-remove-prefix \"/home/john/Mail/\")
+Note the trailing slash. Removing this prefix gives \"mail/misc/42\".
+`nnir' knows to remove the \"/42\" and to replace \"/\" with \".\" to
+arrive at the correct group name, \"mail.misc\"."
+ :type '(regexp)
+ :group 'nnir)
+
+(defcustom nnir-glimpse-additional-switches '("-i")
+ "*A list of strings, to be given as additional arguments to glimpse.
+The switches `-H', `-W', `-l' and `-y' are always used -- calling
+glimpse without them does not make sense in our situation.
+Suggested elements to put here are `-i' and `-w'.
+
+Note that this should be a list. Ie, do NOT use the following:
+ (setq nnir-glimpse-additional-switches \"-i -w\") ; wrong!
+Instead, use this:
+ (setq nnir-glimpse-additional-switches '(\"-i\" \"-w\"))"
+ :type '(repeat (string))
+ :group 'nnir)
+
+;; freeWAIS-sf.
+
+(defcustom nnir-wais-program "waissearch"
+ "*Name of waissearch executable."
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-wais-database (expand-file-name "~/.wais/mail")
+ "*Name of Wais database containing the mail.
+
+Note that this should be a file name without extension. For example,
+if you have a file /home/john/.wais/mail.fmt, use this:
+ (setq nnir-wais-database \"/home/john/.wais/mail\")
+The string given here is passed to `waissearch -d' as-is."
+ :type '(file)
+ :group 'nnir)
+
+(defcustom nnir-wais-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "*The prefix to remove from each directory name returned by waissearch
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable is similar to `nnir-glimpse-remove-prefix', only for Wais,
+not Glimpse."
+ :type '(regexp)
+ :group 'nnir)
+
+;; EWS (Excite for Web Servers) engine.
+
+(defcustom nnir-excite-aquery-program "aquery.pl"
+ "*Name of the EWS query program. Should be `aquery.pl' or a path to same."
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-excite-collection "Mail"
+ "*Name of the EWS collection to search."
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-excite-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "*The prefix to remove from each file name returned by EWS
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable is very similar to `nnir-glimpse-remove-prefix', except
+that it is for EWS, not Glimpse."
+ :type '(regexp)
+ :group 'nnir)
+
+(defcustom nnir-imap-default-charset nil
+ "*Name of the charset of the strings that appear in the search criteria."
+ :type '(choice (const nil) symbol)
+ :group 'nnir)
+
+;; Swish++. Next three variables Copyright (C) 2000, 2001 Christoph
+;; Conrad <christoph.conrad@gmx.de>.
+;; Swish++ home page: http://homepage.mac.com/pauljlucas/software/swish/
+
+(defcustom nnir-swish++-configuration-file
+ (expand-file-name "~/Mail/swish++.conf")
+ "*Configuration file for swish++."
+ :type '(file)
+ :group 'nnir)
+
+(defcustom nnir-swish++-program "search"
+ "*Name of swish++ search executable."
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-swish++-additional-switches '()
+ "*A list of strings, to be given as additional arguments to swish++.
+
+Note that this should be a list. Ie, do NOT use the following:
+ (setq nnir-swish++-additional-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq nnir-swish++-additional-switches '(\"-i\" \"-w\"))"
+ :type '(repeat (string))
+ :group 'nnir)
+
+(defcustom nnir-swish++-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "*The prefix to remove from each file name returned by swish++
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable is very similar to `nnir-glimpse-remove-prefix', except
+that it is for swish++, not Glimpse."
+ :type '(regexp)
+ :group 'nnir)
+
+;; Swish-E. Next three variables Copyright (C) 2000 Christoph Conrad
+;; <christoph.conrad@gmx.de>.
+;; URL: http://sunsite.berkeley.edu/SWISH-E/
+;; New version: http://www.boe.es/swish-e
+
+(defcustom nnir-swish-e-index-file
+ (expand-file-name "~/Mail/index.swish-e")
+ "*Index file for swish-e."
+ :type '(file)
+ :group 'nnir)
+
+(defcustom nnir-swish-e-program "swish-e"
+ "*Name of swish-e search executable."
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-swish-e-additional-switches '()
+ "*A list of strings, to be given as additional arguments to swish-e.
+
+Note that this should be a list. Ie, do NOT use the following:
+ (setq nnir-swish-e-additional-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq nnir-swish-e-additional-switches '(\"-i\" \"-w\"))"
+ :type '(repeat (string))
+ :group 'nnir)
+
+(defcustom nnir-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "*The prefix to remove from each file name returned by swish-e
+in order to get a group name (albeit with / instead of .). This is a
+regular expression.
+
+This variable is very similar to `nnir-glimpse-remove-prefix', except
+that it is for swish-e, not Glimpse."
+ :type '(regexp)
+ :group 'nnir)
+
+;; Namazu engine, see <URL:http://ww.namazu.org/>
+
+(defcustom nnir-namazu-program "namazu"
+ "*Name of Namazu search executable."
+ :type '(string)
+ :group 'nnir)
+
+(defcustom nnir-namazu-index-directory (expand-file-name "~/Mail/namazu/")
+ "*Index directory for Namazu."
+ :type '(directory)
+ :group 'nnir)
+
+(defcustom nnir-namazu-additional-switches '()
+ "*A list of strings, to be given as additional arguments to namazu.
+The switches `-q', `-a', and `-s' are always used, very few other switches
+make any sense in this context.
+
+Note that this should be a list. Ie, do NOT use the following:
+ (setq nnir-namazu-additional-switches \"-i -w\") ; wrong
+Instead, use this:
+ (setq nnir-namazu-additional-switches '(\"-i\" \"-w\"))"
+ :type '(repeat (string))
+ :group 'nnir)
+
+(defcustom nnir-namazu-remove-prefix (concat (getenv "HOME") "/Mail/")
+ "*The prefix to remove from each file name returned by Namazu
+in order to get a group name (albeit with / instead of .).
+
+This variable is very similar to `nnir-glimpse-remove-prefix', except
+that it is for Namazu, not Glimpse."
+ :type '(directory)
+ :group 'nnir)
+
+;;; Internal Variables:
+
+(defvar nnir-current-query nil
+ "Internal: stores current query (= group name).")
+
+(defvar nnir-current-server nil
+ "Internal: stores current server (does it ever change?).")
+
+(defvar nnir-current-group-marked nil
+ "Internal: stores current list of process-marked groups.")
+
+(defvar nnir-artlist nil
+ "Internal: stores search result.")
+
+(defvar nnir-tmp-buffer " *nnir*"
+ "Internal: temporary buffer.")
+
+;;; Code:
+
+;; Gnus glue.
+
+(defun gnus-group-make-nnir-group (extra-parms query)
+ "Create an nnir group. Asks for query."
+ (interactive "P\nsQuery: ")
+ (let ((parms nil))
+ (if extra-parms
+ (setq parms (nnir-read-parms query))
+ (setq parms (list (cons 'query query))))
+ (gnus-group-read-ephemeral-group
+ (concat "nnir:" (prin1-to-string parms)) '(nnir "") t
+ (cons (current-buffer)
+ gnus-current-window-configuration)
+ nil)))
+
+;; Emacs 19 compatibility?
+(or (fboundp 'kbd) (defalias 'kbd 'read-kbd-macro))
+
+(defun nnir-group-mode-hook ()
+ (define-key gnus-group-mode-map
+ (if (fboundp 'read-kbd-macro)
+ (kbd "G G")
+ "GG") ; XEmacs 19 compat
+ 'gnus-group-make-nnir-group))
+(add-hook 'gnus-group-mode-hook
+ (lambda ()
+ (unless (string-match "T-gnus" gnus-version)
+ (nnir-group-mode-hook))))
+
+
+
+;; Summary mode commands.
+
+(defun gnus-summary-nnir-goto-thread ()
+ "Only applies to nnir groups. Go to group this article came from
+and show thread that contains this article."
+ (interactive)
+ (unless (eq 'nnir (car (gnus-find-method-for-group gnus-newsgroup-name)))
+ (error "Can't execute this command unless in nnir group."))
+ (let* ((cur (gnus-summary-article-number))
+ (backend-group (nnir-artlist-artitem-group nnir-artlist cur))
+ (backend-number (nnir-artlist-artitem-number nnir-artlist cur)))
+ (gnus-group-read-ephemeral-group
+ backend-group
+ nnir-mail-backend
+ t ; activate
+ (cons (current-buffer)
+ 'summary) ; window config
+ nil
+ (list backend-number))
+ (gnus-summary-limit (list backend-number))
+ (gnus-summary-refer-thread)))
+
+(if (fboundp 'eval-after-load)
+ (eval-after-load "gnus-sum"
+ '(define-key gnus-summary-goto-map
+ "T" 'gnus-summary-nnir-goto-thread))
+ (add-hook 'gnus-summary-mode-hook
+ (function (lambda ()
+ (define-key gnus-summary-goto-map
+ "T" 'gnus-summary-nnir-goto-thread)))))
+
+
+
+;; Gnus backend interface functions.
+
+(deffoo nnir-open-server (server &optional definitions)
+ ;; Just set the server variables appropriately.
+ (nnoo-change-server 'nnir server definitions))
+
+(deffoo nnir-request-group (group &optional server fast)
+ "GROUP is the query string."
+ (nnir-possibly-change-server server)
+ ;; Check for cache and return that if appropriate.
+ (if (and (equal group nnir-current-query)
+ (equal gnus-group-marked nnir-current-group-marked)
+ (or (null server)
+ (equal server nnir-current-server)))
+ nnir-artlist
+ ;; Cache miss.
+ (setq nnir-artlist (nnir-run-query group))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (if (zerop (length nnir-artlist))
+ (progn
+ (setq nnir-current-query nil
+ nnir-current-server nil
+ nnir-current-group-marked nil
+ nnir-artlist nil)
+ (nnheader-report 'nnir "Search produced empty results."))
+ ;; Remember data for cache.
+ (setq nnir-current-query group)
+ (when server (setq nnir-current-server server))
+ (setq nnir-current-group-marked gnus-group-marked)
+ (nnheader-insert "211 %d %d %d %s\n"
+ (nnir-artlist-length nnir-artlist) ; total #
+ 1 ; first #
+ (nnir-artlist-length nnir-artlist) ; last #
+ group))))) ; group name
+
+(deffoo nnir-retrieve-headers (articles &optional group server fetch-old)
+ (save-excursion
+ (let ((artlist (copy-sequence articles))
+ (idx 1)
+ (art nil)
+ (artitem nil)
+ (artgroup nil) (artno nil)
+ (artrsv nil)
+ (artfullgroup nil)
+ (novitem nil)
+ (novdata nil)
+ (foo nil))
+ (while (not (null artlist))
+ (setq art (car artlist))
+ (or (numberp art)
+ (nnheader-report
+ 'nnir
+ "nnir-retrieve-headers doesn't grok message ids: %s"
+ art))
+ (setq artitem (nnir-artlist-article nnir-artlist art))
+ (setq artrsv (nnir-artitem-rsv artitem))
+ (setq artgroup (nnir-artitem-group artitem))
+ (setq artno (nnir-artitem-number artitem))
+ (setq artfullgroup (nnir-group-full-name artgroup))
+ ;; retrieve NOV or HEAD data for this article, transform into
+ ;; NOV data and prepend to `novdata'
+ (set-buffer nntp-server-buffer)
+ (case (setq foo (gnus-retrieve-headers (list artno) artfullgroup nil))
+ (nov
+ (goto-char (point-min))
+ (setq novitem (nnheader-parse-nov))
+ (unless novitem
+ (pop-to-buffer nntp-server-buffer)
+ (error
+ "nnheader-parse-nov returned nil for article %s in group %s"
+ artno artfullgroup)))
+ (headers
+ (goto-char (point-min))
+ (setq novitem (nnheader-parse-head))
+ (unless novitem
+ (pop-to-buffer nntp-server-buffer)
+ (error
+ "nnheader-parse-head returned nil for article %s in group %s"
+ artno artfullgroup)))
+ (t (nnheader-report 'nnir "Don't support header type %s." foo)))
+ ;; replace article number in original group with article number
+ ;; in nnir group
+ (mail-header-set-number novitem idx)
+ (mail-header-set-from novitem
+ (mail-header-from novitem))
+ (mail-header-set-subject
+ novitem
+ (format "[%d: %s/%d] %s"
+ artrsv artgroup artno
+ (mail-header-subject novitem)))
+ ;;-(mail-header-set-extra novitem nil)
+ (push novitem novdata)
+ (setq artlist (cdr artlist))
+ (setq idx (1+ idx)))
+ (setq novdata (nreverse novdata))
+ (set-buffer nntp-server-buffer) (erase-buffer)
+ (mapcar 'nnheader-insert-nov novdata)
+ 'nov)))
+
+(deffoo nnir-request-article (article
+ &optional group server to-buffer)
+ (save-excursion
+ (let* ((artitem (nnir-artlist-article nnir-artlist
+ article))
+ (artgroup (nnir-artitem-group artitem))
+ (artno (nnir-artitem-number artitem))
+ ;; Bug?
+ ;; Why must we bind nntp-server-buffer here? It won't
+ ;; work if `buf' is used, say. (Of course, the set-buffer
+ ;; line below must then be updated, too.)
+ (nntp-server-buffer (or to-buffer nntp-server-buffer)))
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (message "Requesting article %d from group %s"
+ artno
+ (nnir-group-full-name artgroup))
+ (gnus-request-article artno (nnir-group-full-name artgroup)
+ nntp-server-buffer)
+ (cons artgroup artno))))
+
+
+(nnoo-define-skeleton nnir)
+
+;;; Search Engine Interfaces:
+
+;; Glimpse interface.
+(defun nnir-run-glimpse (query &optional group)
+ "Run given query against glimpse. Returns a vector of (group name, file name)
+pairs (also vectors, actually)."
+ (save-excursion
+ (let ((artlist nil)
+ (groupspec (cdr (assq 'group query)))
+ (qstring (cdr (assq 'query query))))
+ (when (and group groupspec)
+ (error (concat "It does not make sense to use a group spec"
+ " with process-marked groups.")))
+ (when group
+ (setq groupspec (gnus-group-real-name group)))
+ (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (erase-buffer)
+ (if groupspec
+ (message "Doing glimpse query %s on %s..." query groupspec)
+ (message "Doing glimpse query %s..." query))
+ (let* ((cp-list
+ `( ,nnir-glimpse-program
+ nil ; input from /dev/null
+ t ; output
+ nil ; don't redisplay
+ "-H" ,nnir-glimpse-home ; search home dir
+ "-W" ; match pattern in file
+ "-l" "-y" ; misc options
+ ,@nnir-glimpse-additional-switches
+ "-F" ,nnir-glimpse-remove-prefix ; restrict output to mail
+ ,qstring ; the query, in glimpse format
+ ))
+ (exitstatus
+ (progn
+ (message "%s args: %s" nnir-glimpse-program
+ (mapconcat 'identity (cddddr cp-list) " "))
+ (apply 'call-process cp-list))))
+ (unless (or (null exitstatus)
+ (zerop exitstatus))
+ (nnheader-report 'nnir "Couldn't run glimpse: %s" exitstatus)
+ ;; Glimpse failure reason is in this buffer, show it if
+ ;; the user wants it.
+ (when (> gnus-verbose 6)
+ (display-buffer nnir-tmp-buffer))))
+ (when groupspec
+ (keep-lines groupspec))
+ (if groupspec
+ (message "Doing glimpse query %s on %s...done" query groupspec)
+ (message "Doing glimpse query %s...done" query))
+ (sit-for 0)
+ ;; CCC: The following work of extracting group name and article
+ ;; number from the Glimpse output can probably better be done by
+ ;; just going through the buffer once, and plucking out the
+ ;; right information from each line.
+ ;; remove superfluous stuff from glimpse output
+ (goto-char (point-min))
+ (delete-non-matching-lines "/[0-9]+$")
+ ;;(delete-matching-lines "\\.overview~?$")
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" nnir-glimpse-remove-prefix) nil t)
+ (replace-match ""))
+ ;; separate group name from article number with \t
+ ;; XEmacs compatible version
+ (goto-char (point-max))
+ (while (re-search-backward "/[0-9]+$" nil t)
+ (delete-char 1 nil)
+ (insert-char ?\t 1))
+; Emacs compatible version
+; (goto-char (point-min))
+; (while (re-search-forward "\\(/\\)[0-9]+$" nil t)
+; (replace-match "\t" t t nil 1))
+ ;; replace / with . in group names
+ (subst-char-in-region (point-min) (point-max) ?/ ?. t)
+ ;; massage buffer to contain some Lisp;
+ ;; this depends on the artlist encoding internals
+ ;; maybe this dependency should be removed?
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert "[\"")
+ (skip-chars-forward "^\t")
+ (insert "\" ")
+ (end-of-line)
+ (insert " 1000 ]") ; 1000 = score
+ (forward-line 1))
+ (insert "])\n")
+ (goto-char (point-min))
+ (insert "(setq artlist [\n")
+ (eval-buffer)
+ (sort* artlist
+ (function (lambda (x y)
+ (if (string-lessp (nnir-artitem-group x)
+ (nnir-artitem-group y))
+ t
+ (< (nnir-artitem-number x)
+ (nnir-artitem-number y))))))
+ )))
+
+;; freeWAIS-sf interface.
+(defun nnir-run-waissearch (query &optional group)
+ "Run given query agains waissearch. Returns vector of (group name, file name)
+pairs (also vectors, actually)."
+ (when group
+ (error "The freeWAIS-sf backend cannot search specific groups."))
+ (save-excursion
+ (let ((qstring (cdr (assq 'query query)))
+ (artlist nil)
+ (score nil) (artno nil) (dirnam nil) (group nil))
+ (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (erase-buffer)
+ (message "Doing WAIS query %s..." query)
+ (call-process nnir-wais-program
+ nil ; input from /dev/null
+ t ; output to current buffer
+ nil ; don't redisplay
+ "-d" nnir-wais-database ; database to search
+ qstring)
+ (message "Massaging waissearch output...")
+ ;; remove superfluous lines
+ (keep-lines "Score:")
+ ;; extract data from result lines
+ (goto-char (point-min))
+ (while (re-search-forward
+ "Score: +\\([0-9]+\\).*'\\([0-9]+\\) +\\([^']+\\)/'" nil t)
+ (setq score (match-string 1)
+ artno (match-string 2)
+ dirnam (match-string 3))
+ (unless (string-match nnir-wais-remove-prefix dirnam)
+ (nnheader-report 'nnir "Dir name %s doesn't contain prefix %s"
+ dirnam nnir-wais-remove-prefix))
+ (setq group (substitute ?. ?/ (replace-match "" t t dirnam)))
+ (push (vector group
+ (string-to-int artno)
+ (string-to-int score))
+ artlist))
+ (message "Massaging waissearch output...done")
+ (apply 'vector
+ (sort* artlist
+ (function (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y)))))))))
+
+;; EWS (Excite for Web Servers) interface
+(defun nnir-run-excite-search (query &optional group)
+ "Run a given query against EWS. Returns vector of (group name, file name)
+pairs (also vectors, actually)."
+ (when group
+ (error "Searching specific groups not implemented for EWS."))
+ (save-excursion
+ (let ((qstring (cdr (assq 'query query)))
+ artlist group article-num article)
+ (setq nnir-current-query query)
+ (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (erase-buffer)
+ (message "Doing EWS query %s..." qstring)
+ (call-process nnir-excite-aquery-program
+ nil ; input from /dev/null
+ t ; output to current buffer
+ nil ; don't redisplay
+ nnir-excite-collection
+ (if (string= (substring qstring 0 1) "(")
+ qstring
+ (format "(concept %s)" qstring)))
+ (message "Gathering query output...")
+
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^[0-9]+\\s-[0-9]+\\s-[0-9]+\\s-\\(\\S-*\\)" nil t)
+ (setq article (match-string 1))
+ (unless (string-match
+ (concat "^" (regexp-quote nnir-excite-remove-prefix)
+ "\\(.*\\)/\\([0-9]+\\)") article)
+ (nnheader-report 'nnir "Dir name %s doesn't contain prefix %s"
+ article nnir-excite-remove-prefix))
+ (setq group (substitute ?. ?/ (match-string 1 article)))
+ (setq article-num (match-string 2 article))
+ (setq artlist (vconcat artlist (vector (vector group
+ (string-to-int article-num)
+ 1000)))))
+ (message "Gathering query output...done")
+ artlist)))
+
+;; IMAP interface. The following function is Copyright (C) 1998 Simon
+;; Josefsson <jas@pdc.kth.se>.
+;; todo:
+;; nnir invokes this two (2) times???!
+;; we should not use nnimap at all but open our own server connection
+;; we should not LIST * but use nnimap-list-pattern from defs
+;; send queries as literals
+;; handle errors
+
+(eval-when-compile
+ (defvar nnimap-server-buffer))
+
+(defun nnir-run-imap (query &optional group)
+ (require 'imap)
+ (require 'nnimap)
+ (require 'mm-util)
+ (unless group
+ (error "Must specify groups for IMAP searching."))
+ (save-excursion
+ (let ((qstring (cdr (assq 'query query)))
+ (server (cadr nnir-mail-backend))
+ (defs (caddr nnir-mail-backend))
+ artlist buf)
+ (message "Opening server %s" server)
+ (condition-case ()
+ (when (nnimap-open-server server defs) ;; xxx
+ (setq buf nnimap-server-buffer) ;; xxx
+ (message "Searching %s..." group)
+ (let ((arts 0)
+ (mbx (gnus-group-real-name group))
+ (multibyte-p (mm-multibyte-p))
+ charset coding-system)
+ (when (imap-mailbox-select mbx nil buf)
+ (with-temp-buffer
+ (if multibyte-p
+ (mm-enable-multibyte))
+ (insert qstring)
+ (setq charset (car (mm-find-mime-charset-region
+ (point-min)(point-max)))))
+ (unless charset
+ (setq charset nnir-imap-default-charset))
+ (mapcar
+ (lambda (artnum)
+ (push (vector mbx artnum 1) artlist)
+ (setq arts (1+ arts)))
+ (if (and (not (eq charset 'us-ascii))
+ (setq coding-system (mm-charset-to-coding-system
+ charset)))
+ (imap-search
+ (concat "CHARSET " (symbol-name charset) " TEXT \""
+ (mm-encode-coding-string qstring coding-system)
+ "\"") buf)
+ (imap-search (concat "TEXT \"" qstring "\"") buf)))
+ (message "Searching %s... %d matches" mbx arts)))
+ (message "Searching %s...done" group))
+ (quit nil))
+ (reverse artlist))))
+
+;; Swish++ interface. The following function is Copyright (C) 2000,
+;; 2001 Christoph Conrad <christoph.conrad@gmx.de>.
+;; -cc- Todo
+;; Search by
+;; - group
+;; Sort by
+;; - rank (default)
+;; - article number
+;; - file size
+;; - group
+(defun nnir-run-swish++ (query &optional group)
+ "Run given query against swish++.
+Returns a vector of (group name, file name) pairs (also vectors,
+actually).
+
+Tested with swish++ 4.7 on GNU/Linux and with with swish++ 5.0b2 on
+Windows NT 4.0."
+
+ (when group
+ (error "The swish++ backend cannot search specific groups."))
+
+ (save-excursion
+ (let ( (qstring (cdr (assq 'query query)))
+ (groupspec (cdr (assq 'group query)))
+ (artlist nil)
+ (score nil) (artno nil) (dirnam nil) (group nil) )
+
+ (when (equal "" qstring)
+ (error "swish++: You didn't enter anything."))
+
+ (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (erase-buffer)
+
+ (if groupspec
+ (message "Doing swish++ query %s on %s..." qstring groupspec)
+ (message "Doing swish++ query %s..." qstring))
+
+ (let* ((cp-list `( ,nnir-swish++-program
+ nil ; input from /dev/null
+ t ; output
+ nil ; don't redisplay
+ "--config-file" ,nnir-swish++-configuration-file
+ ,@nnir-swish++-additional-switches
+ ,qstring ; the query, in swish++ format
+ ))
+ (exitstatus
+ (progn
+ (message "%s args: %s" nnir-swish++-program
+ (mapconcat 'identity (cddddr cp-list) " "));; ???
+ (apply 'call-process cp-list))))
+ (unless (or (null exitstatus)
+ (zerop exitstatus))
+ (nnheader-report 'nnir "Couldn't run swish++: %s" exitstatus)
+ ;; swish++ failure reason is in this buffer, show it if
+ ;; the user wants it.
+ (when (> gnus-verbose 6)
+ (display-buffer nnir-tmp-buffer))))
+
+ ;; The results are output in the format of:
+ ;; V 4.7 Linux
+ ;; rank relative-path-name file-size file-title
+ ;; V 5.0b2:
+ ;; rank relative-path-name file-size topic??
+ ;; where rank is an integer from 1 to 100.
+ (goto-char (point-min))
+ (while (re-search-forward
+ "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t)
+ (setq score (match-string 1)
+ artno (file-name-nondirectory (match-string 2))
+ dirnam (file-name-directory (match-string 2)))
+
+ ;; don't match directories
+ (when (string-match "^[0-9]+$" artno)
+ (when (not (null dirnam))
+
+ ; maybe limit results to matching groups.
+ (when (or (not groupspec)
+ (string-match groupspec dirnam))
+
+ ;; remove nnir-swish++-remove-prefix from beginning of dirname
+ (when (string-match (concat "^" nnir-swish++-remove-prefix)
+ dirnam)
+ (setq dirnam (replace-match "" t t dirnam)))
+
+ (setq dirnam (substring dirnam 0 -1))
+ ;; eliminate all ".", "/", "\" from beginning. Always matches.
+ (string-match "^[./\\]*\\(.*\\)$" dirnam)
+ ;; "/" -> "."
+ (setq group (substitute ?. ?/ (match-string 1 dirnam)))
+ ;; "\\" -> "."
+ (setq group (substitute ?. ?\\ group))
+
+ (push (vector group
+ (string-to-int artno)
+ (string-to-int score))
+ artlist)))))
+
+ (message "Massaging swish++ output...done")
+
+ ;; Sort by score
+ (apply 'vector
+ (sort* artlist
+ (function (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y)))))))))
+
+;; Swish-E interface. The following function is Copyright (C) 2000,
+;; 2001 by Christoph Conrad <christoph.conrad@gmx.de>.
+(defun nnir-run-swish-e (query &optional group)
+ "Run given query against swish-e.
+Returns a vector of (group name, file name) pairs (also vectors,
+actually).
+
+Tested with swish-e-2.0.1 on Windows NT 4.0."
+
+ ;; swish-e crashes with empty parameter to "-w" on commandline...
+ (when group
+ (error "The swish-e backend cannot search specific groups."))
+
+ (save-excursion
+ (let ( (qstring (cdr (assq 'query query)))
+ (artlist nil)
+ (score nil) (artno nil) (dirnam nil) (group nil) )
+
+ (when (equal "" qstring)
+ (error "swish-e: You didn't enter anything."))
+
+ (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (erase-buffer)
+
+ (message "Doing swish-e query %s..." query)
+ (let* ((cp-list `( ,nnir-swish-e-program
+ nil ; input from /dev/null
+ t ; output
+ nil ; don't redisplay
+ "-f" ,nnir-swish-e-index-file
+ ,@nnir-swish-e-additional-switches
+ "-w"
+ ,qstring ; the query, in swish-e format
+ ))
+ (exitstatus
+ (progn
+ (message "%s args: %s" nnir-swish-e-program
+ (mapconcat 'identity (cddddr cp-list) " "))
+ (apply 'call-process cp-list))))
+ (unless (or (null exitstatus)
+ (zerop exitstatus))
+ (nnheader-report 'nnir "Couldn't run swish-e: %s" exitstatus)
+ ;; swish-e failure reason is in this buffer, show it if
+ ;; the user wants it.
+ (when (> gnus-verbose 6)
+ (display-buffer nnir-tmp-buffer))))
+
+ ;; The results are output in the format of:
+ ;; rank path-name file-title file-size
+ (goto-char (point-min))
+ (while (re-search-forward
+ "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t)
+ (setq score (match-string 1)
+ artno (match-string 3)
+ dirnam (file-name-directory (match-string 2)))
+
+ ;; don't match directories
+ (when (string-match "^[0-9]+$" artno)
+ (when (not (null dirnam))
+
+ ;; remove nnir-swish-e-remove-prefix from beginning of dirname
+ (when (string-match (concat "^" nnir-swish-e-remove-prefix)
+ dirnam)
+ (setq dirnam (replace-match "" t t dirnam)))
+
+ (setq dirnam (substring dirnam 0 -1))
+ ;; eliminate all ".", "/", "\" from beginning. Always matches.
+ (string-match "^[./\\]*\\(.*\\)$" dirnam)
+ ;; "/" -> "."
+ (setq group (substitute ?. ?/ (match-string 1 dirnam)))
+ ;; Windows "\\" -> "."
+ (setq group (substitute ?. ?\\ group))
+
+ (push (vector group
+ (string-to-int artno)
+ (string-to-int score))
+ artlist))))
+
+ (message "Massaging swish-e output...done")
+
+ ;; Sort by score
+ (apply 'vector
+ (sort* artlist
+ (function (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y)))))))))
+
+;; Namazu interface
+(defun nnir-run-namazu (query &optional group)
+ "Run given query against Namazu. Returns a vector of (group name, file name)
+pairs (also vectors, actually).
+
+Tested with Namazu 2.0.6 on a GNU/Linux system."
+ (when group
+ (error "The Namazu backend cannot search specific groups"))
+ (save-excursion
+ (let (
+ (artlist nil)
+ (qstring (cdr (assq 'query query)))
+ (score nil)
+ (group nil)
+ (article nil)
+ )
+ (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (erase-buffer)
+ (let* ((cp-list
+ `( ,nnir-namazu-program
+ nil ; input from /dev/null
+ t ; output
+ nil ; don't redisplay
+ "-q" ; don't be verbose
+ "-a" ; show all matches
+ "-s" ; use short format
+ ,@nnir-namazu-additional-switches
+ ,qstring ; the query, in namazu format
+ ,nnir-namazu-index-directory ; index directory
+ ))
+ (exitstatus
+ (let ((process-environment (copy-sequence process-environment)))
+ ;; Disable locale.
+ (setenv "LC_ALL" "C")
+ (message "%s args: %s" nnir-namazu-program
+ (mapconcat 'identity (cddddr cp-list) " "))
+ (apply 'call-process cp-list))))
+ (unless (or (null exitstatus)
+ (zerop exitstatus))
+ (nnheader-report 'nnir "Couldn't run namazu: %s" exitstatus)
+ ;; Namazu failure reason is in this buffer, show it if
+ ;; the user wants it.
+ (when (> gnus-verbose 6)
+ (display-buffer nnir-tmp-buffer))))
+
+ ;; Namazu output looks something like this:
+ ;; 2. Re: Gnus agent expire broken (score: 55)
+ ;; /home/henrik/Mail/mail/sent/1310 (4,138 bytes)
+
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\([0-9]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)"
+ nil t)
+ (setq score (match-string 3)
+ group (file-name-directory (match-string 4))
+ article (file-name-nondirectory (match-string 4)))
+
+ ;; make sure article and group is sane
+ (when (and (string-match "^[0-9]+$" article)
+ (not (null group)))
+ (when (string-match (concat "^" nnir-namazu-remove-prefix) group)
+ (setq group (replace-match "" t t group)))
+
+ ;; remove trailing slash from groupname
+ (setq group (substring group 0 -1))
+
+ ;; stuff results into artlist vector
+ (push (vector (substitute ?. ?/ group)
+ (string-to-int article)
+ (string-to-int score)) artlist)))
+
+ ;; sort artlist by score
+ (apply 'vector
+ (sort* artlist
+ (function (lambda (x y)
+ (> (nnir-artitem-rsv x)
+ (nnir-artitem-rsv y)))))))))
+
+;;; Util Code:
+
+(defun nnir-read-parms (query)
+ "Reads additional search parameters according to `nnir-engines'."
+ (let ((parmspec (caddr (assoc nnir-search-engine nnir-engines))))
+ (cons (cons 'query query)
+ (mapcar 'nnir-read-parm parmspec))))
+
+(defun nnir-read-parm (parmspec)
+ "Reads a single search parameter.
+`parmspec' is a cons cell, the car is a symbol, the cdr is a prompt."
+ (let ((sym (car parmspec))
+ (prompt (cdr parmspec)))
+ (cons sym (read-string prompt))))
+
+(defun nnir-run-query (query)
+ "Invoke appropriate search engine function (see `nnir-engines').
+If some groups were process-marked, run the query for each of the groups
+and concat the results."
+ (let ((search-func (cadr (assoc nnir-search-engine nnir-engines)))
+ (q (car (read-from-string query))))
+ (if gnus-group-marked
+ (apply 'append
+ (mapcar (lambda (x)
+ (funcall search-func q x))
+ gnus-group-marked))
+ (funcall search-func q nil))))
+
+(defun nnir-group-full-name (shortname)
+ "For the given group name, return a full Gnus group name.
+The Gnus backend/server information is added."
+ (gnus-group-prefixed-name shortname nnir-mail-backend))
+
+(defun nnir-possibly-change-server (server)
+ (unless (and server (nnir-server-opened server))
+ (nnir-open-server server)))
+
+
+;; Data type article list.
+
+(defun nnir-artlist-length (artlist)
+ "Returns number of articles in artlist."
+ (length artlist))
+
+(defun nnir-artlist-article (artlist n)
+ "Returns from ARTLIST the Nth artitem (counting starting at 1)."
+ (elt artlist (1- n)))
+
+(defun nnir-artitem-group (artitem)
+ "Returns the group from the ARTITEM."
+ (elt artitem 0))
+
+(defun nnir-artlist-artitem-group (artlist n)
+ "Returns from ARTLIST the group of the Nth artitem (counting from 1)."
+ (nnir-artitem-group (nnir-artlist-article artlist n)))
+
+(defun nnir-artitem-number (artitem)
+ "Returns the number from the ARTITEM."
+ (elt artitem 1))
+
+(defun nnir-artlist-artitem-number (artlist n)
+ "Returns from ARTLIST the number of the Nth artitem (counting from 1)."
+ (nnir-artitem-number (nnir-artlist-article artlist n)))
+
+(defun nnir-artitem-rsv (artitem)
+ "Returns the Retrieval Status Value (RSV, score) from the ARTITEM."
+ (elt artitem 2))
+
+(defun nnir-artlist-artitem-rsv (artlist n)
+ "Returns from ARTLIST the Retrieval Status Value of the Nth artitem
+(counting from 1)."
+ (nnir-artitem-rsv (nnir-artlist-article artlist n)))
+
+;; unused?
+(defun nnir-artlist-groups (artlist)
+ "Returns a list of all groups in the given ARTLIST."
+ (let ((res nil)
+ (with-dups nil))
+ ;; from each artitem, extract group component
+ (setq with-dups (mapcar 'nnir-artitem-group artlist))
+ ;; remove duplicates from above
+ (mapcar (function (lambda (x) (add-to-list 'res x)))
+ with-dups)
+ res))
+
+
+;; The end.
+(provide 'nnir)
--- /dev/null
+;;; nnmaildir.el --- maildir backend for Gnus
+;; Public domain.
+
+;; Author: Paul Jarc <prj@po.cwru.edu>
+
+;; 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 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:
+
+;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
+;; and in the maildir(5) man page from qmail (available at
+;; <URL:http://www.qmail.org/man/man5/maildir.html>). nnmaildir also stores
+;; extra information in the .nnmaildir/ directory within a maildir.
+;;
+;; Some goals of nnmaildir:
+;; * Everything Just Works, and correctly. E.g., NOV data is automatically
+;; regenerated when stale; no need for manually running
+;; *-generate-nov-databases.
+;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
+;; SIGKILL will never corrupt its data in the filesystem.
+;; * Allow concurrent operation as much as possible. If files change out
+;; from under us, adapt to the changes or degrade gracefully.
+;; * We use the filesystem as a database, so that, e.g., it's easy to
+;; manipulate marks from outside Gnus.
+;; * All information about a group is stored in the maildir, for easy backup,
+;; copying, restoring, etc.
+;;
+;; Todo:
+;; * Add a hook for when moving messages from new/ to cur/, to support
+;; nnmail's duplicate detection.
+;; * Improve generated Xrefs, so crossposts are detectable.
+;; * Improve code readability.
+
+;;; Code:
+
+;; eval this before editing
+[(progn
+ (put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0)
+ (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0)
+ (put 'nnmaildir--with-nov-buffer 'lisp-indent-function 0)
+ (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0)
+ )
+]
+
+(eval-and-compile
+ (require 'nnheader)
+ (require 'gnus)
+ (require 'gnus-util)
+ (require 'gnus-range)
+ (require 'gnus-start)
+ (require 'gnus-int)
+ (require 'message))
+(eval-when-compile
+ (require 'cl)
+ (require 'nnmail))
+
+(defconst nnmaildir-version "Gnus")
+
+(defvar nnmaildir-article-file-name nil
+ "*The filename of the most recently requested article. This variable is set
+by nnmaildir-request-article.")
+
+;; The filename of the article being moved/copied:
+(defvar nnmaildir--file nil)
+
+;; Variables to generate filenames of messages being delivered:
+(defvar nnmaildir--delivery-time "")
+(defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
+(defvar nnmaildir--delivery-count nil)
+
+;; An obarry containing symbols whose names are server names and whose values
+;; are servers:
+(defvar nnmaildir--servers (make-vector 3 0))
+;; The current server:
+(defvar nnmaildir--cur-server nil)
+
+;; A copy of nnmail-extra-headers
+(defvar nnmaildir--extra nil)
+
+;; A NOV structure looks like this (must be prin1-able, so no defstruct):
+["subject\tfrom\tdate"
+ "references\tchars\lines"
+ "To: you\tIn-Reply-To: <your.mess@ge>"
+ (12345 67890) ;; modtime of the corresponding article file
+ (to in-reply-to)] ;; contemporary value of nnmail-extra-headers
+(defconst nnmaildir--novlen 5)
+(defmacro nnmaildir--nov-new (beg mid end mtime extra)
+ `(vector ,beg ,mid ,end ,mtime ,extra))
+(defmacro nnmaildir--nov-get-beg (nov) `(aref ,nov 0))
+(defmacro nnmaildir--nov-get-mid (nov) `(aref ,nov 1))
+(defmacro nnmaildir--nov-get-end (nov) `(aref ,nov 2))
+(defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3))
+(defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4))
+(defmacro nnmaildir--nov-set-beg (nov value) `(aset ,nov 0 ,value))
+(defmacro nnmaildir--nov-set-mid (nov value) `(aset ,nov 1 ,value))
+(defmacro nnmaildir--nov-set-end (nov value) `(aset ,nov 2 ,value))
+(defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
+(defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
+
+(defstruct nnmaildir--art
+ (prefix nil :type string) ;; "time.pid.host"
+ (suffix nil :type string) ;; ":2,flags"
+ (num nil :type natnum) ;; article number
+ (msgid nil :type string) ;; "<mess.age@id>"
+ (nov nil :type vector)) ;; cached nov structure, or nil
+
+(defstruct nnmaildir--grp
+ (name nil :type string) ;; "group.name"
+ (new nil :type list) ;; new/ modtime
+ (cur nil :type list) ;; cur/ modtime
+ (min 1 :type natnum) ;; minimum article number
+ (count 0 :type natnum) ;; count of articles
+ (nlist nil :type list) ;; list of articles, ordered descending by number
+ (flist nil :type vector) ;; obarray mapping filename prefix->article
+ (mlist nil :type vector) ;; obarray mapping message-id->article
+ (cache nil :type vector) ;; nov cache
+ (index nil :type natnum) ;; index of next cache entry to replace
+ (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime
+ ; ("Mark Mod Time Hash")
+
+(defstruct nnmaildir--srv
+ (address nil :type string) ;; server address string
+ (method nil :type list) ;; (nnmaildir "address" ...)
+ (prefix nil :type string) ;; "nnmaildir+address:"
+ (dir nil :type string) ;; "/expanded/path/to/server/dir/"
+ (ls nil :type function) ;; directory-files function
+ (groups nil :type vector) ;; obarray mapping group name->group
+ (curgrp nil :type nnmaildir--grp) ;; current group, or nil
+ (error nil :type string) ;; last error message, or nil
+ (mtime nil :type list) ;; modtime of dir
+ (gnm nil) ;; flag: split from mail-sources?
+ (target-prefix nil :type string)) ;; symlink target prefix
+
+(defun nnmaildir--expired-article (group article)
+ (setf (nnmaildir--art-nov article) nil)
+ (let ((flist (nnmaildir--grp-flist group))
+ (mlist (nnmaildir--grp-mlist group))
+ (min (nnmaildir--grp-min group))
+ (count (1- (nnmaildir--grp-count group)))
+ (prefix (nnmaildir--art-prefix article))
+ (msgid (nnmaildir--art-msgid article))
+ (new-nlist nil)
+ (nlist-pre '(nil . nil))
+ nlist-post num)
+ (unless (zerop count)
+ (setq nlist-post (nnmaildir--grp-nlist group)
+ num (nnmaildir--art-num article))
+ (if (eq num (caar nlist-post))
+ (setq new-nlist (cdr nlist-post))
+ (setq new-nlist nlist-post
+ nlist-pre nlist-post
+ nlist-post (cdr nlist-post))
+ (while (/= num (caar nlist-post))
+ (setq nlist-pre nlist-post
+ nlist-post (cdr nlist-post)))
+ (setq nlist-post (cdr nlist-post))
+ (if (eq num min)
+ (setq min (caar nlist-pre)))))
+ (let ((inhibit-quit t))
+ (setf (nnmaildir--grp-min group) min)
+ (setf (nnmaildir--grp-count group) count)
+ (setf (nnmaildir--grp-nlist group) new-nlist)
+ (setcdr nlist-pre nlist-post)
+ (unintern prefix flist)
+ (unintern msgid mlist))))
+
+(defun nnmaildir--nlist-art (group num)
+ (let ((entry (assq num (nnmaildir--grp-nlist group))))
+ (if entry
+ (cdr entry))))
+(defmacro nnmaildir--flist-art (list file)
+ `(symbol-value (intern-soft ,file ,list)))
+(defmacro nnmaildir--mlist-art (list msgid)
+ `(symbol-value (intern-soft ,msgid ,list)))
+
+(defun nnmaildir--pgname (server gname)
+ (let ((prefix (nnmaildir--srv-prefix server)))
+ (if prefix (concat prefix gname)
+ (setq gname (gnus-group-prefixed-name gname
+ (nnmaildir--srv-method server)))
+ (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname))
+ gname)))
+
+(defun nnmaildir--param (pgname param)
+ (setq param (gnus-group-find-parameter pgname param 'allow-list))
+ (if (vectorp param) (setq param (aref param 0)))
+ (eval param))
+
+(defmacro nnmaildir--with-nntp-buffer (&rest body)
+ `(save-excursion
+ (set-buffer nntp-server-buffer)
+ ,@body))
+(defmacro nnmaildir--with-work-buffer (&rest body)
+ `(save-excursion
+ (set-buffer (get-buffer-create " *nnmaildir work*"))
+ ,@body))
+(defmacro nnmaildir--with-nov-buffer (&rest body)
+ `(save-excursion
+ (set-buffer (get-buffer-create " *nnmaildir nov*"))
+ ,@body))
+(defmacro nnmaildir--with-move-buffer (&rest body)
+ `(save-excursion
+ (set-buffer (get-buffer-create " *nnmaildir move*"))
+ ,@body))
+
+(defmacro nnmaildir--subdir (dir subdir)
+ `(file-name-as-directory (concat ,dir ,subdir)))
+(defmacro nnmaildir--srvgrp-dir (srv-dir gname)
+ `(nnmaildir--subdir ,srv-dir ,gname))
+(defmacro nnmaildir--tmp (dir) `(nnmaildir--subdir ,dir "tmp"))
+(defmacro nnmaildir--new (dir) `(nnmaildir--subdir ,dir "new"))
+(defmacro nnmaildir--cur (dir) `(nnmaildir--subdir ,dir "cur"))
+(defmacro nnmaildir--nndir (dir) `(nnmaildir--subdir ,dir ".nnmaildir"))
+(defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov"))
+(defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks"))
+(defmacro nnmaildir--num-dir (dir) `(nnmaildir--subdir ,dir "num"))
+(defmacro nnmaildir--num-file (dir) `(concat ,dir ":"))
+
+(defmacro nnmaildir--unlink (file-arg)
+ `(let ((file ,file-arg))
+ (if (file-attributes file) (delete-file file))))
+(defun nnmaildir--mkdir (dir)
+ (or (file-exists-p (file-name-as-directory dir))
+ (make-directory-internal (directory-file-name dir))))
+(defun nnmaildir--delete-dir-files (dir ls)
+ (when (file-attributes dir)
+ (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
+ (delete-directory dir)))
+
+(defun nnmaildir--group-maxnum (server group)
+ (if (zerop (nnmaildir--grp-count group)) 0
+ (let ((x (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
+ (nnmaildir--grp-name group))))
+ (setq x (nnmaildir--nndir x)
+ x (nnmaildir--num-dir x)
+ x (nnmaildir--num-file x)
+ x (file-attributes x))
+ (if x (1- (nth 1 x)) 0))))
+
+;; Make the given server, if non-nil, be the current server. Then make the
+;; given group, if non-nil, be the current group of the current server. Then
+;; return the group object for the current group.
+(defun nnmaildir--prepare (server group)
+ (let (x groups)
+ (catch 'return
+ (if (null server)
+ (unless (setq server nnmaildir--cur-server)
+ (throw 'return nil))
+ (unless (setq server (intern-soft server nnmaildir--servers))
+ (throw 'return nil))
+ (setq server (symbol-value server)
+ nnmaildir--cur-server server))
+ (unless (setq groups (nnmaildir--srv-groups server))
+ (throw 'return nil))
+ (unless (nnmaildir--srv-method server)
+ (setq x (concat "nnmaildir:" (nnmaildir--srv-address server))
+ x (gnus-server-to-method x))
+ (unless x (throw 'return nil))
+ (setf (nnmaildir--srv-method server) x))
+ (if (null group)
+ (unless (setq group (nnmaildir--srv-curgrp server))
+ (throw 'return nil))
+ (unless (setq group (intern-soft group groups))
+ (throw 'return nil))
+ (setq group (symbol-value group)))
+ group)))
+
+(defun nnmaildir--tab-to-space (string)
+ (let ((pos 0))
+ (while (string-match "\t" string pos)
+ (aset string (match-beginning 0) ? )
+ (setq pos (match-end 0))))
+ string)
+
+(defun nnmaildir--update-nov (server group article)
+ (let ((nnheader-file-coding-system 'binary)
+ (srv-dir (nnmaildir--srv-dir server))
+ (storage-version 1) ;; [version article-number msgid [...nov...]]
+ dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
+ nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
+ deactivate-mark)
+ (catch 'return
+ (setq gname (nnmaildir--grp-name group)
+ pgname (nnmaildir--pgname server gname)
+ dir (nnmaildir--srvgrp-dir srv-dir gname)
+ msgdir (if (nnmaildir--param pgname 'read-only)
+ (nnmaildir--new dir) (nnmaildir--cur dir))
+ prefix (nnmaildir--art-prefix article)
+ suffix (nnmaildir--art-suffix article)
+ file (concat msgdir prefix suffix)
+ attr (file-attributes file))
+ (unless attr
+ (nnmaildir--expired-article group article)
+ (throw 'return nil))
+ (setq mtime (nth 5 attr)
+ attr (nth 7 attr)
+ nov (nnmaildir--art-nov article)
+ dir (nnmaildir--nndir dir)
+ novdir (nnmaildir--nov-dir dir)
+ novfile (concat novdir prefix))
+ (unless (equal nnmaildir--extra nnmail-extra-headers)
+ (setq nnmaildir--extra (copy-sequence nnmail-extra-headers)))
+ (nnmaildir--with-nov-buffer
+ ;; First we'll check for already-parsed NOV data.
+ (cond ((not (file-exists-p novfile))
+ ;; The NOV file doesn't exist; we have to parse the message.
+ (setq nov nil))
+ ((not nov)
+ ;; The file exists, but the data isn't in memory; read the file.
+ (erase-buffer)
+ (nnheader-insert-file-contents novfile)
+ (setq nov (read (current-buffer)))
+ (if (not (and (vectorp nov)
+ (/= 0 (length nov))
+ (equal storage-version (aref nov 0))))
+ ;; This NOV data seems to be in the wrong format.
+ (setq nov nil)
+ (unless (nnmaildir--art-num article)
+ (setf (nnmaildir--art-num article) (aref nov 1)))
+ (unless (nnmaildir--art-msgid article)
+ (setf (nnmaildir--art-msgid article) (aref nov 2)))
+ (setq nov (aref nov 3)))))
+ ;; Now check whether the already-parsed data (if we have any) is
+ ;; usable: if the message has been edited or if nnmail-extra-headers
+ ;; has been augmented since this data was parsed from the message,
+ ;; then we have to reparse. Otherwise it's up-to-date.
+ (when (and nov (equal mtime (nnmaildir--nov-get-mtime nov)))
+ ;; The timestamp matches. Now check nnmail-extra-headers.
+ (setq old-extra (nnmaildir--nov-get-extra nov))
+ (when (equal nnmaildir--extra old-extra) ;; common case
+ ;; Save memory; use a single copy of the list value.
+ (nnmaildir--nov-set-extra nov nnmaildir--extra)
+ (throw 'return nov))
+ ;; They're not equal, but maybe the new is a subset of the old.
+ (if (null nnmaildir--extra)
+ ;; The empty set is a subset of every set.
+ (throw 'return nov))
+ (if (not (memq nil (mapcar (lambda (e) (memq e old-extra))
+ nnmaildir--extra)))
+ (throw 'return nov)))
+ ;; Parse the NOV data out of the message.
+ (erase-buffer)
+ (nnheader-insert-file-contents file)
+ (insert "\n")
+ (goto-char (point-min))
+ (save-restriction
+ (if (search-forward "\n\n" nil 'noerror)
+ (progn
+ (setq nov-mid (count-lines (point) (point-max)))
+ (narrow-to-region (point-min) (1- (point))))
+ (setq nov-mid 0))
+ (goto-char (point-min))
+ (delete-char 1)
+ (setq nov (nnheader-parse-naked-head)
+ field (or (mail-header-lines nov) 0)))
+ (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
+ (setq nov-mid field))
+ (setq nov-mid (number-to-string nov-mid)
+ nov-mid (concat (number-to-string attr) "\t" nov-mid))
+ (save-match-data
+ (setq field (or (mail-header-references nov) ""))
+ (nnmaildir--tab-to-space field)
+ (setq nov-mid (concat field "\t" nov-mid)
+ nov-beg (mapconcat
+ (lambda (f) (nnmaildir--tab-to-space (or f "")))
+ (list (mail-header-subject nov)
+ (mail-header-from nov)
+ (mail-header-date nov)) "\t")
+ nov-end (mapconcat
+ (lambda (extra)
+ (setq field (symbol-name (car extra))
+ val (cdr extra))
+ (nnmaildir--tab-to-space field)
+ (nnmaildir--tab-to-space val)
+ (concat field ": " val))
+ (mail-header-extra nov) "\t")))
+ (setq msgid (mail-header-id nov))
+ (if (or (null msgid) (nnheader-fake-message-id-p msgid))
+ (setq msgid (concat "<" prefix "@nnmaildir>")))
+ (nnmaildir--tab-to-space msgid)
+ ;; The data is parsed; create an nnmaildir NOV structure.
+ (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime
+ nnmaildir--extra)
+ num (nnmaildir--art-num article))
+ (unless num
+ ;; Allocate a new article number.
+ (erase-buffer)
+ (setq numdir (nnmaildir--num-dir dir)
+ file (nnmaildir--num-file numdir)
+ num -1)
+ (nnmaildir--mkdir numdir)
+ (write-region "" nil file nil 'no-message)
+ (while file
+ ;; Get the number of links to file.
+ (setq attr (nth 1 (file-attributes file)))
+ (if (= attr num)
+ ;; We've already tried this number, in the previous loop
+ ;; iteration, and failed.
+ (signal 'error `("Corrupt internal nnmaildir data" ,numdir)))
+ ;; If attr is 123, try to link file to "123". This atomically
+ ;; increases the link count and creates the "123" link, failing
+ ;; if that link was already created by another Gnus, just after
+ ;; we stat()ed file.
+ (condition-case nil
+ (progn
+ (add-name-to-file file (concat numdir (format "%x" attr)))
+ (setq file nil)) ;; Stop looping.
+ (file-already-exists nil))
+ (setq num attr))
+ (setf (nnmaildir--art-num article) num))
+ ;; Store this new NOV data in a file
+ (erase-buffer)
+ (prin1 (vector storage-version num msgid nov) (current-buffer))
+ (setq file (concat novfile ":"))
+ (nnmaildir--unlink file)
+ (write-region (point-min) (point-max) file nil 'no-message nil 'excl))
+ (rename-file file novfile 'replace)
+ (setf (nnmaildir--art-msgid article) msgid)
+ nov)))
+
+(defun nnmaildir--cache-nov (group article nov)
+ (let ((cache (nnmaildir--grp-cache group))
+ (index (nnmaildir--grp-index group))
+ goner)
+ (unless (nnmaildir--art-nov article)
+ (setq goner (aref cache index))
+ (if goner (setf (nnmaildir--art-nov goner) nil))
+ (aset cache index article)
+ (setf (nnmaildir--grp-index group) (% (1+ index) (length cache))))
+ (setf (nnmaildir--art-nov article) nov)))
+
+(defun nnmaildir--grp-add-art (server group article)
+ (let ((nov (nnmaildir--update-nov server group article))
+ count num min nlist nlist-cdr insert-nlist)
+ (when nov
+ (setq count (1+ (nnmaildir--grp-count group))
+ num (nnmaildir--art-num article)
+ min (if (= count 1) num
+ (min num (nnmaildir--grp-min group)))
+ nlist (nnmaildir--grp-nlist group))
+ (if (or (null nlist) (> num (caar nlist)))
+ (setq nlist (cons (cons num article) nlist))
+ (setq insert-nlist t
+ nlist-cdr (cdr nlist))
+ (while (and nlist-cdr (< num (caar nlist-cdr)))
+ (setq nlist nlist-cdr
+ nlist-cdr (cdr nlist))))
+ (let ((inhibit-quit t))
+ (setf (nnmaildir--grp-count group) count)
+ (setf (nnmaildir--grp-min group) min)
+ (if insert-nlist
+ (setcdr nlist (cons (cons num article) nlist-cdr))
+ (setf (nnmaildir--grp-nlist group) nlist))
+ (set (intern (nnmaildir--art-prefix article)
+ (nnmaildir--grp-flist group))
+ article)
+ (set (intern (nnmaildir--art-msgid article)
+ (nnmaildir--grp-mlist group))
+ article)
+ (set (intern (nnmaildir--grp-name group)
+ (nnmaildir--srv-groups server))
+ group))
+ (nnmaildir--cache-nov group article nov)
+ t)))
+
+(defun nnmaildir--group-ls (server pgname)
+ (or (nnmaildir--param pgname 'directory-files)
+ (nnmaildir--srv-ls server)))
+
+(defun nnmaildir-article-number-to-file-name
+ (number group-name server-address-string)
+ (let ((group (nnmaildir--prepare server-address-string group-name))
+ article dir pgname)
+ (catch 'return
+ (unless group
+ ;; The given group or server does not exist.
+ (throw 'return nil))
+ (setq article (nnmaildir--nlist-art group number))
+ (unless article
+ ;; The given article number does not exist in this group.
+ (throw 'return nil))
+ (setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name)
+ dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir dir group-name)
+ dir (if (nnmaildir--param pgname 'read-only)
+ (nnmaildir--new dir) (nnmaildir--cur dir)))
+ (concat dir (nnmaildir--art-prefix article)
+ (nnmaildir--art-suffix article)))))
+
+(defun nnmaildir-article-number-to-base-name
+ (number group-name server-address-string)
+ (let ((x (nnmaildir--prepare server-address-string group-name)))
+ (when x
+ (setq x (nnmaildir--nlist-art x number))
+ (and x (cons (nnmaildir--art-prefix x)
+ (nnmaildir--art-suffix x))))))
+
+(defun nnmaildir-base-name-to-article-number
+ (base-name group-name server-address-string)
+ (let ((x (nnmaildir--prepare server-address-string group-name)))
+ (when x
+ (setq x (nnmaildir--grp-flist x)
+ x (nnmaildir--flist-art x base-name))
+ (and x (nnmaildir--art-num x)))))
+
+(defun nnmaildir--nlist-iterate (nlist ranges func)
+ (let (entry high low nlist2)
+ (if (eq ranges 'all)
+ (setq ranges `((1 . ,(caar nlist)))))
+ (while ranges
+ (setq entry (car ranges) ranges (cdr ranges))
+ (while (and ranges (eq entry (car ranges)))
+ (setq ranges (cdr ranges))) ;; skip duplicates
+ (if (numberp entry)
+ (setq low entry
+ high entry)
+ (setq low (car entry)
+ high (cdr entry)))
+ (setq nlist2 nlist) ;; Don't assume any sorting of ranges
+ (catch 'iterate-loop
+ (while nlist2
+ (if (<= (caar nlist2) high) (throw 'iterate-loop nil))
+ (setq nlist2 (cdr nlist2))))
+ (catch 'iterate-loop
+ (while nlist2
+ (setq entry (car nlist2) nlist2 (cdr nlist2))
+ (if (< (car entry) low) (throw 'iterate-loop nil))
+ (funcall func (cdr entry)))))))
+
+(defun nnmaildir--up2-1 (n)
+ (if (zerop n) 1 (1- (lsh 1 (1+ (logb n))))))
+
+(defun nnmaildir--system-name ()
+ (gnus-replace-in-string
+ (gnus-replace-in-string
+ (gnus-replace-in-string
+ (system-name)
+ "\\\\" "\\134" 'literal)
+ "/" "\\057" 'literal)
+ ":" "\\072" 'literal))
+
+(defun nnmaildir-request-type (group &optional article)
+ 'mail)
+
+(defun nnmaildir-status-message (&optional server)
+ (nnmaildir--prepare server nil)
+ (nnmaildir--srv-error nnmaildir--cur-server))
+
+(defun nnmaildir-server-opened (&optional server)
+ (and nnmaildir--cur-server
+ (if server
+ (string-equal server (nnmaildir--srv-address nnmaildir--cur-server))
+ t)
+ (nnmaildir--srv-groups nnmaildir--cur-server)
+ t))
+
+(defun nnmaildir-open-server (server &optional defs)
+ (let ((x server)
+ dir size)
+ (catch 'return
+ (setq server (intern-soft x nnmaildir--servers))
+ (if server
+ (and (setq server (symbol-value server))
+ (nnmaildir--srv-groups server)
+ (setq nnmaildir--cur-server server)
+ (throw 'return t))
+ (setq server (make-nnmaildir--srv :address x))
+ (let ((inhibit-quit t))
+ (set (intern x nnmaildir--servers) server)))
+ (setq dir (assq 'directory defs))
+ (unless dir
+ (setf (nnmaildir--srv-error server)
+ "You must set \"directory\" in the select method")
+ (throw 'return nil))
+ (setq dir (cadr dir)
+ dir (eval dir)
+ dir (expand-file-name dir)
+ dir (file-name-as-directory dir))
+ (unless (file-exists-p dir)
+ (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
+ (throw 'return nil))
+ (setf (nnmaildir--srv-dir server) dir)
+ (setq x (assq 'directory-files defs))
+ (if (null x)
+ (setq x (if nnheader-directory-files-is-safe 'directory-files
+ 'nnheader-directory-files-safe))
+ (setq x (cadr x))
+ (unless (functionp x)
+ (setf (nnmaildir--srv-error server)
+ (concat "Not a function: " (prin1-to-string x)))
+ (throw 'return nil)))
+ (setf (nnmaildir--srv-ls server) x)
+ (setq size (length (funcall x dir nil "\\`[^.]" 'nosort))
+ size (nnmaildir--up2-1 size))
+ (and (setq x (assq 'get-new-mail defs))
+ (setq x (cdr x))
+ (car x)
+ (setf (nnmaildir--srv-gnm server) t)
+ (require 'nnmail))
+ (setq x (assq 'target-prefix defs))
+ (if x
+ (progn
+ (setq x (cadr x)
+ x (eval x))
+ (setf (nnmaildir--srv-target-prefix server) x))
+ (setq x (assq 'create-directory defs))
+ (if x
+ (progn
+ (setq x (cadr x)
+ x (eval x)
+ x (file-name-as-directory x))
+ (setf (nnmaildir--srv-target-prefix server) x))
+ (setf (nnmaildir--srv-target-prefix server) "")))
+ (setf (nnmaildir--srv-groups server) (make-vector size 0))
+ (setq nnmaildir--cur-server server)
+ t)))
+
+(defun nnmaildir--parse-filename (file)
+ (let ((prefix (car file))
+ timestamp len)
+ (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix)
+ (progn
+ (setq timestamp (concat "0000" (match-string 1 prefix))
+ len (- (length timestamp) 4))
+ (vector (string-to-number (substring timestamp 0 len))
+ (string-to-number (substring timestamp len))
+ (match-string 2 prefix)
+ file))
+ file)))
+
+(defun nnmaildir--sort-files (a b)
+ (catch 'return
+ (if (consp a)
+ (throw 'return (and (consp b) (string-lessp (car a) (car b)))))
+ (if (consp b) (throw 'return t))
+ (if (< (aref a 0) (aref b 0)) (throw 'return t))
+ (if (> (aref a 0) (aref b 0)) (throw 'return nil))
+ (if (< (aref a 1) (aref b 1)) (throw 'return t))
+ (if (> (aref a 1) (aref b 1)) (throw 'return nil))
+ (string-lessp (aref a 2) (aref b 2))))
+
+(defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls)
+ (catch 'return
+ (let ((36h-ago (- (car (current-time)) 2))
+ absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
+ files num dir flist group x)
+ (setq absdir (nnmaildir--srvgrp-dir srv-dir gname)
+ nndir (nnmaildir--nndir absdir))
+ (unless (file-exists-p absdir)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such directory: " absdir))
+ (throw 'return nil))
+ (setq tdir (nnmaildir--tmp absdir)
+ ndir (nnmaildir--new absdir)
+ cdir (nnmaildir--cur absdir)
+ nattr (file-attributes ndir)
+ cattr (file-attributes cdir))
+ (unless (and (file-exists-p tdir) nattr cattr)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Not a maildir: " absdir))
+ (throw 'return nil))
+ (setq group (nnmaildir--prepare nil gname)
+ pgname (nnmaildir--pgname nnmaildir--cur-server gname))
+ (if group
+ (setq isnew nil)
+ (setq isnew t
+ group (make-nnmaildir--grp :name gname :index 0))
+ (nnmaildir--mkdir nndir)
+ (nnmaildir--mkdir (nnmaildir--nov-dir nndir))
+ (nnmaildir--mkdir (nnmaildir--marks-dir nndir))
+ (write-region "" nil (concat nndir "markfile") nil 'no-message))
+ (setq read-only (nnmaildir--param pgname 'read-only)
+ ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
+ (unless read-only
+ (setq x (nth 11 (file-attributes tdir)))
+ (unless (and (= x (nth 11 nattr)) (= x (nth 11 cattr)))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Maildir spans filesystems: " absdir))
+ (throw 'return nil))
+ (mapcar
+ (lambda (file)
+ (setq x (file-attributes file))
+ (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
+ (delete-file file)))
+ (funcall ls tdir 'full "\\`[^.]" 'nosort)))
+ (or scan-msgs
+ isnew
+ (throw 'return t))
+ (setq nattr (nth 5 nattr))
+ (if (equal nattr (nnmaildir--grp-new group))
+ (setq nattr nil))
+ (if read-only (setq dir (and (or isnew nattr) ndir))
+ (when (or isnew nattr)
+ (mapcar
+ (lambda (file)
+ (let ((path (concat ndir file)))
+ (and (time-less-p (nth 5 (file-attributes path)) (current-time))
+ (rename-file path (concat cdir file ":2,")))))
+ (funcall ls ndir nil "\\`[^.]" 'nosort))
+ (setf (nnmaildir--grp-new group) nattr))
+ (setq cattr (nth 5 (file-attributes cdir)))
+ (if (equal cattr (nnmaildir--grp-cur group))
+ (setq cattr nil))
+ (setq dir (and (or isnew cattr) cdir)))
+ (unless dir (throw 'return t))
+ (setq files (funcall ls dir nil "\\`[^.]" 'nosort)
+ files (save-match-data
+ (mapcar
+ (lambda (f)
+ (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f)
+ (cons (match-string 1 f) (match-string 2 f)))
+ files)))
+ (when isnew
+ (setq num (nnmaildir--up2-1 (length files)))
+ (setf (nnmaildir--grp-flist group) (make-vector num 0))
+ (setf (nnmaildir--grp-mlist group) (make-vector num 0))
+ (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
+ (setq num (nnmaildir--param pgname 'nov-cache-size))
+ (if (numberp num) (if (< num 1) (setq num 1))
+ (setq num 16
+ cdir (nnmaildir--marks-dir nndir)
+ ndir (nnmaildir--subdir cdir "tick")
+ cdir (nnmaildir--subdir cdir "read"))
+ (mapcar
+ (lambda (file)
+ (setq file (car file))
+ (if (or (not (file-exists-p (concat cdir file)))
+ (file-exists-p (concat ndir file)))
+ (setq num (1+ num))))
+ files))
+ (setf (nnmaildir--grp-cache group) (make-vector num nil))
+ (let ((inhibit-quit t))
+ (set (intern gname groups) group))
+ (or scan-msgs (throw 'return t)))
+ (setq flist (nnmaildir--grp-flist group)
+ files (mapcar
+ (lambda (file)
+ (and (null (nnmaildir--flist-art flist (car file)))
+ file))
+ files)
+ files (delq nil files)
+ files (mapcar 'nnmaildir--parse-filename files)
+ files (sort files 'nnmaildir--sort-files))
+ (mapcar
+ (lambda (file)
+ (setq file (if (consp file) file (aref file 3))
+ x (make-nnmaildir--art :prefix (car file) :suffix (cdr file)))
+ (nnmaildir--grp-add-art nnmaildir--cur-server group x))
+ files)
+ (if read-only (setf (nnmaildir--grp-new group) nattr)
+ (setf (nnmaildir--grp-cur group) cattr)))
+ t))
+
+(defun nnmaildir-request-scan (&optional scan-group server)
+ (let ((coding-system-for-write nnheader-file-coding-system)
+ (output-coding-system nnheader-file-coding-system)
+ (buffer-file-coding-system nil)
+ (file-coding-system nil)
+ (file-coding-system-alist nil)
+ (nnmaildir-get-new-mail t)
+ (nnmaildir-group-alist nil)
+ (nnmaildir-active-file nil)
+ x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen
+ deactivate-mark)
+ (nnmaildir--prepare server nil)
+ (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server)
+ srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ method (nnmaildir--srv-method nnmaildir--cur-server)
+ groups (nnmaildir--srv-groups nnmaildir--cur-server)
+ target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
+ (nnmaildir--with-work-buffer
+ (save-match-data
+ (if (stringp scan-group)
+ (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
+ (if (nnmaildir--srv-gnm nnmaildir--cur-server)
+ (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
+ (unintern scan-group groups))
+ (setq x (nth 5 (file-attributes srv-dir))
+ scan-group (null scan-group))
+ (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
+ (if scan-group
+ (mapatoms (lambda (sym)
+ (nnmaildir--scan (symbol-name sym) t groups
+ method srv-dir srv-ls))
+ groups))
+ (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
+ dirs (if (zerop (length target-prefix))
+ dirs
+ (gnus-remove-if
+ (lambda (dir)
+ (and (>= (length dir) (length target-prefix))
+ (string= (substring dir 0
+ (length target-prefix))
+ target-prefix)))
+ dirs))
+ seen (nnmaildir--up2-1 (length dirs))
+ seen (make-vector seen 0))
+ (mapcar
+ (lambda (grp-dir)
+ (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
+ srv-ls)
+ (intern grp-dir seen)))
+ dirs)
+ (setq x nil)
+ (mapatoms (lambda (group)
+ (setq group (symbol-name group))
+ (unless (intern-soft group seen)
+ (setq x (cons group x))))
+ groups)
+ (mapcar (lambda (grp) (unintern grp groups)) x)
+ (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
+ (nth 5 (file-attributes srv-dir))))
+ (and scan-group
+ (nnmaildir--srv-gnm nnmaildir--cur-server)
+ (nnmail-get-new-mail 'nnmaildir nil nil))))))
+ t)
+
+(defun nnmaildir-request-list (&optional server)
+ (nnmaildir-request-scan 'find-new-groups server)
+ (let (pgname ro deactivate-mark)
+ (nnmaildir--prepare server nil)
+ (nnmaildir--with-nntp-buffer
+ (erase-buffer)
+ (mapatoms (lambda (group)
+ (setq pgname (symbol-name group)
+ pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
+ group (symbol-value group)
+ ro (nnmaildir--param pgname 'read-only))
+ (insert (nnmaildir--grp-name group) " ")
+ (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
+ nntp-server-buffer)
+ (insert " ")
+ (princ (nnmaildir--grp-min group) nntp-server-buffer)
+ (insert " " (if ro "n" "y") "\n"))
+ (nnmaildir--srv-groups nnmaildir--cur-server))))
+ t)
+
+(defun nnmaildir-request-newgroups (date &optional server)
+ (nnmaildir-request-list server))
+
+(defun nnmaildir-retrieve-groups (groups &optional server)
+ (let (group deactivate-mark)
+ (nnmaildir--prepare server nil)
+ (nnmaildir--with-nntp-buffer
+ (erase-buffer)
+ (mapcar
+ (lambda (gname)
+ (setq group (nnmaildir--prepare nil gname))
+ (if (null group) (insert "411 no such news group\n")
+ (insert "211 ")
+ (princ (nnmaildir--grp-count group) nntp-server-buffer)
+ (insert " ")
+ (princ (nnmaildir--grp-min group) nntp-server-buffer)
+ (insert " ")
+ (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
+ nntp-server-buffer)
+ (insert " " gname "\n")))
+ groups)))
+ 'group)
+
+(defun nnmaildir-request-update-info (gname info &optional server)
+ (let ((group (nnmaildir--prepare server gname))
+ pgname flist always-marks never-marks old-marks dotfile num dir
+ markdirs marks mark ranges markdir article read end new-marks ls
+ old-mmth new-mmth mtime mark-sym existing missing deactivate-mark)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (throw 'return nil))
+ (setq gname (nnmaildir--grp-name group)
+ pgname (nnmaildir--pgname nnmaildir--cur-server gname)
+ flist (nnmaildir--grp-flist group))
+ (when (zerop (nnmaildir--grp-count group))
+ (gnus-info-set-read info nil)
+ (gnus-info-set-marks info nil 'extend)
+ (throw 'return info))
+ (setq old-marks (cons 'read (gnus-info-read info))
+ old-marks (cons old-marks (gnus-info-marks info))
+ always-marks (nnmaildir--param pgname 'always-marks)
+ never-marks (nnmaildir--param pgname 'never-marks)
+ existing (nnmaildir--grp-nlist group)
+ existing (mapcar 'car existing)
+ existing (nreverse existing)
+ existing (gnus-compress-sequence existing 'always-list)
+ missing (list (cons 1 (nnmaildir--group-maxnum
+ nnmaildir--cur-server group)))
+ missing (gnus-range-difference missing existing)
+ dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir dir gname)
+ dir (nnmaildir--nndir dir)
+ dir (nnmaildir--marks-dir dir)
+ ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
+ markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
+ new-mmth (nnmaildir--up2-1 (length markdirs))
+ new-mmth (make-vector new-mmth 0)
+ old-mmth (nnmaildir--grp-mmth group))
+ (mapcar
+ (lambda (mark)
+ (setq markdir (nnmaildir--subdir dir mark)
+ mark-sym (intern mark)
+ ranges nil)
+ (catch 'got-ranges
+ (if (memq mark-sym never-marks) (throw 'got-ranges nil))
+ (when (memq mark-sym always-marks)
+ (setq ranges existing)
+ (throw 'got-ranges nil))
+ (setq mtime (nth 5 (file-attributes markdir)))
+ (set (intern mark new-mmth) mtime)
+ (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
+ (setq ranges (assq mark-sym old-marks))
+ (if ranges (setq ranges (cdr ranges)))
+ (throw 'got-ranges nil))
+ (mapcar
+ (lambda (prefix)
+ (setq article (nnmaildir--flist-art flist prefix))
+ (if article
+ (setq ranges
+ (gnus-add-to-range ranges
+ `(,(nnmaildir--art-num article))))))
+ (funcall ls markdir nil "\\`[^.]" 'nosort)))
+ (if (eq mark-sym 'read) (setq read ranges)
+ (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
+ markdirs)
+ (gnus-info-set-read info (gnus-range-add read missing))
+ (gnus-info-set-marks info marks 'extend)
+ (setf (nnmaildir--grp-mmth group) new-mmth)
+ info)))
+
+(defun nnmaildir-request-group (gname &optional server fast)
+ (let ((group (nnmaildir--prepare server gname))
+ deactivate-mark)
+ (catch 'return
+ (unless group
+ ;; (insert "411 no such news group\n")
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (throw 'return nil))
+ (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
+ (if fast (throw 'return t))
+ (nnmaildir--with-nntp-buffer
+ (erase-buffer)
+ (insert "211 ")
+ (princ (nnmaildir--grp-count group) nntp-server-buffer)
+ (insert " ")
+ (princ (nnmaildir--grp-min group) nntp-server-buffer)
+ (insert " ")
+ (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
+ nntp-server-buffer)
+ (insert " " gname "\n")
+ t))))
+
+(defun nnmaildir-request-create-group (gname &optional server args)
+ (nnmaildir--prepare server nil)
+ (catch 'return
+ (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
+ srv-dir dir groups)
+ (when (zerop (length gname))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ "Invalid (empty) group name")
+ (throw 'return nil))
+ (when (eq (aref "." 0) (aref gname 0))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ "Group names may not start with \".\"")
+ (throw 'return nil))
+ (when (save-match-data (string-match "[\0/\t]" gname))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Illegal characters (null, tab, or /) in group name: "
+ gname))
+ (throw 'return nil))
+ (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
+ (when (intern-soft gname groups)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Group already exists: " gname))
+ (throw 'return nil))
+ (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
+ (if (file-name-absolute-p target-prefix)
+ (setq dir (expand-file-name target-prefix))
+ (setq dir srv-dir
+ dir (file-truename dir)
+ dir (concat dir target-prefix)))
+ (setq dir (nnmaildir--subdir dir gname))
+ (nnmaildir--mkdir dir)
+ (nnmaildir--mkdir (nnmaildir--tmp dir))
+ (nnmaildir--mkdir (nnmaildir--new dir))
+ (nnmaildir--mkdir (nnmaildir--cur dir))
+ (unless (string= target-prefix "")
+ (make-symbolic-link (concat target-prefix gname)
+ (concat srv-dir gname)))
+ (nnmaildir-request-scan 'find-new-groups))))
+
+(defun nnmaildir-request-rename-group (gname new-name &optional server)
+ (let ((group (nnmaildir--prepare server gname))
+ (coding-system-for-write nnheader-file-coding-system)
+ (output-coding-system nnheader-file-coding-system)
+ (buffer-file-coding-system nil)
+ (file-coding-system nil)
+ (file-coding-system-alist nil)
+ srv-dir x groups)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (throw 'return nil))
+ (when (zerop (length new-name))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ "Invalid (empty) group name")
+ (throw 'return nil))
+ (when (eq (aref "." 0) (aref new-name 0))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ "Group names may not start with \".\"")
+ (throw 'return nil))
+ (when (save-match-data (string-match "[\0/\t]" new-name))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Illegal characters (null, tab, or /) in group name: "
+ new-name))
+ (throw 'return nil))
+ (if (string-equal gname new-name) (throw 'return t))
+ (when (intern-soft new-name
+ (nnmaildir--srv-groups nnmaildir--cur-server))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Group already exists: " new-name))
+ (throw 'return nil))
+ (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
+ (condition-case err
+ (rename-file (concat srv-dir gname)
+ (concat srv-dir new-name))
+ (error
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Error renaming link: " (prin1-to-string err)))
+ (throw 'return nil)))
+ (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
+ groups (make-vector (length x) 0))
+ (mapatoms (lambda (sym)
+ (unless (eq (symbol-value sym) group)
+ (set (intern (symbol-name sym) groups)
+ (symbol-value sym))))
+ x)
+ (setq group (copy-sequence group))
+ (setf (nnmaildir--grp-name group) new-name)
+ (set (intern new-name groups) group)
+ (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
+ t)))
+
+(defun nnmaildir-request-delete-group (gname force &optional server)
+ (let ((group (nnmaildir--prepare server gname))
+ pgname grp-dir target dir ls deactivate-mark)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (throw 'return nil))
+ (setq gname (nnmaildir--grp-name group)
+ pgname (nnmaildir--pgname nnmaildir--cur-server gname)
+ grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ target (car (file-attributes (concat grp-dir gname)))
+ grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
+ (unless (or force (stringp target))
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Not a symlink: " gname))
+ (throw 'return nil))
+ (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
+ (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
+ (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
+ (if (not force)
+ (progn
+ (setq grp-dir (directory-file-name grp-dir))
+ (nnmaildir--unlink grp-dir))
+ (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname))
+ (if (nnmaildir--param pgname 'read-only)
+ (progn (delete-directory (nnmaildir--tmp grp-dir))
+ (nnmaildir--unlink (nnmaildir--new grp-dir))
+ (delete-directory (nnmaildir--cur grp-dir)))
+ (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls)
+ (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls)
+ (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
+ (setq dir (nnmaildir--nndir grp-dir))
+ (mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls))
+ `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
+ ,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
+ 'nosort)))
+ (setq dir (nnmaildir--nndir grp-dir))
+ (nnmaildir--unlink (concat dir "markfile"))
+ (nnmaildir--unlink (concat dir "markfile{new}"))
+ (delete-directory (nnmaildir--marks-dir dir))
+ (delete-directory dir)
+ (if (not (stringp target))
+ (delete-directory grp-dir)
+ (setq grp-dir (directory-file-name grp-dir)
+ dir target)
+ (unless (eq (aref "/" 0) (aref dir 0))
+ (setq dir (concat (file-truename
+ (nnmaildir--srv-dir nnmaildir--cur-server))
+ dir)))
+ (delete-directory dir)
+ (nnmaildir--unlink grp-dir)))
+ t)))
+
+(defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
+ (let ((group (nnmaildir--prepare server gname))
+ srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
+ deactivate-mark)
+ (setq insert-nov
+ (lambda (article)
+ (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
+ article))
+ (when nov
+ (nnmaildir--cache-nov group article nov)
+ (setq num (nnmaildir--art-num article))
+ (princ num nntp-server-buffer)
+ (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
+ (nnmaildir--art-msgid article) "\t"
+ (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
+ gname ":")
+ (princ num nntp-server-buffer)
+ (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (if gname (concat "No such group: " gname) "No current group"))
+ (throw 'return nil))
+ (nnmaildir--with-nntp-buffer
+ (erase-buffer)
+ (setq mlist (nnmaildir--grp-mlist group)
+ nlist (nnmaildir--grp-nlist group)
+ gname (nnmaildir--grp-name group)
+ srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir srv-dir gname))
+ (cond
+ ((null nlist))
+ ((and fetch-old (not (numberp fetch-old)))
+ (nnmaildir--nlist-iterate nlist 'all insert-nov))
+ ((null articles))
+ ((stringp (car articles))
+ (mapcar
+ (lambda (msgid)
+ (setq article (nnmaildir--mlist-art mlist msgid))
+ (if article (funcall insert-nov article)))
+ articles))
+ (t
+ (if fetch-old
+ ;; Assume the article range list is sorted ascending
+ (setq stop (car articles)
+ start (car (last articles))
+ stop (if (numberp stop) stop (car stop))
+ start (if (numberp start) start (cdr start))
+ stop (- stop fetch-old)
+ stop (if (< stop 1) 1 stop)
+ articles (list (cons stop start))))
+ (nnmaildir--nlist-iterate nlist articles insert-nov)))
+ (sort-numeric-fields 1 (point-min) (point-max))
+ 'nov))))
+
+(defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
+ (let ((group (nnmaildir--prepare server gname))
+ (case-fold-search t)
+ list article dir pgname deactivate-mark)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (if gname (concat "No such group: " gname) "No current group"))
+ (throw 'return nil))
+ (if (numberp num-msgid)
+ (setq article (nnmaildir--nlist-art group num-msgid))
+ (setq list (nnmaildir--grp-mlist group)
+ article (nnmaildir--mlist-art list num-msgid))
+ (if article (setq num-msgid (nnmaildir--art-num article))
+ (catch 'found
+ (mapatoms
+ (lambda (group-sym)
+ (setq group (symbol-value group-sym)
+ list (nnmaildir--grp-mlist group)
+ article (nnmaildir--mlist-art list num-msgid))
+ (when article
+ (setq num-msgid (nnmaildir--art-num article))
+ (throw 'found nil)))
+ (nnmaildir--srv-groups nnmaildir--cur-server))))
+ (unless article
+ (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
+ (throw 'return nil)))
+ (setq gname (nnmaildir--grp-name group)
+ pgname (nnmaildir--pgname nnmaildir--cur-server gname)
+ dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir dir gname)
+ dir (if (nnmaildir--param pgname 'read-only)
+ (nnmaildir--new dir) (nnmaildir--cur dir))
+ nnmaildir-article-file-name
+ (concat dir
+ (nnmaildir--art-prefix article)
+ (nnmaildir--art-suffix article)))
+ (unless (file-exists-p nnmaildir-article-file-name)
+ (nnmaildir--expired-article group article)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ "Article has expired")
+ (throw 'return nil))
+ (save-excursion
+ (set-buffer (or to-buffer nntp-server-buffer))
+ (erase-buffer)
+ (nnheader-insert-file-contents nnmaildir-article-file-name))
+ (cons gname num-msgid))))
+
+(defun nnmaildir-request-post (&optional server)
+ (let (message-required-mail-headers)
+ (funcall message-send-mail-function)))
+
+(defun nnmaildir-request-replace-article (number gname buffer)
+ (let ((group (nnmaildir--prepare nil gname))
+ (coding-system-for-write nnheader-file-coding-system)
+ (output-coding-system nnheader-file-coding-system)
+ (buffer-file-coding-system nil)
+ (file-coding-system nil)
+ (file-coding-system-alist nil)
+ dir file article suffix tmpfile deactivate-mark)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (throw 'return nil))
+ (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
+ 'read-only)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Read-only group: " group))
+ (throw 'return nil))
+ (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir dir gname)
+ article (nnmaildir--nlist-art group number))
+ (unless article
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such article: " (number-to-string number)))
+ (throw 'return nil))
+ (setq suffix (nnmaildir--art-suffix article)
+ file (nnmaildir--art-prefix article)
+ tmpfile (concat (nnmaildir--tmp dir) file))
+ (when (file-exists-p tmpfile)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "File exists: " tmpfile))
+ (throw 'return nil))
+ (save-excursion
+ (set-buffer buffer)
+ (write-region (point-min) (point-max) tmpfile nil 'no-message nil
+ 'excl))
+ (unix-sync) ;; no fsync :(
+ (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
+ t)))
+
+(defun nnmaildir-request-move-article (article gname server accept-form
+ &optional last)
+ (let ((group (nnmaildir--prepare server gname))
+ pgname suffix result nnmaildir--file deactivate-mark)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (throw 'return nil))
+ (setq gname (nnmaildir--grp-name group)
+ pgname (nnmaildir--pgname nnmaildir--cur-server gname)
+ article (nnmaildir--nlist-art group article))
+ (unless article
+ (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
+ (throw 'return nil))
+ (setq suffix (nnmaildir--art-suffix article)
+ nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
+ nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
+ nnmaildir--file (if (nnmaildir--param pgname 'read-only)
+ (nnmaildir--new nnmaildir--file)
+ (nnmaildir--cur nnmaildir--file))
+ nnmaildir--file (concat nnmaildir--file
+ (nnmaildir--art-prefix article)
+ suffix))
+ (unless (file-exists-p nnmaildir--file)
+ (nnmaildir--expired-article group article)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ "Article has expired")
+ (throw 'return nil))
+ (nnmaildir--with-move-buffer
+ (erase-buffer)
+ (nnheader-insert-file-contents nnmaildir--file)
+ (setq result (eval accept-form)))
+ (unless (or (null result) (nnmaildir--param pgname 'read-only))
+ (nnmaildir--unlink nnmaildir--file)
+ (nnmaildir--expired-article group article))
+ result)))
+
+(defun nnmaildir-request-accept-article (gname &optional server last)
+ (let ((group (nnmaildir--prepare server gname))
+ (coding-system-for-write nnheader-file-coding-system)
+ (output-coding-system nnheader-file-coding-system)
+ (buffer-file-coding-system nil)
+ (file-coding-system nil)
+ (file-coding-system-alist nil)
+ srv-dir dir file time tmpfile curfile 24h article)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (throw 'return nil))
+ (setq gname (nnmaildir--grp-name group))
+ (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
+ 'read-only)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Read-only group: " gname))
+ (throw 'return nil))
+ (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir srv-dir gname)
+ time (current-time)
+ file (format-time-string "%s." time))
+ (unless (string-equal nnmaildir--delivery-time file)
+ (setq nnmaildir--delivery-time file
+ nnmaildir--delivery-count 0))
+ (when (and (consp (cdr time))
+ (consp (cddr time)))
+ (setq file (concat file "M" (number-to-string (caddr time)))))
+ (setq file (concat file nnmaildir--delivery-pid)
+ file (concat file "Q" (number-to-string nnmaildir--delivery-count))
+ file (concat file "." (nnmaildir--system-name))
+ tmpfile (concat (nnmaildir--tmp dir) file)
+ curfile (concat (nnmaildir--cur dir) file ":2,"))
+ (when (file-exists-p tmpfile)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "File exists: " tmpfile))
+ (throw 'return nil))
+ (when (file-exists-p curfile)
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "File exists: " curfile))
+ (throw 'return nil))
+ (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
+ 24h (run-with-timer 86400 nil
+ (lambda ()
+ (nnmaildir--unlink tmpfile)
+ (setf (nnmaildir--srv-error
+ nnmaildir--cur-server)
+ "24-hour timer expired")
+ (throw 'return nil))))
+ (condition-case nil
+ (add-name-to-file nnmaildir--file tmpfile)
+ (error
+ (write-region (point-min) (point-max) tmpfile nil 'no-message nil
+ 'excl)
+ (unix-sync))) ;; no fsync :(
+ (cancel-timer 24h)
+ (condition-case err
+ (add-name-to-file tmpfile curfile)
+ (error
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "Error linking: " (prin1-to-string err)))
+ (nnmaildir--unlink tmpfile)
+ (throw 'return nil)))
+ (nnmaildir--unlink tmpfile)
+ (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
+ (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
+ (cons gname (nnmaildir--art-num article))))))
+
+(defun nnmaildir-save-mail (group-art)
+ (catch 'return
+ (unless group-art
+ (throw 'return nil))
+ (let (ga gname x groups nnmaildir--file deactivate-mark)
+ (save-excursion
+ (goto-char (point-min))
+ (save-match-data
+ (while (looking-at "From ")
+ (replace-match "X-From-Line: ")
+ (forward-line 1))))
+ (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
+ ga (car group-art) group-art (cdr group-art)
+ gname (car ga))
+ (or (intern-soft gname groups)
+ (nnmaildir-request-create-group gname)
+ (throw 'return nil)) ;; not that nnmail bothers to check :(
+ (unless (nnmaildir-request-accept-article gname)
+ (throw 'return nil))
+ (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
+ nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
+ x (nnmaildir--prepare nil gname)
+ x (nnmaildir--grp-nlist x)
+ x (cdar x)
+ nnmaildir--file (concat nnmaildir--file
+ (nnmaildir--art-prefix x)
+ (nnmaildir--art-suffix x)))
+ (delq nil
+ (mapcar
+ (lambda (ga)
+ (setq gname (car ga))
+ (and (or (intern-soft gname groups)
+ (nnmaildir-request-create-group gname))
+ (nnmaildir-request-accept-article gname)
+ ga))
+ group-art)))))
+
+(defun nnmaildir-active-number (gname)
+ 0)
+
+(defun nnmaildir-request-expire-articles (ranges &optional gname server force)
+ (let ((no-force (not force))
+ (group (nnmaildir--prepare server gname))
+ pgname time boundary bound-iter high low target dir nlist nlist2
+ stop article didnt nnmaildir--file nnmaildir-article-file-name
+ deactivate-mark)
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (if gname (concat "No such group: " gname) "No current group"))
+ (throw 'return (gnus-uncompress-range ranges)))
+ (setq gname (nnmaildir--grp-name group)
+ pgname (nnmaildir--pgname nnmaildir--cur-server gname))
+ (if (nnmaildir--param pgname 'read-only)
+ (throw 'return (gnus-uncompress-range ranges)))
+ (setq time (nnmaildir--param pgname 'expire-age))
+ (unless time
+ (setq time (or (and nnmail-expiry-wait-function
+ (funcall nnmail-expiry-wait-function gname))
+ nnmail-expiry-wait))
+ (if (eq time 'immediate)
+ (setq time 0)
+ (if (numberp time)
+ (setq time (* time 86400)))))
+ (when no-force
+ (unless (integerp time) ;; handle 'never
+ (throw 'return (gnus-uncompress-range ranges)))
+ (setq boundary (current-time)
+ high (- (car boundary) (/ time 65536))
+ low (- (cadr boundary) (% time 65536)))
+ (if (< low 0)
+ (setq low (+ low 65536)
+ high (1- high)))
+ (setcar (cdr boundary) low)
+ (setcar boundary high))
+ (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir dir gname)
+ dir (nnmaildir--cur dir)
+ nlist (nnmaildir--grp-nlist group)
+ ranges (reverse ranges))
+ (nnmaildir--with-move-buffer
+ (nnmaildir--nlist-iterate
+ nlist ranges
+ (lambda (article)
+ (setq nnmaildir--file (nnmaildir--art-prefix article)
+ nnmaildir--file (concat dir nnmaildir--file
+ (nnmaildir--art-suffix article))
+ time (file-attributes nnmaildir--file))
+ (cond
+ ((null time)
+ (nnmaildir--expired-article group article))
+ ((and no-force
+ (progn
+ (setq time (nth 5 time)
+ bound-iter boundary)
+ (while (and bound-iter time
+ (= (car bound-iter) (car time)))
+ (setq bound-iter (cdr bound-iter)
+ time (cdr time)))
+ (and bound-iter time
+ (car-less-than-car bound-iter time))))
+ (setq didnt (cons (nnmaildir--art-num article) didnt)))
+ (t
+ (setq nnmaildir-article-file-name nnmaildir--file
+ target (if force nil
+ (save-excursion
+ (save-restriction
+ (nnmaildir--param pgname 'expire-group)))))
+ (when (and (stringp target)
+ (not (string-equal target pgname))) ;; Move it.
+ (erase-buffer)
+ (nnheader-insert-file-contents nnmaildir--file)
+ (gnus-request-accept-article target nil nil 'no-encode))
+ (if (equal target pgname)
+ ;; Leave it here.
+ (setq didnt (cons (nnmaildir--art-num article) didnt))
+ (nnmaildir--unlink nnmaildir--file)
+ (nnmaildir--expired-article group article))))))
+ (erase-buffer))
+ didnt)))
+
+(defun nnmaildir-request-set-mark (gname actions &optional server)
+ (let ((group (nnmaildir--prepare server gname))
+ (coding-system-for-write nnheader-file-coding-system)
+ (output-coding-system nnheader-file-coding-system)
+ (buffer-file-coding-system nil)
+ (file-coding-system nil)
+ (file-coding-system-alist nil)
+ del-mark del-action add-action set-action marksdir markfile nlist
+ ranges begin end article all-marks todo-marks did-marks mdir mfile
+ pgname ls permarkfile deactivate-mark)
+ (setq del-mark
+ (lambda (mark)
+ (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
+ mfile (concat mfile (nnmaildir--art-prefix article)))
+ (nnmaildir--unlink mfile))
+ del-action (lambda (article) (mapcar del-mark todo-marks))
+ add-action
+ (lambda (article)
+ (mapcar
+ (lambda (mark)
+ (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
+ permarkfile (concat mdir ":")
+ mfile (concat mdir (nnmaildir--art-prefix article)))
+ (unless (memq mark did-marks)
+ (setq did-marks (cons mark did-marks))
+ (nnmaildir--mkdir mdir)
+ (unless (file-attributes permarkfile)
+ (condition-case nil
+ (add-name-to-file markfile permarkfile)
+ (file-error
+ ;; AFS can't make hard links in separate directories
+ (write-region "" nil permarkfile nil 'no-message)))))
+ (unless (file-exists-p mfile)
+ (add-name-to-file permarkfile mfile)))
+ todo-marks))
+ set-action (lambda (article)
+ (funcall add-action)
+ (mapcar (lambda (mark)
+ (unless (memq mark todo-marks)
+ (funcall del-mark mark)))
+ all-marks)))
+ (catch 'return
+ (unless group
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ (mapcar (lambda (action)
+ (setq ranges (gnus-range-add ranges (car action))))
+ actions)
+ (throw 'return ranges))
+ (setq nlist (nnmaildir--grp-nlist group)
+ marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
+ marksdir (nnmaildir--srvgrp-dir marksdir gname)
+ marksdir (nnmaildir--nndir marksdir)
+ markfile (concat marksdir "markfile")
+ marksdir (nnmaildir--marks-dir marksdir)
+ gname (nnmaildir--grp-name group)
+ pgname (nnmaildir--pgname nnmaildir--cur-server gname)
+ ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
+ all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
+ all-marks (mapcar 'intern all-marks))
+ (mapcar
+ (lambda (action)
+ (setq ranges (car action)
+ todo-marks (caddr action))
+ (mapcar (lambda (mark) (add-to-list 'all-marks mark)) todo-marks)
+ (if (numberp (cdr ranges)) (setq ranges (list ranges)))
+ (nnmaildir--nlist-iterate nlist ranges
+ (cond ((eq 'del (cadr action)) del-action)
+ ((eq 'add (cadr action)) add-action)
+ (t set-action))))
+ actions)
+ nil)))
+
+(defun nnmaildir-close-group (gname &optional server)
+ (let ((group (nnmaildir--prepare server gname))
+ pgname ls dir msgdir files flist dirs)
+ (if (null group)
+ (progn
+ (setf (nnmaildir--srv-error nnmaildir--cur-server)
+ (concat "No such group: " gname))
+ nil)
+ (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
+ ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
+ dir (nnmaildir--srv-dir nnmaildir--cur-server)
+ dir (nnmaildir--srvgrp-dir dir gname)
+ msgdir (if (nnmaildir--param pgname 'read-only)
+ (nnmaildir--new dir) (nnmaildir--cur dir))
+ dir (nnmaildir--nndir dir)
+ dirs (cons (nnmaildir--nov-dir dir)
+ (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
+ 'nosort))
+ dirs (mapcar
+ (lambda (dir)
+ (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
+ dirs)
+ files (funcall ls msgdir nil "\\`[^.]" 'nosort)
+ flist (nnmaildir--up2-1 (length files))
+ flist (make-vector flist 0))
+ (save-match-data
+ (mapcar
+ (lambda (file)
+ (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
+ (intern (match-string 1 file) flist))
+ files))
+ (mapcar
+ (lambda (dir)
+ (setq files (cdr dir)
+ dir (file-name-as-directory (car dir)))
+ (mapcar
+ (lambda (file)
+ (unless (or (intern-soft file flist) (string= file ":"))
+ (setq file (concat dir file))
+ (delete-file file)))
+ files))
+ dirs)
+ t)))
+
+(defun nnmaildir-close-server (&optional server)
+ (let (flist ls dirs dir files file x)
+ (nnmaildir--prepare server nil)
+ (when nnmaildir--cur-server
+ (setq server nnmaildir--cur-server
+ nnmaildir--cur-server nil)
+ (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
+ t)
+
+(defun nnmaildir-request-close ()
+ (let (servers buffer)
+ (mapatoms (lambda (server)
+ (setq servers (cons (symbol-name server) servers)))
+ nnmaildir--servers)
+ (mapcar 'nnmaildir-close-server servers)
+ (setq buffer (get-buffer " *nnmaildir work*"))
+ (if buffer (kill-buffer buffer))
+ (setq buffer (get-buffer " *nnmaildir nov*"))
+ (if buffer (kill-buffer buffer))
+ (setq buffer (get-buffer " *nnmaildir move*"))
+ (if buffer (kill-buffer buffer)))
+ t)
+
+(provide 'nnmaildir)
+
+;; Local Variables:
+;; indent-tabs-mode: t
+;; fill-column: 77
+;; End:
+
+;;; nnmaildir.el ends here
--- /dev/null
+;;; nnnil.el --- empty backend for Gnus
+;; Public domain.
+
+;; Author: Paul Jarc <prj@po.cwru.edu>
+
+;; 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:
+
+;; nnnil is a Gnus backend that provides no groups or articles. It's useful
+;; as a primary select method when you want all your real select methods to
+;; be secondary or foreign.
+
+;;; Code:
+
+(eval-and-compile
+ (require 'nnheader))
+
+(defvar nnnil-status-string "")
+
+(defun nnnil-retrieve-headers (articles &optional group server fetch-old)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer))
+ 'nov)
+
+(defun nnnil-open-server (server &optional definitions)
+ t)
+
+(defun nnnil-close-server (&optional server)
+ t)
+
+(defun nnnil-request-close ()
+ t)
+
+(defun nnnil-server-opened (&optional server)
+ t)
+
+(defun nnnil-status-message (&optional server)
+ nnnil-status-string)
+
+(defun nnnil-request-article (article &optional group server to-buffer)
+ (setq nnnil-status-string "No such group")
+ nil)
+
+(defun nnnil-request-group (group &optional server fast)
+ (let (deactivate-mark)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (insert "411 no such news group\n")))
+ (setq nnnil-status-string "No such group")
+ nil)
+
+(defun nnnil-close-group (group &optional server)
+ t)
+
+(defun nnnil-request-list (&optional server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer))
+ t)
+
+(defun nnnil-request-post (&optional server)
+ (setq nnnil-status-string "Read-only server")
+ nil)
+
+(provide 'nnnil)
--- /dev/null
+;;; nnrss.el --- interfacing with RSS
+;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Keywords: RSS
+
+;; 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 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:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'gnus)
+(require 'nnoo)
+(require 'nnmail)
+(require 'message)
+(require 'mm-util)
+(require 'gnus-util)
+(require 'time-date)
+(require 'rfc2231)
+(require 'mm-url)
+(eval-when-compile
+ (ignore-errors
+ (require 'xml)))
+(eval '(require 'xml))
+
+(nnoo-declare nnrss)
+
+(defvoo nnrss-directory (nnheader-concat gnus-directory "rss/")
+ "Where nnrss will save its files.")
+
+;; (group max rss-url)
+(defvoo nnrss-server-data nil)
+
+;; (num timestamp url subject author date extra)
+(defvoo nnrss-group-data nil)
+(defvoo nnrss-group-max 0)
+(defvoo nnrss-group-min 1)
+(defvoo nnrss-group nil)
+(defvoo nnrss-group-hashtb nil)
+(defvoo nnrss-status-string "")
+
+(defconst nnrss-version "nnrss 1.0")
+
+(defvar nnrss-group-alist '()
+ "List of RSS addresses.")
+
+(defvar nnrss-use-local nil)
+
+(defvar nnrss-description-field 'X-Gnus-Description
+ "Field name used for DESCRIPTION.
+To use the description in headers, put this name into `nnmail-extra-headers'.")
+
+(defvar nnrss-url-field 'X-Gnus-Url
+ "Field name used for URL.
+To use the description in headers, put this name into `nnmail-extra-headers'.")
+
+(defvar nnrss-content-function nil
+ "A function which is called in `nnrss-request-article'.
+The arguments are (ENTRY GROUP ARTICLE).
+ENTRY is the record of the current headline. GROUP is the group name.
+ARTICLE is the article number of the current headline.")
+
+(nnoo-define-basics nnrss)
+
+;;; Interface functions
+
+(deffoo nnrss-retrieve-headers (articles &optional group server fetch-old)
+ (nnrss-possibly-change-group group server)
+ (let (e)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (dolist (article articles)
+ (if (setq e (assq article nnrss-group-data))
+ (insert (number-to-string (car e)) "\t" ;; number
+ (if (nth 3 e)
+ (nnrss-format-string (nth 3 e)) "")
+ "\t" ;; subject
+ (if (nth 4 e)
+ (nnrss-format-string (nth 4 e))
+ "(nobody)")
+ "\t" ;;from
+ (or (nth 5 e) "")
+ "\t" ;; date
+ (format "<%d@%s.nnrss>" (car e) group)
+ "\t" ;; id
+ "\t" ;; refs
+ "-1" "\t" ;; chars
+ "-1" "\t" ;; lines
+ "" "\t" ;; Xref
+ (if (and (nth 6 e)
+ (memq nnrss-description-field
+ nnmail-extra-headers))
+ (concat (symbol-name nnrss-description-field)
+ ": "
+ (nnrss-format-string (nth 6 e))
+ "\t")
+ "")
+ (if (and (nth 2 e)
+ (memq nnrss-url-field
+ nnmail-extra-headers))
+ (concat (symbol-name nnrss-url-field)
+ ": "
+ (nnrss-format-string (nth 2 e))
+ "\t")
+ "")
+ "\n")))))
+ 'nov)
+
+(deffoo nnrss-request-group (group &optional server dont-check)
+ (nnrss-possibly-change-group group server)
+ (if dont-check
+ t
+ (nnrss-check-group group server)
+ (nnheader-report 'nnrss "Opened group %s" group)
+ (nnheader-insert
+ "211 %d %d %d %s\n" nnrss-group-max nnrss-group-min nnrss-group-max
+ (prin1-to-string group)
+ t)))
+
+(deffoo nnrss-close-group (group &optional server)
+ t)
+
+(deffoo nnrss-request-article (article &optional group server buffer)
+ (nnrss-possibly-change-group group server)
+ (let ((e (assq article nnrss-group-data))
+ (boundary "=-=-=-=-=-=-=-=-=-")
+ (nntp-server-buffer (or buffer nntp-server-buffer))
+ post err)
+ (when e
+ (catch 'error
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (goto-char (point-min))
+ (insert "Mime-Version: 1.0\nContent-Type: multipart/alternative; boundary=\"" boundary "\"\n")
+ (if group
+ (insert "Newsgroups: " group "\n"))
+ (if (nth 3 e)
+ (insert "Subject: " (nnrss-format-string (nth 3 e)) "\n"))
+ (if (nth 4 e)
+ (insert "From: " (nnrss-format-string (nth 4 e)) "\n"))
+ (if (nth 5 e)
+ (insert "Date: " (nnrss-format-string (nth 5 e)) "\n"))
+ (insert "Message-ID: " (format "<%d@%s.nnrss>" (car e) group) "\n")
+ (insert "\n")
+ (let ((text (if (nth 6 e)
+ (nnrss-string-as-multibyte (nth 6 e))))
+ (link (if (nth 2 e)
+ (nth 2 e))))
+ (insert "\n\n--" boundary "\nContent-Type: text/plain\n\n")
+ (let ((point (point)))
+ (if text
+ (progn (insert text)
+ (goto-char point)
+ (while (re-search-forward "\n" nil t)
+ (replace-match " "))
+ (goto-char (point-max))
+ (insert "\n\n")))
+ (if link
+ (insert link)))
+ (insert "\n\n--" boundary "\nContent-Type: text/html\n\n")
+ (let ((point (point)))
+ (if text
+ (progn (insert "<html><head></head><body>\n" text "\n</body></html>")
+ (goto-char point)
+ (while (re-search-forward "\n" nil t)
+ (replace-match " "))
+ (goto-char (point-max))
+ (insert "\n\n")))
+ (if link
+ (insert "<p><a href=\"" link "\">link</a></p>\n"))))
+ (if nnrss-content-function
+ (funcall nnrss-content-function e group article)))))
+ (cond
+ (err
+ (nnheader-report 'nnrss err))
+ ((not e)
+ (nnheader-report 'nnrss "no such id: %d" article))
+ (t
+ (nnheader-report 'nnrss "article %s retrieved" (car e))
+ ;; we return the article number.
+ (cons nnrss-group (car e))))))
+
+(deffoo nnrss-request-list (&optional server)
+ (nnrss-possibly-change-group nil server)
+ (nnrss-generate-active)
+ t)
+
+(deffoo nnrss-open-server (server &optional defs connectionless)
+ (nnrss-read-server-data server)
+ (nnoo-change-server 'nnrss server defs)
+ t)
+
+(deffoo nnrss-request-expire-articles
+ (articles group &optional server force)
+ (nnrss-possibly-change-group group server)
+ (let (e days not-expirable changed)
+ (dolist (art articles)
+ (if (and (setq e (assq art nnrss-group-data))
+ (nnmail-expired-article-p
+ group
+ (if (listp (setq days (nth 1 e))) days
+ (days-to-time (- days (time-to-days '(0 0)))))
+ force))
+ (setq nnrss-group-data (delq e nnrss-group-data)
+ changed t)
+ (push art not-expirable)))
+ (if changed
+ (nnrss-save-group-data group server))
+ not-expirable))
+
+(deffoo nnrss-request-delete-group (group &optional force server)
+ (nnrss-possibly-change-group group server)
+ (setq nnrss-server-data
+ (delq (assoc group nnrss-server-data) nnrss-server-data))
+ (nnrss-save-server-data server)
+ (let ((file (expand-file-name
+ (nnrss-translate-file-chars
+ (concat group (and server
+ (not (equal server ""))
+ "-")
+ server ".el")) nnrss-directory)))
+ (ignore-errors
+ (delete-file file)))
+ t)
+
+(deffoo nnrss-request-list-newsgroups (&optional server)
+ (nnrss-possibly-change-group nil server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (dolist (elem nnrss-group-alist)
+ (if (third elem)
+ (insert (car elem) "\t" (third elem) "\n"))))
+ t)
+
+(nnoo-define-skeleton nnrss)
+
+;;; Internal functions
+(eval-when-compile (defun xml-rpc-method-call (&rest args)))
+(defun nnrss-fetch (url &optional local)
+ "Fetch the url and put it in a the expected lisp structure."
+ (with-temp-buffer
+ ;some CVS versions of url.el need this to close the connection quickly
+ (let* (xmlform htmlform)
+ ;; bit o' work necessary for w3 pre-cvs and post-cvs
+ (if local
+ (let ((coding-system-for-read 'binary))
+ (insert-file-contents url))
+ (mm-url-insert url))
+
+;; Because xml-parse-region can't deal with anything that isn't
+;; xml and w3-parse-buffer can't deal with some xml, we have to
+;; parse with xml-parse-region first and, if that fails, parse
+;; with w3-parse-buffer. Yuck. Eventually, someone should find out
+;; why w3-parse-buffer fails to parse some well-formed xml and
+;; fix it.
+
+ (condition-case err
+ (setq xmlform (xml-parse-region (point-min) (point-max)))
+ (error (if (fboundp 'w3-parse-buffer)
+ (setq htmlform (caddar (w3-parse-buffer
+ (current-buffer))))
+ (message "nnrss: Not valid XML and w3 parse not available (%s)"
+ url))))
+ (if htmlform
+ htmlform
+ xmlform))))
+
+(defun nnrss-possibly-change-group (&optional group server)
+ (when (and server
+ (not (nnrss-server-opened server)))
+ (nnrss-open-server server))
+ (when (and group (not (equal group nnrss-group)))
+ (nnrss-read-group-data group server)
+ (setq nnrss-group group)))
+
+(defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories))
+
+(defun nnrss-generate-active ()
+ (if (y-or-n-p "fetch extra categories? ")
+ (dolist (func nnrss-extra-categories)
+ (funcall func)))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (dolist (elem nnrss-group-alist)
+ (insert (prin1-to-string (car elem)) " 0 1 y\n"))
+ (dolist (elem nnrss-server-data)
+ (unless (assoc (car elem) nnrss-group-alist)
+ (insert (prin1-to-string (car elem)) " 0 1 y\n")))))
+
+;;; data functions
+
+(defun nnrss-read-server-data (server)
+ (setq nnrss-server-data nil)
+ (let ((file (expand-file-name
+ (nnrss-translate-file-chars
+ (concat "nnrss" (and server
+ (not (equal server ""))
+ "-")
+ server
+ ".el"))
+ nnrss-directory)))
+ (when (file-exists-p file)
+ (with-temp-buffer
+ (let ((coding-system-for-read 'binary)
+ (input-coding-system 'binary)
+ emacs-lisp-mode-hook)
+ (insert-file-contents file)
+ (emacs-lisp-mode)
+ (goto-char (point-min))
+ (eval-buffer))))))
+
+(defun nnrss-save-server-data (server)
+ (gnus-make-directory nnrss-directory)
+ (let ((file (expand-file-name
+ (nnrss-translate-file-chars
+ (concat "nnrss" (and server
+ (not (equal server ""))
+ "-")
+ server ".el"))
+ nnrss-directory)))
+ (let ((coding-system-for-write 'binary)
+ (output-coding-system 'binary)
+ print-level print-length)
+ (with-temp-file file
+ (insert "(setq nnrss-group-alist '"
+ (prin1-to-string nnrss-group-alist)
+ ")\n")
+ (insert "(setq nnrss-server-data '"
+ (prin1-to-string nnrss-server-data)
+ ")\n")))))
+
+(defun nnrss-read-group-data (group server)
+ (setq nnrss-group-data nil)
+ (setq nnrss-group-hashtb (gnus-make-hashtable))
+ (let ((pair (assoc group nnrss-server-data)))
+ (setq nnrss-group-max (or (cadr pair) 0))
+ (setq nnrss-group-min (+ nnrss-group-max 1)))
+ (let ((file (expand-file-name
+ (nnrss-translate-file-chars
+ (concat group (and server
+ (not (equal server ""))
+ "-")
+ server ".el"))
+ nnrss-directory)))
+ (when (file-exists-p file)
+ (with-temp-buffer
+ (let ((coding-system-for-read 'binary)
+ (input-coding-system 'binary)
+ emacs-lisp-mode-hook)
+ (insert-file-contents file)
+ (emacs-lisp-mode)
+ (goto-char (point-min))
+ (eval-buffer)))
+ (dolist (e nnrss-group-data)
+ (gnus-sethash (nth 2 e) e nnrss-group-hashtb)
+ (if (and (car e) (> nnrss-group-min (car e)))
+ (setq nnrss-group-min (car e)))
+ (if (and (car e) (< nnrss-group-max (car e)))
+ (setq nnrss-group-max (car e)))))))
+
+(defun nnrss-save-group-data (group server)
+ (gnus-make-directory nnrss-directory)
+ (let ((file (expand-file-name
+ (nnrss-translate-file-chars
+ (concat group (and server
+ (not (equal server ""))
+ "-")
+ server ".el"))
+ nnrss-directory)))
+ (let ((coding-system-for-write 'binary)
+ (output-coding-system 'binary)
+ print-level print-length)
+ (with-temp-file file
+ (insert "(setq nnrss-group-data '"
+ (prin1-to-string nnrss-group-data)
+ ")\n")))))
+
+;;; URL interface
+
+(defun nnrss-no-cache (url)
+ "")
+
+(defun nnrss-insert-w3 (url)
+ (mm-with-unibyte-current-buffer
+ (mm-url-insert url)))
+
+(defun nnrss-decode-entities-unibyte-string (string)
+ (if string
+ (mm-with-unibyte-buffer
+ (insert string)
+ (mm-url-decode-entities-nbsp)
+ (buffer-string))))
+
+(defalias 'nnrss-insert 'nnrss-insert-w3)
+
+(if (featurep 'xemacs)
+ (defalias 'nnrss-string-as-multibyte 'identity)
+ (defalias 'nnrss-string-as-multibyte 'string-as-multibyte))
+
+;;; Snarf functions
+
+(defun nnrss-check-group (group server)
+ (let (file xml subject url extra changed author
+ date rss-ns rdf-ns content-ns dc-ns)
+ (if (and nnrss-use-local
+ (file-exists-p (setq file (expand-file-name
+ (nnrss-translate-file-chars
+ (concat group ".xml"))
+ nnrss-directory))))
+ (nnrss-fetch file t)
+ (setq url (or (nth 2 (assoc group nnrss-server-data))
+ (second (assoc group nnrss-group-alist))))
+ (unless url
+ (setq url
+ (cdr
+ (assoc 'href
+ (nnrss-discover-feed
+ (read-string
+ (format "URL to search for %s: " group) "http://")))))
+ (let ((pair (assoc group nnrss-server-data)))
+ (if pair
+ (setcdr (cdr pair) (list url))
+ (push (list group nnrss-group-max url) nnrss-server-data)))
+ (setq changed t))
+ (setq xml (nnrss-fetch url)))
+ ;; See
+ ;; http://feeds.archive.org/validator/docs/howto/declare_namespaces.html
+ ;; for more RSS namespaces.
+ (setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/")
+ rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
+ rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")
+ content-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/modules/content/"))
+ (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml)))
+ (when (and (listp item)
+ (eq (intern (concat rss-ns "item")) (car item))
+ (setq url (nnrss-decode-entities-unibyte-string
+ (nnrss-node-text rss-ns 'link (cddr item))))
+ (not (gnus-gethash url nnrss-group-hashtb)))
+ (setq subject (nnrss-node-text rss-ns 'title item))
+ (setq extra (or (nnrss-node-text content-ns 'encoded item)
+ (nnrss-node-text rss-ns 'description item)))
+ (setq author (or (nnrss-node-text rss-ns 'author item)
+ (nnrss-node-text dc-ns 'creator item)))
+ (setq date (or (nnrss-node-text dc-ns 'date item)
+ (nnrss-node-text rss-ns 'pubDate item)
+ (message-make-date)))
+ (push
+ (list
+ (incf nnrss-group-max)
+ (current-time)
+ url
+ (and subject (nnrss-decode-entities-unibyte-string subject))
+ (and author (nnrss-decode-entities-unibyte-string author))
+ date
+ (and extra (nnrss-decode-entities-unibyte-string extra)))
+ nnrss-group-data)
+ (gnus-sethash url (car nnrss-group-data) nnrss-group-hashtb)
+ (setq changed t)))
+ (when changed
+ (nnrss-save-group-data group server)
+ (let ((pair (assoc group nnrss-server-data)))
+ (if pair
+ (setcar (cdr pair) nnrss-group-max)
+ (push (list group nnrss-group-max) nnrss-server-data)))
+ (nnrss-save-server-data server))))
+
+(defun nnrss-generate-download-script ()
+ "Generate a download script in the current buffer.
+It is useful when `(setq nnrss-use-local t)'."
+ (interactive)
+ (insert "#!/bin/sh\n")
+ (insert "WGET=wget\n")
+ (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n")
+ (dolist (elem nnrss-server-data)
+ (let ((url (or (nth 2 elem)
+ (second (assoc (car elem) nnrss-group-alist)))))
+ (insert "$WGET -q -O \"$RSSDIR\"/'"
+ (nnrss-translate-file-chars (concat (car elem) ".xml"))
+ "' '" url "'\n"))))
+
+(defun nnrss-translate-file-chars (name)
+ (let ((nnheader-file-name-translation-alist
+ (append nnheader-file-name-translation-alist '((?' . ?_)))))
+ (nnheader-translate-file-chars name)))
+
+(defvar nnrss-moreover-url
+ "http://w.moreover.com/categories/category_list_rss.html"
+ "The url of moreover.com categories.")
+
+(defun nnrss-snarf-moreover-categories ()
+ "Snarf RSS links from moreover.com."
+ (interactive)
+ (let (category name url changed)
+ (with-temp-buffer
+ (nnrss-insert nnrss-moreover-url)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "<a name=\"\\([^\"]+\\)\">\\|<a href=\"\\(http://[^\"]*moreover\\.com[^\"]+page\\?c=\\([^\"&]+\\)&o=rss\\)" nil t)
+ (if (match-string 1)
+ (setq category (match-string 1))
+ (setq url (match-string 2)
+ name (mm-url-decode-entities-string
+ (rfc2231-decode-encoded-string
+ (match-string 3))))
+ (if category
+ (setq name (concat category "." name)))
+ (unless (assoc name nnrss-server-data)
+ (setq changed t)
+ (push (list name 0 url) nnrss-server-data)))))
+ (if changed
+ (nnrss-save-server-data ""))))
+
+(defun nnrss-format-string (string)
+ (gnus-replace-in-string (nnrss-string-as-multibyte string) " *\n *" " "))
+
+(defun nnrss-node-text (namespace local-name element)
+ (let* ((node (assq (intern (concat namespace (symbol-name local-name)))
+ element))
+ (text (if (and node (listp node))
+ (nnrss-node-just-text node)
+ node))
+ (cleaned-text (if text (gnus-replace-in-string
+ text "^[\000-\037\177]+\\|^ +\\| +$" ""))))
+ (if (string-equal "" cleaned-text)
+ nil
+ cleaned-text)))
+
+(defun nnrss-node-just-text (node)
+ (if (and node (listp node))
+ (mapconcat 'nnrss-node-just-text (cddr node) " ")
+ node))
+
+(defun nnrss-find-el (tag data &optional found-list)
+ "Find the all matching elements in the data. Careful with this on
+large documents!"
+ (if (listp data)
+ (mapcar (lambda (bit)
+ (if (car-safe bit)
+ (progn (if (equal tag (car bit))
+ (setq found-list
+ (append found-list
+ (list bit))))
+ (if (and (listp (car-safe (caddr bit)))
+ (not (stringp (caddr bit))))
+ (setq found-list
+ (append found-list
+ (nnrss-find-el
+ tag (caddr bit))))
+ (setq found-list
+ (append found-list
+ (nnrss-find-el
+ tag (cddr bit))))))))
+ data))
+ found-list)
+
+(defun nnrss-rsslink-p (el)
+ "Test if the element we are handed is an RSS autodiscovery link."
+ (and (eq (car-safe el) 'link)
+ (string-equal (cdr (assoc 'rel (cadr el))) "alternate")
+ (or (string-equal (cdr (assoc 'type (cadr el)))
+ "application/rss+xml")
+ (string-equal (cdr (assoc 'type (cadr el))) "text/xml"))))
+
+(defun nnrss-get-rsslinks (data)
+ "Extract the <link> elements that are links to RSS from the parsed data."
+ (delq nil (mapcar
+ (lambda (el)
+ (if (nnrss-rsslink-p el) el))
+ (nnrss-find-el 'link data))))
+
+(defun nnrss-extract-hrefs (data)
+ "Recursively extract hrefs from a page's source. DATA should be
+the output of xml-parse-region or w3-parse-buffer."
+ (mapcar (lambda (ahref)
+ (cdr (assoc 'href (cadr ahref))))
+ (nnrss-find-el 'a data)))
+
+(defmacro nnrss-match-macro (base-uri item
+ onsite-list offsite-list)
+ `(cond ((or (string-match (concat "^" ,base-uri) ,item)
+ (not (string-match "://" ,item)))
+ (setq ,onsite-list (append ,onsite-list (list ,item))))
+ (t (setq ,offsite-list (append ,offsite-list (list ,item))))))
+
+(defun nnrss-order-hrefs (base-uri hrefs)
+ "Given a list of hrefs, sort them using the following priorities:
+ 1. links ending in .rss
+ 2. links ending in .rdf
+ 3. links ending in .xml
+ 4. links containing the above
+ 5. offsite links
+
+BASE-URI is used to determine the location of the links and
+whether they are `offsite' or `onsite'."
+ (let (rss-onsite-end rdf-onsite-end xml-onsite-end
+ rss-onsite-in rdf-onsite-in xml-onsite-in
+ rss-offsite-end rdf-offsite-end xml-offsite-end
+ rss-offsite-in rdf-offsite-in xml-offsite-in)
+ (mapcar (lambda (href)
+ (if (not (null href))
+ (cond ((string-match "\\.rss$" href)
+ (nnrss-match-macro
+ base-uri href rss-onsite-end rss-offsite-end))
+ ((string-match "\\.rdf$" href)
+ (nnrss-match-macro
+ base-uri href rdf-onsite-end rdf-offsite-end))
+ ((string-match "\\.xml$" href)
+ (nnrss-match-macro
+ base-uri href xml-onsite-end xml-offsite-end))
+ ((string-match "rss" href)
+ (nnrss-match-macro
+ base-uri href rss-onsite-in rss-offsite-in))
+ ((string-match "rdf" href)
+ (nnrss-match-macro
+ base-uri href rdf-onsite-in rdf-offsite-in))
+ ((string-match "xml" href)
+ (nnrss-match-macro
+ base-uri href xml-onsite-in xml-offsite-in)))))
+ hrefs)
+ (append
+ rss-onsite-end rdf-onsite-end xml-onsite-end
+ rss-onsite-in rdf-onsite-in xml-onsite-in
+ rss-offsite-end rdf-offsite-end xml-offsite-end
+ rss-offsite-in rdf-offsite-in xml-offsite-in)))
+
+(defun nnrss-discover-feed (url)
+ "Given a page, find an RSS feed using Mark Pilgrim's
+`ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)."
+
+ (let ((parsed-page (nnrss-fetch url)))
+
+;; 1. if this url is the rss, use it.
+ (if (nnrss-rss-p parsed-page)
+ (let ((rss-ns (nnrss-get-namespace-prefix parsed-page "http://purl.org/rss/1.0/")))
+ (nnrss-rss-title-description rss-ns parsed-page url))
+
+;; 2. look for the <link rel="alternate"
+;; type="application/rss+xml" and use that if it is there.
+ (let ((links (nnrss-get-rsslinks parsed-page)))
+ (if links
+ (let* ((xml (nnrss-fetch
+ (cdr (assoc 'href (cadar links)))))
+ (rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/")))
+ (nnrss-rss-title-description rss-ns xml (cdr (assoc 'href (cadar links)))))
+
+;; 3. look for links on the site in the following order:
+;; - onsite links ending in .rss, .rdf, or .xml
+;; - onsite links containing any of the above
+;; - offsite links ending in .rss, .rdf, or .xml
+;; - offsite links containing any of the above
+ (let* ((base-uri (progn (string-match ".*://[^/]+/?" url)
+ (match-string 0 url)))
+ (hrefs (nnrss-order-hrefs
+ base-uri (nnrss-extract-hrefs parsed-page)))
+ (rss-link nil))
+ (while (and (eq rss-link nil) (not (eq hrefs nil)))
+ (let ((href-data (nnrss-fetch (car hrefs))))
+ (if (nnrss-rss-p href-data)
+ (let* ((rss-ns (nnrss-get-namespace-prefix href-data "http://purl.org/rss/1.0/")))
+ (setq rss-link (nnrss-rss-title-description
+ rss-ns href-data (car hrefs))))
+ (setq hrefs (cdr hrefs)))))
+ (if rss-link rss-link
+
+;; 4. check syndic8
+ (nnrss-find-rss-via-syndic8 url))))))))
+
+(defun nnrss-find-rss-via-syndic8 (url)
+ "query syndic8 for the rss feeds it has for the url."
+ (if (locate-library "xml-rpc")
+ (progn (require 'xml-rpc)
+ (let ((feedid (xml-rpc-method-call
+ "http://www.syndic8.com/xmlrpc.php"
+ 'syndic8.FindSites
+ url)))
+ (if feedid
+ (let* ((feedinfo (xml-rpc-method-call
+ "http://www.syndic8.com/xmlrpc.php"
+ 'syndic8.GetFeedInfo
+ feedid))
+ (urllist
+ (delq nil
+ (mapcar
+ (lambda (listinfo)
+ (if (string-equal
+ (cdr (assoc "status" listinfo))
+ "Syndicated")
+ (cons
+ (cdr (assoc "sitename" listinfo))
+ (list
+ (cons 'title
+ (cdr (assoc
+ "sitename" listinfo)))
+ (cons 'href
+ (cdr (assoc
+ "dataurl" listinfo)))))))
+ feedinfo))))
+ (if (> (length urllist) 1)
+ (let ((completion-ignore-case t)
+ (selection
+ (mapcar (lambda (listinfo)
+ (cons (cdr (assoc "sitename" listinfo))
+ (string-to-int
+ (cdr (assoc "feedid" listinfo)))))
+ feedinfo)))
+ (cdr (assoc
+ (completing-read
+ "Multiple feeds found. Select one: "
+ selection nil t) urllist)))
+ (cdar urllist))))))
+ (error (message "XML-RPC is not available... not checking Syndic8."))))
+
+(defun nnrss-rss-p (data)
+ "Test if data is an RSS feed. Simply ensures that the first
+element is rss or rdf."
+ (or (eq (caar data) 'rss)
+ (eq (caar data) 'rdf:RDF)))
+
+(defun nnrss-rss-title-description (rss-namespace data url)
+ "Return the title of an RSS feed."
+ (if (nnrss-rss-p data)
+ (let ((description (intern (concat rss-namespace "description")))
+ (title (intern (concat rss-namespace "title")))
+ (channel (nnrss-find-el (intern (concat rss-namespace "channel"))
+ data)))
+ (list
+ (cons 'description (caddr (nth 0 (nnrss-find-el description channel))))
+ (cons 'title (caddr (nth 0 (nnrss-find-el title channel))))
+ (cons 'href url)))))
+
+(defun nnrss-get-namespace-prefix (el uri)
+ "Given EL (containing a parsed element) and URI (containing a string
+that gives the URI for which you want to retrieve the namespace
+prefix), return the prefix."
+ (let* ((prefix (car (rassoc uri (cadar el))))
+ (nslist (if prefix
+ (split-string (symbol-name prefix) ":")))
+ (ns (cond ((eq (length nslist) 1) ; no prefix given
+ "")
+ ((eq (length nslist) 2) ; extract prefix
+ (cadr nslist)))))
+ (if (and ns (not (eq ns "")))
+ (concat ns ":")
+ ns)))
+
+(provide 'nnrss)
+
+
+;;; nnrss.el ends here
+
--- /dev/null
+;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp.
+
+;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
+
+;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Keywords: SHA1, FIPS 180-1
+
+;; This file is part of FLIM (Faithful Library about Internet Message).
+
+;; This program 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.
+
+;; This program 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 this program; 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 program is implemented from the definition of SHA-1 in FIPS PUB
+;; 180-1 (Federal Information Processing Standards Publication 180-1),
+;; "Announcing the Standard for SECURE HASH STANDARD".
+;; <URL:http://www.itl.nist.gov/div897/pubs/fip180-1.htm>
+;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c)
+;;
+;; Test cases from FIPS PUB 180-1.
+;;
+;; (sha1 "abc")
+;; => a9993e364706816aba3e25717850c26c9cd0d89d
+;;
+;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq")
+;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1
+;;
+;; (sha1 (make-string 1000000 ?a))
+;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f
+;;
+;; BUGS:
+;; * It is assumed that length of input string is less than 2^29 bytes.
+;; * It is caller's responsibility to make string (or region) unibyte.
+;;
+;; TODO:
+;; * Rewrite from scratch!
+;; This version is much faster than Keiichi Suzuki's another sha1.el,
+;; but it is too dirty.
+
+;;; Code:
+
+(require 'hex-util)
+
+(autoload 'executable-find "executable")
+
+;;;
+;;; external SHA1 function.
+;;;
+
+(defvar sha1-maximum-internal-length 500
+ "*Maximum length of message to use lisp version of SHA1 function.
+If message is longer than this, `sha1-program' is used instead.
+
+If this variable is set to 0, use extarnal program only.
+If this variable is set to nil, use internal function only.")
+
+(defvar sha1-program '("openssl" "sha1")
+ "*Name of program to compute SHA1.
+It must be a string \(program name\) or list of strings \(name and its args\).")
+
+(defvar sha1-use-external
+ (exec-installed-p (car sha1-program))
+ "*Use external sha1 program.
+If this variable is set to nil, use internal function only.")
+
+(defun sha1-string-external (string)
+ ;; `with-temp-buffer' is new in v20, so we do not use it.
+ (save-excursion
+ (let (buffer)
+ (unwind-protect
+ (let (prog args)
+ (if (consp sha1-program)
+ (setq prog (car sha1-program)
+ args (cdr sha1-program))
+ (setq prog sha1-program
+ args nil))
+ (setq buffer (set-buffer
+ (generate-new-buffer " *sha1 external*")))
+ (insert string)
+ (apply (function call-process-region)
+ (point-min)(point-max)
+ prog t t nil args)
+ ;; SHA1 is 40 bytes long in hexadecimal form.
+ (buffer-substring (point-min)(+ (point-min) 40)))
+ (and buffer
+ (buffer-name buffer)
+ (kill-buffer buffer))))))
+
+(defun sha1-region-external (beg end)
+ (sha1-string-external (buffer-substring-no-properties beg end)))
+
+;;;
+;;; internal SHA1 function.
+;;;
+
+(eval-when-compile
+ ;; optional second arg of string-to-number is new in v20.
+ (defconst sha1-K0-high 23170) ; (string-to-number "5A82" 16)
+ (defconst sha1-K0-low 31129) ; (string-to-number "7999" 16)
+ (defconst sha1-K1-high 28377) ; (string-to-number "6ED9" 16)
+ (defconst sha1-K1-low 60321) ; (string-to-number "EBA1" 16)
+ (defconst sha1-K2-high 36635) ; (string-to-number "8F1B" 16)
+ (defconst sha1-K2-low 48348) ; (string-to-number "BCDC" 16)
+ (defconst sha1-K3-high 51810) ; (string-to-number "CA62" 16)
+ (defconst sha1-K3-low 49622) ; (string-to-number "C1D6" 16)
+
+;;; original definition of sha1-F0.
+;;; (defmacro sha1-F0 (B C D)
+;;; (` (logior (logand (, B) (, C))
+;;; (logand (lognot (, B)) (, D)))))
+;;; a little optimization from GnuPG/cipher/sha1.c.
+ (defmacro sha1-F0 (B C D)
+ (` (logxor (, D) (logand (, B) (logxor (, C) (, D))))))
+ (defmacro sha1-F1 (B C D)
+ (` (logxor (, B) (, C) (, D))))
+;;; original definition of sha1-F2.
+;;; (defmacro sha1-F2 (B C D)
+;;; (` (logior (logand (, B) (, C))
+;;; (logand (, B) (, D))
+;;; (logand (, C) (, D)))))
+;;; a little optimization from GnuPG/cipher/sha1.c.
+ (defmacro sha1-F2 (B C D)
+ (` (logior (logand (, B) (, C))
+ (logand (, D) (logior (, B) (, C))))))
+ (defmacro sha1-F3 (B C D)
+ (` (logxor (, B) (, C) (, D))))
+
+ (defmacro sha1-S1 (W-high W-low)
+ (` (let ((W-high (, W-high))
+ (W-low (, W-low)))
+ (setq S1W-high (+ (% (* W-high 2) 65536)
+ (/ W-low (, (/ 65536 2)))))
+ (setq S1W-low (+ (/ W-high (, (/ 65536 2)))
+ (% (* W-low 2) 65536))))))
+ (defmacro sha1-S5 (A-high A-low)
+ (` (progn
+ (setq S5A-high (+ (% (* (, A-high) 32) 65536)
+ (/ (, A-low) (, (/ 65536 32)))))
+ (setq S5A-low (+ (/ (, A-high) (, (/ 65536 32)))
+ (% (* (, A-low) 32) 65536))))))
+ (defmacro sha1-S30 (B-high B-low)
+ (` (progn
+ (setq S30B-high (+ (/ (, B-high) 4)
+ (* (% (, B-low) 4) (, (/ 65536 4)))))
+ (setq S30B-low (+ (/ (, B-low) 4)
+ (* (% (, B-high) 4) (, (/ 65536 4))))))))
+
+ (defmacro sha1-OP (round)
+ (` (progn
+ (sha1-S5 sha1-A-high sha1-A-low)
+ (sha1-S30 sha1-B-high sha1-B-low)
+ (setq sha1-A-low (+ ((, (intern (format "sha1-F%d" round)))
+ sha1-B-low sha1-C-low sha1-D-low)
+ sha1-E-low
+ (, (symbol-value
+ (intern (format "sha1-K%d-low" round))))
+ (aref block-low idx)
+ (progn
+ (setq sha1-E-low sha1-D-low)
+ (setq sha1-D-low sha1-C-low)
+ (setq sha1-C-low S30B-low)
+ (setq sha1-B-low sha1-A-low)
+ S5A-low)))
+ (setq carry (/ sha1-A-low 65536))
+ (setq sha1-A-low (% sha1-A-low 65536))
+ (setq sha1-A-high (% (+ ((, (intern (format "sha1-F%d" round)))
+ sha1-B-high sha1-C-high sha1-D-high)
+ sha1-E-high
+ (, (symbol-value
+ (intern (format "sha1-K%d-high" round))))
+ (aref block-high idx)
+ (progn
+ (setq sha1-E-high sha1-D-high)
+ (setq sha1-D-high sha1-C-high)
+ (setq sha1-C-high S30B-high)
+ (setq sha1-B-high sha1-A-high)
+ S5A-high)
+ carry)
+ 65536)))))
+
+ (defmacro sha1-add-to-H (H X)
+ (` (progn
+ (setq (, (intern (format "sha1-%s-low" H)))
+ (+ (, (intern (format "sha1-%s-low" H)))
+ (, (intern (format "sha1-%s-low" X)))))
+ (setq carry (/ (, (intern (format "sha1-%s-low" H))) 65536))
+ (setq (, (intern (format "sha1-%s-low" H)))
+ (% (, (intern (format "sha1-%s-low" H))) 65536))
+ (setq (, (intern (format "sha1-%s-high" H)))
+ (% (+ (, (intern (format "sha1-%s-high" H)))
+ (, (intern (format "sha1-%s-high" X)))
+ carry)
+ 65536)))))
+ )
+
+;;; buffers (H0 H1 H2 H3 H4).
+(defvar sha1-H0-high)
+(defvar sha1-H0-low)
+(defvar sha1-H1-high)
+(defvar sha1-H1-low)
+(defvar sha1-H2-high)
+(defvar sha1-H2-low)
+(defvar sha1-H3-high)
+(defvar sha1-H3-low)
+(defvar sha1-H4-high)
+(defvar sha1-H4-low)
+
+(defun sha1-block (block-high block-low)
+ (let (;; step (c) --- initialize buffers (A B C D E).
+ (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low)
+ (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low)
+ (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low)
+ (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low)
+ (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low)
+ (idx 16))
+ ;; step (b).
+ (let (;; temporary variables used in sha1-S1 macro.
+ S1W-high S1W-low)
+ (while (< idx 80)
+ (sha1-S1 (logxor (aref block-high (- idx 3))
+ (aref block-high (- idx 8))
+ (aref block-high (- idx 14))
+ (aref block-high (- idx 16)))
+ (logxor (aref block-low (- idx 3))
+ (aref block-low (- idx 8))
+ (aref block-low (- idx 14))
+ (aref block-low (- idx 16))))
+ (aset block-high idx S1W-high)
+ (aset block-low idx S1W-low)
+ (setq idx (1+ idx))))
+ ;; step (d).
+ (setq idx 0)
+ (let (;; temporary variables used in sha1-OP macro.
+ S5A-high S5A-low S30B-high S30B-low carry)
+ (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx)))
+ (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx)))
+ (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx)))
+ (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx))))
+ ;; step (e).
+ (let (;; temporary variables used in sha1-add-to-H macro.
+ carry)
+ (sha1-add-to-H H0 A)
+ (sha1-add-to-H H1 B)
+ (sha1-add-to-H H2 C)
+ (sha1-add-to-H H3 D)
+ (sha1-add-to-H H4 E))))
+
+(defun sha1-binary (string)
+ "Return the SHA1 of STRING in binary form."
+ (let (;; prepare buffers for a block. byte-length of block is 64.
+ ;; input block is split into two vectors.
+ ;;
+ ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ...
+ ;; block-high: +-0-+ +-1-+ +-2-+ +-3-+
+ ;; block-low: +-0-+ +-1-+ +-2-+ +-3-+
+ ;;
+ ;; length of each vector is 80, and elements of each vector are
+ ;; 16bit integers. elements 0x10-0x4F of each vector are
+ ;; assigned later in `sha1-block'.
+ (block-high (eval-when-compile (make-vector 80 nil)))
+ (block-low (eval-when-compile (make-vector 80 nil))))
+ (unwind-protect
+ (let* (;; byte-length of input string.
+ (len (length string))
+ (lim (* (/ len 64) 64))
+ (rem (% len 4))
+ (idx 0)(pos 0))
+ ;; initialize buffers (H0 H1 H2 H3 H4).
+ (setq sha1-H0-high 26437 ; (string-to-number "6745" 16)
+ sha1-H0-low 8961 ; (string-to-number "2301" 16)
+ sha1-H1-high 61389 ; (string-to-number "EFCD" 16)
+ sha1-H1-low 43913 ; (string-to-number "AB89" 16)
+ sha1-H2-high 39098 ; (string-to-number "98BA" 16)
+ sha1-H2-low 56574 ; (string-to-number "DCFE" 16)
+ sha1-H3-high 4146 ; (string-to-number "1032" 16)
+ sha1-H3-low 21622 ; (string-to-number "5476" 16)
+ sha1-H4-high 50130 ; (string-to-number "C3D2" 16)
+ sha1-H4-low 57840) ; (string-to-number "E1F0" 16)
+ ;; loop for each 64 bytes block.
+ (while (< pos lim)
+ ;; step (a).
+ (setq idx 0)
+ (while (< idx 16)
+ (aset block-high idx (+ (* (aref string pos) 256)
+ (aref string (1+ pos))))
+ (setq pos (+ pos 2))
+ (aset block-low idx (+ (* (aref string pos) 256)
+ (aref string (1+ pos))))
+ (setq pos (+ pos 2))
+ (setq idx (1+ idx)))
+ (sha1-block block-high block-low))
+ ;; last block.
+ (if (prog1
+ (< (- len lim) 56)
+ (setq lim (- len rem))
+ (setq idx 0)
+ (while (< pos lim)
+ (aset block-high idx (+ (* (aref string pos) 256)
+ (aref string (1+ pos))))
+ (setq pos (+ pos 2))
+ (aset block-low idx (+ (* (aref string pos) 256)
+ (aref string (1+ pos))))
+ (setq pos (+ pos 2))
+ (setq idx (1+ idx)))
+ ;; this is the last (at most) 32bit word.
+ (cond
+ ((= rem 3)
+ (aset block-high idx (+ (* (aref string pos) 256)
+ (aref string (1+ pos))))
+ (setq pos (+ pos 2))
+ (aset block-low idx (+ (* (aref string pos) 256)
+ 128)))
+ ((= rem 2)
+ (aset block-high idx (+ (* (aref string pos) 256)
+ (aref string (1+ pos))))
+ (aset block-low idx 32768))
+ ((= rem 1)
+ (aset block-high idx (+ (* (aref string pos) 256)
+ 128))
+ (aset block-low idx 0))
+ (t ;; (= rem 0)
+ (aset block-high idx 32768)
+ (aset block-low idx 0)))
+ (setq idx (1+ idx))
+ (while (< idx 16)
+ (aset block-high idx 0)
+ (aset block-low idx 0)
+ (setq idx (1+ idx))))
+ ;; last block has enough room to write the length of string.
+ (progn
+ ;; write bit length of string to last 4 bytes of the block.
+ (aset block-low 15 (* (% len 8192) 8))
+ (setq len (/ len 8192))
+ (aset block-high 15 (% len 65536))
+ ;; XXX: It is not practical to compute SHA1 of
+ ;; such a huge message on emacs.
+ ;; (setq len (/ len 65536)) ; for 64bit emacs.
+ ;; (aset block-low 14 (% len 65536))
+ ;; (aset block-high 14 (/ len 65536))
+ (sha1-block block-high block-low))
+ ;; need one more block.
+ (sha1-block block-high block-low)
+ (fillarray block-high 0)
+ (fillarray block-low 0)
+ ;; write bit length of string to last 4 bytes of the block.
+ (aset block-low 15 (* (% len 8192) 8))
+ (setq len (/ len 8192))
+ (aset block-high 15 (% len 65536))
+ ;; XXX: It is not practical to compute SHA1 of
+ ;; such a huge message on emacs.
+ ;; (setq len (/ len 65536)) ; for 64bit emacs.
+ ;; (aset block-low 14 (% len 65536))
+ ;; (aset block-high 14 (/ len 65536))
+ (sha1-block block-high block-low))
+ ;; make output string (in binary form).
+ (let ((result (make-string 20 0)))
+ (aset result 0 (/ sha1-H0-high 256))
+ (aset result 1 (% sha1-H0-high 256))
+ (aset result 2 (/ sha1-H0-low 256))
+ (aset result 3 (% sha1-H0-low 256))
+ (aset result 4 (/ sha1-H1-high 256))
+ (aset result 5 (% sha1-H1-high 256))
+ (aset result 6 (/ sha1-H1-low 256))
+ (aset result 7 (% sha1-H1-low 256))
+ (aset result 8 (/ sha1-H2-high 256))
+ (aset result 9 (% sha1-H2-high 256))
+ (aset result 10 (/ sha1-H2-low 256))
+ (aset result 11 (% sha1-H2-low 256))
+ (aset result 12 (/ sha1-H3-high 256))
+ (aset result 13 (% sha1-H3-high 256))
+ (aset result 14 (/ sha1-H3-low 256))
+ (aset result 15 (% sha1-H3-low 256))
+ (aset result 16 (/ sha1-H4-high 256))
+ (aset result 17 (% sha1-H4-high 256))
+ (aset result 18 (/ sha1-H4-low 256))
+ (aset result 19 (% sha1-H4-low 256))
+ result))
+ ;; do not leave a copy of input string.
+ (fillarray block-high nil)
+ (fillarray block-low nil))))
+
+(defun sha1-string-internal (string)
+ (encode-hex-string (sha1-binary string)))
+
+(defun sha1-region-internal (beg end)
+ (sha1-string-internal (buffer-substring-no-properties beg end)))
+
+;;;
+;;; application interface.
+;;;
+
+(defun sha1-region (beg end)
+ (if (and sha1-use-external
+ sha1-maximum-internal-length
+ (> (abs (- end beg)) sha1-maximum-internal-length))
+ (sha1-region-external beg end)
+ (sha1-region-internal beg end)))
+
+(defun sha1-string (string)
+ (if (and sha1-use-external
+ sha1-maximum-internal-length
+ (> (length string) sha1-maximum-internal-length))
+ (sha1-string-external string)
+ (sha1-string-internal string)))
+
+(defun sha1 (object &optional beg end)
+ "Return the SHA1 (Secure Hash Algorithm) of an object.
+OBJECT is either a string or a buffer.
+Optional arguments BEG and END denote buffer positions for computing the
+hash of a portion of OBJECT."
+ (if (stringp object)
+ (sha1-string object)
+ (save-excursion
+ (set-buffer object)
+ (sha1-region (or beg (point-min)) (or end (point-max))))))
+
+(provide 'sha1-el)
+
+;;; sha1-el.el ends here
--- /dev/null
+;;; sieve-manage.el --- Implementation of the managesive protocol in elisp
+;; Copyright (C) 2001, 2003 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 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'
+;; `sieve-manage-deletescript'
+;; `sieve-manage-getscript'
+;; 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.
+;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd.
+
+;;; 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 actual authentication.")
+
+(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)))
+
+;; 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
+ (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)))
+
+(eval-and-compile
+ (if (fboundp 'string-bytes)
+ (defalias 'sieve-string-bytes 'string-bytes)
+ (defalias 'sieve-string-bytes 'length)))
+
+(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-deletescript (name &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "DELETESCRIPT \"%s\"" name))
+ (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))
+ (let ((status (match-string 1))
+ (resp-code (match-string 3))
+ (response (match-string 5)))
+ (when response
+ (goto-char (match-beginning 5))
+ (setq response (sieve-manage-is-string)))
+ (list status resp-code response))))
+
+(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, 2003 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 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
+
+;;; Code:
+
+(autoload 'sieve-manage "sieve")
+(autoload 'sieve-upload "sieve")
+(autoload 'c-mode "cc-mode")
+(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
+
+(defvar sieve-control-commands-face 'sieve-control-commands-face
+ "Face name used for Sieve Control Commands.")
+
+(defface sieve-control-commands-face
+ '((((type tty) (class color)) (:foreground "blue" :weight light))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (((class color) (background light)) (:foreground "Orchid"))
+ (((class color) (background dark)) (:foreground "LightSteelBlue"))
+ (t (:bold t)))
+ "Face used for Sieve Control Commands.")
+
+(defvar sieve-action-commands-face 'sieve-action-commands-face
+ "Face name used for Sieve Action Commands.")
+
+(defface sieve-action-commands-face
+ '((((type tty) (class color)) (:foreground "blue" :weight bold))
+ (((class color) (background light)) (:foreground "Blue"))
+ (((class color) (background dark)) (:foreground "LightSkyBlue"))
+ (t (:inverse-video t :bold t)))
+ "Face used for Sieve Action Commands.")
+
+(defvar sieve-test-commands-face 'sieve-test-commands-face
+ "Face name used for Sieve Test Commands.")
+
+(defface sieve-test-commands-face
+ '((((type tty) (class color)) (:foreground "magenta"))
+ (((class grayscale) (background light))
+ (:foreground "LightGray" :bold t :underline t))
+ (((class grayscale) (background dark))
+ (:foreground "Gray50" :bold t :underline t))
+ (((class color) (background light)) (:foreground "CadetBlue"))
+ (((class color) (background dark)) (:foreground "Aquamarine"))
+ (t (:bold t :underline t)))
+ "Face used for Sieve Test Commands.")
+
+(defvar sieve-tagged-arguments-face 'sieve-tagged-arguments-face
+ "Face name used for Sieve Tagged Arguments.")
+
+(defface sieve-tagged-arguments-face
+ '((((type tty) (class color)) (:foreground "cyan" :weight bold))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (t (:bold t)))
+ "Face used for Sieve Tagged Arguments.")
+
+
+(defconst sieve-font-lock-keywords
+ (eval-when-compile
+ (list
+ ;; control commands
+ (cons (regexp-opt '("require" "if" "else" "elsif" "stop"))
+ 'sieve-control-commands-face)
+ ;; action commands
+ (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard"))
+ 'sieve-action-commands-face)
+ ;; test commands
+ (cons (regexp-opt '("address" "allof" "anyof" "exists" "false"
+ "true" "header" "not" "size" "envelope"))
+ 'sieve-test-commands-face)
+ (cons "\\Sw+:\\sw+"
+ 'sieve-tagged-arguments-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-c" 'sieve-upload-and-bury)
+ (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) "#+ *")
+ (unless (featurep 'xemacs)
+ (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, 2003 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 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.
+;; 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."
+ :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))
+
+(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-item nil nil sieve-manage-mode-menu))
+
+(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)
+ (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" (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 (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 (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)))))))
+
+;;;###autoload
+(defun sieve-upload-and-bury (&optional name)
+ (interactive)
+ (sieve-upload name)
+ (bury-buffer))
+
+(provide 'sieve)
+
+;; sieve.el ends here
--- /dev/null
+;;; smime.el --- S/MIME support library
+;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Keywords: SMIME X.509 PEM OpenSSL
+
+;; 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 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 perform S/MIME operations from within Emacs.
+;;
+;; Functions for fetching certificates from public repositories are
+;; provided, currently only from DNS. LDAP support (via EUDC) is planned.
+;;
+;; It uses OpenSSL (tested with version 0.9.5a and 0.9.6) for signing,
+;; encryption and decryption.
+;;
+;; Some general knowledge of S/MIME, X.509, PKCS#12, PEM etc is
+;; probably required to use this library in any useful way.
+;; Especially, don't expect this library to buy security for you. If
+;; you don't understand what you are doing, you're as likely to lose
+;; security than gain any by using this library.
+;;
+;; This library is not intended to provide a "raw" API for S/MIME,
+;; PKCSx or similar, it's intended to perform common operations
+;; done on messages encoded in these formats. The terminology chosen
+;; reflect this.
+;;
+;; The home of this file is in Gnus CVS, but also available from
+;; http://josefsson.org/smime.html.
+
+;;; Quick introduction:
+
+;; Get your S/MIME certificate from VeriSign or someplace. I used
+;; Netscape to generate the key and certificate request and stuff, and
+;; Netscape can export the key into PKCS#12 format.
+;;
+;; Enter OpenSSL. To be able to use this library, it need to have the
+;; SMIME key readable in PEM format. OpenSSL is used to convert the
+;; key:
+;;
+;; $ openssl pkcs12 -in mykey.p12 -clcerts -nodes > mykey.pem
+;; ...
+;;
+;; Now, use M-x customize-variable smime-keys and add mykey.pem as
+;; a key.
+;;
+;; Now you should be able to sign messages! Create a buffer and write
+;; something and run M-x smime-sign-buffer RET RET and you should see
+;; your message MIME armoured and a signature. Encryption, M-x
+;; smime-encrypt-buffer, should also work.
+;;
+;; To be able to verify messages you need to build up trust with
+;; someone. Perhaps you trust the CA that issued your certificate, at
+;; least I did, so I export it's certificates from my PKCS#12
+;; certificate with:
+;;
+;; $ openssl pkcs12 -in mykey.p12 -cacerts -nodes > cacert.pem
+;; ...
+;;
+;; Now, use M-x customize-variable smime-CAs and add cacert.pem as a
+;; CA certificate.
+;;
+;; You should now be able to sign messages, and even verify messages
+;; sent by others that use the same CA as you.
+
+;; Bugs:
+;;
+;; Don't complain that this package doesn't do encrypted PEM files,
+;; submit a patch instead. I store my keys in a safe place, so I
+;; didn't need the encryption. Also, programming was made easier by
+;; that decision. One might think that this even influenced were I
+;; store my keys, and one would probably be right. :-)
+;;
+;; Update: Mathias Herberts sent the patch. However, it uses
+;; environment variables to pass the password to OpenSSL, which is
+;; slightly insecure. Hence a new todo: use a better -passin method.
+;;
+;; Cache password for e.g. 1h
+;;
+;; Suggestions and comments are appreciated, mail me at simon@josefsson.org.
+
+;; begin rant
+;;
+;; I would include pointers to introductory text on concepts used in
+;; this library here, but the material I've read are so horrible I
+;; don't want to recomend them.
+;;
+;; Why can't someone write a simple introduction to all this stuff?
+;; Until then, much of this resemble security by obscurity.
+;;
+;; Also, I'm not going to mention anything about the wonders of
+;; cryptopolitics. Oops, I just did.
+;;
+;; end rant
+
+;;; Revision history:
+
+;; 2000-06-05 initial version, committed to Gnus CVS contrib/
+;; 2000-10-28 retrieve certificates via DNS CERT RRs
+;; 2001-10-14 posted to gnu.emacs.sources
+
+;;; Code:
+
+(require 'dig)
+(require 'comint)
+(eval-when-compile (require 'cl))
+
+(defgroup smime nil
+ "S/MIME configuration.")
+
+(defcustom smime-keys nil
+ "*Map mail addresses to a file containing Certificate (and private key).
+The file is assumed to be in PEM format. You can also associate additional
+certificates to be sent with every message to each address."
+ :type '(repeat (list (string :tag "Mail address")
+ (file :tag "File name")
+ (repeat :tag "Additional certificate files"
+ (file :tag "File name"))))
+ :group 'smime)
+
+(defcustom smime-CA-directory nil
+ "*Directory containing certificates for CAs you trust.
+Directory should contain files (in PEM format) named to the X.509
+hash of the certificate. This can be done using OpenSSL such as:
+
+$ ln -s ca.pem `openssl x509 -noout -hash -in ca.pem`.0
+
+where `ca.pem' is the file containing a PEM encoded X.509 CA
+certificate."
+ :type '(choice (const :tag "none" nil)
+ directory)
+ :group 'smime)
+
+(defcustom smime-CA-file nil
+ "*Files containing certificates for CAs you trust.
+File should contain certificates in PEM format."
+ :type '(choice (const :tag "none" nil)
+ file)
+ :group 'smime)
+
+(defcustom smime-certificate-directory "~/Mail/certs/"
+ "*Directory containing other people's certificates.
+It should contain files named to the X.509 hash of the certificate,
+and the files themself should be in PEM format."
+;The S/MIME library provide simple functionality for fetching
+;certificates into this directory, so there is no need to populate it
+;manually.
+ :type 'directory
+ :group 'smime)
+
+(defcustom smime-openssl-program
+ (and (condition-case ()
+ (eq 0 (call-process "openssl" nil nil nil "version"))
+ (error nil))
+ "openssl")
+ "*Name of OpenSSL binary."
+ :type 'string
+ :group 'smime)
+
+;; OpenSSL option to select the encryption cipher
+
+(defcustom smime-encrypt-cipher "-des3"
+ "*Cipher algorithm used for encryption."
+ :type '(choice (const :tag "Triple DES" "-des3")
+ (const :tag "DES" "-des")
+ (const :tag "RC2 40 bits" "-rc2-40")
+ (const :tag "RC2 64 bits" "-rc2-64")
+ (const :tag "RC2 128 bits" "-rc2-128"))
+ :group 'smime)
+
+(defcustom smime-dns-server nil
+ "*DNS server to query certificates from.
+If nil, use system defaults."
+ :type '(choice (const :tag "System defaults")
+ string)
+ :group 'smime)
+
+(defvar smime-details-buffer "*OpenSSL output*")
+
+(eval-and-compile
+ (defalias 'smime-make-temp-file
+ (if (fboundp 'make-temp-file)
+ 'make-temp-file
+ (lambda (prefix &optional dir-flag) ;; Simple implementation
+ (expand-file-name
+ (make-temp-name prefix)
+ (if (fboundp 'temp-directory)
+ (temp-directory)
+ temporary-file-directory))))))
+
+;; Password dialog function
+
+(defun smime-ask-passphrase ()
+ "Asks the passphrase to unlock the secret key."
+ (let ((passphrase
+ (comint-read-noecho
+ "Passphrase for secret key (RET for no passphrase): " t)))
+ (if (string= passphrase "")
+ nil
+ passphrase)))
+
+;; OpenSSL wrappers.
+
+(defun smime-call-openssl-region (b e buf &rest args)
+ (case (apply 'call-process-region b e smime-openssl-program nil buf nil args)
+ (0 t)
+ (1 (message "OpenSSL: An error occurred parsing the command options.") nil)
+ (2 (message "OpenSSL: One of the input files could not be read.") nil)
+ (3 (message "OpenSSL: An error occurred creating the PKCS#7 file or when reading the MIME message.") nil)
+ (4 (message "OpenSSL: An error occurred decrypting or verifying the message.") nil)
+ (t (error "Unknown OpenSSL exitcode") nil)))
+
+(defun smime-make-certfiles (certfiles)
+ (if certfiles
+ (append (list "-certfile" (expand-file-name (car certfiles)))
+ (smime-make-certfiles (cdr certfiles)))))
+
+;; Sign+encrypt region
+
+(defun smime-sign-region (b e keyfile)
+ "Sign region with certified key in KEYFILE.
+If signing fails, the buffer is not modified. Region is assumed to
+have proper MIME tags. KEYFILE is expected to contain a PEM encoded
+private key and certificate as its car, and a list of additional
+certificates to include in its caar. If no additional certificates is
+included, KEYFILE may be the file containing the PEM encoded private
+key and certificate itself."
+ (smime-new-details-buffer)
+ (let ((keyfile (or (car-safe keyfile) keyfile))
+ (certfiles (and (cdr-safe keyfile) (cadr keyfile)))
+ (buffer (generate-new-buffer (generate-new-buffer-name " *smime*")))
+ (passphrase (smime-ask-passphrase))
+ (tmpfile (smime-make-temp-file "smime")))
+ (if passphrase
+ (setenv "GNUS_SMIME_PASSPHRASE" passphrase))
+ (prog1
+ (when (prog1
+ (apply 'smime-call-openssl-region b e (list buffer tmpfile)
+ "smime" "-sign" "-signer" (expand-file-name keyfile)
+ (append
+ (smime-make-certfiles certfiles)
+ (if passphrase
+ (list "-passin" "env:GNUS_SMIME_PASSPHRASE"))))
+ (if passphrase
+ (setenv "GNUS_SMIME_PASSPHRASE" "" t))
+ (with-current-buffer smime-details-buffer
+ (insert-file-contents tmpfile)
+ (delete-file tmpfile)))
+ (delete-region b e)
+ (insert-buffer-substring buffer)
+ (goto-char b)
+ (when (looking-at "^MIME-Version: 1.0$")
+ (delete-region (point) (progn (forward-line 1) (point))))
+ t)
+ (with-current-buffer smime-details-buffer
+ (goto-char (point-max))
+ (insert-buffer-substring buffer))
+ (kill-buffer buffer))))
+
+(defun smime-encrypt-region (b e certfiles)
+ "Encrypt region for recipients specified in CERTFILES.
+If encryption fails, the buffer is not modified. Region is assumed to
+have proper MIME tags. CERTFILES is a list of filenames, each file
+is expected to contain of a PEM encoded certificate."
+ (smime-new-details-buffer)
+ (let ((buffer (generate-new-buffer (generate-new-buffer-name " *smime*")))
+ (tmpfile (smime-make-temp-file "smime")))
+ (prog1
+ (when (prog1
+ (apply 'smime-call-openssl-region b e (list buffer tmpfile)
+ "smime" "-encrypt" smime-encrypt-cipher
+ (mapcar 'expand-file-name certfiles))
+ (with-current-buffer smime-details-buffer
+ (insert-file-contents tmpfile)
+ (delete-file tmpfile)))
+ (delete-region b e)
+ (insert-buffer-substring buffer)
+ (goto-char b)
+ (when (looking-at "^MIME-Version: 1.0$")
+ (delete-region (point) (progn (forward-line 1) (point))))
+ t)
+ (with-current-buffer smime-details-buffer
+ (goto-char (point-max))
+ (insert-buffer-substring buffer))
+ (kill-buffer buffer))))
+
+;; Sign+encrypt buffer
+
+(defun smime-sign-buffer (&optional keyfile buffer)
+ "S/MIME sign BUFFER with key in KEYFILE.
+KEYFILE should contain a PEM encoded key and certificate."
+ (interactive)
+ (with-current-buffer (or buffer (current-buffer))
+ (smime-sign-region
+ (point-min) (point-max)
+ (if keyfile
+ keyfile
+ (smime-get-key-with-certs-by-email
+ (completing-read
+ (concat "Sign using which key? "
+ (if smime-keys (concat "(default " (caar smime-keys) ") ")
+ ""))
+ smime-keys nil nil (car-safe (car-safe smime-keys))))))))
+
+(defun smime-encrypt-buffer (&optional certfiles buffer)
+ "S/MIME encrypt BUFFER for recipients specified in CERTFILES.
+CERTFILES is a list of filenames, each file is expected to consist of
+a PEM encoded key and certificate. Uses current buffer if BUFFER is
+nil."
+ (interactive)
+ (with-current-buffer (or buffer (current-buffer))
+ (smime-encrypt-region
+ (point-min) (point-max)
+ (or certfiles
+ (list (read-file-name "Recipient's S/MIME certificate: "
+ smime-certificate-directory nil))))))
+
+;; Verify+decrypt region
+
+(defun smime-verify-region (b e)
+ "Verify S/MIME message in region between B and E.
+Returns non-nil on success.
+Any details (stdout and stderr) are left in the buffer specified by
+`smime-details-buffer'."
+ (smime-new-details-buffer)
+ (let ((CAs (append (if smime-CA-file
+ (list "-CAfile"
+ (expand-file-name smime-CA-file)))
+ (if smime-CA-directory
+ (list "-CApath"
+ (expand-file-name smime-CA-directory))))))
+ (unless CAs
+ (error "No CA configured"))
+ (if (apply 'smime-call-openssl-region b e (list smime-details-buffer t)
+ "smime" "-verify" "-out" "/dev/null" CAs)
+ t
+ (insert-buffer-substring smime-details-buffer)
+ nil)))
+
+(defun smime-noverify-region (b e)
+ "Verify integrity of S/MIME message in region between B and E.
+Returns non-nil on success.
+Any details (stdout and stderr) are left in the buffer specified by
+`smime-details-buffer'."
+ (smime-new-details-buffer)
+ (if (apply 'smime-call-openssl-region b e (list smime-details-buffer t)
+ "smime" "-verify" "-noverify" "-out" '("/dev/null"))
+ t
+ (insert-buffer-substring smime-details-buffer)
+ nil))
+
+(eval-when-compile
+ (defvar from))
+
+(defun smime-decrypt-region (b e keyfile)
+ "Decrypt S/MIME message in region between B and E with key in KEYFILE.
+On success, replaces region with decrypted data and return non-nil.
+Any details (stderr on success, stdout and stderr on error) are left
+in the buffer specified by `smime-details-buffer'."
+ (smime-new-details-buffer)
+ (let ((buffer (generate-new-buffer (generate-new-buffer-name " *smime*")))
+ CAs (passphrase (smime-ask-passphrase))
+ (tmpfile (smime-make-temp-file "smime")))
+ (if passphrase
+ (setenv "GNUS_SMIME_PASSPHRASE" passphrase))
+ (if (prog1
+ (apply 'smime-call-openssl-region b e
+ (list buffer tmpfile)
+ "smime" "-decrypt" "-recip" (expand-file-name keyfile)
+ (if passphrase
+ (list "-passin" "env:GNUS_SMIME_PASSPHRASE")))
+ (if passphrase
+ (setenv "GNUS_SMIME_PASSPHRASE" "" t))
+ (with-current-buffer smime-details-buffer
+ (insert-file-contents tmpfile)
+ (delete-file tmpfile)))
+ (progn
+ (delete-region b e)
+ (when (boundp 'from)
+ ;; `from' is dynamically bound in mm-dissect.
+ (insert "From: " from "\n"))
+ (insert-buffer-substring buffer)
+ (kill-buffer buffer)
+ t)
+ (with-current-buffer smime-details-buffer
+ (insert-buffer-substring buffer))
+ (kill-buffer buffer)
+ (delete-region b e)
+ (insert-buffer-substring smime-details-buffer)
+ nil)))
+
+;; Verify+Decrypt buffer
+
+(defun smime-verify-buffer (&optional buffer)
+ "Verify integrity of S/MIME message in BUFFER.
+Uses current buffer if BUFFER is nil. Returns non-nil on success.
+Any details (stdout and stderr) are left in the buffer specified by
+`smime-details-buffer'."
+ (interactive)
+ (with-current-buffer (or buffer (current-buffer))
+ (smime-verify-region (point-min) (point-max))))
+
+(defun smime-noverify-buffer (&optional buffer)
+ "Verify integrity of S/MIME message in BUFFER.
+Does NOT verify validity of certificate (only message integrity).
+Uses current buffer if BUFFER is nil. Returns non-nil on success.
+Any details (stdout and stderr) are left in the buffer specified by
+`smime-details-buffer'."
+ (interactive)
+ (with-current-buffer (or buffer (current-buffer))
+ (smime-noverify-region (point-min) (point-max))))
+
+(defun smime-decrypt-buffer (&optional buffer keyfile)
+ "Decrypt S/MIME message in BUFFER using KEYFILE.
+Uses current buffer if BUFFER is nil, and query user of KEYFILE if it's nil.
+On success, replaces data in buffer and return non-nil.
+Any details (stderr on success, stdout and stderr on error) are left
+in the buffer specified by `smime-details-buffer'."
+ (interactive)
+ (with-current-buffer (or buffer (current-buffer))
+ (smime-decrypt-region
+ (point-min) (point-max)
+ (expand-file-name
+ (or keyfile
+ (smime-get-key-by-email
+ (completing-read
+ (concat "Decipher using which key? "
+ (if smime-keys (concat "(default " (caar smime-keys) ") ")
+ ""))
+ smime-keys nil nil (car-safe (car-safe smime-keys)))))))))
+
+;; Various operations
+
+(defun smime-new-details-buffer ()
+ (with-current-buffer (get-buffer-create smime-details-buffer)
+ (erase-buffer)))
+
+(defun smime-pkcs7-region (b e)
+ "Convert S/MIME message between points B and E into a PKCS7 message."
+ (smime-new-details-buffer)
+ (when (smime-call-openssl-region b e smime-details-buffer "smime" "-pk7out")
+ (delete-region b e)
+ (insert-buffer-substring smime-details-buffer)
+ t))
+
+(defun smime-pkcs7-certificates-region (b e)
+ "Extract any certificates enclosed in PKCS7 message between points B and E."
+ (smime-new-details-buffer)
+ (when (smime-call-openssl-region
+ b e smime-details-buffer "pkcs7" "-print_certs" "-text")
+ (delete-region b e)
+ (insert-buffer-substring smime-details-buffer)
+ t))
+
+(defun smime-pkcs7-email-region (b e)
+ "Get email addresses contained in certificate between points B and E.
+A string or a list of strings is returned."
+ (smime-new-details-buffer)
+ (when (smime-call-openssl-region
+ b e smime-details-buffer "x509" "-email" "-noout")
+ (delete-region b e)
+ (insert-buffer-substring smime-details-buffer)
+ t))
+
+;; Utility functions
+
+(defun smime-get-certfiles (keyfile keys)
+ (if keys
+ (let ((curkey (car keys))
+ (otherkeys (cdr keys)))
+ (if (string= keyfile (cadr curkey))
+ (caddr curkey)
+ (smime-get-certfiles keyfile otherkeys)))))
+
+(eval-and-compile
+ (defalias 'smime-point-at-eol
+ (if (fboundp 'point-at-eol)
+ 'point-at-eol
+ 'line-end-position)))
+
+(defun smime-buffer-as-string-region (b e)
+ "Return each line in region between B and E as a list of strings."
+ (save-excursion
+ (goto-char b)
+ (let (res)
+ (while (< (point) e)
+ (let ((str (buffer-substring (point) (smime-point-at-eol))))
+ (unless (string= "" str)
+ (push str res)))
+ (forward-line))
+ res)))
+
+;; Find certificates
+
+(defun smime-mail-to-domain (mailaddr)
+ (if (string-match "@" mailaddr)
+ (replace-match "." 'fixedcase 'literal mailaddr)
+ mailaddr))
+
+(defun smime-cert-by-dns (mail)
+ (let* ((dig-dns-server smime-dns-server)
+ (digbuf (dig-invoke (smime-mail-to-domain mail) "cert" nil nil "+vc"))
+ (retbuf (generate-new-buffer (format "*certificate for %s*" mail)))
+ (certrr (with-current-buffer digbuf
+ (dig-extract-rr (smime-mail-to-domain mail) "cert")))
+ (cert (and certrr (dig-rr-get-pkix-cert certrr))))
+ (if cert
+ (with-current-buffer retbuf
+ (insert "-----BEGIN CERTIFICATE-----\n")
+ (let ((i 0) (len (length cert)))
+ (while (> (- len 64) i)
+ (insert (substring cert i (+ i 64)) "\n")
+ (setq i (+ i 64)))
+ (insert (substring cert i len) "\n"))
+ (insert "-----END CERTIFICATE-----\n"))
+ (kill-buffer retbuf)
+ (setq retbuf nil))
+ (kill-buffer digbuf)
+ retbuf))
+
+;; User interface.
+
+(defvar smime-buffer "*SMIME*")
+
+(defvar smime-mode-map nil)
+(put 'smime-mode 'mode-class 'special)
+
+(unless smime-mode-map
+ (setq smime-mode-map (make-sparse-keymap))
+ (suppress-keymap smime-mode-map)
+
+ (define-key smime-mode-map "q" 'smime-exit)
+ (define-key smime-mode-map "f" 'smime-certificate-info))
+
+(defun smime-mode ()
+ "Major mode for browsing, viewing and fetching certificates.
+
+All normal editing commands are switched off.
+\\<smime-mode-map>
+
+The following commands are available:
+
+\\{smime-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'smime-mode)
+ (setq mode-name "SMIME")
+ (setq mode-line-process nil)
+ (use-local-map smime-mode-map)
+ (buffer-disable-undo)
+ (setq truncate-lines t)
+ (setq buffer-read-only t))
+
+(defun smime-certificate-info (certfile)
+ (interactive "fCertificate file: ")
+ (let ((buffer (get-buffer-create (format "*certificate %s*" certfile))))
+ (switch-to-buffer buffer)
+ (erase-buffer)
+ (call-process smime-openssl-program nil buffer 'display
+ "x509" "-in" (expand-file-name certfile) "-text")
+ (fundamental-mode)
+ (set-buffer-modified-p nil)
+ (toggle-read-only t)
+ (goto-char (point-min))))
+
+(defun smime-draw-buffer ()
+ (with-current-buffer smime-buffer
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert "\nYour keys:\n")
+ (dolist (key smime-keys)
+ (insert
+ (format "\t\t%s: %s\n" (car key) (cadr key))))
+ (insert "\nTrusted Certificate Authoritys:\n")
+ (insert "\nKnown Certificates:\n"))))
+
+(defun smime ()
+ "Go to the SMIME buffer."
+ (interactive)
+ (unless (get-buffer smime-buffer)
+ (save-excursion
+ (set-buffer (get-buffer-create smime-buffer))
+ (smime-mode)))
+ (smime-draw-buffer)
+ (switch-to-buffer smime-buffer))
+
+(defun smime-exit ()
+ "Quit the S/MIME buffer."
+ (interactive)
+ (kill-buffer (current-buffer)))
+
+;; Other functions
+
+(defun smime-get-key-by-email (email)
+ (cadr (assoc email smime-keys)))
+
+(defun smime-get-key-with-certs-by-email (email)
+ (cdr (assoc email smime-keys)))
+
+(provide 'smime)
+
+;;; smime.el ends here
--- /dev/null
+;;; spam-report.el --- Reporting spam
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.com>
+;; Keywords: network
+
+;; 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 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 module addresses a few aspects of spam reporting under Gnus. Page
+;;; breaks are used for grouping declarations and documentation relating to
+;;; each particular aspect.
+
+;;; Code:
+(require 'gnus)
+(require 'gnus-sum)
+
+(defgroup spam-report nil
+ "Spam reporting configuration.")
+
+(defcustom spam-report-gmane-regex nil
+ "String matching Gmane newsgroups if wanted, e.g. \"^nntp+.*:gmane.\"
+This is probably handled better with group/topic parameters."
+ :type 'regexp
+ :group 'spam-report)
+
+(defcustom spam-report-gmane-spam-header
+ "^X-Report-Spam: http://\\([^/]+\\)\\(.*\\)$"
+ "String matching Gmane spam-reporting header. Two match groups are needed."
+ :type 'regexp
+ :group 'spam-report)
+
+(defcustom spam-report-gmane-use-article-number t
+ "Whether the article number (faster!) or the header should be used."
+ :type 'boolean
+ :group 'spam-report)
+
+(defun spam-report-gmane (article)
+ "Report an article as spam through Gmane"
+ (interactive "nEnter the article number: ")
+ (when (and gnus-newsgroup-name
+ (or (null spam-report-gmane-regex)
+ (string-match spam-report-gmane-regex gnus-newsgroup-name)))
+ (gnus-message 6 "Reporting spam article %d to spam.gmane.org..." article)
+ (if spam-report-gmane-use-article-number
+ (spam-report-url-ping "spam.gmane.org"
+ (format "/%s:%d"
+ (gnus-group-real-name gnus-newsgroup-name)
+ article))
+ (with-current-buffer nntp-server-buffer
+ (gnus-request-head article gnus-newsgroup-name)
+ (goto-char (point-min))
+ (if (re-search-forward spam-report-gmane-spam-header nil t)
+ (let* ((host (match-string 1))
+ (report (match-string 2))
+ (url (format "http://%s%s" host report)))
+ (gnus-message 10 "Reporting spam through URL %s..." url)
+ (spam-report-url-ping host report))
+ (gnus-message 10 "Could not find X-Report-Spam in article %d..."
+ article))))))
+
+
+(defun spam-report-url-ping (host report)
+ "Ping a host through HTTP, addressing a specific GET resource"
+ (let ((tcp-connection))
+ (with-temp-buffer
+ (or (setq tcp-connection
+ (open-network-stream
+ "URL ping"
+ (buffer-name)
+ host
+ 80))
+ (error "Could not open connection to %s" host))
+ (set-marker (process-mark tcp-connection) (point-min))
+ (process-send-string tcp-connection
+ (format "GET %s HTTP/1.1\nHost: %s\n\n"
+ report host)))))
+
+(provide 'spam-report)
+
+;;; spam-report.el ends here.
--- /dev/null
+;;; spam-stat.el --- detecting spam based on statistics
+
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Alex Schroeder <alex@gnu.org>
+;; Keywords: network
+;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SpamStat
+
+;; This file is part of GNU Emacs.
+
+;; This 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.
+
+;; This 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 implements spam analysis according to Paul Graham in "A Plan
+;; for Spam". The basis for all this is a statistical distribution of
+;; words for your spam and non-spam mails. We need this information
+;; in a hash-table so that the analysis can use the information when
+;; looking at your mails. Therefore, before you begin, you need tons
+;; of mails (Graham uses 4000 non-spam and 4000 spam mails for his
+;; experiments).
+;;
+;; The main interface to using spam-stat, are the following functions:
+;;
+;; `spam-stat-buffer-is-spam' -- called in a buffer, that buffer is
+;; considered to be a new spam mail; use this for new mail that has
+;; not been processed before
+;;
+;; `spam-stat-buffer-is-non-spam' -- called in a buffer, that buffer
+;; is considered to be a new non-spam mail; use this for new mail that
+;; has not been processed before
+;;
+;; `spam-stat-buffer-change-to-spam' -- called in a buffer, that
+;; buffer is no longer considered to be normal mail but spam; use this
+;; to change the status of a mail that has already been processed as
+;; non-spam
+;;
+;; `spam-stat-buffer-change-to-non-spam' -- called in a buffer, that
+;; buffer is no longer considered to be spam but normal mail; use this
+;; to change the status of a mail that has already been processed as
+;; spam
+;;
+;; `spam-stat-save' -- save the hash table to the file; the filename
+;; used is stored in the variable `spam-stat-file'
+;;
+;; `spam-stat-load' -- load the hash table from a file; the filename
+;; used is stored in the variable `spam-stat-file'
+;;
+;; `spam-stat-score-word' -- return the spam score for a word
+;;
+;; `spam-stat-score-buffer' -- return the spam score for a buffer
+;;
+;; `spam-stat-split-fancy' -- for fancy mail splitting; add
+;; the rule (: spam-stat-split-fancy) to `nnmail-split-fancy'
+;;
+;; This requires the following in your ~/.gnus file:
+;;
+;; (require 'spam-stat)
+;; (spam-stat-load)
+
+;;; Testing:
+
+;; Typical test will involve calls to the following functions:
+;;
+;; Reset: (spam-stat-reset)
+;; Learn spam: (spam-stat-process-spam-directory "~/Mail/mail/spam")
+;; Learn non-spam: (spam-stat-process-non-spam-directory "~/Mail/mail/misc")
+;; Save table: (spam-stat-save)
+;; File size: (nth 7 (file-attributes spam-stat-file))
+;; Number of words: (hash-table-count spam-stat)
+;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam")
+;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc")
+;; Reduce table size: (spam-stat-reduce-size)
+;; Save table: (spam-stat-save)
+;; File size: (nth 7 (file-attributes spam-stat-file))
+;; Number of words: (hash-table-count spam-stat)
+;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam")
+;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc")
+
+;;; Dictionary Creation:
+
+;; Typically, you will filter away mailing lists etc. using specific
+;; rules in `nnmail-split-fancy'. Somewhere among these rules, you
+;; will filter spam. Here is how you would create your dictionary:
+
+;; Reset: (spam-stat-reset)
+;; Learn spam: (spam-stat-process-spam-directory "~/Mail/mail/spam")
+;; Learn non-spam: (spam-stat-process-non-spam-directory "~/Mail/mail/misc")
+;; Repeat for any other non-spam group you need...
+;; Reduce table size: (spam-stat-reduce-size)
+;; Save table: (spam-stat-save)
+
+;;; Todo:
+
+;; Speed it up. Integrate with Gnus such that it uses spam and expiry
+;; marks to call the appropriate functions when leaving the summary
+;; buffer and saves the hash table when leaving Gnus. More testing:
+;; More mails, disabling SpamAssassin, double checking algorithm, find
+;; improved algorithm.
+
+;;; Thanks:
+
+;; Ted Zlatanov <tzz@lifelogs.com>
+;; Jesper Harder <harder@myrealbox.com>
+;; Dan Schmidt <dfan@dfan.org>
+;; Lasse Rasinen <lrasinen@iki.fi>
+;; Milan Zamazal <pdm@zamazal.org>
+
+\f
+
+;;; Code:
+
+(defgroup spam-stat nil
+ "Statistical spam detection for Emacs.
+Use the functions to build a dictionary of words and their statistical
+distribution in spam and non-spam mails. Then use a function to determine
+whether a buffer contains spam or not."
+ :group 'gnus)
+
+(defcustom spam-stat-file "~/.spam-stat.el"
+ "File used to save and load the dictionary.
+See `spam-stat-to-hash-table' for the format of the file."
+ :type 'file
+ :group 'spam-stat)
+
+(defcustom spam-stat-install-hooks t
+ "Whether spam-stat should install its hooks in Gnus.
+This is set to nil if you use spam-stat through spam.el."
+ :type 'boolean
+ :group 'spam-stat)
+
+(defcustom spam-stat-unknown-word-score 0.2
+ "The score to use for unknown words.
+Also used for words that don't appear often enough."
+ :type 'number
+ :group 'spam-stat)
+
+(defcustom spam-stat-max-word-length 15
+ "Only words shorter than this will be considered."
+ :type 'integer
+ :group 'spam-stat)
+
+(defcustom spam-stat-max-buffer-length 10240
+ "Only the beginning of buffers will be analyzed.
+This variable says how many characters this will be."
+ :type 'integer
+ :group 'spam-stat)
+
+(defcustom spam-stat-split-fancy-spam-group "mail.spam"
+ "Name of the group where spam should be stored, if
+`spam-stat-split-fancy' is used in fancy splitting rules. Has no
+effect when spam-stat is invoked through spam.el."
+ :type 'string
+ :group 'spam-stat)
+
+(defcustom spam-stat-split-fancy-spam-threshhold 0.9
+ "Spam score threshhold in spam-stat-split-fancy."
+ :type 'number
+ :group 'spam-stat)
+
+(defvar spam-stat-syntax-table
+ (let ((table (copy-syntax-table text-mode-syntax-table)))
+ (modify-syntax-entry ?- "w" table)
+ (modify-syntax-entry ?_ "w" table)
+ (modify-syntax-entry ?. "w" table)
+ (modify-syntax-entry ?! "w" table)
+ (modify-syntax-entry ?? "w" table)
+ (modify-syntax-entry ?+ "w" table)
+ table)
+ "Syntax table used when processing mails for statistical analysis.
+The important part is which characters are word constituents.")
+
+(defvar spam-stat-buffer nil
+ "Buffer to use for scoring while splitting.
+This is set by hooking into Gnus.")
+
+(defvar spam-stat-buffer-name " *spam stat buffer*"
+ "Name of the `spam-stat-buffer'.")
+
+;; Functions missing in Emacs 20
+
+(when (memq nil (mapcar 'fboundp
+ '(gethash hash-table-count make-hash-table
+ mapc puthash)))
+ (require 'cl)
+ (unless (fboundp 'puthash)
+ ;; alias puthash is missing from Emacs 20 cl-extra.el
+ (defalias 'puthash 'cl-puthash)))
+
+(eval-when-compile
+ (unless (fboundp 'with-syntax-table)
+ ;; Imported from Emacs 21.2
+ (defmacro with-syntax-table (table &rest body) "\
+Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
+The syntax table of the current buffer is saved, BODY is evaluated, and the
+saved table is restored, even in case of an abnormal exit.
+Value is what BODY returns."
+ (let ((old-table (make-symbol "table"))
+ (old-buffer (make-symbol "buffer")))
+ `(let ((,old-table (syntax-table))
+ (,old-buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-syntax-table (copy-syntax-table ,table))
+ ,@body)
+ (save-current-buffer
+ (set-buffer ,old-buffer)
+ (set-syntax-table ,old-table))))))))
+
+;; Hooking into Gnus
+
+(defun spam-stat-store-current-buffer ()
+ "Store a copy of the current buffer in `spam-stat-buffer'."
+ (save-excursion
+ (let ((str (buffer-string)))
+ (set-buffer (get-buffer-create spam-stat-buffer-name))
+ (erase-buffer)
+ (insert str)
+ (setq spam-stat-buffer (current-buffer)))))
+
+(defun spam-stat-store-gnus-article-buffer ()
+ "Store a copy of the current article in `spam-stat-buffer'.
+This uses `gnus-article-buffer'."
+ (save-excursion
+ (set-buffer gnus-original-article-buffer)
+ (spam-stat-store-current-buffer)))
+
+(when spam-stat-install-hooks
+ (add-hook 'nnmail-prepare-incoming-message-hook
+ 'spam-stat-store-current-buffer)
+ (add-hook 'gnus-select-article-hook
+ 'spam-stat-store-gnus-article-buffer))
+
+;; Data -- not using defstruct in order to save space and time
+
+(defvar spam-stat (make-hash-table :test 'equal)
+ "Hash table used to store the statistics.
+Use `spam-stat-load' to load the file.
+Every word is used as a key in this table. The value is a vector.
+Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good',
+`spam-stat-bad', and `spam-stat-score' to access this vector.")
+
+(defvar spam-stat-ngood 0
+ "The number of good mails in the dictionary.")
+
+(defvar spam-stat-nbad 0
+ "The number of bad mails in the dictionary.")
+
+(defsubst spam-stat-good (entry)
+ "Return the number of times this word belongs to good mails."
+ (aref entry 0))
+
+(defsubst spam-stat-bad (entry)
+ "Return the number of times this word belongs to bad mails."
+ (aref entry 1))
+
+(defsubst spam-stat-score (entry)
+ "Set the score of this word."
+ (if entry
+ (aref entry 2)
+ spam-stat-unknown-word-score))
+
+(defsubst spam-stat-set-good (entry value)
+ "Set the number of times this word belongs to good mails."
+ (aset entry 0 value))
+
+(defsubst spam-stat-set-bad (entry value)
+ "Set the number of times this word belongs to bad mails."
+ (aset entry 1 value))
+
+(defsubst spam-stat-set-score (entry value)
+ "Set the score of this word."
+ (aset entry 2 value))
+
+(defsubst spam-stat-make-entry (good bad)
+ "Return a vector with the given properties."
+ (let ((entry (vector good bad nil)))
+ (spam-stat-set-score entry (spam-stat-compute-score entry))
+ entry))
+
+;; Computing
+
+(defun spam-stat-compute-score (entry)
+ "Compute the score of this word. 1.0 means spam."
+ ;; promote all numbers to floats for the divisions
+ (let* ((g (* 2.0 (spam-stat-good entry)))
+ (b (float (spam-stat-bad entry))))
+ (cond ((< (+ g b) 5)
+ .2)
+ ((= 0 spam-stat-ngood)
+ .99)
+ ((= 0 spam-stat-nbad)
+ .01)
+ (t
+ (max .01
+ (min .99 (/ (/ b spam-stat-nbad)
+ (+ (/ g spam-stat-ngood)
+ (/ b spam-stat-nbad)))))))))
+
+;; Parsing
+
+(defmacro with-spam-stat-max-buffer-size (&rest body)
+ "Narrows the buffer down to the first 4k characters, then evaluates BODY."
+ `(save-restriction
+ (when (> (- (point-max)
+ (point-min))
+ spam-stat-max-buffer-length)
+ (narrow-to-region (point-min)
+ (+ (point-min) spam-stat-max-buffer-length)))
+ ,@body))
+
+(defun spam-stat-buffer-words ()
+ "Return a hash table of words and number of occurences in the buffer."
+ (with-spam-stat-max-buffer-size
+ (with-syntax-table spam-stat-syntax-table
+ (goto-char (point-min))
+ (let ((result (make-hash-table :test 'equal))
+ word count)
+ (while (re-search-forward "\\w+" nil t)
+ (setq word (match-string-no-properties 0)
+ count (1+ (gethash word result 0)))
+ (when (< (length word) spam-stat-max-word-length)
+ (puthash word count result)))
+ result))))
+
+(defun spam-stat-buffer-is-spam ()
+ "Consider current buffer to be a new spam mail."
+ (setq spam-stat-nbad (1+ spam-stat-nbad))
+ (maphash
+ (lambda (word count)
+ (let ((entry (gethash word spam-stat)))
+ (if entry
+ (spam-stat-set-bad entry (+ count (spam-stat-bad entry)))
+ (setq entry (spam-stat-make-entry 0 count)))
+ (spam-stat-set-score entry (spam-stat-compute-score entry))
+ (puthash word entry spam-stat)))
+ (spam-stat-buffer-words)))
+
+(defun spam-stat-buffer-is-non-spam ()
+ "Consider current buffer to be a new non-spam mail."
+ (setq spam-stat-ngood (1+ spam-stat-ngood))
+ (maphash
+ (lambda (word count)
+ (let ((entry (gethash word spam-stat)))
+ (if entry
+ (spam-stat-set-good entry (+ count (spam-stat-good entry)))
+ (setq entry (spam-stat-make-entry count 0)))
+ (spam-stat-set-score entry (spam-stat-compute-score entry))
+ (puthash word entry spam-stat)))
+ (spam-stat-buffer-words)))
+
+(defun spam-stat-buffer-change-to-spam ()
+ "Consider current buffer no longer normal mail but spam."
+ (setq spam-stat-nbad (1+ spam-stat-nbad)
+ spam-stat-ngood (1- spam-stat-ngood))
+ (maphash
+ (lambda (word count)
+ (let ((entry (gethash word spam-stat)))
+ (if (not entry)
+ (error "This buffer has unknown words in it.")
+ (spam-stat-set-good entry (- (spam-stat-good entry) count))
+ (spam-stat-set-bad entry (+ (spam-stat-bad entry) count))
+ (spam-stat-set-score entry (spam-stat-compute-score entry))
+ (puthash word entry spam-stat))))
+ (spam-stat-buffer-words)))
+
+(defun spam-stat-buffer-change-to-non-spam ()
+ "Consider current buffer no longer spam but normal mail."
+ (setq spam-stat-nbad (1- spam-stat-nbad)
+ spam-stat-ngood (1+ spam-stat-ngood))
+ (maphash
+ (lambda (word count)
+ (let ((entry (gethash word spam-stat)))
+ (if (not entry)
+ (error "This buffer has unknown words in it.")
+ (spam-stat-set-good entry (+ (spam-stat-good entry) count))
+ (spam-stat-set-bad entry (- (spam-stat-bad entry) count))
+ (spam-stat-set-score entry (spam-stat-compute-score entry))
+ (puthash word entry spam-stat))))
+ (spam-stat-buffer-words)))
+
+;; Saving and Loading
+
+(defun spam-stat-save ()
+ "Save the `spam-stat' hash table as lisp file."
+ (interactive)
+ (with-temp-buffer
+ (let ((standard-output (current-buffer))
+ (font-lock-maximum-size 0))
+ (insert "(setq spam-stat-ngood "
+ (number-to-string spam-stat-ngood)
+ " spam-stat-nbad "
+ (number-to-string spam-stat-nbad)
+ " spam-stat (spam-stat-to-hash-table '(")
+ (maphash (lambda (word entry)
+ (prin1 (list word
+ (spam-stat-good entry)
+ (spam-stat-bad entry))))
+ spam-stat)
+ (insert ")))")
+ (write-file spam-stat-file))))
+
+(defun spam-stat-load ()
+ "Read the `spam-stat' hash table from disk."
+ (load-file spam-stat-file))
+
+(defun spam-stat-to-hash-table (entries)
+ "Turn list ENTRIES into a hash table and store as `spam-stat'.
+Every element in ENTRIES has the form \(WORD GOOD BAD) where WORD is
+the word string, NGOOD is the number of good mails it has appeared in,
+NBAD is the number of bad mails it has appeared in, GOOD is the number
+of times it appeared in good mails, and BAD is the number of times it
+has appeared in bad mails."
+ (let ((table (make-hash-table :test 'equal)))
+ (mapc (lambda (l)
+ (puthash (car l)
+ (spam-stat-make-entry (nth 1 l) (nth 2 l))
+ table))
+ entries)
+ table))
+
+(defun spam-stat-reset ()
+ "Reset `spam-stat' to an empty hash-table.
+This deletes all the statistics."
+ (interactive)
+ (setq spam-stat (make-hash-table :test 'equal)
+ spam-stat-ngood 0
+ spam-stat-nbad 0))
+
+;; Scoring buffers
+
+(defvar spam-stat-score-data nil
+ "Raw data used in the last run of `spam-stat-score-buffer'.")
+
+(defsubst spam-stat-score-word (word)
+ "Return score for WORD.
+The default score for unknown words is stored in
+`spam-stat-unknown-word-score'."
+ (spam-stat-score (gethash word spam-stat)))
+
+(defun spam-stat-buffer-words-with-scores ()
+ "Process current buffer, return the 15 most conspicuous words.
+These are the words whose spam-stat differs the most from 0.5.
+The list returned contains elements of the form \(WORD SCORE DIFF),
+where DIFF is the difference between SCORE and 0.5."
+ (with-spam-stat-max-buffer-size
+ (with-syntax-table spam-stat-syntax-table
+ (let (result word score)
+ (maphash (lambda (word ignore)
+ (setq score (spam-stat-score-word word)
+ result (cons (list word score (abs (- score 0.5)))
+ result)))
+ (spam-stat-buffer-words))
+ (setq result (sort result (lambda (a b) (< (nth 2 b) (nth 2 a)))))
+ (setcdr (nthcdr 14 result) nil)
+ result))))
+
+(defun spam-stat-score-buffer ()
+ "Return a score describing the spam-probability for this buffer."
+ (setq spam-stat-score-data (spam-stat-buffer-words-with-scores))
+ (let* ((probs (mapcar (lambda (e) (cadr e)) spam-stat-score-data))
+ (prod (apply #'* probs)))
+ (/ prod (+ prod (apply #'* (mapcar #'(lambda (x) (- 1 x))
+ probs))))))
+
+(defun spam-stat-split-fancy ()
+ "Return the name of the spam group if the current mail is spam.
+Use this function on `nnmail-split-fancy'. If you are interested in
+the raw data used for the last run of `spam-stat-score-buffer',
+check the variable `spam-stat-score-data'."
+ (condition-case var
+ (progn
+ (set-buffer spam-stat-buffer)
+ (goto-char (point-min))
+ (when (> (spam-stat-score-buffer) spam-stat-split-fancy-spam-threshhold)
+ (when (boundp 'nnmail-split-trace)
+ (mapc (lambda (entry)
+ (push entry nnmail-split-trace))
+ spam-stat-score-data))
+ spam-stat-split-fancy-spam-group))
+ (error (message "Error in spam-stat-split-fancy: %S" var)
+ nil)))
+
+;; Testing
+
+(defun spam-stat-process-directory (dir func)
+ "Process all the regular files in directory DIR using function FUNC."
+ (let* ((files (directory-files dir t "^[^.]"))
+ (max (/ (length files) 100.0))
+ (count 0))
+ (with-temp-buffer
+ (dolist (f files)
+ (when (and (file-readable-p f)
+ (file-regular-p f)
+ (> (nth 7 (file-attributes f)) 0))
+ (setq count (1+ count))
+ (message "Reading %s: %.2f%%" dir (/ count max))
+ (insert-file-contents f)
+ (funcall func)
+ (erase-buffer))))))
+
+(defun spam-stat-process-spam-directory (dir)
+ "Process all the regular files in directory DIR as spam."
+ (interactive "D")
+ (spam-stat-process-directory dir 'spam-stat-buffer-is-spam))
+
+(defun spam-stat-process-non-spam-directory (dir)
+ "Process all the regular files in directory DIR as non-spam."
+ (interactive "D")
+ (spam-stat-process-directory dir 'spam-stat-buffer-is-non-spam))
+
+(defun spam-stat-count ()
+ "Return size of `spam-stat'."
+ (interactive)
+ (hash-table-count spam-stat))
+
+(defun spam-stat-test-directory (dir)
+ "Test all the regular files in directory DIR for spam.
+If the result is 1.0, then all files are considered spam.
+If the result is 0.0, non of the files is considered spam.
+You can use this to determine error rates."
+ (interactive "D")
+ (let* ((files (directory-files dir t "^[^.]"))
+ (total (length files))
+ (score 0.0); float
+ (max (/ total 100.0)); float
+ (count 0))
+ (with-temp-buffer
+ (dolist (f files)
+ (when (and (file-readable-p f)
+ (file-regular-p f)
+ (> (nth 7 (file-attributes f)) 0))
+ (setq count (1+ count))
+ (message "Reading %.2f%%, score %.2f%%"
+ (/ count max) (/ score count))
+ (insert-file-contents f)
+ (when (> (spam-stat-score-buffer) 0.9)
+ (setq score (1+ score)))
+ (erase-buffer))))
+ (message "Final score: %d / %d = %f" score total (/ score total))))
+
+;; Shrinking the dictionary
+
+(defun spam-stat-reduce-size (&optional count)
+ "Reduce the size of `spam-stat'.
+This removes all words that occur less than COUNT from the dictionary.
+COUNT defaults to 5"
+ (interactive)
+ (setq count (or count 5))
+ (maphash (lambda (key entry)
+ (when (< (+ (spam-stat-good entry)
+ (spam-stat-bad entry))
+ count)
+ (remhash key spam-stat)))
+ spam-stat))
+
+(provide 'spam-stat)
+
+;;; spam-stat.el ends here
--- /dev/null
+;;; spam.el --- Identifying spam
+;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: network
+
+;; 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 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 module addresses a few aspects of spam control under Gnus. Page
+;;; breaks are used for grouping declarations and documentation relating to
+;;; each particular aspect.
+
+;;; The integration with Gnus is not yet complete. See various `FIXME'
+;;; comments, below, for supplementary explanations or discussions.
+
+;;; Several TODO items are marked as such
+
+;;; Code:
+
+(require 'path-util)
+
+(eval-when-compile (require 'cl))
+
+(require 'gnus-sum)
+
+(require 'gnus-uu) ; because of key prefix issues
+(require 'gnus) ; for the definitions of group content classification and spam processors
+(require 'message) ;for the message-fetch-field functions
+
+;; for nnimap-split-download-body-default
+(eval-when-compile (require 'nnimap))
+
+;; autoload query-dig
+(eval-and-compile
+ (autoload 'query-dig "dig"))
+
+;; autoload spam-report
+(eval-and-compile
+ (autoload 'spam-report-gmane "spam-report"))
+
+;; autoload query-dns
+(eval-and-compile
+ (autoload 'query-dns "dns"))
+
+;;; Main parameters.
+
+(defgroup spam nil
+ "Spam configuration.")
+
+(defcustom spam-directory "~/News/spam/"
+ "Directory for spam whitelists and blacklists."
+ :type 'directory
+ :group 'spam)
+
+(defcustom spam-move-spam-nonspam-groups-only t
+ "Whether spam should be moved in non-spam groups only.
+When nil, only ham and unclassified groups will have their spam moved
+to the spam-process-destination. When t, spam will also be moved from
+spam groups."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-mark-only-unseen-as-spam t
+ "Whether only unseen articles should be marked as spam in spam
+groups. When nil, all unread articles in a spam group are marked as
+spam. Set this if you want to leave an article unread in a spam group
+without losing it to the automatic spam-marking process."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-mark-ham-unread-before-move-from-spam-group nil
+ "Whether ham should be marked unread before it's moved out of a spam
+group according to ham-process-destination. This variable is an
+official entry in the international Longest Variable Name
+Competition."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-whitelist (expand-file-name "whitelist" spam-directory)
+ "The location of the whitelist.
+The file format is one regular expression per line.
+The regular expression is matched against the address."
+ :type 'file
+ :group 'spam)
+
+(defcustom spam-blacklist (expand-file-name "blacklist" spam-directory)
+ "The location of the blacklist.
+The file format is one regular expression per line.
+The regular expression is matched against the address."
+ :type 'file
+ :group 'spam)
+
+(defcustom spam-use-dig t
+ "Whether query-dig should be used instead of query-dns."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-blacklist nil
+ "Whether the blacklist should be used by spam-split."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-whitelist nil
+ "Whether the whitelist should be used by spam-split."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-whitelist-exclusive nil
+ "Whether whitelist-exclusive should be used by spam-split.
+Exclusive whitelisting means that all messages from senders not in the whitelist
+are considered spam."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-blackholes nil
+ "Whether blackholes should be used by spam-split."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-hashcash nil
+ "Whether hashcash payments should be detected by spam-split."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-regex-headers nil
+ "Whether a header regular expression match should be used by spam-split.
+Also see the variable `spam-spam-regex-headers' and `spam-ham-regex-headers'."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-bogofilter-headers nil
+ "Whether bogofilter headers should be used by spam-split.
+Enable this if you pre-process messages with Bogofilter BEFORE Gnus sees them."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-bogofilter nil
+ "Whether bogofilter should be invoked by spam-split.
+Enable this if you want Gnus to invoke Bogofilter on new messages."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-BBDB nil
+ "Whether BBDB should be used by spam-split."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-BBDB-exclusive nil
+ "Whether BBDB-exclusive should be used by spam-split.
+Exclusive BBDB means that all messages from senders not in the BBDB are
+considered spam."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-ifile nil
+ "Whether ifile should be used by spam-split."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-use-stat nil
+ "Whether spam-stat should be used by spam-split."
+ :type 'boolean
+ :group 'spam)
+
+(defcustom spam-split-group "spam"
+ "Group name where incoming spam should be put by spam-split."
+ :type 'string
+ :group 'spam)
+
+(defcustom spam-junk-mailgroups (cons spam-split-group '("mail.junk" "poste.pourriel"))
+ "Mailgroups with spam contents.
+All unmarked article in such group receive the spam mark on group entry."
+ :type '(repeat (string :tag "Group"))
+ :group 'spam)
+
+(defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org"
+ "dev.null.dk" "relays.visi.com")
+ "List of blackhole servers."
+ :type '(repeat (string :tag "Server"))
+ :group 'spam)
+
+(defcustom spam-blackhole-good-server-regex nil
+ "String matching IP addresses that should not be checked in the blackholes"
+ :type 'regexp
+ :group 'spam)
+
+(defcustom spam-face 'gnus-splash-face
+ "Face for spam-marked articles"
+ :type 'face
+ :group 'spam)
+
+(defcustom spam-regex-headers-spam '("^X-Spam-Flag: YES")
+ "Regular expression for positive header spam matches"
+ :type '(repeat (regexp :tag "Regular expression to match spam header"))
+ :group 'spam)
+
+(defcustom spam-regex-headers-ham '("^X-Spam-Flag: NO")
+ "Regular expression for positive header ham matches"
+ :type '(repeat (regexp :tag "Regular expression to match ham header"))
+ :group 'spam)
+
+(defgroup spam-ifile nil
+ "Spam ifile configuration."
+ :group 'spam)
+
+(defcustom spam-ifile-path (exec-installed-p "ifile")
+ "File path of the ifile executable program."
+ :type '(choice (file :tag "Location of ifile")
+ (const :tag "ifile is not installed"))
+ :group 'spam-ifile)
+
+(defcustom spam-ifile-database-path nil
+ "File path of the ifile database."
+ :type '(choice (file :tag "Location of the ifile database")
+ (const :tag "Use the default"))
+ :group 'spam-ifile)
+
+(defcustom spam-ifile-spam-category "spam"
+ "Name of the spam ifile category."
+ :type 'string
+ :group 'spam-ifile)
+
+(defcustom spam-ifile-ham-category nil
+ "Name of the ham ifile category. If nil, the current group name will
+be used."
+ :type '(choice (string :tag "Use a fixed category")
+ (const :tag "Use the current group name"))
+ :group 'spam-ifile)
+
+(defcustom spam-ifile-all-categories nil
+ "Whether the ifile check will return all categories, or just spam.
+Set this to t if you want to use the spam-split invocation of ifile as
+your main source of newsgroup names."
+ :type 'boolean
+ :group 'spam-ifile)
+
+(defgroup spam-bogofilter nil
+ "Spam bogofilter configuration."
+ :group 'spam)
+
+(defcustom spam-bogofilter-path (exec-installed-p "bogofilter")
+ "File path of the Bogofilter executable program."
+ :type '(choice (file :tag "Location of bogofilter")
+ (const :tag "Bogofilter is not installed"))
+ :group 'spam-bogofilter)
+
+(defcustom spam-bogofilter-header "X-Bogosity"
+ "The header that Bogofilter inserts in messages."
+ :type 'string
+ :group 'spam-bogofilter)
+
+(defcustom spam-bogofilter-spam-switch "-s"
+ "The switch that Bogofilter uses to register spam messages."
+ :type 'string
+ :group 'spam-bogofilter)
+
+(defcustom spam-bogofilter-ham-switch "-n"
+ "The switch that Bogofilter uses to register ham messages."
+ :type 'string
+ :group 'spam-bogofilter)
+
+(defcustom spam-bogofilter-bogosity-positive-spam-header "^\\(Yes\\|Spam\\)"
+ "The regex on `spam-bogofilter-header' for positive spam identification."
+ :type 'regexp
+ :group 'spam-bogofilter)
+
+(defcustom spam-bogofilter-database-directory nil
+ "Directory path of the Bogofilter databases."
+ :type '(choice (directory :tag "Location of the Bogofilter database directory")
+ (const :tag "Use the default"))
+ :group 'spam-ifile)
+
+;;; Key bindings for spam control.
+
+(gnus-define-keys gnus-summary-mode-map
+ "St" spam-bogofilter-score
+ "Sx" gnus-summary-mark-as-spam
+ "Mst" spam-bogofilter-score
+ "Msx" gnus-summary-mark-as-spam
+ "\M-d" gnus-summary-mark-as-spam)
+
+;;; How to highlight a spam summary line.
+
+;; TODO: How do we redo this every time spam-face is customized?
+
+(push '((eq mark gnus-spam-mark) . spam-face)
+ gnus-summary-highlight)
+
+;; convenience functions
+(defun spam-group-ham-mark-p (group mark &optional spam)
+ (when (stringp group)
+ (let* ((marks (spam-group-ham-marks group spam))
+ (marks (if (symbolp mark)
+ marks
+ (mapcar 'symbol-value marks))))
+ (memq mark marks))))
+
+(defun spam-group-spam-mark-p (group mark)
+ (spam-group-ham-mark-p group mark t))
+
+(defun spam-group-ham-marks (group &optional spam)
+ (when (stringp group)
+ (let* ((marks (if spam
+ (gnus-parameter-spam-marks group)
+ (gnus-parameter-ham-marks group)))
+ (marks (car marks))
+ (marks (if (listp (car marks)) (car marks) marks)))
+ marks)))
+
+(defun spam-group-spam-marks (group)
+ (spam-group-ham-marks group t))
+
+(defun spam-group-spam-contents-p (group)
+ (if (stringp group)
+ (or (member group spam-junk-mailgroups)
+ (memq 'gnus-group-spam-classification-spam
+ (gnus-parameter-spam-contents group)))
+ nil))
+
+(defun spam-group-ham-contents-p (group)
+ (if (stringp group)
+ (memq 'gnus-group-spam-classification-ham
+ (gnus-parameter-spam-contents group))
+ nil))
+
+(defun spam-group-processor-p (group processor)
+ (if (and (stringp group)
+ (symbolp processor))
+ (member processor (car (gnus-parameter-spam-process group)))
+ nil))
+
+(defun spam-group-spam-processor-report-gmane-p (group)
+ (spam-group-processor-p group 'gnus-group-spam-exit-processor-report-gmane))
+
+(defun spam-group-spam-processor-bogofilter-p (group)
+ (spam-group-processor-p group 'gnus-group-spam-exit-processor-bogofilter))
+
+(defun spam-group-spam-processor-blacklist-p (group)
+ (spam-group-processor-p group 'gnus-group-spam-exit-processor-blacklist))
+
+(defun spam-group-spam-processor-ifile-p (group)
+ (spam-group-processor-p group 'gnus-group-spam-exit-processor-ifile))
+
+(defun spam-group-ham-processor-ifile-p (group)
+ (spam-group-processor-p group 'gnus-group-ham-exit-processor-ifile))
+
+(defun spam-group-ham-processor-bogofilter-p (group)
+ (spam-group-processor-p group 'gnus-group-ham-exit-processor-bogofilter))
+
+(defun spam-group-spam-processor-stat-p (group)
+ (spam-group-processor-p group 'gnus-group-spam-exit-processor-stat))
+
+(defun spam-group-ham-processor-stat-p (group)
+ (spam-group-processor-p group 'gnus-group-ham-exit-processor-stat))
+
+(defun spam-group-ham-processor-whitelist-p (group)
+ (spam-group-processor-p group 'gnus-group-ham-exit-processor-whitelist))
+
+(defun spam-group-ham-processor-BBDB-p (group)
+ (spam-group-processor-p group 'gnus-group-ham-exit-processor-BBDB))
+
+(defun spam-group-ham-processor-copy-p (group)
+ (spam-group-processor-p group 'gnus-group-ham-exit-processor-copy))
+
+;;; Summary entry and exit processing.
+
+(defun spam-summary-prepare ()
+ (spam-mark-junk-as-spam-routine))
+
+(add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
+
+;; The spam processors are invoked for any group, spam or ham or neither
+(defun spam-summary-prepare-exit ()
+ (unless gnus-group-is-exiting-without-update-p
+ (gnus-message 6 "Exiting summary buffer and applying spam rules")
+ (when (and spam-bogofilter-path
+ (spam-group-spam-processor-bogofilter-p gnus-newsgroup-name))
+ (gnus-message 5 "Registering spam with bogofilter")
+ (spam-bogofilter-register-spam-routine))
+
+ (when (and spam-ifile-path
+ (spam-group-spam-processor-ifile-p gnus-newsgroup-name))
+ (gnus-message 5 "Registering spam with ifile")
+ (spam-ifile-register-spam-routine))
+
+ (when (spam-group-spam-processor-stat-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering spam with spam-stat")
+ (spam-stat-register-spam-routine))
+
+ (when (spam-group-spam-processor-blacklist-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering spam with the blacklist")
+ (spam-blacklist-register-routine))
+
+ (when (spam-group-spam-processor-report-gmane-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering spam with the Gmane report")
+ (spam-report-gmane-register-routine))
+
+ (if spam-move-spam-nonspam-groups-only
+ (when (not (spam-group-spam-contents-p gnus-newsgroup-name))
+ (spam-mark-spam-as-expired-and-move-routine
+ (gnus-parameter-spam-process-destination gnus-newsgroup-name)))
+ (gnus-message 5 "Marking spam as expired and moving it to %s" gnus-newsgroup-name)
+ (spam-mark-spam-as-expired-and-move-routine
+ (gnus-parameter-spam-process-destination gnus-newsgroup-name)))
+
+ ;; now we redo spam-mark-spam-as-expired-and-move-routine to only
+ ;; expire spam, in case the above did not expire them
+ (gnus-message 5 "Marking spam as expired without moving it")
+ (spam-mark-spam-as-expired-and-move-routine nil)
+
+ (when (spam-group-ham-contents-p gnus-newsgroup-name)
+ (when (spam-group-ham-processor-whitelist-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering ham with the whitelist")
+ (spam-whitelist-register-routine))
+ (when (spam-group-ham-processor-ifile-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering ham with ifile")
+ (spam-ifile-register-ham-routine))
+ (when (spam-group-ham-processor-bogofilter-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering ham with Bogofilter")
+ (spam-bogofilter-register-ham-routine))
+ (when (spam-group-ham-processor-stat-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering ham with spam-stat")
+ (spam-stat-register-ham-routine))
+ (when (spam-group-ham-processor-BBDB-p gnus-newsgroup-name)
+ (gnus-message 5 "Registering ham with the BBDB")
+ (spam-BBDB-register-routine)))
+
+ (when (spam-group-ham-processor-copy-p gnus-newsgroup-name)
+ (gnus-message 5 "Copying ham")
+ (spam-ham-move-routine
+ (gnus-parameter-ham-process-destination gnus-newsgroup-name) t))
+
+ ;; now move all ham articles out of spam groups
+ (when (spam-group-spam-contents-p gnus-newsgroup-name)
+ (gnus-message 5 "Moving ham messages from spam group")
+ (spam-ham-move-routine
+ (gnus-parameter-ham-process-destination gnus-newsgroup-name)))))
+
+(add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
+
+(defun spam-mark-junk-as-spam-routine ()
+ ;; check the global list of group names spam-junk-mailgroups and the
+ ;; group parameters
+ (when (spam-group-spam-contents-p gnus-newsgroup-name)
+ (gnus-message 5 "Marking %s articles as spam"
+ (if spam-mark-only-unseen-as-spam
+ "unseen"
+ "unread"))
+ (let ((articles (if spam-mark-only-unseen-as-spam
+ gnus-newsgroup-unseen
+ gnus-newsgroup-unreads)))
+ (dolist (article articles)
+ (gnus-summary-mark-article article gnus-spam-mark)))))
+
+(defun spam-mark-spam-as-expired-and-move-routine (&optional group)
+ (gnus-summary-kill-process-mark)
+ (let ((articles gnus-newsgroup-articles)
+ article tomove)
+ (dolist (article articles)
+ (when (eq (gnus-summary-article-mark article) gnus-spam-mark)
+ (gnus-summary-mark-article article gnus-expirable-mark)
+ (push article tomove)))
+
+ ;; now do the actual move
+ (when (and tomove
+ (stringp group))
+ (dolist (article tomove)
+ (gnus-summary-set-process-mark article))
+ (when tomove (gnus-summary-move-article nil group))))
+ (gnus-summary-yank-process-mark))
+
+(defun spam-ham-move-routine (&optional group copy)
+ (gnus-summary-kill-process-mark)
+ (let ((articles gnus-newsgroup-articles)
+ article mark tomove)
+ (when (stringp group) ; this routine will do nothing
+ ; without a valid group
+ (dolist (article articles)
+ (when (spam-group-ham-mark-p gnus-newsgroup-name
+ (gnus-summary-article-mark article))
+ (push article tomove)))
+
+ ;; now do the actual move
+ (when tomove
+ (dolist (article tomove)
+ (when spam-mark-ham-unread-before-move-from-spam-group
+ (gnus-summary-mark-article article gnus-unread-mark))
+ (gnus-summary-set-process-mark article))
+ (if copy
+ (gnus-summary-copy-article nil group)
+ (gnus-summary-move-article nil group)))))
+ (gnus-summary-yank-process-mark))
+
+(defun spam-generic-register-routine (spam-func ham-func)
+ (let ((articles gnus-newsgroup-articles)
+ article mark ham-articles spam-articles)
+
+ (while articles
+ (setq article (pop articles)
+ mark (gnus-summary-article-mark article))
+ (cond ((spam-group-spam-mark-p gnus-newsgroup-name mark)
+ (push article spam-articles))
+ ((memq article gnus-newsgroup-saved))
+ ((spam-group-ham-mark-p gnus-newsgroup-name mark)
+ (push article ham-articles))))
+
+ (when (and ham-articles ham-func)
+ (mapc ham-func ham-articles)) ; we use mapc because unlike
+ ; mapcar it discards the
+ ; return values
+ (when (and spam-articles spam-func)
+ (mapc spam-func spam-articles)))) ; we use mapc because unlike
+ ; mapcar it discards the
+ ; return values
+
+(eval-and-compile
+ (defalias 'spam-point-at-eol (if (fboundp 'point-at-eol)
+ 'point-at-eol
+ 'line-end-position)))
+
+(defun spam-get-article-as-string (article)
+ (let ((article-buffer (spam-get-article-as-buffer article))
+ article-string)
+ (when article-buffer
+ (save-window-excursion
+ (set-buffer article-buffer)
+ (setq article-string (buffer-string))))
+ article-string))
+
+(defun spam-get-article-as-buffer (article)
+ (let ((article-buffer))
+ (when (numberp article)
+ (save-window-excursion
+ (gnus-summary-goto-subject article)
+ (gnus-summary-show-article t)
+ (setq article-buffer (get-buffer gnus-article-buffer))))
+ article-buffer))
+
+;; disabled for now
+;; (defun spam-get-article-as-filename (article)
+;; (let ((article-filename))
+;; (when (numberp article)
+;; (nnml-possibly-change-directory (gnus-group-real-name gnus-newsgroup-name))
+;; (setq article-filename (expand-file-name (int-to-string article) nnml-current-directory)))
+;; (if (file-exists-p article-filename)
+;; article-filename
+;; nil)))
+
+(defun spam-fetch-field-from-fast (article)
+ "Fetch the `from' field quickly, using the internal gnus-data-list function"
+ (if (and (numberp article)
+ (assoc article (gnus-data-list nil)))
+ (mail-header-from (gnus-data-header (assoc article (gnus-data-list nil))))
+ nil))
+
+(defun spam-fetch-field-subject-fast (article)
+ "Fetch the `subject' field quickly, using the internal gnus-data-list function"
+ (if (and (numberp article)
+ (assoc article (gnus-data-list nil)))
+ (mail-header-subject (gnus-data-header (assoc article (gnus-data-list nil))))
+ nil))
+
+\f
+;;;; Spam determination.
+
+(defvar spam-list-of-checks
+ '((spam-use-blacklist . spam-check-blacklist)
+ (spam-use-regex-headers . spam-check-regex-headers)
+ (spam-use-whitelist . spam-check-whitelist)
+ (spam-use-BBDB . spam-check-BBDB)
+ (spam-use-ifile . spam-check-ifile)
+ (spam-use-stat . spam-check-stat)
+ (spam-use-blackholes . spam-check-blackholes)
+ (spam-use-hashcash . spam-check-hashcash)
+ (spam-use-bogofilter-headers . spam-check-bogofilter-headers)
+ (spam-use-bogofilter . spam-check-bogofilter))
+"The spam-list-of-checks list contains pairs associating a parameter
+variable with a spam checking function. If the parameter variable is
+true, then the checking function is called, and its value decides what
+happens. Each individual check may return nil, t, or a mailgroup
+name. The value nil means that the check does not yield a decision,
+and so, that further checks are needed. The value t means that the
+message is definitely not spam, and that further spam checks should be
+inhibited. Otherwise, a mailgroup name is returned where the mail
+should go, and further checks are also inhibited. The usual mailgroup
+name is the value of `spam-split-group', meaning that the message is
+definitely a spam.")
+
+(defvar spam-list-of-statistical-checks
+ '(spam-use-ifile spam-use-stat spam-use-bogofilter)
+"The spam-list-of-statistical-checks list contains all the mail
+splitters that need to have the full message body available.")
+
+(defun spam-split (&rest specific-checks)
+ "Split this message into the `spam' group if it is spam.
+This function can be used as an entry in `nnmail-split-fancy', for
+example like this: (: spam-split). It can take checks as parameters.
+
+See the Info node `(gnus)Fancy Mail Splitting' for more details."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (dolist (check spam-list-of-statistical-checks)
+ (when (symbol-value check)
+ (widen)
+ (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
+ (symbol-name check))
+ (return)))
+ ;; (progn (widen) (debug (buffer-string)))
+ (let ((list-of-checks spam-list-of-checks)
+ decision)
+ (while (and list-of-checks (not decision))
+ (let ((pair (pop list-of-checks)))
+ (when (and (symbol-value (car pair))
+ (or (null specific-checks)
+ (memq (car pair) specific-checks)))
+ (gnus-message 5 "spam-split: calling the %s function" (symbol-name (cdr pair)))
+ (setq decision (funcall (cdr pair))))))
+ (if (eq decision t)
+ nil
+ decision)))))
+
+(defun spam-setup-widening ()
+ (dolist (check spam-list-of-statistical-checks)
+ (when (symbol-value check)
+ (setq nnimap-split-download-body-default t))))
+
+(add-hook 'gnus-get-new-news-hook 'spam-setup-widening)
+
+\f
+;;;; Regex headers
+
+(defun spam-check-regex-headers ()
+ (let (ret found)
+ (dolist (h-regex spam-regex-headers-ham)
+ (unless found
+ (goto-char (point-min))
+ (when (re-search-forward h-regex nil t)
+ (message "Ham regex header search positive.")
+ (setq found t))))
+ (dolist (s-regex spam-regex-headers-spam)
+ (unless found
+ (goto-char (point-min))
+ (when (re-search-forward s-regex nil t)
+ (message "Spam regex header search positive." (match-string 1))
+ (setq found t)
+ (setq ret spam-split-group))))
+ ret))
+
+\f
+;;;; Blackholes.
+
+(defun spam-check-blackholes ()
+ "Check the Received headers for blackholed relays."
+ (let ((headers (message-fetch-field "received"))
+ ips matches)
+ (when headers
+ (with-temp-buffer
+ (insert headers)
+ (goto-char (point-min))
+ (gnus-message 5 "Checking headers for relay addresses")
+ (while (re-search-forward
+ "\\[\\([0-9]+.[0-9]+.[0-9]+.[0-9]+\\)\\]" nil t)
+ (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
+ (push (mapconcat 'identity
+ (nreverse (split-string (match-string 1) "\\."))
+ ".")
+ ips)))
+ (dolist (server spam-blackhole-servers)
+ (dolist (ip ips)
+ (unless (and spam-blackhole-good-server-regex
+ (string-match spam-blackhole-good-server-regex ip))
+ (let ((query-string (concat ip "." server)))
+ (if spam-use-dig
+ (let ((query-result (query-dig query-string)))
+ (when query-result
+ (gnus-message 5 "(DIG): positive blackhole check '%s'"
+ query-result)
+ (push (list ip server query-result)
+ matches)))
+ ;; else, if not using dig.el
+ (when (query-dns query-string)
+ (gnus-message 5 "positive blackhole check")
+ (push (list ip server (query-dns query-string 'TXT))
+ matches))))))))
+ (when matches
+ spam-split-group)))
+\f
+;;;; Hashcash.
+
+(condition-case nil
+ (progn
+ (require 'hashcash)
+
+ (defun spam-check-hashcash ()
+ "Check the headers for hashcash payments."
+ (mail-check-payment))) ;mail-check-payment returns a boolean
+
+ (file-error (progn
+ (defalias 'mail-check-payment 'ignore)
+ (defalias 'spam-check-hashcash 'ignore))))
+\f
+;;;; BBDB
+
+;;; original idea for spam-check-BBDB from Alexander Kotelnikov
+;;; <sacha@giotto.sj.ru>
+
+;; all this is done inside a condition-case to trap errors
+
+(condition-case nil
+ (progn
+ (require 'bbdb)
+ (require 'bbdb-com)
+
+ (defun spam-enter-ham-BBDB (from)
+ "Enter an address into the BBDB; implies ham (non-spam) sender"
+ (when (stringp from)
+ (let* ((parsed-address (gnus-extract-address-components from))
+ (name (or (car parsed-address) "Ham Sender"))
+ (net-address (car (cdr parsed-address))))
+ (gnus-message 5 "Adding address %s to BBDB" from)
+ (when (and net-address
+ (not (bbdb-search-simple nil net-address)))
+ (bbdb-create-internal name nil net-address nil nil
+ "ham sender added by spam.el")))))
+
+ (defun spam-BBDB-register-routine ()
+ (spam-generic-register-routine
+ ;; spam function
+ nil
+ ;; ham function
+ (lambda (article)
+ (spam-enter-ham-BBDB (spam-fetch-field-from-fast article)))))
+
+ (defun spam-check-BBDB ()
+ "Mail from people in the BBDB is classified as ham or non-spam"
+ (let ((who (message-fetch-field "from")))
+ (when who
+ (setq who (cadr (gnus-extract-address-components who)))
+ (if (bbdb-search-simple nil who)
+ t
+ (if spam-use-BBDB-exclusive
+ spam-split-group
+ nil))))))
+
+ (file-error (progn
+ (defalias 'bbdb-search-simple 'ignore)
+ (defalias 'spam-check-BBDB 'ignore)
+ (defalias 'spam-BBDB-register-routine 'ignore)
+ (defalias 'spam-enter-ham-BBDB 'ignore)
+ (defalias 'bbdb-create-internal 'ignore)
+ (defalias 'bbdb-records 'ignore))))
+
+\f
+;;;; ifile
+
+;;; check the ifile backend; return nil if the mail was NOT classified
+;;; as spam
+
+(defun spam-get-ifile-database-parameter ()
+ "Get the command-line parameter for ifile's database from spam-ifile-database-path."
+ (if spam-ifile-database-path
+ (format "--db-file=%s" spam-ifile-database-path)
+ nil))
+
+(defun spam-check-ifile ()
+ "Check the ifile backend for the classification of this message"
+ (let ((article-buffer-name (buffer-name))
+ category return)
+ (with-temp-buffer
+ (let ((temp-buffer-name (buffer-name))
+ (db-param (spam-get-ifile-database-parameter)))
+ (save-excursion
+ (set-buffer article-buffer-name)
+ (if db-param
+ (call-process-region (point-min) (point-max) spam-ifile-path
+ nil temp-buffer-name nil "-q" "-c" db-param)
+ (call-process-region (point-min) (point-max) spam-ifile-path
+ nil temp-buffer-name nil "-q" "-c")))
+ (goto-char (point-min))
+ (if (not (eobp))
+ (setq category (buffer-substring (point) (spam-point-at-eol))))
+ (when (not (zerop (length category))) ; we need a category here
+ (if spam-ifile-all-categories
+ (setq return category)
+ ;; else, if spam-ifile-all-categories is not set...
+ (when (string-equal spam-ifile-spam-category category)
+ (setq return spam-split-group))))))
+ return))
+
+(defun spam-ifile-register-with-ifile (article-string category)
+ "Register an article, given as a string, with a category.
+Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
+ (when (stringp article-string)
+ (let ((category (or category gnus-newsgroup-name))
+ (db-param (spam-get-ifile-database-parameter)))
+ (with-temp-buffer
+ (insert article-string)
+ (if db-param
+ (call-process-region (point-min) (point-max) spam-ifile-path
+ nil nil nil
+ "-h" "-i" category db-param)
+ (call-process-region (point-min) (point-max) spam-ifile-path
+ nil nil nil
+ "-h" "-i" category))))))
+
+(defun spam-ifile-register-spam-routine ()
+ (spam-generic-register-routine
+ (lambda (article)
+ (spam-ifile-register-with-ifile
+ (spam-get-article-as-string article) spam-ifile-spam-category))
+ nil))
+
+(defun spam-ifile-register-ham-routine ()
+ (spam-generic-register-routine
+ nil
+ (lambda (article)
+ (spam-ifile-register-with-ifile
+ (spam-get-article-as-string article) spam-ifile-ham-category))))
+
+\f
+;;;; spam-stat
+
+(condition-case nil
+ (progn
+ (let ((spam-stat-install-hooks nil))
+ (require 'spam-stat))
+
+ (defun spam-check-stat ()
+ "Check the spam-stat backend for the classification of this message"
+ (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
+ (spam-stat-buffer (buffer-name)) ; stat the current buffer
+ category return)
+ (spam-stat-split-fancy)))
+
+ (defun spam-stat-register-spam-routine ()
+ (spam-generic-register-routine
+ (lambda (article)
+ (let ((article-string (spam-get-article-as-string article)))
+ (with-temp-buffer
+ (insert article-string)
+ (spam-stat-buffer-is-spam))))
+ nil))
+
+ (defun spam-stat-register-ham-routine ()
+ (spam-generic-register-routine
+ nil
+ (lambda (article)
+ (let ((article-string (spam-get-article-as-string article)))
+ (with-temp-buffer
+ (insert article-string)
+ (spam-stat-buffer-is-non-spam))))))
+
+ (defun spam-maybe-spam-stat-load ()
+ (when spam-use-stat (spam-stat-load)))
+
+ (defun spam-maybe-spam-stat-save ()
+ (when spam-use-stat (spam-stat-save)))
+
+ ;; Add hooks for loading and saving the spam stats
+ (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
+ (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
+ (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load))
+
+ (file-error (progn
+ (defalias 'spam-stat-register-ham-routine 'ignore)
+ (defalias 'spam-stat-register-spam-routine 'ignore)
+ (defalias 'spam-stat-buffer-is-spam 'ignore)
+ (defalias 'spam-stat-buffer-is-non-spam 'ignore)
+ (defalias 'spam-stat-split-fancy 'ignore)
+ (defalias 'spam-stat-load 'ignore)
+ (defalias 'spam-stat-save 'ignore)
+ (defalias 'spam-check-stat 'ignore))))
+
+\f
+
+;;;; Blacklists and whitelists.
+
+(defvar spam-whitelist-cache nil)
+(defvar spam-blacklist-cache nil)
+
+(defun spam-enter-whitelist (address)
+ "Enter ADDRESS into the whitelist."
+ (interactive "sAddress: ")
+ (spam-enter-list address spam-whitelist)
+ (setq spam-whitelist-cache nil))
+
+(defun spam-enter-blacklist (address)
+ "Enter ADDRESS into the blacklist."
+ (interactive "sAddress: ")
+ (spam-enter-list address spam-blacklist)
+ (setq spam-blacklist-cache nil))
+
+(defun spam-enter-list (address file)
+ "Enter ADDRESS into the given FILE, either the whitelist or the blacklist."
+ (unless (file-exists-p (file-name-directory file))
+ (make-directory (file-name-directory file) t))
+ (save-excursion
+ (set-buffer
+ (find-file-noselect file))
+ (goto-char (point-max))
+ (unless (bobp)
+ (insert "\n"))
+ (insert address "\n")
+ (save-buffer)))
+
+;;; returns t if the sender is in the whitelist, nil or spam-split-group otherwise
+(defun spam-check-whitelist ()
+ ;; FIXME! Should it detect when file timestamps change?
+ (unless spam-whitelist-cache
+ (setq spam-whitelist-cache (spam-parse-list spam-whitelist)))
+ (if (spam-from-listed-p spam-whitelist-cache)
+ t
+ (if spam-use-whitelist-exclusive
+ spam-split-group
+ nil)))
+
+(defun spam-check-blacklist ()
+ ;; FIXME! Should it detect when file timestamps change?
+ (unless spam-blacklist-cache
+ (setq spam-blacklist-cache (spam-parse-list spam-blacklist)))
+ (and (spam-from-listed-p spam-blacklist-cache) spam-split-group))
+
+(defun spam-parse-list (file)
+ (when (file-readable-p file)
+ (let (contents address)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (while (not (eobp))
+ (setq address (buffer-substring (point) (spam-point-at-eol)))
+ (forward-line 1)
+ (unless (zerop (length address))
+ (setq address (regexp-quote address))
+ (while (string-match "\\\\\\*" address)
+ (setq address (replace-match ".*" t t address)))
+ (push address contents))))
+ (nreverse contents))))
+
+(defun spam-from-listed-p (cache)
+ (let ((from (message-fetch-field "from"))
+ found)
+ (while cache
+ (when (string-match (pop cache) from)
+ (setq found t
+ cache nil)))
+ found))
+
+(defun spam-blacklist-register-routine ()
+ (spam-generic-register-routine
+ ;; the spam function
+ (lambda (article)
+ (let ((from (spam-fetch-field-from-fast article)))
+ (when (stringp from)
+ (spam-enter-blacklist from))))
+ ;; the ham function
+ nil))
+
+(defun spam-whitelist-register-routine ()
+ (spam-generic-register-routine
+ ;; the spam function
+ nil
+ ;; the ham function
+ (lambda (article)
+ (let ((from (spam-fetch-field-from-fast article)))
+ (when (stringp from)
+ (spam-enter-whitelist from))))))
+
+\f
+;;;; Spam-report glue
+(defun spam-report-gmane-register-routine ()
+ (spam-generic-register-routine
+ 'spam-report-gmane
+ nil))
+
+\f
+;;;; Bogofilter
+(defun spam-check-bogofilter-headers (&optional score)
+ (let ((header (message-fetch-field spam-bogofilter-header)))
+ (when (and header
+ (string-match spam-bogofilter-bogosity-positive-spam-header
+ header))
+ (if score
+ (when (string-match "spamicity=\\([0-9.]+\\)" header)
+ (match-string 1 header))
+ spam-split-group))))
+
+;; return something sensible if the score can't be determined
+(defun spam-bogofilter-score ()
+ "Get the Bogofilter spamicity score"
+ (interactive)
+ (save-window-excursion
+ (gnus-summary-show-article t)
+ (set-buffer gnus-article-buffer)
+ (let ((score (or (spam-check-bogofilter-headers t)
+ (spam-check-bogofilter t))))
+ (message "Spamicity score %s" score)
+ (or score "0"))))
+
+(defun spam-check-bogofilter (&optional score)
+ "Check the Bogofilter backend for the classification of this message"
+ (let ((article-buffer-name (buffer-name))
+ return)
+ (with-temp-buffer
+ (let ((temp-buffer-name (buffer-name)))
+ (save-excursion
+ (set-buffer article-buffer-name)
+ (if spam-bogofilter-database-directory
+ (call-process-region (point-min) (point-max)
+ spam-bogofilter-path
+ nil temp-buffer-name nil "-v"
+ "-d" spam-bogofilter-database-directory)
+ (call-process-region (point-min) (point-max) spam-bogofilter-path
+ nil temp-buffer-name nil "-v")))
+ (setq return (spam-check-bogofilter-headers score))))
+ return))
+
+(defun spam-bogofilter-register-with-bogofilter (article-string spam)
+ "Register an article, given as a string, as spam or non-spam."
+ (when (stringp article-string)
+ (let ((switch (if spam spam-bogofilter-spam-switch
+ spam-bogofilter-ham-switch)))
+ (with-temp-buffer
+ (insert article-string)
+ (if spam-bogofilter-database-directory
+ (call-process-region (point-min) (point-max)
+ spam-bogofilter-path
+ nil nil nil "-v" switch
+ "-d" spam-bogofilter-database-directory)
+ (call-process-region (point-min) (point-max) spam-bogofilter-path
+ nil nil nil "-v" switch))))))
+
+(defun spam-bogofilter-register-spam-routine ()
+ (spam-generic-register-routine
+ (lambda (article)
+ (spam-bogofilter-register-with-bogofilter
+ (spam-get-article-as-string article) t))
+ nil))
+
+(defun spam-bogofilter-register-ham-routine ()
+ (spam-generic-register-routine
+ nil
+ (lambda (article)
+ (spam-bogofilter-register-with-bogofilter
+ (spam-get-article-as-string article) nil))))
+
+(provide 'spam)
+
+;;; spam.el ends here.
--- /dev/null
+;;; tls.el --- TLS/SSL support via wrapper around GnuTLS
+
+;; Copyright (C) 2003 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Keywords: comm, tls, gnutls, ssl
+
+;; 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 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 package implements a simple wrapper around "gnutls-cli" to
+;; make Emacs support TLS/SSL.
+;;
+;; Usage is the same as `open-network-stream', i.e.:
+;;
+;; (setq tmp (open-tls-stream "test" (current-buffer) "news.mozilla.org" 563))
+;; ...
+;; #<process test>
+;; (process-send-string tmp "mode reader\n")
+;; 200 secnews.netscape.com Netscape-Collabra/3.52 03615 NNRP ready ...
+;; nil
+;; (process-send-string tmp "quit\n")
+;; 205
+;; nil
+
+;; To use this package as a replacement for ssl.el by William M. Perry
+;; <wmperry@cs.indiana.edu>, you need to evaluate the following:
+;;
+;; (defalias 'open-ssl-stream 'open-tls-stream)
+
+;;; Code:
+
+(require 'pces)
+
+(eval-and-compile
+ (autoload 'format-spec "format-spec")
+ (autoload 'format-spec-make "format-spec"))
+
+(defgroup tls nil
+ "Transport Layer Security (TLS) parameters."
+ :group 'comm)
+
+(defcustom tls-program '("gnutls-cli -p %p %h"
+ "gnutls-cli -p %p %h --protocols ssl3")
+ "List of strings containing commands to start TLS stream to a host.
+Each entry in the list is tried until a connection is successful.
+%s is replaced with server hostname, %p with port to connect to.
+The program should read input on stdin and write output to
+stdout. Also see `tls-success' for what the program should output
+after successful negotiation."
+ :type '(repeat string)
+ :group 'tls)
+
+(defcustom tls-process-connection-type nil
+ "*Value for `process-connection-type' to use when starting process."
+ :type 'boolean
+ :group 'tls)
+
+(defcustom tls-success "- Handshake was completed"
+ "*Regular expression indicating completed TLS handshakes.
+The default is what GNUTLS's \"gnutls-cli\" outputs."
+ :type 'regexp
+ :group 'tls)
+
+(defun open-tls-stream (name buffer host service)
+ "Open a TLS connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or buffer-name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to, or its IP address.
+Fourth arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to."
+ (let ((cmds tls-program) cmd done)
+ (message "Opening TLS connection to `%s'..." host)
+ (while (and (not done) (setq cmd (pop cmds)))
+ (message "Opening TLS connection with `%s'..." cmd)
+ (let* ((process-connection-type tls-process-connection-type)
+ (process (as-binary-process
+ (start-process
+ name buffer shell-file-name shell-command-switch
+ (format-spec
+ cmd
+ (format-spec-make
+ ?h host
+ ?p (if (integerp service)
+ (int-to-string service)
+ service))))))
+ response)
+ (while (and process
+ (memq (process-status process) '(open run))
+ (save-excursion
+ (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+ (goto-char (point-min))
+ (not (setq done (re-search-forward tls-success nil t)))))
+ (accept-process-output process 1)
+ (sit-for 1))
+ (message "Opening TLS connection with `%s'...%s" cmd
+ (if done "done" "failed"))
+ (if done
+ (setq done process)
+ (delete-process process))))
+ (message "Opening TLS connection to `%s'...%s"
+ host (if done "done" "failed"))
+ done))
+
+(provide 'tls)
+
+;;; tls.el ends here
--- /dev/null
+;;; yenc.el --- elisp native yenc decoder
+;; Copyright (c) 2002 Free Software Foundation, Inc.
+
+;; Author: Jesper Harder <harder@ifa.au.dk>
+;; Keywords: yenc news
+
+;; 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 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:
+
+;; Functions for decoding yenc encoded messages.
+;;
+;; Limitations:
+;;
+;; * Does not handle multipart messages.
+;; * No support for external decoders.
+;; * Doesn't check the crc32 checksum (if present).
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defconst yenc-begin-line
+ "^=ybegin.*$")
+
+(defconst yenc-decoding-vector
+ [214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
+ 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
+ 248 249 250 251 252 253 254 255 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
+ 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
+ 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
+ 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
+ 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
+ 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
+ 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139
+ 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
+ 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
+ 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
+ 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
+ 208 209 210 211 212 213])
+
+;;;###autoload
+(defun yenc-decode-region (start end)
+ "Yenc decode region between START and END using an internal decoder."
+ (interactive "r")
+ (let (work-buffer)
+ (unwind-protect
+ (save-excursion
+ (goto-char start)
+ (when (re-search-forward yenc-begin-line end t)
+ (let ((first (match-end 0))
+ (header-alist (yenc-parse-line (match-string 0)))
+ bytes last footer-alist char)
+ (when (re-search-forward "^=ypart.*$" end t)
+ (setq first (match-end 0)))
+ (when (re-search-forward "^=yend.*$" end t)
+ (setq last (match-beginning 0))
+ (setq footer-alist (yenc-parse-line (match-string 0)))
+ (let (default-enable-multibyte-characters)
+ (setq work-buffer (generate-new-buffer " *yenc-work*")))
+ (while (< first last)
+ (setq char (char-after first))
+ (cond ((or (eq char ?\r)
+ (eq char ?\n)))
+ ((eq char ?=)
+ (setq char (char-after (incf first)))
+ (with-current-buffer work-buffer
+ (insert-char (mod (- char 106) 256) 1)))
+ (t
+ (with-current-buffer work-buffer
+ ;;(insert-char (mod (- char 42) 256) 1)
+ (insert-char (aref yenc-decoding-vector char) 1))))
+ (incf first))
+ (setq bytes (buffer-size work-buffer))
+ (unless (and (= (cdr (assq 'size header-alist)) bytes)
+ (= (cdr (assq 'size footer-alist)) bytes))
+ (message "Warning: Size mismatch while decoding."))
+ (goto-char start)
+ (delete-region start end)
+ (insert-buffer-substring work-buffer))))
+ (and work-buffer (kill-buffer work-buffer))))))
+
+;;;###autoload
+(defun yenc-extract-filename ()
+ "Extract file name from an yenc header."
+ (save-excursion
+ (when (re-search-forward yenc-begin-line nil t)
+ (cdr (assoc 'name (yenc-parse-line (match-string 0)))))))
+
+(defun yenc-parse-line (str)
+ "Extract file name and size from STR."
+ (let (result name)
+ (when (string-match "^=y.*size=\\([0-9]+\\)" str)
+ (push (cons 'size (string-to-number (match-string 1 str))) result))
+ (when (string-match "^=y.*name=\\(.*\\)$" str)
+ (setq name (match-string 1 str))
+ ;; Remove trailing white space
+ (when (string-match " +$" name)
+ (setq name (substring name 0 (match-beginning 0))))
+ (push (cons 'name name) result))
+ result))
+
+(provide 'yenc)
+
+;;; yenc.el ends here
projects / elisp / gnus.git- / commitdiff