Mercurial > emacs
changeset 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
line wrap: on
line diff
--- a/lisp/gnus/ChangeLog Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/ChangeLog Thu Jul 22 16:45:51 2004 +0000 @@ -1,3 +1,7 @@ +2004-07-22 Andreas Schwab <schwab@suse.de> + + Import Gnus 5.10 from the v5_10 branch of the Gnus repository. + 2004-06-29 Kim F. Storm <storm@cua.dk> * nntp.el (nntp-authinfo-file): Add :group 'nntp.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/bar.xbm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,7 @@ +#define noname_width 6 +#define noname_height 48 +static char noname_bits[] = { + 0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c, + 0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c, + 0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c,0x0c, + 0x0c,0x0c,0x0c};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/bar.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,54 @@ +/* XPM */ +static char * picon-bar_xpm[] = { +"6 48 2 1", +" c white s background", +". c black", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. ", +" .. "};
--- a/lisp/gnus/binhex.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/binhex.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,8 +1,7 @@ ;;; binhex.el --- elisp native binhex decode -;; Copyright (c) 1998 Free Software Foundation, Inc. +;; Copyright (c) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> -;; Create Date: Oct 1, 1998 ;; Keywords: binhex news ;; This file is part of GNU Emacs. @@ -26,20 +25,33 @@ ;;; Code: +(autoload 'executable-find "executable") + (eval-when-compile (require 'cl)) -(defalias 'binhex-char-int - (if (fboundp 'char-int) - 'char-int - 'identity)) +(eval-and-compile + (defalias 'binhex-char-int + (if (fboundp 'char-int) + 'char-int + 'identity))) -(defvar binhex-decoder-program "hexbin" - "*Non-nil value should be a string that names a uu decoder. +(defcustom binhex-decoder-program "hexbin" + "*Non-nil value should be a string that names a binhex decoder. The program should expect to read binhex data on its standard -input and write the converted data to its standard output.") +input and write the converted data to its standard output." + :type 'string + :group 'gnus-extract) -(defvar binhex-decoder-switches '("-d") - "*List of command line flags passed to the command `binhex-decoder-program'.") +(defcustom binhex-decoder-switches '("-d") + "*List of command line flags passed to the command `binhex-decoder-program'." + :group 'gnus-extract + :type '(repeat string)) + +(defcustom binhex-use-external + (executable-find binhex-decoder-program) + "*Use external binhex program." + :group 'gnus-extract + :type 'boolean) (defconst binhex-alphabet-decoding-alist '(( ?\! . 0) ( ?\" . 1) ( ?\# . 2) ( ?\$ . 3) ( ?\% . 4) ( ?\& . 5) @@ -69,13 +81,16 @@ ((boundp 'temporary-file-directory) temporary-file-directory) ("/tmp/"))) -(if (featurep 'xemacs) - (defalias 'binhex-insert-char 'insert-char) - (defun binhex-insert-char (char &optional count ignored buffer) - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (with-current-buffer buffer - (insert-char char count))))) +(eval-and-compile + (defalias 'binhex-insert-char + (if (featurep 'xemacs) + 'insert-char + (lambda (char &optional count ignored buffer) + "Insert COUNT copies of CHARACTER into BUFFER." + (if (or (null buffer) (eq buffer (current-buffer))) + (insert-char char count) + (with-current-buffer buffer + (insert-char char count))))))) (defvar binhex-crc-table [0 4129 8258 12387 16516 20645 24774 28903 @@ -184,8 +199,9 @@ (t (binhex-insert-char (setq binhex-last-char char) 1 ignored buffer)))) -(defun binhex-decode-region (start end &optional header-only) - "Binhex decode region between START and END. +;;;###autoload +(defun binhex-decode-region-internal (start end &optional header-only) + "Binhex decode region between START and END without using an external program. If HEADER-ONLY is non-nil only decode header and return filename." (interactive "r") (let ((work-buffer nil) @@ -258,12 +274,14 @@ (and work-buffer (kill-buffer work-buffer))) (if header (aref header 1)))) +;;;###autoload (defun binhex-decode-region-external (start end) "Binhex decode region between START and END using external decoder." (interactive "r") (let ((cbuf (current-buffer)) firstline work-buffer status (file-name (expand-file-name - (concat (binhex-decode-region start end t) ".data") + (concat (binhex-decode-region-internal start end t) + ".data") binhex-temporary-file-directory))) (save-excursion (goto-char start) @@ -296,6 +314,14 @@ (ignore-errors (if file-name (delete-file file-name)))))) +;;;###autoload +(defun binhex-decode-region (start end) + "Binhex decode region between START and END." + (interactive "r") + (if binhex-use-external + (binhex-decode-region-external start end) + (binhex-decode-region-internal start end))) + (provide 'binhex) ;;; arch-tag: 8476badd-1e76-4f1d-a640-f9a38c72eed8
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/canlock.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,314 @@ +;;; 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 '(radio (const :format "Not specified " nil) + (string :tag "Password" :size 0)) + :group 'canlock) + +(defcustom canlock-password-for-verify canlock-password + "Password to use when verifying a Cancel-Lock or a Cancel-Key header." + :type '(radio (const :format "Not specified " nil) + (string :tag "Password" :size 0)) + :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) + +;;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78 +;;; canlock.el ends here
--- a/lisp/gnus/catchup.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/catchup.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,73 +1,33 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 43 1", -" c Gray0", -". c #099909990999", -"X c Gray6", -"o c #133313331333", -"O c Gray9", -"+ c Gray11", -"@ c Gray12", -"# c #23f323f323f3", -"$ c Gray15", -"% c #2ff12ff12ff1", -"& c #3fff3fff3fff", -"* c Gray25", -"= c #4ccc4ccc4ccc", -"- c #519151915191", -"; c #53ed53ed53ed", -": c #565b565b565b", -"> c Gray35", -", c #5b1a5b1a5b1a", -"< c #5fe95fe95fe9", -"1 c #626262626262", -"2 c Gray40", -"3 c #67e767e767e7", -"4 c Gray42", -"5 c #6fff6fff6fff", -"6 c Gray45", -"7 c Gray46", -"8 c #77e977e977e9", -"9 c #7bdb7bdb7bdb", -"0 c #7ccc7ccc7ccc", -"q c Gray50", -"w c #866586658665", -"e c Gray56", -"r c Gray60", -"t c #9bcb9bcb9bcb", -"y c #9fff9fff9fff", -"u c #a7c7a7c7a7c7", -"i c #af0eaf0eaf0e", -"p c Gray70", -"a c Gray75", -"s c Gray81", -"d c #dfffdfffdfff", -"f c #efffefffefff", -"g c Gray100", -/* pixels */ -"aaaaaaaaaaaaaaaaaaaaaaaa", -"aaaaaaaaaaaaaaaaaaaaaaaa", -"aaaaaaaaaaaaaaaaaaaaaaaa", -"aaaaaa7$$*uaaaaaaaaareep", -"aaaaaa$rr6<aaaaaaaae;==>", -"aaaaaa7<r6<aaaaaaaa<6rr$", -"9&&&&&&>6;aaaareeeee#rw*", -"&aqqagga@<<<7e7qqqqqq=:u", -"33e4qgggsaa%1Oa&&&ggge<a", -"17a9ygf7%%%%#=$aa%ggga<a", -"7aa&gga<aaaae$>ae7ggya<a", -"aa;sgg;uaaaapepa<agg&a<a", -"au;&&&%aaaaaaaae<aaa;a6.", -"a<aggg%aaaaaaaa3qqq&e<:o", -"r7<5gg%aaaaaaaaXyggqeaue", -"6gs$6fa=re6666=s@egy3rrr", -"ga>r=aa=r6 <qqdd3=yg&rrr", -"&>er=aa=r6 aggg=wr&g&rrr", -"rrrrr$a<:6 @$$$rri=d5qrr", -"rrrrr<===6$wrrrrrr6&qo6r", -"rrrrrrrrrewrrrrrrr6 oq", -"rrrrrrrrrrrrrrrrrrrrrrrr", -"rrrrrrrrrrrrrrrrrrrrrrrr", -"rrrrrrrrrrrrrrrrrrrrrrrr" -}; +static char * catchup_xpm[] = { +"24 24 6 1", +" c None", +". c #FFFFFFFFFFFF", +"X c #E1E1E0E0E0E0", +"o c #A5A5A5A59595", +"O c #999999999999", +"+ c #000000000000", +" ", +" ", +" ", +" ", +" ", +" ", +" ", +" . ", +" . .X ", +" ... .oX . ", +" ..oooX.oXo .X ", +" .oooXXXX..oXXoXX ", +" .oXXXX.XoX.oXooX ", +" X...X.X.XX.XoXX ", +" Xo..X.XXX.XXXX ", +" . Xo.oXX..XXXXXX ", +"OOOOXoXXXXXo.XXXXX++OOOO", +"OOOOOX..X.XXXXXXXX++OOOO", +"OOOOOX..XXXXXXXXX++OOOOO", +"OOOOOOXXXXXXXXX+++OOOOOO", +"OOOOOOOOOXXXX++++OOOOOOO", +"OOOOOOOOO+++++OOOOOOOOOO", +"OOOOOOOOOO+OOOOOOOOOOOOO", +"OOOOOOOOOOOOOOOOOOOOOOOO"};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/compface.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,58 @@ +;;; 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) + +;;; arch-tag: f9c78e84-98c0-4142-9682-8ba4cf4c3441 +;;; compface.el ends here
--- a/lisp/gnus/cu-exit.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/cu-exit.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,64 +1,31 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 34 1", -" c Gray0", -". c #0bfb0bfb0bfb", -"X c Gray6", -"o c Gray9", -"O c Gray11", -"+ c Gray12", -"@ c #23f323f323f3", -"# c Gray15", -"$ c #2ff52ff52ff5", -"% c #3fff3fff3fff", -"& c Gray25", -"* c Gray28", -"= c #4ccc4ccc4ccc", -"- c #53e853e853e8", -"; c #5b1a5b1a5b1a", -": c #5fef5fef5fef", -"> c #67e767e767e7", -", c Gray42", -"< c #6ff76ff76ff7", -"1 c #77dc77dc77dc", -"2 c Gray50", -"3 c #866586658665", -"4 c #88a888a888a8", -"5 c Gray56", -"6 c Gray60", -"7 c #9bcb9bcb9bcb", -"8 c #9fff9fff9fff", -"9 c #a7d7a7d7a7d7", -"0 c Gray70", -"q c #b635b635b635", -"w c Gray75", -"e c Gray78", -"r c #dfffdfffdfff", -"t c Gray100", -/* pixels */ -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwww-$$$-wwwwwwww", -"wwwwwww9-$w$ttt$wwwwwwww", -"wwwwww:<ro:1ttto::wwwwww", -"wwww1$wrt5 wttt$w$$1wwww", -"wwww1.ttt5 5ww$ttt.1wwww", -"wwwww$8tt+222% 222$wwwww", -"wwwww$%tt%ttt2 ww$6wwwww", -"wwwww$52t%ttt2wtt%wwwwww", -"wwwww1 %r%ttt2w22>wwwwww", -"wwwwww,::X%%%+$w:5wwwwww", -"qqqqqq4*5%t%t255;qqqqqqq", -"6666663#*+2+2%**=6666666", -"6666666=0$w$0*0&36666666", -"6666666=,$9@5*,#66666666", -"6666666= +% 2% #66666666", -"6666666= %e@<2 #66666666", -"6666666:# +666666666", -"666666666=====3666666666", -"666666666666666666666666" -}; +static char * cu_exit_xpm[] = { +"24 24 4 1", +" c None", +". c #000000000000", +"X c #FFFFFFFFFFFF", +"o c #999999999999", +" ", +" ", +" ", +" ", +" ", +" ..... ", +" .. .XXX. ", +" ..X..XXXX... ", +" .XXXX.XXXX.X... ", +" ..XXXX.XXX.XXX.. ", +" .XXX.......... ", +" .XXX.XXX.XXX.. ", +" .XX.XXX.XXX. ", +" .XX.XXX.XX.. ", +" ............ ", +" .X.X.X.X.. ", +"ooooooo..........ooooooo", +"ooooooo.X.X.X.X.oooooooo", +"ooooooo.........oooooooo", +"ooooooo..X...X..oooooooo", +"ooooooo...X.X...oooooooo", +"ooooooo........ooooooooo", +"ooooooooo.....oooooooooo", +"oooooooooooooooooooooooo"};
--- a/lisp/gnus/describe-group.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/describe-group.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,72 +1,32 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 42 1", -" c Gray0", -". c #099909990999", -"X c #0bfb0bfb0bfb", -"o c #133313331333", -"O c Gray9", -"+ c Gray11", -"@ c #23f323f323f3", -"# c Gray15", -"$ c #2d8d2d8d2d8d", -"% c #399939993999", -"& c #433243324332", -"* c #4ccc4ccc4ccc", -"= c #519151915191", -"- c #53e353e353e3", -"; c #565656565656", -": c Gray36", -"> c #5fdf5fdf5fdf", -", c Gray42", -"< c #6fff6fff6fff", -"1 c Gray45", -"2 c #77f777f777f7", -"3 c #7ccc7ccc7ccc", -"4 c Gray50", -"5 c #865a865a865a", -"6 c Gray58", -"7 c Gray60", -"8 c #9bfb9bfb9bfb", -"9 c Gray62", -"0 c #9fff9fff9fff", -"q c #a0c0a0c0a0c0", -"w c Gray64", -"e c Gray65", -"r c Gray70", -"t c #b635b635b635", -"y c Gray73", -"u c Gray75", -"i c #d332d332d332", -"p c Gray85", -"a c #e665e665e665", -"s c #eccbeccbeccb", -"d c #f998f998f998", -"f c Gray100", -/* pixels */ -"&77&77&77&77&77&77&77&77", -"777777777777777777777777", -"77777777777777777iaaa777", -"&77&77&77&77&77<ff<fffp0", -"77777777777777uffffffffp", -"7777777777777udfffffffff", -"&77&77&77&77<ff<ff<ff<ff", -"777777777777ffffffffffff", -"777777777777ffffffffffff", -"&77&77&77&77<ff<ff<ff<ff", -"777777777777ffffffffffff", -"777777777777ffffffffffff", -"&77&77&77&77:ff<ff<ff<ff", -"777777777777rfffffffffff", -"77777&##37770pffffffffff", -"&77%-6ty-#77&7i<ff<ff<fs", -"777*5w7wy*17777pffffffae", -"777$13&7w+*77770rsfffre7", -"&73X:@3*1 *7&77&77&77&77", -"71o2;o***o17777777777777", -"3o,**X%*X377777777777777", -"XO, +##3&77&77&77&77&77", -":;o #50w7777777777777777", -"@oX+57707777777777777777" -}; +static char * describe_group_xpm[] = { +"24 24 5 1", +". c None", +" c #000000000000", +"o c #FFFFF5F5ACAC", +"+ c #E1E1E0E0E0E0", +"@ c #C7C7C6C6C6C6", +"........................", +"........................", +".................oooo...", +" .. .. .. .. .. oo oo o.", +"..............oooooooooo", +".............ooooooooooo", +" .. .. .. .. oo oo oo oo", +"............oooooooooooo", +"............oooooooooooo", +" .. .. .. .. oo oo oo oo", +"............oooooooooooo", +"............oooooooooooo", +" .. .. .. .. oo oo oo oo", +"............oooooooooooo", +"..... ...oooooooooooo", +" .. ++ .. .o oo oo oo", +"... @@@+ ....ooooooooo", +"... @ ....oooooooo.", +" . . .. .. .. ..", +". ..............", +" ................", +" .. .. .. .. .. ..", +" ..................", +" ...................."};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/deuglify.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,472 @@ +;;; 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 'integer + :group 'gnus-outlook-deuglify) + +;;;###autoload +(defcustom gnus-outlook-deuglify-unwrap-max 95 + "Maximum length of the cited line after unwrapping." + :type 'integer + :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 '(radio (const :format "None " nil) + (string :size 0 :value ".?!")) + :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 minimum 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: + +;;; arch-tag: 5f895cc9-51a9-487c-b42e-28844d79eb73 +;;; deuglify.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/dig.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,189 @@ +;;; 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) + +;;; arch-tag: 1d61726e-9400-4013-9ae7-4035e0c7f7d6 +;;; dig.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/dns.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,359 @@ +;;; 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. +(eval-when-compile + (when (featurep 'xemacs) + (require 'gnus-xmas))) + +(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)) + (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)) + + (if (not dns-servers) + (message "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) + +;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a +;;; dns.el ends here
--- a/lisp/gnus/earcon.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/earcon.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ -;;; earcon.el --- sound effects for messages +;;; earcon.el --- Sound effects for messages -;; Copyright (C) 1996, 2000, 2001 Free Software Foundation +;; Copyright (C) 1996, 2000, 2001, 2003 Free Software Foundation ;; Author: Steven L. Baur <steve@miranova.com> @@ -20,10 +20,8 @@ ;; 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. -;; This file is part of GNU Emacs. ;;; Commentary: - ;; This file provides access to sound effects in Gnus. ;;; Code: @@ -52,7 +50,7 @@ ("evil[ \t]+laugh" 1 "Evil_Laugh.au") ("gag\\|puke" 1 "Puke.au") ("snicker" 1 "Snicker.au") - ("meow" 1 "catmeow.au") + ("meow" 1 "catmeow.wav") ("sob\\|boohoo" 1 "cry.wav") ("drum[ \t]*roll" 1 "drumroll.au") ("blast" 1 "explosion.au") @@ -80,7 +78,7 @@ (interactive "e") (set-buffer (window-buffer (posn-window (event-start event)))) (let* ((pos (posn-point (event-start event))) - (data (get-text-property pos 'earcon-data)) + (data (get-text-property pos 'earcon-data)) (fun (get-text-property pos 'earcon-callback))) (if fun (funcall fun data))))
--- a/lisp/gnus/exit-gnus.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/exit-gnus.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,76 +1,33 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 46 1", -" c Gray0", -". c Gray6", -"X c #133313331333", -"o c Gray11", -"O c Gray12", -"+ c Gray15", -"@ c #2ff82ff82ff8", -"# c Gray20", -"$ c #399939993999", -"% c #3fff3fff3fff", -"& c Gray25", -"* c Gray28", -"= c #4ccc4ccc4ccc", -"- c #53e353e353e3", -"; c #565e565e565e", -": c #5b1a5b1a5b1a", -"> c #5ff55ff55ff5", -", c #626262626262", -"< c Gray40", -"1 c #67e767e767e7", -"2 c Gray42", -"3 c #6ff96ff96ff9", -"4 c Gray45", -"5 c #77d777d777d7", -"6 c #7ccc7ccc7ccc", -"7 c Gray50", -"8 c Gray56", -"9 c #97f797f797f7", -"0 c Gray60", -"q c #9bd19bd19bd1", -"w c #9ff29ff29ff2", -"e c #a7cba7cba7cb", -"r c Gray67", -"t c #afd5afd5afd5", -"y c Gray70", -"u c Gray75", -"i c #c3c3c3c3c3c3", -"p c Gray78", -"a c #cbcbcbcbcbcb", -"s c Gray81", -"d c #d7d8d7d8d7d8", -"f c #dff2dff2dff2", -"g c Gray89", -"h c #e7e7e7e7e7e7", -"j c #eff8eff8eff8", -"k c Gray100", -/* pixels */ -"kkkkkkkkkufkkkku7skkkkkk", -"kkkkkkkkw>%fkkw 7kkkkkkk", -"kk3%wkkksu ukk%u7skkkkkk", -"kww>>@@uu3f@8 @@7.@Owskk", -"kkwf777%>77O> >>%7777wkk", -"kkkkkss7j8O.@ 8jujsfjkkk", -"kkkjuuwO @> @>@@ujkkkkkk", -"kkk>%O77O$ > %f >kkkkkk", -"kkk87sj7<=u>@7s8>@%wkkkk", -"kkkkkkq==u>>u ukk3u7kkkk", -"7uwfuw+=>u u> >fuw7uwwuf", -"8twut#>:8q q8* uprwswwtu", -"ipuge&,5uq5uau-@uuuuuadu", -"psuu>4@uuuuuduu5uuduuuuu", -"uugu>4@uuguuuuuuuuauuuuu", -"uuuy:>-uuuuuuugguaaugguu", -"psu8=+uuuuspuuuuudduuuuu", -"ipu8=+uuujfhguuuuuudauuu", -"ue82=+8euuuuishspujdgguu", -"e@$$+X=;>uu5ttp9sduuuuuu", -"&4$8$ 7=4@@5y>qejdjduuuu", -";$4O4444444O@eye5@uuusfd", -">>>>3<>@*<3>@wp9f7uuufsd", -"uuujfhgedhfjqpswsiuuuuuu" -}; +static char * exit_gnus_xpm[] = { +"24 24 6 1", +" c None", +". c #8686ADAD7D7D", +"X c #919187876969", +"o c #C2C2B9B99C9C", +"O c #A8A8F0F0ECEC", +"+ c #EFEFEFEFEFEF", +" ", +" .... . ", +" .. .. . ", +" ............. ", +" . . . .... ", +" ............. ", +" .............. .. ", +" . . .......... . ", +" .XXXX... .. ", +" o.XXX. . .. ", +" oo.X. .. ... ", +" ooX. . ... ", +" oXo. .. ", +" ooX . . ", +" ooX ", +"OOOOoXXOOOOOOOOOOOOOOOOO", +"OOOoXoXOOOOOOOOOOOOOOOOO", +"OOOooXXOOOO+OOOOOOOOOOOO", +"O+OoooXOO+OOO+OO+OOO+OOO", +"OXXoXoXoXOO++O++OO++OO+O", +"XXXXXXXXXXXX+OOOOOOOOOOO", +"XXXXXXXXXXXXXX+O++OO++OO", +"XXXXXXXXXXXXXXXXOOOOOOOO", +"O++O++++O+OO++OOOO++OOO+"};
--- a/lisp/gnus/exit-summ.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/exit-summ.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,45 +1,30 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 15 1", -" c Gray0", -". c #0bfb0bfb0bfb", -"X c Gray9", -"o c #23f323f323f3", -"O c #2fef2fef2fef", -"+ c Gray28", -"@ c #53e353e353e3", -"# c #5fdf5fdf5fdf", -"$ c Gray42", -"% c #77d777d777d7", -"& c Gray56", -"* c #9bcb9bcb9bcb", -"= c #a7c7a7c7a7c7", -"- c Gray70", -"; c Gray75", -/* pixels */ -"@;;@;;@;;@;;@;;@;;@;;@;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -"@;;@;;&=@OOOo O;;@;;", -";;;;;;X&;;;;=## O;;;;;", -";;;;;;.%;;;;;;; O;;;;;", -"@;;@;;@;;@;;*;; O;;@;;", -";;;;;;;;;;;;%;; O;;;;;", -";;;;;;O%;;;;;;; O;;;;;", -"@;;@;;o=;@;;-&- O;;@;;", -";;;;;;X&;;;;+ & O;;;;;", -";;;;;;.%;;;;$ & O;;;;;", -"@;;@;;o=;@;;;;; O;;@;;", -";;;;;;X&;;;;;;; O;;;;;", -";;;;;;*;;;;;@;; O;;;;;", -"@;;@;;&=;@;;;;; O;;@;;", -";;;;;; #;;;;;&#XO+O;;;;;", -";;;;;;o=;*OO*#o%#+*;;;;;", -"@;;@;@;%OOOO@%*@%*@;;@;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -"@;;@;;@;;@;;@;;@;;@;;@;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -";;;;;;;;;;;;;;;;;;;;;;;;" -}; +static char * exit_summ_xpm[] = { +"24 24 3 1", +". c None", +" c #000000000000", +"X c #E1E1E0E0E0E0", +" .. .. .. .. .. .. .. ..", +"........................", +"........................", +" .. .. .. ..", +"...... XXXX .....", +"...... XXXXXXX .....", +" .. .. XX XX XX .. ..", +"...... XXXXXXXX .....", +"...... XXXXXXX .....", +" .. .. X XX .. ..", +"...... XXXX .....", +"...... XXXX .....", +" .. .. X XXXXX .. ..", +"...... XXXXXXX .....", +"...... XXXXX XX .....", +" .. .. X XXXXX .. ..", +"...... XXXXX .....", +"...... X .....", +" .. . . .. ..", +"........................", +"........................", +" .. .. .. .. .. .. .. ..", +"........................", +"........................"};
--- a/lisp/gnus/flow-fill.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/flow-fill.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; flow-fill.el --- interprete RFC2646 "flowed" text -;; Copyright (C) 2000, 2002 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Simon Josefsson <jas@pdc.kth.se> ;; Keywords: mail @@ -35,10 +35,10 @@ ;; paragraph and we let `fill-region' fill the long line into several ;; lines with the quote prefix as `fill-prefix'. -;; Todo: encoding, implement basic `fill-region' (Emacs and XEmacs +;; Todo: implement basic `fill-region' (Emacs and XEmacs ;; implementations differ..) -;; History: +;;; History: ;; 2000-02-17 posted on ding mailing list ;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs @@ -46,11 +46,30 @@ ;; 2000-03-26 committed to gnus cvs ;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule ;; work when first line is at level 0. +;; 2002-01-12 probably incomplete encoding support +;; 2003-12-08 started working on test harness. ;;; Code: (eval-when-compile (require 'cl)) +(defcustom fill-flowed-display-column 'fill-column + "Column beyond which format=flowed lines are wrapped, when displayed. +This can be a Lisp expression or an integer." + :type '(choice (const :tag "Standard `fill-column'" fill-column) + (const :tag "Fit Window" (- (window-width) 5)) + (sexp) + (integer))) + +(defcustom fill-flowed-encode-column 66 + "Column beyond which format=flowed lines are wrapped, in outgoing messages. +This can be a Lisp expression or an integer. +RFC 2646 suggests 66 characters for readability." + :type '(choice (const :tag "Standard fill-column" fill-column) + (const :tag "RFC 2646 default (66)" 66) + (sexp) + (integer))) + (eval-and-compile (defalias 'fill-flowed-point-at-bol (if (fboundp 'point-at-bol) @@ -62,6 +81,29 @@ 'point-at-eol 'line-end-position))) +;;;###autoload +(defun fill-flowed-encode (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + ;; No point in doing this unless hard newlines is used. + (when use-hard-newlines + (let ((start (point-min)) end) + ;; Go through each paragraph, filling it and adding SPC + ;; as the last character on each line. + (while (setq end (text-property-any start (point-max) 'hard 't)) + (let ((fill-column (eval fill-flowed-encode-column))) + (fill-region start end t 'nosqueeze 'to-eop)) + (goto-char start) + ;; `fill-region' probably distorted end. + (setq end (text-property-any start (point-max) 'hard 't)) + (while (and (< (point) end) + (re-search-forward "$" (1- end) t)) + (insert " ") + (setq end (1+ end)) + (forward-char)) + (goto-char (setq start (1+ end))))) + t))) + +;;;###autoload (defun fill-flowed (&optional buffer) (save-excursion (set-buffer (or (current-buffer) buffer)) @@ -70,7 +112,8 @@ (when (save-excursion (beginning-of-line) (looking-at "^\\(>*\\)\\( ?\\)")) - (let ((quote (match-string 1)) sig) + (let ((quote (match-string 1)) + sig) (if (string= quote "") (setq quote nil)) (when (and quote (string= (match-string 2) "")) @@ -79,6 +122,7 @@ (beginning-of-line) (when (> (skip-chars-forward ">") 0) (insert " ")))) + ;; XXX slightly buggy handling of "-- " (while (and (save-excursion (ignore-errors (backward-char 3)) (setq sig (looking-at "-- ")) @@ -86,17 +130,90 @@ (save-excursion (unless (eobp) (forward-char 1) - (looking-at (format "^\\(%s\\)\\([^>]\\)" (or quote " ?")))))) + (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)" + (or quote " ?")))))) (save-excursion (replace-match (if (string= (match-string 2) " ") "" "\\2"))) (backward-delete-char -1) (end-of-line)) (unless sig - (let ((fill-prefix (when quote (concat quote " ")))) - (fill-region (fill-flowed-point-at-bol) - (fill-flowed-point-at-eol) - 'left 'nosqueeze)))))))) + (condition-case nil + (let ((fill-prefix (when quote (concat quote " "))) + (fill-column (eval fill-flowed-display-column)) + filladapt-mode) + (fill-region (fill-flowed-point-at-bol) + (min (1+ (fill-flowed-point-at-eol)) + (point-max)) + 'left 'nosqueeze)) + (error + (forward-line 1) + nil)))))))) + +;; Test vectors. + +(eval-when-compile + (defvar show-trailing-whitespace)) + +(defvar fill-flowed-encode-tests + '( + ;; The syntax of each list element is: + ;; (INPUT . EXPECTED-OUTPUT) + ("> Thou villainous ill-breeding spongy dizzy-eyed +> reeky elf-skinned pigeon-egg! +>> Thou artless swag-bellied milk-livered +>> dismal-dreaming idle-headed scut! +>>> Thou errant folly-fallen spleeny reeling-ripe +>>> unmuzzled ratsbane! +>>>> Henceforth, the coding style is to be strictly +>>>> enforced, including the use of only upper case. +>>>>> I've noticed a lack of adherence to the coding +>>>>> styles, of late. +>>>>>> Any complaints? +" . "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned +> pigeon-egg! +>> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed +>> scut! +>>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane! +>>>> Henceforth, the coding style is to be strictly enforced, +>>>> including the use of only upper case. +>>>>> I've noticed a lack of adherence to the coding styles, of late. +>>>>>> Any complaints? +") +; (" +;> foo +;> +;> +;> bar +;" . " +;> foo bar +;") + )) + +(defun fill-flowed-test () + (interactive "") + (switch-to-buffer (get-buffer-create "*Format=Flowed test output*")) + (erase-buffer) + (setq show-trailing-whitespace t) + (dolist (test fill-flowed-encode-tests) + (let (start output) + (insert "***** BEGIN TEST INPUT *****\n") + (insert (car test)) + (insert "***** END TEST INPUT *****\n\n") + (insert "***** BEGIN TEST OUTPUT *****\n") + (setq start (point)) + (insert (car test)) + (save-restriction + (narrow-to-region start (point)) + (fill-flowed)) + (setq output (buffer-substring start (point-max))) + (insert "***** END TEST OUTPUT *****\n") + (unless (string= output (cdr test)) + (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n") + (insert (cdr test)) + (insert "***** END TEST EXPECTED OUTPUT *****\n")) + (insert "\n\n"))) + (goto-char (point-max))) (provide 'flow-fill)
--- a/lisp/gnus/followup.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/followup.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,54 +1,31 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 24 1", -" c Gray0", -". c Gray6", -"X c Gray9", -"o c Gray12", -"O c #2ff22ff22ff2", -"+ c #3fff3fff3fff", -"@ c Gray28", -"# c #53ed53ed53ed", -"$ c #5fee5fee5fee", -"% c #67e767e767e7", -"& c #6fff6fff6fff", -"* c #77f077f077f0", -"= c #7bdb7bdb7bdb", -"- c Gray50", -"; c Gray56", -": c #9bd79bd79bd7", -"> c #9fff9fff9fff", -", c #a7c7a7c7a7c7", -"< c Gray70", -"1 c Gray75", -"2 c Gray81", -"3 c #dfffdfffdfff", -"4 c #efffefffefff", -"5 c Gray100", -/* pixels */ -"<,1<,1<,1<,1<,1<,1<,1<,1", -",;1,;1,;1,;1,;1,;1,;1,;1", -"111111111111111111111111", -"<,1<,1<,1<,:=+.<,1<,1<,1", -",;1,;1,;1;O*>5+$;1,;1,;1", -"11111111##142+>O11111111", -"<,1<,:=+2555 o2#,1<,1<,1", -",;1;O*>5555>-151$1,;1,;1", -"111<@15555525554*:111111", -"<,1<$:5555555555>=<,1<,1", -",;1,;*>553--55555+,;1,;1", -"111111=>&$1O555552#11111", -"<,111:=+241$+55555#,1<,1", -",;1,$*>55$ 1+555551$1,;1", -"11##14555 $4>>55554*:111", -"<@155555&5551-55555>=<,1", -",O15555555553-355551o,;1", -"1,#55555555553$555+%;111", -"<,#25555555555&1*O<,1<,1", -",;1+55555555555X;1,;1,;1", -"111=>5555555555:*1111111", -"<,1:*45555555552%<<,1<,1", -",;11$15555555555-;,;1,;1", -"1111,#55555555553#111111" -}; +static char * followup_xpm[] = { +"24 24 4 1", +" c None", +". c #A5A5A5A59595", +"X c #C7C7C6C6C6C6", +"o c #E1E1E0E0E0E0", +" ", +" . ", +" ..X. ", +" ..XXX. ", +" ..XXXXXo. ", +" ...XXXXXXooo. . ", +" .o.XXXXXooooo..X. ", +" .oo.XXXoooo..XXX. ", +" .oo..Xooo..XXXXXo. ", +" .oo.XX...XXXXXXooo. ", +" .o.Xoo.o.XXXXXoooo. ", +" .XXoo.oo.XXXoooooo. ", +" .Xooo.oo..XXooooooo. ", +" .ooo.oo.XXooooooooo. ", +" .ooo.o.XoooooooooooX.", +" .ooo.XXoooooooooooo.", +" .ooo.Xoooooooooooo. ", +" .ooo.ooooooooooo. ", +" .oo..oooooooooo. ", +" .. .ooooooo.. ", +" .oooooo. ", +" .ooo.. ", +" .oo. ", +" .. "};
--- a/lisp/gnus/fuwo.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/fuwo.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,53 +1,31 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 23 1", -" c Gray0", -". c Gray6", -"X c Gray9", -"o c Gray12", -"O c #2fef2fef2fef", -"+ c #3fff3fff3fff", -"@ c #53ee53ee53ee", -"# c #5fe85fe85fe8", -"$ c #67e767e767e7", -"% c #6fff6fff6fff", -"& c #77ea77ea77ea", -"* c #7bdb7bdb7bdb", -"= c Gray50", -"- c Gray56", -"; c #9bd69bd69bd6", -": c #9fff9fff9fff", -"> c #a7c7a7c7a7c7", -", c Gray70", -"< c Gray75", -"1 c Gray81", -"2 c #dfffdfffdfff", -"3 c #efffefffefff", -"4 c Gray100", -/* pixels */ -",><,><,><,><,><,><,><,><", -">-<>-<>-<>-<>-<>-<>-<>-<", -"<<<<<<<<<<<<<<<<<<<<<<<<", -",><,><,><,><,><,><,><,><", -">-<>-<>-<>-<>-<>-<>-<>-<", -"<<<<<<<<<<<<;O;<<<<<<<<<", -",><,><,><,>< X;,><,><,><", -">-<>-<>-<>-&#-<>-<>-<>-<", -"<<<<<<<<<<<;<<<<<<<<<<<<", -",><,><,><,><,><,><,><,><", -">-<>-<>-<-O>>-<>-<>-<>-<", -"<<<<<<<<@@<@<<<<<<<<<<<<", -",><<<;*+1<<#;<<,><,><,><", -">-<>#&:<==+#&-<>-<>-<>-<", -"<<@@<3+=<1o <#<<<<<<<<<<", -",>O<=+444:+.4=-,><,><,><", -">-O=<4444:4::<$>-<>-<>-<", -"<&;444444444+4+<<<<<<<<<", -",#;444444444<=4O<<,><,><", -">-O4444444442=2&-<>-<>-<", -"<<;%444444444=<<#<<<<<<<", -",><@2444444444+4=-,><,><", -">-<-=444444444::<$>-<>-<", -"<<<,$1444444444+4+<<<<<<" -}; +static char * fuwo_xpm[] = { +"24 24 4 1", +" c None", +". c #A5A5A5A59595", +"X c #C7C7C6C6C6C6", +"o c #E1E1E0E0E0E0", +" ", +" . ", +" .. . ", +" .. . ", +" .. . ", +" ... . . ", +" . . ..X. ", +" . . ..XXX. ", +" . .. ..XXXXXo. ", +" . . ...XXXXXXooo. ", +" . .X .o.XXXXXoooo. ", +" .XX .oo.XXXoooooo. ", +" .X .oo..XXooooooo. ", +" . .oo.XXooooooooo. ", +" . .o.XoooooooooooX.", +" . .XXoooooooooooo.", +" . .Xoooooooooooo. ", +" . .ooooooooooo. ", +" . ..oooooooooo. ", +" .. .ooooooo.. ", +" .oooooo. ", +" .ooo.. ", +" .oo. ", +" .. "};
--- a/lisp/gnus/get-news.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/get-news.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,68 +1,31 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 38 1", -" c Gray0", -". c #0bfb0bfb0bfb", -"X c Gray6", -"o c #133313331333", -"O c Gray9", -"+ c Gray11", -"@ c Gray12", -"# c #23f323f323f3", -"$ c Gray15", -"% c #2ff32ff32ff3", -"& c #399939993999", -"* c #3fff3fff3fff", -"= c Gray25", -"- c #433243324332", -"; c Gray28", -": c #4ccc4ccc4ccc", -"> c #519151915191", -", c #53e753e753e7", -"< c #565a565a565a", -"1 c Gray35", -"2 c #5b1a5b1a5b1a", -"3 c #5fe55fe55fe5", -"4 c Gray45", -"5 c Gray46", -"6 c #77d777d777d7", -"7 c #7ccc7ccc7ccc", -"8 c Gray50", -"9 c #866586658665", -"0 c Gray56", -"q c Gray60", -"w c #9bcb9bcb9bcb", -"e c #9fff9fff9fff", -"r c #a7c7a7c7a7c7", -"t c Gray70", -"y c Gray75", -"u c Gray81", -"i c #dfffdfffdfff", -"p c Gray100", -/* pixels */ -"0000000ryyyyyyyyyyyyyyyy", -"@8888833yyyyyyyyyyyyyyyy", -"*pppppy3yyyyyyyyyyyyyyyy", -"*pppppy3yyyyyr=$$6yyyyyy", -"*ppppp3%3yyyr<9qq36yyyyy", -"*ppppp ;0>yy0:qqqq%yyyyy", -"*pppppy @82tq>0qq8>yyyyy", -"*pppppy%>q42y0>q42yyyyyy", -"*pppppy3q=q8%%.=:#%6yyyy", -"%yyyyy03y0:qqqqqqqq:0yyy", -"33333330yr<9qqqqqqq42yyy", -"yyyyyyyyyyr=qqqqqqqq$yyy", -"yyyyyyyyyyyy$:%***$q$**X", -"yyyyyyyyyyyy$:yppe3q$pp*", -"yyyyyyyyyyyy$:ypp*q3qpp*", -"yyyyyyyyyyyy$:yp8402upp*", -"yyyyyyyyyyyyo$yi*&48ppp*", -"yyyyyyyyyyy>4&u>00:ippp*", -"yyyyyyyyyyy%q:00Oq%yyyy%", -"yyyyyyyyyyy%q4:o<3&%3333", -"yyyyyyyyyyy%qqq$9443yyyy", -"yyyyyyyyyyy%44@0&4<3yyyy", -"yyyyyyyyyyy6o$;r%&O0yyyy", -"yyyyyyyyyyyy$:0y34%yyyyy" -}; +static char * get_news_xpm[] = { +"24 24 4 1", +". c None", +"X c #A5A5A5A59595", +"o c #E1E1E0E0E0E0", +"O c #C7C7C6C6C6C6", +"........................", +"........................", +"........................", +".....XXX................", +"...XXoooXXXXX...........", +"XXXoooooXXoooX.XXX......", +"XoXooXXXooooXXXoooX.....", +"XooXoXoXooXXXoooooX.....", +"XooXXXooXoXoXooooooX....", +"XooXOXooXXXooXooooooX...", +"XoXOOXooXOXooXXooooooX..", +"OXOOOXoXOOXooXoooooooX..", +"OXOooOXOOOXoXOooooooooX.", +".OXooOXOooOXOOooooooooX.", +".OXoooOXooOXOooooooooooX", +"..OXooOXoooOXooooooooooX", +"..OXooOOXooOXooooooooooX", +"...OXooOXoooOXoooooooXXX", +"...OXooXOXooOXooooooXOO.", +"....OXXOOXooXOXoooXXO...", +".....OO..OXXOOXooXOO....", +"..........OO..OXXO......", +"...............OO.......", +"........................"};
--- a/lisp/gnus/gnntg.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnntg.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,64 +1,31 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 34 1", -" c Gray0", -". c #099909990999", -"X c #0bfb0bfb0bfb", -"o c #133313331333", -"O c Gray9", -"+ c Gray11", -"@ c #23f323f323f3", -"# c Gray15", -"$ c #2fef2fef2fef", -"% c #399939993999", -"& c #3fff3fff3fff", -"* c Gray25", -"= c #433243324332", -"- c Gray28", -"; c #4ccc4ccc4ccc", -": c #519151915191", -"> c #566656665666", -", c #5fed5fed5fed", -"< c #626262626262", -"1 c Gray42", -"2 c Gray45", -"3 c Gray46", -"4 c #77d777d777d7", -"5 c #7ccc7ccc7ccc", -"6 c Gray50", -"7 c #866586658665", -"8 c Gray56", -"9 c Gray60", -"0 c #9bcb9bcb9bcb", -"q c #a7c7a7c7a7c7", -"w c Gray70", -"e c Gray75", -"r c #dfffdfffdfff", -"t c Gray100", -/* pixels */ -"w8888888weeeeeeeeeeeeeee", -"8&66666&8eeeeeeeeeeeeeee", -"86ttttt68eeeeeeeeeeeeeee", -"86ttttt68eeeee0###0eeeee", -"86ttttr&-4eee8:000:8eeee", -"86tttte 144ee,20002,eeee", -"86ttttt6 =,4e4<000<4eeee", -"86ttttt6-,0,4e4,0,4eeeee", -"86ttttt684,0<$$.,#$$0eee", -"8,eeeee,8e,200000000#eee", -"q,,,,,,,qe8:00000000,4ee", -"eeeeeeeeeee0=000006,0$ee", -"eeeeeeeeeeee8;00002;0$ee", -"eeeeeeeeeeee8;00002;0$ee", -"eeeeeeeeeeee8;00002;0$ee", -"eeeeeeeeeeee8;00002;0$ee", -"eeeeeeeeeeee8#;;;;%#;$ee", -"eeeeeeeeeeee=2222+88@0ee", -"eeeeeeeeeeee#00000.4$eee", -"eeeeeeeeeeee#00720O,,eee", -"eeeeeeeeeeee#002;02%8eee", -"eeeeeeeeeeee+22$,>2%8eee", -"eeeeeeeeeeee-#o48O%$qeee", -"eeeeeeeeeeee8;#ee$2,eeee" -}; +static char * gnntg_xpm[] = { +"24 24 4 1", +" c None", +". c #000000000000", +"X c #FFFFFFFFFFFF", +"o c #C7C7C6C6C6C6", +" ", +" ....... ", +" .XXXXX. ", +" .XXXXX. ... ", +" .XXXXX... .ooo. ", +" .XXXXX.... ..ooo.. ", +" .XXXXX..o.. ..ooo.. ", +" .XXXXX...o.. ..o.. ", +" .XXXXX. ..o........ ", +" .XXXXX. ..oooooooo. ", +" ....... .oooooooo.. ", +" .ooooo..o. ", +" .oooo..o. ", +" .oooo..o. ", +" .oooo..o. ", +" .oooo..o. ", +" ......... ", +" ......oo. ", +" .ooooo... ", +" .oo..o... ", +" .oo..o.. ", +" ........ ", +" .... ... ", +" ... ... "};
--- a/lisp/gnus/gnus-agent.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-agent.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; This file is part of GNU Emacs. @@ -25,15 +26,23 @@ (require 'gnus) (require 'gnus-cache) +(require 'nnmail) (require 'nnvirtual) (require 'gnus-sum) (require 'gnus-score) +(require 'gnus-srvr) +(require 'gnus-util) (eval-when-compile (if (featurep 'xemacs) (require 'itimer) (require 'timer)) (require 'cl)) +(eval-and-compile + (autoload 'gnus-server-update-server "gnus-srvr") + (autoload 'gnus-agent-customize-category "gnus-cus") +) + (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." :group 'gnus-agent @@ -49,15 +58,21 @@ :group 'gnus-agent :type 'hook) +(defcustom gnus-agent-fetched-hook nil + "Hook run when finished fetching articles." + :group 'gnus-agent + :type 'hook) + (defcustom gnus-agent-handle-level gnus-level-subscribed "Groups on levels higher than this variable will be ignored by the Agent." :group 'gnus-agent :type 'integer) (defcustom gnus-agent-expire-days 7 - "Read articles older than this will be expired." + "Read articles older than this will be expired. +If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'." :group 'gnus-agent - :type 'integer) + :type '(number :tag "days")) (defcustom gnus-agent-expire-all nil "If non-nil, also expire unread, ticked and dormant articles. @@ -70,16 +85,28 @@ :group 'gnus-agent :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)) + (defcustom gnus-agent-summary-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)) + (defcustom gnus-agent-server-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)) + (defcustom gnus-agent-confirmation-function 'y-or-n-p "Function to confirm when error happens." :version "21.1" @@ -95,13 +122,103 @@ (const :tag "Ask" ask)) :group 'gnus-agent) +(defcustom gnus-agent-go-online 'ask + "Indicate if offline servers go online when you plug in. +If this is `ask' the hook will query the user." + :version "21.1" + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :group 'gnus-agent) + +(defcustom gnus-agent-mark-unread-after-downloaded t + "Indicate whether to mark articles unread after downloaded." + :version "21.1" + :type 'boolean + :group 'gnus-agent) + +(defcustom gnus-agent-download-marks '(download) + "Marks for downloading." + :version "21.1" + :type '(repeat (symbol :tag "Mark")) + :group 'gnus-agent) + +(defcustom gnus-agent-consider-all-articles nil + "When non-nil, the agent will let the agent predicate decide +whether articles need to be downloaded or not, for all articles. When +nil, the default, the agent will only let the predicate decide +whether unread articles are downloaded or not. If you enable this, +groups with large active ranges may open slower and you may also want +to look into the agent expiry settings to block the expiration of +read articles as they would just be downloaded again." + :version "21.4" + :type 'boolean + :group 'gnus-agent) + +(defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb + "Chunk size for `gnus-agent-fetch-session'. +The function will split its article fetches into chunks smaller than +this limit." + :group 'gnus-agent + :type 'integer) + +(defcustom gnus-agent-enable-expiration 'ENABLE + "The default expiration state for each group. +When set to ENABLE, the default, `gnus-agent-expire' will expire old +contents from a group's local storage. This value may be overridden +to disable expiration in specific categories, topics, and groups. Of +course, you could change gnus-agent-enable-expiration to DISABLE then +enable expiration per categories, topics, and groups." + :group 'gnus-agent + :type '(radio (const :format "Enable " ENABLE) + (const :format "Disable " DISABLE))) + +(defcustom gnus-agent-expire-unagentized-dirs t + "*Whether expiration should expire in unagentized directories. +Have gnus-agent-expire scan the directories under +\(gnus-agent-directory) for groups that are no longer agentized. +When found, offer to remove them." + :type 'boolean + :group 'gnus-agent) + +(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap) + "Initially, all servers from these methods are agentized. +The user may remove or add servers using the Server buffer. +See Info node `(gnus)Server Buffer'." + :type '(repeat symbol) + :group 'gnus-agent) + +(defcustom gnus-agent-queue-mail t + "Whether and when outgoing mail should be queued by the agent. +When `always', always queue outgoing mail. When nil, never +queue. Otherwise, queue if and only if unplugged." + :group 'gnus-agent + :type '(radio (const :format "Always" always) + (const :format "Never" nil) + (const :format "When plugged" t))) + +(defcustom gnus-agent-prompt-send-queue nil + "If non-nil, `gnus-group-send-queue' will prompt if called when +unplugged." + :group 'gnus-agent + :type 'boolean) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) (defvar gnus-agent-buffer-alist nil) -(defvar gnus-agent-article-alist nil) +(defvar gnus-agent-article-alist nil + "An assoc list identifying the articles whose headers have been fetched. +If successfully fetched, these headers will be stored in the group's overview +file. The key of each assoc pair is the article ID, the value of each assoc +pair is a flag indicating whether the identified article has been downloaded +\(gnus-agent-fetch-articles sets the value to the day of the download). +NOTES: +1) The last element of this list can not be expired as some + routines (for example, get-agent-fetch-headers) use the last + value to track which articles have had their headers retrieved. +2) The function `gnus-agent-regenerate' may destructively modify the value.") (defvar gnus-agent-group-alist nil) -(defvar gnus-agent-covered-methods nil) (defvar gnus-category-alist nil) (defvar gnus-agent-current-history nil) (defvar gnus-agent-overview-buffer nil) @@ -111,6 +228,7 @@ (defvar gnus-agent-file-name nil) (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) +(defvar gnus-agent-file-loading-cache nil) ;; Dynamic variables (defvar gnus-headers) @@ -141,8 +259,7 @@ (gnus-add-shutdown 'gnus-close-agent 'gnus) (defun gnus-close-agent () - (setq gnus-agent-covered-methods nil - gnus-category-predicate-cache nil + (setq gnus-category-predicate-cache nil gnus-category-group-cache nil gnus-agent-spam-hashtb nil) (gnus-kill-buffer gnus-agent-overview-buffer)) @@ -176,18 +293,120 @@ (file-name-as-directory (expand-file-name "agent.lib" (gnus-agent-directory))))) +(defun gnus-agent-cat-set-property (category property value) + (if value + (setcdr (or (assq property category) + (let ((cell (cons property nil))) + (setcdr category (cons cell (cdr category))) + cell)) value) + (let ((category category)) + (while (cond ((eq property (caadr category)) + (setcdr category (cddr category)) + nil) + (t + (setq category (cdr category))))))) + category) + +(eval-when-compile + (defmacro gnus-agent-cat-defaccessor (name prop-name) + "Define accessor and setter methods for manipulating a list of the form +\(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)). +Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be +manipulated as follows: + (func LIST): Returns VALUE1 + (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1." + `(progn (defmacro ,name (category) + (list (quote cdr) (list (quote assq) + (quote (quote ,prop-name)) category))) + + (define-setf-method ,name (category) + (let* ((--category--temp-- (make-symbol "--category--")) + (--value--temp-- (make-symbol "--value--"))) + (list (list --category--temp--) ; temporary-variables + (list category) ; value-forms + (list --value--temp--) ; store-variables + (let* ((category --category--temp--) ; store-form + (value --value--temp--)) + (list (quote gnus-agent-cat-set-property) + category + (quote (quote ,prop-name)) + value)) + (list (quote ,name) --category--temp--) ; access-form + ))))) + ) + +(defmacro gnus-agent-cat-name (category) + `(car ,category)) + +(gnus-agent-cat-defaccessor + gnus-agent-cat-days-until-old agent-days-until-old) +(gnus-agent-cat-defaccessor + gnus-agent-cat-enable-expiration agent-enable-expiration) +(gnus-agent-cat-defaccessor + gnus-agent-cat-groups agent-groups) +(gnus-agent-cat-defaccessor + gnus-agent-cat-high-score agent-high-score) +(gnus-agent-cat-defaccessor + gnus-agent-cat-length-when-long agent-length-when-long) +(gnus-agent-cat-defaccessor + gnus-agent-cat-length-when-short agent-length-when-short) +(gnus-agent-cat-defaccessor + gnus-agent-cat-low-score agent-low-score) +(gnus-agent-cat-defaccessor + gnus-agent-cat-predicate agent-predicate) +(gnus-agent-cat-defaccessor + gnus-agent-cat-score-file agent-score-file) +(gnus-agent-cat-defaccessor + gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) + +(eval-and-compile + (defsetf gnus-agent-cat-groups (category) (groups) + (list 'gnus-agent-set-cat-groups category groups))) + +(defun gnus-agent-set-cat-groups (category groups) + (unless (eq groups 'ignore) + (let ((new-g groups) + (old-g (gnus-agent-cat-groups category))) + (cond ((eq new-g old-g) + ;; gnus-agent-add-group is fiddling with the group + ;; list. Still, Im done. + nil + ) + ((eq new-g (cdr old-g)) + ;; gnus-agent-add-group is fiddling with the group list + (setcdr (or (assq 'agent-groups category) + (let ((cell (cons 'agent-groups nil))) + (setcdr category (cons cell (cdr category))) + cell)) new-g)) + (t + (let ((groups groups)) + (while groups + (let* ((group (pop groups)) + (old-category (gnus-group-category group))) + (if (eq category old-category) + nil + (setf (gnus-agent-cat-groups old-category) + (delete group (gnus-agent-cat-groups + old-category)))))) + ;; Purge cache as preceeding loop invalidated it. + (setq gnus-category-group-cache nil)) + + (setcdr (or (assq 'agent-groups category) + (let ((cell (cons 'agent-groups nil))) + (setcdr category (cons cell (cdr category))) + cell)) groups)))))) + +(defsubst gnus-agent-cat-make (name &optional default-agent-predicate) + (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) + ;;; Fetching setup functions. (defun gnus-agent-start-fetch () "Initialize data structures for efficient fetching." - (gnus-agent-open-history) - (setq gnus-agent-current-history (gnus-agent-history-buffer)) (gnus-agent-create-buffer)) (defun gnus-agent-stop-fetch () "Save all data structures and clean up." - (gnus-agent-save-history) - (gnus-agent-close-history) (setq gnus-agent-spam-hashtb nil) (save-excursion (set-buffer nntp-server-buffer) @@ -204,6 +423,13 @@ (put 'gnus-agent-with-fetch 'lisp-indent-function 0) (put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) +(defmacro gnus-agent-append-to-list (tail value) + `(setq ,tail (setcdr ,tail (cons ,value nil)))) + +(defmacro gnus-agent-message (level &rest args) + `(if (<= ,level gnus-verbose) + (message ,@args))) + ;;; ;;; Mode infestation ;;; @@ -233,7 +459,13 @@ buffer)))) minor-mode-map-alist)) (when (eq major-mode 'gnus-group-mode) - (gnus-agent-toggle-plugged gnus-plugged)) + (let ((init-plugged gnus-plugged) + (gnus-agent-go-online nil)) + ;; g-a-t-p does nothing when gnus-plugged isn't changed. + ;; Therefore, make certain that the current value does not + ;; match the desired initial value. + (setq gnus-plugged :unknown) + (gnus-agent-toggle-plugged init-plugged))) (gnus-run-hooks 'gnus-agent-mode-hook (intern (format "gnus-agent-%s-mode-hook" buffer))))) @@ -244,9 +476,10 @@ "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session "JY" gnus-agent-synchronize-flags - "JS" gnus-group-send-drafts + "JS" gnus-group-send-queue "Ja" gnus-agent-add-group - "Jr" gnus-agent-remove-group) + "Jr" gnus-agent-remove-group + "Jo" gnus-agent-toggle-group-plugged) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -254,15 +487,23 @@ gnus-agent-group-menu gnus-agent-group-mode-map "" '("Agent" ["Toggle plugged" gnus-agent-toggle-plugged t] + ["Toggle group plugged" gnus-agent-toggle-group-plugged t] ["List categories" gnus-enter-category-buffer t] - ["Send drafts" gnus-group-send-drafts gnus-plugged] + ["Add (current) group to category" gnus-agent-add-group t] + ["Remove (current) group from category" gnus-agent-remove-group t] + ["Send queue" gnus-group-send-queue gnus-plugged] ("Fetch" ["All" gnus-agent-fetch-session gnus-plugged] - ["Group" gnus-agent-fetch-group gnus-plugged]))))) + ["Group" gnus-agent-fetch-group gnus-plugged]) + ["Synchronize flags" gnus-agent-synchronize-flags t] + )))) (defvar gnus-agent-summary-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-agent-summary-mode-map "Jj" gnus-agent-toggle-plugged + "Ju" gnus-agent-summary-fetch-group + "JS" gnus-agent-fetch-group + "Js" gnus-agent-summary-fetch-series "J#" gnus-agent-mark-article "J\M-#" gnus-agent-unmark-article "@" gnus-agent-toggle-mark @@ -277,6 +518,7 @@ ["Mark as downloadable" gnus-agent-mark-article t] ["Unmark as downloadable" gnus-agent-unmark-article t] ["Toggle mark" gnus-agent-toggle-mark t] + ["Fetch downloadable" gnus-agent-summary-fetch-group t] ["Catchup undownloaded" gnus-agent-catchup t])))) (defvar gnus-agent-server-mode-map (make-sparse-keymap)) @@ -294,24 +536,50 @@ ["Add" gnus-agent-add-server t] ["Remove" gnus-agent-remove-server t])))) -(defun gnus-agent-toggle-plugged (plugged) +(defun gnus-agent-make-mode-line-string (string mouse-button mouse-func) + (if (and (fboundp 'propertize) + (fboundp 'make-mode-line-mouse-map)) + (propertize string 'local-map + (make-mode-line-mouse-map mouse-button mouse-func)) + string)) + +(defun gnus-agent-toggle-plugged (set-to) "Toggle whether Gnus is unplugged or not." (interactive (list (not gnus-plugged))) - (if plugged - (progn - (setq gnus-plugged plugged) - (gnus-agent-possibly-synchronize-flags) - (gnus-run-hooks 'gnus-agent-plugged-hook) - (setcar (cdr gnus-agent-mode-status) " Plugged")) - (gnus-agent-close-connections) - (setq gnus-plugged plugged) - (gnus-run-hooks 'gnus-agent-unplugged-hook) - (setcar (cdr gnus-agent-mode-status) " Unplugged")) + (cond ((eq set-to gnus-plugged) + nil) + (set-to + (setq gnus-plugged set-to) + (gnus-run-hooks 'gnus-agent-plugged-hook) + (setcar (cdr gnus-agent-mode-status) + (gnus-agent-make-mode-line-string " Plugged" + 'mouse-2 + 'gnus-agent-toggle-plugged)) + (gnus-agent-go-online gnus-agent-go-online) + (gnus-agent-possibly-synchronize-flags)) + (t + (gnus-agent-close-connections) + (setq gnus-plugged set-to) + (gnus-run-hooks 'gnus-agent-unplugged-hook) + (setcar (cdr gnus-agent-mode-status) + (gnus-agent-make-mode-line-string " Unplugged" + 'mouse-2 + 'gnus-agent-toggle-plugged)))) (set-buffer-modified-p t)) +(defmacro gnus-agent-while-plugged (&rest body) + `(let ((original-gnus-plugged gnus-plugged)) + (unwind-protect + (progn (gnus-agent-toggle-plugged t) + ,@body) + (gnus-agent-toggle-plugged original-gnus-plugged)))) + +(put 'gnus-agent-while-plugged 'lisp-indent-function 0) +(put 'gnus-agent-while-plugged 'edebug-form-spec '(body)) + (defun gnus-agent-close-connections () "Close all methods covered by the Gnus agent." - (let ((methods gnus-agent-covered-methods)) + (let ((methods (gnus-agent-covered-methods))) (while methods (gnus-close-server (pop methods))))) @@ -330,36 +598,64 @@ (gnus)) ;;;###autoload +(defun gnus-slave-unplugged (&optional arg) + "Read news as a slave unplugged." + (interactive "P") + (setq gnus-plugged nil) + (gnus arg nil 'slave)) + +;;;###autoload (defun gnus-agentize () "Allow Gnus to be an offline newsreader. -The normal usage of this command is to put the following as the -last form in your `.gnus.el' file: - -\(gnus-agentize) - -This will modify the `gnus-before-startup-hook', `gnus-post-method', -and `message-send-mail-function' variables, and install the Gnus -agent minor mode in all Gnus buffers." + +The gnus-agentize function is now called internally by gnus when +gnus-agent is set. If you wish to avoid calling gnus-agentize, +customize gnus-agent to nil. + +This will modify the `gnus-setup-news-hook', and +`message-send-mail-real-function' variables, and install the Gnus agent +minor mode in all Gnus buffers." (interactive) (gnus-open-agent) (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) (unless gnus-agent-send-mail-function - (setq gnus-agent-send-mail-function message-send-mail-function - message-send-mail-function 'gnus-agent-send-mail)) - (unless gnus-agent-covered-methods - (setq gnus-agent-covered-methods (list gnus-select-method)))) - -(defun gnus-agent-queue-setup () - "Make sure the queue group exists." - (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb) - (gnus-request-create-group "queue" '(nndraft "")) + (setq gnus-agent-send-mail-function + (or message-send-mail-real-function + message-send-mail-function) + message-send-mail-real-function 'gnus-agent-send-mail)) + + ;; If the servers file doesn't exist, auto-agentize some servers and + ;; save the servers file so this auto-agentizing isn't invoked + ;; again. + (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers")) + (gnus-message 3 "First time agent user, agentizing remote groups...") + (mapc + (lambda (server-or-method) + (let ((method (gnus-server-to-method server-or-method))) + (when (memq (car method) + gnus-agent-auto-agentize-methods) + (push (gnus-method-to-server method) + gnus-agent-covered-methods) + (setq gnus-agent-method-p-cache nil)))) + (cons gnus-select-method gnus-secondary-select-methods)) + (gnus-agent-write-servers))) + +(defun gnus-agent-queue-setup (&optional group-name) + "Make sure the queue group exists. +Optional arg GROUP-NAME allows to specify another group." + (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) + gnus-newsrc-hashtb) + (gnus-request-create-group (or group-name "queue") '(nndraft "")) (let ((gnus-level-default-subscribed 1)) - (gnus-subscribe-group "nndraft:queue" nil '(nndraft ""))) + (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) + nil '(nndraft ""))) (gnus-group-set-parameter - "nndraft:queue" 'gnus-dummy '((gnus-draft-mode))))) + (format "nndraft:%s" (or group-name "queue")) + 'gnus-dummy '((gnus-draft-mode))))) (defun gnus-agent-send-mail () - (if gnus-plugged + (if (or (not gnus-agent-queue-mail) + (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) (funcall gnus-agent-send-mail-function) (goto-char (point-min)) (re-search-forward @@ -370,7 +666,7 @@ (defun gnus-agent-insert-meta-information (type &optional method) "Insert meta-information into the message that says how it's to be posted. -TYPE can be either `mail' or `news'. If the latter METHOD can +TYPE can be either `mail' or `news'. If the latter, then METHOD can be a select method." (save-excursion (message-remove-header gnus-agent-meta-information-header) @@ -400,11 +696,11 @@ gcc " ,"))))) covered) (while (and (not covered) methods) - (setq covered - (member (car methods) gnus-agent-covered-methods) + (setq covered (gnus-agent-method-p (car methods)) methods (cdr methods))) covered))) +;;;###autoload (defun gnus-agent-possibly-save-gcc () "Save GCC if Gnus is unplugged." (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) @@ -430,17 +726,18 @@ (error "Groups can't be fetched when Gnus is unplugged")) (gnus-group-iterate n 'gnus-agent-fetch-group)) -(defun gnus-agent-fetch-group (group) +(defun gnus-agent-fetch-group (&optional group) "Put all new articles in GROUP into the Agent." (interactive (list (gnus-group-group-name))) - (unless gnus-plugged - (error "Groups can't be fetched when Gnus is unplugged")) + (setq group (or group gnus-newsgroup-name)) (unless group (error "No group on the current line")) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (gnus-agent-with-fetch - (gnus-agent-fetch-group-1 group gnus-command-method) - (gnus-message 5 "Fetching %s...done" group)))) + + (gnus-agent-while-plugged + (let ((gnus-command-method (gnus-find-method-for-group group))) + (gnus-agent-with-fetch + (gnus-agent-fetch-group-1 group gnus-command-method) + (gnus-message 5 "Fetching %s...done" group))))) (defun gnus-agent-add-group (category arg) "Add the current group to an agent category." @@ -457,10 +754,12 @@ c groups) (gnus-group-iterate arg (lambda (group) - (when (cadddr (setq c (gnus-group-category group))) - (setf (cadddr c) (delete group (cadddr c)))) + (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) + (setf (gnus-agent-cat-groups c) + (delete group (gnus-agent-cat-groups c)))) (push group groups))) - (setf (cadddr cat) (nconc (cadddr cat) groups)) + (setf (gnus-agent-cat-groups cat) + (nconc (gnus-agent-cat-groups cat) groups)) (gnus-category-write))) (defun gnus-agent-remove-group (arg) @@ -469,15 +768,16 @@ (let (c) (gnus-group-iterate arg (lambda (group) - (when (cadddr (setq c (gnus-group-category group))) - (setf (cadddr c) (delete group (cadddr c)))))) + (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) + (setf (gnus-agent-cat-groups c) + (delete group (gnus-agent-cat-groups c)))))) (gnus-category-write))) (defun gnus-agent-synchronize-flags () "Synchronize unplugged flags with servers." (interactive) (save-excursion - (dolist (gnus-command-method gnus-agent-covered-methods) + (dolist (gnus-command-method (gnus-agent-covered-methods)) (when (file-exists-p (gnus-agent-lib-file "flags")) (gnus-agent-synchronize-flags-server gnus-command-method))))) @@ -485,7 +785,7 @@ "Synchronize flags according to `gnus-agent-synchronize-flags'." (interactive) (save-excursion - (dolist (gnus-command-method gnus-agent-covered-methods) + (dolist (gnus-command-method (gnus-agent-covered-methods)) (when (file-exists-p (gnus-agent-lib-file "flags")) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) @@ -497,11 +797,10 @@ (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) (if (null (gnus-check-server gnus-command-method)) - (message "Couldn't open server %s" (nth 1 gnus-command-method)) + (gnus-message 1 "Couldn't open server %s" (nth 1 gnus-command-method)) (while (not (eobp)) (if (null (eval (read (current-buffer)))) - (progn (forward-line) - (kill-line -1)) + (gnus-delete-line) (write-file (gnus-agent-lib-file "flags")) (error "Couldn't set flags from file %s" (gnus-agent-lib-file "flags")))) @@ -521,36 +820,80 @@ ;;; Server mode commands ;;; -(defun gnus-agent-add-server (server) +(defun gnus-agent-add-server () "Enroll SERVER in the agent program." - (interactive (list (gnus-server-server-name))) - (unless server - (error "No server on the current line")) - (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) - (when (member method gnus-agent-covered-methods) + (interactive) + (let* ((server (gnus-server-server-name)) + (named-server (gnus-server-named-server)) + (method (and server + (gnus-server-get-method nil server)))) + (unless server + (error "No server on the current line")) + + (when (gnus-agent-method-p method) (error "Server already in the agent program")) - (push method gnus-agent-covered-methods) + + (push named-server gnus-agent-covered-methods) + + (setq gnus-agent-method-p-cache nil) + (gnus-server-update-server server) (gnus-agent-write-servers) - (message "Entered %s into the Agent" server))) - -(defun gnus-agent-remove-server (server) + (gnus-message 1 "Entered %s into the Agent" server))) + +(defun gnus-agent-remove-server () "Remove SERVER from the agent program." - (interactive (list (gnus-server-server-name))) - (unless server - (error "No server on the current line")) - (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) - (unless (member method gnus-agent-covered-methods) + (interactive) + (let* ((server (gnus-server-server-name)) + (named-server (gnus-server-named-server))) + (unless server + (error "No server on the current line")) + + (unless (member named-server gnus-agent-covered-methods) (error "Server not in the agent program")) - (setq gnus-agent-covered-methods - (delete method gnus-agent-covered-methods)) + + (setq gnus-agent-covered-methods + (delete named-server gnus-agent-covered-methods) + gnus-agent-method-p-cache nil) + + (gnus-server-update-server server) (gnus-agent-write-servers) - (message "Removed %s from the agent" server))) + (gnus-message 1 "Removed %s from the agent" server))) (defun gnus-agent-read-servers () "Read the alist of covered servers." + (setq gnus-agent-covered-methods + (gnus-agent-read-file + (nnheader-concat gnus-agent-directory "lib/servers")) + gnus-agent-method-p-cache nil) + + ;; I am called so early in start-up that I can not validate server + ;; names. When that is the case, I skip the validation. That is + ;; alright as the gnus startup code calls the validate methods + ;; directly. + (if gnus-server-alist + (gnus-agent-read-servers-validate))) + +(defun gnus-agent-read-servers-validate () + (mapcar (lambda (server-or-method) + (let* ((server (if (stringp server-or-method) + server-or-method + (gnus-method-to-server server-or-method))) + (method (gnus-server-to-method server))) + (if method + (unless (member server gnus-agent-covered-methods) + (push server gnus-agent-covered-methods) + (setq gnus-agent-method-p-cache nil)) + (gnus-message 1 "Ignoring disappeared server `%s'" server)))) + (prog1 gnus-agent-covered-methods + (setq gnus-agent-covered-methods nil)))) + +(defun gnus-agent-read-servers-validate-native (native-method) (setq gnus-agent-covered-methods - (gnus-agent-read-file - (nnheader-concat gnus-agent-directory "lib/servers")))) + (mapcar (lambda (method) + (if (or (not method) + (equal method native-method)) + "native" + method)) gnus-agent-covered-methods))) (defun gnus-agent-write-servers () "Write the alist of covered servers." @@ -558,7 +901,8 @@ (let ((coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") - (prin1 gnus-agent-covered-methods (current-buffer))))) + (prin1 gnus-agent-covered-methods + (current-buffer))))) ;;; ;;; Summary commands @@ -600,155 +944,306 @@ (gnus-agent-mark-article n 'toggle)) (defun gnus-summary-set-agent-mark (article &optional unmark) - "Mark ARTICLE as downloadable." - (let ((unmark (if (and (not (null unmark)) (not (eq t unmark))) - (memq article gnus-newsgroup-downloadable) - unmark))) - (if unmark - (progn - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable)) - (push article gnus-newsgroup-undownloaded)) - (setq gnus-newsgroup-undownloaded - (delq article gnus-newsgroup-undownloaded)) - (push article gnus-newsgroup-downloadable)) - (gnus-summary-update-mark - (if unmark gnus-undownloaded-mark gnus-downloadable-mark) - 'unread))) + "Mark ARTICLE as downloadable. If UNMARK is nil, article is marked. +When UNMARK is t, the article is unmarked. For any other value, the +article's mark is toggled." + (let ((unmark (cond ((eq nil unmark) + nil) + ((eq t unmark) + t) + (t + (memq article gnus-newsgroup-downloadable))))) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-mark + (if unmark + (progn + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable)) + (gnus-article-mark article)) + (setq gnus-newsgroup-downloadable + (gnus-add-to-sorted-list gnus-newsgroup-downloadable article)) + gnus-downloadable-mark) + 'unread)))) (defun gnus-agent-get-undownloaded-list () - "Mark all unfetched articles as read." + "Construct list of articles that have not been downloaded." (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) - (when (and (not gnus-plugged) - (gnus-agent-method-p gnus-command-method)) - (gnus-agent-load-alist gnus-newsgroup-name) - ;; First mark all undownloaded articles as undownloaded. - (let ((articles (append gnus-newsgroup-unreads - gnus-newsgroup-marked - gnus-newsgroup-dormant)) - article) - (while (setq article (pop articles)) - (unless (or (cdr (assq article gnus-agent-article-alist)) - (memq article gnus-newsgroup-downloadable) - (memq article gnus-newsgroup-cached)) - (push article gnus-newsgroup-undownloaded)))) - ;; Then mark downloaded downloadable as not-downloadable, - ;; if you get my drift. - (let ((articles gnus-newsgroup-downloadable) - article) - (while (setq article (pop articles)) - (when (cdr (assq article gnus-agent-article-alist)) - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable)))))))) + (when (set (make-local-variable 'gnus-newsgroup-agentized) + (gnus-agent-method-p gnus-command-method)) + (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name)) + (headers (sort (mapcar (lambda (h) + (mail-header-number h)) + gnus-newsgroup-headers) '<)) + (cached (and gnus-use-cache gnus-newsgroup-cached)) + (undownloaded (list nil)) + (tail-undownloaded undownloaded) + (unfetched (list nil)) + (tail-unfetched unfetched)) + (while (and alist headers) + (let ((a (caar alist)) + (h (car headers))) + (cond ((< a h) + ;; Ignore IDs in the alist that are not being + ;; displayed in the summary. + (setq alist (cdr alist))) + ((> a h) + ;; Headers that are not in the alist should be + ;; fictious (see nnagent-retrieve-headers); they + ;; imply that this article isn't in the agent. + (gnus-agent-append-to-list tail-undownloaded h) + (gnus-agent-append-to-list tail-unfetched h) + (setq headers (cdr headers))) + ((cdar alist) + (setq alist (cdr alist)) + (setq headers (cdr headers)) + nil ; ignore already downloaded + ) + (t + (setq alist (cdr alist)) + (setq headers (cdr headers)) + + ;; This article isn't in the agent. Check to see + ;; if it is in the cache. If it is, it's been + ;; downloaded. + (while (and cached (< (car cached) a)) + (setq cached (cdr cached))) + (unless (equal a (car cached)) + (gnus-agent-append-to-list tail-undownloaded a)))))) + + (while headers + (let ((num (pop headers))) + (gnus-agent-append-to-list tail-undownloaded num) + (gnus-agent-append-to-list tail-unfetched num))) + + (setq gnus-newsgroup-undownloaded (cdr undownloaded) + gnus-newsgroup-unfetched (cdr unfetched)))))) (defun gnus-agent-catchup () - "Mark all undownloaded articles as read." + "Mark as read all unhandled articles. +An article is unhandled if it is neither cached, nor downloaded, nor +downloadable." (interactive) (save-excursion - (while gnus-newsgroup-undownloaded - (gnus-summary-mark-article - (pop gnus-newsgroup-undownloaded) gnus-catchup-mark))) - (gnus-summary-position-point)) + (let ((articles gnus-newsgroup-undownloaded)) + (when (or gnus-newsgroup-downloadable + gnus-newsgroup-cached) + (setq articles (gnus-sorted-ndifference + (gnus-sorted-ndifference + (gnus-copy-sequence articles) + gnus-newsgroup-downloadable) + gnus-newsgroup-cached))) + + (while articles + (gnus-summary-mark-article + (pop articles) gnus-catchup-mark))) + (gnus-summary-position-point))) + +(defun gnus-agent-summary-fetch-series () + (interactive) + (when gnus-newsgroup-processable + (setq gnus-newsgroup-downloadable + (let* ((dl gnus-newsgroup-downloadable) + (gnus-newsgroup-downloadable + (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) + (fetched-articles (gnus-agent-summary-fetch-group))) + ;; The preceeding call to (gnus-agent-summary-fetch-group) + ;; updated gnus-newsgroup-downloadable to remove each + ;; article successfully fetched. + + ;; For each article that I processed, remove its + ;; processable mark IF the article is no longer + ;; downloadable (i.e. it's already downloaded) + (dolist (article gnus-newsgroup-processable) + (unless (memq article gnus-newsgroup-downloadable) + (gnus-summary-remove-process-mark article))) + (gnus-sorted-ndifference dl fetched-articles))))) + +(defun gnus-agent-summary-fetch-group (&optional all) + "Fetch the downloadable articles in the group. +Optional arg ALL, if non-nil, means to fetch all articles." + (interactive "P") + (let ((articles + (if all gnus-newsgroup-articles + gnus-newsgroup-downloadable)) + (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)) + fetched-articles) + (gnus-agent-while-plugged + (unless articles + (error "No articles to download")) + (gnus-agent-with-fetch + (setq gnus-newsgroup-undownloaded + (gnus-sorted-ndifference + gnus-newsgroup-undownloaded + (setq fetched-articles + (gnus-agent-fetch-articles + gnus-newsgroup-name articles))))) + (save-excursion + (dolist (article articles) + (let ((was-marked-downloadable + (memq article gnus-newsgroup-downloadable))) + (cond (gnus-agent-mark-unread-after-downloaded + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable)) + + (gnus-summary-mark-article article gnus-unread-mark)) + (was-marked-downloadable + (gnus-summary-set-agent-mark article t))) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-download-mark article)))))) + fetched-articles)) + +(defun gnus-agent-fetch-selected-article () + "Fetch the current article as it is selected. +This can be added to `gnus-select-article-hook' or +`gnus-mark-article-hook'." + (let ((gnus-command-method gnus-current-select-method)) + (when (and gnus-plugged (gnus-agent-method-p gnus-command-method)) + (when (gnus-agent-fetch-articles + gnus-newsgroup-name + (list gnus-current-article)) + (setq gnus-newsgroup-undownloaded + (delq gnus-current-article gnus-newsgroup-undownloaded)) + (gnus-summary-update-download-mark gnus-current-article))))) ;;; ;;; Internal functions ;;; (defun gnus-agent-save-active (method) - (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format)) - -(defun gnus-agent-save-active-1 (method function) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) (new (gnus-make-hashtable (count-lines (point-min) (point-max)))) (file (gnus-agent-lib-file "active"))) - (funcall function nil new) + (gnus-active-to-gnus-format nil new) (gnus-agent-write-active file new) (erase-buffer) (nnheader-insert-file-contents file)))) (defun gnus-agent-write-active (file new) - (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max)))) - (file (gnus-agent-lib-file "active")) - elem osym) - (when (file-exists-p file) - (with-temp-buffer - (nnheader-insert-file-contents file) - (gnus-active-to-gnus-format nil orig)) - (mapatoms - (lambda (sym) - (when (and sym (boundp sym)) - (if (and (boundp (setq osym (intern (symbol-name sym) orig))) - (setq elem (symbol-value osym))) - (setcdr elem (cdr (symbol-value sym))) - (set (intern (symbol-name sym) orig) (symbol-value sym))))) - new)) (gnus-make-directory (file-name-directory file)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - ;; The hashtable contains real names of groups, no more prefix - ;; removing, so set `full' to `t'. - (gnus-write-active-file file orig t)))) - -(defun gnus-agent-save-groups (method) - (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) + (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) + ;; The hashtable contains real names of groups. However, do NOT + ;; add the foreign server prefix as gnus-active-to-gnus-format + ;; will add it while reading the file. + (gnus-write-active-file file new nil))) + +(defun gnus-agent-possibly-alter-active (group active &optional info) + "Possibly expand a group's active range to include articles +downloaded into the agent." + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group)))) + (when (gnus-agent-method-p gnus-command-method) + (let* ((local (gnus-agent-get-local group)) + (active-min (or (car active) 0)) + (active-max (or (cdr active) 0)) + (agent-min (or (car local) active-min)) + (agent-max (or (cdr local) active-max))) + + (when (< agent-min active-min) + (setcar active agent-min)) + + (when (> agent-max active-max) + (setcdr active agent-max)) + + (when (and info (< agent-max (- active-min 100))) + ;; I'm expanding the active range by such a large amount + ;; that there is a gap of more than 100 articles between the + ;; last article known to the agent and the first article + ;; currently available on the server. This gap contains + ;; articles that have been lost, mark them as read so that + ;; gnus doesn't waste resources trying to fetch them. + + ;; NOTE: I don't do this for smaller gaps (< 100) as I don't + ;; want to modify the local file everytime someone restarts + ;; gnus. The small gap will cause a tiny performance hit + ;; when gnus tries, and fails, to retrieve the articles. + ;; Still that should be smaller than opening a buffer, + ;; printing this list to the buffer, and then writing it to a + ;; file. + + (let ((read (gnus-info-read info))) + (gnus-info-set-read + info + (gnus-range-add + read + (list (cons (1+ agent-max) + (1- active-min)))))) + + ;; Lie about the agent's local range for this group to + ;; disable the set read each time this server is opened. + ;; NOTE: Opening this group will restore the valid local + ;; range but it will also expand the local range to + ;; incompass the new active range. + (gnus-agent-set-local group agent-min (1- active-min))))))) (defun gnus-agent-save-group-info (method group active) + "Update a single group's active range in the agent's copy of the server's active file." (when (gnus-agent-method-p method) (let* ((gnus-command-method method) (coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system) (file (gnus-agent-lib-file "active")) - oactive) + oactive-min oactive-max) (gnus-make-directory (file-name-directory file)) (with-temp-file file ;; Emacs got problem to match non-ASCII group in multibyte buffer. (mm-disable-multibyte) (when (file-exists-p file) - (nnheader-insert-file-contents file)) - (goto-char (point-min)) - (when (re-search-forward - (concat "^" (regexp-quote group) " ") nil t) - (save-excursion - (save-restriction - (narrow-to-region (match-beginning 0) - (progn - (forward-line 1) - (point))) - (setq oactive (car (nnmail-parse-active))))) - (gnus-delete-line)) + (nnheader-insert-file-contents file) + + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote group) " ") nil t) + (save-excursion + (setq oactive-max (read (current-buffer)) ;; max + oactive-min (read (current-buffer)))) ;; min + (gnus-delete-line))) (insert (format "%S %d %d y\n" (intern group) - (cdr active) - (or (car oactive) (car active)))) + (max (or oactive-max (cdr active)) (cdr active)) + (min (or oactive-min (car active)) (car active)))) (goto-char (point-max)) (while (search-backward "\\." nil t) (delete-char 1)))))) (defun gnus-agent-group-path (group) "Translate GROUP into a file name." - (if nnmail-use-long-file-names - (gnus-group-real-name group) - (nnheader-translate-file-chars - (nnheader-replace-chars-in-string - (nnheader-replace-duplicate-chars-in-string - (nnheader-replace-chars-in-string - (gnus-group-real-name group) - ?/ ?_) - ?. ?_) - ?. ?/)))) - - - -(defun gnus-agent-method-p (method) - "Say whether METHOD is covered by the agent." - (member method gnus-agent-covered-methods)) + + ;; NOTE: This is what nnmail-group-pathname does as of Apr 2003. + ;; The two methods must be kept synchronized, which is why + ;; gnus-agent-group-pathname was added. + + (setq group + (nnheader-translate-file-chars + (nnheader-replace-duplicate-chars-in-string + (nnheader-replace-chars-in-string + (gnus-group-real-name group) + ?/ ?_) + ?. ?_))) + (if (or nnmail-use-long-file-names + (file-directory-p (expand-file-name group (gnus-agent-directory)))) + group + (mm-encode-coding-string + (nnheader-replace-chars-in-string group ?. ?/) + nnmail-pathname-coding-system))) + +(defun gnus-agent-group-pathname (group) + "Translate GROUP into a file name." + ;; nnagent uses nnmail-group-pathname to read articles while + ;; unplugged. The agent must, therefore, use the same directory + ;; while plugged. + (let ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group)))) + (nnmail-group-pathname (gnus-group-real-name group) (gnus-agent-directory)))) (defun gnus-agent-get-function (method) - (if (and (not gnus-plugged) - (gnus-agent-method-p method)) - (progn - (require 'nnagent) - 'nnagent) - (car method))) + (if (gnus-online method) + (car method) + (require 'nnagent) + 'nnagent)) + +(defun gnus-agent-covered-methods () + "Return the subset of methods that are covered by the agent." + (delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods))) ;;; History functions @@ -770,14 +1265,6 @@ (nnheader-insert-file-contents file)) (set (make-local-variable 'gnus-agent-file-name) file)))) -(defun gnus-agent-save-history () - (save-excursion - (set-buffer gnus-agent-current-history) - (gnus-make-directory (file-name-directory gnus-agent-file-name)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (1+ (point-min)) (point-max) - gnus-agent-file-name nil 'silent)))) - (defun gnus-agent-close-history () (when (gnus-buffer-live-p gnus-agent-current-history) (kill-buffer gnus-agent-current-history) @@ -785,37 +1272,6 @@ (delq (assoc (gnus-agent-method) gnus-agent-history-buffers) gnus-agent-history-buffers)))) -(defun gnus-agent-enter-history (id group-arts date) - (save-excursion - (set-buffer gnus-agent-current-history) - (goto-char (point-max)) - (let ((p (point))) - (insert id "\t" (number-to-string date) "\t") - (while group-arts - (insert (format "%S" (intern (caar group-arts))) - " " (number-to-string (cdr (pop group-arts))) - " ")) - (insert "\n") - (while (search-backward "\\." p t) - (delete-char 1))))) - -(defun gnus-agent-article-in-history-p (id) - (save-excursion - (set-buffer (gnus-agent-history-buffer)) - (goto-char (point-min)) - (search-forward (concat "\n" id "\t") nil t))) - -(defun gnus-agent-history-path (id) - (save-excursion - (set-buffer (gnus-agent-history-buffer)) - (goto-char (point-min)) - (when (search-forward (concat "\n" id "\t") nil t) - (let ((method (gnus-agent-method))) - (let (paths group) - (while (not (numberp (setq group (read (current-buffer))))) - (push (concat method "/" group) paths)) - (nreverse paths)))))) - ;;; ;;; Fetching ;;; @@ -823,77 +1279,139 @@ (defun gnus-agent-fetch-articles (group articles) "Fetch ARTICLES from GROUP and put them into the Agent." (when articles - ;; Prune off articles that we have already fetched. - (while (and articles - (cdr (assq (car articles) gnus-agent-article-alist))) - (pop articles)) - (let ((arts articles)) - (while (cdr arts) - (if (cdr (assq (cadr arts) gnus-agent-article-alist)) - (setcdr arts (cddr arts)) - (setq arts (cdr arts))))) - (when articles - (let ((dir (concat - (gnus-agent-directory) - (gnus-agent-group-path group) "/")) - (date (time-to-days (current-time))) - (case-fold-search t) - pos crosses id elem) - (gnus-make-directory dir) - (gnus-message 7 "Fetching articles for %s..." group) - ;; Fetch the articles from the backend. - (if (gnus-check-backend-function 'retrieve-articles group) - (setq pos (gnus-retrieve-articles articles group)) - (with-temp-buffer - (let (article) - (while (setq article (pop articles)) - (when (or - (gnus-backlog-request-article group article - nntp-server-buffer) - (gnus-request-article article group)) - (goto-char (point-max)) - (push (cons article (point)) pos) - (insert-buffer-substring nntp-server-buffer))) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - (setq pos (nreverse pos))))) - ;; Then save these articles into the Agent. - (save-excursion - (set-buffer nntp-server-buffer) - (while pos - (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (when (search-backward "\nXrefs: " nil t) - ;; Handle crossposting. - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq crosses nil) - (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") - (push (cons (buffer-substring (match-beginning 1) - (match-end 1)) - (buffer-substring (match-beginning 2) - (match-end 2))) - crosses) - (goto-char (match-end 0))) - (gnus-agent-crosspost crosses (caar pos)))) - (goto-char (point-min)) - (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) - (setq id "No-Message-ID-in-article") - (setq id (buffer-substring (match-beginning 1) (match-end 1)))) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) - (concat dir (number-to-string (caar pos))) - nil 'silent)) - (when (setq elem (assq (caar pos) gnus-agent-article-alist)) - (setcdr elem t)) - (gnus-agent-enter-history - id (or crosses (list (cons group (caar pos)))) date) - (widen) - (pop pos))) - (gnus-agent-save-alist group))))) - -(defun gnus-agent-crosspost (crosses article) + (gnus-agent-load-alist group) + (let* ((alist gnus-agent-article-alist) + (headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) + (selected-sets (list nil)) + (current-set-size 0) + article + header-number) + ;; Check each article + (while (setq article (pop articles)) + ;; Skip alist entries preceeding this article + (while (> article (or (caar alist) (1+ article))) + (setq alist (cdr alist))) + + ;; Prune off articles that we have already fetched. + (unless (and (eq article (caar alist)) + (cdar alist)) + ;; Skip headers preceeding this article + (while (> article + (setq header-number + (let* ((header (car headers))) + (if header + (mail-header-number header) + (1+ article))))) + (setq headers (cdr headers))) + + ;; Add this article to the current set + (setcar selected-sets (cons article (car selected-sets))) + + ;; Update the set size, when the set is too large start a + ;; new one. I do this after adding the article as I want at + ;; least one article in each set. + (when (< gnus-agent-max-fetch-size + (setq current-set-size + (+ current-set-size + (if (= header-number article) + (let ((char-size (mail-header-chars + (car headers)))) + (if (<= char-size 0) + ;; The char size was missing/invalid, + ;; assume a worst-case situation of + ;; 65 char/line. If the line count + ;; is missing, arbitrarily assume a + ;; size of 1000 characters. + (max (* 65 (mail-header-lines + (car headers))) + 1000) + char-size)) + 0)))) + (setcar selected-sets (nreverse (car selected-sets))) + (setq selected-sets (cons nil selected-sets) + current-set-size 0)))) + + (when (or (cdr selected-sets) (car selected-sets)) + (let* ((fetched-articles (list nil)) + (tail-fetched-articles fetched-articles) + (dir (gnus-agent-group-pathname group)) + (date (time-to-days (current-time))) + (case-fold-search t) + pos crosses id) + + (setcar selected-sets (nreverse (car selected-sets))) + (setq selected-sets (nreverse selected-sets)) + + (gnus-make-directory dir) + (gnus-message 7 "Fetching articles for %s..." group) + + (unwind-protect + (while (setq articles (pop selected-sets)) + ;; Fetch the articles from the backend. + (if (gnus-check-backend-function 'retrieve-articles group) + (setq pos (gnus-retrieve-articles articles group)) + (with-temp-buffer + (let (article) + (while (setq article (pop articles)) + (gnus-message 10 "Fetching article %s for %s..." + article group) + (when (or + (gnus-backlog-request-article group article + nntp-server-buffer) + (gnus-request-article article group)) + (goto-char (point-max)) + (push (cons article (point)) pos) + (insert-buffer-substring nntp-server-buffer))) + (copy-to-buffer + nntp-server-buffer (point-min) (point-max)) + (setq pos (nreverse pos))))) + ;; Then save these articles into the Agent. + (save-excursion + (set-buffer nntp-server-buffer) + (while pos + (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) + (goto-char (point-min)) + (unless (eobp) ;; Don't save empty articles. + (when (search-forward "\n\n" nil t) + (when (search-backward "\nXrefs: " nil t) + ;; Handle cross posting. + (goto-char (match-end 0)) ; move to end of header name + (skip-chars-forward "^ ") ; skip server name + (skip-chars-forward " ") + (setq crosses nil) + (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *") + (push (cons (buffer-substring (match-beginning 1) + (match-end 1)) + (string-to-int + (buffer-substring (match-beginning 2) + (match-end 2)))) + crosses) + (goto-char (match-end 0))) + (gnus-agent-crosspost crosses (caar pos) date))) + (goto-char (point-min)) + (if (not (re-search-forward + "^Message-ID: *<\\([^>\n]+\\)>" nil t)) + (setq id "No-Message-ID-in-article") + (setq id (buffer-substring + (match-beginning 1) (match-end 1)))) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) + (concat dir (number-to-string (caar pos))) + nil 'silent)) + + (gnus-agent-append-to-list + tail-fetched-articles (caar pos))) + (widen) + (setq pos (cdr pos))))) + + (gnus-agent-save-alist group (cdr fetched-articles) date) + (gnus-message 7 "")) + (cdr fetched-articles)))))) + +(defun gnus-agent-crosspost (crosses article &optional date) + (setq date (or date t)) + (let (gnus-agent-article-alist group alist beg end) (save-excursion (set-buffer gnus-agent-overview-buffer) @@ -906,7 +1424,7 @@ (unless (setq alist (assoc group gnus-agent-group-alist)) (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) gnus-agent-group-alist)) - (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) + (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) (save-excursion (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" group))) @@ -917,8 +1435,65 @@ (gnus-agent-article-name ".overview" group)))) (nnheader-find-nov-line (string-to-number (cdar crosses))) (insert (string-to-number (cdar crosses))) - (insert-buffer-substring gnus-agent-overview-buffer beg end)) - (pop crosses)))) + (insert-buffer-substring gnus-agent-overview-buffer beg end) + (gnus-agent-check-overview-buffer)) + (setq crosses (cdr crosses))))) + +(defun gnus-agent-backup-overview-buffer () + (when gnus-newsgroup-name + (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name)) + (cnt 0) + name) + (while (file-exists-p + (setq name (concat root "~" + (int-to-string (setq cnt (1+ cnt))) "~")))) + (write-region (point-min) (point-max) name nil 'no-msg) + (gnus-message 1 "Created backup copy of overview in %s." name))) + t) + +(defun gnus-agent-check-overview-buffer (&optional buffer) + "Check the overview file given for sanity. +In particular, checks that the file is sorted by article number +and that there are no duplicates." + (let ((prev-num -1) + (backed-up nil)) + (save-excursion + (when buffer + (set-buffer buffer)) + (save-restriction + (widen) + (goto-char (point-min)) + + (while (< (point) (point-max)) + (let ((p (point)) + (cur (condition-case nil + (read (current-buffer)) + (error nil)))) + (cond + ((or (not (integerp cur)) + (not (eq (char-after) ?\t))) + (or backed-up + (setq backed-up (gnus-agent-backup-overview-buffer))) + (gnus-message 1 + "Overview buffer contains garbage '%s'." + (buffer-substring + p (gnus-point-at-eol)))) + ((= cur prev-num) + (or backed-up + (setq backed-up (gnus-agent-backup-overview-buffer))) + (gnus-message 1 + "Duplicate overview line for %d" cur) + (delete-region (point) (progn (forward-line 1) (point)))) + ((< cur prev-num) + (or backed-up + (setq backed-up (gnus-agent-backup-overview-buffer))) + (gnus-message 1 "Overview buffer not sorted!") + (sort-numeric-fields 1 (point-min) (point-max)) + (goto-char (point-min)) + (setq prev-num -1)) + (t + (setq prev-num cur))) + (forward-line 1))))))) (defun gnus-agent-flush-cache () (save-excursion @@ -930,143 +1505,466 @@ (gnus-agent-article-name ".overview" (caar gnus-agent-buffer-alist)) nil 'silent)) - (pop gnus-agent-buffer-alist)) + (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist))) (while gnus-agent-group-alist - (with-temp-file (caar gnus-agent-group-alist) + (with-temp-file (gnus-agent-article-name + ".agentview" (caar gnus-agent-group-alist)) (princ (cdar gnus-agent-group-alist)) + (insert "\n") + (princ 1 (current-buffer)) (insert "\n")) - (pop gnus-agent-group-alist)))) - -(if (fboundp 'union) - (defalias 'gnus-agent-union 'union) - (defun gnus-agent-union (l1 l2) - "Set union of lists L1 and L2." - (cond ((null l1) l2) - ((null l2) l1) - ((equal l1 l2) l1) - (t - (or (>= (length l1) (length l2)) - (setq l1 (prog1 l2 (setq l2 l1)))) - (while l2 - (or (memq (car l2) l1) - (push (car l2) l1)) - (pop l2)) - l1)))) + (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) + +(defun gnus-agent-find-parameter (group symbol) + "Search for GROUPs SYMBOL in the group's parameters, the group's +topic parameters, the group's category, or the customizable +variables. Returns the first non-nil value found." + (or (gnus-group-find-parameter group symbol t) + (gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t) + (symbol-value + (cdr + (assq symbol + '((agent-short-article . gnus-agent-short-article) + (agent-long-article . gnus-agent-long-article) + (agent-low-score . gnus-agent-low-score) + (agent-high-score . gnus-agent-high-score) + (agent-days-until-old . gnus-agent-expire-days) + (agent-enable-expiration + . gnus-agent-enable-expiration) + (agent-predicate . gnus-agent-predicate))))))) (defun gnus-agent-fetch-headers (group &optional force) - (let ((articles (gnus-list-of-unread-articles group)) - (gnus-decode-encoded-word-function 'identity) - (file (gnus-agent-article-name ".overview" group))) - ;; Add article with marks to list of article headers we want to fetch. - (dolist (arts (gnus-info-marks (gnus-get-info group))) - (setq articles (gnus-agent-union (gnus-uncompress-sequence (cdr arts)) - articles))) - (setq articles (sort articles '<)) - ;; Remove known articles. - (when (gnus-agent-load-alist group) - (setq articles (gnus-sorted-intersection - articles - (gnus-uncompress-range - (cons (1+ (caar (last gnus-agent-article-alist))) - (cdr (gnus-active group))))))) - ;; Fetch them. - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t)) - (when articles - (gnus-message 7 "Fetching headers for %s..." group) + "Fetch interesting headers into the agent. The group's overview +file will be updated to include the headers while a list of available +article numbers will be returned." + (let* ((fetch-all (and gnus-agent-consider-all-articles + ;; Do not fetch all headers if the predicate + ;; implies that we only consider unread articles. + (not (gnus-predicate-implies-unread + (gnus-agent-find-parameter group + 'agent-predicate))))) + (articles (if fetch-all + (gnus-uncompress-range (gnus-active group)) + (gnus-list-of-unread-articles group))) + (gnus-decode-encoded-word-function 'identity) + (file (gnus-agent-article-name ".overview" group))) + + (unless fetch-all + ;; Add articles with marks to the list of article headers we want to + ;; fetch. Don't fetch articles solely on the basis of a recent or seen + ;; mark, but do fetch recent or seen articles if they have other, more + ;; interesting marks. (We have to fetch articles with boring marks + ;; because otherwise the agent will remove their marks.) + (dolist (arts (gnus-info-marks (gnus-get-info group))) + (unless (memq (car arts) '(seen recent killed cache)) + (setq articles (gnus-range-add articles (cdr arts))))) + (setq articles (sort (gnus-uncompress-sequence articles) '<))) + + ;; At this point, I have the list of articles to consider for + ;; fetching. This is the list that I'll return to my caller. Some + ;; of these articles may have already been fetched. That's OK as + ;; the fetch article code will filter those out. Internally, I'll + ;; filter this list to just those articles whose headers need to + ;; be fetched. + (let ((articles articles)) + ;; Remove known articles. + (when (and (or gnus-agent-cache + (not gnus-plugged)) + (gnus-agent-load-alist group)) + ;; Remove articles marked as downloaded. + (if fetch-all + ;; I want to fetch all headers in the active range. + ;; Therefore, exclude only those headers that are in the + ;; article alist. + ;; NOTE: This is probably NOT what I want to do after + ;; agent expiration in this group. + (setq articles (gnus-agent-uncached-articles articles group)) + + ;; I want to only fetch those headers that have never been + ;; fetched. Therefore, exclude all headers that are, or + ;; WERE, in the article alist. + (let ((low (1+ (caar (last gnus-agent-article-alist)))) + (high (cdr (gnus-active group)))) + ;; Low can be greater than High when the same group is + ;; fetched twice in the same session {The first fetch will + ;; fill the article alist such that (last + ;; gnus-agent-article-alist) equals (cdr (gnus-active + ;; group))}. The addition of one(the 1+ above) then + ;; forces Low to be greater than High. When this happens, + ;; gnus-list-range-intersection returns nil which + ;; indicates that no headers need to be fetched. -- Kevin + (setq articles (gnus-list-range-intersection + articles (list (cons low high))))))) + + (gnus-message + 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" + (gnus-compress-sequence articles t)) + (save-excursion - (set-buffer nntp-server-buffer) - (unless (eq 'nov (gnus-retrieve-headers articles group)) - (nnvirtual-convert-headers)) - ;; Save these headers for later processing. - (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - (when (file-exists-p file) - (gnus-agent-braid-nov group articles file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent)) - (gnus-agent-save-alist group articles nil) - (gnus-agent-enter-history - "last-header-fetched-for-session" - (list (cons group (nth (- (length articles) 1) articles))) - (time-to-days (current-time))) - articles)))) + (set-buffer nntp-server-buffer) + + (if articles + (progn + (gnus-message 7 "Fetching headers for %s..." group) + + ;; Fetch them. + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + + (unless (eq 'nov (gnus-retrieve-headers articles group)) + (nnvirtual-convert-headers)) + (gnus-agent-check-overview-buffer) + ;; Move these headers to the overview buffer so that + ;; gnus-agent-braid-nov can merge them with the contents + ;; of FILE. + (copy-to-buffer + gnus-agent-overview-buffer (point-min) (point-max)) + (when (file-exists-p file) + (gnus-agent-braid-nov group articles file)) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + (gnus-agent-save-alist group articles nil) + articles) + (ignore-errors + (erase-buffer) + (nnheader-insert-file-contents file))))) + articles)) (defsubst gnus-agent-copy-nov-line (article) - (let (b e) + (let (art b e) (set-buffer gnus-agent-overview-buffer) - (setq b (point)) - (if (eq article (read (current-buffer))) - (setq e (progn (forward-line 1) (point))) - (progn - (beginning-of-line) - (setq e b))) - (set-buffer nntp-server-buffer) - (insert-buffer-substring gnus-agent-overview-buffer b e))) + (while (and (not (eobp)) + (< (setq art (read (current-buffer))) article)) + (forward-line 1)) + (beginning-of-line) + (if (or (eobp) + (not (eq article art))) + (set-buffer nntp-server-buffer) + (setq b (point)) + (setq e (progn (forward-line 1) (point))) + (set-buffer nntp-server-buffer) + (insert-buffer-substring gnus-agent-overview-buffer b e)))) (defun gnus-agent-braid-nov (group articles file) - (set-buffer gnus-agent-overview-buffer) - (goto-char (point-min)) - (set-buffer nntp-server-buffer) - (erase-buffer) - (nnheader-insert-file-contents file) - (goto-char (point-max)) - (if (or (= (point-min) (point-max)) - (progn - (forward-line -1) - (< (read (current-buffer)) (car articles)))) - ;; We have only headers that are after the older headers, - ;; so we just append them. - (progn - (goto-char (point-max)) - (insert-buffer-substring gnus-agent-overview-buffer)) - ;; We do it the hard way. - (nnheader-find-nov-line (car articles)) - (gnus-agent-copy-nov-line (car articles)) - (pop articles) - (while (and articles - (not (eobp))) - (while (and (not (eobp)) - (< (read (current-buffer)) (car articles))) - (forward-line 1)) - (beginning-of-line) - (unless (eobp) - (gnus-agent-copy-nov-line (car articles)) - (setq articles (cdr articles)))) + "Merge agent overview data with given file. +Takes headers for ARTICLES from `gnus-agent-overview-buffer' and the given +FILE and places the combined headers into `nntp-server-buffer'." + (let (start last) + (set-buffer gnus-agent-overview-buffer) + (goto-char (point-min)) + (set-buffer nntp-server-buffer) + (erase-buffer) + (nnheader-insert-file-contents file) + (goto-char (point-max)) + (forward-line -1) + (unless (looking-at "[0-9]+\t") + ;; Remove corrupted lines + (gnus-message + 1 "Overview %s is corrupted. Removing corrupted lines..." file) + (goto-char (point-min)) + (while (not (eobp)) + (if (looking-at "[0-9]+\t") + (forward-line 1) + (delete-region (point) (progn (forward-line 1) (point))))) + (forward-line -1)) + (unless (or (= (point-min) (point-max)) + (< (setq last (read (current-buffer))) (car articles))) + ;; We do it the hard way. + (when (nnheader-find-nov-line (car articles)) + ;; Replacing existing NOV entry + (delete-region (point) (progn (forward-line 1) (point)))) + (gnus-agent-copy-nov-line (pop articles)) + + (ignore-errors + (while articles + (while (let ((art (read (current-buffer)))) + (cond ((< art (car articles)) + (forward-line 1) + t) + ((= art (car articles)) + (beginning-of-line) + (delete-region + (point) (progn (forward-line 1) (point))) + nil) + (t + (beginning-of-line) + nil)))) + + (gnus-agent-copy-nov-line (pop articles))))) + + ;; Copy the rest lines + (set-buffer nntp-server-buffer) + (goto-char (point-max)) (when articles - (let (b e) + (when last (set-buffer gnus-agent-overview-buffer) - (setq b (point) - e (point-max)) - (set-buffer nntp-server-buffer) - (insert-buffer-substring gnus-agent-overview-buffer b e))))) - -(defun gnus-agent-load-alist (group &optional dir) + (ignore-errors + (while (<= (read (current-buffer)) last) + (forward-line 1))) + (beginning-of-line) + (setq start (point)) + (set-buffer nntp-server-buffer)) + (insert-buffer-substring gnus-agent-overview-buffer start)))) + +;; Keeps the compiler from warning about the free variable in +;; gnus-agent-read-agentview. +(eval-when-compile + (defvar gnus-agent-read-agentview)) + +(defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." - (setq gnus-agent-article-alist - (gnus-agent-read-file - (if dir - (expand-file-name ".agentview" dir) - (gnus-agent-article-name ".agentview" group))))) - -(defun gnus-agent-save-alist (group &optional articles state dir) + ;; Bind free variable that's used in `gnus-agent-read-agentview'. + (let ((gnus-agent-read-agentview group)) + (setq gnus-agent-article-alist + (gnus-cache-file-contents + (gnus-agent-article-name ".agentview" group) + 'gnus-agent-file-loading-cache + 'gnus-agent-read-agentview)))) + +;; Save format may be either 1 or 2. Two is the new, compressed +;; format that is still being tested. Format 1 is uncompressed but +;; known to be reliable. +(defconst gnus-agent-article-alist-save-format 2) + +(defun gnus-agent-read-agentview (file) + "Load FILE and do a `read' there." + (with-temp-buffer + (ignore-errors + (nnheader-insert-file-contents file) + (goto-char (point-min)) + (let ((alist (read (current-buffer))) + (version (condition-case nil (read (current-buffer)) + (end-of-file 0))) + changed-version) + + (cond + ((= version 0) + (let ((inhibit-quit t) + entry) + (gnus-agent-open-history) + (set-buffer (gnus-agent-history-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (if (and (looking-at + "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") + (string= (match-string 2) + gnus-agent-read-agentview) + (setq entry (assoc (string-to-number (match-string 3)) alist))) + (setcdr entry (string-to-number (match-string 1)))) + (forward-line 1)) + (gnus-agent-close-history) + (setq changed-version t))) + ((= version 1) + (setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) + ((= version 2) + (let (uncomp) + (mapcar + (lambda (comp-list) + (let ((state (car comp-list)) + (sequence (gnus-uncompress-sequence + (cdr comp-list)))) + (mapcar (lambda (article-id) + (setq uncomp (cons (cons article-id state) uncomp))) + sequence))) + alist) + (setq alist (sort uncomp 'car-less-than-car))))) + (when changed-version + (let ((gnus-agent-article-alist alist)) + (gnus-agent-save-alist gnus-agent-read-agentview))) + alist)))) + +(defun gnus-agent-save-alist (group &optional articles state) "Save the article-state alist for GROUP." - (let ((file-name-coding-system nnmail-pathname-coding-system)) - (with-temp-file (if dir - (expand-file-name ".agentview" dir) - (gnus-agent-article-name ".agentview" group)) - (princ (setq gnus-agent-article-alist - (nconc gnus-agent-article-alist - (mapcar (lambda (article) (cons article state)) - articles))) - (current-buffer)) - (insert "\n")))) + (let* ((file-name-coding-system nnmail-pathname-coding-system) + (prev (cons nil gnus-agent-article-alist)) + (all prev) + print-level print-length item article) + (while (setq article (pop articles)) + (while (and (cdr prev) + (< (caadr prev) article)) + (setq prev (cdr prev))) + (cond + ((not (cdr prev)) + (setcdr prev (list (cons article state)))) + ((> (caadr prev) article) + (setcdr prev (cons (cons article state) (cdr prev)))) + ((= (caadr prev) article) + (setcdr (cadr prev) state))) + (setq prev (cdr prev))) + (setq gnus-agent-article-alist (cdr all)) + + (gnus-agent-set-local group + (caar gnus-agent-article-alist) + (caar (last gnus-agent-article-alist))) + + (gnus-make-directory (gnus-agent-article-name "" group)) + (with-temp-file (gnus-agent-article-name ".agentview" group) + (cond ((eq gnus-agent-article-alist-save-format 1) + (princ gnus-agent-article-alist (current-buffer))) + ((eq gnus-agent-article-alist-save-format 2) + (let ((compressed nil)) + (mapcar (lambda (pair) + (let* ((article-id (car pair)) + (day-of-download (cdr pair)) + (comp-list (assq day-of-download compressed))) + (if comp-list + (setcdr comp-list + (cons article-id (cdr comp-list))) + (setq compressed + (cons (list day-of-download article-id) + compressed))) + nil)) gnus-agent-article-alist) + (mapcar (lambda (comp-list) + (setcdr comp-list + (gnus-compress-sequence + (nreverse (cdr comp-list))))) + compressed) + (princ compressed (current-buffer))))) + (insert "\n") + (princ gnus-agent-article-alist-save-format (current-buffer)) + (insert "\n")))) + +(defvar gnus-agent-article-local nil) +(defvar gnus-agent-file-loading-local nil) + +(defun gnus-agent-load-local (&optional method) + "Load the METHOD'S local file. The local file contains min/max +article counts for each of the method's subscribed groups." + (let ((gnus-command-method (or method gnus-command-method))) + (setq gnus-agent-article-local + (gnus-cache-file-contents + (gnus-agent-lib-file "local") + 'gnus-agent-file-loading-local + 'gnus-agent-read-and-cache-local)))) + +(defun gnus-agent-read-and-cache-local (file) + "Load and read FILE then bind its contents to +gnus-agent-article-local. If that variable had `dirty' (also known as +modified) original contents, they are first saved to their own file." + + (if (and gnus-agent-article-local + (symbol-value (intern "+dirty" gnus-agent-article-local))) + (gnus-agent-save-local)) + (gnus-agent-read-local file)) + +(defun gnus-agent-read-local (file) + "Load FILE and do a `read' there." + (let ((my-obarray (gnus-make-hashtable (count-lines (point-min) + (point-max)))) + (line 1)) + (with-temp-buffer + (condition-case nil + (nnheader-insert-file-contents file) + (file-error)) + + (goto-char (point-min)) + ;; Skip any comments at the beginning of the file (the only place where they may appear) + (while (= (following-char) ?\;) + (forward-line 1) + (setq line (1+ line))) + + (while (not (eobp)) + (condition-case err + (let (group + min + max + (cur (current-buffer))) + (setq group (read cur) + min (read cur) + max (read cur)) + + (when (stringp group) + (setq group (intern group my-obarray))) + + ;; NOTE: The '+ 0' ensure that min and max are both numerics. + (set group (cons (+ 0 min) (+ 0 max)))) + (error + (gnus-message 3 "Warning - invalid agent local: %s on line %d: " + file line (error-message-string err)))) + (forward-line 1) + (setq line (1+ line)))) + + (set (intern "+dirty" my-obarray) nil) + (set (intern "+method" my-obarray) gnus-command-method) + my-obarray)) + +(defun gnus-agent-save-local (&optional force) + "Save gnus-agent-article-local under it method's agent.lib directory." + (let ((my-obarray gnus-agent-article-local)) + (when (and my-obarray + (or force (symbol-value (intern "+dirty" my-obarray)))) + (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray))) + ;; NOTE: gnus-command-method is used within gnus-agent-lib-file. + (dest (gnus-agent-lib-file "local"))) + (gnus-make-directory (gnus-agent-lib-file "")) + (with-temp-file dest + (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) + (file-name-coding-system nnmail-pathname-coding-system) + (coding-system-for-write + gnus-agent-file-coding-system) + print-level print-length item article + (standard-output (current-buffer))) + (mapatoms (lambda (symbol) + (cond ((not (boundp symbol)) + nil) + ((member (symbol-name symbol) '("+dirty" "+method")) + nil) + (t + (prin1 symbol) + (let ((range (symbol-value symbol))) + (princ " ") + (princ (car range)) + (princ " ") + (princ (cdr range)) + (princ "\n"))))) + my-obarray))))))) + +(defun gnus-agent-get-local (group) + (let* ((gmane (gnus-group-real-name group)) + (gnus-command-method (gnus-find-method-for-group group)) + (local (gnus-agent-load-local)) + (symb (intern gmane local)) + (minmax (and (boundp symb) (symbol-value symb)))) + (unless minmax + ;; Bind these so that gnus-agent-load-alist doesn't change the + ;; current alist (i.e. gnus-agent-article-alist) + (let* ((gnus-agent-article-alist gnus-agent-article-alist) + (gnus-agent-file-loading-cache gnus-agent-file-loading-cache) + (alist (gnus-agent-load-alist group))) + (when alist + (setq minmax + (cons (caar alist) + (caar (last alist)))) + (gnus-agent-set-local group (car minmax) (cdr minmax) + gmane gnus-command-method local)))) + minmax)) + +(defun gnus-agent-set-local (group min max &optional gmane method local) + (let* ((gmane (or gmane (gnus-group-real-name group))) + (gnus-command-method (or method (gnus-find-method-for-group group))) + (local (or local (gnus-agent-load-local))) + (symb (intern gmane local)) + (minmax (and (boundp symb) (symbol-value symb)))) + + (if (cond ((and minmax + (or (not (eq min (car minmax))) + (not (eq max (cdr minmax))))) + (setcar minmax min) + (setcdr minmax max) + t) + (minmax + nil) + ((and min max) + (set symb (cons min max)) + t)) + (set (intern "+dirty" local) t)))) (defun gnus-agent-article-name (article group) - (expand-file-name (if (stringp article) article (string-to-number article)) + (expand-file-name article (file-name-as-directory - (expand-file-name (gnus-agent-group-path group) - (gnus-agent-directory))))) + (gnus-agent-group-pathname group)))) (defun gnus-agent-batch-confirmation (msg) "Show error message and return t." @@ -1089,106 +1987,226 @@ (error "No servers are covered by the Gnus agent")) (unless gnus-plugged (error "Can't fetch articles while Gnus is unplugged")) - (let ((methods gnus-agent-covered-methods) + (let ((methods (gnus-agent-covered-methods)) groups group gnus-command-method) (save-excursion (while methods - (condition-case err - (progn - (setq gnus-command-method (car methods)) - (when (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) - (setq groups (gnus-groups-from-server (car methods))) - (gnus-agent-with-fetch - (while (setq group (pop groups)) - (when (<= (gnus-group-level group) gnus-agent-handle-level) - (gnus-agent-fetch-group-1 group gnus-command-method)))))) - (error - (unless (funcall gnus-agent-confirmation-function - (format "Error (%s). Continue? " err)) - (error "Cannot fetch articles into the Gnus agent"))) - (quit - (unless (funcall gnus-agent-confirmation-function - (format "Quit (%s). Continue? " err)) - (signal 'quit "Cannot fetch articles into the Gnus agent.")))) - (pop methods)) + (setq gnus-command-method (car methods)) + (when (and (or (gnus-server-opened gnus-command-method) + (gnus-open-server gnus-command-method)) + (gnus-online gnus-command-method)) + (setq groups (gnus-groups-from-server (car methods))) + (gnus-agent-with-fetch + (while (setq group (pop groups)) + (when (<= (gnus-group-level group) + gnus-agent-handle-level) + (if (or debug-on-error debug-on-quit) + (gnus-agent-fetch-group-1 + group gnus-command-method) + (condition-case err + (gnus-agent-fetch-group-1 + group gnus-command-method) + (error + (unless (funcall gnus-agent-confirmation-function + (format "Error %s. Continue? " + (error-message-string err))) + (error "Cannot fetch articles into the Gnus agent"))) + (quit + (unless (funcall gnus-agent-confirmation-function + (format + "Quit fetching session %s. Continue? " + (error-message-string err))) + (signal 'quit + "Cannot fetch articles into the Gnus agent"))))))))) + (setq methods (cdr methods))) + (gnus-run-hooks 'gnus-agent-fetched-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) (defun gnus-agent-fetch-group-1 (group method) "Fetch GROUP." (let ((gnus-command-method method) (gnus-newsgroup-name group) - gnus-newsgroup-dependencies gnus-newsgroup-headers - gnus-newsgroup-scored gnus-headers gnus-score - gnus-use-cache articles arts - category predicate info marks score-param + (gnus-newsgroup-dependencies gnus-newsgroup-dependencies) + (gnus-newsgroup-headers gnus-newsgroup-headers) + (gnus-newsgroup-scored gnus-newsgroup-scored) + (gnus-use-cache gnus-use-cache) (gnus-summary-expunge-below gnus-summary-expunge-below) (gnus-summary-mark-below gnus-summary-mark-below) (gnus-orphan-score gnus-orphan-score) ;; Maybe some other gnus-summary local variables should also ;; be put here. + + gnus-headers + gnus-score + articles arts + category predicate info marks score-param ) (unless (gnus-check-group group) (error "Can't open server for %s" group)) + ;; Fetch headers. - (when (and (or (gnus-active group) (gnus-activate-group group)) - (setq articles (gnus-agent-fetch-headers group)) - (let ((nntp-server-buffer gnus-agent-overview-buffer)) - ;; Parse them and see which articles we want to fetch. - (setq gnus-newsgroup-dependencies - (make-vector (length articles) 0)) - (setq gnus-newsgroup-headers - (gnus-get-newsgroup-headers-xover articles nil nil - group)) - ;; `gnus-agent-overview-buffer' may be killed for - ;; timeout reason. If so, recreate it. - (gnus-agent-create-buffer))) - (setq category (gnus-group-category group)) - (setq predicate - (gnus-get-predicate - (or (gnus-group-find-parameter group 'agent-predicate t) - (cadr category)))) - (if (memq (caaddr predicate) '(gnus-agent-true gnus-agent-false)) - ;; Simple implementation - (setq arts - (and (eq (caaddr predicate) 'gnus-agent-true) articles)) - (setq arts nil) - (setq score-param - (or (gnus-group-get-parameter group 'agent-score t) - (caddr category))) - ;; Translate score-param into real one - (cond - ((not score-param)) - ((eq score-param 'file) - (setq score-param (gnus-all-score-files group))) - ((stringp (car score-param))) - (t - (setq score-param (list (list score-param))))) - (when score-param - (gnus-score-headers score-param)) - (while (setq gnus-headers (pop gnus-newsgroup-headers)) - (setq gnus-score - (or (cdr (assq (mail-header-number gnus-headers) - gnus-newsgroup-scored)) - gnus-summary-default-score)) - (when (funcall predicate) - (push (mail-header-number gnus-headers) - arts)))) - ;; Fetch the articles. - (when arts - (gnus-agent-fetch-articles group arts))) - ;; Perhaps we have some additional articles to fetch. - (setq arts (assq 'download (gnus-info-marks - (setq info (gnus-get-info group))))) - (when (cdr arts) - (gnus-agent-fetch-articles - group (gnus-uncompress-range (cdr arts))) - (setq marks (delq arts (gnus-info-marks info))) - (gnus-info-set-marks info marks) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))))) + (when (or gnus-newsgroup-active + (gnus-active group) + (gnus-activate-group group)) + (let ((marked-articles gnus-newsgroup-downloadable)) + ;; Identify the articles marked for download + (unless gnus-newsgroup-active + ;; The variable gnus-newsgroup-active was selected as I need + ;; a gnus-summary local variable that is NOT bound to any + ;; value (its global value should default to nil). + (dolist (mark gnus-agent-download-marks) + (let ((arts (cdr (assq mark (gnus-info-marks + (setq info (gnus-get-info group))))))) + (when arts + (setq marked-articles (nconc (gnus-uncompress-range arts) + marked-articles)) + )))) + (setq marked-articles (sort marked-articles '<)) + + ;; Fetch any new articles from the server + (setq articles (gnus-agent-fetch-headers group)) + + ;; Merge new articles with marked + (setq articles (sort (append marked-articles articles) '<)) + + (when articles + ;; Parse them and see which articles we want to fetch. + (setq gnus-newsgroup-dependencies + (or gnus-newsgroup-dependencies + (make-vector (length articles) 0))) + (setq gnus-newsgroup-headers + (or gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil + group))) + ;; `gnus-agent-overview-buffer' may be killed for + ;; timeout reason. If so, recreate it. + (gnus-agent-create-buffer) + + ;; Figure out how to select articles in this group + (setq category (gnus-group-category group)) + + (setq predicate + (gnus-get-predicate + (gnus-agent-find-parameter group 'agent-predicate))) + + ;; If the selection predicate requires scoring, score each header + (unless (memq predicate '(gnus-agent-true gnus-agent-false)) + (let ((score-param + (gnus-agent-find-parameter group 'agent-score-file))) + ;; Translate score-param into real one + (cond + ((not score-param)) + ((eq score-param 'file) + (setq score-param (gnus-all-score-files group))) + ((stringp (car score-param))) + (t + (setq score-param (list (list score-param))))) + (when score-param + (gnus-score-headers score-param)))) + + (unless (and (eq predicate 'gnus-agent-false) + (not marked-articles)) + (let ((arts (list nil))) + (let ((arts-tail arts) + (alist (gnus-agent-load-alist group)) + (marked-articles marked-articles) + (gnus-newsgroup-headers gnus-newsgroup-headers)) + (while (setq gnus-headers (pop gnus-newsgroup-headers)) + (let ((num (mail-header-number gnus-headers))) + ;; Determine if this article is already in the cache + (while (and alist + (> num (caar alist))) + (setq alist (cdr alist))) + + (unless (and (eq num (caar alist)) + (cdar alist)) + + ;; Determine if this article was marked for download. + (while (and marked-articles + (> num (car marked-articles))) + (setq marked-articles + (cdr marked-articles))) + + ;; When this article is marked, or selected by the + ;; predicate, add it to the download list + (when (or (eq num (car marked-articles)) + (let ((gnus-score + (or (cdr + (assq num gnus-newsgroup-scored)) + gnus-summary-default-score)) + (gnus-agent-long-article + (gnus-agent-find-parameter + group 'agent-long-article)) + (gnus-agent-short-article + (gnus-agent-find-parameter + group 'agent-short-article)) + (gnus-agent-low-score + (gnus-agent-find-parameter + group 'agent-low-score)) + (gnus-agent-high-score + (gnus-agent-find-parameter + group 'agent-high-score)) + (gnus-agent-expire-days + (gnus-agent-find-parameter + group 'agent-days-until-old))) + (funcall predicate))) + (gnus-agent-append-to-list arts-tail num)))))) + + (let (fetched-articles) + ;; Fetch all selected articles + (setq gnus-newsgroup-undownloaded + (gnus-sorted-ndifference + gnus-newsgroup-undownloaded + (setq fetched-articles + (if (cdr arts) + (gnus-agent-fetch-articles group (cdr arts)) + nil)))) + + (let ((unfetched-articles + (gnus-sorted-ndifference (cdr arts) fetched-articles))) + (if gnus-newsgroup-active + ;; Update the summary buffer + (progn + (dolist (article marked-articles) + (gnus-summary-set-agent-mark article t)) + (dolist (article fetched-articles) + (if gnus-agent-mark-unread-after-downloaded + (gnus-summary-mark-article + article gnus-unread-mark)) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-download-mark article))) + (dolist (article unfetched-articles) + (gnus-summary-mark-article + article gnus-canceled-mark))) + + ;; Update the group buffer. + + ;; When some, or all, of the marked articles came + ;; from the download mark. Remove that mark. I + ;; didn't do this earlier as I only want to remove + ;; the marks after the fetch is completed. + + (dolist (mark gnus-agent-download-marks) + (when (eq mark 'download) + (let ((marked-arts + (assq mark (gnus-info-marks + (setq info (gnus-get-info group)))))) + (when (cdr marked-arts) + (setq marks + (delq marked-arts (gnus-info-marks info))) + (gnus-info-set-marks info marks))))) + (let ((read (gnus-info-read + (or info (setq info (gnus-get-info group)))))) + (gnus-info-set-read + info (gnus-add-to-range read unfetched-articles))) + + (gnus-group-update-group group t) + (sit-for 0) + + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string info) + ")")))))))))))) ;;; ;;; Agent Category Mode @@ -1198,11 +2216,21 @@ "Hook run in `gnus-category-mode' buffers.") (defvar gnus-category-line-format " %(%20c%): %g\n" - "Format of category lines.") + "Format of category lines. + +Valid specifiers include: +%c Topic name (string) +%g The number of groups in the topic (integer) + +General format specifiers can also be used. See Info node +`(gnus)Formatting Variables'.") (defvar gnus-category-mode-line-format "Gnus: %%b" "The format specification for the category mode line.") +(defvar gnus-agent-predicate 'false + "The selection predicate used when no other source is available.") + (defvar gnus-agent-short-article 100 "Articles that have fewer lines than this are short.") @@ -1242,6 +2270,7 @@ "k" gnus-category-kill "c" gnus-category-copy "a" gnus-category-add + "e" gnus-agent-customize-category "p" gnus-category-edit-predicate "g" gnus-category-edit-groups "s" gnus-category-edit-score @@ -1262,6 +2291,7 @@ ["Add" gnus-category-add t] ["Kill" gnus-category-kill t] ["Copy" gnus-category-copy t] + ["Edit category" gnus-agent-customize-category t] ["Edit predicate" gnus-category-edit-predicate t] ["Edit score" gnus-category-edit-score t] ["Edit groups" gnus-category-edit-groups t] @@ -1275,7 +2305,7 @@ All normal editing commands are switched off. \\<gnus-category-mode-map> For more in-depth information on this mode, read the manual -(`\\[gnus-info-find-node]'). +\(`\\[gnus-info-find-node]'). The following commands are available: @@ -1298,8 +2328,8 @@ (defalias 'gnus-category-position-point 'gnus-goto-colon) (defun gnus-category-insert-line (category) - (let* ((gnus-tmp-name (car category)) - (gnus-tmp-groups (length (cadddr category)))) + (let* ((gnus-tmp-name (format "%s" (car category))) + (gnus-tmp-groups (length (gnus-agent-cat-groups category)))) (beginning-of-line) (gnus-add-text-properties (point) @@ -1333,15 +2363,41 @@ (gnus-category-position-point))) (defun gnus-category-name () - (or (get-text-property (gnus-point-at-bol) 'gnus-category) + (or (intern (get-text-property (gnus-point-at-bol) 'gnus-category)) (error "No category on the current line"))) (defun gnus-category-read () "Read the category alist." (setq gnus-category-alist - (or (gnus-agent-read-file - (nnheader-concat gnus-agent-directory "lib/categories")) - (list (list 'default 'short nil nil))))) + (or + (with-temp-buffer + (ignore-errors + (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories")) + (goto-char (point-min)) + ;; This code isn't temp, it will be needed so long as + ;; anyone may be migrating from an older version. + + ;; Once we're certain that people will not revert to an + ;; earlier version, we can take out the old-list code in + ;; gnus-category-write. + (let* ((old-list (read (current-buffer))) + (new-list (ignore-errors (read (current-buffer))))) + (if new-list + new-list + ;; Convert from a positional list to an alist. + (mapcar + (lambda (c) + (setcdr c + (delq nil + (gnus-mapcar + (lambda (valu symb) + (if valu + (cons symb valu))) + (cdr c) + '(agent-predicate agent-score-file agent-groups)))) + c) + old-list))))) + (list (gnus-agent-cat-make 'default 'short))))) (defun gnus-category-write () "Write the category alist." @@ -1349,6 +2405,16 @@ gnus-category-group-cache nil) (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") + ;; This prin1 is temporary. It exists so that people can revert + ;; to an earlier version of gnus-agent. + (prin1 (mapcar (lambda (c) + (list (car c) + (cdr (assoc 'agent-predicate c)) + (cdr (assoc 'agent-score-file c)) + (cdr (assoc 'agent-groups c)))) + gnus-category-alist) + (current-buffer)) + (newline) (prin1 gnus-category-alist (current-buffer)))) (defun gnus-category-edit-predicate (category) @@ -1356,9 +2422,16 @@ (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form - (cadr info) (format "Editing the predicate for category %s" category) + (gnus-agent-cat-predicate info) + (format "Editing the select predicate for category %s" category) `(lambda (predicate) - (setcar (cdr (assq ',category gnus-category-alist)) predicate) + ;; Avoid run-time execution of setf form + ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist)) + ;; predicate) + ;; use its expansion instead: + (gnus-agent-cat-set-property (assq ',category gnus-category-alist) + 'agent-predicate predicate) + (gnus-category-write) (gnus-category-list))))) @@ -1367,10 +2440,16 @@ (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form - (caddr info) + (gnus-agent-cat-score-file info) (format "Editing the score expression for category %s" category) - `(lambda (groups) - (setcar (cddr (assq ',category gnus-category-alist)) groups) + `(lambda (score-file) + ;; Avoid run-time execution of setf form + ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist)) + ;; score-file) + ;; use its expansion instead: + (gnus-agent-cat-set-property (assq ',category gnus-category-alist) + 'agent-score-file score-file) + (gnus-category-write) (gnus-category-list))))) @@ -1379,9 +2458,16 @@ (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form - (cadddr info) (format "Editing the group list for category %s" category) + (gnus-agent-cat-groups info) + (format "Editing the group list for category %s" category) `(lambda (groups) - (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups) + ;; Avoid run-time execution of setf form + ;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist)) + ;; groups) + ;; use its expansion instead: + (gnus-agent-set-cat-groups (assq ',category gnus-category-alist) + groups) + (gnus-category-write) (gnus-category-list))))) @@ -1398,8 +2484,10 @@ "Copy the current category." (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) (let ((info (assq category gnus-category-alist))) - (push (list to (gnus-copy-sequence (cadr info)) - (gnus-copy-sequence (caddr info)) nil) + (push (let ((newcat (gnus-copy-sequence info))) + (setf (gnus-agent-cat-name newcat) to) + (setf (gnus-agent-cat-groups newcat) nil) + newcat) gnus-category-alist) (gnus-category-write) (gnus-category-list))) @@ -1409,7 +2497,7 @@ (interactive "SCategory name: ") (when (assq category gnus-category-alist) (error "Category %s already exists" category)) - (push (list category 'false nil nil) + (push (gnus-agent-cat-make category) gnus-category-alist) (gnus-category-write) (gnus-category-list)) @@ -1434,6 +2522,7 @@ (long . gnus-agent-long-p) (low . gnus-agent-low-scored-p) (high . gnus-agent-high-scored-p) + (read . gnus-agent-read-p) (true . gnus-agent-true) (false . gnus-agent-false)) "Mapping from short score predicate symbols to predicate functions.") @@ -1465,9 +2554,18 @@ "Say whether an article has a high score or not." (> gnus-score gnus-agent-high-score)) -(defun gnus-category-make-function (cat) - "Make a function from category CAT." - `(lambda () ,(gnus-category-make-function-1 cat))) +(defun gnus-agent-read-p () + "Say whether an article is read or not." + (gnus-member-of-range (mail-header-number gnus-headers) + (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) + +(defun gnus-category-make-function (predicate) + "Make a function from PREDICATE." + (let ((func (gnus-category-make-function-1 predicate))) + (if (and (= (length func) 1) + (symbolp (car func))) + (car func) + (gnus-byte-compile `(lambda () ,func))))) (defun gnus-agent-true () "Return t." @@ -1477,33 +2575,91 @@ "Return nil." nil) -(defun gnus-category-make-function-1 (cat) - "Make a function from category CAT." +(defun gnus-category-make-function-1 (predicate) + "Make a function from PREDICATE." (cond ;; Functions are just returned as is. - ((or (symbolp cat) - (gnus-functionp cat)) - `(,(or (cdr (assq cat gnus-category-predicate-alist)) - cat))) - ;; More complex category. - ((consp cat) + ((or (symbolp predicate) + (functionp predicate)) + `(,(or (cdr (assq predicate gnus-category-predicate-alist)) + predicate))) + ;; More complex predicate. + ((consp predicate) `(,(cond - ((memq (car cat) '(& and)) + ((memq (car predicate) '(& and)) 'and) - ((memq (car cat) '(| or)) + ((memq (car predicate) '(| or)) 'or) - ((memq (car cat) gnus-category-not) + ((memq (car predicate) gnus-category-not) 'not)) - ,@(mapcar 'gnus-category-make-function-1 (cdr cat)))) + ,@(mapcar 'gnus-category-make-function-1 (cdr predicate)))) (t - (error "Unknown category type: %s" cat)))) + (error "Unknown predicate type: %s" predicate)))) (defun gnus-get-predicate (predicate) - "Return the predicate for CATEGORY." + "Return the function implementing PREDICATE." (or (cdr (assoc predicate gnus-category-predicate-cache)) - (cdar (push (cons predicate - (gnus-category-make-function predicate)) - gnus-category-predicate-cache)))) + (let ((func (gnus-category-make-function predicate))) + (setq gnus-category-predicate-cache + (nconc gnus-category-predicate-cache + (list (cons predicate func)))) + func))) + +(defun gnus-predicate-implies-unread (predicate) + "Say whether PREDICATE implies unread articles only. +It is okay to miss some cases, but there must be no false positives. +That is, if this predicate returns true, then indeed the predicate must +return only unread articles." + (eq t (gnus-function-implies-unread-1 + (gnus-category-make-function-1 predicate)))) + +(defun gnus-function-implies-unread-1 (function) + "Recursively evaluate a predicate function to determine whether it can select +any read articles. Returns t if the function is known to never +return read articles, nil when it is known to always return read +articles, and t_nil when the function may return both read and unread +articles." + (let ((func (car function)) + (args (mapcar 'gnus-function-implies-unread-1 (cdr function)))) + (cond ((eq func 'and) + (cond ((memq t args) ; if any argument returns only unread articles + ;; then that argument constrains the result to only unread articles. + t) + ((memq 't_nil args) ; if any argument is indeterminate + ;; then the result is indeterminate + 't_nil))) + ((eq func 'or) + (cond ((memq nil args) ; if any argument returns read articles + ;; then that argument ensures that the results includes read articles. + nil) + ((memq 't_nil args) ; if any argument is indeterminate + ;; then that argument ensures that the results are indeterminate + 't_nil) + (t ; if all arguments return only unread articles + ;; then the result returns only unread articles + t))) + ((eq func 'not) + (cond ((eq (car args) 't_nil) ; if the argument is indeterminate + ; then the result is indeterminate + (car args)) + (t ; otherwise + ; toggle the result to be the opposite of the argument + (not (car args))))) + ((eq func 'gnus-agent-read-p) + nil) ; The read predicate NEVER returns unread articles + ((eq func 'gnus-agent-false) + t) ; The false predicate returns t as the empty set excludes all read articles + ((eq func 'gnus-agent-true) + nil) ; The true predicate ALWAYS returns read articles + ((catch 'found-match + (let ((alist gnus-category-predicate-alist)) + (while alist + (if (eq func (cdar alist)) + (throw 'found-match t) + (setq alist (cdr alist)))))) + 't_nil) ; All other predicates return read and unread articles + (t + (error "Unknown predicate function: %s" function))))) (defun gnus-group-category (group) "Return the category GROUP belongs to." @@ -1512,188 +2668,1075 @@ (let ((cs gnus-category-alist) groups cat) (while (setq cat (pop cs)) - (setq groups (cadddr cat)) + (setq groups (gnus-agent-cat-groups cat)) (while groups (gnus-sethash (pop groups) cat gnus-category-group-cache))))) (or (gnus-gethash group gnus-category-group-cache) (assq 'default gnus-category-alist))) -(defun gnus-agent-expire () - "Expire all old articles." +(defun gnus-agent-expire-group (group &optional articles force) + "Expire all old articles in GROUP. +If you want to force expiring of certain articles, this function can +take ARTICLES, and FORCE parameters as well. + +The articles on which the expiration process runs are selected as follows: + if ARTICLES is null, all read and unmarked articles. + if ARTICLES is t, all articles. + if ARTICLES is a list, just those articles. +FORCE is equivalent to setting the expiration predicates to true." + (interactive + (list (let ((def (or (gnus-group-group-name) + gnus-newsgroup-name))) + (let ((select (read-string (if def + (concat "Group Name (" + def "): ") + "Group Name: ")))) + (if (and (equal "" select) + def) + def + select))))) + + (if (not group) + (gnus-agent-expire articles group force) + (let ( ;; Bind gnus-agent-expire-stats to enable tracking of + ;; expiration statistics of this single group + (gnus-agent-expire-stats (list 0 0 0.0))) + (if (or (not (eq articles t)) + (yes-or-no-p + (concat "Are you sure that you want to " + "expire all articles in " group "."))) + (let ((gnus-command-method (gnus-find-method-for-group group)) + (overview (gnus-get-buffer-create " *expire overview*")) + orig) + (unwind-protect + (let ((active-file (gnus-agent-lib-file "active"))) + (when (file-exists-p active-file) + (with-temp-buffer + (nnheader-insert-file-contents active-file) + (gnus-active-to-gnus-format + gnus-command-method + (setq orig (gnus-make-hashtable + (count-lines (point-min) (point-max)))))) + (save-excursion + (gnus-agent-expire-group-1 + group overview (gnus-gethash-safe group orig) + articles force)))) + (kill-buffer overview)))) + (gnus-message 4 (gnus-agent-expire-done-message))))) + +(defun gnus-agent-expire-group-1 (group overview active articles force) + ;; Internal function - requires caller to have set + ;; gnus-command-method, initialized overview buffer, and to have + ;; provided a non-nil active + + (let ((dir (gnus-agent-group-pathname group))) + (when (boundp 'gnus-agent-expire-current-dirs) + (set 'gnus-agent-expire-current-dirs + (cons dir + (symbol-value 'gnus-agent-expire-current-dirs)))) + + (if (and (not force) + (eq 'DISABLE (gnus-agent-find-parameter group + 'agent-enable-expiration))) + (gnus-message 5 "Expiry skipping over %s" group) + (gnus-message 5 "Expiring articles in %s" group) + (gnus-agent-load-alist group) + (let* ((stats (if (boundp 'gnus-agent-expire-stats) + ;; Use the list provided by my caller + (symbol-value 'gnus-agent-expire-stats) + ;; otherwise use my own temporary list + (list 0 0 0.0))) + (info (gnus-get-info group)) + (alist gnus-agent-article-alist) + (day (- (time-to-days (current-time)) + (gnus-agent-find-parameter group 'agent-days-until-old))) + (specials (if (and alist + (not force)) + ;; This could be a bit of a problem. I need to + ;; keep the last article to avoid refetching + ;; headers when using nntp in the backend. At + ;; the same time, if someone uses a backend + ;; that supports article moving then I may have + ;; to remove the last article to complete the + ;; move. Right now, I'm going to assume that + ;; FORCE overrides specials. + (list (caar (last alist))))) + (unreads ;; Articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are marked read by global decree + nil) + ((eq articles t) + ;; All articles are marked read by function + ;; parameter + nil) + ((not articles) + ;; Unread articles are marked protected from + ;; expiration Don't call + ;; gnus-list-of-unread-articles as it returns + ;; articles that have not been fetched into the + ;; agent. + (ignore-errors + (gnus-agent-unread-articles group))) + (t + ;; All articles EXCEPT those named by the caller + ;; are protected from expiration + (gnus-sorted-difference + (gnus-uncompress-range + (cons (caar alist) + (caar (last alist)))) + (sort articles '<))))) + (marked ;; More articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are unmarked by global decree + nil) + ((eq articles t) + ;; All articles are unmarked by function + ;; parameter + nil) + (articles + ;; All articles may as well be unmarked as the + ;; unreads list already names the articles we are + ;; going to keep + nil) + (t + ;; Ticked and/or dormant articles are excluded + ;; from expiration + (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant + (gnus-info-marks info)))))))) + (nov-file (concat dir ".overview")) + (cnt 0) + (completed -1) + dlist + type) + + ;; The normal article alist contains elements that look like + ;; (article# . fetch_date) I need to combine other + ;; information with this list. For example, a flag indicating + ;; that a particular article MUST BE KEPT. To do this, I'm + ;; going to transform the elements to look like (article# + ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse + ;; the process to generate the expired article alist. + + ;; Convert the alist elements to (article# fetch_date nil + ;; nil). + (setq dlist (mapcar (lambda (e) + (list (car e) (cdr e) nil nil)) alist)) + + ;; Convert the keep lists to elements that look like (article# + ;; nil keep_flag nil) then append it to the expanded dlist + ;; These statements are sorted by ascending precidence of the + ;; keep_flag. + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'unread nil)) + unreads))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'marked nil)) + marked))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'special nil)) + specials))) + + (set-buffer overview) + (erase-buffer) + (buffer-disable-undo) + (when (file-exists-p nov-file) + (gnus-message 7 "gnus-agent-expire: Loading overview...") + (nnheader-insert-file-contents nov-file) + (goto-char (point-min)) + + (let (p) + (while (< (setq p (point)) (point-max)) + (condition-case nil + ;; If I successfully read an integer (the plus zero + ;; ensures a numeric type), prepend a marker entry + ;; to the list + (push (list (+ 0 (read (current-buffer))) nil nil + (set-marker (make-marker) p)) + dlist) + (error + (gnus-message 1 "gnus-agent-expire: read error \ +occurred when reading expression at %s in %s. Skipping to next \ +line." (point) nov-file))) + ;; Whether I succeeded, or failed, it doesn't matter. + ;; Move to the next line then try again. + (forward-line 1))) + + (gnus-message + 7 "gnus-agent-expire: Loading overview... Done")) + (set-buffer-modified-p nil) + + ;; At this point, all of the information is in dlist. The + ;; only problem is that much of it is spread across multiple + ;; entries. Sort then MERGE!! + (gnus-message 7 "gnus-agent-expire: Sorting entries... ") + ;; If two entries have the same article-number then sort by + ;; ascending keep_flag. + (let ((special 0) + (marked 1) + (unread 2)) + (setq dlist + (sort dlist + (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + (let ((a (or (symbol-value (nth 2 a)) + 3)) + (b (or (symbol-value (nth 2 b)) + 3))) + (<= a b)))))))) + (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") + (gnus-message 7 "gnus-agent-expire: Merging entries... ") + (let ((dlist dlist)) + (while (cdr dlist) ; I'm not at the end-of-list + (if (eq (caar dlist) (caadr dlist)) + (let ((first (cdr (car dlist))) + (secnd (cdr (cadr dlist)))) + (setcar first (or (car first) + (car secnd))) ; fetch_date + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; Keep_flag + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; NOV_entry_marker + + (setcdr dlist (cddr dlist))) + (setq dlist (cdr dlist))))) + (gnus-message 7 "gnus-agent-expire: Merging entries... Done") + + (let* ((len (float (length dlist))) + (alist (list nil)) + (tail-alist alist)) + (while dlist + (let ((new-completed (truncate (* 100.0 + (/ (setq cnt (1+ cnt)) + len)))) + message-log-max) + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 7 "%3d%% completed..." completed))) + (let* ((entry (car dlist)) + (article-number (nth 0 entry)) + (fetch-date (nth 1 entry)) + (keep (nth 2 entry)) + (marker (nth 3 entry))) + + (cond + ;; Kept articles are unread, marked, or special. + (keep + (gnus-agent-message 10 + "gnus-agent-expire: %s:%d: Kept %s article%s." + group article-number keep (if fetch-date " and file" "")) + (when fetch-date + (unless (file-exists-p + (concat dir (number-to-string + article-number))) + (setf (nth 1 entry) nil) + (gnus-agent-message 3 "gnus-agent-expire cleared \ +download flag on %s:%d as the cached article file is missing." + group (caar dlist))) + (unless marker + (gnus-message 1 "gnus-agent-expire detected a \ +missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) + (gnus-agent-append-to-list + tail-alist + (cons article-number fetch-date))) + + ;; The following articles are READ, UNMARKED, and + ;; ORDINARY. See if they can be EXPIRED!!! + ((setq type + (cond + ((not (integerp fetch-date)) + 'read) ;; never fetched article (may expire + ;; right now) + ((not (file-exists-p + (concat dir (number-to-string + article-number)))) + (setf (nth 1 entry) nil) + 'externally-expired) ;; Can't find the cached + ;; article. Handle case + ;; as though this article + ;; was never fetched. + + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + ((< fetch-date day) + 'expired) + (force + 'forced))) + + ;; I found some reason to expire this entry. + + (let ((actions nil)) + (when (memq type '(forced expired)) + (ignore-errors ; Just being paranoid. + (let ((file-name (concat dir (number-to-string + article-number)))) + (incf (nth 2 stats) (nth 7 (file-attributes file-name))) + (incf (nth 1 stats)) + (delete-file file-name)) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil) + ) + + (when marker + (push "NOV entry removed" actions) + (goto-char marker) + + (incf (nth 0 stats)) + + (let ((from (gnus-point-at-bol)) + (to (progn (forward-line 1) (point)))) + (incf (nth 2 stats) (- to from)) + (delete-region from to))) + + ;; If considering all articles is set, I can only + ;; expire article IDs that are no longer in the + ;; active range (That is, articles that preceed the + ;; first article in the new alist). + (if (and gnus-agent-consider-all-articles + (>= article-number (car active))) + ;; I have to keep this ID in the alist + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date)) + (push (format "Removed %s article number from \ +article alist" type) actions)) + + (when actions + (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" + group article-number + (mapconcat 'identity actions ", "))))) + (t + (gnus-agent-message + 10 "gnus-agent-expire: %s:%d: Article kept as \ +expiration tests failed." group article-number) + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date))) + ) + + ;; Clean up markers as I want to recycle this buffer + ;; over several groups. + (when marker + (set-marker marker nil)) + + (setq dlist (cdr dlist)))) + + (setq alist (cdr alist)) + + (let ((inhibit-quit t)) + (unless (equal alist gnus-agent-article-alist) + (setq gnus-agent-article-alist alist) + (gnus-agent-save-alist group)) + + (when (buffer-modified-p) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-make-directory dir) + (write-region (point-min) (point-max) nov-file nil + 'silent) + ;; clear the modified flag as that I'm not confused by + ;; its status on the next pass through this routine. + (set-buffer-modified-p nil))) + + (when (eq articles t) + (gnus-summary-update-info)))))))) + +(defun gnus-agent-expire (&optional articles group force) + "Expire all old articles. +If you want to force expiring of certain articles, this function can +take ARTICLES, GROUP and FORCE parameters as well. + +The articles on which the expiration process runs are selected as follows: + if ARTICLES is null, all read and unmarked articles. + if ARTICLES is t, all articles. + if ARTICLES is a list, just those articles. +Setting GROUP will limit expiration to that group. +FORCE is equivalent to setting the expiration predicates to true." (interactive) - (let ((methods gnus-agent-covered-methods) - (day (- (time-to-days (current-time)) gnus-agent-expire-days)) - gnus-command-method sym group articles - history overview file histories elem art nov-file low info - unreads marked article orig lowest highest) - (save-excursion - (setq overview (gnus-get-buffer-create " *expire overview*")) - (while (setq gnus-command-method (pop methods)) - (when (file-exists-p (gnus-agent-lib-file "active")) - (with-temp-buffer - (nnheader-insert-file-contents (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format - gnus-command-method - (setq orig (gnus-make-hashtable - (count-lines (point-min) (point-max)))))) - (let ((expiry-hashtb (gnus-make-hashtable 1023))) - (gnus-agent-open-history) - (set-buffer - (setq gnus-agent-current-history - (setq history (gnus-agent-history-buffer)))) - (goto-char (point-min)) - (when (> (buffer-size) 1) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^\t") - (if (> (read (current-buffer)) day) - ;; New article; we don't expire it. - (forward-line 1) - ;; Old article. Schedule it for possible nuking. - (while (not (eolp)) - (setq sym (let ((obarray expiry-hashtb) s) - (setq s (read (current-buffer))) - (if (stringp s) (intern s) s))) - (if (boundp sym) - (set sym (cons (cons (read (current-buffer)) (point)) - (symbol-value sym))) - (set sym (list (cons (read (current-buffer)) (point))))) - (skip-chars-forward " ")) - (forward-line 1))) - ;; We now have all articles that can possibly be expired. - (mapatoms - (lambda (sym) - (setq group (symbol-name sym) - articles (sort (symbol-value sym) 'car-less-than-car) - low (car (gnus-active group)) - info (gnus-get-info group) - unreads (ignore-errors - (gnus-list-of-unread-articles group)) - marked (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info))))) - nov-file (gnus-agent-article-name ".overview" group) - lowest nil - highest nil) - (gnus-agent-load-alist group) - (gnus-message 5 "Expiring articles in %s" group) - (set-buffer overview) - (erase-buffer) - (when (file-exists-p nov-file) - (nnheader-insert-file-contents nov-file)) - (goto-char (point-min)) - (setq article 0) - (while (setq elem (pop articles)) - (setq article (car elem)) - (when (or (null low) - (< article low) - gnus-agent-expire-all - (and (not (memq article unreads)) - (not (memq article marked)))) - ;; Find and nuke the NOV line. - (while (and (not (eobp)) - (or (not (numberp - (setq art (read (current-buffer))))) - (< art article))) - (if (and (numberp art) - (file-exists-p - (gnus-agent-article-name - (number-to-string art) group))) - (progn - (unless lowest - (setq lowest art)) - (setq highest art) - (forward-line 1)) - ;; Remove old NOV lines that have no articles. - (gnus-delete-line))) - (if (or (eobp) - (/= art article)) - (beginning-of-line) - (gnus-delete-line)) - ;; Nuke the article. - (when (file-exists-p - (setq file (gnus-agent-article-name - (number-to-string article) - group))) - (delete-file file)) - ;; Schedule the history line for nuking. - (push (cdr elem) histories))) - (gnus-make-directory (file-name-directory nov-file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) nov-file nil 'silent)) - ;; Delete the unwanted entries in the alist. - (setq gnus-agent-article-alist - (sort gnus-agent-article-alist 'car-less-than-car)) - (let* ((alist gnus-agent-article-alist) - (prev (cons nil alist)) - (first prev) - expired) - (while (and alist - (<= (caar alist) article)) - (if (or (not (cdar alist)) - (not (file-exists-p - (gnus-agent-article-name - (number-to-string - (caar alist)) - group)))) - (progn - (push (caar alist) expired) - (setcdr prev (setq alist (cdr alist)))) - (setq prev alist - alist (cdr alist)))) - (setq gnus-agent-article-alist (cdr first)) - (gnus-agent-save-alist group) - ;; Mark all articles up to the first article - ;; in `gnus-article-alist' as read. - (when (and info (caar gnus-agent-article-alist)) - (setcar (nthcdr 2 info) - (gnus-range-add - (nth 2 info) - (cons 1 (- (caar gnus-agent-article-alist) 1))))) - ;; Maybe everything has been expired from `gnus-article-alist' - ;; and so the above marking as read could not be conducted, - ;; or there are expired article within the range of the alist. - (when (and info - expired - (or (not (caar gnus-agent-article-alist)) - (> (car expired) - (caar gnus-agent-article-alist)))) - (setcar (nthcdr 2 info) - (gnus-add-to-range - (nth 2 info) - (nreverse expired)))) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))) - (when lowest - (if (gnus-gethash group orig) - (setcar (gnus-gethash group orig) lowest) - (gnus-sethash group (cons lowest highest) orig)))) - expiry-hashtb) - (set-buffer history) - (setq histories (nreverse (sort histories '<))) - (while histories - (goto-char (pop histories)) - (gnus-delete-line)) - (gnus-agent-save-history) - (gnus-agent-close-history) - (gnus-write-active-file - (gnus-agent-lib-file "active") orig)) - (gnus-message 4 "Expiry...done"))))))) + + (if group + (gnus-agent-expire-group group articles force) + (if (or (not (eq articles t)) + (yes-or-no-p "Are you sure that you want to expire all \ +articles in every agentized group.")) + (let ((methods (gnus-agent-covered-methods)) + ;; Bind gnus-agent-expire-current-dirs to enable tracking + ;; of agent directories. + (gnus-agent-expire-current-dirs nil) + ;; Bind gnus-agent-expire-stats to enable tracking of + ;; expiration statistics across all groups + (gnus-agent-expire-stats (list 0 0 0.0)) + gnus-command-method overview orig) + (setq overview (gnus-get-buffer-create " *expire overview*")) + (unwind-protect + (while (setq gnus-command-method (pop methods)) + (let ((active-file (gnus-agent-lib-file "active"))) + (when (file-exists-p active-file) + (with-temp-buffer + (nnheader-insert-file-contents active-file) + (gnus-active-to-gnus-format + gnus-command-method + (setq orig (gnus-make-hashtable + (count-lines (point-min) (point-max)))))) + (dolist (expiring-group (gnus-groups-from-server + gnus-command-method)) + (let* ((active + (gnus-gethash-safe expiring-group orig))) + + (when active + (save-excursion + (gnus-agent-expire-group-1 + expiring-group overview active articles force)))))))) + (kill-buffer overview)) + (gnus-agent-expire-unagentized-dirs) + (gnus-message 4 (gnus-agent-expire-done-message)))))) + +(defun gnus-agent-expire-done-message () + (if (and (> gnus-verbose 4) + (boundp 'gnus-agent-expire-stats)) + (let* ((stats (symbol-value 'gnus-agent-expire-stats)) + (size (nth 2 stats)) + (units '(B KB MB GB))) + (while (and (> size 1024.0) + (cdr units)) + (setq size (/ size 1024.0) + units (cdr units))) + + (format "Expiry recovered %d NOV entries, deleted %d files,\ + and freed %f %s." + (nth 0 stats) + (nth 1 stats) + size (car units))) + "Expiry...done")) + +(defun gnus-agent-expire-unagentized-dirs () + (when (and gnus-agent-expire-unagentized-dirs + (boundp 'gnus-agent-expire-current-dirs)) + (let* ((keep (gnus-make-hashtable)) + ;; Formally bind gnus-agent-expire-current-dirs so that the + ;; compiler will not complain about free references. + (gnus-agent-expire-current-dirs + (symbol-value 'gnus-agent-expire-current-dirs)) + dir) + + (gnus-sethash gnus-agent-directory t keep) + (while gnus-agent-expire-current-dirs + (setq dir (pop gnus-agent-expire-current-dirs)) + (when (and (stringp dir) + (file-directory-p dir)) + (while (not (gnus-gethash dir keep)) + (gnus-sethash dir t keep) + (setq dir (file-name-directory (directory-file-name dir)))))) + + (let* (to-remove + checker + (checker + (function + (lambda (d) + "Given a directory, check it and its subdirectories for + membership in the keep hash. If it isn't found, add + it to to-remove." + (let ((files (directory-files d)) + file) + (while (setq file (pop files)) + (cond ((equal file ".") ; Ignore self + nil) + ((equal file "..") ; Ignore parent + nil) + ((equal file ".overview") + ;; Directory must contain .overview to be + ;; agent's cache of a group. + (let ((d (file-name-as-directory d)) + r) + ;; Search ancestor's for last directory NOT + ;; found in keep hash. + (while (not (gnus-gethash + (setq d (file-name-directory d)) keep)) + (setq r d + d (directory-file-name d))) + ;; if ANY ancestor was NOT in keep hash and + ;; it it's already in to-remove, add it to + ;; to-remove. + (if (and r + (not (member r to-remove))) + (push r to-remove)))) + ((file-directory-p (setq file (nnheader-concat d file))) + (funcall checker file))))))))) + (funcall checker (expand-file-name gnus-agent-directory)) + + (when (and to-remove + (or gnus-expert-user + (gnus-y-or-n-p + "gnus-agent-expire has identified local directories that are\ + not currently required by any agentized group. Do you wish to consider\ + deleting them?"))) + (while to-remove + (let ((dir (pop to-remove))) + (if (gnus-y-or-n-p (format "Delete %s? " dir)) + (let* (delete-recursive + (delete-recursive + (function + (lambda (f-or-d) + (ignore-errors + (if (file-directory-p f-or-d) + (condition-case nil + (delete-directory f-or-d) + (file-error + (mapcar (lambda (f) + (or (member f '("." "..")) + (funcall delete-recursive + (nnheader-concat + f-or-d f)))) + (directory-files f-or-d)) + (delete-directory f-or-d))) + (delete-file f-or-d))))))) + (funcall delete-recursive dir)))))))))) ;;;###autoload (defun gnus-agent-batch () + "Start Gnus, send queue and fetch session." (interactive) (let ((init-file-user "") (gnus-always-read-dribble-file t)) (gnus)) - (gnus-group-send-drafts) - (gnus-agent-fetch-session)) + (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) + (gnus-group-send-queue) + (gnus-agent-fetch-session))) + +(defun gnus-agent-unread-articles (group) + (let* ((read (gnus-info-read (gnus-get-info group))) + (known (gnus-agent-load-alist group)) + (unread (list nil)) + (tail-unread unread)) + (while (and known read) + (let ((candidate (car (pop known)))) + (while (let* ((range (car read)) + (min (if (numberp range) range (car range))) + (max (if (numberp range) range (cdr range)))) + (cond ((or (not min) + (< candidate min)) + (gnus-agent-append-to-list tail-unread candidate) + nil) + ((> candidate max) + (setq read (cdr read)) + ;; return t so that I always loop one more + ;; time. If I just iterated off the end of + ;; read, min will become nil and the current + ;; candidate will be added to the unread list. + t)))))) + (while known + (gnus-agent-append-to-list tail-unread (car (pop known)))) + (cdr unread))) + +(defun gnus-agent-uncached-articles (articles group &optional cached-header) + "Restrict ARTICLES to numbers already fetched. +Returns a sublist of ARTICLES that excludes thos article ids in GROUP +that have already been fetched. +If CACHED-HEADER is nil, articles are only excluded if the article itself +has been fetched." + + ;; Logically equivalent to: (gnus-sorted-difference articles (mapcar + ;; 'car gnus-agent-article-alist)) + + ;; Functionally, I don't need to construct a temp list using mapcar. + + (if (and (or gnus-agent-cache (not gnus-plugged)) + (gnus-agent-load-alist group)) + (let* ((ref gnus-agent-article-alist) + (arts articles) + (uncached (list nil)) + (tail-uncached uncached)) + (while (and ref arts) + (let ((v1 (car arts)) + (v2 (caar ref))) + (cond ((< v1 v2) ; v1 does not appear in the reference list + (gnus-agent-append-to-list tail-uncached v1) + (setq arts (cdr arts))) + ((= v1 v2) + (unless (or cached-header (cdar ref)) ; v1 is already cached + (gnus-agent-append-to-list tail-uncached v1)) + (setq arts (cdr arts)) + (setq ref (cdr ref))) + (t ; reference article (v2) preceeds the list being filtered + (setq ref (cdr ref)))))) + (while arts + (gnus-agent-append-to-list tail-uncached (pop arts))) + (cdr uncached)) + ;; if gnus-agent-load-alist fails, no articles are cached. + articles)) + +(defun gnus-agent-retrieve-headers (articles group &optional fetch-old) + (save-excursion + (gnus-agent-create-buffer) + (let ((gnus-decode-encoded-word-function 'identity) + (file (gnus-agent-article-name ".overview" group)) + cached-articles uncached-articles) + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + + ;; Populate temp buffer with known headers + (when (file-exists-p file) + (with-current-buffer gnus-agent-overview-buffer + (erase-buffer) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-nov-file file (car articles))))) + + (if (setq uncached-articles (gnus-agent-uncached-articles articles group + t)) + (progn + ;; Populate nntp-server-buffer with uncached headers + (set-buffer nntp-server-buffer) + (erase-buffer) + (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent + (gnus-retrieve-headers + uncached-articles group fetch-old)))) + (nnvirtual-convert-headers)) + ((eq 'nntp (car gnus-current-select-method)) + ;; The author of gnus-get-newsgroup-headers-xover + ;; reports that the XOVER command is commonly + ;; unreliable. The problem is that recently + ;; posted articles may not be entered into the + ;; NOV database in time to respond to my XOVER + ;; query. + ;; + ;; I'm going to use his assumption that the NOV + ;; database is updated in order of ascending + ;; article ID. Therefore, a response containing + ;; article ID N implies that all articles from 1 + ;; to N-1 are up-to-date. Therefore, missing + ;; articles in that range have expired. + + (set-buffer nntp-server-buffer) + (let* ((fetched-articles (list nil)) + (tail-fetched-articles fetched-articles) + (min (cond ((numberp fetch-old) + (max 1 (- (car articles) fetch-old))) + (fetch-old + 1) + (t + (car articles)))) + (max (car (last articles)))) + + ;; Get the list of articles that were fetched + (goto-char (point-min)) + (let ((pm (point-max))) + (while (< (point) pm) + (when (looking-at "[0-9]+\t") + (gnus-agent-append-to-list + tail-fetched-articles + (read (current-buffer)))) + (forward-line 1))) + + ;; Clip this list to the headers that will + ;; actually be returned + (setq fetched-articles (gnus-list-range-intersection + (cdr fetched-articles) + (cons min max))) + + ;; Clip the uncached articles list to exclude + ;; IDs after the last FETCHED header. The + ;; excluded IDs may be fetchable using HEAD. + (if (car tail-fetched-articles) + (setq uncached-articles + (gnus-list-range-intersection + uncached-articles + (cons (car uncached-articles) + (car tail-fetched-articles))))) + + ;; Create the list of articles that were + ;; "successfully" fetched. Success, in this + ;; case, means that the ID should not be + ;; fetched again. In the case of an expired + ;; article, the header will not be fetched. + (setq uncached-articles + (gnus-sorted-nunion fetched-articles + uncached-articles)) + ))) + + ;; Erase the temp buffer + (set-buffer gnus-agent-overview-buffer) + (erase-buffer) + + ;; Copy the nntp-server-buffer to the temp buffer + (set-buffer nntp-server-buffer) + (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + + ;; Merge the temp buffer with the known headers (found on + ;; disk in FILE) into the nntp-server-buffer + (when (and uncached-articles (file-exists-p file)) + (gnus-agent-braid-nov group uncached-articles file)) + + ;; Save the new set of known headers to FILE + (set-buffer nntp-server-buffer) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + + ;; Update the group's article alist to include the newly + ;; fetched articles. + (gnus-agent-load-alist group) + (gnus-agent-save-alist group uncached-articles nil) + ) + + ;; Copy the temp buffer to the nntp-server-buffer + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring gnus-agent-overview-buffer))) + + (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) + + 'nov)) + +(defun gnus-agent-request-article (article group) + "Retrieve ARTICLE in GROUP from the agent cache." + (when (and gnus-agent + (or gnus-agent-cache + (not gnus-plugged)) + (numberp article)) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (file (gnus-agent-article-name (number-to-string article) group)) + (buffer-read-only nil)) + (when (and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((coding-system-for-read gnus-cache-coding-system)) + (insert-file-contents file)) + t)))) + +(defun gnus-agent-regenerate-group (group &optional reread) + "Regenerate GROUP. +If REREAD is t, all articles in the .overview are marked as unread. +If REREAD is a list, the specified articles will be marked as unread. +In addition, their NOV entries in .overview will be refreshed using +the articles' current headers. +If REREAD is not nil, downloaded articles are marked as unread." + (interactive + (list (let ((def (or (gnus-group-group-name) + gnus-newsgroup-name))) + (let ((select (read-string (if def + (concat "Group Name (" + def "): ") + "Group Name: ")))) + (if (and (equal "" select) + def) + def + select))) + (catch 'mark + (while (let (c + (cursor-in-echo-area t) + (echo-keystrokes 0)) + (message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ") + (setq c (read-char-exclusive)) + + (cond ((or (eq c ?\r) (eq c ?n) (eq c ?N)) + (throw 'mark nil)) + ((or (eq c ?a) (eq c ?A)) + (throw 'mark t)) + ((or (eq c ?d) (eq c ?D)) + (throw 'mark 'some))) + (gnus-message 3 "Ignoring unexpected input") + (sit-for 1) + t))))) + + (when group + (gnus-message 5 "Regenerating in %s" group) + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group))) + (file (gnus-agent-article-name ".overview" group)) + (dir (file-name-directory file)) + point + (downloaded (if (file-exists-p dir) + (sort (mapcar (lambda (name) (string-to-int name)) + (directory-files dir nil "^[0-9]+$" t)) + '>) + (progn (gnus-make-directory dir) nil))) + dl nov-arts + alist header + regenerated) + + (mm-with-unibyte-buffer + (if (file-exists-p file) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file))) + (set-buffer-modified-p nil) + + ;; Load the article IDs found in the overview file. As a + ;; side-effect, validate the file contents. + (let ((load t)) + (while load + (setq load nil) + (goto-char (point-min)) + (while (< (point) (point-max)) + (cond ((and (looking-at "[0-9]+\t") + (<= (- (match-end 0) (match-beginning 0)) 9)) + (push (read (current-buffer)) nov-arts) + (forward-line 1) + (let ((l1 (car nov-arts)) + (l2 (cadr nov-arts))) + (cond ((and (listp reread) (memq l1 reread)) + (gnus-delete-line) + (setq nov-arts (cdr nov-arts)) + (gnus-message 4 "gnus-agent-regenerate-group: NOV\ +entry of article %s deleted." l1)) + ((not l2) + nil) + ((< l1 l2) + (gnus-message 3 "gnus-agent-regenerate-group: NOV\ + entries are NOT in ascending order.") + ;; Don't sort now as I haven't verified + ;; that every line begins with a number + (setq load t)) + ((= l1 l2) + (forward-line -1) + (gnus-message 4 "gnus-agent-regenerate-group: NOV\ + entries contained duplicate of article %s. Duplicate deleted." l1) + (gnus-delete-line) + (setq nov-arts (cdr nov-arts)))))) + (t + (gnus-message 1 "gnus-agent-regenerate-group: NOV\ + entries contained line that did not begin with an article number. Deleted\ + line.") + (gnus-delete-line)))) + (when load + (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ + entries into ascending order.") + (sort-numeric-fields 1 (point-min) (point-max)) + (setq nov-arts nil)))) + (gnus-agent-check-overview-buffer) + + ;; Construct a new article alist whose nodes match every header + ;; in the .overview file. As a side-effect, missing headers are + ;; reconstructed from the downloaded article file. + (while (or downloaded nov-arts) + (cond ((and downloaded + (or (not nov-arts) + (> (car downloaded) (car nov-arts)))) + ;; This entry is missing from the overview file + (gnus-message 3 "Regenerating NOV %s %d..." group + (car downloaded)) + (let ((file (concat dir (number-to-string (car downloaded))))) + (mm-with-unibyte-buffer + (nnheader-insert-file-contents file) + (nnheader-remove-body) + (setq header (nnheader-parse-naked-head))) + (mail-header-set-number header (car downloaded)) + (if nov-arts + (let ((key (concat "^" (int-to-string (car nov-arts)) + "\t"))) + (or (re-search-backward key nil t) + (re-search-forward key)) + (forward-line 1)) + (goto-char (point-min))) + (nnheader-insert-nov header)) + (setq nov-arts (cons (car downloaded) nov-arts))) + ((eq (car downloaded) (car nov-arts)) + ;; This entry in the overview has been downloaded + (push (cons (car downloaded) + (time-to-days + (nth 5 (file-attributes + (concat dir (number-to-string + (car downloaded))))))) alist) + (setq downloaded (cdr downloaded)) + (setq nov-arts (cdr nov-arts))) + (t + ;; This entry in the overview has not been downloaded + (push (cons (car nov-arts) nil) alist) + (setq nov-arts (cdr nov-arts))))) + + ;; When gnus-agent-consider-all-articles is set, + ;; gnus-agent-regenerate-group should NOT remove article IDs from + ;; the alist. Those IDs serve as markers to indicate that an + ;; attempt has been made to fetch that article's header. + + ;; When gnus-agent-consider-all-articles is NOT set, + ;; gnus-agent-regenerate-group can remove the article ID of every + ;; article (with the exception of the last ID in the list - it's + ;; special) that no longer appears in the overview. In this + ;; situtation, the last article ID in the list implies that it, + ;; and every article ID preceeding it, have been fetched from the + ;; server. + + (if gnus-agent-consider-all-articles + ;; Restore all article IDs that were not found in the overview file. + (let* ((n (cons nil alist)) + (merged n) + (o (gnus-agent-load-alist group))) + (while o + (let ((nID (caadr n)) + (oID (caar o))) + (cond ((not nID) + (setq n (setcdr n (list (list oID)))) + (setq o (cdr o))) + ((< oID nID) + (setcdr n (cons (list oID) (cdr n))) + (setq o (cdr o))) + ((= oID nID) + (setq o (cdr o)) + (setq n (cdr n))) + (t + (setq n (cdr n)))))) + (setq alist (cdr merged))) + ;; Restore the last article ID if it is not already in the new alist + (let ((n (last alist)) + (o (last (gnus-agent-load-alist group)))) + (cond ((not o) + nil) + ((not n) + (push (cons (caar o) nil) alist)) + ((< (caar n) (caar o)) + (setcdr n (list (car o))))))) + + (let ((inhibit-quit t)) + (if (setq regenerated (buffer-modified-p)) + (let ((coding-system-for-write gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) file nil 'silent))) + + (setq regenerated (or regenerated + (and reread gnus-agent-article-alist) + (not (equal alist gnus-agent-article-alist)))) + + (setq gnus-agent-article-alist alist) + + (when regenerated + (gnus-agent-save-alist group) + + ;; I have to alter the group's active range NOW as + ;; gnus-make-ascending-articles-unread will use it to + ;; recalculate the number of unread articles in the group + + (let ((group (gnus-group-real-name group)) + (group-active (gnus-active group))) + (gnus-agent-possibly-alter-active group group-active))))) + + (when (and reread gnus-agent-article-alist) + (gnus-make-ascending-articles-unread + group + (if (listp reread) + reread + (delq nil (mapcar (function (lambda (c) + (cond ((eq reread t) + (car c)) + ((cdr c) + (car c))))) + gnus-agent-article-alist)))) + + (when (gnus-buffer-live-p gnus-group-buffer) + (gnus-group-update-group group t) + (sit-for 0))) + + (gnus-message 5 nil) + regenerated))) + +;;;###autoload +(defun gnus-agent-regenerate (&optional clean reread) + "Regenerate all agent covered files. +If CLEAN, obsolete (ignore)." + (interactive "P") + (let (regenerated) + (gnus-message 4 "Regenerating Gnus agent files...") + (dolist (gnus-command-method (gnus-agent-covered-methods)) + (dolist (group (gnus-groups-from-server gnus-command-method)) + (setq regenerated (or (gnus-agent-regenerate-group group reread) + regenerated)))) + (gnus-message 4 "Regenerating Gnus agent files...done") + + regenerated)) + +(defun gnus-agent-go-online (&optional force) + "Switch servers into online status." + (interactive (list t)) + (dolist (server gnus-opened-servers) + (when (eq (nth 1 server) 'offline) + (if (if (eq force 'ask) + (gnus-y-or-n-p + (format "Switch %s:%s into online status? " + (caar server) (cadar server))) + force) + (setcar (nthcdr 1 server) 'close))))) + +(defun gnus-agent-toggle-group-plugged (group) + "Toggle the status of the server of the current group." + (interactive (list (gnus-group-group-name))) + (let* ((method (gnus-find-method-for-group group)) + (status (cadr (assoc method gnus-opened-servers)))) + (if (eq status 'offline) + (gnus-server-set-status method 'closed) + (gnus-close-server method) + (gnus-server-set-status method 'offline)) + (message "Turn %s:%s from %s to %s." (car method) (cadr method) + (if (eq status 'offline) 'offline 'online) + (if (eq status 'offline) 'online 'offline)))) + +(defun gnus-agent-group-covered-p (group) + (gnus-agent-method-p (gnus-group-method group))) + +(add-hook 'gnus-group-prepare-hook + (lambda () + 'gnus-agent-do-once + + (when (listp gnus-agent-expire-days) + (beep) + (beep) + (gnus-message 1 "WARNING: gnus-agent-expire-days no longer\ + supports being set to a list.")(sleep-for 3) + (gnus-message 1 "Change your configuration to set it to an\ + integer.")(sleep-for 3) + (gnus-message 1 "I am now setting group parameters on each\ + group to match the configuration that the list offered.") + + (save-excursion + (let ((groups (gnus-group-listed-groups))) + (while groups + (let* ((group (pop groups)) + (days gnus-agent-expire-days) + (day (catch 'found + (while days + (when (eq 0 (string-match + (caar days) + group)) + (throw 'found (cadar days))) + (setq days (cdr days))) + nil))) + (when day + (gnus-group-set-parameter group 'agent-days-until-old + day)))))) + + (let ((h gnus-group-prepare-hook)) + (while h + (let ((func (pop h))) + (when (and (listp func) + (eq (cadr (caddr func)) 'gnus-agent-do-once)) + (remove-hook 'gnus-group-prepare-hook func) + (setq h nil))))) + + (gnus-message 1 "I have finished setting group parameters on\ + each group. You may now customize your groups and/or topics to control the\ + agent.")))) (provide 'gnus-agent)
--- a/lisp/gnus/gnus-art.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-art.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,7 +1,6 @@ ;;; gnus-art.el --- article mode commands for Gnus - -;; Copyright (C) 1996, 97, 98, 1999, 2000, 01, 02, 2004 -;; Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -27,18 +26,26 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (defvar tool-bar-map)) (require 'gnus) (require 'gnus-sum) (require 'gnus-spec) (require 'gnus-int) +(require 'gnus-win) (require 'mm-bodies) (require 'mail-parse) (require 'mm-decode) (require 'mm-view) (require 'wid-edit) (require 'mm-uu) +(require 'message) + +(autoload 'gnus-msg-mail "gnus-msg" nil t) +(autoload 'gnus-button-mailto "gnus-msg") +(autoload 'gnus-button-reply "gnus-msg" nil t) (defgroup gnus-article nil "Article display." @@ -102,33 +109,47 @@ :group 'gnus-article) (defcustom gnus-ignored-headers - '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:" - "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" - "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:" - "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:" - "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:" - "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:" - "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:" - "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:" - "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:" - "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:" - "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:" - "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" - "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" - "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" - "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:" - "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" - "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" - "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:" - "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:" - "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:" - "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:" - "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:" - "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:" - "^List-[A-Za-z]+:" "^X-Listprocessor-Version:" - "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:" - "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:" - "^X-Received:" "^Content-length:" "X-precedence:") + (mapcar + (lambda (header) + (concat "^" header ":")) + '("Path" "Expires" "Date-Received" "References" "Xref" "Lines" + "Relay-Version" "Message-ID" "Approved" "Sender" "Received" + "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To" + "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature" + "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop" + "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face" + "X-Attribution" "X-Originating-IP" "Delivered-To" + "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace" + "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*" + "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date" + "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache" + "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time" + "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List" + "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt" + "Old-Received" "X-Pgp" "X-Auth" "X-From-Line" + "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender" + "MBOX-Line" "Priority" "X400-[-A-Za-z]+" + "Status" "X-Gnus-Mail-Source" "Cancel-Lock" + "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance" + "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3" + "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT" + "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin" + "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender" + "List-[A-Za-z]+" "X-Listprocessor-Version" + "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks" + "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway" + "X-Received" "Content-length" "X-precedence" + "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info" + "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup" + "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To" + "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post" + "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive" + "X-Content-length" "X-Posting-Agent" "Original-Received" + "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom" + "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway" + "X-Local-Origin" "X-Local-Destination" "X-UserInfo1" + "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications" + "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer")) "*All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." @@ -138,7 +159,7 @@ :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." @@ -162,17 +183,39 @@ (defcustom gnus-boring-article-headers '(empty followup-to reply-to) "Headers that are only to be displayed if they have interesting data. -Possible values in this list are `empty', `newsgroups', `followup-to', -`reply-to', `date', `long-to', and `many-to'." +Possible values in this list are: + + 'empty Headers with no content. + 'newsgroups Newsgroup identical to Gnus group. + 'to-address To identical to To-address. + 'to-list To identical to To-list. + 'cc-list CC identical to To-list. + 'followup-to Followup-to identical to Newsgroups. + 'reply-to Reply-to identical to From. + 'date Date less than four days old. + 'long-to To and/or Cc longer than 1024 characters. + 'many-to Multiple To and/or Cc." :type '(set (const :tag "Headers with no content." empty) - (const :tag "Newsgroups with only one group." newsgroups) - (const :tag "Followup-to identical to newsgroups." followup-to) - (const :tag "Reply-to identical to from." reply-to) + (const :tag "Newsgroups identical to Gnus group." newsgroups) + (const :tag "To identical to To-address." to-address) + (const :tag "To identical to To-list." to-list) + (const :tag "CC identical to To-list." cc-list) + (const :tag "Followup-to identical to Newsgroups." followup-to) + (const :tag "Reply-to identical to From." reply-to) (const :tag "Date less than four days old." date) - (const :tag "Very long To and/or Cc header." long-to) + (const :tag "To and/or Cc longer than 1024 characters." long-to) (const :tag "Multiple To and/or Cc headers." many-to)) :group 'gnus-article-hiding) +(defcustom gnus-article-skip-boring nil + "Skip over text that is not worth reading. +By default, if you set this t, then Gnus will display citations and +signatures, but will never scroll down to show you a page consisting +only of boring text. Boring text is controlled by +`gnus-article-boring-faces'." + :type 'boolean + :group 'gnus-article-hiding) + (defcustom gnus-signature-separator '("^-- $" "^-- *$") "Regexp matching signature separator. This can also be a list of regexps. In that case, it will be checked @@ -200,27 +243,26 @@ :type 'sexp :group 'gnus-article-hiding) -;; Fixme: This isn't the right thing for mixed graphical and and -;; non-graphical frames in a session. -;; gnus-xmas.el overrides this for XEmacs. +;; Fixme: This isn't the right thing for mixed graphical and non-graphical +;; frames in a session. (defcustom gnus-article-x-face-command - (if (and (fboundp 'image-type-available-p) - (image-type-available-p 'xbm)) - 'gnus-article-display-xface - (if (or (and (boundp 'gnus-article-compface-xbm) - gnus-article-compface-xbm) - (eq 0 (string-match "#define" - (shell-command-to-string "uncompface -X")))) - "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -" + (if (featurep 'xemacs) + (if (or (gnus-image-type-available-p 'xface) + (gnus-image-type-available-p 'pbm)) + 'gnus-display-x-face-in-from + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -") + (if (gnus-image-type-available-p 'pbm) + 'gnus-display-x-face-in-from "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ display -")) "*String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." - :type '(choice string - (function-item gnus-article-display-xface) + :type `(choice string + (function-item gnus-display-x-face-in-from) function) :version "21.1" + :group 'gnus-picon :group 'gnus-article-washing) (defcustom gnus-article-x-face-too-ugly nil @@ -231,30 +273,73 @@ (defcustom gnus-article-banner-alist nil "Banner alist for stripping. For example, - ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" + ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" :version "21.1" :type '(repeat (cons symbol regexp)) :group 'gnus-article-washing) +(gnus-define-group-parameter + banner + :variable-document + "Alist of regexps (to match group names) and banner." + :variable-group gnus-article-washing + :parameter-type + '(choice :tag "Banner" + :value nil + (const :tag "Remove signature" signature) + (symbol :tag "Item in `gnus-article-banner-alist'" none) + regexp + (const :tag "None" nil)) + :parameter-document + "If non-nil, specify how to remove `banners' from articles. + +Symbol `signature' means to remove signatures delimited by +`gnus-signature-separator'. Any other symbol is used to look up a +regular expression to match the banner in `gnus-article-banner-alist'. +A string is used as a regular expression to match the banner +directly.") + +(defcustom gnus-article-address-banner-alist nil + "Alist of mail addresses and banners. +Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp +to match a mail address in the From: header, BANNER is one of a symbol +`signature', an item in `gnus-article-banner-alist', a regexp and nil. +If ADDRESS matches author's mail address, it will remove things like +advertisements. For example: + +\((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\")) +" + :type '(repeat + (cons + (regexp :tag "Address") + (choice :tag "Banner" :value nil + (const :tag "Remove signature" signature) + (symbol :tag "Item in `gnus-article-banner-alist'" none) + regexp + (const :tag "None" nil)))) + :group 'gnus-article-washing) + (defcustom gnus-emphasis-alist (let ((format - "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)") + "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)") (types - '(("_" "_" underline) + '(("\\*" "\\*" bold) + ("_" "_" underline) ("/" "/" italic) - ("\\*" "\\*" bold) ("_/" "/_" underline-italic) ("_\\*" "\\*_" underline-bold) ("\\*/" "/\\*" bold-italic) ("_\\*/" "/\\*_" underline-bold-italic)))) - `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" - 2 3 gnus-emphasis-underline) - ,@(mapcar + `(,@(mapcar (lambda (spec) (list (format format (car spec) (cadr spec)) 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) - types))) + types) + ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)" + 2 3 gnus-emphasis-strikethru) + ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" + 2 3 gnus-emphasis-underline))) "*Alist that says how to fontify certain phrases. Each item looks like this: @@ -281,11 +366,11 @@ :group 'gnus-article-emphasis :type 'regexp) -(defface gnus-emphasis-bold '((t (:weight bold))) +(defface gnus-emphasis-bold '((t (:bold t))) "Face used for displaying strong emphasized text (*word*)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-italic '((t (:slant italic))) +(defface gnus-emphasis-italic '((t (:italic t))) "Face used for displaying italic emphasized text (/word/)." :group 'gnus-article-emphasis) @@ -293,24 +378,30 @@ "Face used for displaying underlined emphasized text (_word_)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-underline-bold '((t (:weight bold :underline t))) +(defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) "Face used for displaying underlined bold emphasized text (_*word*_)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-underline-italic '((t (:slant italic :underline t))) +(defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) "Face used for displaying underlined italic emphasized text (_/word/_)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-bold-italic '((t (:weight bold :slant italic))) +(defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) "Face used for displaying bold italic emphasized text (/*word*/)." :group 'gnus-article-emphasis) (defface gnus-emphasis-underline-bold-italic - '((t (:weight bold :slant italic :underline t))) + '((t (:bold t :italic t :underline t))) "Face used for displaying underlined bold italic emphasized text. Example: (_/*word*/_)." :group 'gnus-article-emphasis) +(defface gnus-emphasis-strikethru (if (featurep 'xemacs) + '((t (:strikethru t))) + '((t (:strike-through t)))) + "Face used for displaying strike-through text (-word-)." + :group 'gnus-article-emphasis) + (defface gnus-emphasis-highlight-words '((t (:background "black" :foreground "yellow"))) "Face used for displaying highlighted words." @@ -367,6 +458,7 @@ * gnus-summary-save-in-mail (Unix mail format) * gnus-summary-save-in-folder (MH folder) * gnus-summary-save-in-file (article format) +* gnus-summary-save-body-in-file (article body) * gnus-summary-save-in-vm (use VM's folder format) * gnus-summary-write-to-file (article format -- overwrite)." :group 'gnus-article-saving @@ -374,6 +466,7 @@ (function-item gnus-summary-save-in-mail) (function-item gnus-summary-save-in-folder) (function-item gnus-summary-save-in-file) + (function-item gnus-summary-save-body-in-file) (function-item gnus-summary-save-in-vm) (function-item gnus-summary-write-to-file))) @@ -452,6 +545,13 @@ :type 'hook :group 'gnus-article-various) +(when (featurep 'xemacs) + ;; Extracted from gnus-xmas-define in order to preserve user settings + (when (fboundp 'turn-off-scroll-in-place) + (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) + ;; Extracted from gnus-xmas-redefine in order to preserve user settings + (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)) + (defcustom gnus-article-menu-hook nil "*Hook run after the creation of the article mode menu." :type 'hook @@ -462,10 +562,8 @@ :type 'hook :group 'gnus-article-various) -(defcustom gnus-article-hide-pgp-hook nil - "*A hook called after successfully hiding a PGP signature." - :type 'hook - :group 'gnus-article-various) +(make-obsolete-variable 'gnus-article-hide-pgp-hook + "This variable is obsolete in Gnus 5.10.") (defcustom gnus-article-button-face 'bold "Face used for highlighting buttons in the article buffer. @@ -492,7 +590,7 @@ (defface gnus-signature-face '((t - (:slant italic))) + (:italic t))) "Face used for highlighting a signature in the article buffer." :group 'gnus-article-highlight :group 'gnus-article-signature) @@ -505,7 +603,7 @@ (background light)) (:foreground "red3")) (t - (:slant italic))) + (:italic t))) "Face used for displaying from headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -518,7 +616,7 @@ (background light)) (:foreground "red4")) (t - (:weight bold :slant italic))) + (:bold t :italic t))) "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -526,13 +624,15 @@ (defface gnus-header-newsgroups-face '((((class color) (background dark)) - (:foreground "yellow" :slant italic)) + (:foreground "yellow" :italic t)) (((class color) (background light)) - (:foreground "MidnightBlue" :slant italic)) + (:foreground "MidnightBlue" :italic t)) (t - (:slant italic))) - "Face used for displaying newsgroups headers." + (:italic t))) + "Face used for displaying newsgroups headers. +In the default setup this face is only used for crossposted +articles." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -544,7 +644,7 @@ (background light)) (:foreground "maroon")) (t - (:weight bold))) + (:bold t))) "Face used for displaying header names." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -552,12 +652,12 @@ (defface gnus-header-content-face '((((class color) (background dark)) - (:foreground "forest green" :slant italic)) + (:foreground "forest green" :italic t)) (((class color) (background light)) - (:foreground "indianred4" :slant italic)) + (:foreground "indianred4" :italic t)) (t - (:slant italic))) "Face used for displaying header content." + (:italic t))) "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -566,17 +666,17 @@ ("Subject" nil gnus-header-subject-face) ("Newsgroups:.*," nil gnus-header-newsgroups-face) ("" gnus-header-name-face gnus-header-content-face)) - "*Controls highlighting of article header. + "*Controls highlighting of article headers. An alist of the form (HEADER NAME CONTENT). -HEADER is a regular expression which should match the name of an -header header and NAME and CONTENT are either face names or nil. +HEADER is a regular expression which should match the name of a +header and NAME and CONTENT are either face names or nil. The name of each header field will be displayed using the face -specified by the first element in the list where HEADER match the -header name and NAME is non-nil. Similarly, the content will be -displayed by the first non-nil matching CONTENT face." +specified by the first element in the list where HEADER matches +the header name and NAME is non-nil. Similarly, the content will +be displayed by the first non-nil matching CONTENT face." :group 'gnus-article-headers :group 'gnus-article-highlight :type '(repeat (list (regexp :tag "Header") @@ -588,7 +688,8 @@ (face :value default))))) (defcustom gnus-article-decode-hook - '(article-decode-charset article-decode-encoded-words) + '(article-decode-charset article-decode-encoded-words + article-decode-group-name article-decode-idna-rhs) "*Hook run to decode charsets in articles." :group 'gnus-article-headers :type 'hook) @@ -602,7 +703,8 @@ "Function used to decode headers.") (defvar gnus-article-dumbquotes-map - '(("\202" ",") + '(("\200" "EUR") + ("\202" ",") ("\203" "f") ("\204" ",,") ("\205" "...") @@ -615,6 +717,7 @@ ("\225" "*") ("\226" "-") ("\227" "--") + ("\230" "~") ("\231" "(TM)") ("\233" ">") ("\234" "oe") @@ -628,11 +731,57 @@ :type '(repeat regexp)) (defcustom gnus-unbuttonized-mime-types '(".*/.*") - "List of MIME types that should not be given buttons when rendered inline." + "List of MIME types that should not be given buttons when rendered inline. +See also `gnus-buttonized-mime-types' which may override this variable. +This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." + :version "21.1" + :group 'gnus-article-mime + :type '(repeat regexp)) + +(defcustom gnus-buttonized-mime-types nil + "List of MIME types that should be given buttons when rendered inline. +If set, this variable overrides `gnus-unbuttonized-mime-types'. +To see e.g. security buttons you could set this to +`(\"multipart/signed\")'. +This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil." :version "21.1" :group 'gnus-article-mime :type '(repeat regexp)) +(defcustom gnus-inhibit-mime-unbuttonizing nil + "If non-nil, all MIME parts get buttons. +When nil (the default value), then some MIME parts do not get buttons, +as described by the variables `gnus-buttonized-mime-types' and +`gnus-unbuttonized-mime-types'." + :version "21.3" + :type 'boolean) + +(defcustom gnus-body-boundary-delimiter "_" + "String used to delimit header and body. +This variable is used by `gnus-article-treat-body-boundary' which can +be controlled by `gnus-treat-body-boundary'." + :group 'gnus-article-various + :type '(choice (item :tag "None" :value nil) + string)) + +(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces") + "Defines the location of the faces database. +For information on obtaining this database of pretty pictures, please +see http://www.cs.indiana.edu/picons/ftp/index.html" + :type '(repeat directory) + :link '(url-link :tag "download" + "http://www.cs.indiana.edu/picons/ftp/index.html") + :link '(custom-manual "(gnus)Picons") + :group 'gnus-picon) + +(defun gnus-picons-installed-p () + "Say whether picons are installed on your machine." + (let ((installed nil)) + (dolist (database gnus-picon-databases) + (when (file-exists-p database) + (setq installed t))) + installed)) + (defcustom gnus-article-mime-part-function nil "Function called with a MIME handle as the argument. This is meant for people who want to do something automatic based @@ -674,15 +823,17 @@ (defcustom gnus-mime-action-alist '(("save to file" . gnus-mime-save-part) + ("save and strip" . gnus-mime-save-part-and-strip) + ("delete part" . gnus-mime-delete-part) ("display as text" . gnus-mime-inline-part) ("view the part" . gnus-mime-view-part) ("pipe to command" . gnus-mime-pipe-part) ("toggle display" . gnus-article-press-button) + ("toggle display" . gnus-article-view-part-as-charset) ("view as type" . gnus-mime-view-part-as-type) - ("internalize type" . gnus-mime-internalize-part) - ("externalize type" . gnus-mime-externalize-part)) + ("view internally" . gnus-mime-view-part-internally) + ("view externally" . gnus-mime-view-part-externally)) "An alist of actions that run on the MIME attachment." - :version "21.1" :group 'gnus-article-mime :type '(repeat (cons (string :tag "name") (function)))) @@ -713,27 +864,30 @@ (defvar gnus-inhibit-treatment nil "Whether to inhibit treatment.") -(defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard")) +(defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard")) "Highlight the signature. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (put 'gnus-treat-highlight-signature 'highlight t) (defcustom gnus-treat-buttonize 100000 "Add buttons. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (put 'gnus-treat-buttonize 'highlight t) (defcustom gnus-treat-buttonize-head 'head "Add buttons to the head. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (put 'gnus-treat-buttonize-head 'highlight t) @@ -744,200 +898,312 @@ 50000) "Emphasize text. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (put 'gnus-treat-emphasize 'highlight t) (defcustom gnus-treat-strip-cr nil "Remove carriage returns. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(defcustom gnus-treat-unsplit-urls nil + "Remove newlines from within URLs. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(defcustom gnus-treat-leading-whitespace nil + "Remove leading whitespace in headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-hide-headers 'head "Hide headers. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-hide-boring-headers nil "Hide boring headers. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-hide-signature nil "Hide the signature. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-fill-article nil "Fill the article. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-hide-citation nil "Hide cited text. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-hide-citation-maybe nil "Hide cited text. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-strip-list-identifiers 'head "Strip list identifiers from `gnus-list-identifiers`. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) -(defcustom gnus-treat-strip-pgp t - "Strip PGP signatures. -Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." - :group 'gnus-article-treat - :type gnus-article-treat-custom) +(make-obsolete-variable 'gnus-treat-strip-pgp + "This option is obsolete in Gnus 5.10.") (defcustom gnus-treat-strip-pem nil "Strip PEM signatures. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-strip-banner t "Strip banners from articles. The banner to be stripped is specified in the `banner' group parameter. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-highlight-headers 'head "Highlight the headers. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (put 'gnus-treat-highlight-headers 'highlight t) (defcustom gnus-treat-highlight-citation t "Highlight cited text. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (put 'gnus-treat-highlight-citation 'highlight t) (defcustom gnus-treat-date-ut nil "Display the Date in UT (GMT). Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-local nil "Display the Date in the local timezone. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-head-custom) + +(defcustom gnus-treat-date-english nil + "Display the Date in a format that can be read aloud in English. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-lapsed nil "Display the Date header in a way that says how much time has elapsed. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-original nil "Display the date in the original timezone. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-iso8601 nil "Display the date in the ISO8601 format. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-date-user-defined nil "Display the date in a user-defined format. The format is defined by the `gnus-article-time-format' variable. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) (defcustom gnus-treat-strip-headers-in-body t "Strip the X-No-Archive header line from the beginning of the body. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-strip-trailing-blank-lines nil "Strip trailing blank lines. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-strip-leading-blank-lines nil "Strip leading blank lines. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-strip-multiple-blank-lines nil "Strip multiple blank lines. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(defcustom gnus-treat-unfold-headers 'head + "Unfold folded header lines. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fold-headers nil + "Fold headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fold-newsgroups 'head + "Fold the Newsgroups and Followup-To headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-overstrike t "Treat overstrike highlighting. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (put 'gnus-treat-overstrike 'highlight t) -(defcustom gnus-treat-display-xface - (and (or (and (fboundp 'image-type-available-p) +(make-obsolete-variable 'gnus-treat-display-xface + 'gnus-treat-display-x-face) + +(defcustom gnus-treat-display-x-face + (and (not noninteractive) + (or (and (fboundp 'image-type-available-p) (image-type-available-p 'xbm) - (string-match "^0x" (shell-command-to-string "uncompface"))) - (and (featurep 'xemacs) (featurep 'xface))) + (string-match "^0x" (shell-command-to-string "uncompface")) + (executable-find "icontopbm")) + (and (featurep 'xemacs) + (featurep 'xface))) 'head) "Display X-Face headers. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)X-Face' for details." :group 'gnus-article-treat :version "21.1" + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)X-Face") + :type gnus-article-treat-head-custom + :set (lambda (symbol value) + (set-default + symbol + (cond ((or (boundp symbol) (get symbol 'saved-value)) + value) + ((boundp 'gnus-treat-display-xface) + (message "\ +** gnus-treat-display-xface is an obsolete variable;\ + use gnus-treat-display-x-face instead") + (default-value 'gnus-treat-display-xface)) + ((get 'gnus-treat-display-xface 'saved-value) + (message "\ +** gnus-treat-display-xface is an obsolete variable;\ + use gnus-treat-display-x-face instead") + (eval (car (get 'gnus-treat-display-xface 'saved-value)))) + (t + value))))) +(put 'gnus-treat-display-x-face 'highlight t) + +(defcustom gnus-treat-display-face + (and (not noninteractive) + (or (and (fboundp 'image-type-available-p) + (image-type-available-p 'png)) + (and (featurep 'xemacs) + (featurep 'png))) + 'head) + "Display Face headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)X-Face' for details." + :group 'gnus-article-treat + :version "21.1" + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)X-Face") :type gnus-article-treat-head-custom) -(put 'gnus-treat-display-xface 'highlight t) +(put 'gnus-treat-display-face 'highlight t) (defcustom gnus-treat-display-smileys (if (or (and (featurep 'xemacs) @@ -947,85 +1213,195 @@ t nil) "Display smileys. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Smileys' for details." :group 'gnus-article-treat :version "21.1" + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Smileys") :type gnus-article-treat-custom) (put 'gnus-treat-display-smileys 'highlight t) -(defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil) - "Display picons. +(defcustom gnus-treat-from-picon + (if (and (gnus-image-type-available-p 'xpm) + (gnus-picons-installed-p)) + 'head nil) + "Display picons in the From header. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Picons' for details." + :group 'gnus-article-treat + :group 'gnus-picon + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Picons") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-from-picon 'highlight t) + +(defcustom gnus-treat-mail-picon + (if (and (gnus-image-type-available-p 'xpm) + (gnus-picons-installed-p)) + 'head nil) + "Display picons in To and Cc headers. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Picons' for details." + :group 'gnus-article-treat + :group 'gnus-picon + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Picons") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-mail-picon 'highlight t) + +(defcustom gnus-treat-newsgroups-picon + (if (and (gnus-image-type-available-p 'xpm) + (gnus-picons-installed-p)) + 'head nil) + "Display picons in the Newsgroups and Followup-To headers. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' and Info node +`(gnus)Picons' for details." :group 'gnus-article-treat + :group 'gnus-picon + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Picons") :type gnus-article-treat-head-custom) -(put 'gnus-treat-display-picons 'highlight t) +(put 'gnus-treat-newsgroups-picon 'highlight t) + +(defcustom gnus-treat-body-boundary + (if (or gnus-treat-newsgroups-picon + gnus-treat-mail-picon + gnus-treat-from-picon) + 'head nil) + "Draw a boundary at the end of the headers. +Valid values are nil and `head'. +See Info node `(gnus)Customizing Articles' for details." + :version "21.1" + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-head-custom) (defcustom gnus-treat-capitalize-sentences nil "Capitalize sentence-starting words. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(defcustom gnus-treat-wash-html nil + "Format as HTML. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-fill-long-lines nil "Fill long lines. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-play-sounds nil "Play sounds. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-translate nil "Translate articles from one language to another. Valid values are nil, t, `head', `last', an integer or a predicate. -See the manual for details." +See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) +(defcustom gnus-treat-x-pgp-sig nil + "Verify X-PGP-Sig. +To automatically treat X-PGP-Sig, set it to head. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :group 'mime-security + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(defvar gnus-article-encrypt-protocol-alist + '(("PGP" . mml2015-self-encrypt))) + +;; Set to nil if more than one protocol added to +;; gnus-article-encrypt-protocol-alist. +(defcustom gnus-article-encrypt-protocol "PGP" + "The protocol used for encrypt articles. +It is a string, such as \"PGP\". If nil, ask user." + :type 'string + :group 'mime-security) + +(defvar gnus-article-wash-function nil + "Function used for converting HTML into text.") + +(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) + (mm-coding-system-p 'utf-8) + (executable-find idna-program)) + "Whether IDNA decoding of headers is used when viewing messages. +This requires GNU Libidn, and by default only enabled if it is found." + :group 'gnus-article-headers + :type 'boolean) + +(defcustom gnus-article-over-scroll nil + "If non-nil, allow scrolling the article buffer even when there no more text." + :group 'gnus-article + :type 'boolean) + ;;; Internal variables +(defvar gnus-english-month-names + '("January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December")) + (defvar article-goto-body-goes-to-point-min-p nil) (defvar gnus-article-wash-types nil) (defvar gnus-article-emphasis-alist nil) +(defvar gnus-article-image-alist nil) (defvar gnus-article-mime-handle-alist-1 nil) (defvar gnus-treatment-function-alist - '((gnus-treat-strip-banner gnus-article-strip-banner) + '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) + (gnus-treat-strip-banner gnus-article-strip-banner) (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-buttonize gnus-article-add-buttons) (gnus-treat-fill-article gnus-article-fill-cited-article) (gnus-treat-fill-long-lines gnus-article-fill-long-lines) (gnus-treat-strip-cr gnus-article-remove-cr) - (gnus-treat-emphasize gnus-article-emphasize) - (gnus-treat-display-xface gnus-article-display-x-face) - (gnus-treat-hide-headers gnus-article-maybe-hide-headers) - (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) - (gnus-treat-hide-signature gnus-article-hide-signature) - (gnus-treat-hide-citation gnus-article-hide-citation) - (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) - (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) - (gnus-treat-strip-pgp gnus-article-hide-pgp) - (gnus-treat-strip-pem gnus-article-hide-pem) - (gnus-treat-highlight-headers gnus-article-highlight-headers) - (gnus-treat-highlight-citation gnus-article-highlight-citation) - (gnus-treat-highlight-signature gnus-article-highlight-signature) + (gnus-treat-unsplit-urls gnus-article-unsplit-urls) (gnus-treat-date-ut gnus-article-date-ut) (gnus-treat-date-local gnus-article-date-local) + (gnus-treat-date-english gnus-article-date-english) (gnus-treat-date-lapsed gnus-article-date-lapsed) (gnus-treat-date-original gnus-article-date-original) (gnus-treat-date-user-defined gnus-article-date-user) (gnus-treat-date-iso8601 gnus-article-date-iso8601) + (gnus-treat-display-x-face gnus-article-display-x-face) + (gnus-treat-display-face gnus-article-display-face) + (gnus-treat-hide-headers gnus-article-maybe-hide-headers) + (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) + (gnus-treat-hide-signature gnus-article-hide-signature) + (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) + (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace) + (gnus-treat-strip-pem gnus-article-hide-pem) + (gnus-treat-from-picon gnus-treat-from-picon) + (gnus-treat-mail-picon gnus-treat-mail-picon) + (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) + (gnus-treat-highlight-headers gnus-article-highlight-headers) + (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-strip-trailing-blank-lines gnus-article-remove-trailing-blank-lines) (gnus-treat-strip-leading-blank-lines @@ -1033,10 +1409,18 @@ (gnus-treat-strip-multiple-blank-lines gnus-article-strip-multiple-blank-lines) (gnus-treat-overstrike gnus-article-treat-overstrike) + (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) + (gnus-treat-fold-headers gnus-article-treat-fold-headers) + (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) - (gnus-treat-display-smileys gnus-smiley-display) + (gnus-treat-display-smileys gnus-treat-smiley) (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) - (gnus-treat-display-picons gnus-article-display-picons) + (gnus-treat-wash-html gnus-article-wash-html) + (gnus-treat-emphasize gnus-article-emphasize) + (gnus-treat-hide-citation gnus-article-hide-citation) + (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) + (gnus-treat-highlight-citation gnus-article-highlight-citation) + (gnus-treat-body-boundary gnus-article-treat-body-boundary) (gnus-treat-play-sounds gnus-earcon-display))) (defvar gnus-article-mime-handle-alist nil) @@ -1045,9 +1429,13 @@ (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) - (modify-syntax-entry ?- "w" table) - (modify-syntax-entry ?> ")" table) - (modify-syntax-entry ?< "(" table) + ;; This causes the citation match run O(2^n). + ;; (modify-syntax-entry ?- "w" table) + (modify-syntax-entry ?> ")<" table) + (modify-syntax-entry ?< "(>" table) + ;; make M-. in article buffers work for `foo' strings + (modify-syntax-entry ?' " " table) + (modify-syntax-entry ?` " " table) table) "Syntax table used in article mode buffers. Initialized from `text-mode-syntax-table.") @@ -1063,6 +1451,34 @@ (defvar gnus-inhibit-hiding nil) +;;; Macros for dealing with the article buffer. + +(defmacro gnus-with-article-headers (&rest forms) + `(save-excursion + (set-buffer gnus-article-buffer) + (save-restriction + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t)) + (article-narrow-to-head) + ,@forms)))) + +(put 'gnus-with-article-headers 'lisp-indent-function 0) +(put 'gnus-with-article-headers 'edebug-form-spec '(body)) + +(defmacro gnus-with-article-buffer (&rest forms) + `(save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil)) + ,@forms))) + +(put 'gnus-with-article-buffer 'lisp-indent-function 0) +(put 'gnus-with-article-buffer 'edebug-form-spec '(body)) + +(defun gnus-article-goto-header (header) + "Go to HEADER, which is a regular expression." + (re-search-forward (concat "^\\(" header "\\):") nil t)) + (defsubst gnus-article-hide-text (b e props) "Set text PROPS on the B to E region, extending `intangible' 1 past B." (gnus-add-text-properties-when 'article-type nil b e props) @@ -1080,14 +1496,13 @@ (defun gnus-article-hide-text-type (b e type) "Hide text of TYPE between B and E." - (push type gnus-article-wash-types) + (gnus-add-wash-type type) (gnus-article-hide-text b e (cons 'article-type (cons type gnus-hidden-properties)))) (defun gnus-article-unhide-text-type (b e type) "Unhide text of TYPE between B and E." - (setq gnus-article-wash-types - (delq type gnus-article-wash-types)) + (gnus-delete-wash-type type) (remove-text-properties b e (cons 'article-type (cons type gnus-hidden-properties))) (when (memq 'intangible gnus-hidden-properties) @@ -1127,13 +1542,13 @@ (defsubst gnus-article-header-rank () "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." (let ((list gnus-sorted-header-list) - (i 0)) + (i 1)) (while list - (when (looking-at (car list)) - (setq list nil)) - (setq list (cdr list)) - (incf i)) - i)) + (if (looking-at (car list)) + (setq list nil) + (setq list (cdr list)) + (incf i))) + i)) (defun article-hide-headers (&optional arg delete) "Hide unwanted headers and possibly sort them as well." @@ -1142,7 +1557,7 @@ (unless gnus-inhibit-hiding (save-excursion (save-restriction - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (case-fold-search t) (max (1+ (length gnus-sorted-header-list))) (ignored (when (not gnus-visible-headers) @@ -1171,7 +1586,7 @@ ;; `gnus-ignored-headers' and `gnus-visible-headers' to ;; select which header lines is to remain visible in the ;; article buffer. - (while (re-search-forward "^[^ \t]*:" nil t) + (while (re-search-forward "^[^ \t:]*:" nil t) (beginning-of-line) ;; Mark the rank of the header. (put-text-property @@ -1186,7 +1601,7 @@ (when (setq beg (text-property-any (point-min) (point-max) 'message-rank (+ 2 max))) ;; We delete the unwanted headers. - (push 'headers gnus-article-wash-types) + (gnus-add-wash-type 'headers) (add-text-properties (point-min) (+ 5 (point-min)) '(article-type headers dummy-invisible t)) (delete-region beg (point-max)))))))) @@ -1200,7 +1615,7 @@ (not gnus-show-all-headers)) (save-excursion (save-restriction - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (list gnus-boring-article-headers) (inhibit-point-motion-hooks t) elem) @@ -1214,7 +1629,7 @@ (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) (forward-line -1) (gnus-article-hide-text-type - (progn (beginning-of-line) (point)) + (gnus-point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1223,26 +1638,77 @@ 'boring-headers))) ;; Hide boring Newsgroups header. ((eq elem 'newsgroups) - (when (equal (gnus-fetch-field "newsgroups") - (gnus-group-real-name - (if (boundp 'gnus-newsgroup-name) - gnus-newsgroup-name - ""))) + (when (gnus-string-equal + (gnus-fetch-field "newsgroups") + (gnus-group-real-name + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name + ""))) (gnus-article-hide-header "newsgroups"))) + ((eq elem 'to-address) + (let ((to (message-fetch-field "to")) + (to-address + (gnus-parameter-to-address + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and to to-address + (ignore-errors + (gnus-string-equal + ;; only one address in To + (nth 1 (mail-extract-address-components to)) + to-address))) + (gnus-article-hide-header "to")))) + ((eq elem 'to-list) + (let ((to (message-fetch-field "to")) + (to-list + (gnus-parameter-to-list + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and to to-list + (ignore-errors + (gnus-string-equal + ;; only one address in To + (nth 1 (mail-extract-address-components to)) + to-list))) + (gnus-article-hide-header "to")))) + ((eq elem 'cc-list) + (let ((cc (message-fetch-field "cc")) + (to-list + (gnus-parameter-to-list + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and cc to-list + (ignore-errors + (gnus-string-equal + ;; only one address in CC + (nth 1 (mail-extract-address-components cc)) + to-list))) + (gnus-article-hide-header "cc")))) ((eq elem 'followup-to) - (when (equal (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) + (when (gnus-string-equal + (message-fetch-field "followup-to") + (message-fetch-field "newsgroups")) (gnus-article-hide-header "followup-to"))) ((eq elem 'reply-to) - (let ((from (message-fetch-field "from")) - (reply-to (message-fetch-field "reply-to"))) - (when (and + (if (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to) + (gnus-article-hide-header "reply-to") + (let ((from (message-fetch-field "from")) + (reply-to (message-fetch-field "reply-to"))) + (when + (and from reply-to (ignore-errors (equal - (nth 1 (mail-extract-address-components from)) - (nth 1 (mail-extract-address-components reply-to))))) - (gnus-article-hide-header "reply-to")))) + (sort (mapcar + (lambda (x) (downcase (cadr x))) + (mail-extract-address-components from t)) + 'string<) + (sort (mapcar + (lambda (x) (downcase (cadr x))) + (mail-extract-address-components reply-to t)) + 'string<)))) + (gnus-article-hide-header "reply-to"))))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) (when (and date @@ -1289,7 +1755,7 @@ (goto-char (point-min)) (when (re-search-forward (concat "^" header ":") nil t) (gnus-article-hide-text-type - (progn (beginning-of-line) (point)) + (gnus-point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1303,7 +1769,7 @@ (defun article-normalize-headers () "Make all header lines 40 characters long." (interactive) - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) column) (save-excursion (save-restriction @@ -1329,14 +1795,15 @@ (forward-line 1)))))) (defun article-treat-dumbquotes () - "Translate M****s*** sm*rtq**t*s into proper text. + "Translate M****s*** sm*rtq**t*s and other symbols into proper text. Note that this function guesses whether a character is a sm*rtq**t* or not, so it should only be used interactively. -Sm*rtq**t*s are M****s***'s unilateral extension to the character map -in an attempt to provide more quoting characters. If you see -something like \\222 or \\264 where you're expecting some kind of -apostrophe or quotation mark, then try this wash." +Sm*rtq**t*s are M****s***'s unilateral extension to the +iso-8859-1 character map in an attempt to provide more quoting +characters. If you see something like \\222 or \\264 where +you're expecting some kind of apostrophe or quotation mark, then +try this wash." (interactive) (article-translate-strings gnus-article-dumbquotes-map)) @@ -1346,7 +1813,7 @@ characters to translate to." (save-excursion (when (article-goto-body) - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (x (make-string 225 ?x)) (i -1)) (while (< (incf i) (length x)) @@ -1362,7 +1829,7 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (save-excursion (when (article-goto-body) - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) elem) (while (setq elem (pop map)) (save-excursion @@ -1374,7 +1841,7 @@ (interactive) (save-excursion (when (article-goto-body) - (let ((inhibit-read-only t)) + (let ((buffer-read-only nil)) (while (search-forward "\b" nil t) (let ((next (char-after)) (previous (char-after (- (point) 2)))) @@ -1395,11 +1862,94 @@ (put-text-property (point) (1+ (point)) 'face 'underline))))))))) +(defun gnus-article-treat-unfold-headers () + "Unfold folded message headers. +Only the headers that fit into the current window width will be +unfolded." + (interactive) + (gnus-with-article-headers + (let (length) + (while (not (eobp)) + (save-restriction + (mail-header-narrow-to-field) + (let ((header (buffer-string))) + (with-temp-buffer + (insert header) + (goto-char (point-min)) + (while (re-search-forward "\n[\t ]" nil t) + (replace-match " " t t))) + (setq length (- (point-max) (point-min) 1))) + (when (< length (window-width)) + (while (re-search-forward "\n[\t ]" nil t) + (replace-match " " t t))) + (goto-char (point-max))))))) + +(defun gnus-article-treat-fold-headers () + "Fold message headers." + (interactive) + (gnus-with-article-headers + (while (not (eobp)) + (save-restriction + (mail-header-narrow-to-field) + (mail-header-fold-field) + (goto-char (point-max)))))) + +(defun gnus-treat-smiley () + "Toggle display of textual emoticons (\"smileys\") as small graphical icons." + (interactive) + (gnus-with-article-buffer + (if (memq 'smiley gnus-article-wash-types) + (gnus-delete-images 'smiley) + (article-goto-body) + (let ((images (smiley-region (point) (point-max)))) + (when images + (gnus-add-wash-type 'smiley) + (dolist (image images) + (gnus-add-image 'smiley image))))))) + +(defun gnus-article-remove-images () + "Remove all images from the article buffer." + (interactive) + (gnus-with-article-buffer + (dolist (elem gnus-article-image-alist) + (gnus-delete-images (car elem))))) + +(defun gnus-article-treat-fold-newsgroups () + "Unfold folded message headers. +Only the headers that fit into the current window width will be +unfolded." + (interactive) + (gnus-with-article-headers + (while (gnus-article-goto-header "newsgroups\\|followup-to") + (save-restriction + (mail-header-narrow-to-field) + (while (re-search-forward ", *" nil t) + (replace-match ", " t t)) + (mail-header-fold-field) + (goto-char (point-max)))))) + +(defun gnus-article-treat-body-boundary () + "Place a boundary line at the end of the headers." + (interactive) + (when (and gnus-body-boundary-delimiter + (> (length gnus-body-boundary-delimiter) 0)) + (gnus-with-article-headers + (goto-char (point-max)) + (let ((start (point))) + (insert "X-Boundary: ") + (gnus-add-text-properties start (point) '(invisible t intangible t)) + (insert (let (str) + (while (>= (1- (window-width)) (length str)) + (setq str (concat str gnus-body-boundary-delimiter))) + (substring str 0 (1- (window-width)))) + "\n") + (gnus-put-text-property start (point) 'gnus-decoration 'header))))) + (defun article-fill-long-lines () "Fill lines that are wider than the window width." (interactive) (save-excursion - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (width (window-width (get-buffer-window (current-buffer))))) (save-restriction (article-goto-body) @@ -1407,9 +1957,11 @@ (while (not (eobp)) (end-of-line) (when (>= (current-column) (min fill-column width)) - (narrow-to-region (point) (gnus-point-at-bol)) - (fill-paragraph nil) - (goto-char (point-max)) + (narrow-to-region (min (1+ (point)) (point-max)) + (gnus-point-at-bol)) + (let ((goback (point-marker))) + (fill-paragraph nil) + (goto-char (marker-position goback))) (widen)) (forward-line 1))))))) @@ -1417,7 +1969,7 @@ "Capitalize the first word in each sentence." (interactive) (save-excursion - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (paragraph-start "^[\n\^L]")) (article-goto-body) (while (not (eobp)) @@ -1428,7 +1980,7 @@ "Remove trailing CRs and then translate remaining CRs into LFs." (interactive) (save-excursion - (let ((inhibit-read-only t)) + (let ((buffer-read-only nil)) (goto-char (point-min)) (while (re-search-forward "\r+$" nil t) (replace-match "" t t)) @@ -1440,7 +1992,7 @@ "Remove all trailing blank lines from the article." (interactive) (save-excursion - (let ((inhibit-read-only t)) + (let ((buffer-read-only nil)) (goto-char (point-max)) (delete-region (point) @@ -1453,56 +2005,107 @@ (forward-line 1) (point)))))) +(defun article-display-face () + "Display any Face headers in the header." + (interactive) + (let ((wash-face-p buffer-read-only)) + (gnus-with-article-headers + ;; When displaying parts, this function can be called several times on + ;; the same article, without any intended toggle semantic (as typing `W + ;; D d' would have). So face deletion must occur only when we come from + ;; an interactive command, that is when the *Article* buffer is + ;; read-only. + (if (and wash-face-p (memq 'face gnus-article-wash-types)) + (gnus-delete-images 'face) + (let (face faces) + (save-excursion + (when (and wash-face-p + (progn + (goto-char (point-min)) + (not (re-search-forward "^Face:[\t ]*" nil t))) + (gnus-buffer-live-p gnus-original-article-buffer)) + (set-buffer gnus-original-article-buffer)) + (save-restriction + (mail-narrow-to-head) + (while (gnus-article-goto-header "Face") + (push (mail-header-field-value) faces)))) + (while (setq face (pop faces)) + (let ((png (gnus-convert-face-to-png face)) + image) + (when png + (setq image (gnus-create-image png 'png t)) + (gnus-article-goto-header "from") + (when (bobp) + (insert "From: [no `from' set]\n") + (forward-char -17)) + (gnus-add-wash-type 'face) + (gnus-add-image 'face image) + (gnus-put-image image nil 'face)))))) + ))) + (defun article-display-x-face (&optional force) "Look for an X-Face header and display it if present." (interactive (list 'force)) - (save-excursion - ;; Delete the old process, if any. - (when (process-status "article-x-face") - (delete-process "article-x-face")) - (let ((inhibit-point-motion-hooks t) - (case-fold-search t) - from last) - (save-restriction - (article-narrow-to-head) - (goto-char (point-min)) - (setq from (message-fetch-field "from")) - (goto-char (point-min)) - (while (and gnus-article-x-face-command - (not last) - (or force - ;; Check whether this face is censored. - (not gnus-article-x-face-too-ugly) - (and gnus-article-x-face-too-ugly from - (not (string-match gnus-article-x-face-too-ugly - from)))) - ;; Has to be present. - (re-search-forward "^X-Face: " nil t)) - ;; This used to try to do multiple faces (`while' instead of - ;; `when' above), but (a) sending multiple EOFs to xv doesn't - ;; work (b) it can crash some versions of Emacs (c) are - ;; multiple faces really something to encourage? + (let ((wash-face-p buffer-read-only)) ;; When type `W f' + (gnus-with-article-headers + ;; Delete the old process, if any. + (when (process-status "article-x-face") + (delete-process "article-x-face")) + ;; See the comment in `article-display-face'. + (if (and wash-face-p (memq 'xface gnus-article-wash-types)) + ;; We have already displayed X-Faces, so we remove them + ;; instead. + (gnus-delete-images 'xface) + ;; Display X-Faces. + (let (x-faces from face) + (save-excursion + (when (and wash-face-p + (progn + (goto-char (point-min)) + (not (re-search-forward + "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t))) + (gnus-buffer-live-p gnus-original-article-buffer)) + ;; If type `W f', use gnus-original-article-buffer, + ;; otherwise use the current buffer because displaying + ;; RFC822 parts calls this function too. + (set-buffer gnus-original-article-buffer)) + (save-restriction + (mail-narrow-to-head) + (while (gnus-article-goto-header "X-Face") + (push (mail-header-field-value) x-faces)) + (setq from (message-fetch-field "from")))) + ;; Sending multiple EOFs to xv doesn't work, so we only do a + ;; single external face. (when (stringp gnus-article-x-face-command) - (setq last t)) - ;; We now have the area of the buffer where the X-Face is stored. - (save-excursion - (let ((beg (point)) - (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) - ;; We display the face. - (if (symbolp gnus-article-x-face-command) - ;; The command is a lisp function, so we call it. - (if (gnus-functionp gnus-article-x-face-command) - (funcall gnus-article-x-face-command beg end) - (error "%s is not a function" gnus-article-x-face-command)) - ;; The command is a string, so we interpret the command - ;; as a, well, command, and fork it off. - (let ((process-connection-type nil)) - (process-kill-without-query - (start-process - "article-x-face" nil shell-file-name shell-command-switch - gnus-article-x-face-command)) - (process-send-region "article-x-face" beg end) - (process-send-eof "article-x-face")))))))))) + (setq x-faces (list (car x-faces)))) + (while (and (setq face (pop x-faces)) + gnus-article-x-face-command + (or force + ;; Check whether this face is censored. + (not gnus-article-x-face-too-ugly) + (and gnus-article-x-face-too-ugly from + (not (string-match gnus-article-x-face-too-ugly + from))))) + ;; We display the face. + (cond ((stringp gnus-article-x-face-command) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (process-kill-without-query + (start-process + "article-x-face" nil shell-file-name + shell-command-switch gnus-article-x-face-command)) + (with-temp-buffer + (insert face) + (process-send-region "article-x-face" + (point-min) (point-max))) + (process-send-eof "article-x-face"))) + ((functionp gnus-article-x-face-command) + ;; The command is a lisp function, so we call it. + (funcall gnus-article-x-face-command face)) + (t + (error "%s is not a function" + gnus-article-x-face-command))))))))) (defun article-decode-mime-words () "Decode all MIME-encoded words in the article." @@ -1577,13 +2180,77 @@ (article-narrow-to-head) (funcall gnus-decode-header-function (point-min) (point-max))))) -(defun article-de-quoted-unreadable (&optional force) +(defun article-decode-group-name () + "Decode group names in `Newsgroups:'." + (let ((inhibit-point-motion-hooks t) + buffer-read-only + (method (gnus-find-method-for-group gnus-newsgroup-name))) + (when (and (or gnus-group-name-charset-method-alist + gnus-group-name-charset-group-alist) + (gnus-buffer-live-p gnus-original-article-buffer)) + (save-restriction + (article-narrow-to-head) + (with-current-buffer gnus-original-article-buffer + (goto-char (point-min))) + (while (re-search-forward + "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) + (replace-match (save-match-data + (gnus-decode-newsgroups + ;; XXX how to use data in article buffer? + (with-current-buffer gnus-original-article-buffer + (re-search-forward + "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" + nil t) + (match-string 1)) + gnus-newsgroup-name method)) + t t nil 1)) + (goto-char (point-min)) + (with-current-buffer gnus-original-article-buffer + (goto-char (point-min))) + (while (re-search-forward + "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t) + (replace-match (save-match-data + (gnus-decode-newsgroups + ;; XXX how to use data in article buffer? + (with-current-buffer gnus-original-article-buffer + (re-search-forward + "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" + nil t) + (match-string 1)) + gnus-newsgroup-name method)) + t t nil 1)))))) + +(autoload 'idna-to-unicode "idna") + +(defun article-decode-idna-rhs () + "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer." + (when gnus-use-idna + (save-restriction + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward "\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) + (let (ace unicode) + (when (save-match-data + (and (setq ace (match-string 1)) + (save-excursion + (and (re-search-backward "^[^ \t]" nil t) + (looking-at "From\\|To\\|Cc"))) + (save-excursion (backward-char) + (message-idna-inside-rhs-p)) + (setq unicode (idna-to-unicode ace)))) + (unless (string= ace unicode) + (replace-match unicode nil nil nil 1))))))))) + +(defun article-de-quoted-unreadable (&optional force read-charset) "Translate a quoted-printable-encoded article. If FORCE, decode the article whether it is marked as quoted-printable -or not." - (interactive (list 'force)) +or not. +If READ-CHARSET, ask for a coding system." + (interactive (list 'force current-prefix-arg)) (save-excursion - (let ((inhibit-read-only t) type charset) + (let ((buffer-read-only nil) type charset) (if (gnus-buffer-live-p gnus-original-article-buffer) (with-current-buffer gnus-original-article-buffer (setq type @@ -1596,6 +2263,8 @@ (mail-content-type-get ctl 'charset))) (if (stringp charset) (setq charset (intern (downcase charset))))))) + (if read-charset + (setq charset (mm-read-coding-system "Charset: " charset))) (unless charset (setq charset gnus-newsgroup-charset)) (when (or force @@ -1605,12 +2274,13 @@ (quoted-printable-decode-region (point) (point-max) (mm-charset-to-coding-system charset)))))) -(defun article-de-base64-unreadable (&optional force) +(defun article-de-base64-unreadable (&optional force read-charset) "Translate a base64 article. -If FORCE, decode the article whether it is marked as base64 not." - (interactive (list 'force)) +If FORCE, decode the article whether it is marked as base64 not. +If READ-CHARSET, ask for a coding system." + (interactive (list 'force current-prefix-arg)) (save-excursion - (let ((inhibit-read-only t) type charset) + (let ((buffer-read-only nil) type charset) (if (gnus-buffer-live-p gnus-original-article-buffer) (with-current-buffer gnus-original-article-buffer (setq type @@ -1623,6 +2293,8 @@ (mail-content-type-get ctl 'charset))) (if (stringp charset) (setq charset (intern (downcase charset))))))) + (if read-charset + (setq charset (mm-read-coding-system "Charset: " charset))) (unless charset (setq charset gnus-newsgroup-charset)) (when (or force @@ -1643,97 +2315,106 @@ (interactive) (require 'rfc1843) (save-excursion - (let ((inhibit-read-only t)) + (let ((buffer-read-only nil)) (rfc1843-decode-region (point-min) (point-max))))) -(defun article-wash-html () - "Format an html article." +(defun article-unsplit-urls () + "Remove the newlines that some other mailers insert into URLs." (interactive) (save-excursion - (let ((inhibit-read-only t) + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (re-search-forward + "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) + (replace-match "\\1\\3" t))) + (when (interactive-p) + (gnus-treat-article nil)))) + + +(defun article-wash-html (&optional read-charset) + "Format an HTML article. +If READ-CHARSET, ask for a coding system." + (interactive "P") + (save-excursion + (let ((buffer-read-only nil) charset) - (if (gnus-buffer-live-p gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (let* ((ct (gnus-fetch-field "content-type")) - (ctl (and ct - (ignore-errors - (mail-header-parse-content-type ct))))) - (setq charset (and ctl - (mail-content-type-get ctl 'charset))) - (if (stringp charset) - (setq charset (intern (downcase charset))))))) + (when (gnus-buffer-live-p gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (let* ((ct (gnus-fetch-field "content-type")) + (ctl (and ct + (ignore-errors + (mail-header-parse-content-type ct))))) + (setq charset (and ctl + (mail-content-type-get ctl 'charset))) + (when (stringp charset) + (setq charset (intern (downcase charset))))))) + (when read-charset + (setq charset (mm-read-coding-system "Charset: " charset))) (unless charset (setq charset gnus-newsgroup-charset)) (article-goto-body) (save-window-excursion (save-restriction (narrow-to-region (point) (point-max)) - (mm-setup-w3) - (let ((w3-strict-width (window-width)) - (url-gateway-unplugged t) - (url-standalone-mode t)) - (condition-case var - (w3-region (point-min) (point-max)) - (error)))))))) + (let* ((func (or gnus-article-wash-function mm-text-html-renderer)) + (entry (assq func mm-text-html-washer-alist))) + (when entry + (setq func (cdr entry))) + (cond + ((functionp func) + (funcall func)) + (t + (apply (car func) (cdr func)))))))))) + +(defun gnus-article-wash-html-with-w3 () + "Wash the current buffer with w3." + (mm-setup-w3) + (let ((w3-strict-width (window-width)) + (url-standalone-mode t) + (url-gateway-unplugged t) + (w3-honor-stylesheets nil)) + (condition-case () + (w3-region (point-min) (point-max)) + (error)))) + +(defun gnus-article-wash-html-with-w3m () + "Wash the current buffer with emacs-w3m." + (mm-setup-w3m) + (save-restriction + (narrow-to-region (point) (point-max)) + (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images + nil + "\\`cid:")) + w3m-force-redisplay) + (w3m-region (point-min) (point-max))) + (when mm-inline-text-html-with-w3m-keymap + (add-text-properties + (point-min) (point-max) + (nconc (mm-w3m-local-map-property) + '(mm-inline-text-html-with-w3m t)))))) (defun article-hide-list-identifiers () "Remove list identifies from the Subject header. The `gnus-list-identifiers' variable specifies what to do." (interactive) - (save-excursion - (save-restriction - (let ((inhibit-point-motion-hooks t) - buffer-read-only) - (article-narrow-to-head) - (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers - (mapconcat 'identity gnus-list-identifiers " *\\|")))) - (when regexp - (goto-char (point-min)) - (when (re-search-forward - (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp - " *\\)\\)+\\(Re: +\\)?\\)") - nil t) - (let ((s (or (match-string 3) (match-string 5)))) - (delete-region (match-beginning 1) (match-end 1)) - (when s - (goto-char (match-beginning 1)) - (insert s)))))))))) - -(defun article-hide-pgp () - "Remove any PGP headers and signatures in the current article." - (interactive) - (save-excursion - (save-restriction - (let ((inhibit-point-motion-hooks t) - buffer-read-only beg end) - (article-goto-body) - ;; Hide the "header". - (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (push 'pgp gnus-article-wash-types) - (delete-region (match-beginning 0) (match-end 0)) - ;; Remove armor headers (rfc2440 6.2) - (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t) - (point))) - (setq beg (point)) - ;; Hide the actual signature. - (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) - (setq end (1+ (match-beginning 0))) - (delete-region - end - (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) - (match-end 0) - ;; Perhaps we shouldn't hide to the end of the buffer - ;; if there is no end to the signature? - (point-max)))) - ;; Hide "- " PGP quotation markers. - (when (and beg end) - (narrow-to-region beg end) - (goto-char (point-min)) - (while (re-search-forward "^- " nil t) - (delete-region - (match-beginning 0) (match-end 0))) - (widen)) - (gnus-run-hooks 'gnus-article-hide-pgp-hook)))))) + (let ((inhibit-point-motion-hooks t) + (regexp (if (consp gnus-list-identifiers) + (mapconcat 'identity gnus-list-identifiers " *\\|") + gnus-list-identifiers)) + buffer-read-only) + (when regexp + (save-excursion + (save-restriction + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward + (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") + nil t) + (delete-region (match-beginning 2) (match-end 0)) + (beginning-of-line)) + (when (re-search-forward + "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t) + (delete-region (match-beginning 1) (match-end 1)))))))) (defun article-hide-pem (&optional arg) "Toggle hiding of any PEM headers and signatures in the current article. @@ -1749,7 +2430,7 @@ "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" nil t) (setq end (1+ (match-beginning 0)))) - (push 'pem gnus-article-wash-types) + (gnus-add-wash-type 'pem) (gnus-article-hide-text-type end (if (search-forward "\n\n" nil t) @@ -1763,29 +2444,50 @@ (match-beginning 0) (match-end 0) 'pem))))))) (defun article-strip-banner () - "Strip the banner specified by the `banner' group parameter." + "Strip the banners specified by the `banner' group parameter and by +`gnus-article-address-banner-alist'." (interactive) (save-excursion (save-restriction + (let ((inhibit-point-motion-hooks t)) + (when (gnus-parameter-banner gnus-newsgroup-name) + (article-really-strip-banner + (gnus-parameter-banner gnus-newsgroup-name))) + (when gnus-article-address-banner-alist + (article-really-strip-banner + (let ((from (save-restriction + (widen) + (article-narrow-to-head) + (mail-fetch-field "from")))) + (when (and from + (setq from + (caar (mail-header-parse-addresses from)))) + (catch 'found + (dolist (pair gnus-article-address-banner-alist) + (when (string-match (car pair) from) + (throw 'found (cdr pair))))))))))))) + +(defun article-really-strip-banner (banner) + "Strip the banner specified by the argument." + (save-excursion + (save-restriction (let ((inhibit-point-motion-hooks t) - (banner (gnus-group-find-parameter gnus-newsgroup-name 'banner)) (gnus-signature-limit nil) - buffer-read-only beg end) - (when banner - (article-goto-body) - (cond - ((eq banner 'signature) - (when (gnus-article-narrow-to-signature) - (widen) - (forward-line -1) - (delete-region (point) (point-max)))) - ((symbolp banner) - (if (setq banner (cdr (assq banner gnus-article-banner-alist))) - (while (re-search-forward banner nil t) - (delete-region (match-beginning 0) (match-end 0))))) - ((stringp banner) - (while (re-search-forward banner nil t) - (delete-region (match-beginning 0) (match-end 0)))))))))) + buffer-read-only) + (article-goto-body) + (cond + ((eq banner 'signature) + (when (gnus-article-narrow-to-signature) + (widen) + (forward-line -1) + (delete-region (point) (point-max)))) + ((symbolp banner) + (if (setq banner (cdr (assq banner gnus-article-banner-alist))) + (while (re-search-forward banner nil t) + (delete-region (match-beginning 0) (match-end 0))))) + ((stringp banner) + (while (re-search-forward banner nil t) + (delete-region (match-beginning 0) (match-end 0))))))))) (defun article-babel () "Translate article using an online translation service." @@ -1794,15 +2496,15 @@ (save-excursion (set-buffer gnus-article-buffer) (when (article-goto-body) - (let* ((inhibit-read-only t) + (let* ((buffer-read-only nil) (start (point)) (end (point-max)) (orig (buffer-substring start end)) - (trans (babel-as-string orig))) + (trans (babel-as-string orig))) (save-restriction (narrow-to-region start end) (delete-region start end) - (insert trans)))))) + (insert trans)))))) (defun article-hide-signature (&optional arg) "Hide the signature in the current article. @@ -1812,10 +2514,11 @@ (unless (gnus-article-check-hidden-text 'signature arg) (save-excursion (save-restriction - (let ((inhibit-read-only t)) + (let ((buffer-read-only nil)) (when (gnus-article-narrow-to-signature) (gnus-article-hide-text-type - (point-min) (point-max) 'signature))))))) + (point-min) (point-max) 'signature)))))) + (gnus-set-mode-line 'article)) (defun article-strip-headers-in-body () "Strip offensive headers from bodies." @@ -1875,10 +2578,10 @@ (replace-match "" nil t))) ;; Then replace multiple empty lines with a single empty line. (article-goto-body) - (while (re-search-forward "\n\n\n+" nil t) + (while (re-search-forward "\n\n\\(\n+\\)" nil t) (unless (gnus-annotation-in-region-p (match-beginning 0) (match-end 0)) - (replace-match "\n\n" t t)))))) + (delete-region (match-beginning 1) (match-end 1))))))) (defun article-strip-leading-space () "Remove all white space from the beginning of the lines in the article." @@ -1932,7 +2635,7 @@ (< (- (point-max) (point)) limit)) (and (floatp limit) (< (count-lines (point) (point-max)) limit)) - (and (gnus-functionp limit) + (and (functionp limit) (funcall limit)) (and (stringp limit) (not (re-search-forward limit nil t)))) @@ -2001,13 +2704,14 @@ (defun gnus-article-show-hidden-text (type &optional dummy) "Show all hidden text of type TYPE. Originally it is hide instead of DUMMY." - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) (gnus-remove-text-properties-when 'article-type type (point-min) (point-max) (cons 'article-type (cons type - gnus-hidden-properties))))) + gnus-hidden-properties))) + (gnus-delete-wash-type type))) (defconst article-time-units `((year . ,(* 365.25 24 60 60)) @@ -2018,6 +2722,17 @@ (second . 1)) "Mapping from time units to seconds.") +(defun gnus-article-forward-header () + "Move point to the start of the next header. +If the current header is a continuation header, this can be several +lines forward." + (let ((ended nil)) + (while (not ended) + (forward-line 1) + (if (looking-at "[ \t]+[^ \t]") + (forward-line 1) + (setq ended t))))) + (defun article-date-ut (&optional type highlight header) "Convert DATE date to universal time in the current article. If TYPE is `local', convert to local time; if it is `lapsed', output @@ -2029,7 +2744,7 @@ (message-fetch-field "date") "")) (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") - (date-regexp + (date-regexp (cond ((not gnus-article-date-lapsed-new-header) tdate-regexp) @@ -2054,20 +2769,25 @@ (forward-line 1)) (when (and date (not (string= date ""))) (goto-char (point-min)) - (let ((inhibit-read-only t)) - ;; Delete any old Date headers. - (while (re-search-forward date-regexp nil t) + (let ((buffer-read-only nil)) + ;; Delete any old Date headers. + (while (re-search-forward date-regexp nil t) (if pos (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) + (progn (gnus-article-forward-header) + (point))) (delete-region (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))) + (progn (gnus-article-forward-header) + (forward-char -1) + (point))) (setq pos (point)))) - (when (and (not pos) (re-search-forward tdate-regexp nil t)) + (when (and (not pos) + (re-search-forward tdate-regexp nil t)) (forward-line 1)) - (if pos (goto-char pos)) + (when pos + (goto-char pos)) (insert (article-make-date-line date (or type 'ut))) - (when (not pos) + (unless pos (insert "\n") (forward-line -1)) ;; Do highlighting. @@ -2082,103 +2802,130 @@ (defun article-make-date-line (date type) "Return a DATE line of TYPE." - (let ((time (condition-case () - (date-to-time date) - (error '(0 0))))) - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (let ((tz (car (current-time-zone time)))) - (format "Date: %s %s%02d%02d" (current-time-string time) - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60)))) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (current-time-string - (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) - (cond ((< ls 0) (list (1- ms) (+ ls 65536))) - ((> ls 65535) (list (1+ ms) (- ls 65536))) - (t (list ms ls))))) - " UT")) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " (if (string-match "\n+$" date) - (substring date 0 (match-beginning 0)) - date))) - ;; Let the user define the format. - ((eq type 'user) - (if (gnus-functionp gnus-article-time-format) - (funcall gnus-article-time-format time) - (concat - "Date: " - (format-time-string gnus-article-time-format time)))) - ;; ISO 8601. - ((eq type 'iso8601) - (let ((tz (car (current-time-zone time)))) - (concat - "Date: " - (format-time-string "%Y%m%dT%H%M%S" time) - (format "%s%02d%02d" - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60))))) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone functions are - ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time (subtract-time now time)) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) - num prev) + (unless (memq type '(local ut original user iso8601 lapsed english)) + (error "Unknown conversion type: %s" type)) + (condition-case () + (let ((time (date-to-time date))) (cond - ((null real-time) - "X-Sent: Unknown") - ((zerop sec) - "X-Sent: Now") - (t - (concat - "X-Sent: " - ;; 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. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago" - " in the future")))))) - (t - (error "Unknown conversion type: %s" type))))) + ;; Convert to the local timezone. + ((eq type 'local) + (let ((tz (car (current-time-zone time)))) + (format "Date: %s %s%02d%02d" (current-time-string time) + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60)))) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (current-time-string + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) + (cond ((< ls 0) (list (1- ms) (+ ls 65536))) + ((> ls 65535) (list (1+ ms) (- ls 65536))) + (t (list ms ls))))) + " UT")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " (if (string-match "\n+$" date) + (substring date 0 (match-beginning 0)) + date))) + ;; Let the user define the format. + ((eq type 'user) + (let ((format (or (condition-case nil + (with-current-buffer gnus-summary-buffer + gnus-article-time-format) + (error nil)) + gnus-article-time-format))) + (if (functionp format) + (funcall format time) + (concat "Date: " (format-time-string format time))))) + ;; ISO 8601. + ((eq type 'iso8601) + (let ((tz (car (current-time-zone time)))) + (concat + "Date: " + (format-time-string "%Y%m%dT%H%M%S" time) + (format "%s%02d%02d" + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))))) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time (subtract-time now time)) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown") + ((zerop sec) + "X-Sent: Now") + (t + (concat + "X-Sent: " + ;; 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. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago" + " in the future")))))) + ;; Display the date in proper English + ((eq type 'english) + (let ((dtime (decode-time time))) + (concat + "Date: the " + (number-to-string (nth 3 dtime)) + (let ((digit (% (nth 3 dtime) 10))) + (cond + ((memq (nth 3 dtime) '(11 12 13)) "th") + ((= digit 1) "st") + ((= digit 2) "nd") + ((= digit 3) "rd") + (t "th"))) + " of " + (nth (1- (nth 4 dtime)) gnus-english-month-names) + " " + (number-to-string (nth 5 dtime)) + " at " + (format "%02d" (nth 2 dtime)) + ":" + (format "%02d" (nth 1 dtime))))))) + (error + (format "Date: %s (from Gnus)" date)))) (defun article-date-local (&optional highlight) "Convert the current article date to the local timezone." (interactive (list t)) (article-date-ut 'local highlight)) +(defun article-date-english (&optional highlight) + "Convert the current article date to something that is proper English." + (interactive (list t)) + (article-date-ut 'english highlight)) + (defun article-date-original (&optional highlight) "Convert the current article date to what it was originally. This is only useful if you have used some other date conversion @@ -2200,9 +2947,12 @@ (lambda (w) (set-buffer (window-buffer w)) (when (eq major-mode 'gnus-article-mode) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t)))) + (let ((mark (point-marker))) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil t) + (article-date-lapsed t)) + (goto-char (marker-position mark)) + (move-marker mark nil)))) nil 'visible))))) (defun gnus-start-date-timer (&optional n) @@ -2234,12 +2984,23 @@ (interactive (list t)) (article-date-ut 'iso8601 highlight)) -(defun article-show-all () - "Show all hidden text in the article buffer." +;; (defun article-show-all () +;; "Show all hidden text in the article buffer." +;; (interactive) +;; (save-excursion +;; (let ((buffer-read-only nil)) +;; (gnus-article-unhide-text (point-min) (point-max))))) + +(defun article-remove-leading-whitespace () + "Remove excessive whitespace from all headers." (interactive) (save-excursion - (let ((inhibit-read-only t)) - (gnus-article-unhide-text (point-min) (point-max))))) + (save-restriction + (let ((buffer-read-only nil)) + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t) + (delete-region (match-beginning 1) (match-end 1))))))) (defun article-emphasize (&optional arg) "Emphasize text according to `gnus-emphasis-alist'." @@ -2252,7 +3013,7 @@ gnus-article-emphasis-alist) (error)) gnus-emphasis-alist)) - (inhibit-read-only t) + (buffer-read-only nil) (props (append '(article-type emphasis) gnus-hidden-properties)) regexp elem beg invisible visible face) @@ -2265,15 +3026,15 @@ visible (nth 2 elem) face (nth 3 elem)) (while (re-search-forward regexp nil t) - (when (and (match-beginning visible) (match-beginning invisible)) - (push 'emphasis gnus-article-wash-types) - (gnus-article-hide-text - (match-beginning invisible) (match-end invisible) props) - (gnus-article-unhide-text-type - (match-beginning visible) (match-end visible) 'emphasis) - (gnus-put-text-property-excluding-newlines - (match-beginning visible) (match-end visible) 'face face) - (goto-char (match-end invisible))))))))) + (when (and (match-beginning visible) (match-beginning invisible)) + (gnus-article-hide-text + (match-beginning invisible) (match-end invisible) props) + (gnus-article-unhide-text-type + (match-beginning visible) (match-end visible) 'emphasis) + (gnus-put-overlay-excluding-newlines + (match-beginning visible) (match-end visible) 'face face) + (gnus-add-wash-type 'emphasis) + (goto-char (match-end invisible))))))))) (defun gnus-article-setup-highlight-words (&optional highlight-words) "Setup newsgroup emphasis alist." @@ -2375,7 +3136,8 @@ ;; A single split name was found ((= 1 (length split-name)) (let* ((name (expand-file-name - (car split-name) gnus-article-save-directory)) + (car split-name) + gnus-article-save-directory)) (dir (cond ((file-directory-p name) (file-name-as-directory name)) ((file-exists-p name) name) @@ -2399,9 +3161,10 @@ (car (push result file-name-history))))))) ;; Create the directory. (gnus-make-directory (file-name-directory file)) - ;; If we have read a directory, we append the default file name. + ;; If we have read a directory, we append the default file name. (when (file-directory-p file) - (setq file (expand-file-name (file-name-nondirectory default-name) + (setq file (expand-file-name (file-name-nondirectory + default-name) (file-name-as-directory file)))) ;; Possibly translate some characters. (nnheader-translate-file-chars file)))))) @@ -2448,6 +3211,7 @@ (save-restriction (widen) (if (and (file-readable-p filename) + (file-regular-p filename) (mail-file-babyl-p filename)) (rmail-output-to-rmail-file filename t) (gnus-output-to-mail filename))))) @@ -2472,7 +3236,7 @@ filename) (defun gnus-summary-write-to-file (&optional filename) - "Write this article to a file. + "Write this article to a file, overwriting it if the file exists. Optional argument FILENAME specifies file name. The directory to save in defaults to `gnus-article-save-directory'." (gnus-summary-save-in-file nil t)) @@ -2521,6 +3285,21 @@ (shell-command-on-region (point-min) (point-max) command nil))) (setq gnus-last-shell-command command)) +(defmacro gnus-read-string (prompt &optional initial-contents history + default-value) + "Like `read-string' but allow for older XEmacsen that don't have the 5th arg." + (if (and (featurep 'xemacs) + (< emacs-minor-version 2)) + `(read-string ,prompt ,initial-contents ,history) + `(read-string ,prompt ,initial-contents ,history ,default-value))) + +(defun gnus-summary-pipe-to-muttprint (&optional command) + "Pipe this article to muttprint." + (setq command (gnus-read-string + "Print using command: " gnus-summary-muttprint-program + nil gnus-summary-muttprint-program)) + (gnus-summary-save-in-pipe command)) + ;;; Article file names when saving. (defun gnus-capitalize-newsgroup (newsgroup) @@ -2573,9 +3352,100 @@ (expand-file-name (if (gnus-use-long-file-name 'not-save) newsgroup - (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) + (file-relative-name + (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)) + default-directory)) gnus-article-save-directory))) +(defun gnus-sender-save-name (newsgroup headers &optional last-file) + "Generate file name from sender." + (let ((from (mail-header-from headers))) + (expand-file-name + (if (and from (string-match "\\([^ <]+\\)@" from)) + (match-string 1 from) + "nobody") + gnus-article-save-directory))) + +(defun article-verify-x-pgp-sig () + "Verify X-PGP-Sig." + (interactive) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (let ((sig (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "X-PGP-Sig"))) + items info headers) + (when (and sig + mml2015-use + (mml2015-clear-verify-function)) + (with-temp-buffer + (insert-buffer-substring gnus-original-article-buffer) + (setq items (split-string sig)) + (message-narrow-to-head) + (let ((inhibit-point-motion-hooks t) + (case-fold-search t)) + ;; Don't verify multiple headers. + (setq headers (mapconcat (lambda (header) + (concat header ": " + (mail-fetch-field header) + "\n")) + (split-string (nth 1 items) ",") ""))) + (delete-region (point-min) (point-max)) + (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n") + (insert "X-Signed-Headers: " (nth 1 items) "\n") + (insert headers) + (widen) + (forward-line) + (while (not (eobp)) + (if (looking-at "^-") + (insert "- ")) + (forward-line)) + (insert "\n-----BEGIN PGP SIGNATURE-----\n") + (insert "Version: " (car items) "\n\n") + (insert (mapconcat 'identity (cddr items) "\n")) + (insert "\n-----END PGP SIGNATURE-----\n") + (let ((mm-security-handle (list (format "multipart/signed")))) + (mml2015-clean-buffer) + (let ((coding-system-for-write (or gnus-newsgroup-charset + 'iso-8859-1))) + (funcall (mml2015-clear-verify-function))) + (setq info + (or (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-details) + (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-info))))) + (when info + (let (buffer-read-only bface eface) + (save-restriction + (message-narrow-to-head) + (goto-char (point-max)) + (forward-line -1) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (message-remove-header "X-Gnus-PGP-Verify") + (if (re-search-forward "^X-PGP-Sig:" nil t) + (forward-line) + (goto-char (point-max))) + (narrow-to-region (point) (point)) + (insert "X-Gnus-PGP-Verify: " info "\n") + (goto-char (point-min)) + (forward-line) + (while (not (eobp)) + (if (not (looking-at "^[ \t]")) + (insert " ")) + (forward-line)) + ;; Do highlighting. + (goto-char (point-min)) + (when (looking-at "\\([^:]+\\): *") + (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'face bface) + (put-text-property (match-end 0) (point-max) + 'face eface))))))))) + +(defun article-verify-cancel-lock () + "Verify Cancel-Lock header." + (interactive) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (canlock-verify gnus-original-article-buffer))) + (eval-and-compile (mapcar (lambda (func) @@ -2586,7 +3456,7 @@ (setq afunc func gfunc (intern (format "gnus-%s" func)))) (defalias gfunc - (if (fboundp afunc) + (when (fboundp afunc) `(lambda (&optional interactive &rest args) ,(documentation afunc t) (interactive (list t)) @@ -2596,18 +3466,22 @@ (call-interactively ',afunc) (apply ',afunc args)))))))) '(article-hide-headers + article-verify-x-pgp-sig + article-verify-cancel-lock article-hide-boring-headers article-treat-overstrike article-fill-long-lines article-capitalize-sentences article-remove-cr + article-remove-leading-whitespace article-display-x-face + article-display-face article-de-quoted-unreadable article-de-base64-unreadable article-decode-HZ article-wash-html + article-unsplit-urls article-hide-list-identifiers - article-hide-pgp article-strip-banner article-babel article-hide-pem @@ -2621,6 +3495,7 @@ article-strip-blank-lines article-strip-all-blank-lines article-date-local + article-date-english article-date-iso8601 article-date-original article-date-ut @@ -2632,7 +3507,8 @@ article-emphasize article-treat-dumbquotes article-normalize-headers - (article-show-all . gnus-article-show-all-headers)))) +;; (article-show-all . gnus-article-show-all-headers) + ))) ;;; ;;; Gnus article mode @@ -2657,6 +3533,8 @@ ">" end-of-buffer "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug + "R" gnus-article-reply-with-original + "F" gnus-article-followup-with-original "\C-hk" gnus-article-describe-key "\C-hc" gnus-article-describe-key-briefly @@ -2669,9 +3547,9 @@ (substitute-key-definition 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) -(defvar gnus-article-post-menu nil) - (defun gnus-article-make-menu-bar () + (unless (boundp 'gnus-article-commands-menu) + (gnus-summary-make-menu-bar)) (gnus-turn-off-edit-menu 'article) (unless (boundp 'gnus-article-article-menu) (easy-menu-define @@ -2693,29 +3571,19 @@ ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] ["Remove carriage return" gnus-article-remove-cr t] + ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] ["Remove base64" gnus-article-de-base64-unreadable t] ["Treat html" gnus-article-wash-html t] + ["Remove newlines from within URLs" gnus-article-unsplit-urls t] ["Decode HZ" gnus-article-decode-HZ t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency - (when (boundp 'gnus-summary-post-menu) - (cond - ((not (keymapp gnus-summary-post-menu)) - (setq gnus-article-post-menu gnus-summary-post-menu)) - ((not gnus-article-post-menu) - ;; Don't share post menu. - (setq gnus-article-post-menu - (copy-keymap gnus-summary-post-menu)))) - (define-key gnus-article-mode-map [menu-bar post] - (cons "Post" gnus-article-post-menu))) + ;; Note "Post" menu is defined in gnus-sum.el for consistency (gnus-run-hooks 'gnus-article-menu-hook))) -;; Fixme: do something for the Emacs tool bar in Article mode a la -;; Summary. - (defun gnus-article-mode () "Major mode for displaying an article. @@ -2738,16 +3606,21 @@ (make-local-variable 'minor-mode-alist) (use-local-map gnus-article-mode-map) (when (gnus-visual-p 'article-menu 'menu) - (gnus-article-make-menu-bar)) + (gnus-article-make-menu-bar) + (when gnus-summary-tool-bar-map + (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map))) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) - (make-local-variable 'gnus-page-broken) + (set (make-local-variable 'gnus-page-broken) nil) (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) (make-local-variable 'gnus-article-mime-handles) (make-local-variable 'gnus-article-decoded-p) (make-local-variable 'gnus-article-mime-handle-alist) (make-local-variable 'gnus-article-wash-types) + (make-local-variable 'gnus-article-image-alist) + (make-local-variable 'gnus-article-charset) + (make-local-variable 'gnus-article-ignored-charsets) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) @@ -2783,6 +3656,12 @@ (if (get-buffer name) (save-excursion (set-buffer name) + (when (and gnus-article-edit-mode + (buffer-modified-p) + (not + (y-or-n-p "Article mode edit in progress; discard? "))) + (error "Action aborted")) + (set (make-local-variable 'gnus-article-edit-mode) nil) (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) (setq gnus-article-mime-handles nil)) @@ -2790,6 +3669,8 @@ (setq gnus-article-mime-handle-alist nil) (buffer-disable-undo) (setq buffer-read-only t) + ;; This list just keeps growing if we don't reset it. + (setq gnus-button-marker-list nil) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) (current-buffer)) @@ -2804,7 +3685,7 @@ ;; from the head of the article. (defun gnus-article-set-window-start (&optional line) (set-window-start - (get-buffer-window gnus-article-buffer t) + (gnus-get-buffer-window gnus-article-buffer t) (save-excursion (set-buffer gnus-article-buffer) (goto-char (point-min)) @@ -2837,7 +3718,7 @@ (when (and (boundp 'transient-mark-mode) transient-mark-mode) (setq mark-active nil)) - (if (not (setq result (let ((inhibit-read-only t)) + (if (not (setq result (let ((buffer-read-only nil)) (gnus-request-article-this-buffer article group)))) ;; There is no such article. @@ -2848,7 +3729,9 @@ (cons gnus-newsgroup-name article)) (set-buffer gnus-summary-buffer) (setq gnus-current-article article) - (if (eq (gnus-article-mark article) gnus-undownloaded-mark) + (if (and (memq article gnus-newsgroup-undownloaded) + (not (gnus-online (gnus-find-method-for-group + gnus-newsgroup-name)))) (progn (gnus-summary-set-agent-mark article) (message "Message marked for downloading")) @@ -2912,14 +3795,14 @@ (gnus-article-prepare-display) ;; Do page break. (goto-char (point-min)) - (setq gnus-page-broken - (when gnus-break-pages - (gnus-narrow-to-page) - t))) + (when gnus-break-pages + (gnus-narrow-to-page))) (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) (gnus-set-mode-line 'article)) (article-goto-body) + (unless (bobp) + (forward-line -1)) (set-window-point (get-buffer-window (current-buffer)) (point)) (gnus-configure-windows 'article) t)))))) @@ -2934,7 +3817,8 @@ (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) (setq buffer-read-only nil - gnus-article-wash-types nil) + gnus-article-wash-types nil + gnus-article-image-alist nil) (gnus-run-hooks 'gnus-tmp-internal-hook) (when gnus-display-mime-function (funcall gnus-display-mime-function)) @@ -2945,14 +3829,19 @@ ;;; (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" - "The following specs can be used: + "Format of the MIME buttons. + +Valid specifiers include: %t The MIME type %T MIME type, along with additional info %n The `name' parameter %d The description, if any %l The length of the encoded part %p The part identifier number -%e Dots if the part isn't displayed") +%e Dots if the part isn't displayed + +General format specifiers can also be used. See Info node +`(gnus)Formatting Variables'.") (defvar gnus-mime-button-line-format-alist '((?t gnus-tmp-type ?s) @@ -2967,42 +3856,68 @@ '((gnus-article-press-button "\r" "Toggle Display") (gnus-mime-view-part "v" "View Interactively...") (gnus-mime-view-part-as-type "t" "View As Type...") + (gnus-mime-view-part-as-charset "C" "View As charset...") (gnus-mime-save-part "o" "Save...") + (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") + (gnus-mime-delete-part "d" "Delete part") (gnus-mime-copy-part "c" "View As Text, In Other Buffer") (gnus-mime-inline-part "i" "View As Text, In This Buffer") - (gnus-mime-internalize-part "E" "View Internally") - (gnus-mime-externalize-part "e" "View Externally") + (gnus-mime-view-part-internally "E" "View Internally") + (gnus-mime-view-part-externally "e" "View Externally") + (gnus-mime-print-part "p" "Print") (gnus-mime-pipe-part "|" "Pipe To Command...") - (gnus-mime-action-on-part "." "Take action on the part"))) + (gnus-mime-action-on-part "." "Take action on the part..."))) (defun gnus-article-mime-part-status () (if gnus-article-mime-handle-alist-1 - (format " (%d parts)" (length gnus-article-mime-handle-alist-1)) + (if (eq 1 (length gnus-article-mime-handle-alist-1)) + " (1 part)" + (format " (%d parts)" (length gnus-article-mime-handle-alist-1))) "")) (defvar gnus-mime-button-map (let ((map (make-sparse-keymap))) - ;; Not for Emacs 21: fixme better. - ;; (set-keymap-parent map gnus-article-mode-map) + (unless (>= (string-to-number emacs-version) 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-article-push-button) (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) (dolist (c gnus-mime-button-commands) (define-key map (cadr c) (car c))) map)) -(defun gnus-mime-button-menu (event) - "Construct a context-sensitive menu of MIME commands." - (interactive "e") - (save-excursion - (mouse-set-point event) - (gnus-article-check-buffer) - (let ((response (x-popup-menu - t `("MIME Part" - ("" ,@(mapcar (lambda (c) - (cons (caddr c) (car c))) - gnus-mime-button-commands)))))) - (if response - (call-interactively response))))) +(easy-menu-define + gnus-mime-button-menu gnus-mime-button-map "MIME button menu." + `("MIME Part" + ,@(mapcar (lambda (c) + (vector (caddr c) (car c) :enable t)) + gnus-mime-button-commands))) + +(eval-when-compile + (define-compiler-macro popup-menu (&whole form + menu &optional position prefix) + (if (and (fboundp 'popup-menu) + (not (memq 'popup-menu (assoc "lmenu" load-history)))) + form + ;; Gnus is probably running under Emacs 20. + `(let* ((menu (cdr ,menu)) + (response (x-popup-menu + t (list (car menu) + (cons "" (mapcar (lambda (c) + (cons (caddr c) (car c))) + (cdr menu))))))) + (if response + (call-interactively (nth 3 (assq response menu)))))))) + +(defun gnus-mime-button-menu (event prefix) + "Construct a context-sensitive menu of MIME commands." + (interactive "e\nP") + (save-window-excursion + (let ((pos (event-start event))) + (select-window (posn-window pos)) + (goto-char (posn-point pos)) + (gnus-article-check-buffer) + (popup-menu gnus-mime-button-menu nil prefix)))) (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." @@ -3012,33 +3927,186 @@ (let ((handles (or handles gnus-article-mime-handles)) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) - (if (stringp (car handles)) - (gnus-mime-view-all-parts (cdr handles)) - (mapcar 'mm-display-part handles))))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) + (when handles + (mm-remove-parts handles) + (goto-char (point-min)) + (or (search-forward "\n\n") (goto-char (point-max))) + (let (buffer-read-only) + (delete-region (point) (point-max)) + (mm-display-parts handles)))))) + +(defun gnus-mime-save-part-and-strip () + "Save the MIME part under point then replace it with an external body." + (interactive) + (gnus-article-check-buffer) + (let* ((data (get-text-property (point) 'gnus-data)) + file param + (handles gnus-article-mime-handles)) + (if (mm-multiple-handles gnus-article-mime-handles) + (error "This function is not implemented")) + (setq file (and data (mm-save-part data))) + (when file + (with-current-buffer (mm-handle-buffer data) + (erase-buffer) + (insert "Content-Type: " (mm-handle-media-type data)) + (mml-insert-parameter-string (cdr (mm-handle-type data)) + '(charset)) + (insert "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: binary\n") + (insert "\n")) + (setcdr data + (cdr (mm-make-handle nil + `("message/external-body" + (access-type . "LOCAL-FILE") + (name . ,file))))) + (set-buffer gnus-summary-buffer) + (gnus-article-edit-article + `(lambda () + (erase-buffer) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets)) + (mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (insert-buffer gnus-original-article-buffer) + (mime-to-mml ',handles) + (setq gnus-article-mime-handles nil) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (gnus-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) + `(lambda (no-highlight) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (message-options message-options) + (message-options-set-recipient) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets))) + (mml-to-mime) + (mml-destroy-buffers) + (remove-hook 'kill-buffer-hook + 'mml-destroy-buffers t) + (kill-local-variable 'mml-buffer-list)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) + ,gnus-summary-buffer no-highlight)))))) + +(defun gnus-mime-delete-part () + "Delete the MIME part under point. +Replace it with some information about the removed part." + (interactive) + (gnus-article-check-buffer) + (unless (and gnus-novice-user + (not (gnus-yes-or-no-p + "Really delete attachment forever? "))) + (let* ((data (get-text-property (point) 'gnus-data)) + (handles gnus-article-mime-handles) + (none "(none)") + (description + (or + (mail-decode-encoded-word-string (or (mm-handle-description data) + none)))) + (filename + (or (mail-content-type-get (mm-handle-disposition data) 'filename) + none)) + (type (mm-handle-media-type data))) + (if (mm-multiple-handles gnus-article-mime-handles) + (error "This function is not implemented")) + (with-current-buffer (mm-handle-buffer data) + (let ((bsize (format "%s" (buffer-size)))) + (erase-buffer) + (insert + (concat + ",----\n" + "| The following attachment has been deleted:\n" + "|\n" + "| Type: " type "\n" + "| Filename: " filename "\n" + "| Size (encoded): " bsize " Byte\n" + "| Description: " description "\n" + "`----\n")) + (setcdr data + (cdr (mm-make-handle + nil `("text/plain") nil nil + (list "attachment") + (format "Deleted attachment (%s bytes)" bsize)))))) + (set-buffer gnus-summary-buffer) + ;; FIXME: maybe some of the following code (borrowed from + ;; `gnus-mime-save-part-and-strip') isn't necessary? + (gnus-article-edit-article + `(lambda () + (erase-buffer) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets)) + (mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (insert-buffer gnus-original-article-buffer) + (mime-to-mml ',handles) + (setq gnus-article-mime-handles nil) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (gnus-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) + `(lambda (no-highlight) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (message-options message-options) + (message-options-set-recipient) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets))) + (mml-to-mime) + (mml-destroy-buffers) + (remove-hook 'kill-buffer-hook + 'mml-destroy-buffers t) + (kill-local-variable 'mml-buffer-list)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) + ,gnus-summary-buffer no-highlight))))) + ;; Not in `gnus-mime-save-part-and-strip': + (gnus-article-edit-done) + (gnus-summary-expand-window) + (gnus-summary-show-article)) (defun gnus-mime-save-part () "Save the MIME part under point." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) - (mm-save-part data))) + (when data + (mm-save-part data)))) (defun gnus-mime-pipe-part () "Pipe the MIME part under point to a process." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) - (mm-pipe-part data))) + (when data + (mm-pipe-part data)))) (defun gnus-mime-view-part () "Interactively choose a viewing method for the MIME part under point." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) - (push (setq data (copy-sequence data)) gnus-article-mime-handles) - (mm-interactively-view-part data))) + (when data + (setq gnus-article-mime-handles + (mm-merge-handles + gnus-article-mime-handles (setq data (copy-sequence data)))) + (mm-interactively-view-part data)))) (defun gnus-mime-view-part-as-type-internal () (gnus-article-check-buffer) @@ -3048,48 +4116,113 @@ (def-type (and name (mm-default-file-encoding name)))) (and def-type (cons def-type 0)))) -(defun gnus-mime-view-part-as-type (mime-type) +(defun gnus-mime-view-part-as-type (&optional mime-type) "Choose a MIME media type, and view the part as such." - (interactive - (list (completing-read - "View as MIME type: " - (mapcar #'list (mailcap-mime-types)) - nil nil - (gnus-mime-view-part-as-type-internal)))) + (interactive) + (unless mime-type + (setq mime-type (completing-read + "View as MIME type: " + (mapcar #'list (mailcap-mime-types)) + nil nil + (gnus-mime-view-part-as-type-internal)))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) - (gnus-mm-display-part - (mm-make-handle (mm-handle-buffer handle) - (cons mime-type (cdr (mm-handle-type handle))) - (mm-handle-encoding handle) - (mm-handle-undisplayer handle) - (mm-handle-disposition handle) - (mm-handle-description handle) - (mm-handle-cache handle) - (mm-handle-id handle))))) + (when handle + (setq handle + (mm-make-handle (mm-handle-buffer handle) + (cons mime-type (cdr (mm-handle-type handle))) + (mm-handle-encoding handle) + (mm-handle-undisplayer handle) + (mm-handle-disposition handle) + (mm-handle-description handle) + nil + (mm-handle-id handle))) + (setq gnus-article-mime-handles + (mm-merge-handles gnus-article-mime-handles handle)) + (gnus-mm-display-part handle)))) + +(eval-when-compile + (require 'jka-compr)) + +;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days +;; emacs can do that itself. +;; +(defun gnus-mime-jka-compr-maybe-uncompress () + "Uncompress the current buffer if `auto-compression-mode' is enabled. +The uncompress method used is derived from `buffer-file-name'." + (when (and (fboundp 'jka-compr-installed-p) + (jka-compr-installed-p)) + (let ((info (jka-compr-get-compression-info buffer-file-name))) + (when info + (let ((basename (file-name-nondirectory buffer-file-name)) + (args (jka-compr-info-uncompress-args info)) + (prog (jka-compr-info-uncompress-program info)) + (message (jka-compr-info-uncompress-message info)) + (err-file (jka-compr-make-temp-name))) + (if message + (message "%s %s..." message basename)) + (unwind-protect + (unless (memq (apply 'call-process-region + (point-min) (point-max) + prog + t (list t err-file) nil + args) + jka-compr-acceptable-retval-list) + (jka-compr-error prog args basename message err-file)) + (jka-compr-delete-temp-file err-file))))))) (defun gnus-mime-copy-part (&optional handle) - "Put the MIME part under point into a new buffer." + "Put the MIME part under point into a new buffer. +If `auto-compression-mode' is enabled, compressed files like .gz and .bz2 +are decompressed." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - (contents (mm-get-part handle)) - (base (file-name-nondirectory - (or - (mail-content-type-get (mm-handle-type handle) 'name) - (mail-content-type-get (mm-handle-type handle) - 'filename) - "*decoded*"))) - (buffer (generate-new-buffer base))) - (switch-to-buffer buffer) - (insert contents) - ;; We do it this way to make `normal-mode' set the appropriate mode. - (unwind-protect - (progn - (setq buffer-file-name (expand-file-name base)) - (normal-mode)) - (setq buffer-file-name nil)) - (goto-char (point-min)))) + (contents (and handle (mm-get-part handle))) + (base (and handle + (file-name-nondirectory + (or + (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename) + "*decoded*")))) + (buffer (and base (generate-new-buffer base)))) + (when contents + (switch-to-buffer buffer) + (insert contents) + ;; We do it this way to make `normal-mode' set the appropriate mode. + (unwind-protect + (progn + (setq buffer-file-name (expand-file-name base)) + (gnus-mime-jka-compr-maybe-uncompress) + (normal-mode)) + (setq buffer-file-name nil)) + (goto-char (point-min))))) + +(defun gnus-mime-print-part (&optional handle filename) + "Print the MIME part under point." + (interactive (list nil (ps-print-preprint current-prefix-arg))) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + (contents (and handle (mm-get-part handle))) + (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory))) + (printer (mailcap-mime-info (mm-handle-media-type handle) "print"))) + (when contents + (if printer + (unwind-protect + (progn + (mm-save-part-to-file handle file) + (call-process shell-file-name nil + (generate-new-buffer " *mm*") + nil + shell-command-switch + (mm-mailcap-command + printer file (mm-handle-type handle)))) + (delete-file file)) + (with-temp-buffer + (insert contents) + (gnus-print-buffer)) + (ps-despool filename))))) (defun gnus-mime-inline-part (&optional handle arg) "Insert the MIME part under point into the current buffer." @@ -3099,30 +4232,52 @@ contents charset (b (point)) buffer-read-only) - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (setq contents (mm-get-part handle)) - (cond - ((not arg) - (setq charset (or (mail-content-type-get - (mm-handle-type handle) 'charset) - gnus-newsgroup-charset))) - ((numberp arg) - (setq charset - (or (cdr (assq arg - gnus-summary-show-article-charset-alist)) - (read-coding-system "Charset: "))))) - (forward-line 2) - (mm-insert-inline handle - (if (and charset - (setq charset (mm-charset-to-coding-system - charset)) - (not (eq charset 'ascii))) - (mm-decode-coding-string contents charset) - contents)) - (goto-char b)))) - -(defun gnus-mime-externalize-part (&optional handle) + (when handle + (if (and (not arg) (mm-handle-undisplayer handle)) + (mm-remove-part handle) + (setq contents (mm-get-part handle)) + (cond + ((not arg) + (setq charset (or (mail-content-type-get + (mm-handle-type handle) 'charset) + gnus-newsgroup-charset))) + ((numberp arg) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) + (setq charset + (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (mm-read-coding-system "Charset: "))))) + (forward-line 2) + (mm-insert-inline handle + (if (and charset + (setq charset (mm-charset-to-coding-system + charset)) + (not (eq charset 'ascii))) + (mm-decode-coding-string contents charset) + contents)) + (goto-char b))))) + +(defun gnus-mime-view-part-as-charset (&optional handle arg) + "Insert the MIME part under point into the current buffer using the +specified charset." + (interactive (list nil current-prefix-arg)) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + contents charset + (b (point)) + buffer-read-only) + (when handle + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) + (let ((gnus-newsgroup-charset + (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (mm-read-coding-system "Charset: "))) + (gnus-newsgroup-ignored-charsets 'gnus-all)) + (gnus-article-press-button))))) + +(defun gnus-mime-view-part-externally (&optional handle) "View the MIME part under point with an external viewer." (interactive) (gnus-article-check-buffer) @@ -3133,13 +4288,14 @@ (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-ignored-charsets))) - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (mm-display-part handle)))) - -(defun gnus-mime-internalize-part (&optional handle) + (when handle + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (mm-display-part handle))))) + +(defun gnus-mime-view-part-internally (&optional handle) "View the MIME part under point with an internal viewer. -In no internal viewer is available, use an external viewer." +If no internal viewer is available, use an external viewer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) @@ -3148,21 +4304,22 @@ (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) - (if (mm-handle-undisplayer handle) - (mm-remove-part handle) - (mm-display-part handle)))) + gnus-newsgroup-ignored-charsets)) + buffer-read-only) + (when handle + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (mm-display-part handle))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at \(point\)." (interactive - (list (completing-read "Action: " gnus-mime-action-alist))) + (list (completing-read "Action: " gnus-mime-action-alist nil t))) (gnus-article-check-buffer) (let ((action-pair (assoc action gnus-mime-action-alist))) (if action-pair (funcall (cdr action-pair))))) - (defun gnus-article-part-wrapper (n function) (save-current-buffer (set-buffer gnus-article-buffer) @@ -3192,10 +4349,16 @@ (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-copy-part)) -(defun gnus-article-externalize-part (n) +(defun gnus-article-view-part-as-charset (n) + "View MIME part N using a specified charset. +N is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) + +(defun gnus-article-view-part-externally (n) "View MIME part N externally, which is the numerical prefix." (interactive "p") - (gnus-article-part-wrapper n 'gnus-mime-externalize-part)) + (gnus-article-part-wrapper n 'gnus-mime-view-part-externally)) (defun gnus-article-inline-part (n) "Inline MIME part N, which is the numerical prefix." @@ -3253,11 +4416,14 @@ (let ((window (selected-window)) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + (if (gnus-buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets) + nil))) (save-excursion (unwind-protect - (let ((win (get-buffer-window (current-buffer) t)) + (let ((win (gnus-get-buffer-window (current-buffer) t)) (beg (point))) (when win (select-window win)) @@ -3267,7 +4433,8 @@ ;; This will remove the part. (mm-display-part handle) (save-restriction - (narrow-to-region (point) (1+ (point))) + (narrow-to-region (point) + (if (eobp) (point) (1+ (point)))) (mm-display-part handle) ;; We narrow to the part itself and ;; then call the treatment functions. @@ -3278,25 +4445,23 @@ nil id (gnus-article-mime-total-parts) (mm-handle-media-type handle))))) - (select-window window)))) + (if (window-live-p window) + (select-window window))))) (goto-char point) - (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) + (gnus-delete-line) (gnus-insert-mime-button handle id (list (mm-handle-displayed-p handle))) (goto-char point)))) (defun gnus-article-goto-part (n) "Go to MIME part N." - (let ((point (text-property-any (point-min) (point-max) 'gnus-part n))) - (when point - (goto-char point)))) + (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) (let ((gnus-tmp-name - (or (mail-content-type-get (mm-handle-type handle) - 'name) - (mail-content-type-get (mm-handle-disposition handle) - 'filename) + (or (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-disposition handle) 'filename) + (mail-content-type-get (mm-handle-type handle) 'url) "")) (gnus-tmp-type (mm-handle-media-type handle)) (gnus-tmp-description @@ -3314,21 +4479,22 @@ (setq gnus-tmp-type-long (concat gnus-tmp-type (and (not (equal gnus-tmp-name "")) (concat "; " gnus-tmp-name)))) - (or (equal gnus-tmp-description "") - (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (unless (equal gnus-tmp-description "") + (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) (unless (bolp) (insert "\n")) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist - `(keymap ,gnus-mime-button-map - ;; Not for Emacs 21: fixme better. - ;; local-map ,gnus-mime-button-map - gnus-callback gnus-mm-display-part - gnus-part ,gnus-tmp-id - article-type annotation - gnus-data ,handle)) - (setq e (point)) + `(,@(gnus-local-map-property gnus-mime-button-map) + gnus-callback gnus-mm-display-part + gnus-part ,gnus-tmp-id + article-type annotation + gnus-data ,handle)) + (setq e (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point))) (widget-convert-button 'link b e :mime-handle handle @@ -3371,7 +4537,10 @@ ;; We have to do this since selecting the window ;; may change the point. So we set the window point. (set-window-point window point))) - (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) + (let* ((handles (or ihandles + (mm-dissect-buffer nil gnus-article-loose-mime) + (and gnus-article-emulate-mime + (mm-uu-dissect)))) buffer-read-only handle name type b e display) (when (and (not ihandles) (not gnus-displaying-mime)) @@ -3407,7 +4576,28 @@ (narrow-to-region (point-min) (point)) (gnus-treat-article 'head)))))))) -(defvar gnus-mime-display-multipart-as-mixed nil) +(defcustom gnus-mime-display-multipart-as-mixed nil + "Display \"multipart\" parts as \"multipart/mixed\". + +If t, it overrides nil values of +`gnus-mime-display-multipart-alternative-as-mixed' and +`gnus-mime-display-multipart-related-as-mixed'." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-mime-display-multipart-alternative-as-mixed nil + "Display \"multipart/alternative\" parts as \"multipart/mixed\"." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-mime-display-multipart-related-as-mixed nil + "Display \"multipart/related\" parts as \"multipart/mixed\". + +If displaying \"text/html\" is discouraged \(see +`mm-discouraged-alternatives'\) images or other material inside a +\"multipart/related\" part might be overlooked when this variable is nil." + :group 'gnus-article-mime + :type 'boolean) (defun gnus-mime-display-part (handle) (cond @@ -3420,16 +4610,30 @@ handle)) ;; multipart/alternative ((and (equal (car handle) "multipart/alternative") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-alternative-as-mixed))) (let ((id (1+ (length gnus-article-mime-handle-alist)))) (push (cons id handle) gnus-article-mime-handle-alist) (gnus-mime-display-alternative (cdr handle) nil nil id))) ;; multipart/related ((and (equal (car handle) "multipart/related") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-related-as-mixed))) ;;;!!!We should find the start part, but we just default ;;;!!!to the first part. + ;;(gnus-mime-display-part (cadr handle)) + ;;;!!! Most multipart/related is an HTML message plus images. + ;;;!!! Unfortunately we are unable to let W3 display those + ;;;!!! included images, so we just display it as a mixed multipart. + ;;(gnus-mime-display-mixed (cdr handle)) + ;;;!!! No, w3 can display everything just fine. (gnus-mime-display-part (cadr handle))) + ((equal (car handle) "multipart/signed") + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((equal (car handle) "multipart/encrypted") + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) ;; Other multiparts are handled like multipart/mixed. (t (gnus-mime-display-mixed (cdr handle))))) @@ -3460,7 +4664,9 @@ "inline") (mm-attachment-override-p handle)))) (mm-automatic-display-p handle) - (or (mm-inlined-p handle) + (or (and + (mm-inlinable-p handle) + (mm-inlined-p handle)) (mm-automatic-external-display-p type))) (setq display t) (when (equal (mm-handle-media-supertype handle) "text") @@ -3475,12 +4681,13 @@ handle id (list (or display (and not-attachment text)))) (gnus-article-insert-newline) ;(gnus-article-insert-newline) + ;; Remember modify the number of forward lines. (setq move t)) (setq beg (point)) (cond (display (when move - (forward-line -2) + (forward-line -1) (setq beg (point))) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets @@ -3492,7 +4699,7 @@ (goto-char (point-max))) ((and text not-attachment) (when move - (forward-line -2) + (forward-line -1) (setq beg (point))) (gnus-article-insert-newline) (mm-insert-inline handle (mm-get-part handle)) @@ -3509,11 +4716,16 @@ (defun gnus-unbuttonized-mime-type-p (type) "Say whether TYPE is to be unbuttonized." (unless gnus-inhibit-mime-unbuttonizing - (catch 'found - (let ((types gnus-unbuttonized-mime-types)) - (while types - (when (string-match (pop types) type) - (throw 'found t))))))) + (when (catch 'found + (let ((types gnus-unbuttonized-mime-types)) + (while types + (when (string-match (pop types) type) + (throw 'found t))))) + (not (catch 'found + (let ((types gnus-buttonized-mime-types)) + (while types + (when (string-match (pop types) type) + (throw 'found t))))))))) (defun gnus-article-insert-newline () "Insert a newline, but mark it as undeletable." @@ -3541,6 +4753,7 @@ (unless (setq not-pref (cadr (member preferred ihandles))) (setq not-pref (car ihandles))) (when (or ibegend + (not preferred) (not (gnus-unbuttonized-mime-type-p "multipart/alternative"))) (gnus-add-text-properties @@ -3555,11 +4768,9 @@ ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',not-pref ',begend ,id)) - ;; Not for Emacs 21: fixme better. - ;; local-map ,gnus-mime-button-map + ,@(gnus-local-map-property gnus-mime-button-map) ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face - keymap ,gnus-mime-button-map gnus-part ,id gnus-data ,handle)) (widget-convert-button 'link from (point) @@ -3581,11 +4792,9 @@ ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',handle ',begend ,id)) - ;; Not for Emacs 21: fixme better. - ;; local-map ,gnus-mime-button-map + ,@(gnus-local-map-property gnus-mime-button-map) ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face - keymap ,gnus-mime-button-map gnus-part ,id gnus-data ,handle)) (widget-convert-button 'link from (point) @@ -3614,6 +4823,39 @@ (when ibegend (goto-char point)))) +(defconst gnus-article-wash-status-strings + (let ((alist '((cite "c" "Possible hidden citation text" + " " "All citation text visible") + (headers "h" "Hidden headers" + " " "All headers visible.") + (pgp "p" "Encrypted or signed message status hidden" + " " "No hidden encryption nor digital signature status") + (signature "s" "Signature has been hidden" + " " "Signature is visible") + (overstrike "o" "Overstrike (^H) characters applied" + " " "No overstrike characters applied") + (emphasis "e" "/*_Emphasis_*/ characters applied" + " " "No /*_emphasis_*/ characters applied"))) + result) + (dolist (entry alist result) + (let ((key (nth 0 entry)) + (on (copy-sequence (nth 1 entry))) + (on-help (nth 2 entry)) + (off (copy-sequence (nth 3 entry))) + (off-help (nth 4 entry))) + (put-text-property 0 1 'help-echo on-help on) + (put-text-property 0 1 'help-echo off-help off) + (push (list key on off) result)))) + "Alist of strings describing wash status in the mode line. +Each entry has the form (KEY ON OF), where the KEY is a symbol +representing the particular washing function, ON is the string to use +in the article mode line when the washing function is active, and OFF +is the string to use when it is inactive.") + +(defun gnus-article-wash-status-entry (key value) + (let ((entry (assoc key gnus-article-wash-status-strings))) + (if value (nth 1 entry) (nth 2 entry)))) + (defun gnus-article-wash-status () "Return a string which display status of article washing." (save-excursion @@ -3623,16 +4865,42 @@ (boring (memq 'boring-headers gnus-article-wash-types)) (pgp (memq 'pgp gnus-article-wash-types)) (pem (memq 'pem gnus-article-wash-types)) + (signed (memq 'signed gnus-article-wash-types)) + (encrypted (memq 'encrypted gnus-article-wash-types)) (signature (memq 'signature gnus-article-wash-types)) (overstrike (memq 'overstrike gnus-article-wash-types)) (emphasis (memq 'emphasis gnus-article-wash-types))) - (format "%c%c%c%c%c%c" - (if cite ?c ? ) - (if (or headers boring) ?h ? ) - (if (or pgp pem) ?p ? ) - (if signature ?s ? ) - (if overstrike ?o ? ) - (if emphasis ?e ? ))))) + (concat + (gnus-article-wash-status-entry 'cite cite) + (gnus-article-wash-status-entry 'headers (or headers boring)) + (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted)) + (gnus-article-wash-status-entry 'signature signature) + (gnus-article-wash-status-entry 'overstrike overstrike) + (gnus-article-wash-status-entry 'emphasis emphasis))))) + +(defun gnus-add-wash-type (type) + "Add a washing of TYPE to the current status." + (add-to-list 'gnus-article-wash-types type)) + +(defun gnus-delete-wash-type (type) + "Add a washing of TYPE to the current status." + (setq gnus-article-wash-types (delq type gnus-article-wash-types))) + +(defun gnus-add-image (category image) + "Add IMAGE of CATEGORY to the list of displayed images." + (let ((entry (assq category gnus-article-image-alist))) + (unless entry + (setq entry (list category)) + (push entry gnus-article-image-alist)) + (nconc entry (list image)))) + +(defun gnus-delete-images (category) + "Delete all images in CATEGORY." + (let ((entry (assq category gnus-article-image-alist))) + (dolist (image (cdr entry)) + (gnus-remove-image image category)) + (setq gnus-article-image-alist (delq entry gnus-article-image-alist)) + (gnus-delete-wash-type category))) (defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) @@ -3671,30 +4939,35 @@ (widen) ;; Remove any old next/prev buttons. (when (gnus-visual-p 'page-marker) - (let ((inhibit-read-only t)) + (let ((buffer-read-only nil)) (gnus-remove-text-with-property 'gnus-prev) (gnus-remove-text-with-property 'gnus-next))) - (when + (if (cond ((< arg 0) (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) ((> arg 0) (re-search-forward page-delimiter nil 'move arg))) - (goto-char (match-end 0))) - (narrow-to-region - (point) - (if (re-search-forward page-delimiter nil 'move) - (match-beginning 0) - (point))) - (when (and (gnus-visual-p 'page-marker) - (> (point-min) (save-restriction (widen) (point-min)))) + (goto-char (match-end 0)) (save-excursion (goto-char (point-min)) - (gnus-insert-prev-page-button))) - (when (and (gnus-visual-p 'page-marker) - (< (point-max) (save-restriction (widen) (point-max)))) - (save-excursion - (goto-char (point-max)) - (gnus-insert-next-page-button))))) + (setq gnus-page-broken + (and (re-search-forward page-delimiter nil t) t)))) + (when gnus-page-broken + (narrow-to-region + (point) + (if (re-search-forward page-delimiter nil 'move) + (match-beginning 0) + (point))) + (when (and (gnus-visual-p 'page-marker) + (not (= (point-min) 1))) + (save-excursion + (goto-char (point-min)) + (gnus-insert-prev-page-button))) + (when (and (gnus-visual-p 'page-marker) + (< (+ (point-max) 2) (buffer-size))) + (save-excursion + (goto-char (point-max)) + (gnus-insert-next-page-button)))))) ;; Article mode commands @@ -3705,12 +4978,28 @@ (goto-char (point-min)) (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) + (defun gnus-article-goto-prev-page () - "Show the next page of the article." + "Show the previous page of the article." (interactive) - (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) + (if (bobp) + (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) (gnus-article-prev-page nil))) +;; This is cleaner but currently breaks `gnus-pick-mode': +;; +;; (defun gnus-article-goto-next-page () +;; "Show the next page of the article." +;; (interactive) +;; (gnus-eval-in-buffer-window gnus-summary-buffer +;; (gnus-summary-next-page))) +;; +;; (defun gnus-article-goto-prev-page () +;; "Show the next page of the article." +;; (interactive) +;; (gnus-eval-in-buffer-window gnus-summary-buffer +;; (gnus-summary-prev-page))) + (defun gnus-article-next-page (&optional lines) "Show the next page of the current article. If end of article, return non-nil. Otherwise return nil. @@ -3720,25 +5009,32 @@ (if (save-excursion (end-of-line) (and (pos-visible-in-window-p) ;Not continuation line. - (eobp))) + (>= (1+ (point)) (point-max)))) ;Allow for trailing newline. ;; Nothing in this page. (if (or (not gnus-page-broken) (save-excursion (save-restriction - (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? - t ;Nothing more. + (widen) + (eobp)))) ;Real end-of-buffer? + (progn + (when gnus-article-over-scroll + (gnus-article-next-page-1 lines)) + t) ;Nothing more. (gnus-narrow-to-page 1) ;Go to next page. nil) ;; More in this page. - (let ((scroll-in-place nil)) - (condition-case () - (scroll-up lines) - (end-of-buffer - ;; Long lines may cause an end-of-buffer error. - (goto-char (point-max))))) - (move-to-window-line 0) + (gnus-article-next-page-1 lines) nil)) +(defun gnus-article-next-page-1 (lines) + (let ((scroll-in-place nil)) + (condition-case () + (scroll-up lines) + (end-of-buffer + ;; Long lines may cause an end-of-buffer error. + (goto-char (point-max))))) + (move-to-window-line 0)) + (defun gnus-article-prev-page (&optional lines) "Show previous page of current article. Argument LINES specifies lines to be scrolled down." @@ -3759,17 +5055,33 @@ (goto-char (point-min)))) (move-to-window-line 0))))) +(defun gnus-article-only-boring-p () + "Decide whether there is only boring text remaining in the article. +Something \"interesting\" is a word of at least two letters that does +not have a face in `gnus-article-boring-faces'." + (when (and gnus-article-skip-boring + (boundp 'gnus-article-boring-faces) + (symbol-value 'gnus-article-boring-faces)) + (save-excursion + (catch 'only-boring + (while (re-search-forward "\\b\\w\\w" nil t) + (forward-char -1) + (when (not (gnus-intersection + (gnus-faces-at (point)) + (symbol-value 'gnus-article-boring-faces))) + (throw 'only-boring nil))) + (throw 'only-boring t))))) + (defun gnus-article-refer-article () "Read article specified by message-id around point." (interactive) - (let ((point (point))) - (search-forward ">" nil t) ;Move point to end of "<....>". - (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) - (let ((message-id (match-string 1))) - (goto-char point) + (save-excursion + (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t) + (re-search-forward "<?news:<?\\|<" (gnus-point-at-eol) t) + (if (re-search-forward "[^@ ]+@[^ \t>]+" (gnus-point-at-eol) t) + (let ((msg-id (concat "<" (match-string 0) ">"))) (set-buffer gnus-summary-buffer) - (gnus-summary-refer-article message-id)) - (goto-char (point)) + (gnus-summary-refer-article msg-id)) (error "No references around point")))) (defun gnus-article-show-summary () @@ -3818,61 +5130,61 @@ (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" - "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" - "=" "^" "\M-^" "|")) - (nosave-but-article - '("A\r")) - (nosave-in-article - '("\C-d")) - (up-to-top - '("n" "Gn" "p" "Gp")) - keys new-sum-point) + '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" + "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" + "=" "^" "\M-^" "|")) + (nosave-but-article + '("A\r")) + (nosave-in-article + '("\C-d")) + (up-to-top + '("n" "Gn" "p" "Gp")) + keys new-sum-point) (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (or key last-command-event) unread-command-events) - (setq keys (if (featurep 'xemacs) + (push (or key last-command-event) unread-command-events) + (setq keys (if (featurep 'xemacs) (events-to-keys (read-key-sequence nil)) (read-key-sequence nil))))) (message "") (if (or (member keys nosaves) - (member keys nosave-but-article) - (member keys nosave-in-article)) - (let (func) - (save-window-excursion - (pop-to-buffer gnus-article-current-summary 'norecord) - ;; We disable the pick minor mode commands. - (let (gnus-pick-mode) - (setq func (lookup-key (current-local-map) keys)))) - (if (or (not func) + (member keys nosave-but-article) + (member keys nosave-in-article)) + (let (func) + (save-window-excursion + (pop-to-buffer gnus-article-current-summary 'norecord) + ;; We disable the pick minor mode commands. + (let (gnus-pick-mode) + (setq func (lookup-key (current-local-map) keys)))) + (if (or (not func) (numberp func)) - (ding) - (unless (member keys nosave-in-article) - (set-buffer gnus-article-current-summary)) - (call-interactively func) - (setq new-sum-point (point))) - (when (member keys nosave-but-article) - (pop-to-buffer gnus-article-buffer 'norecord))) + (ding) + (unless (member keys nosave-in-article) + (set-buffer gnus-article-current-summary)) + (call-interactively func) + (setq new-sum-point (point))) + (when (member keys nosave-but-article) + (pop-to-buffer gnus-article-buffer 'norecord))) ;; These commands should restore window configuration. (let ((obuf (current-buffer)) - (owin (current-window-configuration)) - (opoint (point)) - (summary gnus-article-current-summary) - func in-buffer selected) - (if not-restore-window - (pop-to-buffer summary 'norecord) - (switch-to-buffer summary 'norecord)) - (setq in-buffer (current-buffer)) - ;; We disable the pick minor mode commands. - (if (and (setq func (let (gnus-pick-mode) + (owin (current-window-configuration)) + (opoint (point)) + (summary gnus-article-current-summary) + func in-buffer selected) + (if not-restore-window + (pop-to-buffer summary 'norecord) + (switch-to-buffer summary 'norecord)) + (setq in-buffer (current-buffer)) + ;; We disable the pick minor mode commands. + (if (and (setq func (let (gnus-pick-mode) (lookup-key (current-local-map) keys))) (functionp func)) - (progn - (call-interactively func) - (setq new-sum-point (point)) + (progn + (call-interactively func) + (setq new-sum-point (point)) (when (eq in-buffer (current-buffer)) (setq selected (gnus-summary-select-article)) (set-buffer obuf) @@ -3888,7 +5200,7 @@ (when win (set-window-point win new-sum-point)))) ) (switch-to-buffer gnus-article-buffer) - (ding)))))) + (ding)))))) (defun gnus-article-describe-key (key) "Display documentation of the function invoked by KEY. KEY is a string." @@ -3898,10 +5210,16 @@ (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (elt key 0) unread-command-events) - (setq key (if (featurep 'xemacs) - (events-to-keys (read-key-sequence "Describe key: ")) - (read-key-sequence "Describe key: ")))) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + (string-to-list key))) + (setq key (read-key-sequence "Describe key: ")))) (describe-key key)) (describe-key key))) @@ -3913,22 +5231,65 @@ (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (elt key 0) unread-command-events) - (setq key (if (featurep 'xemacs) - (events-to-keys (read-key-sequence "Describe key: ")) - (read-key-sequence "Describe key: ")))) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + (string-to-list key))) + (setq key (read-key-sequence "Describe key: ")))) (describe-key-briefly key insert)) (describe-key-briefly key insert))) +(defun gnus-article-reply-with-original (&optional wide) + "Start composing a reply mail to the current message. +The text in the region will be yanked. If the region isn't active, +the entire article will be yanked." + (interactive "P") + (let ((article (cdr gnus-article-current)) + contents) + (if (not (gnus-mark-active-p)) + (with-current-buffer gnus-summary-buffer + (gnus-summary-reply (list (list article)) wide)) + (setq contents (buffer-substring (point) (mark t))) + ;; Deactivate active regions. + (when (and (boundp 'transient-mark-mode) + transient-mark-mode) + (setq mark-active nil)) + (with-current-buffer gnus-summary-buffer + (gnus-summary-reply + (list (list article contents)) wide))))) + +(defun gnus-article-followup-with-original () + "Compose a followup to the current article. +The text in the region will be yanked. If the region isn't active, +the entire article will be yanked." + (interactive) + (let ((article (cdr gnus-article-current)) + contents) + (if (not (gnus-mark-active-p)) + (with-current-buffer gnus-summary-buffer + (gnus-summary-followup (list (list article)))) + (setq contents (buffer-substring (point) (mark t))) + ;; Deactivate active regions. + (when (and (boundp 'transient-mark-mode) + transient-mark-mode) + (setq mark-active nil)) + (with-current-buffer gnus-summary-buffer + (gnus-summary-followup + (list (list article contents))))))) + (defun gnus-article-hide (&optional arg force) "Hide all the gruft in the current article. -This means that PGP stuff, signatures, cited text and (some) -headers will be hidden. +This means that signatures, cited text and (some) headers will be +hidden. If given a prefix, show the hidden text instead." (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-article-hide-headers arg) (gnus-article-hide-list-identifiers arg) - (gnus-article-hide-pgp arg) (gnus-article-hide-citation-maybe arg force) (gnus-article-hide-signature arg)) @@ -3944,6 +5305,9 @@ (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) (gnus-request-group gnus-newsgroup-name t))) +(eval-when-compile + (autoload 'nneething-get-file-name "nneething")) + (defun gnus-request-article-this-buffer (article group) "Get an article and insert it into this buffer." (let (do-update-line sparse-header) @@ -3993,12 +5357,10 @@ gnus-newsgroup-name))) (when (and (eq (car method) 'nneething) (vectorp header)) - (let ((dir (expand-file-name - (mail-header-subject header) - (file-name-as-directory - (or (cadr (assq 'nneething-address method)) - (nth 1 method)))))) - (when (file-directory-p dir) + (let ((dir (nneething-get-file-name + (mail-header-id header)))) + (when (and (stringp dir) + (file-directory-p dir)) (setq article 'nneething) (gnus-group-enter-directory dir)))))))) @@ -4037,14 +5399,19 @@ (numberp article) (gnus-cache-request-article article group)) 'article) + ;; Check the agent cache. + ((gnus-agent-request-article article group) + 'article) ;; Get the article and put into the article buffer. ((or (stringp article) (numberp article)) (let ((gnus-override-method gnus-override-method) (methods (and (stringp article) gnus-refer-article-method)) + (backend (car (gnus-find-method-for-group + gnus-newsgroup-name))) result - (inhibit-read-only t)) + (buffer-read-only nil)) (if (or (not (listp methods)) (and (symbolp (car methods)) (assq (car methods) nnoo-definition-alist))) @@ -4061,7 +5428,8 @@ (gnus-kill-all-overlays) (let ((gnus-newsgroup-name group)) (gnus-check-group-server)) - (when (gnus-request-article article group (current-buffer)) + (cond + ((gnus-request-article article group (current-buffer)) (when (numberp article) (gnus-async-prefetch-next group article gnus-summary-buffer) @@ -4069,10 +5437,13 @@ (gnus-backlog-enter-article group article (current-buffer)))) (setq result 'article)) - (if (not result) - (if methods - (setq gnus-override-method (pop methods)) - (setq result 'done)))) + (methods + (setq gnus-override-method (pop methods))) + ((not (string-match "^400 " + (nnheader-get-report backend))) + ;; If we get 400 server disconnect, reconnect and + ;; retry; otherwise, assume the article has expired. + (setq result 'done)))) (and (eq result 'article) 'article))) ;; It was a pseudo. (t article))) @@ -4110,7 +5481,7 @@ (set-buffer gnus-summary-buffer) (gnus-summary-update-article do-update-line sparse-header) (gnus-summary-goto-subject do-update-line nil t) - (set-window-point (get-buffer-window (current-buffer) t) + (set-window-point (gnus-get-buffer-window (current-buffer) t) (point)) (set-buffer buf)))))) @@ -4126,21 +5497,72 @@ (defvar gnus-article-edit-done-function nil) (defvar gnus-article-edit-mode-map nil) +(defvar gnus-article-edit-mode nil) ;; Should we be using derived.el for this? (unless gnus-article-edit-mode-map - (setq gnus-article-edit-mode-map (make-sparse-keymap)) + (setq gnus-article-edit-mode-map (make-keymap)) (set-keymap-parent gnus-article-edit-mode-map text-mode-map) (gnus-define-keys gnus-article-edit-mode-map + "\C-c?" describe-mode "\C-c\C-c" gnus-article-edit-done - "\C-c\C-k" gnus-article-edit-exit) + "\C-c\C-k" gnus-article-edit-exit + "\C-c\C-f\C-t" message-goto-to + "\C-c\C-f\C-o" message-goto-from + "\C-c\C-f\C-b" message-goto-bcc + ;;"\C-c\C-f\C-w" message-goto-fcc + "\C-c\C-f\C-c" message-goto-cc + "\C-c\C-f\C-s" message-goto-subject + "\C-c\C-f\C-r" message-goto-reply-to + "\C-c\C-f\C-n" message-goto-newsgroups + "\C-c\C-f\C-d" message-goto-distribution + "\C-c\C-f\C-f" message-goto-followup-to + "\C-c\C-f\C-m" message-goto-mail-followup-to + "\C-c\C-f\C-k" message-goto-keywords + "\C-c\C-f\C-u" message-goto-summary + "\C-c\C-f\C-i" message-insert-or-toggle-importance + "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to + "\C-c\C-b" message-goto-body + "\C-c\C-i" message-goto-signature + + "\C-c\C-t" message-insert-to + "\C-c\C-n" message-insert-newsgroups + "\C-c\C-o" message-sort-headers + "\C-c\C-e" message-elide-region + "\C-c\C-v" message-delete-not-region + "\C-c\C-z" message-kill-to-signature + "\M-\r" message-newline-and-reformat + "\C-c\C-a" mml-attach-file + "\C-a" message-beginning-of-line + "\t" message-tab + "\M-;" comment-region) (gnus-define-keys (gnus-article-edit-wash-map "\C-c\C-w" gnus-article-edit-mode-map) "f" gnus-article-edit-full-stops)) -(define-derived-mode gnus-article-edit-mode message-mode "Article Edit" +(easy-menu-define + gnus-article-edit-mode-field-menu gnus-article-edit-mode-map "" + '("Field" + ["Fetch To" message-insert-to t] + ["Fetch Newsgroups" message-insert-newsgroups t] + "----" + ["To" message-goto-to t] + ["From" message-goto-from t] + ["Subject" message-goto-subject t] + ["Cc" message-goto-cc t] + ["Reply-To" message-goto-reply-to t] + ["Summary" message-goto-summary t] + ["Keywords" message-goto-keywords t] + ["Newsgroups" message-goto-newsgroups t] + ["Followup-To" message-goto-followup-to t] + ["Mail-Followup-To" message-goto-mail-followup-to t] + ["Distribution" message-goto-distribution t] + ["Body" message-goto-body t] + ["Signature" message-goto-signature t])) + +(define-derived-mode gnus-article-edit-mode text-mode "Article Edit" "Major mode for editing articles. This is an extended text-mode. @@ -4149,6 +5571,10 @@ (make-local-variable 'gnus-prev-winconf) (set (make-local-variable 'font-lock-defaults) '(message-font-lock-keywords t)) + (set (make-local-variable 'mail-header-separator) "") + (set (make-local-variable 'gnus-article-edit-mode) t) + (easy-menu-add message-mode-field-menu message-mode-map) + (mml-mode) (setq buffer-read-only nil) (buffer-enable-undo) (widen)) @@ -4177,6 +5603,7 @@ (set-buffer gnus-article-buffer) (gnus-article-edit-mode) (funcall start-func) + (set-buffer-modified-p nil) (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) @@ -4185,69 +5612,57 @@ (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." (interactive "P") - (widen) - (save-excursion - (save-restriction - (when (article-goto-body) - (let ((lines (count-lines (point) (point-max))) - (length (- (point-max) (point))) - (case-fold-search t) - (body (copy-marker (point)))) - (goto-char (point-min)) - (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward - "^x-content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string lines))))))) (let ((func gnus-article-edit-done-function) (buf (current-buffer)) - (start (window-start))) - (gnus-article-edit-exit) + (start (window-start)) + (p (point)) + (winconf gnus-prev-winconf)) + (widen) ;; Widen it in case that users narrowed the buffer. + (funcall func arg) + (set-buffer buf) + ;; The cache and backlog have to be flushed somewhat. + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + ;; Flush original article as well. (save-excursion - (set-buffer buf) - (let ((inhibit-read-only t)) - (funcall func arg)) - ;; The cache and backlog have to be flushed somewhat. - (when gnus-keep-backlog - (gnus-backlog-remove-article - (car gnus-article-current) (cdr gnus-article-current))) - ;; Flush original article as well. - (save-excursion - (when (get-buffer gnus-original-article-buffer) - (set-buffer gnus-original-article-buffer) - (setq gnus-original-article nil))) - (when gnus-use-cache - (gnus-cache-update-article - (car gnus-article-current) (cdr gnus-article-current)))) + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current))) + ;; We remove all text props from the article buffer. + (kill-all-local-variables) + (gnus-set-text-properties (point-min) (point-max) nil) + (gnus-article-mode) + (set-window-configuration winconf) (set-buffer buf) (set-window-start (get-buffer-window buf) start) - (set-window-point (get-buffer-window buf) (point)))) + (set-window-point (get-buffer-window buf) (point))) + (gnus-summary-show-article)) (defun gnus-article-edit-exit () "Exit the article editing without updating." (interactive) - ;; We remove all text props from the article buffer. - (let ((buf (buffer-substring-no-properties (point-min) (point-max))) - (curbuf (current-buffer)) - (p (point)) - (window-start (window-start))) - (erase-buffer) - (insert buf) - (let ((winconf gnus-prev-winconf)) - (gnus-article-mode) - (set-window-configuration winconf) - ;; Tippy-toe some to make sure that point remains where it was. - (save-current-buffer - (set-buffer curbuf) - (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p))))) + (when (or (not (buffer-modified-p)) + (yes-or-no-p "Article modified; kill anyway? ")) + (let ((curbuf (current-buffer)) + (p (point)) + (window-start (window-start))) + (erase-buffer) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (insert-buffer gnus-original-article-buffer)) + (let ((winconf gnus-prev-winconf)) + (kill-all-local-variables) + (gnus-article-mode) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (save-current-buffer + (set-buffer curbuf) + (set-window-start (get-buffer-window (current-buffer)) window-start) + (goto-char p)))) + (gnus-summary-show-article))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -4268,36 +5683,492 @@ (defcustom gnus-button-url-regexp (if (string-match "[[:digit:]]" "1") ;; support POSIX? - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,[:word:]]+[-a-zA-Z0-9_=#$@~`%&*+|\\/[:word:]]\\)" - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)") + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)" + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)") "Regular expression that matches URLs." :group 'gnus-article-buttons :type 'regexp) +(defcustom gnus-button-valid-fqdn-regexp + message-valid-fqdn-regexp + "Regular expression that matches a valid FQDN." + :group 'gnus-article-buttons + :type 'regexp) + +(defcustom gnus-button-man-handler 'manual-entry + "Function to use for displaying man pages. +The function must take at least one argument with a string naming the +man page." + :type '(choice (function-item :tag "Man" manual-entry) + (function-item :tag "Woman" woman) + (function :tag "Other")) + :group 'gnus-article-buttons) + +(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/" + "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive. +If the default site is too slow, try to find a CTAN mirror, see +<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also +the variable `gnus-button-handle-ctan'." + :group 'gnus-article-buttons + :link '(custom-manual "(gnus)Group Parameters") + :type '(choice (const "http://www.tex.ac.uk/tex-archive/") + (const "http://tug.ctan.org/tex-archive/") + (const "http://www.dante.de/CTAN/") + (string :tag "Other"))) + +(defcustom gnus-button-ctan-handler 'browse-url + "Function to use for displaying CTAN links. +The function must take one argument, the string naming the URL." + :type '(choice (function-item :tag "Browse Url" browse-url) + (function :tag "Other")) + :group 'gnus-article-buttons) + +(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/" + "Bogus strings removed from CTAN URLs." + :group 'gnus-article-buttons + :type '(choice (const "^/?tex-archive/\\|/") + (regexp :tag "Other"))) + +(defcustom gnus-button-ctan-directory-regexp + (concat + "\\("; Cannot use `\(?: ... \)' (compatibility with Emacs 20). + "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|" + "indexing\\|info\\|language\\|macros\\|support\\|systems\\|" + "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete" + "\\)") + "Regular expression for ctan directories. +It should match all directories in the top level of `gnus-ctan-url'." + :group 'gnus-article-buttons + :type 'regexp) + +(defcustom gnus-button-mid-or-mail-regexp + (concat "\\b\\(<?[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*@" + ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de> + gnus-button-valid-fqdn-regexp + ">?\\)\\b") + "Regular expression that matches a message ID or a mail address." + :group 'gnus-article-buttons + :type 'regexp) + +(defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic + "What to do when the button on a string as \"foo123@bar.invalid\" is pushed. +Strings like this can be either a message ID or a mail address. If it is one +of the symbols `mid' or `mail', Gnus will always assume that the string is a +message ID or a mail address, respectively. If this variable is set to the +symbol `ask', always query the user what do do. If it is a function, this +function will be called with the string as it's only argument. The function +must return `mid', `mail', `invalid' or `ask'." + :group 'gnus-article-buttons + :type '(choice (function-item :tag "Heuristic function" + gnus-button-mid-or-mail-heuristic) + (const ask) + (const mid) + (const mail))) + +(defcustom gnus-button-mid-or-mail-heuristic-alist + '((-10.0 . ".+\\$.+@") + (-10.0 . "#") + (-10.0 . "\\*") + (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs + (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i + (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i; + (-1.0 . "^[^a-z]+@") + ;; + (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@" + (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@" + (-3.0 . "[A-Z][A-Z][a-z][a-z].*@") + (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@") + ;; + (-2.0 . "^[0-9]") + (-1.0 . "^[0-9][0-9]") + ;; + ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/; + (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") + ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/; + (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]") + ;; + (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@" + (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@") + ;; "[0-9]{8,}.*\@" + (-3.0 + . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@") + ;; "[0-9]{12,}.*\@" + ;; compensation for TDMA dated mail addresses: + (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@") + ;; + (-20.0 . "\\.fsf@") ;; Gnus + (-20.0 . "^slrn") + (-20.0 . "^Pine") + (-20.0 . "_-_") ;; Subject change in thread + ;; + (-20.0 . "\\.ln@") ;; leafnode + (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de") + (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent + ;; + ;; (5.0 . "") ;; $local_part_len <= 7 + (10.0 . "^[^0-9]+@") + (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@") + ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part + (3.0 . "\@stud") + ;; + (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@") + ;; + (0.5 . "^[A-Z][a-z]") + (0.5 . "^[A-Z][a-z][a-z]") + (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3} + (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4} + "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'. + +A negative RATE indicates a message IDs, whereas a positive indicates a mail +address. The REGEXP is processed with `case-fold-search' set to nil." + :group 'gnus-article-buttons + :type '(repeat (cons (number :tag "Rate") + (regexp :tag "Regexp")))) + +(defun gnus-button-mid-or-mail-heuristic (mid-or-mail) + "Guess whether MID-OR-MAIL is a message ID or a mail address. +Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail +address, `ask' if unsure and `invalid' if the string is invalid." + (let ((case-fold-search nil) + (list gnus-button-mid-or-mail-heuristic-alist) + (result 0) rate regexp lpartlen elem) + (setq lpartlen + (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1"))) + (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen) + ;; Certain special cases... + (when (string-match + (concat + "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|" + "^[0-9]+\\.[0-9]+@compuserve\\|" + "@public\\.gmane\\.org") + mid-or-mail) + (gnus-message 8 "`%s' is a known mail address." mid-or-mail) + (setq result 'mail)) + (when (string-match "@.*@\\| " mid-or-mail) + (gnus-message 8 "`%s' is invalid." mid-or-mail) + (setq result 'invalid)) + ;; Nothing more to do, if result is not a number here... + (when (numberp result) + (while list + (setq elem (car list) + rate (car elem) + regexp (cdr elem) + list (cdr list)) + (when (string-match regexp mid-or-mail) + (setq result (+ result rate)) + (gnus-message + 9 "`%s' matched `%s', rate `%s', result `%s'." + mid-or-mail regexp rate result))) + (when (<= lpartlen 7) + (setq result (+ result 5.0)) + (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'." + mid-or-mail result)) + (when (>= lpartlen 12) + (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail) + (cond + ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail) + ;; Long local part should contain realname if e-mail address, + ;; too many digits: message-id. + ;; $score -= 5.0 + 0.1 * $local_part_len; + (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen)))) + (setq result (+ result rate)) + (gnus-message + 9 "Many digits in `%s', rate `%s', result `%s'." + mid-or-mail rate result)) + ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@" + mid-or-mail) + ;; Too few vowels [^aeiouy]{4,}.*\@ + (setq result (+ result -5.0)) + (gnus-message + 9 "Few vowels in `%s', rate `%s', result `%s'." + mid-or-mail -5.0 result)) + (t + (setq result (+ result 5.0)) + (gnus-message + 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result))))) + (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result) + ;; Maybe we should make this a customizable alist: (condition . 'result) + (cond + ((symbolp result) result) + ;; Now convert number into proper results: + ((< result -10.0) 'mid) + ((> result 10.0) 'mail) + (t 'ask)))) + +(defun gnus-button-handle-mid-or-mail (mid-or-mail) + (let* ((pref gnus-button-prefer-mid-or-mail) guessed + (url-mid (concat "news" ":" mid-or-mail)) + (url-mailto (concat "mailto" ":" mid-or-mail))) + (gnus-message 9 "mid-or-mail=%s" mid-or-mail) + (when (fboundp pref) + (setq guessed + ;; get rid of surrounding angles... + (funcall pref + (gnus-replace-in-string mid-or-mail "^<\\|>$" ""))) + (if (or (eq 'mid guessed) (eq 'mail guessed)) + (setq pref guessed) + (setq pref 'ask))) + (if (eq pref 'ask) + (save-window-excursion + (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? ")) + (setq pref 'mail) + (setq pref 'mid)))) + (cond ((eq pref 'mid) + (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid) + (gnus-button-handle-news url-mid)) + ((eq pref 'mail) + (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto) + (gnus-url-mailto url-mailto)) + (t (gnus-message 3 "Invalid string."))))) + +(defun gnus-button-handle-custom (url) + "Follow a Custom URL." + (customize-apropos (gnus-url-unhex-string url))) + +(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)") + +;; FIXME: Maybe we should merge some of the functions that do quite similar +;; stuff? + +(defun gnus-button-handle-describe-function (url) + "Call `describe-function' when pushing the corresponding URL button." + (describe-function + (intern + (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) + +(defun gnus-button-handle-describe-variable (url) + "Call `describe-variable' when pushing the corresponding URL button." + (describe-variable + (intern + (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) + +(defun gnus-button-handle-symbol (url) +"Display help on variable or function. +Calls `describe-variable' or `describe-function'." + (let ((sym (intern url))) + (cond + ((fboundp sym) (describe-function sym)) + ((boundp sym) (describe-variable sym)) + (t (gnus-message 3 "`%s' is not a known function of variable." url))))) + +(defun gnus-button-handle-describe-key (url) + "Call `describe-key' when pushing the corresponding URL button." + (let* ((key-string + (gnus-replace-in-string url gnus-button-handle-describe-prefix "")) + (keys (ignore-errors (eval `(kbd ,key-string))))) + (if keys + (describe-key keys) + (gnus-message 3 "Invalid key sequence in button: %s" key-string)))) + +(defun gnus-button-handle-apropos (url) + "Call `apropos' when pushing the corresponding URL button." + (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + +(defun gnus-button-handle-apropos-command (url) + "Call `apropos' when pushing the corresponding URL button." + (apropos-command + (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + +(defun gnus-button-handle-apropos-variable (url) + "Call `apropos' when pushing the corresponding URL button." + (funcall + (if (fboundp 'apropos-variable) 'apropos-variable 'apropos) + (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + +(defun gnus-button-handle-apropos-documentation (url) + "Call `apropos' when pushing the corresponding URL button." + (funcall + (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos) + (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + +(defun gnus-button-handle-library (url) + "Call `locate-library' when pushing the corresponding URL button." + (gnus-message 9 "url=`%s'" url) + (let* ((lib (locate-library url)) + (file (gnus-replace-in-string (or lib "") "\.elc" ".el"))) + (if (not lib) + (gnus-message 1 "Cannot locale library `%s'." url) + (find-file-read-only file)))) + +(defun gnus-button-handle-ctan (url) + "Call `browse-url' when pushing a CTAN URL button." + (funcall + gnus-button-ctan-handler + (concat + gnus-ctan-url + (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp "")))) + +(defcustom gnus-button-tex-level 5 + "*Integer that says how many TeX-related buttons Gnus will show. +The higher the number, the more buttons will appear and the more false +positives are possible. Note that you can set this variable local to +specific groups. Setting it higher in TeX groups is probably a good idea. +See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on +how to set variables in specific groups." + :group 'gnus-article-buttons + :link '(custom-manual "(gnus)Group Parameters") + :type 'integer) + +(defcustom gnus-button-man-level 5 + "*Integer that says how many man-related buttons Gnus will show. +The higher the number, the more buttons will appear and the more false +positives are possible. Note that you can set this variable local to +specific groups. Setting it higher in Unix groups is probably a good idea. +See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on +how to set variables in specific groups." + :group 'gnus-article-buttons + :link '(custom-manual "(gnus)Group Parameters") + :type 'integer) + +(defcustom gnus-button-emacs-level 5 + "*Integer that says how many emacs-related buttons Gnus will show. +The higher the number, the more buttons will appear and the more false +positives are possible. Note that you can set this variable local to +specific groups. Setting it higher in Emacs or Gnus related groups is +probably a good idea. See Info node `(gnus)Group Parameters' and the variable +`gnus-parameters' on how to set variables in specific groups." + :group 'gnus-article-buttons + :link '(custom-manual "(gnus)Group Parameters") + :type 'integer) + +(defcustom gnus-button-message-level 5 + "*Integer that says how many buttons for news or mail messages will appear. +The higher the number, the more buttons will appear and the more false +positives are possible." + ;; mail addresses, MIDs, URLs for news, ... + :group 'gnus-article-buttons + :type 'integer) + +(defcustom gnus-button-browse-level 5 + "*Integer that says how many buttons for browsing will appear. +The higher the number, the more buttons will appear and the more false +positives are possible." + ;; stuff handled by `browse-url' or `gnus-button-embedded-url' + :group 'gnus-article-buttons + :type 'integer) + (defcustom gnus-button-alist - `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" - 0 t gnus-button-message-id 2) - ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1) - ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" - 1 t - gnus-button-fetch-group 4) - ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2) - ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 - t gnus-button-message-id 3) - ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2) - ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) - ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) - ;; This is how URLs _should_ be embedded in text... - ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1) - ;; Info manual references. - ("(\\(info\\|Info-goto-node\\)[ \n\t]+\"\\(([^)\"\n]+)[^\"\n]+\\)\")" - 0 t Info-goto-node 2) + '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" + 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3) + ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t + gnus-button-handle-news 2) + ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" + 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5) + ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3) + ;; RFC 2392 (Don't allow `/' in domain part --> CID) + ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)" + 0 (>= gnus-button-message-level 0) gnus-button-message-id 2) + ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" + 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) + ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 2) + ;; RFC 2368 (The mailto URL scheme) + ("mailto:\\([-a-z.@_+0-9%=?&]+\\)" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) + ("\\bmailto:\\([^ \n\t]+\\)" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) + ;; CTAN + ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\(" + gnus-button-ctan-directory-regexp + "[^][>)!;:,'\n\t ]+\\)") + 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1) + ((concat "\\btex-archive/\\(" + gnus-button-ctan-directory-regexp + "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)") + 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1) + ((concat + "\\b\\(" + gnus-button-ctan-directory-regexp + "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)") + 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1) + ;; This is info (home-grown style) <info://foo/bar+baz> + ("\\binfo://\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1) + ;; Info GNOME style <info:foo#bar_baz> + ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1) + ;; Info KDE style <info:(foo)bar baz> + ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>" + 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2) + ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0 + (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2) + ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" + ;; Info links like `C-h i d m CC Mode RET' + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2) + ;; This is custom + ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2) + ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0 + (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1) + ;; Emacs help commands + ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + ;; regexp doesn't match arguments containing ` '. + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1) + ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1) + ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) + ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) + ;; The following entries may lead to many false positives so don't enable + ;; them by default (use a high button level): + ("/\\([a-z][-a-z0-9]+\\.el\\)\\>" + 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) + ("`\\([a-z][-a-z0-9]+\\.el\\)'" + 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) + ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'" + 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1) + ("`\\([a-z][a-z0-9]+-[a-z]+\\)'" + 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1) + ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)" + 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1) + ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1) + ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2) + ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2) + ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'" + ;; Unlike the other regexps we really have to require quoting + ;; here to determine where it ends. + 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) + ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... + ("<URL: *\\([^<>]*\\)>" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) ;; Raw URLs. - (,gnus-button-url-regexp 0 t browse-url 0)) + (gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) + ;; man pages + ("\\b\\([a-z][a-z]+\\)([1-9])\\W" + 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) + gnus-button-handle-man 1) + ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x) + ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W" + 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5)) + gnus-button-handle-man 1) + ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm), + ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7) + ("\\b\\([a-z][-+_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W" + 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1) + ;; MID or mail: To avoid too many false positives we don't try to catch + ;; all kind of allowed MIDs or mail addresses. Domain part must contain + ;; at least one dot. TLD must contain two or three chars or be a know TLD + ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist' + ;; so that non-ambiguous entries (see above) match first. + (gnus-button-mid-or-mail-regexp + 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1)) "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where -REGEXP: is the string matching text around the button, +REGEXP: is the string (case insensitive) matching text around the button (can +also be Lisp expression evaluating to a string), BUTTON: is the number of the regexp grouping actually matching the button, FORM: is a Lisp expression which must eval to true for the button to be added, @@ -4307,7 +6178,7 @@ CALLBACK can also be a variable, in that case the value of that variable it the real callback function." :group 'gnus-article-buttons - :type '(repeat (list regexp + :type '(repeat (list (choice regexp variable sexp) (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -4316,16 +6187,22 @@ (integer :tag "Regexp group"))))) (defcustom gnus-header-button-alist - `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" - 0 t gnus-button-message-id 0) - ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) + '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" + 0 (>= gnus-button-message-level 0) gnus-button-message-id 0) + ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" + 1 (>= gnus-button-message-level 0) gnus-button-reply 1) ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" - 0 t gnus-button-mailto 0) - ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0) - ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0) - ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0) - ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t - gnus-button-message-id 3)) + 0 (>= gnus-button-message-level 0) gnus-button-mailto 0) + ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^Subject:" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^[^:]+:" gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url 0) + ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&]+\\)" + 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) + ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" + 1 (>= gnus-button-message-level 0) gnus-button-message-id 4)) "*Alist of headers and regexps to match buttons in article heads. This alist is very similar to `gnus-button-alist', except that each @@ -4338,7 +6215,7 @@ :group 'gnus-article-buttons :group 'gnus-article-headers :type '(repeat (list (regexp :tag "Header") - regexp + (choice regexp variable) (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -4362,7 +6239,7 @@ (interactive "e") (set-buffer (window-buffer (posn-window (event-start event)))) (let* ((pos (posn-point (event-start event))) - (data (get-text-property pos 'gnus-data)) + (data (get-text-property pos 'gnus-data)) (fun (get-text-property pos 'gnus-callback))) (goto-char pos) (when fun @@ -4373,8 +6250,8 @@ If the text at point has a `gnus-callback' property, call it with the value of the `gnus-data' text property." (interactive) - (let* ((data (get-text-property (point) 'gnus-data)) - (fun (get-text-property (point) 'gnus-callback))) + (let ((data (get-text-property (point) 'gnus-data)) + (fun (get-text-property (point) 'gnus-callback))) (when fun (funcall fun data)))) @@ -4408,7 +6285,7 @@ (set-buffer gnus-article-buffer) (save-restriction (let ((alist gnus-header-face-alist) - (inhibit-read-only t) + (buffer-read-only nil) (case-fold-search t) (inhibit-point-motion-hooks t) entry regexp header-face field-face from hpoints fpoints) @@ -4447,7 +6324,7 @@ (interactive) (save-excursion (set-buffer gnus-article-buffer) - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) (save-restriction (when (and gnus-signature-face @@ -4472,7 +6349,7 @@ (interactive (list 'force)) (save-excursion (set-buffer gnus-article-buffer) - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (case-fold-search t) (alist gnus-button-alist) @@ -4493,7 +6370,7 @@ (article-goto-body) (setq beg (point)) (while (setq entry (pop alist)) - (setq regexp (car entry)) + (setq regexp (eval (car entry))) (goto-char beg) (while (re-search-forward regexp nil t) (let* ((start (and entry (match-beginning (nth 1 entry)))) @@ -4517,7 +6394,7 @@ (save-excursion (set-buffer gnus-article-buffer) (save-restriction - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (case-fold-search t) (alist gnus-header-button-alist) @@ -4535,7 +6412,7 @@ (match-beginning 0)) (point-max))) (goto-char beg) - (while (re-search-forward (nth 1 entry) end t) + (while (re-search-forward (eval (nth 1 entry)) end t) ;; Each match within a header. (let* ((entry (cdr entry)) (start (match-beginning (nth 1 entry))) @@ -4575,17 +6452,22 @@ (defun gnus-signature-toggle (end) (save-excursion (set-buffer gnus-article-buffer) - (let ((inhibit-read-only t) + (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) (if (text-property-any end (point-max) 'article-type 'signature) - (gnus-remove-text-properties-when - 'article-type 'signature end (point-max) - (cons 'article-type (cons 'signature - gnus-hidden-properties))) + (progn + (gnus-delete-wash-type 'signature) + (gnus-remove-text-properties-when + 'article-type 'signature end (point-max) + (cons 'article-type (cons 'signature + gnus-hidden-properties)))) + (gnus-add-wash-type 'signature) (gnus-add-text-properties-when 'article-type nil end (point-max) (cons 'article-type (cons 'signature - gnus-hidden-properties))))))) + gnus-hidden-properties))))) + (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article)))) (defun gnus-button-entry () ;; Return the first entry in `gnus-button-alist' matching this place. @@ -4593,7 +6475,7 @@ (entry nil)) (while alist (setq entry (pop alist)) - (if (looking-at (car entry)) + (if (looking-at (eval (car entry))) (setq alist nil) (setq entry nil))) entry)) @@ -4621,6 +6503,90 @@ (gnus-message 1 "You must define `%S' to use this button" (cons fun args))))))) +(defun gnus-parse-news-url (url) + (let (scheme server group message-id articles) + (with-temp-buffer + (insert url) + (goto-char (point-min)) + (when (looking-at "\\([A-Za-z]+\\):") + (setq scheme (match-string 1)) + (goto-char (match-end 0))) + (when (looking-at "//\\([^/]+\\)/") + (setq server (match-string 1)) + (goto-char (match-end 0))) + + (cond + ((looking-at "\\(.*@.*\\)") + (setq message-id (match-string 1))) + ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)") + (setq group (match-string 1) + articles (split-string (match-string 2) "-"))) + ((looking-at "\\([^/]+\\)/?") + (setq group (match-string 1))) + (t + (error "Unknown news URL syntax")))) + (list scheme server group message-id articles))) + +(defun gnus-button-handle-news (url) + "Fetch a news URL." + (destructuring-bind (scheme server group message-id articles) + (gnus-parse-news-url url) + (cond + (message-id + (save-excursion + (set-buffer gnus-summary-buffer) + (if server + (let ((gnus-refer-article-method (list (list 'nntp server)))) + (gnus-summary-refer-article message-id)) + (gnus-summary-refer-article message-id)))) + (group + (gnus-button-fetch-group url))))) + +(defun gnus-button-handle-man (url) + "Fetch a man page." + (funcall gnus-button-man-handler url)) + +(defun gnus-button-handle-info-url (url) + "Fetch an info URL." + (setq url (mm-subst-char-in-string ?+ ?\ url)) + (cond + ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url) + (gnus-info-find-node + (concat "(" (or (gnus-url-unhex-string (match-string 1 url)) + "Gnus") + ")" (gnus-url-unhex-string (match-string 2 url))))) + ((string-match "([^)\"]+)[^\"]+" url) + (setq url + (gnus-replace-in-string + (gnus-replace-in-string url "[\n\t ]+" " ") "\"" "")) + (gnus-info-find-node url)) + (t (error "Can't parse %s" url)))) + +(defun gnus-button-handle-info-url-gnome (url) + "Fetch GNOME style info URL." + (setq url (mm-subst-char-in-string ?_ ?\ url)) + (if (string-match "\\([^#]+\\)#?\\(.*\\)" url) + (gnus-info-find-node + (concat "(" + (gnus-url-unhex-string + (match-string 1 url)) + ")" + (or (gnus-url-unhex-string + (match-string 2 url)) + "Top"))) + (error "Can't parse %s" url))) + +(defun gnus-button-handle-info-url-kde (url) + "Fetch KDE style info URL." + (gnus-info-find-node (gnus-url-unhex-string url))) + +(defun gnus-button-handle-info-keystrokes (url) + "Call `info' when pushing the corresponding URL button." + ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'. + (info) + (Info-directory) + (Info-menu url)) + (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." (save-excursion @@ -4632,8 +6598,10 @@ (if (not (string-match "[:/]" address)) ;; This is just a simple group url. (gnus-group-read-ephemeral-group address gnus-select-method) - (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$" - address)) + (if (not + (string-match + "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?" + address)) (error "Can't parse %s" address) (gnus-group-read-ephemeral-group (match-string 4 address) @@ -4641,89 +6609,56 @@ (nntp-address ,(match-string 1 address)) (nntp-port-number ,(if (match-end 3) (match-string 3 address) - "nntp"))))))) + "nntp"))) + nil nil nil + (and (match-end 6) (list (string-to-int (match-string 6 address)))))))) (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) (setq pairs (split-string query "&")) (while pairs (setq cur (car pairs) - pairs (cdr pairs)) + pairs (cdr pairs)) (if (not (string-match "=" cur)) - nil ; Grace - (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) - val (gnus-url-unhex-string (substring cur (match-end 0) nil))) - (if downcase - (setq key (downcase key))) - (setq cur (assoc key retval)) - (if cur - (setcdr cur (cons val (cdr cur))) - (setq retval (cons (list key val) retval))))) + nil ; Grace + (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) + val (gnus-url-unhex-string (substring cur (match-end 0) nil) t)) + (if downcase + (setq key (downcase key))) + (setq cur (assoc key retval)) + (if cur + (setcdr cur (cons val (cdr cur))) + (setq retval (cons (list key val) retval))))) retval)) -(defun gnus-url-unhex (x) - (if (> x ?9) - (if (>= x ?a) - (+ 10 (- x ?a)) - (+ 10 (- x ?A))) - (- x ?0))) - -(defun gnus-url-unhex-string (str &optional allow-newlines) - "Remove %XXX embedded spaces, etc in a url. -If optional second argument ALLOW-NEWLINES is non-nil, then allow the -decoding of carriage returns and line feeds in the string, which is normally -forbidden in URL encoding." - (setq str (or str "")) - (let ((tmp "") - (case-fold-search t)) - (while (string-match "%[0-9a-f][0-9a-f]" str) - (let* ((start (match-beginning 0)) - (ch1 (gnus-url-unhex (elt str (+ start 1)))) - (code (+ (* 16 ch1) - (gnus-url-unhex (elt str (+ start 2)))))) - (setq tmp (concat - tmp (substring str 0 start) - (cond - (allow-newlines - (char-to-string code)) - ((or (= code ?\n) (= code ?\r)) - " ") - (t (char-to-string code)))) - str (substring str (match-end 0))))) - (setq tmp (concat tmp str)) - tmp)) - (defun gnus-url-mailto (url) ;; Send mail to someone (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) (let (to args subject func) - (if (string-match (regexp-quote "?") url) - (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) - args (gnus-url-parse-query-string - (substring url (match-end 0) nil) t)) - (setq to (gnus-url-unhex-string url))) - (setq args (cons (list "to" to) args) - subject (cdr-safe (assoc "subject" args))) - (message-mail) + (setq args (gnus-url-parse-query-string + (if (string-match "^\\?" url) + (substring url 1) + (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) + (concat "to=" (match-string 1 url) "&" + (match-string 2 url)) + (concat "to=" url))) + t) + subject (cdr-safe (assoc "subject" args))) + (gnus-msg-mail) (while args (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) - (insert (mapconcat 'identity (cdar args) ", ")) + (funcall func) + (message-position-on-field (caar args))) + (insert (gnus-replace-in-string + (mapconcat 'identity (reverse (cdar args)) ", ") + "\r\n" "\n" t)) (setq args (cdr args))) (if subject - (message-goto-body) + (message-goto-body) (message-goto-subject)))) -(defun gnus-button-mailto (address) - "Mail to ADDRESS." - (set-buffer (gnus-copy-article-buffer)) - (message-reply address)) - -(defalias 'gnus-button-reply 'message-reply) - (defun gnus-button-embedded-url (address) "Activate ADDRESS with `browse-url'." (browse-url (gnus-strip-whitespace address))) @@ -4733,56 +6668,87 @@ (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") -(defvar gnus-prev-page-map nil) -(unless gnus-prev-page-map - (setq gnus-prev-page-map (make-sparse-keymap)) - (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) - (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) +(defvar gnus-prev-page-map + (let ((map (make-sparse-keymap))) + (unless (>= emacs-major-version 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-button-prev-page) + (define-key map "\r" 'gnus-button-prev-page) + map)) (defun gnus-insert-prev-page-button () - (let ((inhibit-read-only t)) + (let ((b (point)) + (buffer-read-only nil)) (gnus-eval-format gnus-prev-page-line-format nil - `(gnus-prev t local-map ,gnus-prev-page-map - gnus-callback gnus-article-button-prev-page - article-type annotation)))) - -(defvar gnus-next-page-map nil) -(unless gnus-next-page-map - (setq gnus-next-page-map (make-keymap)) - (suppress-keymap gnus-prev-page-map) - (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) - (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) - -(defun gnus-button-next-page () + `(,@(gnus-local-map-property gnus-prev-page-map) + gnus-prev t + gnus-callback gnus-article-button-prev-page + article-type annotation)) + (widget-convert-button + 'link b (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point)) + :action 'gnus-button-prev-page + :button-keymap gnus-prev-page-map))) + +(defvar gnus-prev-page-map + (let ((map (make-sparse-keymap))) + (unless (>= emacs-major-version 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-button-prev-page) + (define-key map "\r" 'gnus-button-prev-page) + map)) + +(defvar gnus-next-page-map + (let ((map (make-sparse-keymap))) + (unless (>= emacs-major-version 21) + ;; XEmacs doesn't care. + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-button-next-page) + (define-key map "\r" 'gnus-button-next-page) + map)) + +(defun gnus-button-next-page (&optional args more-args) "Go to the next page." (interactive) (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-next-page) (select-window win))) -(defun gnus-button-prev-page () +(defun gnus-button-prev-page (&optional args more-args) "Go to the prev page." (interactive) (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-prev-page) (select-window win))) (defun gnus-insert-next-page-button () - (let ((inhibit-read-only t)) + (let ((b (point)) + (buffer-read-only nil)) (gnus-eval-format gnus-next-page-line-format nil - `(gnus-next - t local-map ,gnus-next-page-map - gnus-callback gnus-article-button-next-page - article-type annotation)))) + `(,@(gnus-local-map-property gnus-next-page-map) + gnus-next t + gnus-callback gnus-article-button-next-page + article-type annotation)) + (widget-convert-button + 'link b (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point)) + :action 'gnus-button-next-page + :button-keymap gnus-next-page-map))) (defun gnus-article-button-next-page (arg) "Go to the next page." (interactive "P") (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-next-page) (select-window win))) @@ -4790,7 +6756,7 @@ "Go to the prev page." (interactive "P") (let ((win (selected-window))) - (select-window (get-buffer-window gnus-article-buffer t)) + (select-window (gnus-get-buffer-window gnus-article-buffer t)) (gnus-article-prev-page) (select-window win))) @@ -4799,8 +6765,8 @@ "List of methods used to decode headers. This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item -is FUNCTION, FUNCTION will be applied to all newsgroups. If item is a -\(REGEXP . FUNCTION), FUNCTION will be only applied to these newsgroups +is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a +\(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups whose names match REGEXP. For example: @@ -4850,11 +6816,11 @@ (highlightp (gnus-visual-p 'article-highlight 'highlight)) val elem) (gnus-run-hooks 'gnus-part-display-hook) - (while (setq elem (pop alist)) + (dolist (elem alist) (setq val (save-excursion - (if (gnus-buffer-live-p gnus-summary-buffer) - (set-buffer gnus-summary-buffer)) + (when (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-summary-buffer)) (symbol-value (car elem)))) (when (and (or (consp val) treated-type) @@ -4876,6 +6842,8 @@ (cond ((null val) nil) + (condition + (eq condition val)) ((and (listp val) (stringp (car val))) (apply 'gnus-or (mapcar `(lambda (s) @@ -4894,8 +6862,6 @@ (equal (car val) type)) (t (error "%S is not a valid predicate" pred))))) - (condition - (eq condition val)) ((eq val t) t) ((eq val 'head) @@ -4907,6 +6873,251 @@ (t (error "%S is not a valid value" val)))) +(defun gnus-article-encrypt-body (protocol &optional n) + "Encrypt the article body." + (interactive + (list + (or gnus-article-encrypt-protocol + (completing-read "Encrypt protocol: " + gnus-article-encrypt-protocol-alist + nil t)) + current-prefix-arg)) + (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) + (unless func + (error (format "Can't find the encrypt protocol %s" protocol))) + (if (member gnus-newsgroup-name '("nndraft:delayed" + "nndraft:drafts" + "nndraft:queue")) + (error "Can't encrypt the article in group %s" + gnus-newsgroup-name)) + (gnus-summary-iterate n + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) + (summary-buffer gnus-summary-buffer) + references point) + (gnus-set-global-variables) + (when (gnus-group-read-only-p) + (error "The current newsgroup does not support article encrypt")) + (gnus-summary-show-article t) + (setq references + (or (mail-header-references gnus-current-headers) "")) + (set-buffer gnus-article-buffer) + (let* ((buffer-read-only nil) + (headers + (mapcar (lambda (field) + (and (save-restriction + (message-narrow-to-head) + (goto-char (point-min)) + (search-forward field nil t)) + (prog2 + (message-narrow-to-field) + (buffer-string) + (delete-region (point-min) (point-max)) + (widen)))) + '("Content-Type:" "Content-Transfer-Encoding:" + "Content-Disposition:")))) + (message-narrow-to-head) + (message-remove-header "MIME-Version") + (goto-char (point-max)) + (setq point (point)) + (insert (apply 'concat headers)) + (widen) + (narrow-to-region point (point-max)) + (let ((message-options message-options)) + (message-options-set 'message-sender user-mail-address) + (message-options-set 'message-recipients user-mail-address) + (message-options-set 'message-sign-encrypt 'not) + (funcall func)) + (goto-char (point-min)) + (insert "MIME-Version: 1.0\n") + (widen) + (gnus-summary-edit-article-done + references nil summary-buffer t)) + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + (save-excursion + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current)))))))) + +(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n" + "The following specs can be used: +%t The security MIME type +%i Additional info +%d Details +%D Details if button is pressed") + +(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n" + "The following specs can be used: +%t The security MIME type +%i Additional info +%d Details +%D Details if button is pressed") + +(defvar gnus-mime-security-button-line-format-alist + '((?t gnus-tmp-type ?s) + (?i gnus-tmp-info ?s) + (?d gnus-tmp-details ?s) + (?D gnus-tmp-pressed-details ?s))) + +(defvar gnus-mime-security-button-map + (let ((map (make-sparse-keymap))) + (unless (>= (string-to-number emacs-version) 21) + (set-keymap-parent map gnus-article-mode-map)) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map "\r" 'gnus-article-press-button) + map)) + +(defvar gnus-mime-security-details-buffer nil) + +(defvar gnus-mime-security-button-pressed nil) + +(defvar gnus-mime-security-show-details-inline t + "If non-nil, show details in the article buffer.") + +(defun gnus-mime-security-verify-or-decrypt (handle) + (mm-remove-parts (cdr handle)) + (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region)) + point buffer-read-only) + (if region + (goto-char (car region))) + (save-restriction + (narrow-to-region (point) (point)) + (with-current-buffer (mm-handle-multipart-original-buffer handle) + (let* ((mm-verify-option 'known) + (mm-decrypt-option 'known) + (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) + (unless (eq nparts (cdr handle)) + (mm-destroy-parts (cdr handle)) + (setcdr handle nparts)))) + (setq point (point)) + (gnus-mime-display-security handle) + (goto-char (point-max))) + (when region + (delete-region (point) (cdr region)) + (set-marker (car region) nil) + (set-marker (cdr region) nil)) + (goto-char point))) + +(defun gnus-mime-security-show-details (handle) + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (if (not details) + (gnus-message 5 "No details.") + (if gnus-mime-security-show-details-inline + (let ((gnus-mime-security-button-pressed + (not (get-text-property (point) 'gnus-mime-details))) + (gnus-mime-security-button-line-format + (get-text-property (point) 'gnus-line-format)) + buffer-read-only) + (forward-char -1) + (while (eq (get-text-property (point) 'gnus-line-format) + gnus-mime-security-button-line-format) + (forward-char -1)) + (forward-char) + (save-restriction + (narrow-to-region (point) (point)) + (gnus-insert-mime-security-button handle)) + (delete-region (point) + (or (text-property-not-all + (point) (point-max) + 'gnus-line-format + gnus-mime-security-button-line-format) + (point-max)))) + ;; Not inlined. + (if (gnus-buffer-live-p gnus-mime-security-details-buffer) + (with-current-buffer gnus-mime-security-details-buffer + (erase-buffer) + t) + (setq gnus-mime-security-details-buffer + (gnus-get-buffer-create "*MIME Security Details*"))) + (with-current-buffer gnus-mime-security-details-buffer + (insert details) + (goto-char (point-min))) + (pop-to-buffer gnus-mime-security-details-buffer))))) + +(defun gnus-mime-security-press-button (handle) + (save-excursion + (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (gnus-mime-security-show-details handle) + (gnus-mime-security-verify-or-decrypt handle)))) + +(defun gnus-insert-mime-security-button (handle &optional displayed) + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) + (gnus-tmp-type + (concat + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted") + " Part")) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + "Undecided")) + (gnus-tmp-details + (mm-handle-multipart-ctl-parameter handle 'gnus-details)) + gnus-tmp-pressed-details + b e) + (setq gnus-tmp-details + (if gnus-tmp-details + (concat "\n" gnus-tmp-details) + "")) + (setq gnus-tmp-pressed-details + (if gnus-mime-security-button-pressed gnus-tmp-details "")) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (gnus-eval-format + gnus-mime-security-button-line-format + gnus-mime-security-button-line-format-alist + `(,@(gnus-local-map-property gnus-mime-security-button-map) + gnus-callback gnus-mime-security-press-button + gnus-line-format ,gnus-mime-security-button-line-format + gnus-mime-details ,gnus-mime-security-button-pressed + article-type annotation + gnus-data ,handle)) + (setq e (if (bolp) + ;; Exclude a newline. + (1- (point)) + (point))) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-security-button-map + :help-echo + (lambda (widget/window &optional overlay pos) + ;; Needed to properly clear the message due to a bug in + ;; wid-edit (XEmacs only). + (when (boundp 'help-echo-owns-message) + (setq help-echo-owns-message t)) + (format + "%S: show detail" + (aref gnus-mouse-2 0)))))) + +(defun gnus-mime-display-security (handle) + (save-restriction + (narrow-to-region (point) (point)) + (unless (gnus-unbuttonized-mime-type-p (car handle)) + (gnus-insert-mime-security-button handle)) + (gnus-mime-display-mixed (cdr handle)) + (unless (bolp) + (insert "\n")) + (unless (gnus-unbuttonized-mime-type-p (car handle)) + (let ((gnus-mime-security-button-line-format + gnus-mime-security-button-end-line-format)) + (gnus-insert-mime-security-button handle))) + (mm-set-handle-multipart-parameter + handle 'gnus-region + (cons (set-marker (make-marker) (point-min)) + (set-marker (make-marker) (point-max)))))) + (gnus-ems-redefine) (provide 'gnus-art)
--- a/lisp/gnus/gnus-async.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-async.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; gnus-async.el --- asynchronous support for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -35,12 +36,6 @@ "Support for asynchronous operations." :group 'gnus) -(defcustom gnus-asynchronous nil - "*If nil, inhibit all Gnus asynchronicity. -If non-nil, let the other asynch variables be heeded." - :group 'gnus-asynchronous - :type 'boolean) - (defcustom gnus-use-article-prefetch 30 "*If non-nil, prefetch articles in groups that allow this. If a number, prefetch only that many articles forward; @@ -50,6 +45,12 @@ (const :tag "all" t) (integer :tag "some" 0))) +(defcustom gnus-asynchronous nil + "*If nil, inhibit all Gnus asynchronicity. +If non-nil, let the other asynch variables be heeded." + :group 'gnus-asynchronous + :type 'boolean) + (defcustom gnus-prefetched-article-deletion-strategy '(read exit) "List of symbols that say when to remove articles from the prefetch buffer. Possible values in this list are `read', which means that @@ -276,15 +277,16 @@ ;; needs to be done in nntp.el. (while (eq article gnus-async-current-prefetch-article) (incf tries) - (when (nntp-accept-process-output proc 1) + (when (nntp-accept-process-output proc) (setq tries 0)) - (when (and (not nntp-have-messaged) (eq 3 tries)) + (when (and (not nntp-have-messaged) + (= tries 3)) (gnus-message 5 "Waiting for async article...") (setq nntp-have-messaged t))) (quit ;; if the user interrupted on a slow/hung connection, ;; do something friendly. - (when (< 3 tries) + (when (> tries 3) (setq gnus-async-current-prefetch-article nil)) (signal 'quit nil))) (when nntp-have-messaged
--- a/lisp/gnus/gnus-audio.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-audio.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ -;;; gnus-audio.el --- sound effects for Gnus -;; Copyright (C) 1996, 2000 Free Software Foundation +;;; gnus-audio.el --- Sound effects for Gnus +;; Copyright (C) 1996, 2000, 2003 Free Software Foundation ;; Author: Steven L. Baur <steve@miranova.com> ;; Keywords: news, mail, multimedia @@ -47,15 +47,15 @@ :type '(choice directory (const nil)) :group 'gnus-audio) -(defcustom gnus-audio-au-player "/usr/bin/showaudio" +(defcustom gnus-audio-au-player (executable-find "play") "Executable program for playing sun AU format sound files." :group 'gnus-audio - :type 'string) + :type '(choice file (const nil))) -(defcustom gnus-audio-wav-player "/usr/local/bin/play" +(defcustom gnus-audio-wav-player (executable-find "play") "Executable program for playing WAV files." :group 'gnus-audio - :type 'string) + :type '(choice file (const nil))) ;;; The following isn't implemented yet. Wait for Millennium Gnus. ;;(defvar gnus-audio-effects-enabled t @@ -93,7 +93,7 @@ ;;;###autoload (defun gnus-audio-play (file) "Play a sound FILE through the speaker." - (interactive) + (interactive "fSound file name: ") (let ((sound-file (if (file-exists-p file) file (expand-file-name file gnus-audio-directory))))
--- a/lisp/gnus/gnus-bcklg.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-bcklg.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; gnus-bcklg.el --- backlog functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -55,36 +56,39 @@ (defun gnus-backlog-shutdown () "Clear all backlog variables and buffers." + (interactive) (when (get-buffer gnus-backlog-buffer) - (kill-buffer gnus-backlog-buffer)) + (gnus-kill-buffer gnus-backlog-buffer)) (setq gnus-backlog-hashtb nil gnus-backlog-articles nil)) (defun gnus-backlog-enter-article (group number buffer) - (gnus-backlog-setup) - (let ((ident (intern (concat group ":" (int-to-string number)) - gnus-backlog-hashtb)) - b) - (if (memq ident gnus-backlog-articles) - () ; It's already kept. + (when (and (numberp number) + (not (string-match "^nnvirtual" group))) + (gnus-backlog-setup) + (let ((ident (intern (concat group ":" (int-to-string number)) + gnus-backlog-hashtb)) + b) + (if (memq ident gnus-backlog-articles) + () ; It's already kept. ;; Remove the oldest article, if necessary. - (and (numberp gnus-keep-backlog) - (>= (length gnus-backlog-articles) gnus-keep-backlog) + (and (numberp gnus-keep-backlog) + (>= (length gnus-backlog-articles) gnus-keep-backlog) (gnus-backlog-remove-oldest-article)) - (push ident gnus-backlog-articles) - ;; Insert the new article. - (save-excursion - (set-buffer (gnus-backlog-buffer)) - (let (buffer-read-only) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (setq b (point)) - (insert-buffer-substring buffer) - ;; Tag the beginning of the article with the ident. - (if (> (point-max) b) + (push ident gnus-backlog-articles) + ;; Insert the new article. + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (let (buffer-read-only) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (insert-buffer-substring buffer) + ;; Tag the beginning of the article with the ident. + (if (> (point-max) b) (gnus-put-text-property b (1+ b) 'gnus-backlog ident) - (gnus-error 3 "Article %d is blank" number))))))) + (gnus-error 3 "Article %d is blank" number)))))))) (defun gnus-backlog-remove-oldest-article () (save-excursion @@ -127,7 +131,8 @@ (setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) (defun gnus-backlog-request-article (group number &optional buffer) - (when (numberp number) + (when (and (numberp number) + (not (string-match "^nnvirtual" group))) (gnus-backlog-setup) (let ((ident (intern (concat group ":" (int-to-string number)) gnus-backlog-hashtb))
--- a/lisp/gnus/gnus-cache.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-cache.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-cache.el --- cache interface for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -33,6 +33,8 @@ (require 'gnus-range) (require 'gnus-start) (eval-when-compile + (if (not (fboundp 'gnus-agent-load-alist)) + (defun gnus-agent-load-alist (group))) (require 'gnus-sum)) (defcustom gnus-cache-active-file @@ -160,11 +162,7 @@ (when (and number (> number 0) ; Reffed article. (or force - (and (or (not gnus-cacheable-groups) - (string-match gnus-cacheable-groups group)) - (or (not gnus-uncacheable-groups) - (not (string-match - gnus-uncacheable-groups group))) + (and (gnus-cache-fully-p group) (gnus-cache-member-of-class gnus-cache-enter-articles ticked dormant unread))) (not (file-exists-p (setq file (gnus-cache-file-name @@ -183,7 +181,8 @@ (when (> (buffer-size) 0) (let ((coding-system-for-write gnus-cache-coding-system)) (gnus-write-buffer file)) - (setq headers (nnheader-parse-head t)) + (nnheader-remove-body) + (setq headers (nnheader-parse-naked-head)) (mail-header-set-number headers number) (gnus-cache-change-buffer group) (set-buffer (cdr gnus-cache-buffer)) @@ -209,8 +208,9 @@ (nnheader-insert-nov headers) ;; Update the active info. (set-buffer gnus-summary-buffer) - (gnus-cache-update-active group number) - (push article gnus-newsgroup-cached) + (gnus-cache-possibly-update-active group (cons number number)) + (setq gnus-newsgroup-cached + (gnus-add-to-sorted-list gnus-newsgroup-cached article)) (gnus-summary-update-secondary-mark article)) t)))))) @@ -235,7 +235,7 @@ (defun gnus-cache-possibly-remove-articles-1 () "Possibly remove some of the removable articles." - (unless (eq gnus-use-cache 'passive) + (when (gnus-cache-fully-p gnus-newsgroup-name) (let ((articles gnus-cache-removable-articles) (cache-articles gnus-newsgroup-cached) article) @@ -283,9 +283,7 @@ ;; the normal way. (let ((gnus-use-cache nil)) (gnus-retrieve-headers articles group fetch-old)) - (let ((uncached-articles (gnus-sorted-intersection - (gnus-sorted-complement articles cached) - articles)) + (let ((uncached-articles (gnus-sorted-difference articles cached)) (cache-file (gnus-cache-file-name group ".overview")) type) ;; We first retrieve all the headers that we don't have in @@ -335,14 +333,16 @@ (when (gnus-cache-possibly-enter-article gnus-newsgroup-name article nil nil nil t) + (setq gnus-newsgroup-undownloaded (delq article gnus-newsgroup-undownloaded)) (push article out)) (gnus-message 2 "Can't cache article %d" article)) + (gnus-summary-update-download-mark article) (gnus-summary-update-secondary-mark article)) (gnus-summary-next-subject 1) (gnus-summary-position-point) (nreverse out))) -(defun gnus-cache-remove-article (n) +(defun gnus-cache-remove-article (&optional n) "Remove the next N articles from the cache. If not given a prefix, use the process marked articles instead. Returns the list of articles removed." @@ -354,7 +354,14 @@ (setq article (pop articles)) (gnus-summary-remove-process-mark article) (when (gnus-cache-possibly-remove-article article nil nil nil t) + (when gnus-newsgroup-agentized + (let ((alist (gnus-agent-load-alist gnus-newsgroup-name))) + (unless (cdr (assoc article alist)) + (setq gnus-newsgroup-undownloaded + (gnus-add-to-sorted-list + gnus-newsgroup-undownloaded article))))) (push article out)) + (gnus-summary-update-download-mark article) (gnus-summary-update-secondary-mark article)) (gnus-summary-next-subject 1) (gnus-summary-position-point) @@ -367,15 +374,20 @@ (defun gnus-summary-insert-cached-articles () "Insert all the articles cached for this group into the current buffer." (interactive) - (let ((cached (sort (copy-sequence gnus-newsgroup-cached) '>)) - (gnus-verbose (max 6 gnus-verbose))) - (unless cached - (gnus-message 3 "No cached articles for this group")) - (while cached - (gnus-summary-goto-subject (pop cached) t)))) + (let ((gnus-verbose (max 6 gnus-verbose))) + (if (not gnus-newsgroup-cached) + (gnus-message 3 "No cached articles for this group") + (gnus-summary-goto-subjects gnus-newsgroup-cached)))) -(defalias 'gnus-summary-limit-include-cached - 'gnus-summary-insert-cached-articles) +(defun gnus-summary-limit-include-cached () + "Limit the summary buffer to articles that are cached." + (interactive) + (let ((gnus-verbose (max 6 gnus-verbose))) + (if gnus-newsgroup-cached + (progn + (gnus-summary-limit gnus-newsgroup-cached) + (gnus-summary-position-point)) + (gnus-message 3 "No cached articles for this group")))) ;;; Internal functions. @@ -422,7 +434,8 @@ ?. ?_))) ;; Translate the first colon into a slash. (when (string-match ":" group) - (aset group (match-beginning 0) ?/)) + (setq group (concat (substring group 0 (match-beginning 0)) + "/" (substring group (match-end 0))))) (nnheader-replace-chars-in-string group ?. ?/))) t) gnus-cache-directory)))) @@ -460,10 +473,11 @@ (when (or (looking-at (concat (int-to-string number) "\t")) (search-forward (concat "\n" (int-to-string number) "\t") (point-max) t)) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))))) - (setq gnus-newsgroup-cached - (delq article gnus-newsgroup-cached)) + (gnus-delete-line))) + (unless (setq gnus-newsgroup-cached + (delq article gnus-newsgroup-cached)) + (gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb) + (setq gnus-cache-active-altered t)) (gnus-summary-update-secondary-mark article) t))) @@ -477,9 +491,13 @@ (directory-files dir nil "^[0-9]+$" t)) '<)) ;; Update the cache active file, just to synch more. - (when articles - (gnus-cache-update-active group (car articles) t) - (gnus-cache-update-active group (car (last articles)))) + (if articles + (progn + (gnus-cache-update-active group (car articles) t) + (gnus-cache-update-active group (car (last articles)))) + (when (gnus-gethash group gnus-cache-active-hashtb) + (gnus-sethash group nil gnus-cache-active-hashtb) + (setq gnus-cache-active-altered t))) articles))) (defun gnus-cache-braid-nov (group cached &optional file) @@ -503,13 +521,13 @@ (< (read (current-buffer)) (car cached))) (forward-line 1)) (beginning-of-line) - (save-excursion - (set-buffer cache-buf) - (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") - nil t) - (setq beg (progn (beginning-of-line) (point)) - end (progn (end-of-line) (point))) - (setq beg nil))) + (set-buffer cache-buf) + (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") + nil t) + (setq beg (gnus-point-at-bol) + end (progn (end-of-line) (point))) + (setq beg nil)) + (set-buffer nntp-server-buffer) (when beg (insert-buffer-substring cache-buf beg end) (insert "\n")) @@ -531,20 +549,20 @@ (car cached))) (search-forward "\n.\n" nil 'move)) (beginning-of-line) - (save-excursion - (set-buffer cache-buf) - (erase-buffer) - (let ((coding-system-for-read - gnus-cache-coding-system)) - (insert-file-contents (gnus-cache-file-name group (car cached)))) - (goto-char (point-min)) - (insert "220 ") - (princ (car cached) (current-buffer)) - (insert " Article retrieved.\n") - (search-forward "\n\n" nil 'move) - (delete-region (point) (point-max)) - (forward-char -1) - (insert ".")) + (set-buffer cache-buf) + (erase-buffer) + (let ((coding-system-for-read + gnus-cache-coding-system)) + (insert-file-contents (gnus-cache-file-name group (car cached)))) + (goto-char (point-min)) + (insert "220 ") + (princ (car cached) (current-buffer)) + (insert " Article retrieved.\n") + (search-forward "\n\n" nil 'move) + (delete-region (point) (point-max)) + (forward-char -1) + (insert ".") + (set-buffer nntp-server-buffer) (insert-buffer-substring cache-buf) (setq cached (cdr cached))) (kill-buffer cache-buf))) @@ -604,6 +622,24 @@ ;; Mark the active hashtb as unaltered. (setq gnus-cache-active-altered nil))) +(defun gnus-cache-possibly-update-active (group active) + "Update active info bounds of GROUP with ACTIVE if necessary. +The update is performed if ACTIVE contains a higher or lower bound +than the current." + (let ((lower t) (higher t)) + (if gnus-cache-active-hashtb + (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) + (when cache-active + (unless (< (car active) (car cache-active)) + (setq lower nil)) + (unless (> (cdr active) (cdr cache-active)) + (setq higher nil)))) + (gnus-cache-read-active)) + (when lower + (gnus-cache-update-active group (car active) t)) + (when higher + (gnus-cache-update-active group (cdr active))))) + (defun gnus-cache-update-active (group number &optional low) "Update the upper bound of the active info of GROUP to NUMBER. If LOW, update the lower bound instead." @@ -641,7 +677,7 @@ (gnus-message 5 "Generating the cache active file...") (setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) (when (string-match "^\\(nn[^_]+\\)_" group) - (setq group (replace-match "\\1:" t t group))) + (setq group (replace-match "\\1:" t nil group))) ;; Separate articles from all other files and directories. (while files (if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) @@ -670,13 +706,27 @@ (interactive (list gnus-cache-directory)) (gnus-cache-close) (let ((nnml-generate-active-function 'identity)) - (nnml-generate-nov-databases-1 dir))) + (nnml-generate-nov-databases-1 dir)) + (gnus-cache-open)) (defun gnus-cache-move-cache (dir) "Move the cache tree to somewhere else." (interactive "FMove the cache tree to: ") (rename-file gnus-cache-directory dir)) +(defun gnus-cache-fully-p (&optional group) + "Returns non-nil if the cache should be fully used. +If GROUP is non-nil, also cater to `gnus-cacheable-groups' and +`gnus-uncacheable-groups'." + (and gnus-use-cache + (not (eq gnus-use-cache 'passive)) + (if (null group) + t + (and (or (not gnus-cacheable-groups) + (string-match gnus-cacheable-groups group)) + (or (not gnus-uncacheable-groups) + (not (string-match gnus-uncacheable-groups group))))))) + (provide 'gnus-cache) ;;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a
--- a/lisp/gnus/gnus-cite.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-cite.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ -;;; gnus-cite.el --- parse citations in articles for Gnus -*- coding: iso-latin-1 -*- +;;; gnus-cite.el --- parse citations in articles for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Per Abhiddenware @@ -29,8 +29,9 @@ (eval-when-compile (require 'cl)) (require 'gnus) +(require 'gnus-range) (require 'gnus-art) -(require 'gnus-range) +(require 'message) ; for message-cite-prefix-regexp ;;; Customization: @@ -40,19 +41,6 @@ :link '(custom-manual "(gnus)Article Highlighting") :group 'gnus-article) -(defcustom gnus-cite-reply-regexp - "^\\(Subject: Re\\|In-Reply-To\\|References\\):" - "*If headers match this regexp it is reasonable to believe that -article has citations." - :group 'gnus-cite - :type 'string) - -(defcustom gnus-cite-always-check nil - "Check article always for citations. Set it t to check all articles." - :group 'gnus-cite - :type '(choice (const :tag "no" nil) - (const :tag "yes" t))) - (defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n" "Format of opened cited text buttons." :group 'gnus-cite @@ -79,20 +67,13 @@ :type '(choice (const :tag "all" nil) integer)) -(defcustom gnus-cite-prefix-regexp - ;; The Latin-1 angle quote looks pretty dubious. -- fx - "^[]>»|:}+ ]*[]>»|:}+]\\(.*>»\\)?\\|^.*>" - "*Regexp matching the longest possible citation prefix on a line." - :group 'gnus-cite - :type 'regexp) - (defcustom gnus-cite-max-prefix 20 "Maximum possible length for a citation prefix." :group 'gnus-cite :type 'integer) (defcustom gnus-supercite-regexp - (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" + (concat "^\\(" message-cite-prefix-regexp "\\)? *" ">>>>> +\"\\([^\"\n]+\\)\" +==") "*Regexp matching normal Supercite attribution lines. The first grouping must match prefixes added by other packages." @@ -110,21 +91,44 @@ :group 'gnus-cite :type 'integer) +;; Some Microsoft products put in a citation that extends to the +;; remainder of the message: +;; +;; -----Original Message----- +;; From: ... +;; To: ... +;; Sent: ... [date, in non-RFC-2822 format] +;; Subject: ... +;; +;; Cited message, with no prefixes +;; +;; The four headers are always the same. But note they are prone to +;; folding without additional indentation. +;; +;; Others use "----- Original Message -----" instead, and properly quote +;; the body using "> ". This style is handled without special cases. + (defcustom gnus-cite-attribution-prefix - "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|-----Original Message-----" + "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----" "*Regexp matching the beginning of an attribution line." :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-attribution-suffix - "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|-----Original Message-----\\)[ \t]*$" + "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \t]*$" "*Regexp matching the end of an attribution line. The text matching the first grouping will be used as a button." :group 'gnus-cite :type 'regexp) +(defcustom gnus-cite-unsightly-citation-regexp + "^-----Original Message-----\nFrom: \\(.+\n\\)+\n" + "Regexp matching Microsoft-type rest-of-message citations." + :group 'gnus-cite + :type 'regexp) + (defface gnus-cite-attribution-face '((t - (:slant italic))) + (:italic t))) "Face used for attribution lines.") (defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face @@ -140,7 +144,7 @@ (background light)) (:foreground "MidnightBlue")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-2 '((((class color) @@ -150,7 +154,7 @@ (background light)) (:foreground "firebrick")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-3 '((((class color) @@ -160,7 +164,7 @@ (background light)) (:foreground "dark green")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-4 '((((class color) @@ -170,7 +174,7 @@ (background light)) (:foreground "OrangeRed")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-5 '((((class color) @@ -180,7 +184,7 @@ (background light)) (:foreground "dark khaki")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-6 '((((class color) @@ -190,7 +194,7 @@ (background light)) (:foreground "dark violet")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-7 '((((class color) @@ -200,7 +204,7 @@ (background light)) (:foreground "SteelBlue4")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-8 '((((class color) @@ -210,7 +214,7 @@ (background light)) (:foreground "magenta")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-9 '((((class color) @@ -220,7 +224,7 @@ (background light)) (:foreground "violet")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-10 '((((class color) @@ -230,7 +234,7 @@ (background light)) (:foreground "medium purple")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defface gnus-cite-face-11 '((((class color) @@ -240,7 +244,7 @@ (background light)) (:foreground "turquoise")) (t - (:slant italic))) + (:italic t))) "Citation face.") (defcustom gnus-cite-face-list @@ -270,6 +274,17 @@ :group 'gnus-cite :type 'boolean) +;; This has to go here because its default value depends on +;; gnus-cite-face-list. +(defcustom gnus-article-boring-faces (cons 'gnus-signature-face + gnus-cite-face-list) + "List of faces that are not worth reading. +If an article has more pages below the one you are looking at, but +nothing on those pages is a word of at least three letters that is not +in a boring face, then the pages will be skipped." + :type '(repeat face) + :group 'gnus-article-hiding) + ;;; Internal Variables: (defvar gnus-cite-article nil) @@ -317,7 +332,7 @@ corresponding citation merged with `gnus-cite-attribution-face'. Text is considered cited if at least `gnus-cite-minimum-match-count' -lines matches `gnus-cite-prefix-regexp' with the same prefix. +lines matches `message-cite-prefix-regexp' with the same prefix. Lines matching `gnus-cite-attribution-suffix' and perhaps `gnus-cite-attribution-prefix' are considered attribution lines." @@ -358,7 +373,7 @@ (goto-char (point-min)) (forward-line (1- number)) (when (re-search-forward gnus-cite-attribution-suffix - (save-excursion (end-of-line 1) (point)) + (gnus-point-at-eol) t) (gnus-article-add-button (match-beginning 1) (match-end 1) 'gnus-cite-toggle prefix)) @@ -450,7 +465,10 @@ (narrow-to-region (caar marks) (caadr marks)) (let ((adaptive-fill-regexp (concat "^" (regexp-quote (cdar marks)) " *")) - (fill-prefix (cdar marks))) + (fill-prefix + (if (string= (cdar marks) "") "" + (concat (cdar marks) " "))) + use-hard-newlines) (fill-region (point-min) (point-max))) (set-marker (caar marks) nil) (setq marks (cdr marks))) @@ -519,6 +537,7 @@ (setq beg nil) (setq end (point-marker)))))) (when (and beg end) + (gnus-add-wash-type 'cite) ;; We use markers for the end-points to facilitate later ;; wrapping and mangling of text. (setq beg (set-marker (make-marker) beg) @@ -558,14 +577,20 @@ (and (> arg 0) (not hidden)) (and (< arg 0) hidden)) (if hidden - (gnus-remove-text-properties-when - 'article-type 'cite beg end - (cons 'article-type (cons 'cite - gnus-hidden-properties))) + (progn + ;; Can't remove 'cite from g-a-wash-types here because + ;; multiple citations may be hidden -jas + (gnus-remove-text-properties-when + 'article-type 'cite beg end + (cons 'article-type (cons 'cite + gnus-hidden-properties)))) + (gnus-add-wash-type 'cite) (gnus-add-text-properties-when 'article-type nil beg end (cons 'article-type (cons 'cite gnus-hidden-properties)))) + (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article)) (save-excursion (goto-char start) (gnus-delete-line) @@ -594,41 +619,44 @@ variables are ignored. See also the documentation for `gnus-article-highlight-citation'." (interactive (append (gnus-article-hidden-arg) '(force))) - (unless (gnus-article-check-hidden-text 'cite arg) - (save-excursion - (set-buffer gnus-article-buffer) - (gnus-cite-parse-maybe force) - (article-goto-body) - (let ((start (point)) - (atts gnus-cite-attribution-alist) - (buffer-read-only nil) - (inhibit-point-motion-hooks t) - (hidden 0) - total) - (goto-char (point-max)) - (gnus-article-search-signature) - (setq total (count-lines start (point))) - (while atts - (setq hidden (+ hidden (length (cdr (assoc (cdar atts) - gnus-cite-prefix-alist)))) - atts (cdr atts))) - (when (or force - (and (> (* 100 hidden) (* gnus-cite-hide-percentage total)) - (> hidden gnus-cite-hide-absolute))) - (setq atts gnus-cite-attribution-alist) + (with-current-buffer gnus-article-buffer + (gnus-delete-wash-type 'cite) + (unless (gnus-article-check-hidden-text 'cite arg) + (save-excursion + (gnus-cite-parse-maybe force) + (article-goto-body) + (let ((start (point)) + (atts gnus-cite-attribution-alist) + (buffer-read-only nil) + (inhibit-point-motion-hooks t) + (hidden 0) + total) + (goto-char (point-max)) + (gnus-article-search-signature) + (setq total (count-lines start (point))) (while atts - (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) - atts (cdr atts)) - (while total - (setq hidden (car total) - total (cdr total)) - (goto-char (point-min)) - (forward-line (1- hidden)) - (unless (assq hidden gnus-cite-attribution-alist) - (gnus-add-text-properties - (point) (progn (forward-line 1) (point)) - (nconc (list 'article-type 'cite) - gnus-hidden-properties)))))))))) + (setq hidden (+ hidden (length (cdr (assoc (cdar atts) + gnus-cite-prefix-alist)))) + atts (cdr atts))) + (when (or force + (and (> (* 100 hidden) (* gnus-cite-hide-percentage total)) + (> hidden gnus-cite-hide-absolute))) + (gnus-add-wash-type 'cite) + (setq atts gnus-cite-attribution-alist) + (while atts + (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) + atts (cdr atts)) + (while total + (setq hidden (car total) + total (cdr total)) + (goto-char (point-min)) + (forward-line (1- hidden)) + (unless (assq hidden gnus-cite-attribution-alist) + (gnus-add-text-properties + (point) (progn (forward-line 1) (point)) + (nconc (list 'article-type 'cite) + gnus-hidden-properties))))))))) + (gnus-set-mode-line 'article))) (defun gnus-article-hide-citation-in-followups () "Hide cited text in non-root articles." @@ -663,11 +691,13 @@ (defun gnus-cite-delete-overlays () (dolist (overlay gnus-cite-overlay-list) - (when (or (not (gnus-overlay-end overlay)) - (and (>= (gnus-overlay-end overlay) (point-min)) - (<= (gnus-overlay-end overlay) (point-max)))) - (setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list)) - (gnus-delete-overlay overlay)))) + (ignore-errors + (when (or (not (gnus-overlay-end overlay)) + (and (>= (gnus-overlay-end overlay) (point-min)) + (<= (gnus-overlay-end overlay) (point-max)))) + (setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list)) + (ignore-errors + (gnus-delete-overlay overlay)))))) (defun gnus-cite-parse-wrapper () ;; Wrap chopped gnus-cite-parse. @@ -690,23 +720,26 @@ (goto-char (point-max)) (gnus-article-search-signature) (point))) - alist entry start begin end numbers prefix) + (prefix-regexp (concat "^\\(" message-cite-prefix-regexp "\\)")) + alist entry start begin end numbers prefix guess-limit) ;; Get all potential prefixes in `alist'. (while (< (point) max) ;; Each line. (setq begin (point) - end (progn (beginning-of-line 2) (point)) + guess-limit (progn (skip-chars-forward "^> \t\r\n") (point)) + end (gnus-point-at-bol 2) start end) (goto-char begin) ;; Ignore standard Supercite attribution prefix. - (when (looking-at gnus-supercite-regexp) + (when (and (< guess-limit (+ begin gnus-cite-max-prefix)) + (looking-at gnus-supercite-regexp)) (if (match-end 1) (setq end (1+ (match-end 1))) (setq end (1+ begin)))) ;; Ignore very long prefixes. - (when (> end (+ (point) gnus-cite-max-prefix)) - (setq end (+ (point) gnus-cite-max-prefix))) - (while (re-search-forward gnus-cite-prefix-regexp (1- end) t) + (when (> end (+ begin gnus-cite-max-prefix)) + (setq end (+ begin gnus-cite-max-prefix))) + (while (re-search-forward prefix-regexp (1- end) t) ;; Each prefix. (setq end (match-end 0) prefix (buffer-substring begin end)) @@ -718,9 +751,19 @@ (goto-char begin)) (goto-char start) (setq line (1+ line))) + ;; Horrible special case for some Microsoft mailers. + (goto-char (point-min)) + (when (re-search-forward gnus-cite-unsightly-citation-regexp max t) + (setq begin (count-lines (point-min) (point))) + (setq end (count-lines (point-min) max)) + (setq entry nil) + (while (< begin end) + (push begin entry) + (setq begin (1+ begin))) + (push (cons "" entry) alist)) ;; We got all the potential prefixes. Now create ;; `gnus-cite-prefix-alist' containing the oldest prefix for each - ;; line that appears at least gnus-cite-minimum-match-count + ;; line that appears at least `gnus-cite-minimum-match-count' ;; times. First sort them by length. Longer is older. (setq alist (sort alist (lambda (a b) (> (length (car a)) (length (car b)))))) @@ -960,14 +1003,20 @@ (goto-char (point-min)) (forward-line (1- number)) (cond ((get-text-property (point) 'invisible) + ;; Can't remove 'cite from g-a-wash-types here because + ;; multiple citations may be hidden -jas (remove-text-properties (point) (progn (forward-line 1) (point)) gnus-hidden-properties)) ((assq number gnus-cite-attribution-alist)) (t + (gnus-add-wash-type 'cite) (gnus-add-text-properties (point) (progn (forward-line 1) (point)) (nconc (list 'article-type 'cite) - gnus-hidden-properties)))))))) + gnus-hidden-properties)))) + (let ((gnus-article-mime-handle-alist-1 + gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article)))))) (defun gnus-cite-find-prefix (line) ;; Return citation prefix for LINE. @@ -990,6 +1039,17 @@ (while vars (make-local-variable (pop vars))))) +(defun gnus-cited-line-p () + "Say whether the current line is a cited line." + (save-excursion + (beginning-of-line) + (let ((found nil)) + (dolist (prefix (mapcar 'car gnus-cite-prefix-alist)) + (when (string= (buffer-substring (point) (+ (length prefix) (point))) + prefix) + (setq found t))) + found))) + (gnus-ems-redefine) (provide 'gnus-cite)
--- a/lisp/gnus/gnus-cus.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-cus.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,7 @@ ;;; gnus-cus.el --- customization commands for Gnus ;; -;; Copyright (C) 1996,1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Keywords: news @@ -27,15 +28,14 @@ ;;; Code: (require 'wid-edit) +(require 'gnus) +(require 'gnus-agent) (require 'gnus-score) (require 'gnus-topic) +(require 'gnus-art) ;;; Widgets: -;; There should be special validation for this. -(define-widget 'gnus-email-address 'string - "An email address") - (defun gnus-custom-mode () "Major mode for editing Gnus customization buffers. @@ -72,36 +72,7 @@ ;;; Group Customization: (defconst gnus-group-parameters - '((to-address (gnus-email-address :tag "To Address") "\ -This will be used when doing followups and posts. - -This is primarily useful in mail groups that represent closed -mailing lists--mailing lists where it's expected that everybody that -writes to the mailing list is subscribed to it. Since using this -parameter ensures that the mail only goes to the mailing list itself, -it means that members won't receive two copies of your followups. - -Using `to-address' will actually work whether the group is foreign or -not. Let's say there's a group on the server that is called -`fa.4ad-l'. This is a real newsgroup, but the server has gotten the -articles from a mail-to-news gateway. Posting directly to this group -is therefore impossible--you have to send mail to the mailing list -address instead. - -The gnus-group-split mail splitting mechanism will behave as if this -address was listed in gnus-group-split Addresses (see below).") - - (to-list (gnus-email-address :tag "To List") "\ -This address will be used when doing a `a' in the group. - -It is totally ignored when doing a followup--except that if it is -present in a news group, you'll get mail group semantics when doing -`f'. - -The gnus-group-split mail splitting mechanism will behave as if this -address was listed in gnus-group-split Addresses (see below).") - - (extra-aliases (choice + '((extra-aliases (choice :tag "Extra Aliases" (list :tag "List" @@ -168,29 +139,6 @@ `gcc' header (this symbol takes precedence over any default `Gcc' rules as described later).") - (banner (choice :tag "Banner" - :value nil - (const :tag "Remove signature" signature) - (symbol :tag "Item in `gnus-article-banner-alist'" none) - regexp - (const :tag "None" nil)) "\ -If non-nil, specify how to remove `banners' from articles. - -Symbol `signature' means to remove signatures delimited by -`gnus-signature-separator'. Any other symbol is used to look up a -regular expression to match the banner in `gnus-article-banner-alist'. -A string is used as a regular expression to match the banner -directly.") - - (auto-expire (const :tag "Automatic Expire" t) "\ -All articles that are read will be marked as expirable.") - - (total-expire (const :tag "Total Expire" t) "\ -All read articles will be put through the expiry process - -This happens even if they are not marked as expirable. -Use with caution.") - (expiry-wait (choice :tag "Expire Wait" :value never (const never) @@ -205,13 +153,13 @@ `immediate'.") (expiry-target (choice :tag "Expiry Target" - :value delete - (const delete) - (function :format "%v" nnmail-) - string) "\ + :value delete + (const delete) + (function :format "%v" nnmail-) + string) "\ Where expired messages end up. -Overrides `nnmail-expiry-target', which see.") +Overrides `nnmail-expiry-target'.") (score-file (file :tag "Score File") "\ Make the specified file into the current score file. @@ -232,34 +180,31 @@ (display (choice :tag "Display" :value default (const all) - (const default)) "\ + (integer) + (const default) + (sexp :tag "Other")) "\ Which articles to display on entering the group. `all' Display all articles, both read and unread. +`integer' + Display the last NUMBER articles in the group. This is the same as + entering the group with C-u NUMBER. + `default' Display the default visible articles, which normally includes - unread and ticked articles.") + unread and ticked articles. + +`Other' + Display the articles that satisfy the S-expression. The S-expression + should be in an array form.") (comment (string :tag "Comment") "\ An arbitrary comment on the group.") (visible (const :tag "Permanently visible" t) "\ -Always display this group, even when there are no unread articles -in it..") - - (charset (symbol :tag "Charset") "\ -The default charset to use in the group.") - - (ignored-charsets - (choice :tag "Ignored charsets" - :value nil - (repeat (symbol))) "\ -List of charsets that should be ignored. - -When these charsets are used in the \"charset\" parameter, the -default charset will be used instead.") +Always display this group, even when there are no unread articles in it.") (highlight-words (choice :tag "Highlight words" @@ -270,23 +215,23 @@ (symbol :tag "Face" gnus-emphasis-highlight-words)))) "highlight regexps. -See gnus-emphasis-alist.") +See `gnus-emphasis-alist'.") (posting-style (choice :tag "Posting style" :value nil (repeat (list - (choice :tag "Type" + (choice :tag "Type" :value nil (const signature) - (const signature-file) - (const organization) - (const address) - (const name) - (const body)) + (const signature-file) + (const organization) + (const address) + (const name) + (const body)) (string :format "%v")))) "post style. -See gnus-posting-styles.")) +See `gnus-posting-styles'.")) "Alist of valid group or topic parameters. Each entry has the form (NAME TYPE DOC), where NAME is the parameter @@ -295,9 +240,15 @@ (defconst gnus-extra-topic-parameters '((subscribe (regexp :tag "Subscribe") "\ -If `gnus-subscribe-newsgroup-method' is set to +If `gnus-subscribe-newsgroup-method' or +`gnus-subscribe-options-newsgroup-method' is set to `gnus-subscribe-topics', new groups that matches this regexp will -automatically be subscribed to this topic")) +automatically be subscribed to this topic") + (subscribe-level (integer :tag "Subscribe Level" :value 1) "\ +If this topic parameter is set, when new groups are subscribed +automatically under this topic (via the `subscribe' topic parameter) +assign this level to the group, rather than the default level +set in `gnus-level-default-subscribed'")) "Alist of topic parameters that are not also group parameters. Each entry has the form (NAME TYPE DOC), where NAME is the parameter @@ -312,6 +263,72 @@ Each entry has the form (NAME TYPE DOC), where NAME is the parameter itself (a symbol), TYPE is the parameters type (a sexp widget), and DOC is a documentation string for the parameter.") + +(eval-and-compile + (defconst gnus-agent-parameters + '((agent-predicate + (sexp :tag "Selection Predicate" :value false) + "Predicate used to automatically select articles for downloading." + gnus-agent-cat-predicate) + (agent-score + (choice :tag "Score File" :value nil + (const file :tag "Use group's score files") + (repeat (list (string :format "%v" :tag "File name")))) + "Which score files to use when using score to select articles to fetch. + + `nil' + All articles will be scored to zero (0). + + `file' + The group's score files will be used to score the articles. + + `List' + A list of score file names." + gnus-agent-cat-score-file) + (agent-short-article + (integer :tag "Max Length of Short Article" :value "") + "The SHORT predicate will evaluate to true when the article is +shorter than this length." gnus-agent-cat-length-when-short) + (agent-long-article + (integer :tag "Min Length of Long Article" :value "") + "The LONG predicate will evaluate to true when the article is +longer than this length." gnus-agent-cat-length-when-long) + (agent-low-score + (integer :tag "Low Score Limit" :value "") + "The LOW predicate will evaluate to true when the article scores +lower than this limit." gnus-agent-cat-low-score) + (agent-high-score + (integer :tag "High Score Limit" :value "") + "The HIGH predicate will evaluate to true when the article scores +higher than this limit." gnus-agent-cat-high-score) + (agent-days-until-old + (integer :tag "Days Until Old" :value "") + "The OLD predicate will evaluate to true when the fetched article +has been stored locally for at least this many days." + gnus-agent-cat-days-until-old) + (agent-enable-expiration + (radio :tag "Expire in this Group or Topic" :value nil + (const :format "Enable " ENABLE) + (const :format "Disable " DISABLE)) + "\nEnable, or disable, agent expiration in this group or topic." + gnus-agent-cat-enable-expiration) + (agent-enable-undownloaded-faces + (boolean :tag "Enable Agent Faces") + "Have the summary buffer use the agent's undownloaded faces. +These faces, when enabled, act as a warning that an article has not +been fetched into either the agent nor the cache. This is of most use +to users who use the agent as a cache (i.e. they only operate on +articles that have been downloaded). Leave disabled to display normal +article faces even when the article hasn't been downloaded." +gnus-agent-cat-enable-undownloaded-faces)) + "Alist of group parameters that are not also topic parameters. + +Each entry has the form (NAME TYPE DOC ACCESSOR), where NAME is the +parameter itself (a symbol), TYPE is the parameters type (a sexp +widget), DOC is a documentation string for the parameter, and ACCESSOR +is a function (symbol) that extracts the current value from the +category.")) + (defvar gnus-custom-params) (defvar gnus-custom-method) (defvar gnus-custom-group) @@ -326,18 +343,37 @@ :doc ,(nth 2 entry) (const :format "" ,(nth 0 entry)) ,(nth 1 entry))) - (append gnus-group-parameters + (append (reverse gnus-group-parameters-more) + gnus-group-parameters (if group gnus-extra-group-parameters - gnus-extra-topic-parameters))))) + gnus-extra-topic-parameters)))) + (agent (mapcar (lambda (entry) + (let ((type (nth 1 entry)) + vcons) + (if (listp type) + (setq type (copy-sequence type))) + + (setq vcons (cdr (memq :value type))) + + (if (symbolp (car vcons)) + (condition-case nil + (setcar vcons (symbol-value (car vcons))) + (error))) + `(cons :format "%v%h\n" + :doc ,(nth 2 entry) + (const :format "" ,(nth 0 entry)) + ,type))) + (if gnus-agent + gnus-agent-parameters)))) (unless (or group topic) (error "No group on current line")) (when (and group topic) - (error "Both a group and topic on current line")) + (error "Both a group an topic on current line")) (unless (or topic (setq info (gnus-get-info group))) (error "Killed group; can't be edited")) ;; Ready. - (kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) + (gnus-kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) (gnus-custom-mode) (make-local-variable 'gnus-custom-group) @@ -364,24 +400,54 @@ :action 'gnus-group-customize-done) (widget-insert ".\n\n") (make-local-variable 'gnus-custom-params) - (setq gnus-custom-params - (widget-create 'group - :value (if group - (gnus-info-params info) - (gnus-topic-parameters topic)) - `(set :inline t - :greedy t - :tag "Parameters" - :format "%t:\n%h%v" - :doc "\ + + (let ((values (if group + (gnus-info-params info) + (gnus-topic-parameters topic)))) + + ;; The parameters in values may contain duplicates. This is + ;; normally OK as assq returns the first. However, right here + ;; every duplicate ends up being displayed. So, rather than + ;; display them, remove them from the list. + + (let ((tmp (setq values (gnus-copy-sequence values))) + elem) + (while (cdr tmp) + (while (setq elem (assq (caar tmp) (cdr tmp))) + (delq elem tmp)) + (setq tmp (cdr tmp)))) + + (setq gnus-custom-params + (apply 'widget-create 'group + :value values + (delq nil + (list `(set :inline t + :greedy t + :tag "Parameters" + :format "%t:\n%h%v" + :doc "\ These special parameters are recognized by Gnus. Check the [ ] for the parameters you want to apply to this group or to the groups in this topic, then edit the value to suit your taste." - ,@types) - '(repeat :inline t - :tag "Variables" - :format "%t:\n%h%v%i\n\n" - :doc "\ + ,@types) + (when gnus-agent + `(set :inline t + :greedy t + :tag "Agent Parameters" + :format "%t:\n%h%v" + :doc "\ These agent parameters are +recognized by Gnus. They control article selection and expiration for +use in the unplugged cache. Check the [ ] for the parameters you want +to apply to this group or to the groups in this topic, then edit the +value to suit your taste. + +For those interested, group parameters override topic parameters while +topic parameters override agent category parameters. Underlying +category parameters are the customizable variables." ,@agent)) + '(repeat :inline t + :tag "Variables" + :format "%t:\n%h%v%i\n\n" + :doc "\ Set variables local to the group you are entering. If you want to turn threading off in `news.answers', you could put @@ -394,14 +460,14 @@ put something like `(dummy-variable (ding))' in the parameters of that group. `dummy-variable' will be set to the result of the `(ding)' form, but who cares?" - (list :format "%v" :value (nil nil) - (symbol :tag "Variable") - (sexp :tag - "Value"))) + (list :format "%v" :value (nil nil) + (symbol :tag "Variable") + (sexp :tag + "Value"))) - '(repeat :inline t - :tag "Unknown entries" - sexp))) + '(repeat :inline t + :tag "Unknown entries" + sexp)))))) (when group (widget-insert "\n\nYou can also edit the ") (widget-create 'info-link @@ -701,8 +767,13 @@ (defvar gnus-custom-score-alist) (defun gnus-score-customize (file) - "Customize score file FILE." + "Customize score file FILE. +When called interactively, FILE defaults to the current score file. +This can be changed using the `\\[gnus-score-change-score-file]' command." (interactive (list gnus-current-score-file)) + (unless file + (error (format "No score file for %s" + (gnus-group-decoded-name gnus-newsgroup-name)))) (let ((scores (gnus-score-load file)) (types (mapcar (lambda (entry) `(group :format "%v%h\n" @@ -814,6 +885,174 @@ (gnus-score-set 'touched '(t) alist)) (bury-buffer)) +(eval-when-compile + (defvar category-fields nil) + (defvar gnus-agent-cat-name) + (defvar gnus-agent-cat-score-file) + (defvar gnus-agent-cat-length-when-short) + (defvar gnus-agent-cat-length-when-long) + (defvar gnus-agent-cat-low-score) + (defvar gnus-agent-cat-high-score) + (defvar gnus-agent-cat-enable-expiration) + (defvar gnus-agent-cat-days-until-old) + (defvar gnus-agent-cat-predicate) + (defvar gnus-agent-cat-groups) + (defvar gnus-agent-cat-enable-undownloaded-faces) +) + +(defun gnus-trim-whitespace (s) + (when (string-match "\\`[ \n\t]+" s) + (setq s (substring s (match-end 0)))) + (when (string-match "[ \n\t]+\\'" s) + (setq s (substring s 0 (match-beginning 0)))) + s) + +(defmacro gnus-agent-cat-prepare-category-field (parameter) + (let* ((entry (assq parameter gnus-agent-parameters)) + (field (nth 3 entry))) + `(let* ((type (copy-sequence + (nth 1 (assq ',parameter gnus-agent-parameters)))) + (val (,field info)) + (deflt (if (,field defaults) + (concat " [" (gnus-trim-whitespace + (pp-to-string (,field defaults))) "]"))) + symb) + + (if (eq (car type) 'radio) + (let* ((rtype (nreverse type)) + (rt rtype)) + (while (listp (or (cadr rt) 'not-list)) + (setq rt (cdr rt))) + + (setcdr rt (cons '(const :format "Inherit " nil) (cdr rt))) + (setq type (nreverse rtype)))) + + (if deflt + (let ((tag (cdr (memq :tag type)))) + (when (string-match "\n" deflt) + (while (progn (setq deflt (replace-match "\n " t t + deflt)) + (string-match "\n" deflt (match-end 0)))) + (setq deflt (concat "\n" deflt))) + + (setcar tag (concat (car tag) deflt)))) + + (widget-insert "\n") + + (setq val (if val + (widget-create type :value val) + (widget-create type)) + symb (set (make-local-variable ',field) val)) + + (widget-put symb :default val) + (widget-put symb :accessor ',field) + (push symb category-fields)))) + +(defun gnus-agent-customize-category (category) + "Edit the CATEGORY." + (interactive (list (gnus-category-name))) + (let ((info (assq category gnus-category-alist)) + (defaults (list nil '(agent-predicate . false) + (cons 'agent-enable-expiration + gnus-agent-enable-expiration) + '(agent-days-until-old . 7) + (cons 'agent-length-when-short + gnus-agent-short-article) + (cons 'agent-length-when-long gnus-agent-long-article) + (cons 'agent-low-score gnus-agent-low-score) + (cons 'agent-high-score gnus-agent-high-score)))) + + (let ((old (get-buffer "*Gnus Agent Category Customize*"))) + (when old + (gnus-kill-buffer old))) + (switch-to-buffer (gnus-get-buffer-create + "*Gnus Agent Category Customize*")) + + (let ((inhibit-read-only t)) + (gnus-custom-mode) + (buffer-disable-undo) + + (let* ((name (gnus-agent-cat-name info))) + (widget-insert "Customize the Agent Category '") + (widget-insert (symbol-name name)) + (widget-insert "' and press ") + (widget-create + 'push-button + :notify + '(lambda (&rest ignore) + (let* ((info (assq gnus-agent-cat-name gnus-category-alist)) + (widgets category-fields)) + (while widgets + (let* ((widget (pop widgets)) + (value (condition-case nil (widget-value widget) (error)))) + (eval `(setf (,(widget-get widget :accessor) ',info) + ',value))))) + (gnus-category-write) + (gnus-kill-buffer (current-buffer)) + (when (get-buffer gnus-category-buffer) + (switch-to-buffer (get-buffer gnus-category-buffer)) + (gnus-category-list))) + "Done") + (widget-insert + "\n Note: Empty fields default to the customizable global\ + variables.\n\n") + + (set (make-local-variable 'gnus-agent-cat-name) + name)) + + (set (make-local-variable 'category-fields) nil) + (gnus-agent-cat-prepare-category-field agent-predicate) + + (gnus-agent-cat-prepare-category-field agent-score) + (gnus-agent-cat-prepare-category-field agent-short-article) + (gnus-agent-cat-prepare-category-field agent-long-article) + (gnus-agent-cat-prepare-category-field agent-low-score) + (gnus-agent-cat-prepare-category-field agent-high-score) + + ;; The group list is NOT handled with + ;; gnus-agent-cat-prepare-category-field as I don't want the + ;; group list to appear when customizing a topic. + (widget-insert "\n") + + (let ((symb + (set + (make-local-variable 'gnus-agent-cat-groups) + (widget-create + `(choice + :format "%[Select Member Groups%]\n%v" :value ignore + (const :menu-tag "do not change" :tag "" :value ignore) + (checklist :entry-format "%b %v" + :menu-tag "display group selectors" + :greedy t + :value + ,(delq nil + (mapcar + (lambda (newsrc) + (car (member + (gnus-info-group newsrc) + (gnus-agent-cat-groups info)))) + (cdr gnus-newsrc-alist))) + ,@(mapcar (lambda (newsrc) + `(const ,(gnus-info-group newsrc))) + (cdr gnus-newsrc-alist)))))))) + + (widget-put symb :default (gnus-agent-cat-groups info)) + (widget-put symb :accessor 'gnus-agent-cat-groups) + (push symb category-fields)) + + (widget-insert "\nExpiration Settings ") + + (gnus-agent-cat-prepare-category-field agent-enable-expiration) + (gnus-agent-cat-prepare-category-field agent-days-until-old) + + (widget-insert "\nVisual Settings ") + + (gnus-agent-cat-prepare-category-field agent-enable-undownloaded-faces) + + (use-local-map widget-keymap) + (widget-setup) + (buffer-enable-undo)))) + ;;; The End: (provide 'gnus-cus)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-delay.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,196 @@ +;;; 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: + +;;; arch-tag: fb2ad634-a897-4142-a503-f5991ec2349d +;;; gnus-delay.el ends here
--- a/lisp/gnus/gnus-demon.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-demon.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,7 @@ ;;; gnus-demon.el --- daemonic Gnus behaviour -;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -148,32 +150,32 @@ (if (not (stringp time)) time (let* ((now (current-time)) - ;; obtain NOW as discrete components -- make a vector for speed - (nowParts (decode-time now)) - ;; obtain THEN as discrete components - (thenParts (parse-time-string time)) - (thenHour (elt thenParts 2)) - (thenMin (elt thenParts 1)) - ;; convert time as elements into number of seconds since EPOCH. - (then (encode-time 0 - thenMin - thenHour - ;; If THEN is earlier than NOW, make it - ;; same time tomorrow. Doc for encode-time - ;; says that this is OK. - (+ (elt nowParts 3) - (if (or (< thenHour (elt nowParts 2)) - (and (= thenHour (elt nowParts 2)) - (<= thenMin (elt nowParts 1)))) - 1 0)) - (elt nowParts 4) - (elt nowParts 5) - (elt nowParts 6) - (elt nowParts 7) - (elt nowParts 8))) - ;; calculate number of seconds between NOW and THEN - (diff (+ (* 65536 (- (car then) (car now))) - (- (cadr then) (cadr now))))) + ;; obtain NOW as discrete components -- make a vector for speed + (nowParts (decode-time now)) + ;; obtain THEN as discrete components + (thenParts (parse-time-string time)) + (thenHour (elt thenParts 2)) + (thenMin (elt thenParts 1)) + ;; convert time as elements into number of seconds since EPOCH. + (then (encode-time 0 + thenMin + thenHour + ;; If THEN is earlier than NOW, make it + ;; same time tomorrow. Doc for encode-time + ;; says that this is OK. + (+ (elt nowParts 3) + (if (or (< thenHour (elt nowParts 2)) + (and (= thenHour (elt nowParts 2)) + (<= thenMin (elt nowParts 1)))) + 1 0)) + (elt nowParts 4) + (elt nowParts 5) + (elt nowParts 6) + (elt nowParts 7) + (elt nowParts 8))) + ;; calculate number of seconds between NOW and THEN + (diff (+ (* 65536 (- (car then) (car now))) + (- (cadr then) (cadr now))))) ;; return number of timesteps in the number of seconds (round (/ diff gnus-demon-timestep)))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-diary.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,461 @@ +;;; 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. +(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) + +;;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b +;;; gnus-diary.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-dired.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,207 @@ +;;; gnus-dired.el --- utility functions where gnus and dired meet + +;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004 +;; 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-m\C-a" gnus-dired-attach + "\C-c\C-m\C-l" gnus-dired-find-file-mailcap + "\C-c\C-m\C-p" 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) + +;;; arch-tag: 44737731-e445-4638-a31e-713c7590ec76 +;;; gnus-dired.el ends here
--- a/lisp/gnus/gnus-draft.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-draft.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-draft.el --- draft message support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000 +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -46,6 +46,7 @@ (gnus-define-keys gnus-draft-mode-map "Dt" gnus-draft-toggle-sending + "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' "De" gnus-draft-edit-message "Ds" gnus-draft-send-message "DS" gnus-draft-send-all-messages)) @@ -94,13 +95,18 @@ (defun gnus-draft-edit-message () "Enter a mail/post buffer to edit and send the draft." (interactive) - (let ((article (gnus-summary-article-number))) + (let ((article (gnus-summary-article-number)) + (group gnus-newsgroup-name)) (gnus-summary-mark-as-read article gnus-canceled-mark) - (gnus-draft-setup article gnus-newsgroup-name t) + (gnus-draft-setup article group t) (set-buffer-modified-p t) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-remove-header "date"))) (save-buffer) (let ((gnus-verbose-backends nil)) - (gnus-request-expire-articles (list article) gnus-newsgroup-name t)) + (gnus-request-expire-articles (list article) group t)) (push `((lambda () (when (gnus-buffer-exists-p ,gnus-summary-buffer) @@ -126,8 +132,9 @@ (defun gnus-draft-send (article &optional group interactive) "Send message ARTICLE." - (let ((message-syntax-checks (if interactive nil + (let ((message-syntax-checks (if interactive message-syntax-checks 'dont-check-for-anything-just-trust-me)) + (message-hidden-headers nil) (message-inhibit-body-encoding (or (not group) (equal group "nndraft:queue") message-inhibit-body-encoding)) @@ -135,13 +142,20 @@ message-send-hook)) (message-setup-hook (and group (not (equal group "nndraft:queue")) message-setup-hook)) - type method) + type method move-to) (gnus-draft-setup article (or group "nndraft:queue")) ;; We read the meta-information that says how and where ;; this message is to be sent. (save-restriction (message-narrow-to-head) (when (re-search-forward + (concat "^" (regexp-quote gnus-agent-target-move-group-header) + ":") nil t) + (skip-syntax-forward "-") + (setq move-to (buffer-substring (point) (gnus-point-at-eol))) + (message-remove-header gnus-agent-target-move-group-header)) + (goto-char (point-min)) + (when (re-search-forward (concat "^" (regexp-quote gnus-agent-meta-information-header) ":") nil t) (setq type (ignore-errors (read (current-buffer))) @@ -159,8 +173,12 @@ (message-this-is-mail (eq type 'mail)) (gnus-post-method method) (message-post-method method)) - (message-send-and-exit)) - (message-send-and-exit))) + (if move-to + (gnus-inews-do-gcc move-to) + (message-send-and-exit))) + (if move-to + (gnus-inews-do-gcc move-to) + (message-send-and-exit)))) (let ((gnus-verbose-backends nil)) (gnus-request-expire-articles (list article) (or group "nndraft:queue") t))))) @@ -168,10 +186,14 @@ (defun gnus-draft-send-all-messages () "Send all the sendable drafts." (interactive) - (gnus-uu-mark-buffer) - (gnus-draft-send-message)) + (when (or + gnus-expert-user + (gnus-y-or-n-p + "Send all drafts? ")) + (gnus-uu-mark-buffer) + (gnus-draft-send-message))) -(defun gnus-group-send-drafts () +(defun gnus-group-send-queue () "Send all sendable articles from the queue group." (interactive) (gnus-activate-group "nndraft:queue") @@ -181,6 +203,7 @@ (cdr (assq 'unsend (gnus-info-marks (gnus-get-info "nndraft:queue")))))) + (gnus-posting-styles nil) (total (length articles)) article) (while (setq article (pop articles)) @@ -190,6 +213,20 @@ (- total (length articles)) total))) (gnus-draft-send article))))))) +;;;###autoload +(defun gnus-draft-reminder () + "Reminder user if there are unsent drafts." + (interactive) + (if (gnus-alive-p) + (let (active) + (catch 'continue + (dolist (group '("nndraft:drafts" "nndraft:queue")) + (setq active (gnus-activate-group group)) + (if (and active (>= (cdr active) (car active))) + (if (y-or-n-p "There are unsent drafts. Confirm to exit? ") + (throw 'continue t) + (error "Stop!")))))))) + ;;; Utility functions ;;;!!!If this is byte-compiled, it fails miserably. @@ -199,21 +236,41 @@ (progn (defun gnus-draft-setup (narticle group &optional restore) - (gnus-setup-message 'forward - (let ((article narticle)) - (message-mail) - (erase-buffer) - (if (not (gnus-request-restore-buffer article group)) - (error "Couldn't restore the article") - (if (and restore (equal group "nndraft:queue")) + (let (ga) + (gnus-setup-message 'forward + (let ((article narticle)) + (message-mail) + (erase-buffer) + (if (not (gnus-request-restore-buffer article group)) + (error "Couldn't restore the article") + (when (and restore + (equal group "nndraft:queue")) (mime-to-mml)) - ;; Insert the separator. - (goto-char (point-min)) - (search-forward "\n\n") - (forward-char -1) - (insert mail-header-separator) - (forward-line 1) - (message-set-auto-save-file-name)))))) + ;; Insert the separator. + (goto-char (point-min)) + (search-forward "\n\n") + (forward-char -1) + (insert mail-header-separator) + (forward-line 1) + (setq ga (message-fetch-field gnus-draft-meta-information-header)) + (message-set-auto-save-file-name)))) + (gnus-backlog-remove-article group narticle) + (when (and ga + (ignore-errors (setq ga (car (read-from-string ga))))) + (setq gnus-newsgroup-name + (if (equal (car ga) "") nil (car ga))) + (gnus-configure-posting-styles) + (setq gnus-message-group-art (cons gnus-newsgroup-name (cadr ga))) + (setq message-post-method + `(lambda (arg) + (gnus-post-method arg ,(car ga)))) + (unless (equal (cadr ga) "") + (message-add-action + `(progn + (gnus-add-mark ,(car ga) 'replied ,(cadr ga)) + (gnus-request-set-mark ,(car ga) (list (list (list ,(cadr ga)) + 'add '(reply))))) + 'send)))))) (defun gnus-draft-article-sendable-p (article) "Say whether ARTICLE is sendable."
--- a/lisp/gnus/gnus-dup.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-dup.el Thu Jul 22 16:45:51 2004 +0000 @@ -113,7 +113,7 @@ (gnus-dup-open)) (setq gnus-dup-list-dirty t) ; mark list for saving (let ((data gnus-newsgroup-data) - datum msgid) + datum msgid) ;; Enter the Message-IDs of all read articles into the list ;; and hash table. (while (setq datum (pop data)) @@ -121,11 +121,11 @@ (> (gnus-data-number datum) 0) (not (memq (gnus-data-number datum) gnus-newsgroup-unreads)) (not (= (gnus-data-mark datum) gnus-canceled-mark)) - (setq msgid (mail-header-id (gnus-data-header datum))) - (not (nnheader-fake-message-id-p msgid)) - (not (intern-soft msgid gnus-dup-hashtb))) + (setq msgid (mail-header-id (gnus-data-header datum))) + (not (nnheader-fake-message-id-p msgid)) + (not (intern-soft msgid gnus-dup-hashtb))) (push msgid gnus-dup-list) - (intern msgid gnus-dup-hashtb)))) + (intern msgid gnus-dup-hashtb)))) ;; Chop off excess Message-IDs from the list. (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) (when end
--- a/lisp/gnus/gnus-eform.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-eform.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-eform.el --- a mode for editing forms for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -114,7 +114,9 @@ "Update changes and kill the current buffer." (interactive) (goto-char (point-min)) - (let ((form (read (current-buffer))) + (let ((form (condition-case nil + (read (current-buffer)) + (end-of-file nil))) (func gnus-edit-form-done-function)) (gnus-edit-form-exit) (funcall func form)))
--- a/lisp/gnus/gnus-ems.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-ems.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -45,12 +45,13 @@ (eval-and-compile (autoload 'gnus-xmas-define "gnus-xmas") (autoload 'gnus-xmas-redefine "gnus-xmas") - (autoload 'appt-select-lowest-window "appt")) + (autoload 'appt-select-lowest-window "appt") + (autoload 'gnus-get-buffer-create "gnus") + (autoload 'nnheader-find-etc-directory "nnheader")) -(if (featurep 'xemacs) - (autoload 'gnus-smiley-display "smiley") - (autoload 'gnus-smiley-display "smiley-ems") ; override XEmacs version -) +(autoload 'smiley-region "smiley") +;; Fixme: shouldn't require message +(autoload 'message-text-with-property "message") (defun gnus-kill-all-overlays () "Delete all overlays in the current buffer." @@ -71,20 +72,30 @@ valstr))) (eval-and-compile + (defalias 'gnus-char-width + (if (fboundp 'char-width) + 'char-width + (lambda (ch) 1)))) ;; A simple hack. + +(eval-and-compile (if (featurep 'xemacs) (gnus-xmas-define) (defvar gnus-mouse-face-prop 'mouse-face "Property used for highlighting mouse regions."))) -(defvar gnus-tmp-unread) -(defvar gnus-tmp-replied) -(defvar gnus-tmp-score-char) -(defvar gnus-tmp-indentation) -(defvar gnus-tmp-opening-bracket) -(defvar gnus-tmp-lines) -(defvar gnus-tmp-name) -(defvar gnus-tmp-closing-bracket) -(defvar gnus-tmp-subject-or-nil) +(eval-when-compile + (defvar gnus-tmp-unread) + (defvar gnus-tmp-replied) + (defvar gnus-tmp-score-char) + (defvar gnus-tmp-indentation) + (defvar gnus-tmp-opening-bracket) + (defvar gnus-tmp-lines) + (defvar gnus-tmp-name) + (defvar gnus-tmp-closing-bracket) + (defvar gnus-tmp-subject-or-nil) + (defvar gnus-check-before-posting) + (defvar gnus-mouse-face) + (defvar gnus-group-buffer)) (defun gnus-ems-redefine () (cond @@ -96,18 +107,18 @@ ;; [Note] Now there are three kinds of mule implementations, ;; original MULE, XEmacs/mule and Emacs 20+ including - ;; MULE features. Unfortunately these API are different. In - ;; particular, Emacs (including original MULE) and XEmacs are + ;; MULE features. Unfortunately these APIs are different. In + ;; particular, Emacs (including original Mule) and XEmacs are ;; quite different. However, this version of Gnus doesn't support ;; anything other than XEmacs 20+ and Emacs 20.3+. ;; Predicates to check are following: - ;; (boundp 'MULE) is t only if MULE (original; anything older than + ;; (boundp 'MULE) is t only if Mule (original; anything older than ;; Mule 2.3) is running. - ;; (featurep 'mule) is t when every mule variants are running. + ;; (featurep 'mule) is t when other mule variants are running. ;; It is possible to detect XEmacs/mule by (featurep 'mule) and - ;; checking `emacs-version'. In this case, the implementation for + ;; (featurep 'xemacs). In this case, the implementation for ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. (defvar gnus-summary-display-table nil @@ -144,6 +155,10 @@ (boundp 'mark-active) mark-active)) +(defun gnus-mark-active-p () + "Non-nil means the mark and region are currently active in this buffer." + mark-active) ; aliased to region-exists-p in XEmacs. + (if (fboundp 'add-minor-mode) (defalias 'gnus-add-minor-mode 'add-minor-mode) (defun gnus-add-minor-mode (mode name map &rest rest) @@ -166,11 +181,13 @@ (when (and dir (file-exists-p (setq file (expand-file-name "x-splash" dir)))) - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (ignore-errors - (setq pixmap (read (current-buffer)))))) + (let ((coding-system-for-read 'raw-text) + default-enable-multibyte-characters) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (ignore-errors + (setq pixmap (read (current-buffer))))))) (when pixmap (make-face 'gnus-splash) (setq height (/ (car pixmap) (frame-char-height)) @@ -189,81 +206,36 @@ (goto-char (point-min)) (sit-for 0)))))) -(defvar gnus-article-xface-ring-internal nil - "Cache for face data.") +;;; Image functions. -;; Worth customizing? -(defvar gnus-article-xface-ring-size 6 - "Length of the ring used for `gnus-article-xface-ring-internal'.") - -(defvar gnus-article-compface-xbm - (eq 0 (string-match "#define" (shell-command-to-string "uncompface -X"))) - "Non-nil means the compface program supports the -X option. -That produces XBM output.") +(defun gnus-image-type-available-p (type) + (and (fboundp 'image-type-available-p) + (image-type-available-p type))) -(defun gnus-article-display-xface (beg end) - "Display an XFace header from between BEG and END in the current article. -Requires support for images in your Emacs and 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. See also -`gnus-article-compface-xbm'. - -This function is for Emacs 21+. See `gnus-xmas-article-display-xface' -for XEmacs." - ;; It might be worth converting uncompface's output in Lisp. +(defun gnus-create-image (file &optional type data-p &rest props) + (let ((face (plist-get props :face))) + (when face + (setq props (plist-put props :foreground (face-foreground face))) + (setq props (plist-put props :background (face-background face)))) + (apply 'create-image file type data-p props))) - (when (if (fboundp 'display-graphic-p) - (display-graphic-p)) - (unless gnus-article-xface-ring-internal ; Only load ring when needed. - (setq gnus-article-xface-ring-internal - (make-ring gnus-article-xface-ring-size))) - (save-excursion - (let* ((cur (current-buffer)) - (data (buffer-substring beg end)) - (image (cdr-safe (assoc data (ring-elements - gnus-article-xface-ring-internal)))) - default-enable-multibyte-characters) - (unless image - (with-temp-buffer - (insert data) - (and (eq 0 (apply #'call-process-region (point-min) (point-max) - "uncompface" - 'delete '(t nil) nil - (if gnus-article-compface-xbm - '("-X")))) - (if gnus-article-compface-xbm - t - (goto-char (point-min)) - (progn (insert "/* Width=48, Height=48 */\n") t) - (eq 0 (call-process-region (point-min) (point-max) - "icontopbm" - 'delete '(t nil)))) - ;; Miles Bader says that faces don't look right as - ;; light on dark. - (if (eq 'dark (cdr-safe (assq 'background-mode - (frame-parameters)))) - (setq image (create-image (buffer-string) - (if gnus-article-compface-xbm - 'xbm - 'pbm) - t - :ascent 'center - :foreground "black" - :background "white")) - (setq image (create-image (buffer-string) - (if gnus-article-compface-xbm - 'xbm - 'pbm) - t - :ascent 'center))))) - (ring-insert gnus-article-xface-ring-internal (cons data image))) - (when image - (goto-char (point-min)) - (re-search-forward "^From:" nil 'move) - (while (get-text-property (point) 'display) - (goto-char (next-single-property-change (point) 'display))) - (insert-image image)))))) +(defun gnus-put-image (glyph &optional string category) + (let ((point (point))) + (insert-image glyph (or string " ")) + (put-text-property point (point) 'gnus-image-category category) + (unless string + (put-text-property (1- (point)) (point) + 'gnus-image-text-deletable t)) + glyph)) + +(defun gnus-remove-image (image &optional category) + (dolist (position (message-text-with-property 'display)) + (when (and (equal (get-text-property position 'display) image) + (equal (get-text-property position 'gnus-image-category) + category)) + (put-text-property position (1+ position) 'display nil) + (when (get-text-property position 'gnus-image-text-deletable) + (delete-region position (1+ position)))))) (provide 'gnus-ems)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-fun.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,252 @@ +;;; 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)) + (gnus-message 9 "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 :face 'gnus-x-face) + (gnus-create-image + pbm 'pbm t :face 'gnus-x-face)) nil 'xface)) + (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) + +;;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1 +;;; gnus-fun.el ends here
--- a/lisp/gnus/gnus-gl.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-gl.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; gnus-gl.el --- an interface to GroupLens for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Brad Miller <bmiller@cs.umn.edu> @@ -131,7 +131,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar gnus-summary-grouplens-line-format - "%U\%R\%z%l%I\%(%[%4L: %-20,20n%]%) %s\n" + "%U\%R\%z%l%I\%(%[%4L: %-23,23n%]%) %s\n" "*The line format spec in summary GroupLens mode buffers.") (defvar grouplens-pseudonym "" @@ -342,7 +342,7 @@ (defun bbb-build-mid-scores-alist (groupname) "this function can be called as part of the function to return the list of score files to use. -See the gnus variable gnus-score-find-score-files-function. +See the gnus variable `gnus-score-find-score-files-function'. *Note:* If you want to use grouplens scores along with calculated scores, you should see the offset and scale variables. At this point, I don't @@ -510,11 +510,11 @@ ;; Return an empty string "" (let* ((rate-string (make-string 12 ?\ )) - (mid (mail-header-id header)) - (hashent (gnus-gethash mid grouplens-current-hashtable)) - (pred (or (nth 0 hashent) 0)) - (low (nth 1 hashent)) - (high (nth 2 hashent))) + (mid (mail-header-id header)) + (hashent (gnus-gethash mid grouplens-current-hashtable)) + (pred (or (nth 0 hashent) 0)) + (low (nth 1 hashent)) + (high (nth 2 hashent))) ;; Init rate-string (aset rate-string 0 ?|) (aset rate-string 11 ?|) @@ -632,10 +632,10 @@ (defun bbb-build-rate-command (rate-alist) (concat "putratings " grouplens-bbb-token " " grouplens-current-group " \r\n" - (mapconcat '(lambda (this) ; form (mid . (score . time)) - (concat (car this) - " :rating=" (cadr this) ".00" - " :time=" (cddr this))) + (mapconcat (lambda (this) ; form (mid . (score . time)) + (concat (car this) + " :rating=" (cadr this) ".00" + " :time=" (cddr this))) rate-alist "\r\n") "\r\n.\r\n")) @@ -810,9 +810,9 @@ (if (null arg) (not gnus-grouplens-mode) (> (prefix-numeric-value arg) 0))) (when gnus-grouplens-mode - (make-local-hook 'gnus-select-article-hook) + (gnus-make-local-hook 'gnus-select-article-hook) (add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local) - (make-local-hook 'gnus-exit-group-hook) + (gnus-make-local-hook 'gnus-exit-group-hook) (add-hook 'gnus-exit-group-hook 'bbb-exit-group nil 'local) (make-local-variable 'gnus-score-find-score-files-function)
--- a/lisp/gnus/gnus-group.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-group.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-group.el --- group mode commands for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -26,7 +26,9 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (defvar tool-bar-map)) (require 'gnus) (require 'gnus-start) @@ -37,6 +39,9 @@ (require 'gnus-win) (require 'gnus-undo) (require 'time-date) +(require 'gnus-ems) + +(eval-when-compile (require 'mm-url)) (defcustom gnus-group-archive-directory "*ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" @@ -117,24 +122,30 @@ for the groups to be sorted. Pre-made functions include `gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name', `gnus-group-sort-by-unread', `gnus-group-sort-by-level', -`gnus-group-sort-by-score', `gnus-group-sort-by-method', and -`gnus-group-sort-by-rank'. +`gnus-group-sort-by-score', `gnus-group-sort-by-method', +`gnus-group-sort-by-server', and `gnus-group-sort-by-rank'. This variable can also be a list of sorting functions. In that case, the most significant sort function should be the last function in the list." :group 'gnus-group-listing :link '(custom-manual "(gnus)Sorting Groups") - :type '(radio (function-item gnus-group-sort-by-alphabet) - (function-item gnus-group-sort-by-real-name) - (function-item gnus-group-sort-by-unread) - (function-item gnus-group-sort-by-level) - (function-item gnus-group-sort-by-score) - (function-item gnus-group-sort-by-method) - (function-item gnus-group-sort-by-rank) - (function :tag "other" nil))) - -(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y: %(%g%)%l\n" + :type '(repeat :value-to-internal (lambda (widget value) + (if (listp value) value (list value))) + :match (lambda (widget value) + (or (symbolp value) + (widget-editable-list-match widget value))) + (choice (function-item gnus-group-sort-by-alphabet) + (function-item gnus-group-sort-by-real-name) + (function-item gnus-group-sort-by-unread) + (function-item gnus-group-sort-by-level) + (function-item gnus-group-sort-by-score) + (function-item gnus-group-sort-by-method) + (function-item gnus-group-sort-by-server) + (function-item gnus-group-sort-by-rank) + (function :tag "other" nil)))) + +(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%l %O\n" "*Format of group lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -147,14 +158,18 @@ %i Number of ticked and dormant (integer) %T Number of ticked articles (integer) %R Number of read articles (integer) +%U Number of unseen articles (integer) %t Estimated total number of articles (integer) %y Number of unread, unticked articles (integer) %G Group name (string) %g Qualified group name (string) +%c Short (collapsed) group name. See `gnus-group-uncollapsed-levels'. +%C Group comment (string) %D Group description (string) %s Select method (string) %o Moderated group (char, \"m\") %p Process mark (char) +%B Whether a summary buffer for the group is open (char, \"*\") %O Moderated group (string, \"(m)\" or \"\") %P Topic indentation (string) %m Whether there is new(ish) mail in the group (char, \"%\") @@ -165,13 +180,10 @@ %E Icon as defined by `gnus-group-icon-list'. %u User defined specifier. The next character in the format string should be a letter. Gnus will call the function gnus-user-format-function-X, - where X is the letter following %u. The function will be passed the - current header as argument. The function should return a string, which - will be inserted into the buffer just like information from any other - group specifier. - -Text between %( and %) will be highlighted with `gnus-mouse-face' when -the mouse point move inside the area. There can only be one such area. + where X is the letter following %u. The function will be passed a + single dummy parameter as argument. The function should return a + string, which will be inserted into the buffer just like information + from any other group specifier. Note that this format specification is not always respected. For reasons of efficiency, when listing killed groups, this specification @@ -183,7 +195,11 @@ a bit of extra memory will be used. %D will also worsen performance. Also note that if you change the format specification to include any of these specs, you must probably re-start Gnus to see them go into -effect." +effect. + +General format specifiers can also be used. +See Info node `(gnus)Formatting Variables'." + :link '(custom-manual "(gnus)Formatting Variables") :group 'gnus-group-visual :type 'string) @@ -198,11 +214,10 @@ :group 'gnus-group-visual :type 'string) -(defcustom gnus-group-mode-hook nil - "Hook for Gnus group mode." - :group 'gnus-group-various - :options '(gnus-topic-mode) - :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) + (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)) (defcustom gnus-group-menu-hook nil "Hook run after the creation of the group mode menu." @@ -288,52 +303,52 @@ (sexp :tag "Method")))) (defcustom gnus-group-highlight - '(;; News. - ((and (= unread 0) (not mailp) (eq level 1)) . + '(;; Mail. + ((and mailp (= unread 0) (eq level 1)) . + gnus-group-mail-1-empty-face) + ((and mailp (eq level 1)) . + gnus-group-mail-1-face) + ((and mailp (= unread 0) (eq level 2)) . + gnus-group-mail-2-empty-face) + ((and mailp (eq level 2)) . + gnus-group-mail-2-face) + ((and mailp (= unread 0) (eq level 3)) . + gnus-group-mail-3-empty-face) + ((and mailp (eq level 3)) . + gnus-group-mail-3-face) + ((and mailp (= unread 0)) . + gnus-group-mail-low-empty-face) + ((and mailp) . + gnus-group-mail-low-face) + ;; News. + ((and (= unread 0) (eq level 1)) . gnus-group-news-1-empty-face) - ((and (not mailp) (eq level 1)) . + ((and (eq level 1)) . gnus-group-news-1-face) - ((and (= unread 0) (not mailp) (eq level 2)) . + ((and (= unread 0) (eq level 2)) . gnus-group-news-2-empty-face) - ((and (not mailp) (eq level 2)) . + ((and (eq level 2)) . gnus-group-news-2-face) - ((and (= unread 0) (not mailp) (eq level 3)) . + ((and (= unread 0) (eq level 3)) . gnus-group-news-3-empty-face) - ((and (not mailp) (eq level 3)) . + ((and (eq level 3)) . gnus-group-news-3-face) - ((and (= unread 0) (not mailp) (eq level 4)) . + ((and (= unread 0) (eq level 4)) . gnus-group-news-4-empty-face) - ((and (not mailp) (eq level 4)) . + ((and (eq level 4)) . gnus-group-news-4-face) - ((and (= unread 0) (not mailp) (eq level 5)) . + ((and (= unread 0) (eq level 5)) . gnus-group-news-5-empty-face) - ((and (not mailp) (eq level 5)) . + ((and (eq level 5)) . gnus-group-news-5-face) - ((and (= unread 0) (not mailp) (eq level 6)) . + ((and (= unread 0) (eq level 6)) . gnus-group-news-6-empty-face) - ((and (not mailp) (eq level 6)) . + ((and (eq level 6)) . gnus-group-news-6-face) - ((and (= unread 0) (not mailp)) . + ((and (= unread 0)) . gnus-group-news-low-empty-face) - ((and (not mailp)) . - gnus-group-news-low-face) - ;; Mail. - ((and (= unread 0) (eq level 1)) . - gnus-group-mail-1-empty-face) - ((eq level 1) . - gnus-group-mail-1-face) - ((and (= unread 0) (eq level 2)) . - gnus-group-mail-2-empty-face) - ((eq level 2) . - gnus-group-mail-2-face) - ((and (= unread 0) (eq level 3)) . - gnus-group-mail-3-empty-face) - ((eq level 3) . - gnus-group-mail-3-face) - ((= unread 0) . - gnus-group-mail-low-empty-face) (t . - gnus-group-mail-low-face)) + gnus-group-news-low-face)) "*Controls the highlighting of group buffer lines. Below is a list of `Form'/`Face' pairs. When deciding how a a @@ -395,26 +410,44 @@ :type '(repeat (cons (sexp :tag "Form") file))) (defcustom gnus-group-name-charset-method-alist nil - "*Alist of method and the charset for group names. + "Alist of method and the charset for group names. For example: - (((nntp \"news.com.cn\") . cn-gb-2312)) -" + (((nntp \"news.com.cn\") . cn-gb-2312))" :version "21.1" :group 'gnus-charset :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset")))) -(defcustom gnus-group-name-charset-group-alist nil - "*Alist of group regexp and the charset for group names. +(defcustom gnus-group-name-charset-group-alist + (if (or (and (fboundp 'find-coding-system) (find-coding-system 'utf-8)) + (mm-coding-system-p 'utf-8)) + '((".*" . utf-8)) + nil) + "Alist of group regexp and the charset for group names. For example: - ((\"\\.com\\.cn:\" . cn-gb-2312)) -" + ((\"\\.com\\.cn:\" . cn-gb-2312))" :group 'gnus-charset :type '(repeat (cons (regexp :tag "Group") (symbol :tag "Charset")))) +(defcustom gnus-group-jump-to-group-prompt nil + "Default prompt for `gnus-group-jump-to-group'. +If non-nil, the value should be a string, e.g. \"nnml:\", +in which case `gnus-group-jump-to-group' offers \"Group: nnml:\" +in the minibuffer prompt." + :group 'gnus-group-various + :type '(choice (string :tag "Prompt string") + (const :tag "Empty" nil))) + +(defvar gnus-group-listing-limit 1000 + "*A limit of the number of groups when listing. +If the number of groups is larger than the limit, list them in a +simple manner.") + ;;; Internal variables +(defvar gnus-group-is-exiting-p nil) +(defvar gnus-group-is-exiting-without-update-p nil) (defvar gnus-group-sort-alist-function 'gnus-group-sort-flat "Function for sorting the group buffer.") @@ -441,6 +474,7 @@ (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) (t number)) ?s) (?R gnus-tmp-number-of-read ?s) + (?U (gnus-number-of-unseen-articles-in-group gnus-tmp-group) ?d) (?t gnus-tmp-number-total ?d) (?y gnus-tmp-number-of-unread ?s) (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) @@ -450,6 +484,7 @@ (?g gnus-tmp-group ?s) (?G gnus-tmp-qualified-group ?s) (?c (gnus-short-group-name gnus-tmp-group) ?s) + (?C gnus-tmp-comment ?s) (?D gnus-tmp-newsgroup-description ?s) (?o gnus-tmp-moderated ?c) (?O gnus-tmp-moderated-string ?s) @@ -458,6 +493,7 @@ (?n gnus-tmp-news-method ?s) (?P gnus-group-indentation ?s) (?E gnus-tmp-group-icon ?s) + (?B gnus-tmp-summary-live ?c) (?l gnus-tmp-grouplens ?s) (?z gnus-tmp-news-method-string ?s) (?m (gnus-group-new-mail gnus-tmp-group) ?c) @@ -483,167 +519,221 @@ (defvar gnus-group-icon-cache nil) +(defvar gnus-group-listed-groups nil) +(defvar gnus-group-list-option nil) + ;;; ;;; Gnus group mode ;;; (put 'gnus-group-mode 'mode-class 'special) -(when t - (gnus-define-keys gnus-group-mode-map - " " gnus-group-read-group - "=" gnus-group-select-group - "\r" gnus-group-select-group - "\M-\r" gnus-group-quick-select-group - "\M- " gnus-group-visible-select-group - [(meta control return)] gnus-group-select-group-ephemerally - "j" gnus-group-jump-to-group - "n" gnus-group-next-unread-group - "p" gnus-group-prev-unread-group - "\177" gnus-group-prev-unread-group - [delete] gnus-group-prev-unread-group - [backspace] gnus-group-prev-unread-group - "N" gnus-group-next-group - "P" gnus-group-prev-group - "\M-n" gnus-group-next-unread-group-same-level - "\M-p" gnus-group-prev-unread-group-same-level - "," gnus-group-best-unread-group - "." gnus-group-first-unread-group - "u" gnus-group-unsubscribe-current-group - "U" gnus-group-unsubscribe-group - "c" gnus-group-catchup-current - "C" gnus-group-catchup-current-all - "\M-c" gnus-group-clear-data - "l" gnus-group-list-groups - "L" gnus-group-list-all-groups - "m" gnus-group-mail - "g" gnus-group-get-new-news - "\M-g" gnus-group-get-new-news-this-group - "R" gnus-group-restart - "r" gnus-group-read-init-file - "B" gnus-group-browse-foreign-server - "b" gnus-group-check-bogus-groups - "F" gnus-group-find-new-groups - "\C-c\C-d" gnus-group-describe-group - "\M-d" gnus-group-describe-all-groups - "\C-c\C-a" gnus-group-apropos - "\C-c\M-\C-a" gnus-group-description-apropos - "a" gnus-group-post-news - "\ek" gnus-group-edit-local-kill - "\eK" gnus-group-edit-global-kill - "\C-k" gnus-group-kill-group - "\C-y" gnus-group-yank-group - "\C-w" gnus-group-kill-region - "\C-x\C-t" gnus-group-transpose-groups - "\C-c\C-l" gnus-group-list-killed - "\C-c\C-x" gnus-group-expire-articles - "\C-c\M-\C-x" gnus-group-expire-all-groups - "V" gnus-version - "s" gnus-group-save-newsrc - "z" gnus-group-suspend - "q" gnus-group-exit - "Q" gnus-group-quit - "?" gnus-group-describe-briefly - "\C-c\C-i" gnus-info-find-node - "\M-e" gnus-group-edit-group-method - "^" gnus-group-enter-server-mode - gnus-mouse-2 gnus-mouse-pick-group - "<" beginning-of-buffer - ">" end-of-buffer - "\C-c\C-b" gnus-bug - "\C-c\C-s" gnus-group-sort-groups - "t" gnus-topic-mode - "\C-c\M-g" gnus-activate-all-groups - "\M-&" gnus-group-universal-argument - "#" gnus-group-mark-group - "\M-#" gnus-group-unmark-group) - - (gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) - "m" gnus-group-mark-group - "u" gnus-group-unmark-group - "w" gnus-group-mark-region - "b" gnus-group-mark-buffer - "r" gnus-group-mark-regexp - "U" gnus-group-unmark-all-groups) - - (gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map) - "d" gnus-group-make-directory-group - "h" gnus-group-make-help-group - "u" gnus-group-make-useful-group - "a" gnus-group-make-archive-group - "k" gnus-group-make-kiboze-group - "l" gnus-group-nnimap-edit-acl - "m" gnus-group-make-group - "E" gnus-group-edit-group - "e" gnus-group-edit-group-method - "p" gnus-group-edit-group-parameters - "v" gnus-group-add-to-virtual - "V" gnus-group-make-empty-virtual - "D" gnus-group-enter-directory - "f" gnus-group-make-doc-group - "w" gnus-group-make-web-group - "r" gnus-group-rename-group - "c" gnus-group-customize - "x" gnus-group-nnimap-expunge - "\177" gnus-group-delete-group - [delete] gnus-group-delete-group) - - (gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map) - "b" gnus-group-brew-soup - "w" gnus-soup-save-areas - "s" gnus-soup-send-replies - "p" gnus-soup-pack-packet - "r" nnsoup-pack-replies) - - (gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map) - "s" gnus-group-sort-groups - "a" gnus-group-sort-groups-by-alphabet - "u" gnus-group-sort-groups-by-unread - "l" gnus-group-sort-groups-by-level - "v" gnus-group-sort-groups-by-score - "r" gnus-group-sort-groups-by-rank - "m" gnus-group-sort-groups-by-method) - - (gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map) - "s" gnus-group-sort-selected-groups - "a" gnus-group-sort-selected-groups-by-alphabet - "u" gnus-group-sort-selected-groups-by-unread - "l" gnus-group-sort-selected-groups-by-level - "v" gnus-group-sort-selected-groups-by-score - "r" gnus-group-sort-selected-groups-by-rank - "m" gnus-group-sort-selected-groups-by-method) - - (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) - "k" gnus-group-list-killed - "z" gnus-group-list-zombies - "s" gnus-group-list-groups - "u" gnus-group-list-all-groups - "A" gnus-group-list-active - "a" gnus-group-apropos - "d" gnus-group-description-apropos - "m" gnus-group-list-matching - "M" gnus-group-list-all-matching - "l" gnus-group-list-level - "c" gnus-group-list-cached - "?" gnus-group-list-dormant) - - (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) - "f" gnus-score-flush-cache) - - (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) - "d" gnus-group-describe-group - "f" gnus-group-fetch-faq - "v" gnus-version) - - (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) - "l" gnus-group-set-current-level - "t" gnus-group-unsubscribe-current-group - "s" gnus-group-unsubscribe-group - "k" gnus-group-kill-group - "y" gnus-group-yank-group - "w" gnus-group-kill-region - "\C-k" gnus-group-kill-level - "z" gnus-group-kill-all-zombies)) +(gnus-define-keys gnus-group-mode-map + " " gnus-group-read-group + "=" gnus-group-select-group + "\r" gnus-group-select-group + "\M-\r" gnus-group-quick-select-group + "\M- " gnus-group-visible-select-group + [(meta control return)] gnus-group-select-group-ephemerally + "j" gnus-group-jump-to-group + "n" gnus-group-next-unread-group + "p" gnus-group-prev-unread-group + "\177" gnus-group-prev-unread-group + [delete] gnus-group-prev-unread-group + [backspace] gnus-group-prev-unread-group + "N" gnus-group-next-group + "P" gnus-group-prev-group + "\M-n" gnus-group-next-unread-group-same-level + "\M-p" gnus-group-prev-unread-group-same-level + "," gnus-group-best-unread-group + "." gnus-group-first-unread-group + "u" gnus-group-unsubscribe-current-group + "U" gnus-group-unsubscribe-group + "c" gnus-group-catchup-current + "C" gnus-group-catchup-current-all + "\M-c" gnus-group-clear-data + "l" gnus-group-list-groups + "L" gnus-group-list-all-groups + "m" gnus-group-mail + "i" gnus-group-news + "g" gnus-group-get-new-news + "\M-g" gnus-group-get-new-news-this-group + "R" gnus-group-restart + "r" gnus-group-read-init-file + "B" gnus-group-browse-foreign-server + "b" gnus-group-check-bogus-groups + "F" gnus-group-find-new-groups + "\C-c\C-d" gnus-group-describe-group + "\M-d" gnus-group-describe-all-groups + "\C-c\C-a" gnus-group-apropos + "\C-c\M-\C-a" gnus-group-description-apropos + "a" gnus-group-post-news + "\ek" gnus-group-edit-local-kill + "\eK" gnus-group-edit-global-kill + "\C-k" gnus-group-kill-group + "\C-y" gnus-group-yank-group + "\C-w" gnus-group-kill-region + "\C-x\C-t" gnus-group-transpose-groups + "\C-c\C-l" gnus-group-list-killed + "\C-c\C-x" gnus-group-expire-articles + "\C-c\M-\C-x" gnus-group-expire-all-groups + "V" gnus-version + "s" gnus-group-save-newsrc + "z" gnus-group-suspend + "q" gnus-group-exit + "Q" gnus-group-quit + "?" gnus-group-describe-briefly + "\C-c\C-i" gnus-info-find-node + "\M-e" gnus-group-edit-group-method + "^" gnus-group-enter-server-mode + gnus-mouse-2 gnus-mouse-pick-group + "<" beginning-of-buffer + ">" end-of-buffer + "\C-c\C-b" gnus-bug + "\C-c\C-s" gnus-group-sort-groups + "t" gnus-topic-mode + "\C-c\M-g" gnus-activate-all-groups + "\M-&" gnus-group-universal-argument + "#" gnus-group-mark-group + "\M-#" gnus-group-unmark-group) + +(gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) + "m" gnus-group-mark-group + "u" gnus-group-unmark-group + "w" gnus-group-mark-region + "b" gnus-group-mark-buffer + "r" gnus-group-mark-regexp + "U" gnus-group-unmark-all-groups) + +(gnus-define-keys (gnus-group-sieve-map "D" gnus-group-mode-map) + "u" gnus-sieve-update + "g" gnus-sieve-generate) + +(gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map) + "d" gnus-group-make-directory-group + "h" gnus-group-make-help-group + "u" gnus-group-make-useful-group + "a" gnus-group-make-archive-group + "k" gnus-group-make-kiboze-group + "l" gnus-group-nnimap-edit-acl + "m" gnus-group-make-group + "E" gnus-group-edit-group + "e" gnus-group-edit-group-method + "p" gnus-group-edit-group-parameters + "v" gnus-group-add-to-virtual + "V" gnus-group-make-empty-virtual + "D" gnus-group-enter-directory + "f" gnus-group-make-doc-group + "w" gnus-group-make-web-group + "M" gnus-group-read-ephemeral-group + "r" gnus-group-rename-group + "R" gnus-group-make-rss-group + "c" gnus-group-customize + "x" gnus-group-nnimap-expunge + "\177" gnus-group-delete-group + [delete] gnus-group-delete-group) + +(gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map) + "b" gnus-group-brew-soup + "w" gnus-soup-save-areas + "s" gnus-soup-send-replies + "p" gnus-soup-pack-packet + "r" nnsoup-pack-replies) + +(gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map) + "s" gnus-group-sort-groups + "a" gnus-group-sort-groups-by-alphabet + "u" gnus-group-sort-groups-by-unread + "l" gnus-group-sort-groups-by-level + "v" gnus-group-sort-groups-by-score + "r" gnus-group-sort-groups-by-rank + "m" gnus-group-sort-groups-by-method + "n" gnus-group-sort-groups-by-real-name) + +(gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map) + "s" gnus-group-sort-selected-groups + "a" gnus-group-sort-selected-groups-by-alphabet + "u" gnus-group-sort-selected-groups-by-unread + "l" gnus-group-sort-selected-groups-by-level + "v" gnus-group-sort-selected-groups-by-score + "r" gnus-group-sort-selected-groups-by-rank + "m" gnus-group-sort-selected-groups-by-method + "n" gnus-group-sort-selected-groups-by-real-name) + +(gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) + "k" gnus-group-list-killed + "z" gnus-group-list-zombies + "s" gnus-group-list-groups + "u" gnus-group-list-all-groups + "A" gnus-group-list-active + "a" gnus-group-apropos + "d" gnus-group-description-apropos + "m" gnus-group-list-matching + "M" gnus-group-list-all-matching + "l" gnus-group-list-level + "c" gnus-group-list-cached + "?" gnus-group-list-dormant) + +(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map) + "k" gnus-group-list-limit + "z" gnus-group-list-limit + "s" gnus-group-list-limit + "u" gnus-group-list-limit + "A" gnus-group-list-limit + "m" gnus-group-list-limit + "M" gnus-group-list-limit + "l" gnus-group-list-limit + "c" gnus-group-list-limit + "?" gnus-group-list-limit) + +(gnus-define-keys (gnus-group-list-flush-map "f" gnus-group-list-map) + "k" gnus-group-list-flush + "z" gnus-group-list-flush + "s" gnus-group-list-flush + "u" gnus-group-list-flush + "A" gnus-group-list-flush + "m" gnus-group-list-flush + "M" gnus-group-list-flush + "l" gnus-group-list-flush + "c" gnus-group-list-flush + "?" gnus-group-list-flush) + +(gnus-define-keys (gnus-group-list-plus-map "p" gnus-group-list-map) + "k" gnus-group-list-plus + "z" gnus-group-list-plus + "s" gnus-group-list-plus + "u" gnus-group-list-plus + "A" gnus-group-list-plus + "m" gnus-group-list-plus + "M" gnus-group-list-plus + "l" gnus-group-list-plus + "c" gnus-group-list-plus + "?" gnus-group-list-plus) + +(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) + "f" gnus-score-flush-cache) + +(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) + "c" gnus-group-fetch-charter + "C" gnus-group-fetch-control + "d" gnus-group-describe-group + "f" gnus-group-fetch-faq + "v" gnus-version) + +(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) + "l" gnus-group-set-current-level + "t" gnus-group-unsubscribe-current-group + "s" gnus-group-unsubscribe-group + "k" gnus-group-kill-group + "y" gnus-group-yank-group + "w" gnus-group-kill-region + "\C-k" gnus-group-kill-level + "z" gnus-group-kill-all-zombies) + +(defun gnus-topic-mode-p () + "Return non-nil in `gnus-topic-mode'." + (and (boundp 'gnus-topic-mode) + (symbol-value 'gnus-topic-mode))) (defun gnus-group-make-menu-bar () (gnus-turn-off-edit-menu 'group) @@ -651,40 +741,77 @@ (easy-menu-define gnus-group-reading-menu gnus-group-mode-map "" - '("Group" - ["Read" gnus-group-read-group (gnus-group-group-name)] - ["Select" gnus-group-select-group (gnus-group-group-name)] + `("Group" + ["Read" gnus-group-read-group + :included (not (gnus-topic-mode-p)) + :active (gnus-group-group-name)] + ["Read " gnus-topic-read-group + :included (gnus-topic-mode-p)] + ["Select" gnus-group-select-group + :included (not (gnus-topic-mode-p)) + :active (gnus-group-group-name)] + ["Select " gnus-topic-select-group + :included (gnus-topic-mode-p)] ["See old articles" (gnus-group-select-group 'all) :keys "C-u SPC" :active (gnus-group-group-name)] - ["Catch up" gnus-group-catchup-current :active (gnus-group-group-name) - :help "Mark unread articles in the current group as read"] + ["Catch up" gnus-group-catchup-current + :included (not (gnus-topic-mode-p)) + :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Mark unread articles in the current group as read"))] + ["Catch up " gnus-topic-catchup-articles + :included (gnus-topic-mode-p) + ,@(if (featurep 'xemacs) nil + '(:help "Mark unread articles in the current group or topic as read"))] ["Catch up all articles" gnus-group-catchup-current-all (gnus-group-group-name)] ["Check for new articles" gnus-group-get-new-news-this-group + :included (not (gnus-topic-mode-p)) :active (gnus-group-group-name) - :help "Check for new messages in current group"] + ,@(if (featurep 'xemacs) nil + '(:help "Check for new messages in current group"))] + ["Check for new articles " gnus-topic-get-new-news-this-topic + :included (gnus-topic-mode-p) + ,@(if (featurep 'xemacs) nil + '(:help "Check for new messages in current group or topic"))] ["Toggle subscription" gnus-group-unsubscribe-current-group (gnus-group-group-name)] ["Kill" gnus-group-kill-group :active (gnus-group-group-name) - :help "Kill (remove) current group"] + ,@(if (featurep 'xemacs) nil + '(:help "Kill (remove) current group"))] ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] ["Describe" gnus-group-describe-group :active (gnus-group-group-name) - :help "Display description of the current group"] + ,@(if (featurep 'xemacs) nil + '(:help "Display description of the current group"))] ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] + ["Fetch charter" gnus-group-fetch-charter + :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Display the charter of the current group"))] + ["Fetch control message" gnus-group-fetch-control + :active (gnus-group-group-name) + ,@(if (featurep 'xemacs) nil + '(:help "Display the archived control message for the current group"))] ;; Actually one should check, if any of the marked groups gives t for ;; (gnus-check-backend-function 'request-expire-articles ...) ["Expire articles" gnus-group-expire-articles - (or (and (gnus-group-group-name) - (gnus-check-backend-function - 'request-expire-articles - (gnus-group-group-name))) gnus-group-marked)] - ["Set group level" gnus-group-set-current-level + :included (not (gnus-topic-mode-p)) + :active (or (and (gnus-group-group-name) + (gnus-check-backend-function + 'request-expire-articles + (gnus-group-group-name))) gnus-group-marked)] + ["Expire articles " gnus-topic-expire-articles + :included (gnus-topic-mode-p)] + ["Set group level..." gnus-group-set-current-level (gnus-group-group-name)] ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] ["Customize" gnus-group-customize (gnus-group-group-name)] ("Edit" ["Parameters" gnus-group-edit-group-parameters - (gnus-group-group-name)] + :included (not (gnus-topic-mode-p)) + :active (gnus-group-group-name)] + ["Parameters " gnus-topic-edit-parameters + :included (gnus-topic-mode-p)] ["Select method" gnus-group-edit-group-method (gnus-group-group-name)] ["Info" gnus-group-edit-group (gnus-group-group-name)] @@ -715,22 +842,25 @@ ["Sort by score" gnus-group-sort-groups-by-score t] ["Sort by level" gnus-group-sort-groups-by-level t] ["Sort by unread" gnus-group-sort-groups-by-unread t] - ["Sort by name" gnus-group-sort-groups-by-alphabet t]) + ["Sort by name" gnus-group-sort-groups-by-alphabet t] + ["Sort by real name" gnus-group-sort-groups-by-real-name t]) ("Sort process/prefixed" ["Default sort" gnus-group-sort-selected-groups - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + (not (gnus-topic-mode-p))] ["Sort by method" gnus-group-sort-selected-groups-by-method - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + (not (gnus-topic-mode-p))] ["Sort by rank" gnus-group-sort-selected-groups-by-rank - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + (not (gnus-topic-mode-p))] ["Sort by score" gnus-group-sort-selected-groups-by-score - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + (not (gnus-topic-mode-p))] ["Sort by level" gnus-group-sort-selected-groups-by-level - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + (not (gnus-topic-mode-p))] ["Sort by unread" gnus-group-sort-selected-groups-by-unread - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + (not (gnus-topic-mode-p))] ["Sort by name" gnus-group-sort-selected-groups-by-alphabet - (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]) + (not (gnus-topic-mode-p))] + ["Sort by real name" gnus-group-sort-selected-groups-by-real-name + (not (gnus-topic-mode-p))]) ("Mark" ["Mark group" gnus-group-mark-group (and (gnus-group-group-name) @@ -740,27 +870,30 @@ (memq (gnus-group-group-name) gnus-group-marked))] ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] ["Mark regexp..." gnus-group-mark-regexp t] - ["Mark region" gnus-group-mark-region t] + ["Mark region" gnus-group-mark-region :active (gnus-mark-active-p)] ["Mark buffer" gnus-group-mark-buffer t] ["Execute command" gnus-group-universal-argument (or gnus-group-marked (gnus-group-group-name))]) ("Subscribe" - ["Subscribe to a group" gnus-group-unsubscribe-group t] - ["Kill all newsgroups in region" gnus-group-kill-region t] + ["Subscribe to a group..." gnus-group-unsubscribe-group t] + ["Kill all newsgroups in region" gnus-group-kill-region + :active (gnus-mark-active-p)] ["Kill all zombie groups" gnus-group-kill-all-zombies gnus-zombie-list] ["Kill all groups on level..." gnus-group-kill-level t]) ("Foreign groups" - ["Make a foreign group" gnus-group-make-group t] - ["Add a directory group" gnus-group-make-directory-group t] + ["Make a foreign group..." gnus-group-make-group t] + ["Add a directory group..." gnus-group-make-directory-group t] ["Add the help group" gnus-group-make-help-group t] ["Add the archive group" gnus-group-make-archive-group t] - ["Make a doc group" gnus-group-make-doc-group t] - ["Make a web group" gnus-group-make-web-group t] - ["Make a kiboze group" gnus-group-make-kiboze-group t] - ["Make a virtual group" gnus-group-make-empty-virtual t] - ["Add a group to a virtual" gnus-group-add-to-virtual t] - ["Rename group" gnus-group-rename-group + ["Make a doc group..." gnus-group-make-doc-group t] + ["Make a web group..." gnus-group-make-web-group t] + ["Make a kiboze group..." gnus-group-make-kiboze-group t] + ["Make a virtual group..." gnus-group-make-empty-virtual t] + ["Add a group to a virtual..." gnus-group-add-to-virtual t] + ["Make an ephemeral group..." gnus-group-read-ephemeral-group t] + ["Make an RSS group..." gnus-group-make-rss-group t] + ["Rename group..." gnus-group-rename-group (gnus-check-backend-function 'request-rename-group (gnus-group-group-name))] ["Delete group" gnus-group-delete-group @@ -774,9 +907,12 @@ ["Next unread same level" gnus-group-next-unread-group-same-level t] ["Previous unread same level" gnus-group-prev-unread-group-same-level t] - ["Jump to group" gnus-group-jump-to-group t] + ["Jump to group..." gnus-group-jump-to-group t] ["First unread group" gnus-group-first-unread-group t] ["Best unread group" gnus-group-best-unread-group t]) + ("Sieve" + ["Generate" gnus-sieve-generate t] + ["Generate and update" gnus-sieve-update t]) ["Delete bogus groups" gnus-group-check-bogus-groups t] ["Find new newsgroups" gnus-group-find-new-groups t] ["Transpose" gnus-group-transpose-groups @@ -785,7 +921,7 @@ (easy-menu-define gnus-group-misc-menu gnus-group-mode-map "" - '("Misc" + `("Gnus" ("SOUP" ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] ["Send replies" gnus-soup-send-replies @@ -794,13 +930,20 @@ ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) ["Send a mail" gnus-group-mail t] - ["Post an article..." gnus-group-post-news t] + ["Send a message (mail or news)" gnus-group-post-news t] + ["Create a local message" gnus-group-news t] ["Check for new news" gnus-group-get-new-news - :help "Get newly arrived articles"] + ,@(if (featurep 'xemacs) '(t) + '(:help "Get newly arrived articles")) + ] + ["Send queued messages" gnus-delay-send-queue + ,@(if (featurep 'xemacs) '(t) + '(:help "Send all messages that are scheduled to be sent now")) + ] ["Activate all groups" gnus-activate-all-groups t] ["Restart Gnus" gnus-group-restart t] ["Read init file" gnus-group-read-init-file t] - ["Browse foreign server" gnus-group-browse-foreign-server t] + ["Browse foreign server..." gnus-group-browse-foreign-server t] ["Enter server buffer" gnus-group-enter-server-mode t] ["Expire all expirable articles" gnus-group-expire-all-groups t] ["Generate any kiboze groups" nnkiboze-generate-groups t] @@ -813,7 +956,8 @@ ["Toggle topics" gnus-topic-mode t] ["Send a bug report" gnus-bug t] ["Exit from Gnus" gnus-group-exit - :help "Quit reading news"] + ,@(if (featurep 'xemacs) '(t) + '(:help "Quit reading news"))] ["Exit without saving" gnus-group-quit t])) (gnus-run-hooks 'gnus-group-menu-hook))) @@ -828,7 +972,8 @@ (default-value 'tool-bar-mode) (not gnus-group-toolbar-map)) (setq gnus-group-toolbar-map - (let ((tool-bar-map (make-sparse-keymap))) + (let ((tool-bar-map (make-sparse-keymap)) + (load-path (mm-image-load-path))) (tool-bar-add-item-from-menu 'gnus-group-get-new-news "get-news" gnus-group-mode-map) (tool-bar-add-item-from-menu @@ -891,6 +1036,7 @@ (defun gnus-update-group-mark-positions () (save-excursion (let ((gnus-process-mark ?\200) + (gnus-group-update-hook nil) (gnus-group-marked '("dummy.group")) (gnus-active-hashtb (make-vector 10 0)) (topic "")) @@ -932,7 +1078,7 @@ (when gnus-carpal (gnus-carpal-setup-buffer 'group)))) -(defsubst gnus-group-name-charset (method group) +(defun gnus-group-name-charset (method group) (if (null method) (setq method (gnus-find-method-for-group group))) (let ((item (assoc method gnus-group-name-charset-method-alist)) @@ -946,7 +1092,8 @@ result (cdr item)))) result))) -(defsubst gnus-group-name-decode (string charset) +(defun gnus-group-name-decode (string charset) + ;; Fixme: Don't decode in unibyte mode. (if (and string charset (featurep 'mule)) (mm-decode-coding-string string charset) string)) @@ -1028,18 +1175,35 @@ (interactive "nList groups on level: \nP") (gnus-group-list-groups level all level)) -(defun gnus-group-prepare-flat (level &optional all lowest regexp) +(defun gnus-group-prepare-logic (group test) + (or (and gnus-group-listed-groups + (null gnus-group-list-option) + (member group gnus-group-listed-groups)) + (cond + ((null gnus-group-listed-groups) test) + ((null gnus-group-list-option) test) + (t (and (member group gnus-group-listed-groups) + (if (eq gnus-group-list-option 'flush) + (not test) + test)))))) + +(defun gnus-group-prepare-flat (level &optional predicate lowest regexp) "List all newsgroups with unread articles of level LEVEL or lower. -If ALL is non-nil, list groups that have no unread articles. +If PREDICATE is a function, list groups that the function returns non-nil; +if it is t, list groups that have no unread articles. If LOWEST is non-nil, list all newsgroups of level LOWEST or higher. -If REGEXP, only list groups matching REGEXP." +If REGEXP is a function, list dead groups that the function returns non-nil; +if it is a string, only list groups matching REGEXP." (set-buffer gnus-group-buffer) (let ((buffer-read-only nil) (newsrc (cdr gnus-newsrc-alist)) (lowest (or lowest 1)) + (not-in-list (and gnus-group-listed-groups + (copy-sequence gnus-group-listed-groups))) info clevel unread group params) (erase-buffer) - (when (< lowest gnus-level-zombie) + (when (or (< lowest gnus-level-zombie) + gnus-group-listed-groups) ;; List living groups. (while newsrc (setq info (car newsrc) @@ -1047,41 +1211,60 @@ params (gnus-info-params info) newsrc (cdr newsrc) unread (car (gnus-gethash group gnus-newsrc-hashtb))) - (and unread ; This group might be unchecked - (or (not regexp) - (string-match regexp group)) - (<= (setq clevel (gnus-info-level info)) level) - (>= clevel lowest) - (or all ; We list all groups? - (if (eq unread t) ; Unactivated? - gnus-group-list-inactive-groups ; We list unactivated - (> unread 0)) ; We list groups with unread articles - (and gnus-list-groups-with-ticked-articles - (cdr (assq 'tick (gnus-info-marks info)))) + (when not-in-list + (setq not-in-list (delete group not-in-list))) + (when (gnus-group-prepare-logic + group + (and unread ; This group might be unchecked + (or (not (stringp regexp)) + (string-match regexp group)) + (<= (setq clevel (gnus-info-level info)) level) + (>= clevel lowest) + (cond + ((functionp predicate) + (funcall predicate info)) + (predicate t) ; We list all groups? + (t + (or + (if (eq unread t) ; Unactivated? + gnus-group-list-inactive-groups + ; We list unactivated + (> unread 0)) + ; We list groups with unread articles + (and gnus-list-groups-with-ticked-articles + (cdr (assq 'tick (gnus-info-marks info)))) ; And groups with tickeds - ;; Check for permanent visibility. - (and gnus-permanently-visible-groups - (string-match gnus-permanently-visible-groups - group)) - (memq 'visible params) - (cdr (assq 'visible params))) - (gnus-group-insert-group-line - group (gnus-info-level info) - (gnus-info-marks info) unread (gnus-info-method info))))) + ;; Check for permanent visibility. + (and gnus-permanently-visible-groups + (string-match gnus-permanently-visible-groups + group)) + (memq 'visible params) + (cdr (assq 'visible params))))))) + (gnus-group-insert-group-line + group (gnus-info-level info) + (gnus-info-marks info) unread (gnus-info-method info))))) ;; List dead groups. - (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie) - (gnus-group-prepare-flat-list-dead - (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) - gnus-level-zombie ?Z - regexp)) - (and (>= level gnus-level-killed) (<= lowest gnus-level-killed) - (gnus-group-prepare-flat-list-dead - (setq gnus-killed-list (sort gnus-killed-list 'string<)) - gnus-level-killed ?K regexp)) + (when (or gnus-group-listed-groups + (and (>= level gnus-level-zombie) + (<= lowest gnus-level-zombie))) + (gnus-group-prepare-flat-list-dead + (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) + gnus-level-zombie ?Z + regexp)) + (when not-in-list + (dolist (group gnus-zombie-list) + (setq not-in-list (delete group not-in-list)))) + (when (or gnus-group-listed-groups + (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))) + (gnus-group-prepare-flat-list-dead + (gnus-union + not-in-list + (setq gnus-killed-list (sort gnus-killed-list 'string<))) + gnus-level-killed ?K regexp)) (gnus-group-set-mode-line) - (setq gnus-group-list-mode (cons level all)) + (setq gnus-group-list-mode (cons level predicate)) (gnus-run-hooks 'gnus-group-prepare-hook) t)) @@ -1090,35 +1273,38 @@ ;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does ;; this by ignoring the group format specification altogether. (let (group) - (if regexp - ;; This loop is used when listing groups that match some - ;; regexp. + (if (> (length groups) gnus-group-listing-limit) (while groups (setq group (pop groups)) - (when (string-match regexp group) + (when (gnus-group-prepare-logic + group + (or (not regexp) + (and (stringp regexp) (string-match regexp group)) + (and (functionp regexp) (funcall regexp group)))) (gnus-add-text-properties (point) (prog1 (1+ (point)) (insert " " mark " *: " - (gnus-group-name-decode group - (gnus-group-name-charset - nil group)) + (gnus-group-decoded-name group) "\n")) (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 'gnus-unread t 'gnus-level level)))) - ;; This loop is used when listing all groups. (while groups (setq group (pop groups)) - (gnus-add-text-properties - (point) (prog1 (1+ (point)) - (insert " " mark " *: " - (gnus-group-name-decode group - (gnus-group-name-charset - nil group)) - "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) - 'gnus-unread t - 'gnus-level level)))))) + (when (gnus-group-prepare-logic + group + (or (not regexp) + (and (stringp regexp) (string-match regexp group)) + (and (functionp regexp) (funcall regexp group)))) + (gnus-group-insert-group-line + group level nil + (let ((active (gnus-active group))) + (if active + (if (zerop (cdr active)) + 0 + (- (1+ (cdr active)) (car active))) + nil)) + (gnus-method-simplify (gnus-find-method-for-group group)))))))) (defun gnus-group-update-group-line () "Update the current line in the group buffer." @@ -1161,7 +1347,19 @@ 0 (- (1+ (cdr active)) (car active))) nil) - nil)))) + (gnus-method-simplify (gnus-find-method-for-group group)))))) + +(defun gnus-number-of-unseen-articles-in-group (group) + (let* ((info (nth 2 (gnus-group-entry group))) + (marked (gnus-info-marks info)) + (seen (cdr (assq 'seen marked))) + (active (gnus-active group))) + (if (not active) + 0 + (length (gnus-uncompress-range + (gnus-range-difference + (gnus-range-difference (list active) (gnus-info-read info)) + seen)))))) (defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level gnus-tmp-marked number @@ -1191,6 +1389,9 @@ (gnus-tmp-qualified-group (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group) group-name-charset)) + (gnus-tmp-comment + (or (gnus-group-get-parameter gnus-tmp-group 'comment t) + gnus-tmp-group)) (gnus-tmp-newsgroup-description (if gnus-description-hashtb (or (gnus-group-name-decode @@ -1215,6 +1416,11 @@ (zerop number) (cdr (assq 'tick gnus-tmp-marked))) ?* ? )) + (gnus-tmp-summary-live + (if (and (not gnus-group-is-exiting-p) + (gnus-buffer-live-p (gnus-summary-buffer-name + gnus-tmp-group))) + ?* ? )) (gnus-tmp-process-marked (if (member gnus-tmp-group gnus-group-marked) gnus-process-mark ? )) @@ -1229,7 +1435,9 @@ (point) (prog1 (1+ (point)) ;; Insert the text. - (eval gnus-group-line-format-spec)) + (let ((gnus-tmp-group (gnus-group-name-decode + gnus-tmp-group group-name-charset))) + (eval gnus-group-line-format-spec))) `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb) gnus-unread ,(if (numberp number) (string-to-int gnus-tmp-number-of-unread) @@ -1248,7 +1456,7 @@ "Highlight the current line according to `gnus-group-highlight'." (let* ((list gnus-group-highlight) (p (point)) - (end (progn (end-of-line) (point))) + (end (gnus-point-at-eol)) ;; now find out where the line starts and leave point there. (beg (progn (beginning-of-line) (point))) (group (gnus-group-group-name)) @@ -1257,11 +1465,15 @@ (active (gnus-active group)) (total (if active (1+ (- (cdr active) (car active))) 0)) (info (nth 2 entry)) - (method (gnus-server-get-method group (gnus-info-method info))) + (method (inline (gnus-server-get-method group (gnus-info-method info)))) (marked (gnus-info-marks info)) - (mailp (memq 'mail (assoc (symbol-name - (car (or method gnus-select-method))) - gnus-valid-select-methods))) + (mailp (apply 'append + (mapcar + (lambda (x) + (memq x (assoc (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + '(mail post-mail)))) (level (or (gnus-info-level info) gnus-level-killed)) (score (or (gnus-info-score info) 0)) (ticked (gnus-range-length (cdr (assq 'tick marked)))) @@ -1526,9 +1738,11 @@ (interactive "sMark (regexp): ") (let ((alist (cdr gnus-newsrc-alist)) group) - (while alist - (when (string-match regexp (setq group (gnus-info-group (pop alist)))) - (gnus-group-set-mark group)))) + (save-excursion + (while alist + (when (string-match regexp (setq group (gnus-info-group (pop alist)))) + (gnus-group-jump-to-group group) + (gnus-group-set-mark group))))) (gnus-group-position-point)) (defun gnus-group-remove-mark (group &optional test-marked) @@ -1582,7 +1796,7 @@ (setq n (1- n)) (gnus-group-next-group way))) (nreverse groups))) - ((gnus-region-active-p) + ((and (gnus-region-active-p) (mark)) ;; Work on the region between point and mark. (let ((max (max (point) (mark))) groups) @@ -1667,9 +1881,12 @@ (defun gnus-group-select-group (&optional all) "Select this newsgroup. No article is selected automatically. +If the group is opened, just switch the summary buffer. If ALL is non-nil, already read articles become readable. If ALL is a number, fetch this number of articles." (interactive "P") + (when (and (eobp) (not (gnus-group-group-name))) + (forward-line -1)) (gnus-group-read-group all t)) (defun gnus-group-quick-select-group (&optional all) @@ -1712,13 +1929,13 @@ (gnus-group-prefixed-name group method) method))) ;;;###autoload -(defun gnus-fetch-group (group) +(defun gnus-fetch-group (group &optional articles) "Start Gnus if necessary and enter GROUP. Returns whether the fetching was successful or not." (interactive (list (completing-read "Group name: " gnus-active-hashtb))) (unless (get-buffer gnus-group-buffer) (gnus-no-server)) - (gnus-group-read-group nil nil group)) + (gnus-group-read-group articles nil group)) ;;;###autoload (defun gnus-fetch-group-other-frame (group) @@ -1735,19 +1952,48 @@ (defvar gnus-ephemeral-group-server 0) +(defcustom gnus-large-ephemeral-newsgroup 200 + "The number of articles which indicates a large ephemeral newsgroup. +Same as `gnus-large-newsgroup', but only used for ephemeral newsgroups. + +If the number of articles in a newsgroup is greater than this value, +confirmation is required for selecting the newsgroup. If it is nil, no +confirmation is required." + :group 'gnus-group-select + :type '(choice (const :tag "No limit" nil) + integer)) + +(defcustom gnus-fetch-old-ephemeral-headers nil + "Same as `gnus-fetch-old-headers', but only used for ephemeral newsgroups." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const some) + number + (sexp :menu-tag "other" t))) + ;; Enter a group that is not in the group buffer. Non-nil is returned ;; if selection was successful. (defun gnus-group-read-ephemeral-group (group method &optional activate quit-config request-only - select-articles) + select-articles + parameters) "Read GROUP from METHOD as an ephemeral group. If ACTIVATE, request the group first. If QUIT-CONFIG, use that window configuration when exiting from the ephemeral group. If REQUEST-ONLY, don't actually read the group; just request it. If SELECT-ARTICLES, only select those articles. +If PARAMETERS, use those as the group parameters. Return the name of the group if selection was successful." + (interactive + (list + ;; (gnus-read-group "Group name: ") + (completing-read + "Group: " gnus-active-hashtb + nil nil nil + 'gnus-group-history) + (gnus-read-method "From method: "))) ;; Transform the select method into a unique server. (when (stringp method) (setq method (gnus-server-to-method method))) @@ -1756,15 +2002,19 @@ (,(intern (format "%s-address" (car method))) ,(cadr method)) ,@(cddr method))) (let ((group (if (gnus-group-foreign-p group) group - (gnus-group-prefixed-name group method)))) + (gnus-group-prefixed-name (gnus-group-real-name group) + method)))) (gnus-sethash group `(-1 nil (,group ,gnus-level-default-subscribed nil nil ,method - ((quit-config . - ,(if quit-config quit-config - (cons gnus-summary-buffer - gnus-current-window-configuration)))))) + ,(cons + (if quit-config + (cons 'quit-config quit-config) + (cons 'quit-config + (cons gnus-summary-buffer + gnus-current-window-configuration))) + parameters))) gnus-newsrc-hashtb) (push method gnus-ephemeral-servers) (set-buffer gnus-group-buffer) @@ -1778,7 +2028,10 @@ (if request-only group (condition-case () - (when (gnus-group-read-group t t group select-articles) + (when (let ((gnus-large-newsgroup gnus-large-ephemeral-newsgroup) + (gnus-fetch-old-headers + gnus-fetch-old-ephemeral-headers)) + (gnus-group-read-group t t group select-articles)) group) ;;(error nil) (quit @@ -1788,11 +2041,12 @@ (defun gnus-group-jump-to-group (group) "Jump to newsgroup GROUP." (interactive - (list (completing-read - "Group: " gnus-active-hashtb nil - (gnus-read-active-file-p) - nil - 'gnus-group-history))) + (list (mm-string-make-unibyte + (completing-read + "Group: " gnus-active-hashtb nil + (gnus-read-active-file-p) + gnus-group-jump-to-group-prompt + 'gnus-group-history)))) (when (equal group "") (error "Empty group name")) @@ -1937,7 +2191,7 @@ (forward-line 1)) (when best-point (goto-char best-point)) - (gnus-summary-position-point) + (gnus-group-position-point) (and best-point (gnus-group-group-name)))) (defun gnus-group-first-unread-group () @@ -2000,7 +2254,7 @@ (forward-line -1) (gnus-group-position-point) - ;; Load the backend and try to make the backend create + ;; Load the back end and try to make the back end create ;; the group as well. (when (assoc (symbol-name (setq backend (car (gnus-server-get-method nil meth)))) @@ -2008,7 +2262,9 @@ (require backend)) (gnus-check-server meth) (when (gnus-check-backend-function 'request-create-group nname) - (gnus-request-create-group nname nil args)) + (unless (gnus-request-create-group nname nil args) + (error "Could not create group on server: %s" + (nnheader-get-report backend)))) t)) (defun gnus-group-delete-groups (&optional arg) @@ -2023,19 +2279,23 @@ (lambda (group) (gnus-group-delete-group group nil t)))))) +(defvar gnus-cache-active-altered) + (defun gnus-group-delete-group (group &optional force no-prompt) "Delete the current group. Only meaningful with editable groups. If FORCE (the prefix) is non-nil, all the articles in the group will be deleted. This is \"deleted\" as in \"removed forever from the face of the Earth\". There is no undo. The user will be prompted before -doing the deletion." +doing the deletion. +Note that you also have to specify FORCE if you want the group to +be removed from the server, even when it's empty." (interactive (list (gnus-group-group-name) current-prefix-arg)) (unless group - (error "No group to rename")) + (error "No group to delete")) (unless (gnus-check-backend-function 'request-delete-group group) - (error "This backend does not support group deletion")) + (error "This back end does not support group deletion")) (prog1 (if (and (not no-prompt) (not (gnus-yes-or-no-p @@ -2050,6 +2310,10 @@ (gnus-group-goto-group group) (gnus-group-kill-group 1 t) (gnus-sethash group nil gnus-active-hashtb) + (if (boundp 'gnus-cache-active-hashtb) + (when gnus-cache-active-hashtb + (gnus-sethash group nil gnus-cache-active-hashtb) + (setq gnus-cache-active-altered t))) t)) (gnus-group-position-point))) @@ -2063,12 +2327,12 @@ (progn (unless (gnus-check-backend-function 'request-rename-group (gnus-group-group-name)) - (error "This backend does not support renaming groups")) + (error "This back end does not support renaming groups")) (gnus-read-group "Rename group to: " (gnus-group-real-name (gnus-group-group-name)))))) (unless (gnus-check-backend-function 'request-rename-group group) - (error "This backend does not support renaming groups")) + (error "This back end does not support renaming groups")) (unless group (error "No group to rename")) (when (equal (gnus-group-real-name group) new-name) @@ -2084,6 +2348,9 @@ (gnus-group-real-name new-name) (gnus-info-method (gnus-get-info group))))) + (when (gnus-active new-name) + (error "The group %s already exists" new-name)) + (gnus-message 6 "Renaming group %s to %s..." group new-name) (prog1 (if (progn @@ -2132,7 +2399,17 @@ (t "group info")) (gnus-group-decoded-name group)) `(lambda (form) - (gnus-group-edit-group-done ',part ,group form))))) + (gnus-group-edit-group-done ',part ,group form))) + (local-set-key + "\C-c\C-i" + (gnus-create-info-command + (cond + ((eq part 'method) + "(gnus)Select Methods") + ((eq part 'params) + "(gnus)Group Parameters") + (t + "(gnus)Group Info")))))) (defun gnus-group-edit-group-method (group) "Edit the select method of GROUP." @@ -2193,20 +2470,33 @@ (setcar entry (eval (cadar entry))))) (gnus-group-make-group group method)) -(defun gnus-group-make-help-group () - "Create the Gnus documentation group." +(defun gnus-group-make-help-group (&optional noerror) + "Create the Gnus documentation group. +Optional argument NOERROR modifies the behavior of this function when the +group already exists: +- if not given, and error is signaled, +- if t, stay silent, +- if anything else, just print a message." (interactive) (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help"))) (file (nnheader-find-etc-directory "gnus-tut.txt" t))) - (when (gnus-gethash name gnus-newsrc-hashtb) - (error "Documentation group already exists")) - (if (not file) - (gnus-message 1 "Couldn't find doc group") - (gnus-group-make-group - (gnus-group-real-name name) - (list 'nndoc "gnus-help" - (list 'nndoc-address file) - (list 'nndoc-article-type 'mbox))))) + (if (gnus-gethash name gnus-newsrc-hashtb) + (cond ((eq noerror nil) + (error "Documentation group already exists")) + ((eq noerror t) + ;; stay silent + ) + (t + (gnus-message 1 "Documentation group already exists"))) + ;; else: + (if (not file) + (gnus-message 1 "Couldn't find doc group") + (gnus-group-make-group + (gnus-group-real-name name) + (list 'nndoc "gnus-help" + (list 'nndoc-address file) + (list 'nndoc-article-type 'mbox)))) + )) (gnus-group-position-point)) (defun gnus-group-make-doc-group (file type) @@ -2271,12 +2561,41 @@ (nnweb-type ,(intern type)) (nnweb-ephemeral-p t)))) (if solid - (gnus-group-make-group group "nnweb" "" `(,(intern type) ,search)) + (progn + (gnus-pull 'nnweb-ephemeral-p method) + (gnus-group-make-group group method)) (gnus-group-read-ephemeral-group group method t (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) +(eval-when-compile + (defvar nnrss-group-alist) + (defun nnrss-discover-feed (arg)) + (defun nnrss-save-server-data (arg))) +(defun gnus-group-make-rss-group (&optional url) + "Given a URL, discover if there is an RSS feed. +If there is, use Gnus to create an nnrss group" + (interactive) + (require 'nnrss) + (if (not url) + (setq url (read-from-minibuffer "URL to Search for RSS: "))) + (let ((feedinfo (nnrss-discover-feed url))) + (if feedinfo + (let ((title (read-from-minibuffer "Title: " + (cdr (assoc 'title + feedinfo)))) + (desc (read-from-minibuffer "Description: " + (cdr (assoc 'description + feedinfo)))) + (href (cdr (assoc 'href feedinfo)))) + (push (list title href desc) + nnrss-group-alist) + (gnus-group-unsubscribe-group + (concat "nnrss:" title)) + (nnrss-save-server-data nil)) + (error "No feeds found for %s" url)))) + (defvar nnwarchive-type-definition) (defvar gnus-group-warchive-type-history nil) (defvar gnus-group-warchive-login-history nil) @@ -2353,7 +2672,7 @@ (gnus-group-real-name group) (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) -(eval-when-compile (defvar nnkiboze-score-file)) +(defvar nnkiboze-score-file) (defun gnus-group-make-kiboze-group (group address scores) "Create an nnkiboze group. The user will be prompted for a name, a regexp to match groups, and @@ -2504,6 +2823,7 @@ (interactive (list gnus-group-sort-function current-prefix-arg)) (funcall gnus-group-sort-alist-function (gnus-make-sort-function func) reverse) + (gnus-group-unmark-all-groups) (gnus-group-list-groups) (gnus-dribble-touch)) @@ -2526,6 +2846,12 @@ (interactive "P") (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse)) +(defun gnus-group-sort-groups-by-real-name (&optional reverse) + "Sort the group buffer alphabetically by real (unprefixed) group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-real-name reverse)) + (defun gnus-group-sort-groups-by-unread (&optional reverse) "Sort the group buffer by number of unread articles. If REVERSE, sort in reverse order." @@ -2551,11 +2877,17 @@ (gnus-group-sort-groups 'gnus-group-sort-by-rank reverse)) (defun gnus-group-sort-groups-by-method (&optional reverse) - "Sort the group buffer alphabetically by backend name. + "Sort the group buffer alphabetically by back end name. If REVERSE, sort in reverse order." (interactive "P") (gnus-group-sort-groups 'gnus-group-sort-by-method reverse)) +(defun gnus-group-sort-groups-by-server (&optional reverse) + "Sort the group buffer alphabetically by server name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-server reverse)) + ;;; Selected group sorting. (defun gnus-group-sort-selected-groups (n func &optional reverse) @@ -2564,7 +2896,9 @@ (let ((groups (gnus-group-process-prefix n))) (funcall gnus-group-sort-selected-function groups (gnus-make-sort-function func) reverse) - (gnus-group-list-groups))) + (gnus-group-unmark-all-groups) + (gnus-group-list-groups) + (gnus-dribble-touch))) (defun gnus-group-sort-selected-flat (groups func reverse) (let (entries infos) @@ -2596,6 +2930,13 @@ (interactive (gnus-interactive "P\ny")) (gnus-group-sort-selected-groups n 'gnus-group-sort-by-alphabet reverse)) +(defun gnus-group-sort-selected-groups-by-real-name (&optional n reverse) + "Sort the group buffer alphabetically by real group name. +Obeys the process/prefix convention. If REVERSE (the symbolic prefix), +sort in reverse order." + (interactive (gnus-interactive "P\ny")) + (gnus-group-sort-selected-groups n 'gnus-group-sort-by-real-name reverse)) + (defun gnus-group-sort-selected-groups-by-unread (&optional n reverse) "Sort the group buffer by number of unread articles. Obeys the process/prefix convention. If REVERSE (the symbolic prefix), @@ -2625,7 +2966,7 @@ (gnus-group-sort-selected-groups n 'gnus-group-sort-by-rank reverse)) (defun gnus-group-sort-selected-groups-by-method (&optional n reverse) - "Sort the group buffer alphabetically by backend name. + "Sort the group buffer alphabetically by back end name. Obeys the process/prefix convention. If REVERSE (the symbolic prefix), sort in reverse order." (interactive (gnus-interactive "P\ny")) @@ -2654,15 +2995,24 @@ (< (gnus-info-level info1) (gnus-info-level info2))) (defun gnus-group-sort-by-method (info1 info2) - "Sort alphabetically by backend name." - (string< (symbol-name (car (gnus-find-method-for-group - (gnus-info-group info1) info1))) - (symbol-name (car (gnus-find-method-for-group - (gnus-info-group info2) info2))))) + "Sort alphabetically by back end name." + (string< (car (gnus-find-method-for-group + (gnus-info-group info1) info1)) + (car (gnus-find-method-for-group + (gnus-info-group info2) info2)))) + +(defun gnus-group-sort-by-server (info1 info2) + "Sort alphabetically by server name." + (string< (gnus-method-to-full-server-name + (gnus-find-method-for-group + (gnus-info-group info1) info1)) + (gnus-method-to-full-server-name + (gnus-find-method-for-group + (gnus-info-group info2) info2)))) (defun gnus-group-sort-by-score (info1 info2) "Sort by group score." - (< (gnus-info-score info1) (gnus-info-score info2))) + (> (gnus-info-score info1) (gnus-info-score info2))) (defun gnus-group-sort-by-rank (info1 info2) "Sort by level and score." @@ -2702,13 +3052,22 @@ (defun gnus-info-clear-data (info) "Clear all marks and read ranges from INFO." - (let ((group (gnus-info-group info))) + (let ((group (gnus-info-group info)) + action) + (dolist (el (gnus-info-marks info)) + (push `(,(cdr el) add (,(car el))) action)) + (push `(,(gnus-info-read info) add (read)) action) (gnus-undo-register `(progn + (gnus-request-set-mark ,group ',action) (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) (when (gnus-group-goto-group ,group) + (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t) (gnus-group-update-group-line)))) + (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el))) + action)) + (gnus-request-set-mark group action) (gnus-info-set-read info nil) (when (gnus-info-marks info) (gnus-info-set-marks info nil)))) @@ -2768,34 +3127,38 @@ The return value is the number of articles that were marked as read, or nil if no action could be taken." (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) - (num (car entry))) + (num (car entry)) + (marks (nth 3 (nth 2 entry))) + (unread (gnus-list-of-unread-articles group))) ;; Remove entries for this group. (nnmail-purge-split-history (gnus-group-real-name group)) ;; Do the updating only if the newsgroup isn't killed. (if (not (numberp (car entry))) (gnus-message 1 "Can't catch up %s; non-active group" group) + (gnus-update-read-articles group nil) + (when all + ;; Nix out the lists of marks and dormants. + (gnus-request-set-mark group (list (list (cdr (assq 'tick marks)) + 'del '(tick)) + (list (cdr (assq 'dormant marks)) + 'del '(dormant)))) + (setq unread (gnus-uncompress-range + (gnus-range-add (gnus-range-add + unread (cdr (assq 'dormant marks))) + (cdr (assq 'tick marks))))) + (gnus-add-marked-articles group 'tick nil nil 'force) + (gnus-add-marked-articles group 'dormant nil nil 'force)) ;; Do auto-expirable marks if that's required. (when (gnus-group-auto-expirable-p group) - (gnus-add-marked-articles - group 'expire (gnus-list-of-unread-articles group)) - (when all - (let ((marks (nth 3 (nth 2 entry)))) - (gnus-add-marked-articles - group 'expire (gnus-uncompress-range (cdr (assq 'tick marks)))) - (gnus-add-marked-articles - group 'expire (gnus-uncompress-range (cdr (assq 'tick marks))))))) - (when entry - (gnus-update-read-articles group nil) - ;; Also nix out the lists of marks and dormants. - (when all - (gnus-add-marked-articles group 'tick nil nil 'force) - (gnus-add-marked-articles group 'dormant nil nil 'force)) - (let ((gnus-newsgroup-name group)) - (gnus-run-hooks 'gnus-group-catchup-group-hook)) - num)))) + (gnus-add-marked-articles group 'expire unread) + (gnus-request-set-mark group (list (list unread 'add '(expire))))) + (let ((gnus-newsgroup-name group)) + (gnus-run-hooks 'gnus-group-catchup-group-hook)) + num))) (defun gnus-group-expire-articles (&optional n) - "Expire all expirable articles in the current newsgroup." + "Expire all expirable articles in the current newsgroup. +Uses the process/prefix convention." (interactive "P") (let ((groups (gnus-group-process-prefix n)) group) @@ -2854,15 +3217,18 @@ (interactive (list current-prefix-arg - (string-to-int - (let ((s (read-string - (format "Level (default %s): " - (or (gnus-group-group-level) - gnus-level-default-subscribed))))) - (if (string-match "^\\s-*$" s) - (int-to-string (or (gnus-group-group-level) - gnus-level-default-subscribed)) - s))))) + (progn + (unless (gnus-group-process-prefix current-prefix-arg) + (error "No group on the current line")) + (string-to-int + (let ((s (read-string + (format "Level (default %s): " + (or (gnus-group-group-level) + gnus-level-default-subscribed))))) + (if (string-match "^\\s-*$" s) + (int-to-string (or (gnus-group-group-level) + gnus-level-default-subscribed)) + s)))))) (unless (and (>= level 1) (<= level gnus-level-killed)) (error "Invalid level: %d" level)) (let ((groups (gnus-group-process-prefix n)) @@ -2891,26 +3257,22 @@ "Toggle subscription of the current group. If given numerical prefix, toggle the N next groups." (interactive "P") - (let ((groups (gnus-group-process-prefix n)) - group) - (while groups - (setq group (car groups) - groups (cdr groups)) - (gnus-group-remove-mark group) - (gnus-group-unsubscribe-group - group - (cond - ((eq do-sub 'unsubscribe) - gnus-level-default-unsubscribed) - ((eq do-sub 'subscribe) - gnus-level-default-subscribed) - ((<= (gnus-group-group-level) gnus-level-subscribed) - gnus-level-default-unsubscribed) - (t - gnus-level-default-subscribed)) - t) - (gnus-group-update-group-line)) - (gnus-group-next-group 1))) + (dolist (group (gnus-group-process-prefix n)) + (gnus-group-remove-mark group) + (gnus-group-unsubscribe-group + group + (cond + ((eq do-sub 'unsubscribe) + gnus-level-default-unsubscribed) + ((eq do-sub 'subscribe) + gnus-level-default-subscribed) + ((<= (gnus-group-group-level) gnus-level-subscribed) + gnus-level-default-unsubscribed) + (t + gnus-level-default-subscribed)) + t) + (gnus-group-update-group-line)) + (gnus-group-next-group 1)) (defun gnus-group-unsubscribe-group (group &optional level silent) "Toggle subscription to GROUP. @@ -3026,29 +3388,27 @@ (message "Killed group %s" group)) ;; If there are lots and lots of groups to be killed, we use ;; this thing instead. - (let (entry) - (setq groups (nreverse groups)) - (while groups - (gnus-group-remove-mark (setq group (pop groups))) - (gnus-delete-line) - (push group gnus-killed-list) - (setq gnus-newsrc-alist - (delq (assoc group gnus-newsrc-alist) - gnus-newsrc-alist)) - (when gnus-group-change-level-function - (funcall gnus-group-change-level-function - group gnus-level-killed 3)) - (cond - ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) - (push (cons (car entry) (nth 2 entry)) - gnus-list-of-killed-groups) - (setcdr (cdr entry) (cdddr entry))) - ((member group gnus-zombie-list) - (setq gnus-zombie-list (delete group gnus-zombie-list)))) - ;; There may be more than one instance displayed. - (while (gnus-group-goto-group group) - (gnus-delete-line))) - (gnus-make-hashtable-from-newsrc-alist))) + (dolist (group (nreverse groups)) + (gnus-group-remove-mark group) + (gnus-delete-line) + (push group gnus-killed-list) + (setq gnus-newsrc-alist + (delq (assoc group gnus-newsrc-alist) + gnus-newsrc-alist)) + (when gnus-group-change-level-function + (funcall gnus-group-change-level-function + group gnus-level-killed 3)) + (cond + ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (push (cons (car entry) (nth 2 entry)) + gnus-list-of-killed-groups) + (setcdr (cdr entry) (cdddr entry))) + ((member group gnus-zombie-list) + (setq gnus-zombie-list (delete group gnus-zombie-list)))) + ;; There may be more than one instance displayed. + (while (gnus-group-goto-group group) + (gnus-delete-line))) + (gnus-make-hashtable-from-newsrc-alist)) (gnus-group-position-point) (if (< (length out) 2) (car out) (nreverse out)))) @@ -3113,7 +3473,7 @@ (defun gnus-group-list-all-groups (&optional arg) "List all newsgroups with level ARG or lower. -Default is gnus-level-unsubscribed, which lists all subscribed and most +Default is `gnus-level-unsubscribed', which lists all subscribed and most unsubscribed groups." (interactive "P") (gnus-group-list-groups (or arg gnus-level-unsubscribed) t)) @@ -3175,9 +3535,7 @@ (gnus-add-text-properties (point) (prog1 (1+ (point)) (insert " *: " - (gnus-group-name-decode group - (gnus-group-name-charset - nil group)) + (gnus-group-decoded-name group) "\n")) (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) 'gnus-unread t @@ -3202,6 +3560,7 @@ ;; Binding this variable will inhibit multiple fetchings ;; of the same mail source. (nnmail-fetched-sources (list t))) + (gnus-run-hooks 'gnus-get-top-new-news-hook) (gnus-run-hooks 'gnus-get-new-news-hook) ;; Read any slave files. @@ -3301,6 +3660,60 @@ (find-file file) (setq found t)))))) +(defun gnus-group-fetch-charter (group) + "Fetch the charter for the current group. +If given a prefix argument, prompt for a group." + (interactive + (list (or (when current-prefix-arg + (completing-read "Group: " gnus-active-hashtb)) + (gnus-group-group-name) + gnus-newsgroup-name))) + (unless group + (error "No group name given")) + (require 'mm-url) + (condition-case nil (require 'url-http) (error nil)) + (let ((name (mm-url-form-encode-xwfu (gnus-group-real-name group))) + url hierarchy) + (when (string-match "\\(^[^\\.]+\\)\\..*" name) + (setq hierarchy (match-string 1 name)) + (if (and (setq url (cdr (assoc hierarchy gnus-group-charter-alist))) + (if (fboundp 'url-http-file-exists-p) + (url-http-file-exists-p (eval url)) + t)) + (browse-url (eval url)) + (setq url (concat "http://" hierarchy + ".news-admin.org/charters/" name)) + (if (and (fboundp 'url-http-file-exists-p) + (url-http-file-exists-p url)) + (browse-url url) + (gnus-group-fetch-control group)))))) + +(defun gnus-group-fetch-control (group) + "Fetch the archived control messages for the current group. +If given a prefix argument, prompt for a group." + (interactive + (list (or (when current-prefix-arg + (completing-read "Group: " gnus-active-hashtb)) + (gnus-group-group-name) + gnus-newsgroup-name))) + (unless group + (error "No group name given")) + (let ((name (gnus-group-real-name group)) + hierarchy) + (when (string-match "\\(^[^\\.]+\\)\\..*" name) + (setq hierarchy (match-string 1 name)) + (if gnus-group-fetch-control-use-browse-url + (browse-url (concat "ftp://ftp.isc.org/usenet/control/" + hierarchy "/" name ".gz")) + (let ((enable-local-variables nil)) + (gnus-group-read-ephemeral-group + group + `(nndoc ,group (nndoc-address + ,(find-file-noselect + (concat "/ftp@ftp.isc.org:/usenet/control/" + hierarchy "/" name ".gz"))) + (nndoc-article-type mbox)) t nil nil)))))) + (defun gnus-group-describe-group (force &optional group) "Display a description of the current newsgroup." (interactive (list current-prefix-arg (gnus-group-group-name))) @@ -3396,7 +3809,7 @@ (pop-to-buffer obuf))) (defun gnus-group-description-apropos (regexp) - "List all newsgroups that have names or descriptions that match a regexp." + "List all newsgroups that have names or descriptions that match REGEXP." (interactive "sGnus description apropos (regexp): ") (when (not (or gnus-description-hashtb (gnus-read-all-descriptions-files))) @@ -3417,8 +3830,8 @@ (when (and level (> (prefix-numeric-value level) gnus-level-killed)) (gnus-get-killed-groups)) - (gnus-group-prepare-flat - (or level gnus-level-subscribed) all (or lowest 1) regexp) + (funcall gnus-group-prepare-function + (or level gnus-level-subscribed) (and all t) (or lowest 1) regexp) (goto-char (point-min)) (gnus-group-position-point)) @@ -3495,17 +3908,26 @@ (interactive) (gnus-save-newsrc-file)) +(defvar gnus-backlog-articles) + (defun gnus-group-suspend () "Suspend the current Gnus session. In fact, cleanup buffers except for group mode buffer. -The hook gnus-suspend-gnus-hook is called before actually suspending." +The hook `gnus-suspend-gnus-hook' is called before actually suspending." (interactive) (gnus-run-hooks 'gnus-suspend-gnus-hook) + (gnus-offer-save-summaries) ;; Kill Gnus buffers except for group mode buffer. (let ((group-buf (get-buffer gnus-group-buffer))) - (dolist (buf (gnus-buffers)) - (unless (or (eq buf group-buf) (eq buf gnus-dribble-buffer)) - (kill-buffer buf))) + (mapcar (lambda (buf) + (unless (or (member buf (list group-buf gnus-dribble-buffer)) + (progn + (save-excursion + (set-buffer buf) + (eq major-mode 'message-mode)))) + (gnus-kill-buffer buf))) + (gnus-buffers)) + (setq gnus-backlog-articles nil) (gnus-kill-gnus-frames) (when group-buf (bury-buffer group-buf) @@ -3552,6 +3974,12 @@ (file-name-nondirectory gnus-current-startup-file)))) (gnus-run-hooks 'gnus-exit-gnus-hook) (gnus-configure-windows 'group t) + (when (and (gnus-buffer-live-p gnus-dribble-buffer) + (not (zerop (save-excursion + (set-buffer gnus-dribble-buffer) + (buffer-size))))) + (gnus-dribble-enter + ";;; Gnus was exited on purpose without saving the .newsrc files.")) (gnus-dribble-save) (gnus-close-backends) (gnus-clear-system) @@ -3572,10 +4000,10 @@ and the second element is the address." (interactive (list (let ((how (completing-read - "Which backend: " + "Which back end: " (append gnus-valid-select-methods gnus-server-alist) nil t (cons "nntp" 0) 'gnus-method-history))) - ;; We either got a backend name or a virtual server name. + ;; We either got a back end name or a virtual server name. ;; If the first, we also need an address. (if (assoc how gnus-valid-select-methods) (list (intern how) @@ -3641,7 +4069,8 @@ (setcar (nthcdr 2 entry) info) (when (and (not (eq (car entry) t)) (gnus-active (gnus-info-group info))) - (setcar entry (length (gnus-list-of-unread-articles (car info)))))) + (setcar entry (length + (gnus-list-of-unread-articles (car info)))))) (error "No such group: %s" (gnus-info-group info)))))) (defun gnus-group-set-method-info (group select-method) @@ -3676,6 +4105,16 @@ (sort (nconc (gnus-uncompress-range (cdr m)) (copy-sequence articles)) '<) t)))))) +(defun gnus-add-mark (group mark article) + "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." + (let ((buffer (gnus-summary-buffer-name group))) + (if (gnus-buffer-live-p buffer) + (save-excursion + (set-buffer (get-buffer buffer)) + (gnus-summary-add-mark article mark)) + (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists)) + (list article))))) + ;;; ;;; Group timestamps ;;; @@ -3697,7 +4136,7 @@ "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." (let* ((time (or (gnus-group-timestamp group) (list 0 0))) - (delta (subtract-time (current-time) time))) + (delta (subtract-time (current-time) time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) @@ -3708,68 +4147,6 @@ "" (gnus-time-iso8601 time)))) -(defun gnus-group-prepare-flat-list-dead-predicate - (groups level mark predicate) - (let (group) - (if predicate - ;; This loop is used when listing groups that match some - ;; regexp. - (while (setq group (pop groups)) - (when (funcall predicate group) - (gnus-add-text-properties - (point) (prog1 (1+ (point)) - (insert " " mark " *: " - (gnus-group-name-decode group - (gnus-group-name-charset - nil group)) - "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) - 'gnus-unread t - 'gnus-level level))))))) - -(defun gnus-group-prepare-flat-predicate (level predicate &optional lowest - dead-predicate) - "List all newsgroups with unread articles of level LEVEL or lower. -If LOWEST is non-nil, list all newsgroups of level LOWEST or higher. -If PREDICATE, only list groups which PREDICATE returns non-nil. -If DEAD-PREDICATE, list dead groups which DEAD-PREDICATE returns non-nil." - (set-buffer gnus-group-buffer) - (let ((buffer-read-only nil) - (newsrc (cdr gnus-newsrc-alist)) - (lowest (or lowest 1)) - info clevel unread group params) - (erase-buffer) - ;; List living groups. - (while newsrc - (setq info (car newsrc) - group (gnus-info-group info) - params (gnus-info-params info) - newsrc (cdr newsrc) - unread (car (gnus-gethash group gnus-newsrc-hashtb))) - (and unread ; This group might be unchecked - (funcall predicate info) - (<= (setq clevel (gnus-info-level info)) level) - (>= clevel lowest) - (gnus-group-insert-group-line - group (gnus-info-level info) - (gnus-info-marks info) unread (gnus-info-method info)))) - - ;; List dead groups. - (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie) - (gnus-group-prepare-flat-list-dead-predicate - (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) - gnus-level-zombie ?Z - dead-predicate)) - (and (>= level gnus-level-killed) (<= lowest gnus-level-killed) - (gnus-group-prepare-flat-list-dead-predicate - (setq gnus-killed-list (sort gnus-killed-list 'string<)) - gnus-level-killed ?K dead-predicate)) - - (gnus-group-set-mode-line) - (setq gnus-group-list-mode (cons level t)) - (gnus-run-hooks 'gnus-group-prepare-hook) - t)) - (defun gnus-group-list-cached (level &optional lowest) "List all groups with cached articles. If the prefix LEVEL is non-nil, it should be a number that says which @@ -3782,21 +4159,22 @@ (setq level (prefix-numeric-value level))) (when (or (not level) (>= level gnus-level-zombie)) (gnus-cache-open)) - (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed) - #'(lambda (info) - (let ((marks (gnus-info-marks info))) - (assq 'cache marks))) - lowest - #'(lambda (group) - (or (gnus-gethash group - gnus-cache-active-hashtb) - ;; Cache active file might use "." - ;; instead of ":". - (gnus-gethash - (mapconcat 'identity - (split-string group ":") - ".") - gnus-cache-active-hashtb)))) + (funcall gnus-group-prepare-function + (or level gnus-level-subscribed) + #'(lambda (info) + (let ((marks (gnus-info-marks info))) + (assq 'cache marks))) + lowest + #'(lambda (group) + (or (gnus-gethash group + gnus-cache-active-hashtb) + ;; Cache active file might use "." + ;; instead of ":". + (gnus-gethash + (mapconcat 'identity + (split-string group ":") + ".") + gnus-cache-active-hashtb)))) (goto-char (point-min)) (gnus-group-position-point)) @@ -3812,14 +4190,90 @@ (setq level (prefix-numeric-value level))) (when (or (not level) (>= level gnus-level-zombie)) (gnus-cache-open)) - (gnus-group-prepare-flat-predicate (or level gnus-level-subscribed) - #'(lambda (info) - (let ((marks (gnus-info-marks info))) - (assq 'dormant marks))) - lowest) + (funcall gnus-group-prepare-function + (or level gnus-level-subscribed) + #'(lambda (info) + (let ((marks (gnus-info-marks info))) + (assq 'dormant marks))) + lowest + 'ignore) (goto-char (point-min)) (gnus-group-position-point)) +(defun gnus-group-listed-groups () + "Return a list of listed groups." + (let (point groups) + (goto-char (point-min)) + (while (setq point (text-property-not-all (point) (point-max) + 'gnus-group nil)) + (goto-char point) + (push (symbol-name (get-text-property point 'gnus-group)) groups) + (forward-char 1)) + groups)) + +(defun gnus-group-list-plus (&optional args) + "List groups plus the current selection." + (interactive "P") + (let ((gnus-group-listed-groups (gnus-group-listed-groups)) + (gnus-group-list-mode gnus-group-list-mode) ;; Save it. + func) + (push last-command-event unread-command-events) + (if (featurep 'xemacs) + (push (make-event 'key-press '(key ?A)) unread-command-events) + (push ?A unread-command-events)) + (let (gnus-pick-mode keys) + (setq keys (if (featurep 'xemacs) + (events-to-keys (read-key-sequence nil)) + (read-key-sequence nil))) + (setq func (lookup-key (current-local-map) keys))) + (if (or (not func) + (numberp func)) + (ding) + (call-interactively func)))) + +(defun gnus-group-list-flush (&optional args) + "Flush groups from the current selection." + (interactive "P") + (let ((gnus-group-list-option 'flush)) + (gnus-group-list-plus args))) + +(defun gnus-group-list-limit (&optional args) + "List groups limited within the current selection." + (interactive "P") + (let ((gnus-group-list-option 'limit)) + (gnus-group-list-plus args))) + +(defun gnus-group-mark-article-read (group article) + "Mark ARTICLE read." + (let ((buffer (gnus-summary-buffer-name group)) + (mark gnus-read-mark) + active n) + (if (get-buffer buffer) + (with-current-buffer buffer + (setq active gnus-newsgroup-active) + (gnus-activate-group group) + (when gnus-newsgroup-prepared + (when (and gnus-newsgroup-auto-expire + (memq mark gnus-auto-expirable-marks)) + (setq mark gnus-expirable-mark)) + (setq mark (gnus-request-update-mark + group article mark)) + (gnus-mark-article-as-read article mark) + (setq gnus-newsgroup-active (gnus-active group)) + (when active + (setq n (1+ (cdr active))) + (while (<= n (cdr gnus-newsgroup-active)) + (unless (eq n article) + (push n gnus-newsgroup-unselected)) + (setq n (1+ n))) + (setq gnus-newsgroup-unselected + (nreverse gnus-newsgroup-unselected))))) + (gnus-activate-group group) + (gnus-group-make-articles-read group (list article)) + (when (gnus-group-auto-expirable-p group) + (gnus-add-marked-articles + group 'expire (list article)))))) + (provide 'gnus-group) ;;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6
--- a/lisp/gnus/gnus-int.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-int.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-int.el --- backend interface functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -29,12 +29,31 @@ (eval-when-compile (require 'cl)) (require 'gnus) +(require 'message) +(require 'gnus-range) + +(autoload 'gnus-agent-expire "gnus-agent") +(autoload 'gnus-agent-read-servers-validate-native "gnus-agent") (defcustom gnus-open-server-hook nil "Hook called just before opening connection to the news server." :group 'gnus-start :type 'hook) +(defcustom gnus-server-unopen-status nil + "The default status if the server is not able to open. +If the server is covered by Gnus agent, the possible values are +`denied', set the server denied; `offline', set the server offline; +nil, ask user. If the server is not covered by Gnus agent, set the +server denied." + :group 'gnus-start + :type '(choice (const :tag "Ask" nil) + (const :tag "Deny server" denied) + (const :tag "Unplug Agent" offline))) + +(defvar gnus-internal-registry-spool-current-method nil + "The current method, for the registry.") + ;;; ;;; Server Communication ;;; @@ -87,6 +106,18 @@ (require 'nntp))) (setq gnus-current-select-method gnus-select-method) (gnus-run-hooks 'gnus-open-server-hook) + + ;; Partially validate agent covered methods now that the + ;; gnus-select-method is known. + + (if gnus-agent + ;; NOTE: This is here for one purpose only. By validating + ;; the current select method, it converts the old 5.10.3, + ;; and earlier, format to the current format. That enables + ;; the agent code within gnus-open-server to function + ;; correctly. + (gnus-agent-read-servers-validate-native gnus-select-method)) + (or ;; gnus-open-server-hook might have opened it (gnus-server-opened gnus-select-method) @@ -110,7 +141,8 @@ "Check whether the connection to METHOD is down. If METHOD is nil, use `gnus-select-method'. If it is down, start it up (again)." - (let ((method (or method gnus-select-method))) + (let ((method (or method gnus-select-method)) + result) ;; Transform virtual server names into select methods. (when (stringp method) (setq method (gnus-server-to-method method))) @@ -124,9 +156,15 @@ (format " on %s" (nth 1 method))))) (gnus-run-hooks 'gnus-open-server-hook) (prog1 - (gnus-open-server method) + (condition-case () + (setq result (gnus-open-server method)) + (quit (message "Quit gnus-check-server") + nil)) (unless silent - (message "")))))) + (gnus-message 5 "Opening %s server%s...%s" (car method) + (if (equal (nth 1 method) "") "" + (format " on %s" (nth 1 method))) + (if result "done" "failed"))))))) (defun gnus-get-function (method function &optional noerror) "Return a function symbol based on METHOD and FUNCTION." @@ -175,18 +213,66 @@ (gnus-message 1 "Denied server") nil) ;; Open the server. - (let ((result - (funcall (gnus-get-function gnus-command-method 'open-server) - (nth 1 gnus-command-method) - (nthcdr 2 gnus-command-method)))) + (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server)) + (result + (condition-case err + (funcall open-server-function + (nth 1 gnus-command-method) + (nthcdr 2 gnus-command-method)) + (error + (gnus-message 1 (format + "Unable to open server due to: %s" + (error-message-string err))) + nil) + (quit + (gnus-message 1 "Quit trying to open server") + nil))) + open-offline) ;; If this hasn't been opened before, we add it to the list. (unless elem (setq elem (list gnus-command-method nil) gnus-opened-servers (cons elem gnus-opened-servers))) ;; Set the status of this server. - (setcar (cdr elem) (if result 'ok 'denied)) - ;; Return the result from the "open" call. - result)))) + (setcar (cdr elem) + (cond (result + (if (eq open-server-function #'nnagent-open-server) + ;; The agent's backend has a "special" status + 'offline + 'ok)) + ((and gnus-agent + (gnus-agent-method-p gnus-command-method)) + (cond (gnus-server-unopen-status + ;; Set the server's status to the unopen + ;; status. If that status is offline, + ;; recurse to open the agent's backend. + (setq open-offline (eq gnus-server-unopen-status 'offline)) + gnus-server-unopen-status) + ((gnus-y-or-n-p + (format "Unable to open %s:%s, go offline? " + (car gnus-command-method) + (cadr gnus-command-method))) + (setq open-offline t) + 'offline) + (t + ;; This agentized server was still denied + 'denied))) + (t + ;; This unagentized server must be denied + 'denied))) + + ;; NOTE: I MUST set the server's status to offline before this + ;; recursive call as this status will drive the + ;; gnus-get-function (called above) to return the agent's + ;; backend. + (if open-offline + ;; Recursively open this offline server to perform the + ;; open-server function of the agent's backend. + (let ((gnus-server-unopen-status 'denied)) + ;; Bind gnus-server-unopen-status to avoid recursively + ;; prompting with "go offline?". This is only a concern + ;; when the agent's backend fails to open the server. + (gnus-open-server gnus-command-method)) + result))))) (defun gnus-close-server (gnus-command-method) "Close the connection to GNUS-COMMAND-METHOD." @@ -228,8 +314,8 @@ (defun gnus-status-message (gnus-command-method) "Return the status message from GNUS-COMMAND-METHOD. -If GNUS-COMMAND-METHOD is a string, it is interpreted as a group name. The method -this group uses will be queried." +If GNUS-COMMAND-METHOD is a string, it is interpreted as a group +name. The method this group uses will be queried." (let ((gnus-command-method (if (stringp gnus-command-method) (gnus-find-method-for-group gnus-command-method) @@ -289,11 +375,16 @@ "Request headers for ARTICLES in GROUP. If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (let ((gnus-command-method (gnus-find-method-for-group group))) - (if (and gnus-use-cache (numberp (car articles))) - (gnus-cache-retrieve-headers articles group fetch-old) + (cond + ((and gnus-use-cache (numberp (car articles))) + (gnus-cache-retrieve-headers articles group fetch-old)) + ((and gnus-agent (gnus-online gnus-command-method) + (gnus-agent-method-p gnus-command-method)) + (gnus-agent-retrieve-headers articles group fetch-old)) + (t (funcall (gnus-get-function gnus-command-method 'retrieve-headers) articles (gnus-group-real-name group) - (nth 1 gnus-command-method) fetch-old)))) + (nth 1 gnus-command-method) fetch-old))))) (defun gnus-retrieve-articles (articles group) "Request ARTICLES in GROUP." @@ -319,7 +410,7 @@ (gnus-group-real-name group) article)))) (defun gnus-request-set-mark (group action) - "Set marks on articles in the backend." + "Set marks on articles in the back end." (let ((gnus-command-method (gnus-find-method-for-group group))) (if (not (gnus-check-backend-function 'request-set-mark (car gnus-command-method))) @@ -329,7 +420,7 @@ (nth 1 gnus-command-method))))) (defun gnus-request-update-mark (group article mark) - "Allow the backend to change the mark the user tries to put on an article." + "Allow the back end to change the mark the user tries to put on an article." (let ((gnus-command-method (gnus-find-method-for-group group))) (if (not (gnus-check-backend-function 'request-update-mark (car gnus-command-method))) @@ -358,6 +449,10 @@ (gnus-cache-request-article article group)) (setq res (cons group article) clean-up t)) + ;; Check the agent cache. + ((gnus-agent-request-article article group) + (setq res (cons group article) + clean-up t)) ;; Use `head' function. ((fboundp head) (setq res (funcall head article (gnus-group-real-name group) @@ -387,6 +482,10 @@ (gnus-cache-request-article article group)) (setq res (cons group article) clean-up t)) + ;; Check the agent cache. + ((gnus-agent-request-article article group) + (setq res (cons group article) + clean-up t)) ;; Use `head' function. ((fboundp head) (setq res (funcall head article (gnus-group-real-name group) @@ -418,9 +517,11 @@ (gnus-inhibit-demon t) (mail-source-plugged gnus-plugged)) (if (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) - (funcall (gnus-get-function gnus-command-method 'request-scan) - (and group (gnus-group-real-name group)) - (nth 1 gnus-command-method))))) + (progn + (setq gnus-internal-registry-spool-current-method gnus-command-method) + (funcall (gnus-get-function gnus-command-method 'request-scan) + (and group (gnus-group-real-name group)) + (nth 1 gnus-command-method)))))) (defsubst gnus-request-update-info (info gnus-command-method) "Request that GNUS-COMMAND-METHOD update INFO." @@ -428,23 +529,49 @@ (setq gnus-command-method (gnus-server-to-method gnus-command-method))) (when (gnus-check-backend-function 'request-update-info (car gnus-command-method)) - (funcall (gnus-get-function gnus-command-method 'request-update-info) - (gnus-group-real-name (gnus-info-group info)) - info (nth 1 gnus-command-method)))) + (let ((group (gnus-info-group info))) + (and (funcall (gnus-get-function gnus-command-method + 'request-update-info) + (gnus-group-real-name group) + info (nth 1 gnus-command-method)) + ;; If the minimum article number is greater than 1, then all + ;; smaller article numbers are known not to exist; we'll + ;; artificially add those to the 'read range. + (let* ((active (gnus-active group)) + (min (car active))) + (when (> min 1) + (let* ((range (if (= min 2) 1 (cons 1 (1- min)))) + (read (gnus-info-read info)) + (new-read (gnus-range-add read (list range)))) + (gnus-info-set-read info new-read))) + info))))) (defun gnus-request-expire-articles (articles group &optional force) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (funcall (gnus-get-function gnus-command-method 'request-expire-articles) - articles (gnus-group-real-name group) (nth 1 gnus-command-method) - force))) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (not-deleted + (funcall + (gnus-get-function gnus-command-method 'request-expire-articles) + articles (gnus-group-real-name group) (nth 1 gnus-command-method) + force))) + (when (and gnus-agent + (gnus-agent-method-p gnus-command-method)) + (let ((expired-articles (gnus-sorted-difference articles not-deleted))) + (when expired-articles + (gnus-agent-expire expired-articles group 'force)))) + not-deleted)) -(defun gnus-request-move-article - (article group server accept-function &optional last) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (funcall (gnus-get-function gnus-command-method 'request-move-article) - article (gnus-group-real-name group) - (nth 1 gnus-command-method) accept-function last))) - +(defun gnus-request-move-article (article group server accept-function + &optional last) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (result (funcall (gnus-get-function gnus-command-method + 'request-move-article) + article (gnus-group-real-name group) + (nth 1 gnus-command-method) accept-function last))) + (when (and result gnus-agent + (gnus-agent-method-p gnus-command-method)) + (gnus-agent-expire (list article) group 'force)) + result)) + (defun gnus-request-accept-article (group &optional gnus-command-method last no-encode) ;; Make sure there's a newline at the end of the article. @@ -457,25 +584,29 @@ (unless (bolp) (insert "\n")) (unless no-encode - (save-restriction - (message-narrow-to-head) - (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer))) - (message-encode-message-body)) - (let ((func (car (or gnus-command-method - (gnus-find-method-for-group group))))) - (funcall (intern (format "%s-request-accept-article" func)) + (let ((message-options message-options)) + (message-options-set-recipient) + (save-restriction + (message-narrow-to-head) + (let ((mail-parse-charset message-default-charset)) + (mail-encode-encoded-word-buffer))) + (message-encode-message-body))) + (let ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group)))) + (funcall (gnus-get-function gnus-command-method 'request-accept-article) (if (stringp group) (gnus-group-real-name group) group) (cadr gnus-command-method) last))) (defun gnus-request-replace-article (article group buffer &optional no-encode) (unless no-encode - (save-restriction - (message-narrow-to-head) - (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer))) - (message-encode-message-body)) + (let ((message-options message-options)) + (message-options-set-recipient) + (save-restriction + (message-narrow-to-head) + (let ((mail-parse-charset message-default-charset)) + (mail-encode-encoded-word-buffer))) + (message-encode-message-body))) (let ((func (car (gnus-group-name-to-method group)))) (funcall (intern (format "%s-request-replace-article" func)) article (gnus-group-real-name group) buffer)))
--- a/lisp/gnus/gnus-kill.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-kill.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-kill.el --- kill commands for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003 ;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> @@ -357,16 +357,16 @@ (defun gnus-apply-kill-file-unless-scored () "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) - ;; Ignores global KILL. - (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) + ;; Ignores global KILL. + (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" gnus-newsgroup-name)) - 0) - ((or (file-exists-p (gnus-newsgroup-kill-file nil)) - (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) - (gnus-apply-kill-file-internal)) - (t - 0))) + 0) + ((or (file-exists-p (gnus-newsgroup-kill-file nil)) + (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) + (gnus-apply-kill-file-internal)) + (t + 0))) (defun gnus-apply-kill-file-internal () "Apply a kill file to the current newsgroup. @@ -398,7 +398,7 @@ gnus-newsgroup-kill-headers)) (setq headers (cdr headers)))) (setq files nil)) - (setq files (cdr files))))) + (setq files (cdr files))))) (if (not gnus-newsgroup-kill-headers) () (save-window-excursion @@ -428,16 +428,6 @@ 0)))) ;; Parse a Gnus killfile. -(defun gnus-score-insert-help (string alist idx) - (save-excursion - (pop-to-buffer "*Score Help*") - (buffer-disable-undo) - (erase-buffer) - (insert string ":\n\n") - (while alist - (insert (format " %c: %s\n" (caar alist) (nth idx (car alist)))) - (setq alist (cdr alist))))) - (defun gnus-kill-parse-gnus-kill-file () (goto-char (point-min)) (gnus-kill-file-mode) @@ -588,7 +578,7 @@ (insert "\n t")) (insert ")") (prog1 - (buffer-substring (point-min) (point-max)) + (buffer-string) (kill-buffer (current-buffer)))))) (defun gnus-execute-1 (function regexp form header) @@ -608,7 +598,7 @@ (setq did-kill (string-match regexp value))) (cond ((stringp form) ;Keyboard macro. (execute-kbd-macro form)) - ((gnus-functionp form) + ((functionp form) (funcall form)) (t (eval form))))) @@ -627,7 +617,7 @@ (setq did-kill (re-search-forward regexp nil t))) (cond ((stringp form) ;Keyboard macro. (execute-kbd-macro form)) - ((gnus-functionp form) + ((functionp form) (funcall form)) (t (eval form))))))) @@ -641,18 +631,30 @@ marked as read or ticked are ignored." (save-excursion (let ((killed-no 0) - function article header) + function article header extras) (cond ;; Search body. ((or (null field) (string-equal field "")) (setq function nil)) ;; Get access function of header field. - ((fboundp - (setq function - (intern-soft - (concat "mail-header-" (downcase field))))) - (setq function `(lambda (h) (,function h)))) + ((cond ((fboundp + (setq function + (intern-soft + (concat "mail-header-" (downcase field))))) + (setq function `(lambda (h) (,function h)))) + ((when (setq extras + (member (downcase field) + (mapcar (lambda (header) + (downcase (symbol-name header))) + gnus-extra-headers))) + (setq function + `(lambda (h) + (gnus-extra-header + (quote ,(nth (- (length gnus-extra-headers) + (length extras)) + gnus-extra-headers)) + h))))))) ;; Signal error. (t (error "Unknown header field: \"%s\"" field)))
--- a/lisp/gnus/gnus-logic.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-logic.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-logic.el --- advanced scoring code for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -59,24 +59,25 @@ (defun gnus-score-advanced (rule &optional trace) "Apply advanced scoring RULE to all the articles in the current group." - (let ((headers gnus-newsgroup-headers) - gnus-advanced-headers score) - (while (setq gnus-advanced-headers (pop headers)) - (when (gnus-advanced-score-rule (car rule)) - ;; This rule was successful, so we add the score to - ;; this article. + (let (new-score score multiple) + (dolist (gnus-advanced-headers gnus-newsgroup-headers) + (when (setq multiple (gnus-advanced-score-rule (car rule))) + (setq new-score (or (nth 1 rule) + gnus-score-interactive-default-score)) + (when (numberp multiple) + (setq new-score (* multiple new-score))) + ;; This rule was successful, so we add the score to this + ;; article. (if (setq score (assq (mail-header-number gnus-advanced-headers) gnus-newsgroup-scored)) (setcdr score - (+ (cdr score) - (or (nth 1 rule) - gnus-score-interactive-default-score))) + (+ (cdr score) new-score)) (push (cons (mail-header-number gnus-advanced-headers) - (or (nth 1 rule) - gnus-score-interactive-default-score)) + new-score) gnus-newsgroup-scored) (when trace (push (cons "A file" rule) + ;; Must be synced with `gnus-score-edit-file-at-point'. gnus-score-trace))))))) (defun gnus-advanced-score-rule (rule) @@ -116,7 +117,7 @@ ;; 1- type redirection. (string-to-number (substring (symbol-name type) - (match-beginning 0) (match-end 0))) + (match-beginning 1) (match-end 1))) ;; ^^^ type redirection. (length (symbol-name type)))))) (when gnus-advanced-headers @@ -129,9 +130,8 @@ (error "Unknown advanced score type: %s" rule))))) (defun gnus-advanced-score-article (rule) - ;; `rule' is a semi-normal score rule, so we find out - ;; what function that's supposed to do the actual - ;; processing. + ;; `rule' is a semi-normal score rule, so we find out what function + ;; that's supposed to do the actual processing. (let* ((header (car rule)) (func (assoc (downcase header) gnus-advanced-index))) (if (not func) @@ -162,7 +162,7 @@ (defun gnus-advanced-integer (index match type) (if (not (memq type '(< > <= >= =))) (error "No such integer score type: %s" type) - (funcall type match (or (aref gnus-advanced-headers index) 0)))) + (funcall type (or (aref gnus-advanced-headers index) 0) match))) (defun gnus-advanced-date (index match type) (let ((date (apply 'encode-time (parse-time-string @@ -189,8 +189,8 @@ 'gnus-request-body) (t 'gnus-request-article))) ofunc article) - ;; Not all backends support partial fetching. In that case, - ;; we just fetch the entire article. + ;; Not all backends support partial fetching. In that case, we + ;; just fetch the entire article. (unless (gnus-check-backend-function (intern (concat "request-" header)) gnus-newsgroup-name) @@ -201,8 +201,8 @@ (when (funcall request-func article gnus-newsgroup-name) (goto-char (point-min)) ;; If just parts of the article is to be searched and the - ;; backend didn't support partial fetching, we just narrow - ;; to the relevant parts. + ;; backend didn't support partial fetching, we just narrow to + ;; the relevant parts. (when ofunc (if (eq ofunc 'gnus-request-head) (narrow-to-region
--- a/lisp/gnus/gnus-mh.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-mh.el Thu Jul 22 16:45:51 2004 +0000 @@ -40,6 +40,9 @@ (require 'gnus-msg) (require 'gnus-sum) +(eval-when-compile + (defvar mh-lib-progs)) + (defun gnus-summary-save-article-folder (&optional arg) "Append the current article to an mh folder. If N is a positive number, save the N next articles.
--- a/lisp/gnus/gnus-ml.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-ml.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ -;;; gnus-ml.el --- mailing list minor mode for Gnus +;;; gnus-ml.el --- Mailing list minor mode for Gnus -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. ;; Author: Julien Gilles <jgilles@free.fr> ;; Keywords: news @@ -26,10 +26,6 @@ ;; implement (small subset of) RFC 2369 -;;; Usage: - -;; (add-hook 'gnus-summary-mode-hook 'turn-on-gnus-mailing-list-mode) - ;;; Code: (require 'gnus) @@ -49,12 +45,12 @@ (setq gnus-mailing-list-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-mailing-list-mode-map - "\C-nh" gnus-mailing-list-help - "\C-ns" gnus-mailing-list-subscribe - "\C-nu" gnus-mailing-list-unsubscribe - "\C-np" gnus-mailing-list-post - "\C-no" gnus-mailing-list-owner - "\C-na" gnus-mailing-list-archive + "\C-c\C-nh" gnus-mailing-list-help + "\C-c\C-ns" gnus-mailing-list-subscribe + "\C-c\C-nu" gnus-mailing-list-unsubscribe + "\C-c\C-np" gnus-mailing-list-post + "\C-c\C-no" gnus-mailing-list-owner + "\C-c\C-na" gnus-mailing-list-archive )) (defun gnus-mailing-list-make-menu-bar () @@ -71,10 +67,29 @@ ;;;###autoload (defun turn-on-gnus-mailing-list-mode () - (when (gnus-group-get-parameter gnus-newsgroup-name 'to-list) + (when (gnus-group-find-parameter gnus-newsgroup-name 'to-list) (gnus-mailing-list-mode 1))) ;;;###autoload +(defun gnus-mailing-list-insinuate (&optional force) + "Setup group parameters from List-Post header. +If FORCE is non-nil, replace the old ones." + (interactive "P") + (let ((list-post + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "list-post")))) + (if list-post + (if (and (not force) + (gnus-group-get-parameter gnus-newsgroup-name 'to-list)) + (gnus-message 1 "to-list is non-nil.") + (if (string-match "<mailto:\\([^>]*\\)>" list-post) + (setq list-post (match-string 1 list-post))) + (gnus-group-add-parameter gnus-newsgroup-name + (cons 'to-list list-post)) + (gnus-mailing-list-mode 1)) + (gnus-message 1 "no list-post in this message.")))) + +;;;###autoload (defun gnus-mailing-list-mode (&optional arg) "Minor mode for providing mailing-list commands. @@ -140,11 +155,15 @@ (defun gnus-mailing-list-archive () "Browse archive" (interactive) + (require 'browse-url) (let ((list-archive (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-archive")))) - (cond (list-archive (gnus-mailing-list-message list-archive)) - (t (gnus-message 1 "no list-owner in this group"))))) + (cond (list-archive + (if (string-match "<\\(http:[^>]*\\)>" list-archive) + (browse-url (match-string 1 list-archive)) + (browse-url list-archive))) + (t (gnus-message 1 "no list-archive in this group"))))) ;;; Utility functions @@ -158,7 +177,7 @@ (cond ((string-match "<mailto:\\([^>]*\\)>" address) (let ((args (match-string 1 address))) - (cond ; with param + (cond ; with param ((string-match "\\(.*\\)\\?\\(.*\\)" args) (setq mailto (match-string 1 args)) (let ((param (match-string 2 args))) @@ -169,7 +188,7 @@ (if (string-match "to=\\([^&]*\\)" param) (push (match-string 1 param) to)) )) - (t (setq mailto args))))) ; without param + (t (setq mailto args))))) ; without param ; other case <http://... to be done. (t nil))
--- a/lisp/gnus/gnus-mlspl.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-mlspl.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; gnus-mlspl.el --- a group params-based mail splitting mechanism -;; Copyright (C) 1998, 1999, 2000 + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Alexandre Oliva <oliva@lsd.ic.unicamp.br> @@ -8,18 +9,18 @@ ;; 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. +;; 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. +;; 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, +;; 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: @@ -62,7 +63,7 @@ uses are as simple as the name of a default mail group, but more elaborate fancy splits may also be useful to split mail that doesn't match any of the group-specified splitting rules. See -gnus-group-split-fancy for details." +`gnus-group-split-fancy' for details." (interactive "P") (setq nnmail-split-methods 'nnmail-split-fancy) (when catch-all @@ -88,7 +89,7 @@ ;;;###autoload (defun gnus-group-split () "Uses information from group parameters in order to split mail. -See gnus-group-split-fancy for more information. +See `gnus-group-split-fancy' for more information. gnus-group-split is a valid value for nnmail-split-methods." (let (nnmail-split-fancy) @@ -140,12 +141,12 @@ nnml:mail.others: \((split-spec . catch-all)) -Calling (gnus-group-split-fancy nil nil \"mail.misc\") returns: +Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: \(| (& (any \"\\\\(bar@femail\\\\.com\\\\|.*@femail\\\\.com\\\\)\" \"mail.bar\") (any \"\\\\(foo@nowhere\\\\.gov\\\\|foo@localhost\\\\|foo-redist@home\\\\)\" - - \"bugs-foo\" - \"rambling-foo\" \"mail.foo\")) + - \"bugs-foo\" - \"rambling-foo\" \"mail.foo\")) \"mail.others\")" (let* ((newsrc (cdr gnus-newsrc-alist)) split) @@ -202,12 +203,9 @@ (list 'any split-regexp) ;; Generate RESTRICTs for SPLIT-EXCLUDEs. (if (listp split-exclude) - (let ((seq split-exclude) - res) - (while seq - (push (cons '- (pop seq)) - res)) - (apply #'nconc (nreverse res))) + (apply #'append + (mapcar (lambda (arg) (list '- arg)) + split-exclude)) (list '- split-exclude)) (list group-clean)) split)
--- a/lisp/gnus/gnus-msg.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-msg.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> @@ -33,6 +33,7 @@ (require 'gnus-ems) (require 'message) (require 'gnus-art) +(require 'gnus-util) (defcustom gnus-post-method 'current "*Preferred method for posting USENET news. @@ -54,7 +55,7 @@ (const current) (sexp :tag "Methods" ,gnus-select-method))) -(defvar gnus-outgoing-message-group nil +(defcustom gnus-outgoing-message-group nil "*All outgoing messages will be put in this group. If you want to store all your outgoing mail and articles in the group \"nnml:archive\", you set this variable to that value. This variable @@ -63,18 +64,26 @@ If you want to have greater control over what group to put each message in, you can set this variable to a function that checks the current newsgroup name and then returns a suitable group name (or list -of names).") +of names)." + :group 'gnus-message + :type '(choice (string :tag "Group") + (function))) -(defvar gnus-mailing-list-groups nil - "*Regexp matching groups that are really mailing lists. +(defcustom gnus-mailing-list-groups nil + "*If non-nil a regexp matching groups that are really mailing lists. This is useful when you're reading a mailing list that has been gatewayed to a newsgroup, and you want to followup to an article in -the group.") +the group." + :group 'gnus-message + :type '(choice (regexp) + (const nil))) -(defvar gnus-add-to-list nil - "*If non-nil, add a `to-list' parameter automatically.") +(defcustom gnus-add-to-list nil + "*If non-nil, add a `to-list' parameter automatically." + :group 'gnus-message + :type 'boolean) -(defvar gnus-crosspost-complaint +(defcustom gnus-crosspost-complaint "Hi, You posted the article below with the following Newsgroups header: @@ -90,22 +99,79 @@ " "Format string to be inserted when complaining about crossposts. The first %s will be replaced by the Newsgroups header; -the second with the current group name.") +the second with the current group name." + :group 'gnus-message + :type 'string) -(defvar gnus-message-setup-hook nil - "Hook run after setting up a message buffer.") +(defcustom gnus-message-setup-hook nil + "Hook run after setting up a message buffer." + :group 'gnus-message + :type 'hook) + +(defcustom gnus-bug-create-help-buffer t + "*Should we create the *Gnus Help Bug* buffer?" + :group 'gnus-message + :type 'boolean) -(defvar gnus-bug-create-help-buffer t - "*Should we create the *Gnus Help Bug* buffer?") +(defcustom gnus-posting-styles nil + "*Alist of styles to use when posting. +See Info node `(gnus)Posting Styles'." + :group 'gnus-message + :link '(custom-manual "(gnus)Posting Styles") + :type '(repeat (cons (choice (regexp) + (variable) + (list (const header) + (string :tag "Header") + (regexp :tag "Regexp")) + (function) + (sexp)) + (repeat (list + (choice (const signature) + (const signature-file) + (const organization) + (const address) + (const x-face-file) + (const name) + (const body) + (symbol) + (string :tag "Header")) + (choice (string) + (function) + (variable) + (sexp))))))) -(defvar gnus-posting-styles nil - "*Alist of styles to use when posting.") +(defcustom gnus-gcc-mark-as-read nil + "If non-nil, automatically mark Gcc articles as read." + :version "21.1" + :group 'gnus-message + :type 'boolean) + +(make-obsolete-variable 'gnus-inews-mark-gcc-as-read + 'gnus-gcc-mark-as-read) -(defcustom gnus-group-posting-charset-alist +(defcustom gnus-gcc-externalize-attachments nil + "Should local-file attachments be included as external parts in Gcc copies? +If it is `all', attach files as external parts; +if a regexp and matches the Gcc group name, attach files as external parts; +if nil, attach files as normal parts." + :version "21.1" + :group 'gnus-message + :type '(choice (const nil :tag "None") + (const all :tag "Any") + (string :tag "Regexp"))) + +(gnus-define-group-parameter + posting-charset-alist + :type list + :function-document + "Return the permitted unencoded charsets for posting of GROUP." + :variable gnus-group-posting-charset-alist + :variable-default '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1)) ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r)) (message-this-is-mail nil nil) (message-this-is-news nil t)) + :variable-document "Alist of regexps and permitted unencoded charsets for posting. Each element of the alist has the form (TEST HEADER BODY-LIST), where TEST is either a regular expression matching the newsgroup header or a @@ -118,31 +184,118 @@ Note that any value other than nil for HEADER infringes some RFCs, so use this option with care." - :type '(repeat (list :tag "Permitted unencoded charsets" - (choice :tag "Where" - (regexp :tag "Group") - (const :tag "Mail message" :value message-this-is-mail) - (const :tag "News article" :value message-this-is-news)) - (choice :tag "Header" - (const :tag "None" nil) - (symbol :tag "Charset")) - (choice :tag "Body" - (const :tag "Any" :value t) - (const :tag "None" :value nil) - (repeat :tag "Charsets" - (symbol :tag "Charset"))))) - :group 'gnus-charset) + :variable-group gnus-charset + :variable-type + '(repeat (list :tag "Permitted unencoded charsets" + (choice :tag "Where" + (regexp :tag "Group") + (const :tag "Mail message" :value message-this-is-mail) + (const :tag "News article" :value message-this-is-news)) + (choice :tag "Header" + (const :tag "None" nil) + (symbol :tag "Charset")) + (choice :tag "Body" + (const :tag "Any" :value t) + (const :tag "None" :value nil) + (repeat :tag "Charsets" + (symbol :tag "Charset"))))) + :parameter-type '(choice :tag "Permitted unencoded charsets" + :value nil + (repeat (symbol))) + :parameter-document "\ +List of charsets that are permitted to be unencoded.") + +(defcustom gnus-debug-files + '("gnus.el" "gnus-sum.el" "gnus-group.el" + "gnus-art.el" "gnus-start.el" "gnus-async.el" + "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el" + "gnus-agent.el" "gnus-cache.el" "gnus-srvr.el" + "mm-util.el" "mm-decode.el" "nnmail.el" "message.el") + "Files whose variables will be reported in `gnus-bug'." + :version "21.1" + :group 'gnus-message + :type '(repeat (string :tag "File"))) + +(defcustom gnus-debug-exclude-variables + '(mm-mime-mule-charset-alist + nnmail-split-fancy message-minibuffer-local-map) + "Variables that should not be reported in `gnus-bug'." + :version "21.1" + :group 'gnus-message + :type '(repeat (symbol :tag "Variable"))) + +(defcustom gnus-discouraged-post-methods + '(nndraft nnml nnimap nnmaildir nnmh nnfolder nndir) + "A list of back ends that are not used in \"real\" newsgroups. +This variable is used only when `gnus-post-method' is `current'." + :version "21.3" + :group 'gnus-group-foreign + :type '(repeat (symbol :tag "Back end"))) + +(defcustom gnus-message-replysign + nil + "Automatically sign replies to signed messages. +See also the `mml-default-sign-method' variable." + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-message-replyencrypt + nil + "Automatically encrypt replies to encrypted messages. +See also the `mml-default-encrypt-method' variable." + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-message-replysignencrypted + t + "Setting this causes automatically encrypted messages to also be signed." + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-confirm-mail-reply-to-news nil + "If non-nil, Gnus requests confirmation when replying to news. +This is done because new users often reply by mistake when reading +news. +This can also be a function receiving the group name as the only +parameter which should return non-nil iff a confirmation is needed, or +a regexp, in which case a confirmation is asked for iff the group name +matches the regexp." + :group 'gnus-message + :type '(choice (const :tag "No" nil) + (const :tag "Yes" t) + (regexp :tag "Iff group matches regexp") + (function :tag "Iff function evaluates to non-nil"))) + +(defcustom gnus-confirm-treat-mail-like-news + nil + "If non-nil, Gnus will treat mail like news with regard to confirmation +when replying by mail. See the `gnus-confirm-mail-reply-to-news' variable +for fine-tuning this. +If nil, Gnus will never ask for confirmation if replying to mail." + :group 'gnus-message + :type 'boolean) + +(defcustom gnus-summary-resend-default-address t + "If non-nil, Gnus tries to suggest a default address to resend to. +If nil, the address field will always be empty after invoking +`gnus-summary-resend-message'." + :group 'gnus-message + :type 'boolean) ;;; Internal variables. (defvar gnus-inhibit-posting-styles nil "Inhibit the use of posting styles.") +(defvar gnus-article-yanked-articles nil) (defvar gnus-message-buffer "*Mail Gnus*") (defvar gnus-article-copy nil) +(defvar gnus-check-before-posting nil) (defvar gnus-last-posting-server nil) (defvar gnus-message-group-art nil) +(defvar gnus-msg-force-broken-reply-to nil) + (defconst gnus-bug-message "Sending a bug report to the Gnus Towers. ======================================== @@ -166,6 +319,8 @@ (eval-and-compile (autoload 'gnus-uu-post-news "gnus-uu" nil t) + (autoload 'news-setup "rnewspost") + (autoload 'news-reply-mode "rnewspost") (autoload 'rmail-dont-reply-to "mail-utils") (autoload 'rmail-output "rmailout")) @@ -176,6 +331,7 @@ (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map) "p" gnus-summary-post-news + "i" gnus-summary-news-other-window "f" gnus-summary-followup "F" gnus-summary-followup-with-original "c" gnus-summary-cancel-article @@ -185,11 +341,15 @@ "R" gnus-summary-reply-with-original "w" gnus-summary-wide-reply "W" gnus-summary-wide-reply-with-original + "v" gnus-summary-very-wide-reply + "V" gnus-summary-very-wide-reply-with-original "n" gnus-summary-followup-to-mail "N" gnus-summary-followup-to-mail-with-original "m" gnus-summary-mail-other-window "u" gnus-uu-post-news "\M-c" gnus-summary-mail-crosspost-complaint + "Br" gnus-summary-reply-broken-reply-to + "BR" gnus-summary-reply-broken-reply-to-with-original "om" gnus-summary-mail-forward "op" gnus-summary-post-forward "Om" gnus-uu-digest-mail-forward @@ -198,19 +358,27 @@ (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) "b" gnus-summary-resend-bounced-mail ;; "c" gnus-summary-send-draft - "r" gnus-summary-resend-message) + "r" gnus-summary-resend-message + "e" gnus-summary-resend-message-edit) ;;; Internal functions. +(defun gnus-inews-make-draft () + `(lambda () + (gnus-inews-make-draft-meta-information + ,gnus-newsgroup-name ',gnus-article-reply))) + (defvar gnus-article-reply nil) (defmacro gnus-setup-message (config &rest forms) (let ((winconf (make-symbol "gnus-setup-message-winconf")) (buffer (make-symbol "gnus-setup-message-buffer")) (article (make-symbol "gnus-setup-message-article")) + (yanked (make-symbol "gnus-setup-yanked-articles")) (group (make-symbol "gnus-setup-message-group"))) `(let ((,winconf (current-window-configuration)) (,buffer (buffer-name (current-buffer))) - (,article (and gnus-article-reply (gnus-summary-article-number))) + (,article gnus-article-reply) + (,yanked gnus-article-yanked-articles) (,group gnus-newsgroup-name) (message-header-setup-hook (copy-sequence message-header-setup-hook)) @@ -219,11 +387,29 @@ (setq mml-buffer-list nil) (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) - (add-hook 'message-mode-hook 'gnus-configure-posting-styles) + ;; #### FIXME: for a reason that I did not manage to identify yet, + ;; the variable `gnus-newsgroup-name' does not honor a dynamically + ;; scoped or setq'ed value from a caller like `C-u gnus-summary-mail'. + ;; After evaluation of @forms below, it gets the value we actually want + ;; to override, and the posting styles are used. For that reason, I've + ;; added an optional argument to `gnus-configure-posting-styles' to + ;; make sure that the correct value for the group name is used. -- drv + (add-hook 'message-mode-hook + (lambda () + (gnus-configure-posting-styles ,group))) + (gnus-pull ',(intern gnus-draft-meta-information-header) + message-required-headers) + (when (and ,group + (not (string= ,group ""))) + (push (cons + (intern gnus-draft-meta-information-header) + (gnus-inews-make-draft)) + message-required-headers)) (unwind-protect (progn ,@forms) - (gnus-inews-add-send-actions ,winconf ,buffer ,article) + (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config + ,yanked) (setq gnus-message-buffer (current-buffer)) (set (make-local-variable 'gnus-message-group-art) (cons ,group ,article)) @@ -233,29 +419,71 @@ (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) ;; Global value (set (make-local-variable 'mml-buffer-list) mbl1);; Local value + (gnus-make-local-hook 'kill-buffer-hook) + (gnus-make-local-hook 'change-major-mode-hook) (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) (mml-destroy-buffers) (setq mml-buffer-list mbl))) + (message-hide-headers) (gnus-add-buffer) (gnus-configure-windows ,config t) + (run-hooks 'post-command-hook) (set-buffer-modified-p nil)))) +(defun gnus-inews-make-draft-meta-information (group article) + (concat "(\"" group "\" " + (if article (number-to-string + (if (listp article) + (car article) + article)) "\"\"") + ")")) + ;;;###autoload -(defun gnus-msg-mail (&rest args) +(defun gnus-msg-mail (&optional to subject other-headers continue + switch-action yank-action send-actions) "Start editing a mail message to be sent. Like `message-mail', but with Gnus paraphernalia, particularly the Gcc: header for archiving purposes." (interactive) - (gnus-setup-message 'message - (apply 'message-mail args)) + (let ((buf (current-buffer)) + mail-buf) + (gnus-setup-message 'message + (message-mail to subject other-headers continue + nil yank-action send-actions)) + (when switch-action + (setq mail-buf (current-buffer)) + (switch-to-buffer buf) + (apply switch-action mail-buf nil))) ;; COMPOSEFUNC should return t if succeed. Undocumented ??? t) +(defvar save-selected-window-window) + +;;;###autoload +(defun gnus-button-mailto (address) + "Mail to ADDRESS." + (set-buffer (gnus-copy-article-buffer)) + (gnus-setup-message 'message + (message-reply address)) + (and (boundp 'save-selected-window-window) + (not (window-live-p save-selected-window-window)) + (setq save-selected-window-window (selected-window)))) + +;;;###autoload +(defun gnus-button-reply (&optional to-address wide) + "Like `message-reply'." + (interactive) + (gnus-setup-message 'message + (message-reply to-address wide)) + (and (boundp 'save-selected-window-window) + (not (window-live-p save-selected-window-window)) + (setq save-selected-window-window (selected-window)))) + ;;;###autoload (define-mail-user-agent 'gnus-user-agent - 'gnus-msg-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook) + 'gnus-msg-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook) (defun gnus-setup-posting-charset (group) (let ((alist gnus-group-posting-charset-alist) @@ -266,32 +494,43 @@ (while (setq elem (pop alist)) (when (or (and (stringp (car elem)) (string-match (car elem) group)) - (and (gnus-functionp (car elem)) + (and (functionp (car elem)) (funcall (car elem) group)) (and (symbolp (car elem)) (symbol-value (car elem)))) (throw 'found (cons (cadr elem) (caddr elem))))))))) -(defun gnus-inews-add-send-actions (winconf buffer article) - (make-local-hook 'message-sent-hook) +(defun gnus-inews-add-send-actions (winconf buffer article + &optional config yanked) + (gnus-make-local-hook 'message-sent-hook) (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc 'gnus-inews-do-gcc) nil t) (when gnus-agent - (make-local-hook 'message-header-hook) + (gnus-make-local-hook 'message-header-hook) (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t)) (setq message-post-method `(lambda (arg) (gnus-post-method arg ,gnus-newsgroup-name))) (setq message-newsreader (setq message-mailer (gnus-extended-version))) (message-add-action - `(set-window-configuration ,winconf) 'exit 'postpone 'kill) - (message-add-action `(when (gnus-buffer-exists-p ,buffer) - (save-excursion - (set-buffer ,buffer) - ,(when article - `(gnus-summary-mark-article-as-replied ,article)))) - 'send)) + (set-window-configuration ,winconf)) + 'exit 'postpone 'kill) + (let ((to-be-marked (cond + (yanked + (mapcar + (lambda (x) (if (listp x) (car x) x)) yanked)) + (article (if (listp article) article (list article))) + (t nil)))) + (message-add-action + `(when (gnus-buffer-exists-p ,buffer) + (save-excursion + (set-buffer ,buffer) + ,(when to-be-marked + (if (eq config 'forward) + `(gnus-summary-mark-article-as-forwarded ',to-be-marked) + `(gnus-summary-mark-article-as-replied ',to-be-marked))))) + 'send))) (put 'gnus-setup-message 'lisp-indent-function 1) (put 'gnus-setup-message 'edebug-form-spec '(form body)) @@ -306,6 +545,8 @@ ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) (buffer (current-buffer))) (unwind-protect (progn @@ -317,15 +558,49 @@ (gnus-read-active-file-p)) (gnus-group-group-name)) "")) + ;; #### see comment in gnus-setup-message -- drv (gnus-setup-message 'message (message-mail))) (save-excursion (set-buffer buffer) (setq gnus-newsgroup-name group))))) +(defun gnus-group-news (&optional arg) + "Start composing a news. +If ARG, post to group under point. +If ARG is 1, prompt for group name to post to. + +This function prepares a news even when using mail groups. This is useful +for posting messages to mail groups without actually sending them over the +network. The corresponding back end must have a 'request-post method." + (interactive "P") + ;; We can't `let' gnus-newsgroup-name here, since that leads + ;; to local variables leaking. + (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) + (buffer (current-buffer))) + (unwind-protect + (progn + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + (gnus-group-group-name)) + "")) + ;; #### see comment in gnus-setup-message -- drv + (gnus-setup-message 'message + (message-news (gnus-group-real-name gnus-newsgroup-name)))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) + (defun gnus-group-post-news (&optional arg) - "Start composing a news message. -If ARG, post to the group under point. -If ARG is 1, prompt for a group name." + "Start composing a message (a news by default). +If ARG, post to group under point. If ARG is 1, prompt for group name. +Depending on the selected group, the message might be either a mail or +a news." (interactive "P") ;; Bind this variable here to make message mode hooks work ok. (let ((gnus-newsgroup-name @@ -334,22 +609,110 @@ (completing-read "Newsgroup: " gnus-active-hashtb nil (gnus-read-active-file-p)) (gnus-group-group-name)) - ""))) + "")) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy)) + (gnus-post-news 'post gnus-newsgroup-name nil nil nil nil + (string= gnus-newsgroup-name "")))) + +(defun gnus-summary-mail-other-window (&optional arg) + "Start composing a mail in another window. +Use the posting of the current group by default. +If ARG, don't do that. If ARG is 1, prompt for group name to find the +posting style." + (interactive "P") + ;; We can't `let' gnus-newsgroup-name here, since that leads + ;; to local variables leaking. + (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) + (buffer (current-buffer))) + (unwind-protect + (progn + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name)) + ;; #### see comment in gnus-setup-message -- drv + (gnus-setup-message 'message (message-mail))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) + +(defun gnus-summary-news-other-window (&optional arg) + "Start composing a news in another window. +Post to the current group by default. +If ARG, don't do that. If ARG is 1, prompt for group name to post to. + +This function prepares a news even when using mail groups. This is useful +for posting messages to mail groups without actually sending them over the +network. The corresponding back end must have a 'request-post method." + (interactive "P") + ;; We can't `let' gnus-newsgroup-name here, since that leads + ;; to local variables leaking. + (let ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) + (buffer (current-buffer))) + (unwind-protect + (progn + (setq gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Use group: " + gnus-active-hashtb nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name)) + ;; #### see comment in gnus-setup-message -- drv + (gnus-setup-message 'message + (progn + (message-news (gnus-group-real-name gnus-newsgroup-name)) + (set (make-local-variable 'gnus-discouraged-post-methods) + (delq + (car (gnus-find-method-for-group gnus-newsgroup-name)) + (copy-sequence gnus-discouraged-post-methods)))))) + (save-excursion + (set-buffer buffer) + (setq gnus-newsgroup-name group))))) + +(defun gnus-summary-post-news (&optional arg) + "Start composing a message. Post to the current group by default. +If ARG, don't do that. If ARG is 1, prompt for a group name to post to. +Depending on the selected group, the message might be either a mail or +a news." + (interactive "P") + ;; Bind this variable here to make message mode hooks work ok. + (let ((gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (completing-read "Newsgroup: " gnus-active-hashtb nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name)) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy)) (gnus-post-news 'post gnus-newsgroup-name))) -(defun gnus-summary-post-news () - "Start composing a news message." - (interactive) - (gnus-post-news 'post gnus-newsgroup-name)) (defun gnus-summary-followup (yank &optional force-news) "Compose a followup to an article. -If prefix argument YANK is non-nil, original article is yanked automatically." +If prefix argument YANK is non-nil, the original article is yanked +automatically. +YANK is a list of elements, where the car of each element is the +article number, and the cdr is the string to be yanked." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) (when yank - (gnus-summary-goto-subject (car yank))) + (gnus-summary-goto-subject + (if (listp (car yank)) + (caar yank) + (car yank)))) (save-window-excursion (gnus-summary-select-article)) (let ((headers (gnus-summary-article-header (gnus-summary-article-number))) @@ -357,10 +720,13 @@ ;; Send a followup. (gnus-post-news nil gnus-newsgroup-name headers gnus-article-buffer - yank nil force-news))) + yank nil force-news) + (gnus-summary-handle-replysign))) (defun gnus-summary-followup-with-original (n &optional force-news) - "Compose a followup to an article and include the original article." + "Compose a followup to an article and include the original article. +The text in the region will be yanked. If the region isn't +active, the entire article will be yanked." (interactive "P") (gnus-summary-followup (gnus-summary-work-articles n) force-news)) @@ -377,16 +743,24 @@ (gnus-summary-followup (gnus-summary-work-articles arg) t)) (defun gnus-inews-yank-articles (articles) - (let (beg article) + (let (beg article yank-string) (message-goto-body) (while (setq article (pop articles)) + (when (listp article) + (setq yank-string (nth 1 article) + article (nth 0 article))) (save-window-excursion (set-buffer gnus-summary-buffer) (gnus-summary-select-article nil nil nil article) (gnus-summary-remove-process-mark article)) - (gnus-copy-article-buffer) + (gnus-copy-article-buffer nil yank-string) (let ((message-reply-buffer gnus-article-copy) - (message-reply-headers gnus-current-headers)) + (message-reply-headers + ;; The headers are decoded. + (with-current-buffer gnus-article-copy + (save-restriction + (nnheader-narrow-to-headers) + (nnheader-parse-naked-head))))) (message-yank-original) (setq beg (or beg (mark t)))) (when articles @@ -403,7 +777,7 @@ (let ((articles (gnus-summary-work-articles n)) (message-post-method `(lambda (arg) - (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name))) + (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))) article) (while (setq article (pop articles)) (when (gnus-summary-select-article t nil nil article) @@ -435,7 +809,7 @@ -(defun gnus-copy-article-buffer (&optional article-buffer) +(defun gnus-copy-article-buffer (&optional article-buffer yank-string) ;; make a copy of the article buffer with all text properties removed ;; this copy is in the buffer gnus-article-copy. ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used @@ -451,40 +825,59 @@ (error "Can't find any article buffer") (save-excursion (set-buffer article-buffer) - (save-restriction - ;; Copy over the (displayed) article buffer, delete - ;; hidden text and remove text properties. - (widen) - (copy-to-buffer gnus-article-copy (point-min) (point-max)) - (set-buffer gnus-article-copy) - (gnus-article-delete-text-of-type 'annotation) - (gnus-remove-text-with-property 'gnus-prev) - (gnus-remove-text-with-property 'gnus-next) - (insert - (prog1 - (buffer-substring-no-properties (point-min) (point-max)) - (erase-buffer))) - ;; Find the original headers. - (set-buffer gnus-original-article-buffer) - (goto-char (point-min)) - (while (looking-at message-unix-mail-delimiter) - (forward-line 1)) - (setq beg (point)) - (setq end (or (search-forward "\n\n" nil t) (point))) - ;; Delete the headers from the displayed articles. - (set-buffer gnus-article-copy) - (delete-region (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) - ;; Insert the original article headers. - (insert-buffer-substring gnus-original-article-buffer beg end) - (article-decode-encoded-words))) + (let ((gnus-newsgroup-charset (or gnus-article-charset + gnus-newsgroup-charset)) + (gnus-newsgroup-ignored-charsets + (or gnus-article-ignored-charsets + gnus-newsgroup-ignored-charsets))) + (save-restriction + ;; Copy over the (displayed) article buffer, delete + ;; hidden text and remove text properties. + (widen) + (copy-to-buffer gnus-article-copy (point-min) (point-max)) + (set-buffer gnus-article-copy) + (when yank-string + (message-goto-body) + (delete-region (point) (point-max)) + (insert yank-string)) + (gnus-article-delete-text-of-type 'annotation) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next) + (gnus-remove-text-with-property 'gnus-decoration) + (insert + (prog1 + (buffer-substring-no-properties (point-min) (point-max)) + (erase-buffer))) + ;; Find the original headers. + (set-buffer gnus-original-article-buffer) + (goto-char (point-min)) + (while (looking-at message-unix-mail-delimiter) + (forward-line 1)) + (let ((mail-header-separator "")) + (setq beg (point) + end (or (message-goto-body) + ;; There may be just a header. + (point-max)))) + ;; Delete the headers from the displayed articles. + (set-buffer gnus-article-copy) + (let ((mail-header-separator "")) + (delete-region (goto-char (point-min)) + (or (message-goto-body) (point-max)))) + ;; Insert the original article headers. + (insert-buffer-substring gnus-original-article-buffer beg end) + ;; Decode charsets. + (let ((gnus-article-decode-hook + (delq 'article-decode-charset + (copy-sequence gnus-article-decode-hook)))) + (run-hooks 'gnus-article-decode-hook))))) gnus-article-copy))) (defun gnus-post-news (post &optional group header article-buffer yank subject force-news) (when article-buffer (gnus-copy-article-buffer)) - (let ((gnus-article-reply article-buffer) + (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number))) + (gnus-article-yanked-articles yank) (add-to-list gnus-add-to-list)) (gnus-setup-message (cond (yank 'reply-yank) (article-buffer 'reply) @@ -495,9 +888,9 @@ to-address to-group mailing-list to-list newsgroup-p) (when group - (setq to-address (gnus-group-find-parameter group 'to-address) + (setq to-address (gnus-parameter-to-address group) to-group (gnus-group-find-parameter group 'to-group) - to-list (gnus-group-find-parameter group 'to-list) + to-list (gnus-parameter-to-list group) newsgroup-p (gnus-group-find-parameter group 'newsgroup) mailing-list (when gnus-mailing-list-groups (string-match gnus-mailing-list-groups group)) @@ -509,8 +902,7 @@ force-news (and (gnus-news-group-p (or pgroup gnus-newsgroup-name) - (if header (mail-header-number header) - gnus-current-article)) + (or header gnus-current-article)) (not mailing-list) (not to-list) (not to-address))) @@ -519,7 +911,13 @@ (message-news (or to-group group)) (set-buffer gnus-article-copy) (gnus-msg-treat-broken-reply-to) - (message-followup (if (or newsgroup-p force-news) nil to-group))) + (message-followup (if (or newsgroup-p force-news) + (if (save-restriction + (article-narrow-to-head) + (message-fetch-field "newsgroups")) + nil + "") + to-group))) ;; The is mail. (if post (progn @@ -537,10 +935,11 @@ (when yank (gnus-inews-yank-articles yank)))))) -(defun gnus-msg-treat-broken-reply-to () +(defun gnus-msg-treat-broken-reply-to (&optional force) "Remove the Reply-to header if broken-reply-to." - (when (gnus-group-find-parameter - gnus-newsgroup-name 'broken-reply-to) + (when (or force + (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to)) (save-restriction (message-narrow-to-head) (message-remove-header "reply-to")))) @@ -548,28 +947,31 @@ (defun gnus-post-method (arg group &optional silent) "Return the posting method based on GROUP and ARG. If SILENT, don't prompt the user." - (let ((group-method (gnus-find-method-for-group group))) + (let ((gnus-post-method (or (gnus-parameter-post-method group) + gnus-post-method)) + (group-method (gnus-find-method-for-group group))) (cond ;; If the group-method is nil (which shouldn't happen) we use ;; the default method. ((null group-method) - (or (and (null (eq gnus-post-method 'active)) gnus-post-method) - gnus-select-method message-post-method)) + (or (and (listp gnus-post-method) ;If not current/native/nil + (not (listp (car gnus-post-method))) ; and not a list of methods + gnus-post-method) ;then use it. + gnus-select-method + message-post-method)) ;; We want the inverse of the default ((and arg (not (eq arg 0))) - (if (eq gnus-post-method 'active) + (if (eq gnus-post-method 'current) gnus-select-method group-method)) ;; We query the user for a post method. ((or arg - (and gnus-post-method - (not (eq gnus-post-method 'current)) + (and (listp gnus-post-method) (listp (car gnus-post-method)))) (let* ((methods ;; Collect all methods we know about. (append - (when (and gnus-post-method - (not (eq gnus-post-method 'current))) + (when (listp gnus-post-method) (if (listp (car gnus-post-method)) gnus-post-method (list gnus-post-method))) @@ -590,7 +992,9 @@ (setq method-alist (mapcar (lambda (m) - (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)) + (if (equal (cadr m) "") + (list (symbol-name (car m)) m) + (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))) post-methods)) ;; Query the user. (cadr @@ -606,44 +1010,34 @@ method-alist)))) ;; Override normal method. ((and (eq gnus-post-method 'current) - (not (eq (car group-method) 'nndraft)) - (gnus-get-function group-method 'request-post t) - (not arg)) + (not (memq (car group-method) gnus-discouraged-post-methods)) + (gnus-get-function group-method 'request-post t)) + (assert (not arg)) group-method) - ((and gnus-post-method - (not (eq gnus-post-method 'current))) + ;; Use gnus-post-method. + ((listp gnus-post-method) ;A method... + (assert (not (listp (car gnus-post-method)))) ;... not a list of methods. gnus-post-method) - ;; Use the normal select method. + ;; Use the normal select method (nil or native). (t gnus-select-method)))) -;; Dummies to avoid byte-compile warning. -(eval-when-compile - (defvar nnspool-rejected-article-hook) - (defvar xemacs-codename)) - (defun gnus-extended-version () - "Stringified Gnus version and Emacs version." + "Stringified Gnus version and Emacs version. +See the variable `gnus-user-agent'." (interactive) - (concat - "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t) - " (" gnus-version ")" - " " - (cond - ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) - (concat "Emacs/" (match-string 1 emacs-version))) - ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" - emacs-version) - (concat (match-string 1 emacs-version) - (format "/%d.%d" emacs-major-version emacs-minor-version) - (if (match-beginning 3) - (match-string 3 emacs-version) - "") - (if (boundp 'xemacs-codename) - (concat " (" xemacs-codename ")") - ""))) - (t emacs-version)))) + (let* ((float-output-format nil) + (gnus-v + (concat "Gnus/" + (prin1-to-string (gnus-continuum-version gnus-version) t) + " (" gnus-version ")")) + (emacs-v (gnus-emacs-version))) + (if (stringp gnus-user-agent) + gnus-user-agent + (concat gnus-v + (when emacs-v + (concat " " emacs-v)))))) ;;; @@ -652,28 +1046,77 @@ ;;; Mail reply commands of Gnus summary mode -(defun gnus-summary-reply (&optional yank wide) - "Start composing a reply mail to the current message. +(defun gnus-summary-reply (&optional yank wide very-wide) + "Start composing a mail reply to the current message. If prefix argument YANK is non-nil, the original article is yanked -automatically." +automatically. +If WIDE, make a wide reply. +If VERY-WIDE, make a very wide reply." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) - ;; Stripping headers should be specified with mail-yank-ignored-headers. - (when yank - (gnus-summary-goto-subject (car yank))) - (let ((gnus-article-reply t)) - (gnus-setup-message (if yank 'reply-yank 'reply) - (gnus-summary-select-article) - (set-buffer (gnus-copy-article-buffer)) - (gnus-msg-treat-broken-reply-to) - (save-restriction - (message-narrow-to-head) - (goto-char (point-max))) - (mml-quote-region (point) (point-max)) - (message-reply nil wide) + ;; Allow user to require confirmation before replying by mail to the + ;; author of a news article (or mail message). + (when (or + (not (or (gnus-news-group-p gnus-newsgroup-name) + gnus-confirm-treat-mail-like-news)) + (not (cond ((stringp gnus-confirm-mail-reply-to-news) + (string-match gnus-confirm-mail-reply-to-news + gnus-newsgroup-name)) + ((functionp gnus-confirm-mail-reply-to-news) + (funcall gnus-confirm-mail-reply-to-news gnus-newsgroup-name)) + (t gnus-confirm-mail-reply-to-news))) + (y-or-n-p "Really reply by mail to article author? ")) + (let* ((article + (if (listp (car yank)) + (caar yank) + (car yank))) + (gnus-article-reply (or article (gnus-summary-article-number))) + (gnus-article-yanked-articles yank) + (headers "")) + ;; Stripping headers should be specified with mail-yank-ignored-headers. (when yank - (gnus-inews-yank-articles yank))))) + (gnus-summary-goto-subject article)) + (gnus-setup-message (if yank 'reply-yank 'reply) + (if (not very-wide) + (gnus-summary-select-article) + (dolist (article very-wide) + (gnus-summary-select-article nil nil nil article) + (save-excursion + (set-buffer (gnus-copy-article-buffer)) + (gnus-msg-treat-broken-reply-to) + (save-restriction + (message-narrow-to-head) + (setq headers (concat headers (buffer-string))))))) + (set-buffer (gnus-copy-article-buffer)) + (gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to) + (save-restriction + (message-narrow-to-head) + (when very-wide + (erase-buffer) + (insert headers)) + (goto-char (point-max))) + (mml-quote-region (point) (point-max)) + (message-reply nil wide) + (when yank + (gnus-inews-yank-articles yank)) + (gnus-summary-handle-replysign))))) + +(defun gnus-summary-handle-replysign () + "Check the various replysign variables and take action accordingly." + (when (or gnus-message-replysign gnus-message-replyencrypt) + (let (signed encrypted) + (save-excursion + (set-buffer gnus-article-buffer) + (setq signed (memq 'signed gnus-article-wash-types)) + (setq encrypted (memq 'encrypted gnus-article-wash-types))) + (cond ((and gnus-message-replyencrypt encrypted) + (mml-secure-message mml-default-encrypt-method + (if gnus-message-replysignencrypted + 'signencrypt + 'encrypt))) + ((and gnus-message-replysign signed) + (mml-secure-message mml-default-sign-method 'sign)))))) (defun gnus-summary-reply-with-original (n &optional wide) "Start composing a reply mail to the current message. @@ -681,6 +1124,24 @@ (interactive "P") (gnus-summary-reply (gnus-summary-work-articles n) wide)) +(defun gnus-summary-reply-broken-reply-to (&optional yank wide very-wide) + "Like `gnus-summary-reply' except removing reply-to field. +If prefix argument YANK is non-nil, the original article is yanked +automatically. +If WIDE, make a wide reply. +If VERY-WIDE, make a very wide reply." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (let ((gnus-msg-force-broken-reply-to t)) + (gnus-summary-reply yank wide very-wide))) + +(defun gnus-summary-reply-broken-reply-to-with-original (n &optional wide) + "Like `gnus-summary-reply-with-original' except removing reply-to field. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply-broken-reply-to (gnus-summary-work-articles n) wide)) + (defun gnus-summary-wide-reply (&optional yank) "Start composing a wide reply mail to the current message. If prefix argument YANK is non-nil, the original article is yanked @@ -692,50 +1153,125 @@ (defun gnus-summary-wide-reply-with-original (n) "Start composing a wide reply mail to the current message. -The original article will be yanked." +The original article will be yanked. +Uses the process/prefix convention." (interactive "P") (gnus-summary-reply-with-original n t)) +(defun gnus-summary-very-wide-reply (&optional yank) + "Start composing a very wide reply mail to the current message. +If prefix argument YANK is non-nil, the original article is yanked +automatically." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-reply yank t (gnus-summary-work-articles yank))) + +(defun gnus-summary-very-wide-reply-with-original (n) + "Start composing a very wide reply mail to the current message. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply + (gnus-summary-work-articles n) t (gnus-summary-work-articles n))) + (defun gnus-summary-mail-forward (&optional arg post) - "Forward the current message to another user. -If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml'; + "Forward the current message(s) to another user. +If process marks exist, forward all marked messages; +if ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml'; if ARG is 1, decode the message and forward directly inline; if ARG is 2, forward message as an rfc822 MIME section; if ARG is 3, decode message and forward as an rfc822 MIME section; if ARG is 4, forward message directly inline; otherwise, use flipped `message-forward-as-mime'. -If POST, post instead of mail." +If POST, post instead of mail. +For the `inline' alternatives, also see the variable +`message-forward-ignored-headers'." (interactive "P") - (let ((message-forward-as-mime message-forward-as-mime) - (message-forward-show-mml message-forward-show-mml)) - (cond - ((null arg)) - ((eq arg 1) (setq message-forward-as-mime nil - message-forward-show-mml t)) - ((eq arg 2) (setq message-forward-as-mime t - message-forward-show-mml nil)) - ((eq arg 3) (setq message-forward-as-mime t - message-forward-show-mml t)) - ((eq arg 4) (setq message-forward-as-mime nil - message-forward-show-mml nil)) - (t (setq message-forward-as-mime (not message-forward-as-mime)))) - (gnus-setup-message 'forward - (gnus-summary-select-article) - (let ((mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)) - (set-buffer gnus-original-article-buffer) - (message-forward post))))) + (if (cdr (gnus-summary-work-articles nil)) + ;; Process marks are given. + (gnus-uu-digest-mail-forward arg post) + ;; No process marks. + (let ((message-forward-as-mime message-forward-as-mime) + (message-forward-show-mml message-forward-show-mml)) + (cond + ((null arg)) + ((eq arg 1) + (setq message-forward-as-mime nil + message-forward-show-mml t)) + ((eq arg 2) + (setq message-forward-as-mime t + message-forward-show-mml nil)) + ((eq arg 3) + (setq message-forward-as-mime t + message-forward-show-mml t)) + ((eq arg 4) + (setq message-forward-as-mime nil + message-forward-show-mml nil)) + (t + (setq message-forward-as-mime (not message-forward-as-mime)))) + (let* ((gnus-article-reply (gnus-summary-article-number)) + (gnus-article-yanked-articles (list gnus-article-reply))) + (gnus-setup-message 'forward + (gnus-summary-select-article) + (let ((mail-parse-charset + (or (and (gnus-buffer-live-p gnus-article-buffer) + (with-current-buffer gnus-article-buffer + gnus-article-charset)) + gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + gnus-newsgroup-ignored-charsets)) + (set-buffer gnus-original-article-buffer) + (message-forward post))))))) (defun gnus-summary-resend-message (address n) "Resend the current article to ADDRESS." - (interactive "sResend message(s) to: \nP") + (interactive + (list (message-read-from-minibuffer + "Resend message(s) to: " + (when (and gnus-summary-resend-default-address + (gnus-buffer-live-p gnus-original-article-buffer)) + ;; If some other article is currently selected, the + ;; initial-contents is wrong. Whatever, it is just the + ;; initial-contents. + (with-current-buffer gnus-original-article-buffer + (nnmail-fetch-field "to")))) + current-prefix-arg)) (let ((articles (gnus-summary-work-articles n)) article) (while (setq article (pop articles)) (gnus-summary-select-article nil nil nil article) (save-excursion (set-buffer gnus-original-article-buffer) - (message-resend address))))) + (message-resend address)) + (gnus-summary-mark-article-as-forwarded article)))) + +;; From: Matthieu Moy <Matthieu.Moy@imag.fr> +(defun gnus-summary-resend-message-edit () + "Resend an article that has already been sent. +A new buffer will be created to allow the user to modify body and +contents of the message, and then, everything will happen as when +composing a new message." + (interactive) + (let ((article (gnus-summary-article-number))) + (gnus-setup-message 'reply-yank + (gnus-summary-select-article t) + (set-buffer gnus-original-article-buffer) + (let ((cur (current-buffer)) + (to (message-fetch-field "to"))) + ;; Get a normal message buffer. + (message-pop-to-buffer (message-buffer-name "Resend" to)) + (insert-buffer-substring cur) + (message-narrow-to-head-1) + ;; Gnus will generate a new one when sending. + (message-remove-header "Message-ID") + (message-remove-header message-ignored-resent-headers t) + ;; Remove unwanted headers. + (goto-char (point-max)) + (insert mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^To:\\|^Newsgroups:" nil 'move) + (forward-char 1)) + (widen))))) (defun gnus-summary-post-forward (&optional arg) "Forward the current article to a newsgroup. @@ -796,12 +1332,6 @@ (when (gnus-y-or-n-p "Send this complaint? ") (message-send-and-exit))))))) -(defun gnus-summary-mail-other-window () - "Compose mail in other window." - (interactive) - (gnus-setup-message 'message - (message-mail))) - (defun gnus-mail-parse-comma-list () (let (accumulated beg) @@ -836,7 +1366,7 @@ ;; This mail group doesn't have a `to-list', so we add one ;; here. Magic! (when (gnus-y-or-n-p - (format "Do you want to add this as `to-list': %s " to-address)) + (format "Do you want to add this as `to-list': %s? " to-address)) (gnus-group-add-parameter group (cons 'to-list to-address)))))) (defun gnus-put-message () @@ -845,35 +1375,34 @@ (let ((reply gnus-article-reply) (winconf gnus-prev-winconf) (group gnus-newsgroup-name)) + (unless (and group + (not (gnus-group-read-only-p group))) + (setq group (read-string "Put in group: " nil (gnus-writable-groups)))) - (or (and group (not (gnus-group-read-only-p group))) - (setq group (read-string "Put in group: " nil - (gnus-writable-groups)))) (when (gnus-gethash group gnus-newsrc-hashtb) (error "No such group: %s" group)) - (save-excursion (save-restriction (widen) (message-narrow-to-headers) - (let (gnus-deletable-headers) - (if (message-news-p) - (message-generate-headers message-required-news-headers) - (message-generate-headers message-required-mail-headers))) + (let ((gnus-deletable-headers nil)) + (message-generate-headers + (if (message-news-p) + message-required-news-headers + message-required-mail-headers))) (goto-char (point-max)) - (insert "Gcc: " group "\n") + (if (string-match " " group) + (insert "Gcc: \"" group "\"\n") + (insert "Gcc: " group "\n")) (widen))) - (gnus-inews-do-gcc) - - (when (get-buffer gnus-group-buffer) - (when (gnus-buffer-exists-p (car-safe reply)) - (set-buffer (car reply)) - (and (cdr reply) - (gnus-summary-mark-article-as-replied - (cdr reply)))) - (when winconf - (set-window-configuration winconf))))) + (when (and (get-buffer gnus-group-buffer) + (gnus-buffer-exists-p (car-safe reply)) + (cdr reply)) + (set-buffer (car reply)) + (gnus-summary-mark-article-as-replied (cdr reply))) + (when winconf + (set-window-configuration winconf)))) (defun gnus-article-mail (yank) "Send a reply to the address near point. @@ -884,7 +1413,7 @@ (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point))) (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point)))))) (when address - (message-reply address) + (gnus-msg-mail address) (when yank (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) @@ -919,9 +1448,10 @@ (let (text) (save-excursion (set-buffer (gnus-get-buffer-create " *gnus environment info*")) + (erase-buffer) (gnus-debug) (setq text (buffer-string))) - (insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>")) + (insert "<#part type=application/emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>")) (goto-char (point-min)) (search-forward "Subject: " nil t) (message ""))) @@ -936,8 +1466,7 @@ (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t) current-prefix-arg)) (gnus-summary-iterate n - (let ((gnus-display-mime-function nil) - (gnus-inhibit-treatment t)) + (let ((gnus-inhibit-treatment t)) (gnus-summary-select-article)) (save-excursion (set-buffer buffer) @@ -947,10 +1476,7 @@ "Attempts to go through the Gnus source file and report what variables have been changed. The source file has to be in the Emacs load path." (interactive) - (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el" - "gnus-art.el" "gnus-start.el" "gnus-async.el" - "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el" - "nnmail.el" "message.el")) + (let ((files gnus-debug-files) (point (point)) file expr olist sym) (gnus-message 4 "Please wait while we snoop your variables...") @@ -973,6 +1499,7 @@ (and (or (eq (car expr) 'defvar) (eq (car expr) 'defcustom)) (stringp (nth 3 expr)) + (not (memq (nth 1 expr) gnus-debug-exclude-variables)) (or (not (boundp (nth 1 expr))) (not (equal (eval (nth 2 expr)) (symbol-value (nth 1 expr))))) @@ -982,17 +1509,15 @@ (insert "------------------ Environment follows ------------------\n\n")) (while olist (if (boundp (car olist)) - (condition-case () - (pp `(setq ,(car olist) - ,(if (or (consp (setq sym (symbol-value (car olist)))) - (and (symbolp sym) - (not (or (eq sym nil) - (eq sym t))))) - (list 'quote (symbol-value (car olist))) - (symbol-value (car olist)))) - (current-buffer)) - (error - (format "(setq %s 'whatever)\n" (car olist)))) + (ignore-errors + (pp `(setq ,(car olist) + ,(if (or (consp (setq sym (symbol-value (car olist)))) + (and (symbolp sym) + (not (or (eq sym nil) + (eq sym t))))) + (list 'quote (symbol-value (car olist))) + (symbol-value (car olist)))) + (current-buffer))) (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) (setq olist (cdr olist))) (insert "\n\n") @@ -1008,7 +1533,7 @@ (defun gnus-summary-resend-bounced-mail (&optional fetch) "Re-mail the current message. -This only makes sense if the current message is a bounce message than +This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to you. If FETCH, try to fetch the article that this is a reply to, if indeed @@ -1028,62 +1553,98 @@ ;;; Gcc handling. (defun gnus-inews-group-method (group) - (cond ((and (null (gnus-get-info group)) - (eq (car gnus-message-archive-method) - (car - (gnus-server-to-method - (gnus-group-method group))))) - ;; If the group doesn't exist, we assume - ;; it's an archive group... - gnus-message-archive-method) - ;; Use the method. - ((gnus-info-method (gnus-get-info group)) - (gnus-info-method (gnus-get-info group))) - ;; Find the method. - (t (gnus-group-method group)))) + (cond + ;; If the group doesn't exist, we assume + ;; it's an archive group... + ((and (null (gnus-get-info group)) + (eq (car (gnus-server-to-method gnus-message-archive-method)) + (car (gnus-server-to-method (gnus-group-method group))))) + gnus-message-archive-method) + ;; Use the method. + ((gnus-info-method (gnus-get-info group)) + (gnus-info-method (gnus-get-info group))) + ;; Find the method. + (t (gnus-server-to-method (gnus-group-method group))))) ;; Do Gcc handling, which copied the message over to some group. (defun gnus-inews-do-gcc (&optional gcc) (interactive) - (when (gnus-alive-p) - (save-excursion - (save-restriction - (message-narrow-to-headers) - (let ((gcc (or gcc (mail-fetch-field "gcc" nil t))) - (cur (current-buffer)) - groups group method) - (when gcc - (message-remove-header "gcc") - (widen) - (setq groups (message-unquote-tokens - (message-tokenize-header gcc " ,"))) - ;; Copy the article over to some group(s). - (while (setq group (pop groups)) - (gnus-check-server - (setq method (gnus-inews-group-method group))) - (unless (gnus-request-group group t method) - (gnus-request-create-group group method)) - (save-excursion - (nnheader-set-temp-buffer " *acc*") - (insert-buffer-substring cur) - (message-encode-message-body) - (save-restriction - (message-narrow-to-headers) - (let ((mail-parse-charset message-default-charset) - (rfc2047-header-encoding-alist - (cons '("Newsgroups" . default) - rfc2047-header-encoding-alist))) - (mail-encode-encoded-word-buffer))) - (goto-char (point-min)) - (when (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (replace-match "" t t )) - (unless (gnus-request-accept-article group method t t) - (gnus-message 1 "Couldn't store article in group %s: %s" - group (gnus-status-message method)) - (sit-for 2)) - (kill-buffer (current-buffer)))))))))) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (let ((gcc (or gcc (mail-fetch-field "gcc" nil t))) + (cur (current-buffer)) + groups group method group-art + mml-externalize-attachments) + (when gcc + (message-remove-header "gcc") + (widen) + (setq groups (message-unquote-tokens + (message-tokenize-header gcc " ,"))) + ;; Copy the article over to some group(s). + (while (setq group (pop groups)) + (unless (gnus-check-server + (setq method (gnus-inews-group-method group))) + (error "Can't open server %s" (if (stringp method) method + (car method)))) + (unless (gnus-request-group group nil method) + (gnus-request-create-group group method)) + (setq mml-externalize-attachments + (if (stringp gnus-gcc-externalize-attachments) + (string-match gnus-gcc-externalize-attachments group) + gnus-gcc-externalize-attachments)) + (save-excursion + (nnheader-set-temp-buffer " *acc*") + (insert-buffer-substring cur) + (message-encode-message-body) + (save-restriction + (message-narrow-to-headers) + (let* ((mail-parse-charset message-default-charset) + (newsgroups-field (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups"))) + (followup-field (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Followup-To"))) + ;; BUG: We really need to get the charset for + ;; each name in the Newsgroups and Followup-To + ;; lines to allow crossposting between group + ;; namess with incompatible character sets. + ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08. + (group-field-charset + (gnus-group-name-charset + method (or newsgroups-field ""))) + (followup-field-charset + (gnus-group-name-charset + method (or followup-field ""))) + (rfc2047-header-encoding-alist + (append + (when group-field-charset + (list (cons "Newsgroups" group-field-charset))) + (when followup-field-charset + (list (cons "Followup-To" followup-field-charset))) + rfc2047-header-encoding-alist))) + (mail-encode-encoded-word-buffer))) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t )) + (unless (setq group-art + (gnus-request-accept-article group method t t)) + (gnus-message 1 "Couldn't store article in group %s: %s" + group (gnus-status-message method)) + (sit-for 2)) + (when (and group-art + ;; FIXME: Should gcc-mark-as-read work when + ;; Gnus is not running? + (gnus-alive-p) + (or gnus-gcc-mark-as-read + (and + (boundp 'gnus-inews-mark-gcc-as-read) + (symbol-value 'gnus-inews-mark-gcc-as-read)))) + (gnus-group-mark-article-read group (cdr group-art))) + (kill-buffer (current-buffer))))))))) (defun gnus-inews-insert-gcc () "Insert Gcc headers based on `gnus-outgoing-message-group'." @@ -1092,14 +1653,21 @@ (message-narrow-to-headers) (let* ((group gnus-outgoing-message-group) (gcc (cond - ((gnus-functionp group) + ((functionp group) (funcall group)) ((or (stringp group) (list group)) group)))) (when gcc (insert "Gcc: " - (if (stringp gcc) gcc - (mapconcat 'identity gcc " ")) + (if (stringp gcc) + (if (string-match " " gcc) + (concat "\"" gcc "\"") + gcc) + (mapconcat (lambda (group) + (if (string-match " " group) + (concat "\"" group "\"") + group)) + gcc " ")) "\n")))))) (defun gnus-inews-insert-archive-gcc (&optional group) @@ -1126,7 +1694,7 @@ ((and (listp var) (stringp (car var))) ;; A list of groups. var) - ((gnus-functionp var) + ((functionp var) ;; A function. (funcall var group)) (t @@ -1139,7 +1707,7 @@ ;; Regexp. (when (string-match (caar var) group) (cdar var))) - ((gnus-functionp (car var)) + ((functionp (car var)) ;; Function. (funcall (car var) group)) (t @@ -1160,31 +1728,51 @@ (progn (insert (if (stringp gcc-self-val) - gcc-self-val - group)) + (if (string-match " " gcc-self-val) + (concat "\"" gcc-self-val "\"") + gcc-self-val) + ;; In nndoc groups, we use the parent group name + ;; instead of the current group. + (let ((group (or (gnus-group-find-parameter + gnus-newsgroup-name 'parent-group) + group))) + (if (string-match " " group) + (concat "\"" group "\"") + group)))) (if (not (eq gcc-self-val 'none)) (insert "\n") - (progn - (beginning-of-line) - (kill-line)))) + (gnus-delete-line))) ;; Use the list of groups. (while (setq name (pop groups)) - (insert (if (string-match ":" name) - name - (gnus-group-prefixed-name - name gnus-message-archive-method))) + (let ((str (if (string-match ":" name) + name + (gnus-group-prefixed-name + name gnus-message-archive-method)))) + (insert (if (string-match " " str) + (concat "\"" str "\"") + str))) (when groups (insert " "))) (insert "\n"))))))) +(defun gnus-mailing-list-followup-to () + "Look at the headers in the current buffer and return a Mail-Followup-To address." + (let ((x-been-there (gnus-fetch-original-field "x-beenthere")) + (list-post (gnus-fetch-original-field "list-post"))) + (when (and list-post + (string-match "mailto:\\([^>]+\\)" list-post)) + (setq list-post (match-string 1 list-post))) + (or list-post + x-been-there))) + ;;; Posting styles. -(defun gnus-configure-posting-styles () +(defun gnus-configure-posting-styles (&optional group-name) "Configure posting styles according to `gnus-posting-styles'." (unless gnus-inhibit-posting-styles - (let ((group (or gnus-newsgroup-name "")) + (let ((group (or group-name gnus-newsgroup-name "")) (styles gnus-posting-styles) - style match variable attribute value v results + style match attribute value v results filep name address element) ;; If the group has a posting-style parameter, add it at the end with a ;; regexp matching everything, to be sure it takes precedence over all @@ -1202,25 +1790,36 @@ ;; Regexp string match on the group name. (string-match match group)) ((eq match 'header) - (let ((header (message-fetch-field (pop style)))) - (and header - (string-match (pop style) header)))) + ;; Obsolete format of header match. + (and (gnus-buffer-live-p gnus-article-copy) + (with-current-buffer gnus-article-copy + (let ((header (message-fetch-field (pop style)))) + (and header + (string-match (pop style) header)))))) ((or (symbolp match) - (gnus-functionp match)) + (functionp match)) (cond - ((gnus-functionp match) + ((functionp match) ;; Function to be called. (funcall match)) ((boundp match) ;; Variable to be checked. (symbol-value match)))) ((listp match) - ;; This is a form to be evaled. - (eval match))) + (cond + ((eq (car match) 'header) + ;; New format of header match. + (and (gnus-buffer-live-p gnus-article-copy) + (with-current-buffer gnus-article-copy + (let ((header (message-fetch-field (nth 1 match)))) + (and header + (string-match (nth 2 match) header)))))) + (t + ;; This is a form to be evaled. + (eval match))))) ;; We have a match, so we set the variables. (dolist (attribute style) (setq element (pop attribute) - variable nil filep nil) (setq value (cond @@ -1237,21 +1836,28 @@ ((stringp value) value) ((or (symbolp value) - (gnus-functionp value)) - (cond ((gnus-functionp value) + (functionp value)) + (cond ((functionp value) (funcall value)) ((boundp value) (symbol-value value)))) ((listp value) (eval value)))) ;; Translate obsolescent value. - (when (eq element 'signature-file) + (cond + ((eq element 'signature-file) (setq element 'signature filep t)) + ((eq element 'x-face-file) + (setq element 'x-face + filep t))) ;; Get the contents of file elems. (when (and filep v) (setq v (with-temp-buffer (insert-file-contents v) + (goto-char (point-max)) + (while (bolp) + (delete-char -1)) (buffer-string)))) (setq results (delq (assoc element results) results)) (push (cons element v) results)))) @@ -1259,7 +1865,9 @@ (setq name (assq 'name results) address (assq 'address results)) (setq results (delq name (delq address results))) - (make-local-variable 'message-setup-hook) + (gnus-make-local-hook 'message-setup-hook) + (setq results (sort results (lambda (x y) + (string-lessp (car x) (car y))))) (dolist (result results) (add-hook 'message-setup-hook (cond @@ -1291,19 +1899,23 @@ (let ((value ,(cdr result))) (when value (message-goto-eoh) - (insert ,header ": " value "\n")))))))))) + (insert ,header ": " value) + (unless (bolp) + (insert "\n"))))))))) + nil 'local)) (when (or name address) (add-hook 'message-setup-hook `(lambda () - (set (make-local-variable 'user-mail-address) - ,(or (cdr address) user-mail-address)) + (set (make-local-variable 'user-mail-address) + ,(or (cdr address) user-mail-address)) (let ((user-full-name ,(or (cdr name) (user-full-name))) (user-mail-address ,(or (cdr address) user-mail-address))) (save-excursion (message-remove-header "From") (message-goto-eoh) - (insert "From: " (message-make-from) "\n"))))))))) + (insert "From: " (message-make-from) "\n")))) + nil 'local))))) ;;; Allow redefinition of functions.
--- a/lisp/gnus/gnus-nocem.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-nocem.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,8 @@ ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002, 2004 +;; Free Software Foundation, Inc. + ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -58,6 +60,7 @@ See <URL:http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html> for an issuer registry." :group 'gnus-nocem + :link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html") :type '(repeat (choice string sexp))) (defcustom gnus-nocem-directory @@ -294,7 +297,8 @@ (while (search-forward "\t" nil t) (cond ((not (ignore-errors - (setq group (let ((obarray gnus-active-hashtb)) (read buf))))) + (setq group (let ((obarray gnus-nocem-real-group-hashtb)) + (read buf))))) ;; An error. ) ((not (symbolp group))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-picon.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,283 @@ +;;; gnus-picon.el --- displaying pretty icons in Gnus + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: news xpm annotation glyph faces + +;; 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: + +;; There are three picon types relevant to Gnus: +;; +;; Persons: person@subdomain.dom +;; users/dom/subdomain/person/face.gif +;; usenix/dom/subdomain/person/face.gif +;; misc/MISC/person/face.gif +;; Domains: subdomain.dom +;; domain/dom/subdomain/unknown/face.gif +;; Groups: comp.lang.lisp +;; news/comp/lang/lisp/unknown/face.gif +;; +;; Original implementation by Wes Hardaker <hardaker@ece.ucdavis.edu>. +;; +;;; Code: + +(require 'gnus) +(require 'custom) +(require 'gnus-art) + +;;; User variables: + +(defcustom gnus-picon-news-directories '("news") + "*List of directories to search for newsgroups faces." + :type '(repeat string) + :group 'gnus-picon) + +(defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc") + "*List of directories to search for user faces." + :type '(repeat string) + :group 'gnus-picon) + +(defcustom gnus-picon-domain-directories '("domains") + "*List of directories to search for domain faces. +Some people may want to add \"unknown\" to this list." + :type '(repeat string) + :group 'gnus-picon) + +(defcustom gnus-picon-file-types + (let ((types (list "xbm"))) + (when (gnus-image-type-available-p 'gif) + (push "gif" types)) + (when (gnus-image-type-available-p 'xpm) + (push "xpm" types)) + types) + "*List of suffixes on picon file names to try." + :type '(repeat string) + :group 'gnus-picon) + +(defface gnus-picon-xbm-face '((t (:foreground "black" :background "white"))) + "Face to show xbm picon in." + :group 'gnus-picon) + +(defface gnus-picon-face '((t (:foreground "black" :background "white"))) + "Face to show picon in." + :group 'gnus-picon) + +;;; Internal variables: + +(defvar gnus-picon-setup-p nil) +(defvar gnus-picon-glyph-alist nil + "Picon glyphs cache. +List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") +(defvar gnus-picon-cache nil) + +;;; Functions: + +(defsubst gnus-picon-split-address (address) + (setq address (split-string address "@")) + (if (stringp (cadr address)) + (cons (car address) (split-string (cadr address) "\\.")) + (if (stringp (car address)) + (split-string (car address) "\\.")))) + +(defun gnus-picon-find-face (address directories &optional exact) + (let* ((address (gnus-picon-split-address address)) + (user (pop address)) + (faddress address) + database directory result instance base) + (catch 'found + (dolist (database gnus-picon-databases) + (dolist (directory directories) + (setq address faddress + base (expand-file-name directory database)) + (while address + (when (setq result (gnus-picon-find-image + (concat base "/" (mapconcat 'downcase + (reverse address) + "/") + "/" (downcase user) "/"))) + (throw 'found result)) + (if exact + (setq address nil) + (pop address))) + ;; Kludge to search MISC as well. But not in "news". + (unless (string= directory "news") + (when (setq result (gnus-picon-find-image + (concat base "/MISC/" user "/"))) + (throw 'found result)))))))) + +(defun gnus-picon-find-image (directory) + (let ((types gnus-picon-file-types) + found type file) + (while (and (not found) + (setq type (pop types))) + (setq found (file-exists-p (setq file (concat directory "face." type))))) + (if found + file + nil))) + +(defun gnus-picon-insert-glyph (glyph category) + "Insert GLYPH into the buffer. +GLYPH can be either a glyph or a string." + (if (stringp glyph) + (insert glyph) + (gnus-add-wash-type category) + (gnus-add-image category (car glyph)) + (gnus-put-image (car glyph) (cdr glyph) category))) + +(defun gnus-picon-create-glyph (file) + (or (cdr (assoc file gnus-picon-glyph-alist)) + (cdar (push (cons file (gnus-create-image file)) + gnus-picon-glyph-alist)))) + +;;; Functions that does picon transformations: + +(defun gnus-picon-transform-address (header category) + (gnus-with-article-headers + (let ((addresses + (mail-header-parse-addresses + ;; mail-header-parse-addresses does not work (reliably) on + ;; decoded headers. + (or + (ignore-errors + (mail-encode-encoded-word-string + (or (mail-fetch-field header) ""))) + (mail-fetch-field header)))) + spec file point cache) + (dolist (address addresses) + (setq address (car address)) + (when (and (stringp address) + (setq spec (gnus-picon-split-address address))) + (if (setq cache (cdr (assoc address gnus-picon-cache))) + (setq spec cache) + (when (setq file (or (gnus-picon-find-face + address gnus-picon-user-directories) + (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (cdr spec) ".")) + gnus-picon-user-directories))) + (setcar spec (cons (gnus-picon-create-glyph file) + (car spec)))) + + (dotimes (i (1- (length spec))) + (when (setq file (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (nthcdr (1+ i) spec) ".")) + gnus-picon-domain-directories t)) + (setcar (nthcdr (1+ i) spec) + (cons (gnus-picon-create-glyph file) + (nth (1+ i) spec))))) + (setq spec (nreverse spec)) + (push (cons address spec) gnus-picon-cache)) + + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (when (search-forward address nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq point (point)) + (while spec + (goto-char point) + (if (> (length spec) 2) + (insert ".") + (if (= (length spec) 2) + (insert "@"))) + (gnus-picon-insert-glyph (pop spec) category)))))))) + +(defun gnus-picon-transform-newsgroups (header) + (interactive) + (gnus-with-article-headers + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (let ((groups (message-tokenize-header (mail-fetch-field header))) + spec file point) + (dolist (group groups) + (unless (setq spec (cdr (assoc group gnus-picon-cache))) + (setq spec (nreverse (split-string group "[.]"))) + (dotimes (i (length spec)) + (when (setq file (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (nthcdr i spec) ".")) + gnus-picon-news-directories t)) + (setcar (nthcdr i spec) + (cons (gnus-picon-create-glyph file) + (nth i spec))))) + (push (cons group spec) gnus-picon-cache)) + (when (search-forward group nil t) + (delete-region (match-beginning 0) (match-end 0)) + (save-restriction + (narrow-to-region (point) (point)) + (while spec + (goto-char (point-min)) + (if (> (length spec) 1) + (insert ".")) + (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) + (goto-char (point-max)))))))) + +;;; Commands: + +;; #### NOTE: the test for buffer-read-only is the same as in +;; article-display-[x-]face. See the comment up there. + +;;;###autoload +(defun gnus-treat-from-picon () + "Display picons in the From header. +If picons are already displayed, remove them." + (interactive) + (let ((wash-picon-p buffer-read-only)) + (gnus-with-article-buffer + (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types)) + (gnus-delete-images 'from-picon) + (gnus-picon-transform-address "from" 'from-picon))) + )) + +;;;###autoload +(defun gnus-treat-mail-picon () + "Display picons in the Cc and To headers. +If picons are already displayed, remove them." + (interactive) + (let ((wash-picon-p buffer-read-only)) + (gnus-with-article-buffer + (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types)) + (gnus-delete-images 'mail-picon) + (gnus-picon-transform-address "cc" 'mail-picon) + (gnus-picon-transform-address "to" 'mail-picon))) + )) + +;;;###autoload +(defun gnus-treat-newsgroups-picon () + "Display picons in the Newsgroups and Followup-To headers. +If picons are already displayed, remove them." + (interactive) + (let ((wash-picon-p buffer-read-only)) + (gnus-with-article-buffer + (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types)) + (gnus-delete-images 'newsgroups-picon) + (gnus-picon-transform-newsgroups "newsgroups") + (gnus-picon-transform-newsgroups "followup-to"))) + )) + +(provide 'gnus-picon) + +;;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f +;;; gnus-picon.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-pointer.xbm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,6 @@ +#define noname_width 18 +#define noname_height 13 +static char noname_bits[] = { + 0x00,0x00,0x00,0xc0,0x0c,0x00,0xe0,0x1f,0x00,0x92,0x39,0x00,0x0e,0x71,0x02, + 0x46,0xe0,0x03,0x20,0xc0,0x01,0x00,0x08,0x00,0x10,0x0d,0x00,0xc4,0x08,0x00, + 0x78,0x08,0x00,0x18,0x89,0x00,0x00,0x08,0x00};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-pointer.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,22 @@ +/* XPM */ +static char *gnus-pointer[] = { +/* width height num_colors chars_per_pixel */ +" 18 13 2 1", +/* colors */ +". c #0000ff", +"# c None s None", +/* pixels */ +"##################", +"######..##..######", +"#####........#####", +"#.##.##..##...####", +"#...####.###...##.", +"#..###.######.....", +"#####.########...#", +"###########.######", +"####.###.#..######", +"######..###.######", +"###....####.######", +"###..######.######", +"###########.######" +}; \ No newline at end of file
--- a/lisp/gnus/gnus-range.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-range.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,7 @@ ;;; gnus-range.el --- range and sequence functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -30,6 +31,11 @@ ;;; List and range functions +(defsubst gnus-range-normalize (range) + "Normalize RANGE. +If RANGE is a single range, return (RANGE). Otherwise, return RANGE." + (if (listp (cdr-safe range)) range (list range))) + (defun gnus-last-element (list) "Return last element of LIST." (while (cdr list) @@ -55,6 +61,85 @@ (setq list2 (cdr list2))) list1)) +(defun gnus-range-difference (range1 range2) + "Return the range of elements in RANGE1 that do not appear in RANGE2. +Both ranges must be in ascending order." + (setq range1 (gnus-range-normalize range1)) + (setq range2 (gnus-range-normalize range2)) + (let* ((new-range (cons nil (copy-sequence range1))) + (r new-range) + (safe t)) + (while (cdr r) + (let* ((r1 (cadr r)) + (r2 (car range2)) + (min1 (if (numberp r1) r1 (car r1))) + (max1 (if (numberp r1) r1 (cdr r1))) + (min2 (if (numberp r2) r2 (car r2))) + (max2 (if (numberp r2) r2 (cdr r2)))) + + (cond ((> min1 max1) + ;; Invalid range: may result from overlap condition (below) + ;; remove Invalid range + (setcdr r (cddr r))) + ((and (= min1 max1) + (listp r1)) + ;; Inefficient representation: may result from overlap condition (below) + (setcar (cdr r) min1)) + ((not min2) + ;; All done with range2 + (setq r nil)) + ((< max1 min2) + ;; No overlap: range1 preceeds range2 + (pop r)) + ((< max2 min1) + ;; No overlap: range2 preceeds range1 + (pop range2)) + ((and (<= min2 min1) (<= max1 max2)) + ;; Complete overlap: range1 removed + (setcdr r (cddr r))) + (t + (setcdr r (nconc (list (cons min1 (1- min2)) (cons (1+ max2) max1)) (cddr r))))))) + (cdr new-range))) + + + +;;;###autoload +(defun gnus-sorted-difference (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2. +Both lists have to be sorted over <. +The tail of LIST1 is not copied." + (let (out) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq out (cons (car list1) out)) + (setq list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (nconc (nreverse out) list1))) + +;;;###autoload +(defun gnus-sorted-ndifference (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2. +Both lists have to be sorted over <. +LIST1 is modified." + (let* ((top (cons nil list1)) + (prev top)) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setcdr prev (cdr list1)) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (cdr top))) + +;;;###autoload (defun gnus-sorted-complement (list1 list2) "Return a list of elements that are in LIST1 or LIST2 but not both. Both lists have to be sorted over <." @@ -73,6 +158,7 @@ (setq list2 (cdr list2))))) (nconc (nreverse out) (or list1 list2))))) +;;;###autoload (defun gnus-intersection (list1 list2) (let ((result nil)) (while list2 @@ -81,8 +167,10 @@ (setq list2 (cdr list2))) result)) +;;;###autoload (defun gnus-sorted-intersection (list1 list2) - ;; LIST1 and LIST2 have to be sorted over <. + "Return intersection of LIST1 and LIST2. +LIST1 and LIST2 have to be sorted over <." (let (out) (while (and list1 list2) (cond ((= (car list1) (car list2)) @@ -95,9 +183,13 @@ (setq list2 (cdr list2))))) (nreverse out))) -(defun gnus-set-sorted-intersection (list1 list2) - ;; LIST1 and LIST2 have to be sorted over <. - ;; This function modifies LIST1. +;;;###autoload +(defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection) + +;;;###autoload +(defun gnus-sorted-nintersection (list1 list2) + "Return intersection of LIST1 and LIST2 by modifying cdr pointers of LIST1. +LIST1 and LIST2 have to be sorted over <." (let* ((top (cons nil list1)) (prev top)) (while (and list1 list2) @@ -113,6 +205,55 @@ (setcdr prev nil) (cdr top))) +;;;###autoload +(defun gnus-sorted-union (list1 list2) + "Return union of LIST1 and LIST2. +LIST1 and LIST2 have to be sorted over <." + (let (out) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq out (cons (car list1) out) + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq out (cons (car list1) out) + list1 (cdr list1))) + (t + (setq out (cons (car list2) out) + list2 (cdr list2))))) + (while list1 + (setq out (cons (car list1) out) + list1 (cdr list1))) + (while list2 + (setq out (cons (car list2) out) + list2 (cdr list2))) + (nreverse out))) + +;;;###autoload +(defun gnus-sorted-nunion (list1 list2) + "Return union of LIST1 and LIST2 by modifying cdr pointers of LIST1. +LIST1 and LIST2 have to be sorted over <." + (let* ((top (cons nil list1)) + (prev top)) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1))) + (t + (setcdr prev (list (car list2))) + (setq prev (cdr prev) + list2 (cdr list2)) + (setcdr prev list1)))) + (while list2 + (setcdr prev (list (car list2))) + (setq prev (cdr prev) + list2 (cdr list2))) + (cdr top))) + (defun gnus-compress-sequence (numbers &optional always-list) "Convert list of numbers to a list of ranges or a single range. If ALWAYS-LIST is non-nil, this function will always release a list of @@ -319,9 +460,58 @@ (setq ranges (cdr ranges))) (not not-stop)))) +(defun gnus-list-range-intersection (list ranges) + "Return a list of numbers in LIST that are members of RANGES. +LIST is a sorted list." + (setq ranges (gnus-range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (and ranges + (if (numberp (car ranges)) + (= (car ranges) number) + ;; (caar ranges) <= number <= (cdar ranges) + (>= number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defalias 'gnus-inverse-list-range-intersection 'gnus-list-range-difference) + +(defun gnus-list-range-difference (list ranges) + "Return a list of numbers in LIST that are not members of RANGES. +LIST is a sorted list." + (setq ranges (gnus-range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (or (not ranges) + (if (numberp (car ranges)) + (not (= (car ranges) number)) + ;; not ((caar ranges) <= number <= (cdar ranges)) + (< number (caar ranges)))) + (push number result))) + (nreverse result))) + (defun gnus-range-length (range) "Return the length RANGE would have if uncompressed." - (length (gnus-uncompress-range range))) + (cond + ((null range) + 0) + ((not (listp (cdr range))) + (- (cdr range) (car range) -1)) + (t + (let ((sum 0)) + (dolist (x range sum) + (setq sum + (+ sum (if (consp x) (- (cdr x) (car x) -1) 1)))))))) (defun gnus-sublist-p (list sublist) "Test whether all elements in SUBLIST are members of LIST." @@ -387,6 +577,18 @@ (if item (push item range)) (reverse range))) +;;;###autoload +(defun gnus-add-to-sorted-list (list num) + "Add NUM into sorted LIST by side effect." + (let* ((top (cons nil list)) + (prev top)) + (while (and list (< (car list) num)) + (setq prev list + list (cdr list))) + (unless (eq (car list) num) + (setcdr prev (cons num list))) + (cdr top))) + (provide 'gnus-range) ;;; arch-tag: 4780bdd8-5a15-4aff-be28-18727895b6ad
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-registry.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,703 @@ +;;; 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: + +;; This is the gnus-registry.el package, works with other backends +;; besides nnmail. The major issue is that it doesn't go across +;; backends, so for instance if an article is in nnml:sys and you see +;; a reference to it in nnimap splitting, the article will end up in +;; nnimap:sys + +;; gnus-registry.el intercepts article respooling, moving, deleting, +;; and copying for all backends. If it doesn't work correctly for +;; you, submit a bug report and I'll be glad to fix it. It needs +;; documentation in the manual (also on my to-do list). + +;; Put this in your startup file (~/.gnus.el for instance) + +;; (setq gnus-registry-max-entries 2500 +;; gnus-registry-use-long-group-names t) + +;; (gnus-registry-initialize) + +;; Then use this in your fancy-split: + +;; (: gnus-registry-split-fancy-with-parent) + +;; TODO: + +;; - get the correct group on spool actions + +;; - articles that are spooled to a different backend should be handled + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-int) +(require 'gnus-sum) +(require 'nnmail) + +(defvar gnus-registry-dirty t + "Boolean set to t when the registry is modified") + +(defgroup gnus-registry nil + "The Gnus registry." + :group 'gnus) + +(defvar gnus-registry-hashtb nil + "*The article registry by Message ID.") + +(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-install nil + "Whether the registry should be installed." + :group 'gnus-registry + :type 'boolean) + +(defcustom gnus-registry-clean-empty t + "Whether the empty registry entries should be deleted. +Registry entries are considered empty when they have no groups." + :group 'gnus-registry + :type 'boolean) + +(defcustom gnus-registry-use-long-group-names nil + "Whether the registry should use long group names (BUGGY)." + :group 'gnus-registry + :type 'boolean) + +(defcustom gnus-registry-track-extra nil + "Whether the registry should track extra data about a message. +The Subject and Sender (From:) headers are currently tracked this +way." + :group 'gnus-registry + :type + '(set :tag "Tracking choices" + (const :tag "Track by subject (Subject: header)" subject) + (const :tag "Track by sender (From: header)" sender))) + +(defcustom gnus-registry-entry-caching t + "Whether the registry should cache extra information." + :group 'gnus-registry + :type 'boolean) + +(defcustom gnus-registry-minimum-subject-length 5 + "The minimum length of a subject before it's considered trackable." + :group 'gnus-registry + :type 'integer) + +(defcustom gnus-registry-trim-articles-without-groups t + "Whether the registry should clean out message IDs without groups." + :group 'gnus-registry + :type 'boolean) + +(defcustom gnus-registry-cache-file "~/.gnus.registry.eld" + "File where the Gnus registry will be stored." + :group 'gnus-registry + :type 'file) + +(defcustom gnus-registry-max-entries nil + "Maximum number of entries in the registry, nil for unlimited." + :group 'gnus-registry + :type '(radio (const :format "Unlimited " nil) + (integer :format "Maximum number: %v\n" :size 0))) + +;; 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-track-subject-p () + (memq 'subject gnus-registry-track-extra)) + +(defun gnus-registry-track-sender-p () + (memq 'sender gnus-registry-track-extra)) + +(defun gnus-registry-cache-read () + "Read the registry cache file." + (interactive) + (let ((file gnus-registry-cache-file)) + (when (file-exists-p file) + (gnus-message 5 "Reading %s..." file) + (gnus-load file) + (gnus-message 5 "Reading %s...done" file)))) + +(defun gnus-registry-cache-save () + "Save the registry cache file." + (interactive) + (let ((file gnus-registry-cache-file)) + (save-excursion + (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) + (make-local-variable 'version-control) + (setq version-control gnus-backup-startup-file) + (setq buffer-file-name file) + (setq default-directory (file-name-directory buffer-file-name)) + (buffer-disable-undo) + (erase-buffer) + (gnus-message 5 "Saving %s..." file) + (if gnus-save-startup-file-via-temp-buffer + (let ((coding-system-for-write gnus-ding-file-coding-system) + (standard-output (current-buffer))) + (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist) + (gnus-registry-cache-whitespace file) + (save-buffer)) + (let ((coding-system-for-write gnus-ding-file-coding-system) + (version-control gnus-backup-startup-file) + (startup-file file) + (working-dir (file-name-directory file)) + working-file + (i -1)) + ;; Generate the name of a non-existent file. + (while (progn (setq working-file + (format + (if (and (eq system-type 'ms-dos) + (not (gnus-long-file-names))) + "%s#%d.tm#" ; MSDOS limits files to 8+3 + (if (memq system-type '(vax-vms axp-vms)) + "%s$tmp$%d" + "%s#tmp#%d")) + working-dir (setq i (1+ i)))) + (file-exists-p working-file))) + + (unwind-protect + (progn + (gnus-with-output-to-file working-file + (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) + + ;; These bindings will mislead the current buffer + ;; into thinking that it is visiting the startup + ;; file. + (let ((buffer-backed-up nil) + (buffer-file-name startup-file) + (file-precious-flag t) + (setmodes (file-modes startup-file))) + ;; Backup the current version of the startup file. + (backup-buffer) + + ;; Replace the existing startup file with the temp file. + (rename-file working-file startup-file t) + (set-file-modes startup-file setmodes))) + (condition-case nil + (delete-file working-file) + (file-error nil))))) + + (gnus-kill-buffer (current-buffer)) + (gnus-message 5 "Saving %s...done" file)))) + +;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> +;; Save the gnus-registry file with extra line breaks. +(defun gnus-registry-cache-whitespace (filename) + (gnus-message 5 "Adding whitespace to %s" filename) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^(\\|(\\\"" nil t) + (replace-match "\n\\&" t)) + (goto-char (point-min)) + (while (re-search-forward " $" nil t) + (replace-match "" t t)))) + +(defun gnus-registry-save (&optional force) + (when (or gnus-registry-dirty force) + (let ((caching gnus-registry-entry-caching)) + ;; turn off entry caching, so mtime doesn't get recorded + (setq gnus-registry-entry-caching nil) + ;; remove entry caches + (maphash + (lambda (key value) + (if (hash-table-p value) + (remhash key gnus-registry-hashtb))) + gnus-registry-hashtb) + ;; remove empty entries + (when gnus-registry-clean-empty + (gnus-registry-clean-empty-function)) + ;; now trim the registry appropriately + (setq gnus-registry-alist (gnus-registry-trim + (hashtable-to-alist gnus-registry-hashtb))) + ;; really save + (gnus-registry-cache-save) + (setq gnus-registry-entry-caching caching) + (setq gnus-registry-dirty nil)))) + +(defun gnus-registry-clean-empty-function () + "Remove all empty entries from the registry. Returns count thereof." + (let ((count 0)) + (maphash + (lambda (key value) + (unless (gnus-registry-fetch-group key) + (incf count) + (remhash key gnus-registry-hashtb))) + gnus-registry-hashtb) + count)) + +(defun gnus-registry-read () + (gnus-registry-cache-read) + (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) + (setq gnus-registry-dirty nil)) + +(defun gnus-registry-trim (alist) + "Trim alist to size, using gnus-registry-max-entries." + (if (null gnus-registry-max-entries) + alist ; just return the alist + ;; else, when given max-entries, trim the alist + (let ((timehash (make-hash-table + :size 4096 + :test 'equal))) + (maphash + (lambda (key value) + (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) + gnus-registry-hashtb) + + ;; we use the return value of this setq, which is the trimmed alist + (setq alist + (nthcdr + (- (length alist) gnus-registry-max-entries) + (sort alist + (lambda (a b) + (time-less-p + (cdr (gethash (car a) timehash)) + (cdr (gethash (car b) timehash)))))))))) + +(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-registry-action (action data-header from &optional to method) + (let* ((id (mail-header-id data-header)) + (subject (gnus-registry-simplify-subject + (mail-header-subject data-header))) + (sender (mail-header-from data-header)) + (from (gnus-group-guess-full-name-from-command-method from)) + (to (if to (gnus-group-guess-full-name-from-command-method 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 subject sender)) ; undo the delete + + (gnus-registry-add-group id to subject sender))) + +(defun gnus-registry-spool-action (id group &optional subject sender) + (let ((group (gnus-group-guess-full-name-from-command-method group))) + (when (and (stringp id) (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 subject sender))) + +;; 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"))) + (nnmail-split-fancy-with-parent-ignore-groups + (if (listp nnmail-split-fancy-with-parent-ignore-groups) + nnmail-split-fancy-with-parent-ignore-groups + (list nnmail-split-fancy-with-parent-ignore-groups))) + references res) + (if refstr + (progn + (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)) + + ;; else: there were no references, now try the extra tracking + (let ((sender (message-fetch-field "from")) + (subject (gnus-registry-simplify-subject + (message-fetch-field "subject"))) + (single-match t)) + (when (and single-match + (gnus-registry-track-sender-p) + sender) + (maphash + (lambda (key value) + (let ((this-sender (cdr + (gnus-registry-fetch-extra key 'sender)))) + (when (and single-match + this-sender + (equal sender this-sender)) + ;; too many matches, bail + (unless (equal res (gnus-registry-fetch-group key)) + (setq single-match nil)) + (setq res (gnus-registry-fetch-group key)) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 5 9) + "%s (extra tracking) traced sender %s to group %s" + "gnus-registry-split-fancy-with-parent" + sender + (if res res "nil"))))) + gnus-registry-hashtb)) + (when (and single-match + (gnus-registry-track-subject-p) + subject + (< gnus-registry-minimum-subject-length (length subject))) + (maphash + (lambda (key value) + (let ((this-subject (cdr + (gnus-registry-fetch-extra key 'subject)))) + (when (and single-match + this-subject + (equal subject this-subject)) + ;; too many matches, bail + (unless (equal res (gnus-registry-fetch-group key)) + (setq single-match nil)) + (setq res (gnus-registry-fetch-group key)) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 5 9) + "%s (extra tracking) traced subject %s to group %s" + "gnus-registry-split-fancy-with-parent" + subject + (if res res "nil"))))) + gnus-registry-hashtb)) + (unless single-match + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent: too many extra matches for %s" + refstr) + (setq res nil)))) + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent traced %s to group %s" + refstr (if res res "nil")) + + (when (and res gnus-registry-use-long-group-names) + (let ((m1 (gnus-find-method-for-group res)) + (m2 (or gnus-command-method + (gnus-find-method-for-group gnus-newsgroup-name))) + (short-res (gnus-group-short-name res))) + (if (gnus-methods-equal-p m1 m2) + (progn + (gnus-message + 9 + "gnus-registry-split-fancy-with-parent stripped group %s to %s" + res + short-res) + (setq res short-res)) + ;; else... + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent ignored foreign group %s" + res) + (setq res nil)))) + res)) + +(defun gnus-registry-register-message-ids () + "Register the Message-ID of every article in the group" + (unless (gnus-parameter-registry-ignore 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 + (gnus-registry-fetch-simplified-message-subject-fast article) + (gnus-registry-fetch-sender-fast article))))))) + +(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-simplify-subject (subject) + (if (stringp subject) + (gnus-simplify-subject subject) + nil)) + +(defun gnus-registry-fetch-simplified-message-subject-fast (article) + "Fetch the Subject quickly, using the internal gnus-data-list function" + (if (and (numberp article) + (assoc article (gnus-data-list nil))) + (gnus-registry-simplify-subject + (mail-header-subject (gnus-data-header + (assoc article (gnus-data-list nil))))) + nil)) + +(defun gnus-registry-fetch-sender-fast (article) + "Fetch the Sender 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 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-extra (id &optional entry) + "Get the extra data of a message, based on the message ID. +Returns the first place where the trail finds a nonstring." + (let ((entry-cache (gethash entry gnus-registry-hashtb))) + (if (and entry + (hash-table-p entry-cache) + (gethash id entry-cache)) + (gethash id entry-cache) + ;; else, if there is no caching possible... + (let ((trail (gethash id gnus-registry-hashtb))) + (when (listp trail) + (dolist (crumb trail) + (unless (stringp crumb) + (return (gnus-registry-fetch-extra-entry crumb entry id))))))))) + +(defun gnus-registry-fetch-extra-entry (alist &optional entry id) + "Get the extra data of a message, or a specific entry in it. +Update the entry cache if needed." + (if (and entry id) + (let ((entry-cache (gethash entry gnus-registry-hashtb)) + entree) + (when gnus-registry-entry-caching + ;; create the hash table + (unless (hash-table-p entry-cache) + (setq entry-cache (make-hash-table + :size 4096 + :test 'equal)) + (puthash entry entry-cache gnus-registry-hashtb)) + + ;; get the entree from the hash table or from the alist + (setq entree (gethash id entry-cache))) + + (unless entree + (setq entree (assq entry alist)) + (when gnus-registry-entry-caching + (puthash id entree entry-cache))) + entree) + alist)) + +(defun gnus-registry-store-extra (id extra) + "Store the extra data of a message, based on the message ID. +The message must have at least one group name." + (when (gnus-registry-group-count id) + ;; we now know the trail has at least 1 group name, so it's not empty + (let ((trail (gethash id gnus-registry-hashtb)) + (old-extra (gnus-registry-fetch-extra id)) + entry-cache) + (dolist (crumb trail) + (unless (stringp crumb) + (dolist (entry crumb) + (setq entry-cache (gethash (car entry) gnus-registry-hashtb)) + (when entry-cache + (remhash id entry-cache)))) + (puthash id (cons extra (delete old-extra trail)) + gnus-registry-hashtb) + (setq gnus-registry-dirty t))))) + +(defun gnus-registry-store-extra-entry (id key value) + "Put a specific entry in the extras field of the registry entry for id." + (let* ((extra (gnus-registry-fetch-extra id)) + (alist (cons (cons key value) + (gnus-assq-delete-all key (gnus-registry-fetch-extra id))))) + (gnus-registry-store-extra id alist))) + +(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 group name." + (when (gnus-registry-group-count id) + ;; we now know the trail has at least 1 group name + (let ((trail (gethash id gnus-registry-hashtb))) + (dolist (crumb trail) + (when (stringp crumb) + (return (if gnus-registry-use-long-group-names + crumb + (gnus-group-short-name crumb)))))))) + +(defun gnus-registry-group-count (id) + "Get the number of groups of a message, based on the message ID." + (let ((trail (gethash id gnus-registry-hashtb))) + (if (and trail (listp trail)) + (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail)) + 0))) + +(defun gnus-registry-delete-group (id group) + "Delete a group for a message, based on the message ID." + (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 there are no more groups + (when gnus-registry-trim-articles-without-groups + (unless (gnus-registry-group-count id) + (gnus-registry-delete-id id))) + (gnus-registry-store-extra-entry id 'mtime (current-time))))) + +(defun gnus-registry-delete-id (id) + "Delete a message ID from the registry." + (when (stringp id) + (remhash id gnus-registry-hashtb) + (maphash + (lambda (key value) + (when (hash-table-p value) + (remhash id value))) + gnus-registry-hashtb))) + +(defun gnus-registry-add-group (id group &optional subject sender) + "Add a group for a message, based on the message ID." + (when group + (when (and id + (not (string-match "totally-fudged-out-message-id" id))) + (let ((full-group group) + (group (if gnus-registry-use-long-group-names + group + (gnus-group-short-name group)))) + (gnus-registry-delete-group id group) + + (unless gnus-registry-use-long-group-names ;; unnecessary in this case + (gnus-registry-delete-group id full-group)) + + (let ((trail (gethash id gnus-registry-hashtb))) + (puthash id (if trail + (cons group trail) + (list group)) + gnus-registry-hashtb) + + (when (and (gnus-registry-track-subject-p) + subject) + (gnus-registry-store-extra-entry + id + 'subject + (gnus-registry-simplify-subject subject))) + (when (and (gnus-registry-track-sender-p) + sender) + (gnus-registry-store-extra-entry + id + 'sender + sender)) + + (gnus-registry-store-extra-entry id 'mtime (current-time))))))) + +(defun gnus-registry-clear () + "Clear the Gnus registry." + (interactive) + (setq gnus-registry-alist nil) + (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) + (setq gnus-registry-dirty t)) + +;;;###autoload +(defun gnus-registry-initialize () + (interactive) + (setq gnus-registry-install t) + (gnus-registry-install-hooks) + (gnus-registry-read)) + +;;;###autoload +(defun gnus-registry-install-hooks () + "Install the registry hooks." + (interactive) + (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) + (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) + (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) + (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + + (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) + + (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + +(defun gnus-registry-unload-hook () + "Uninstall the registry hooks." + (interactive) + (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) + (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) + (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) + (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + + (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) + + (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + +(when gnus-registry-install + (gnus-registry-install-hooks) + (gnus-registry-read)) + +;; TODO: a lot of things + +(provide 'gnus-registry) + +;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 +;;; gnus-registry.el ends here
--- a/lisp/gnus/gnus-salt.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-salt.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,7 @@ ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2001 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -30,13 +31,15 @@ (require 'gnus) (require 'gnus-sum) +(require 'gnus-win) ;;; ;;; gnus-pick-mode ;;; (defvar gnus-pick-mode nil - "Minor mode for providing a pick-and-read interface in Gnus summary buffers.") + "Minor mode for providing a pick-and-read interface in Gnus +summary buffers.") (defcustom gnus-pick-display-summary nil "*Display summary while reading." @@ -48,18 +51,22 @@ :type 'hook :group 'gnus-summary-pick) +(when (featurep 'xemacs) + (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)) + (defcustom gnus-mark-unpicked-articles-as-read nil "*If non-nil, mark all unpicked articles as read." :type 'boolean :group 'gnus-summary-pick) (defcustom gnus-pick-elegant-flow t - "If non-nil, `gnus-pick-start-reading' runs `gnus-summary-next-group' when no articles have been picked." + "If non-nil, `gnus-pick-start-reading' runs + `gnus-summary-next-group' when no articles have been picked." :type 'boolean :group 'gnus-summary-pick) (defcustom gnus-summary-pick-line-format - "%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + "%-5P %U\%R\%z\%I\%(%[%4L: %-23,23n%]%) %s\n" "*The format specification of the lines in pick buffers. It accepts the same format specs that `gnus-summary-line-format' does." :type 'string @@ -82,22 +89,22 @@ (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) (easy-menu-define - gnus-pick-menu gnus-pick-mode-map "" - '("Pick" - ("Pick" - ["Article" gnus-summary-mark-as-processable t] - ["Thread" gnus-uu-mark-thread t] - ["Region" gnus-uu-mark-region t] - ["Regexp" gnus-uu-mark-by-regexp t] - ["Buffer" gnus-uu-mark-buffer t]) - ("Unpick" - ["Article" gnus-summary-unmark-as-processable t] - ["Thread" gnus-uu-unmark-thread t] - ["Region" gnus-uu-unmark-region t] - ["Regexp" gnus-uu-unmark-by-regexp t] - ["Buffer" gnus-summary-unmark-all-processable t]) - ["Start reading" gnus-pick-start-reading t] - ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) + gnus-pick-menu gnus-pick-mode-map "" + '("Pick" + ("Pick" + ["Article" gnus-summary-mark-as-processable t] + ["Thread" gnus-uu-mark-thread t] + ["Region" gnus-uu-mark-region t] + ["Regexp" gnus-uu-mark-by-regexp t] + ["Buffer" gnus-uu-mark-buffer t]) + ("Unpick" + ["Article" gnus-summary-unmark-as-processable t] + ["Thread" gnus-uu-unmark-thread t] + ["Region" gnus-uu-unmark-region t] + ["Regexp" gnus-uu-unmark-by-regexp t] + ["Buffer" gnus-summary-unmark-all-processable t]) + ["Start reading" gnus-pick-start-reading t] + ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) (defun gnus-pick-mode (&optional arg) "Minor mode for providing a pick-and-read interface in Gnus summary buffers. @@ -148,11 +155,11 @@ (interactive "P") (if gnus-newsgroup-processable (progn - (gnus-summary-limit-to-articles nil) - (when (or catch-up gnus-mark-unpicked-articles-as-read) + (gnus-summary-limit-to-articles nil) + (when (or catch-up gnus-mark-unpicked-articles-as-read) (gnus-summary-limit-mark-excluded-as-read)) - (gnus-summary-first-article) - (gnus-configure-windows + (gnus-summary-first-article) + (gnus-configure-windows (if gnus-pick-display-summary 'article 'pick) t)) (if gnus-pick-elegant-flow (progn @@ -223,7 +230,7 @@ (let* ((echo-keystrokes 0) (start-posn (event-start start-event)) (start-point (posn-point start-posn)) - (start-line (1+ (count-lines 1 start-point))) + (start-line (1+ (count-lines 1 start-point))) (start-window (posn-window start-posn)) (bounds (gnus-window-edges start-window)) (top (nth 1 bounds)) @@ -235,7 +242,7 @@ (setq mouse-selection-click-count click-count) (setq mouse-selection-click-count-buffer (current-buffer)) (mouse-set-point start-event) - ;; In case the down click is in the middle of some intangible text, + ;; In case the down click is in the middle of some intangible text, ;; use the end of that text, and put it in START-POINT. (when (< (point) start-point) (goto-char start-point)) @@ -246,61 +253,61 @@ ;; (but not outside the window where the drag started). (let (event end end-point (end-of-range (point))) (track-mouse - (while (progn - (setq event (cdr (gnus-read-event-char))) - (or (mouse-movement-p event) - (eq (car-safe event) 'switch-frame))) - (if (eq (car-safe event) 'switch-frame) - nil - (setq end (event-end event) - end-point (posn-point end)) + (while (progn + (setq event (cdr (gnus-read-event-char))) + (or (mouse-movement-p event) + (eq (car-safe event) 'switch-frame))) + (if (eq (car-safe event) 'switch-frame) + nil + (setq end (event-end event) + end-point (posn-point end)) - (cond - ;; Are we moving within the original window? - ((and (eq (posn-window end) start-window) - (integer-or-marker-p end-point)) - ;; Go to START-POINT first, so that when we move to END-POINT, - ;; if it's in the middle of intangible text, - ;; point jumps in the direction away from START-POINT. - (goto-char start-point) - (goto-char end-point) - (gnus-pick-article) - ;; In case the user moved his mouse really fast, pick - ;; articles on the line between this one and the last one. - (let* ((this-line (1+ (count-lines 1 end-point))) - (min-line (min this-line start-line)) - (max-line (max this-line start-line))) - (while (< min-line max-line) - (goto-line min-line) - (gnus-pick-article) - (setq min-line (1+ min-line))) - (setq start-line this-line)) - (when (zerop (% click-count 3)) - (setq end-of-range (point)))) - (t - (let ((mouse-row (cdr (cdr (mouse-position))))) - (cond - ((null mouse-row)) - ((< mouse-row top) - (mouse-scroll-subr start-window (- mouse-row top))) - ((>= mouse-row bottom) - (mouse-scroll-subr start-window - (1+ (- mouse-row bottom))))))))))) + (cond + ;; Are we moving within the original window? + ((and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + ;; Go to START-POINT first, so that when we move to END-POINT, + ;; if it's in the middle of intangible text, + ;; point jumps in the direction away from START-POINT. + (goto-char start-point) + (goto-char end-point) + (gnus-pick-article) + ;; In case the user moved his mouse really fast, pick + ;; articles on the line between this one and the last one. + (let* ((this-line (1+ (count-lines 1 end-point))) + (min-line (min this-line start-line)) + (max-line (max this-line start-line))) + (while (< min-line max-line) + (goto-line min-line) + (gnus-pick-article) + (setq min-line (1+ min-line))) + (setq start-line this-line)) + (when (zerop (% click-count 3)) + (setq end-of-range (point)))) + (t + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top))) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window + (1+ (- mouse-row bottom))))))))))) (when (consp event) (let ((fun (key-binding (vector (car event))))) ;; Run the binding of the terminating up-event, if possible. - ;; In the case of a multiple click, it gives the wrong results, + ;; In the case of a multiple click, it gives the wrong results, ;; because it would fail to set up a region. (when nil - ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun)) - ;; In this case, we can just let the up-event execute normally. + ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun)) + ;; In this case, we can just let the up-event execute normally. (let ((end (event-end event))) ;; Set the position in the event before we replay it, ;; because otherwise it may have a position in the wrong ;; buffer. (setcar (cdr end) end-of-range) ;; Delete the overlay before calling the function, - ;; because delete-overlay increases buffer-modified-tick. + ;; because delete-overlay increases buffer-modified-tick. (push event unread-command-events)))))))) (defun gnus-pick-next-page () @@ -333,9 +340,9 @@ (defun gnus-binary-make-menu-bar () (unless (boundp 'gnus-binary-menu) (easy-menu-define - gnus-binary-menu gnus-binary-mode-map "" - '("Pick" - ["Switch binary mode off" gnus-binary-mode t])))) + gnus-binary-menu gnus-binary-mode-map "" + '("Pick" + ["Switch binary mode off" gnus-binary-mode t])))) (defun gnus-binary-mode (&optional arg) "Minor mode for providing a binary group interface in Gnus summary buffers." @@ -361,7 +368,7 @@ (defun gnus-binary-display-article (article &optional all-header) "Run ARTICLE through the binary decode functions." (when (gnus-summary-goto-subject article) - (let ((gnus-view-pseudos 'automatic)) + (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-uu)))) (defun gnus-binary-show-article (&optional arg) @@ -418,6 +425,11 @@ :type 'hook :group 'gnus-summary-tree) +(when (featurep 'xemacs) + (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) + (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)) + + ;;; Internal variables. (defvar gnus-tree-line-format-alist @@ -460,9 +472,9 @@ (defun gnus-tree-make-menu-bar () (unless (boundp 'gnus-tree-menu) (easy-menu-define - gnus-tree-menu gnus-tree-mode-map "" - '("Tree" - ["Select article" gnus-tree-select-article t])))) + gnus-tree-menu gnus-tree-mode-map "" + '("Tree" + ["Select article" gnus-tree-select-article t])))) (defun gnus-tree-mode () "Major mode for displaying thread trees." @@ -543,7 +555,7 @@ (defun gnus-tree-recenter () "Center point in the tree window." (let ((selected (selected-window)) - (tree-window (get-buffer-window gnus-tree-buffer t))) + (tree-window (gnus-get-buffer-window gnus-tree-buffer t))) (when tree-window (select-window tree-window) (when gnus-selected-tree-overlay @@ -555,7 +567,7 @@ (bottom (save-excursion (goto-char (point-max)) (forward-line (- height)) (point)))) - ;; Set the window start to either `bottom', which is the biggest + ;; Set the window start to either `bottom', which is the biggest ;; possible valid number, or the second line from the top, ;; whichever is the least. (set-window-start @@ -656,6 +668,10 @@ (let* ((score (or (cdr (assq article gnus-newsgroup-scored)) gnus-summary-default-score 0)) (default gnus-summary-default-score) + (default-high gnus-summary-default-high-score) + (default-low gnus-summary-default-low-score) + (uncached (memq article gnus-newsgroup-undownloaded)) + (downloaded (not uncached)) (mark (or (gnus-summary-article-mark article) gnus-unread-mark))) ;; Eval the cars of the lists until we find a match. (while (and list @@ -686,8 +702,8 @@ (gnus-tree-minimize) (gnus-tree-recenter) (let ((selected (selected-window))) - (when (get-buffer-window (set-buffer gnus-tree-buffer) t) - (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t)) + (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t) + (select-window (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)) (gnus-horizontal-recenter) (select-window selected)))))) @@ -825,6 +841,13 @@ (defun gnus-tree-close (group) (gnus-kill-buffer gnus-tree-buffer)) +(defun gnus-tree-perhaps-minimize () + (when (and gnus-tree-minimize-window + (get-buffer gnus-tree-buffer)) + (save-excursion + (set-buffer gnus-tree-buffer) + (gnus-tree-minimize)))) + (defun gnus-highlight-selected-tree (article) "Highlight the selected article in the tree." (let ((buf (current-buffer)) @@ -843,11 +866,11 @@ (gnus-tree-minimize) (gnus-tree-recenter) (let ((selected (selected-window))) - (when (get-buffer-window (set-buffer gnus-tree-buffer) t) - (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t)) + (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t) + (select-window (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)) (gnus-horizontal-recenter) (select-window selected)))) - ;; If we remove this save-excursion, it updates the wrong mode lines?!? +;; If we remove this save-excursion, it updates the wrong mode lines?!? (save-excursion (set-buffer gnus-tree-buffer) (gnus-set-mode-line 'tree)) @@ -860,7 +883,7 @@ (when (setq region (gnus-tree-article-region article)) (gnus-put-text-property (car region) (cdr region) 'face face) (set-window-point - (get-buffer-window (current-buffer) t) (cdr region)))))) + (gnus-get-buffer-window (current-buffer) t) (cdr region)))))) ;;; ;;; gnus-carpal @@ -886,6 +909,7 @@ ("matching" . gnus-group-list-matching) ("post" . gnus-group-post-news) ("mail" . gnus-group-mail) + ("local" . (lambda () (interactive) (gnus-group-news 0))) ("rescan" . gnus-group-get-new-news) ("browse-foreign" . gnus-group-browse-foreign) ("exit" . gnus-group-exit))) @@ -916,7 +940,8 @@ ("kill" . gnus-summary-kill-thread) "post" ("post" . gnus-summary-post-news) - ("mail" . gnus-summary-mail) + ("local" . gnus-summary-news-other-window) + ("mail" . gnus-summary-mail-other-window) ("followup" . gnus-summary-followup-with-original) ("reply" . gnus-summary-reply-with-original) ("cancel" . gnus-summary-cancel-article)
--- a/lisp/gnus/gnus-score.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-score.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-score.el --- scoring code for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2004 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Per Abrahamsen <amanda@iesd.auc.dk> @@ -32,9 +32,12 @@ (require 'gnus) (require 'gnus-sum) (require 'gnus-range) +(require 'gnus-win) (require 'message) (require 'score-mode) +(autoload 'ffap-string-at-point "ffap") + (defcustom gnus-global-score-files nil "List of global score files and directories. Set this variable if you want to use people's score files. One entry @@ -47,7 +50,7 @@ (setq gnus-global-score-files '(\"/ftp.gnus.org:/pub/larsi/ding/score/soc.motss.SCORE\" - \"/ftp.some-where:/pub/score\"))" + \"/ftp.some-where:/pub/score\"))" :group 'gnus-score-files :type '(repeat file)) @@ -232,6 +235,12 @@ (symbol :tag "other")) (integer :tag "Score")))))) +(defcustom gnus-adaptive-word-length-limit nil + "*Words of a length lesser than this limit will be ignored when doing adaptive scoring." + :group 'gnus-score-adapt + :type '(radio (const :format "Unlimited " nil) + (integer :format "Maximum length: %v\n" :size 0))) + (defcustom gnus-ignored-adaptive-words nil "List of words to be ignored when doing adaptive word scoring." :group 'gnus-score-adapt @@ -483,7 +492,8 @@ "Make a score entry based on the current article. The user will be prompted for header to score on, match type, permanence, and the string to be used. The numerical prefix will be -used as score." +used as score. A symbolic prefix of `a' says to use the `all.SCORE' +file for the command instead of the current score file." (interactive (gnus-interactive "P\ny")) (gnus-summary-increase-score (- (gnus-score-delta-default score)) symp)) @@ -497,7 +507,8 @@ "Make a score entry based on the current article. The user will be prompted for header to score on, match type, permanence, and the string to be used. The numerical prefix will be -used as score." +used as score. A symbolic prefix of `a' says to use the `all.SCORE' +file for the command instead of the current score file." (interactive (gnus-interactive "P\ny")) (let* ((nscore (gnus-score-delta-default score)) (prefix (if (< nscore 0) ?L ?I)) @@ -616,7 +627,7 @@ (gnus-score-insert-help "Match permanence" char-to-perm 2))) (gnus-score-kill-help-buffer) - (if mimic (message "%c %c %c %c" prefix hchar tchar pchar) + (if mimic (message "%c %c %c" prefix hchar tchar pchar) (message "")) (unless (setq temporary (cadr (assq pchar char-to-perm))) ;; Deal with der(r)ided superannuated paradigms. @@ -637,7 +648,7 @@ (and gnus-extra-headers (equal (nth 1 entry) "extra") (intern ; need symbol - (gnus-completing-read + (gnus-completing-read-with-default (symbol-name (car gnus-extra-headers)) ; default response "Score extra header:" ; prompt (mapcar (lambda (x) ; completion list @@ -729,13 +740,16 @@ (insert (format format (caar alist) (nth idx (car alist)))) (setq alist (cdr alist)) (setq i (1+ i)))) + (goto-char (point-min)) ;; display ourselves in a small window at the bottom (gnus-appt-select-lowest-window) - (split-window) - (pop-to-buffer "*Score Help*") + (if (< (/ (window-height) 2) window-min-height) + (switch-to-buffer "*Score Help*") + (split-window) + (pop-to-buffer "*Score Help*")) (let ((window-min-height 1)) (shrink-window-if-larger-than-buffer)) - (select-window (get-buffer-window gnus-summary-buffer t)))) + (select-window (gnus-get-buffer-window gnus-summary-buffer t)))) (defun gnus-summary-header (header &optional no-err extra) ;; Return HEADER for current articles, or error. @@ -863,7 +877,7 @@ ;; Return the new scoring rule. new)) -(defun gnus-summary-score-effect (header match type score extra) +(defun gnus-summary-score-effect (header match type score &optional extra) "Simulate the effect of a score file entry. HEADER is the header being scored. MATCH is the string we are looking for. @@ -875,8 +889,8 @@ (lambda (x) (fboundp (nth 2 x))) t) (read-string "Match: ") - (y-or-n-p "Use regexp match? ") - (prefix-numeric-value current-prefix-arg))) + (if (y-or-n-p "Use regexp match? ") 'r 's) + (string-to-int (read-string "Score: ")))) (save-excursion (unless (and (stringp match) (> (length match) 0)) (error "No match")) @@ -926,7 +940,6 @@ ;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>. -;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. (defun gnus-score-set-mark-below (score) "Automatically mark articles with score below SCORE as read." (interactive @@ -1093,6 +1106,39 @@ 4 (substitute-command-keys "\\<gnus-score-mode-map>\\[gnus-score-edit-exit] to save edits"))) +(defun gnus-score-edit-file-at-point (&optional format) + "Edit score file at point in Score Trace buffers. +If FORMAT, also format the current score file." + (let* ((rule (save-excursion + (beginning-of-line) + (read (current-buffer)))) + (sep "[ \n\r\t]*") + ;; Must be synced with `gnus-score-find-trace': + (reg " -> +") + (file (save-excursion + (end-of-line) + (if (and (re-search-backward reg (gnus-point-at-bol) t) + (re-search-forward reg (gnus-point-at-eol) t)) + (buffer-substring (point) (gnus-point-at-eol)) + nil)))) + (if (or (not file) + (string-match "\\<\\(non-file rule\\|A file\\)\\>" file) + ;; (see `gnus-score-find-trace' and `gnus-score-advanced') + (string= "" file)) + (gnus-error 3 "Can't find a score file in current line.") + (gnus-score-edit-file file) + (when format + (gnus-score-pretty-print)) + (when (consp rule) ;; the rule exists + (setq rule (mapconcat #'(lambda (obj) + (regexp-quote (format "%S" obj))) + rule + sep)) + (goto-char (point-min)) + (re-search-forward rule nil t) + ;; make it easy to use `kill-sexp': + (goto-char (1- (match-beginning 0))))))) + (defun gnus-score-load-file (file) ;; Load score file FILE. Returns a list a retrieved score-alists. (let* ((file (expand-file-name @@ -1143,7 +1189,7 @@ (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist))) (files (gnus-score-get 'files alist)) (exclude-files (gnus-score-get 'exclude-files alist)) - (orphan (car (gnus-score-get 'orphan alist))) + (orphan (car (gnus-score-get 'orphan alist))) (adapt (gnus-score-get 'adapt alist)) (thread-mark-and-expunge (car (gnus-score-get 'thread-mark-and-expunge alist))) @@ -1202,7 +1248,6 @@ (setq gnus-newsgroup-adaptive t) adapt) (t - ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) gnus-default-adaptive-score-alist))) (setq gnus-thread-expunge-below (or thread-mark-and-expunge gnus-thread-expunge-below)) @@ -1428,7 +1473,7 @@ (headers gnus-newsgroup-headers) (current-score-file gnus-current-score-file) entry header new) - (gnus-message 5 "Scoring...") + (gnus-message 7 "Scoring...") ;; Create articles, an alist of the form `(HEADER . SCORE)'. (while (setq header (pop headers)) ;; WARNING: The assq makes the function O(N*S) while it could @@ -1470,7 +1515,7 @@ (with-current-buffer gnus-summary-buffer (setq gnus-newsgroup-scored scored)))) ;; Remove the buffer. - (kill-buffer (current-buffer))) + (gnus-kill-buffer (current-buffer))) ;; Add articles to `gnus-newsgroup-scored'. (while gnus-scores-articles @@ -1489,7 +1534,7 @@ (gnus-score-advanced (car score) trace)) (pop score)))) - (gnus-message 5 "Scoring...done")))))) + (gnus-message 7 "Scoring...done")))))) (defun gnus-score-lower-thread (thread score-adjust) "Lower the score on THREAD with SCORE-ADJUST. @@ -1516,21 +1561,19 @@ which has references, but is not connected via its references to a root article. This function finds all the orphans, and adjusts their score in `gnus-newsgroup-scored' by SCORE." - (let ((threads (gnus-make-threads))) - ;; gnus-make-threads produces a list, where each entry is a "thread" - ;; as described in the gnus-score-lower-thread docs. This function - ;; will be called again (after limiting has been done) if the display - ;; is threaded. It would be nice to somehow save this info and use - ;; it later. - (while threads - (let* ((thread (car threads)) - (id (aref (car thread) gnus-score-index))) - ;; If the parent of the thread is not a root, lower the score of - ;; it and its descendants. Note that some roots seem to satisfy - ;; (eq id nil) and some (eq id ""); not sure why. - (if (and id (not (string= id ""))) - (gnus-score-lower-thread thread score))) - (setq threads (cdr threads))))) + ;; gnus-make-threads produces a list, where each entry is a "thread" + ;; as described in the gnus-score-lower-thread docs. This function + ;; will be called again (after limiting has been done) if the display + ;; is threaded. It would be nice to somehow save this info and use + ;; it later. + (dolist (thread (gnus-make-threads)) + (let ((id (aref (car thread) gnus-score-index))) + ;; If the parent of the thread is not a root, lower the score of + ;; it and its descendants. Note that some roots seem to satisfy + ;; (eq id nil) and some (eq id ""); not sure why. + (when (and id + (not (string= id ""))) + (gnus-score-lower-thread thread score))))) (defun gnus-score-integer (scores header now expire &optional trace) (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) @@ -1718,7 +1761,8 @@ (setq found t) (when trace (push - (cons (car-safe (rassq alist gnus-score-cache)) kill) + (cons (car-safe (rassq alist gnus-score-cache)) + kill) gnus-score-trace))) ;; Update expire date (unless trace @@ -1776,7 +1820,7 @@ (put-text-property (1- (point)) (point) 'articles alike)) (setq alike (list art) last this))) - (when last ; Bwadr, duplicate code. + (when last ; Bwadr, duplicate code. (insert last ?\n) (put-text-property (1- (point)) (point) 'articles alike)) @@ -1785,7 +1829,7 @@ (setq alist (car scores) scores (cdr scores) entries (assoc header alist)) - (while (cdr entries) ;First entry is the header index. + (while (cdr entries) ;First entry is the header index. (let* ((rest (cdr entries)) (kill (car rest)) (match (nth 0 kill)) @@ -1805,7 +1849,7 @@ (goto-char (point-min)) (if (= dmt ?e) (while (funcall search-func match nil t) - (and (= (progn (beginning-of-line) (point)) + (and (= (gnus-point-at-bol) (match-beginning 0)) (= (progn (end-of-line) (point)) (match-end 0)) @@ -1824,6 +1868,12 @@ (setq found (setq arts (get-text-property (point) 'articles))) ;; Found a match, update scores. (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (when trace + (push (cons + (car-safe (rassq alist gnus-score-cache)) + kill) + gnus-score-trace)) (when (setq new (gnus-score-add-followups (car art) score all-scores thread)) (push new news))))) @@ -1871,8 +1921,8 @@ ;; Insert the unique article headers in the buffer. (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) ;; gnus-score-index is used as a free variable. - (simplify (and gnus-score-thread-simplify - (string= "subject" header))) + (simplify (and gnus-score-thread-simplify + (string= "subject" header))) alike last this art entries alist articles fuzzies arts words kill) @@ -1897,7 +1947,7 @@ ;; with working on them as a group. What a hassle. ;; Just wait 'til you see what horrors we commit against `match'... (if (= gnus-score-index 9) - (setq this (prin1-to-string this))) ; ick. + (setq this (gnus-prin1-to-string this))) ; ick. (if simplify (setq this (gnus-map-function gnus-simplify-subject-functions this))) @@ -1936,10 +1986,10 @@ (dmt (downcase mt)) ;; Assume user already simplified regexp and fuzzies (match (if (and simplify (not (memq dmt '(?f ?r)))) - (gnus-map-function - gnus-simplify-subject-functions - (nth 0 kill)) - (nth 0 kill))) + (gnus-map-function + gnus-simplify-subject-functions + (nth 0 kill)) + (nth 0 kill))) (search-func (cond ((= dmt ?r) 're-search-forward) ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) @@ -1949,7 +1999,7 @@ ;; Evil hackery to make match usable in non-standard headers. (when extra (setq match (concat "[ (](" extra " \\. \"[^)]*" - match "[^(]*\")[ )]") + match "[^\"]*\")[ )]") search-func 're-search-forward)) ; XXX danger?!? (cond @@ -2275,11 +2325,14 @@ ;; Put the word and score into the hashtb. (setq val (gnus-gethash (setq word (match-string 0)) hashtb)) - (setq val (+ score (or val 0))) - (if (and gnus-adaptive-word-minimum - (< val gnus-adaptive-word-minimum)) - (setq val gnus-adaptive-word-minimum)) - (gnus-sethash word val hashtb)) + (when (or (not gnus-adaptive-word-length-limit) + (> (length word) + gnus-adaptive-word-length-limit)) + (setq val (+ score (or val 0))) + (if (and gnus-adaptive-word-minimum + (< val gnus-adaptive-word-minimum)) + (setq val gnus-adaptive-word-minimum)) + (gnus-sethash word val hashtb))) (erase-buffer)))) (set-syntax-table syntab)) ;; Make all the ignorable words ignored. @@ -2318,7 +2371,10 @@ (let ((gnus-newsgroup-headers (list (gnus-summary-article-header))) (gnus-newsgroup-scored nil) - trace) + ;; Must be synced with `gnus-score-edit-file-at-point': + (frmt "%S [%s] -> %s\n") + trace + file) (save-excursion (nnheader-set-temp-buffer "*Score Trace*")) (setq gnus-score-trace nil) @@ -2328,11 +2384,44 @@ 1 "No score rules apply to the current article (default score %d)." gnus-summary-default-score) (set-buffer "*Score Trace*") + ;; Use a keymap instead? + (local-set-key "q" + (lambda () + (interactive) + (bury-buffer nil) + (gnus-summary-expand-window))) + (local-set-key "e" (lambda () + "Run `gnus-score-edit-file-at-point'." + (interactive) + (gnus-score-edit-file-at-point))) + (local-set-key "f" (lambda () + "Run `gnus-score-edit-file-at-point'." + (interactive) + (gnus-score-edit-file-at-point 'format))) + (local-set-key "t" 'toggle-truncate-lines) (setq truncate-lines t) - (while trace - (insert (format "%S -> %s\n" (cdar trace) - (or (caar trace) "(non-file rule)"))) - (setq trace (cdr trace))) + (dolist (entry trace) + (setq file (or (car entry) + ;; Must be synced with + ;; `gnus-score-edit-file-at-point': + "(non-file rule)")) + (insert + (format frmt + (cdr entry) + ;; Don't use `file-name-sans-extension' to see .SCORE and + ;; .ADAPT directly: + (file-name-nondirectory file) + (abbreviate-file-name file)))) + (insert + "\n\nQuick help: + +Type `e' to edit score file corresponding to the score rule on current line, +`f' to format (pretty print) the score file and edit it, +`t' toggle to truncate long lines in this buffer, +`q' to quit. + +The first sexp on each line is the score rule, followed by the file name of +the score file and its full name, including the directory.") (goto-char (point-min)) (gnus-configure-windows 'score-trace))) (set-buffer gnus-summary-buffer) @@ -2460,7 +2549,7 @@ (defun gnus-summary-lower-thread (&optional score) "Lower score of articles in the current thread with SCORE." (interactive "P") - (gnus-summary-raise-thread (- (1- (gnus-score-delta-default score))))) + (gnus-summary-raise-thread (- (gnus-score-delta-default score)))) ;;; Finding score files. @@ -2522,7 +2611,8 @@ (push file out)))) (or out ;; Return a dummy value. - (list "~/News/this.file.does.not.exist.SCORE")))) + (list (expand-file-name "this.file.does.not.exist.SCORE" + gnus-kill-files-directory))))) (defun gnus-score-file-regexp () "Return a regexp that match all score files." @@ -2586,11 +2676,13 @@ (replace-match ".*" t t)) (goto-char (point-min)) ;; Deal with "not."s. - (setq not-match (looking-at "not.")) - (setq regexp - (concat "^" (buffer-substring (+ (point-min) (if not-match 4 0)) - (point-max)) - "$")) + (if (looking-at "not.") + (progn + (setq not-match t) + (setq regexp + (concat "^" (buffer-substring 5 (point-max)) "$"))) + (setq regexp (concat "^" (buffer-substring 1 (point-max)) "$")) + (setq not-match nil)) ;; Finally - if this resulting regexp matches the group name, ;; we add this score file to the list of score files ;; applicable to this group. @@ -2601,7 +2693,7 @@ (ignore-errors (string-match regexp group-trans)))) (push (car sfiles) ofiles))) (setq sfiles (cdr sfiles))) - (kill-buffer (current-buffer)) + (gnus-kill-buffer (current-buffer)) ;; Slight kludge here - the last score file returned should be ;; the local score file, whether it exists or not. This is so ;; that any score commands the user enters will go to the right @@ -2733,9 +2825,10 @@ ;; Go through all the functions for finding score files (or actual ;; scores) and add them to a list. (while funcs - (when (gnus-functionp (car funcs)) + (when (functionp (car funcs)) (setq score-files - (nconc score-files (nreverse (funcall (car funcs) group))))) + (append score-files + (nreverse (funcall (car funcs) group))))) (setq funcs (cdr funcs))) (when gnus-score-use-all-scores ;; Add any home score files. @@ -2800,7 +2893,7 @@ (let (out) (while files ;; #### /$ Unix-specific? - (if (string-match "/$" (car files)) + (if (file-directory-p (car files)) (setq out (nconc (directory-files (car files) t (concat (gnus-score-file-regexp) "$")))) @@ -2835,16 +2928,17 @@ ((stringp elem) elem) ;; Function. - ((gnus-functionp elem) + ((functionp elem) (funcall elem group)) ;; Regexp-file cons. ((consp elem) (when (string-match (gnus-globalify-regexp (car elem)) group) (replace-match (cadr elem) t nil group)))))) (when found + (setq found (nnheader-translate-file-chars found)) (if (file-name-absolute-p found) - found - (nnheader-concat gnus-kill-files-directory found))))) + found + (nnheader-concat gnus-kill-files-directory found))))) (defun gnus-hierarchial-home-score-file (group) "Return the score file of the top-level hierarchy of GROUP." @@ -2872,13 +2966,19 @@ (defun gnus-decay-score (score) "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'." - (floor - (- score - (* (if (< score 0) -1 1) - (min (abs score) - (max gnus-score-decay-constant - (* (abs score) - gnus-score-decay-scale))))))) + (let ((n (- score + (* (if (< score 0) -1 1) + (min (abs score) + (max gnus-score-decay-constant + (* (abs score) + gnus-score-decay-scale))))))) + (if (and (featurep 'xemacs) + ;; XEmacs' floor can handle only the floating point + ;; number below the half of the maximum integer. + (> (abs n) (lsh -1 -2))) + (string-to-number + (car (split-string (number-to-string n) "\\."))) + (floor n)))) (defun gnus-decay-scores (alist day) "Decay non-permanent scores in ALIST." @@ -2911,7 +3011,7 @@ In the `bad' case, the string is a unsafe subexpression of REGEXP, and we do not have a simple replacement to suggest. -See `(Gnus)Scoring Tips' for examples of good regular expressions." +See Info node `(gnus)Scoring Tips' for examples of good regular expressions." (let (case-fold-search) (and ;; First, try a relatively fast necessary condition.
--- a/lisp/gnus/gnus-setup.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-setup.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,7 @@ -;;; gnus-setup.el --- initialization & setup for Gnus 5 +;;; gnus-setup.el --- Initialization & Setup for Gnus 5 -;; Copyright (C) 1995, 1996, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2000, 2001 +;; Free Software Foundation, Inc. ;; Author: Steven L. Baur <steve@miranova.com> ;; Keywords: news @@ -89,8 +90,8 @@ (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) (autoload 'mc-install-write-mode "mailcrypt" nil t) (autoload 'mc-install-read-mode "mailcrypt" nil t) - (add-hook 'message-mode-hook 'mc-install-write-mode) - (add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) +;;; (add-hook 'message-mode-hook 'mc-install-write-mode) +;;; (add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) (when gnus-use-mhe (add-hook 'mh-folder-mode-hook 'mc-install-read-mode) (add-hook 'mh-letter-mode-hook 'mc-install-write-mode)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-sieve.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,240 @@ +;;; 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 'boolean + :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) + +;;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3 +;;; gnus-sieve.el ends here
--- a/lisp/gnus/gnus-soup.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-soup.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; gnus-soup.el --- SOUP packet writing support for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002 ;; Free Software Foundation, Inc. ;; Author: Per Abrahamsen <abraham@iesd.auc.dk> @@ -154,11 +154,11 @@ gnus-soup-encoding-type gnus-soup-index-type) (gnus-soup-area-set-number - area (1+ (or (gnus-soup-area-number area) 0)))) - ;; Mark article as read. - (set-buffer gnus-summary-buffer) + area (1+ (or (gnus-soup-area-number area) 0))) + ;; Mark article as read. + (set-buffer gnus-summary-buffer) + (gnus-summary-mark-as-read (car articles) gnus-souped-mark)) (gnus-summary-remove-process-mark (car articles)) - (gnus-summary-mark-as-read (car articles) gnus-souped-mark) (setq articles (cdr articles))) (kill-buffer tmp-buf)) (gnus-soup-save-areas) @@ -357,9 +357,9 @@ (gnus-make-directory dir) (setq gnus-soup-areas nil) (gnus-message 4 "Packing %s..." packer) - (if (zerop (call-process shell-file-name - nil nil nil shell-command-switch - (concat "cd " dir " ; " packer))) + (if (eq 0 (call-process shell-file-name + nil nil nil shell-command-switch + (concat "cd " dir " ; " packer))) (progn (call-process shell-file-name nil nil nil shell-command-switch (concat "cd " dir " ; rm " files)) @@ -496,10 +496,10 @@ (gnus-make-directory dir) (gnus-message 4 "Unpacking: %s" (format unpacker packet)) (prog1 - (zerop (call-process - shell-file-name nil nil nil shell-command-switch - (format "cd %s ; %s" (expand-file-name dir) - (format unpacker packet)))) + (eq 0 (call-process + shell-file-name nil nil nil shell-command-switch + (format "cd %s ; %s" (expand-file-name dir) + (format unpacker packet)))) (gnus-message 4 "Unpacking...done"))) (defun gnus-soup-send-packet (packet) @@ -540,26 +540,35 @@ (match-beginning 1) (match-end 1))))) (switch-to-buffer tmp-buf) (erase-buffer) + (mm-disable-multibyte) (insert-buffer-substring msg-buf beg end) - (goto-char (point-min)) - (search-forward "\n\n") - (forward-char -1) - (insert mail-header-separator) - (setq message-newsreader (setq message-mailer - (gnus-extended-version))) (cond ((string= (gnus-soup-reply-kind (car replies)) "news") (gnus-message 5 "Sending news message to %s..." (mail-fetch-field "newsgroups")) (sit-for 1) (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me)) - (funcall message-send-news-function))) + 'dont-check-for-anything-just-trust-me) + (method (if (functionp message-post-method) + (funcall message-post-method) + message-post-method)) + result) + (run-hooks 'message-send-news-hook) + (gnus-open-server method) + (message "Sending news via %s..." + (gnus-server-string method)) + (unless (let ((mail-header-separator "")) + (gnus-request-post method)) + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method)))))) ((string= (gnus-soup-reply-kind (car replies)) "mail") (gnus-message 5 "Sending mail to %s..." (mail-fetch-field "to")) (sit-for 1) - (message-send-mail)) + (let ((mail-header-separator "")) + (mm-with-unibyte-current-buffer + (funcall (or message-send-mail-real-function + message-send-mail-function))))) (t (error "Unknown reply kind"))) (set-buffer msg-buf)
--- a/lisp/gnus/gnus-spec.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-spec.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ -;;; gnus-spec.el --- format spec functions for Gnus -*- coding: iso-latin-1 -*- -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;;; gnus-spec.el --- format spec functions for Gnus +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -30,6 +30,17 @@ (require 'gnus) +(defcustom gnus-use-correct-string-widths (featurep 'xemacs) + "*If non-nil, use correct functions for dealing with wide characters." + :group 'gnus-format + :type 'boolean) + +(defcustom gnus-make-format-preserve-properties (featurep 'xemacs) + "*If non-nil, use a replacement `format' function which preserves +text properties. This is only needed on XEmacs, as FSF Emacs does this anyway." + :group 'gnus-format + :type 'boolean) + ;;; Internal variables. (defvar gnus-summary-mark-positions nil) @@ -69,6 +80,8 @@ (defvar gnus-tmp-article-number) (defvar gnus-mouse-face) (defvar gnus-mouse-face-prop) +(defvar gnus-tmp-header) +(defvar gnus-tmp-from) (defun gnus-summary-line-format-spec () (insert gnus-tmp-unread gnus-tmp-replied @@ -77,13 +90,15 @@ (point) (progn (insert - gnus-tmp-opening-bracket - (format "%4d: %-20s" - gnus-tmp-lines - (if (> (length gnus-tmp-name) 20) - (substring gnus-tmp-name 0 20) - gnus-tmp-name)) - gnus-tmp-closing-bracket) + (format "%c%4s: %-23s%c" gnus-tmp-opening-bracket gnus-tmp-lines + (let ((val + (inline + (gnus-summary-from-or-to-or-newsgroups + gnus-tmp-header gnus-tmp-from)))) + (if (> (length val) 23) + (substring val 0 23) + val)) + gnus-tmp-closing-bracket)) (point)) gnus-mouse-face-prop gnus-mouse-face) (insert " " gnus-tmp-subject-or-nil "\n")) @@ -120,18 +135,21 @@ (defvar gnus-format-specs `((version . ,emacs-version) + (gnus-version . ,(gnus-continuum-version)) (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec) (summary-dummy "* %(: :%) %S\n" ,gnus-summary-dummy-line-format-spec) - (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n" ,gnus-summary-line-format-spec)) "Alist of format specs.") +(defvar gnus-default-format-specs gnus-format-specs) + (defvar gnus-article-mode-line-format-spec nil) (defvar gnus-summary-mode-line-format-spec nil) (defvar gnus-group-mode-line-format-spec nil) -;;; Phew. All that gruft is over, fortunately. +;;; Phew. All that gruft is over with, fortunately. ;;;###autoload (defun gnus-update-format (var) @@ -169,6 +187,9 @@ ;; Make the indentation array. ;; See whether all the stored info needs to be flushed. (when (or force + (not gnus-newsrc-file-version) + (not (equal (gnus-continuum-version) + (gnus-continuum-version gnus-newsrc-file-version))) (not (equal emacs-version (cdr (assq 'version gnus-format-specs))))) (setq gnus-format-specs nil)) @@ -176,8 +197,8 @@ ;; Go through all the formats and see whether they need updating. (let (new-format entry type val) (while (setq type (pop types)) - ;; Jump to the proper buffer to find out the value of - ;; the variable, if possible. (It may be buffer-local.) + ;; Jump to the proper buffer to find out the value of the + ;; variable, if possible. (It may be buffer-local.) (save-excursion (let ((buffer (intern (format "gnus-%s-buffer" type))) val) @@ -243,39 +264,109 @@ (defun gnus-balloon-face-function (form type) `(gnus-put-text-property (point) (progn ,@form (point)) - 'balloon-help + ,(if (fboundp 'balloon-help-mode) + ''balloon-help + ''help-echo) ,(intern (format "gnus-balloon-face-%d" type)))) +(defun gnus-spec-tab (column) + (if (> column 0) + `(insert (make-string (max (- ,column (current-column)) 0) ? )) + (let ((column (abs column))) + (if gnus-use-correct-string-widths + `(progn + (if (> (current-column) ,column) + (while (progn + (delete-backward-char 1) + (> (current-column) ,column)))) + (insert (make-string (max (- ,column (current-column)) 0) ? ))) + `(progn + (if (> (current-column) ,column) + (delete-region (point) + (- (point) (- (current-column) ,column))) + (insert (make-string (max (- ,column (current-column)) 0) + ? )))))))) + +(defun gnus-correct-length (string) + "Return the correct width of STRING." + (let ((length 0)) + (mapcar (lambda (char) (incf length (gnus-char-width char))) string) + length)) + +(defun gnus-correct-substring (string start &optional end) + (let ((wstart 0) + (wend 0) + (wseek 0) + (seek 0) + (length (length string)) + (string (concat string "\0"))) + ;; Find the start position. + (while (and (< seek length) + (< wseek start)) + (incf wseek (gnus-char-width (aref string seek))) + (incf seek)) + (setq wstart seek) + ;; Find the end position. + (while (and (<= seek length) + (or (not end) + (<= wseek end))) + (incf wseek (gnus-char-width (aref string seek))) + (incf seek)) + (setq wend seek) + (substring string wstart (1- wend)))) + +(defun gnus-string-width-function () + (cond + (gnus-use-correct-string-widths + 'gnus-correct-length) + ((fboundp 'string-width) + 'string-width) + (t + 'length))) + +(defun gnus-substring-function () + (cond + (gnus-use-correct-string-widths + 'gnus-correct-substring) + ((fboundp 'string-width) + 'gnus-correct-substring) + (t + 'substring))) + (defun gnus-tilde-max-form (el max-width) "Return a form that limits EL to MAX-WIDTH." - (let ((max (abs max-width))) + (let ((max (abs max-width)) + (length-fun (gnus-string-width-function)) + (substring-fun (gnus-substring-function))) (if (symbolp el) - `(if (> (length ,el) ,max) + `(if (> (,length-fun ,el) ,max) ,(if (< max-width 0) - `(substring ,el (- (length el) ,max)) - `(substring ,el 0 ,max)) + `(,substring-fun ,el (- (,length-fun ,el) ,max)) + `(,substring-fun ,el 0 ,max)) ,el) `(let ((val (eval ,el))) - (if (> (length val) ,max) + (if (> (,length-fun val) ,max) ,(if (< max-width 0) - `(substring val (- (length val) ,max)) - `(substring val 0 ,max)) + `(,substring-fun val (- (,length-fun val) ,max)) + `(,substring-fun val 0 ,max)) val))))) (defun gnus-tilde-cut-form (el cut-width) "Return a form that cuts CUT-WIDTH off of EL." - (let ((cut (abs cut-width))) + (let ((cut (abs cut-width)) + (length-fun (gnus-string-width-function)) + (substring-fun (gnus-substring-function))) (if (symbolp el) - `(if (> (length ,el) ,cut) + `(if (> (,length-fun ,el) ,cut) ,(if (< cut-width 0) - `(substring ,el 0 (- (length el) ,cut)) - `(substring ,el ,cut)) + `(,substring-fun ,el 0 (- (,length-fun ,el) ,cut)) + `(,substring-fun ,el ,cut)) ,el) `(let ((val (eval ,el))) - (if (> (length val) ,cut) + (if (> (,length-fun val) ,cut) ,(if (< cut-width 0) - `(substring val 0 (- (length val) ,cut)) - `(substring val ,cut)) + `(,substring-fun val 0 (- (,length-fun val) ,cut)) + `(,substring-fun val ,cut)) val))))) (defun gnus-tilde-ignore-form (el ignore-value) @@ -287,6 +378,28 @@ (if (equal val ,ignore-value) "" val)))) +(defun gnus-pad-form (el pad-width) + "Return a form that pads EL to PAD-WIDTH accounting for multi-column +characters correctly. This is because `format' may pad to columns or to +characters when given a pad value." + (let ((pad (abs pad-width)) + (side (< 0 pad-width)) + (length-fun (gnus-string-width-function))) + (if (symbolp el) + `(let ((need (- ,pad (,length-fun ,el)))) + (if (> need 0) + (concat ,(when side '(make-string need ?\ )) + ,el + ,(when (not side) '(make-string need ?\ ))) + ,el)) + `(let* ((val (eval ,el)) + (need (- ,pad (,length-fun val)))) + (if (> need 0) + (concat ,(when side '(make-string need ?\ )) + val + ,(when (not side) '(make-string need ?\ ))) + val))))) + (defun gnus-parse-format (format spec-alist &optional insert) ;; This function parses the FORMAT string with the help of the ;; SPEC-ALIST and returns a list that can be eval'ed to return the @@ -294,52 +407,115 @@ ;; the text between them will have the mouse-face text property. ;; If the FORMAT string contains the specifiers %[ and %], the text between ;; them will have the balloon-help text property. - (if (string-match - "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'" - format) - (gnus-parse-complex-format format spec-alist) - ;; This is a simple format. - (gnus-parse-simple-format format spec-alist insert))) + (let ((case-fold-search nil)) + (if (string-match + "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'\\|%[-0-9]*=\\|%[-0-9]*\\*" + format) + (gnus-parse-complex-format format spec-alist) + ;; This is a simple format. + (gnus-parse-simple-format format spec-alist insert)))) (defun gnus-parse-complex-format (format spec-alist) - (save-excursion - (gnus-set-work-buffer) - (insert format) - (goto-char (point-min)) - (while (re-search-forward "\"" nil t) - (replace-match "\\\"" nil t)) - (goto-char (point-min)) - (insert "(\"") - (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t) - (let ((number (if (match-beginning 1) - (match-string 1) "0")) - (delim (aref (match-string 2) 0))) - (if (or (= delim ?\() - (= delim ?\{) - (= delim ?\«)) - (replace-match (concat "\"(" - (cond ((= delim ?\() "mouse") - ((= delim ?\{) "face") - (t "balloon")) - " " number " \"")) - (replace-match "\")\"")))) - (goto-char (point-max)) - (insert "\")") - (goto-char (point-min)) - (let ((form (read (current-buffer)))) - (cons 'progn (gnus-complex-form-to-spec form spec-alist))))) + (let ((cursor-spec nil)) + (save-excursion + (gnus-set-work-buffer) + (insert format) + (goto-char (point-min)) + (while (re-search-forward "\"" nil t) + (replace-match "\\\"" nil t)) + (goto-char (point-min)) + (insert "(\"") + ;; Convert all font specs into font spec lists. + (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t) + (let ((number (if (match-beginning 1) + (match-string 1) "0")) + (delim (aref (match-string 2) 0))) + (if (or (= delim ?\() + (= delim ?\{) + (= delim ?\«)) + (replace-match (concat "\"(" + (cond ((= delim ?\() "mouse") + ((= delim ?\{) "face") + (t "balloon")) + " " number " \"") + t t) + (replace-match "\")\"")))) + (goto-char (point-max)) + (insert "\")") + ;; Convert point position commands. + (goto-char (point-min)) + (let ((case-fold-search nil)) + (while (re-search-forward "%\\([-0-9]+\\)?\\*" nil t) + (replace-match "\"(point)\"" t t) + (setq cursor-spec t))) + ;; Convert TAB commands. + (goto-char (point-min)) + (while (re-search-forward "%\\([-0-9]+\\)=" nil t) + (replace-match (format "\"(tab %s)\"" (match-string 1)) t t)) + ;; Convert the buffer into the spec. + (goto-char (point-min)) + (let ((form (read (current-buffer)))) + (if cursor-spec + `(let (gnus-position) + ,@(gnus-complex-form-to-spec form spec-alist) + (if gnus-position + (gnus-put-text-property gnus-position (1+ gnus-position) + 'gnus-position t))) + `(progn + ,@(gnus-complex-form-to-spec form spec-alist))))))) (defun gnus-complex-form-to-spec (form spec-alist) (delq nil (mapcar (lambda (sform) - (if (stringp sform) - (gnus-parse-simple-format sform spec-alist t) + (cond + ((stringp sform) + (gnus-parse-simple-format sform spec-alist t)) + ((eq (car sform) 'point) + '(setq gnus-position (point))) + ((eq (car sform) 'tab) + (gnus-spec-tab (cadr sform))) + (t (funcall (intern (format "gnus-%s-face-function" (car sform))) (gnus-complex-form-to-spec (cddr sform) spec-alist) - (nth 1 sform)))) + (nth 1 sform))))) form))) + +(defun gnus-xmas-format (fstring &rest args) + "A version of `format' which preserves text properties. + +Required for XEmacs, where the built in `format' function strips all text +properties from both the format string and any inserted strings. + +Only supports the format sequence %s, and %% for inserting +literal % characters. A pad width and an optional - (to right pad) +are supported for %s." + (let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s") + (n (length args))) + (with-temp-buffer + (insert fstring) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (goto-char (match-end 0)) + (cond + ((string= (match-string 0) "%%") + (delete-char -1)) + (t + (if (null args) + (error 'wrong-number-of-arguments #'my-format n fstring)) + (let* ((minlen (string-to-int (or (match-string 2) ""))) + (arg (car args)) + (str (if (stringp arg) arg (format "%s" arg))) + (lpad (null (match-string 1))) + (padlen (max 0 (- minlen (length str))))) + (replace-match "") + (if lpad (insert-char ?\ padlen)) + (insert str) + (unless lpad (insert-char ?\ padlen)) + (setq args (cdr args)))))) + (buffer-string)))) + (defun gnus-parse-simple-format (format spec-alist &optional insert) ;; This function parses the FORMAT string with the help of the ;; SPEC-ALIST and returns a list that can be eval'ed to return a @@ -347,7 +523,7 @@ (let ((max-width 0) spec flist fstring elem result dontinsert user-defined type value pad-width spec-beg cut-width ignore-value - tilde-form tilde elem-type) + tilde-form tilde elem-type extended-spec) (save-excursion (gnus-set-work-buffer) (insert format) @@ -359,7 +535,8 @@ max-width nil cut-width nil ignore-value nil - tilde-form nil) + tilde-form nil + extended-spec nil) (setq spec-beg (1- (point))) ;; Parse this spec fully. @@ -400,10 +577,18 @@ t) (t nil))) - ;; User-defined spec -- find the spec name. - (when (eq (setq spec (char-after)) ?u) + (cond + ;; User-defined spec -- find the spec name. + ((eq (setq spec (char-after)) ?u) (forward-char 1) - (setq user-defined (char-after))) + (when (and (eq (setq user-defined (char-after)) ?&) + (looking-at "&\\([^;]+\\);")) + (setq user-defined (match-string 1)) + (goto-char (match-end 1)))) + ;; extended spec + ((and (eq spec ?&) (looking-at "&\\([^;]+\\);")) + (setq extended-spec (intern (match-string 1))) + (goto-char (match-end 1)))) (forward-char 1) (delete-region spec-beg (point)) @@ -421,20 +606,27 @@ (user-defined (setq elem (list - (list (intern (format "gnus-user-format-function-%c" - user-defined)) + (list (intern (format + (if (stringp user-defined) + "gnus-user-format-function-%s" + "gnus-user-format-function-%c") + user-defined)) 'gnus-tmp-header) ?s))) ;; Find the specification from `spec-alist'. - ((setq elem (cdr (assq spec spec-alist)))) + ((setq elem (cdr (assq (or extended-spec spec) spec-alist)))) (t (setq elem '("*" ?s)))) (setq elem-type (cadr elem)) ;; Insert the new format elements. - (when pad-width + (when (and pad-width + (not (and (featurep 'xemacs) + gnus-use-correct-string-widths))) (insert (number-to-string pad-width))) ;; Create the form to be evaled. - (if (or max-width cut-width ignore-value) + (if (or max-width cut-width ignore-value + (and (featurep 'xemacs) + gnus-use-correct-string-widths)) (progn (insert ?s) (let ((el (car elem))) @@ -448,16 +640,18 @@ (setq el (gnus-tilde-cut-form el cut-width))) (when max-width (setq el (gnus-tilde-max-form el max-width))) + (when pad-width + (setq el (gnus-pad-form el pad-width))) (push el flist))) (insert elem-type) (push (car elem) flist)))) - (setq fstring (buffer-string))) + (setq fstring (buffer-substring-no-properties (point-min) (point-max)))) ;; Do some postprocessing to increase efficiency. (setq result (cond - ;; Emptyness. + ;; Emptiness. ((string= fstring "") nil) ;; Not a format string. @@ -487,6 +681,13 @@ ;; A single string spec in the end of the spec. ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring) (list (match-string 1 fstring) (car flist))) + ;; Only string (and %) specs (XEmacs only!) + ((and (featurep 'xemacs) + gnus-make-format-preserve-properties + (string-match + "\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'" + fstring)) + (list (cons 'gnus-xmas-format (cons fstring (nreverse flist))))) ;; A more complex spec. (t (list (cons 'format (cons fstring (nreverse flist))))))) @@ -522,7 +723,7 @@ (while entries (setq entry (pop entries)) - (if (eq (car entry) 'version) + (if (memq (car entry) '(gnus-version version)) (setq gnus-format-specs (delq entry gnus-format-specs)) (let ((form (caddr entry))) (when (and (listp form) @@ -531,7 +732,7 @@ ;; Under XEmacs, it's (funcall #<compiled-function ...>) (not (and (eq 'funcall (car form)) (byte-code-function-p (cadr form))))) - (fset 'gnus-tmp-func `(lambda () ,form)) + (defalias 'gnus-tmp-func `(lambda () ,form)) (byte-compile 'gnus-tmp-func) (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))
--- a/lisp/gnus/gnus-srvr.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-srvr.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-srvr.el --- virtual server support for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -34,10 +34,17 @@ (require 'gnus-int) (require 'gnus-range) -(defvar gnus-server-mode-hook nil - "Hook run in `gnus-server-mode' buffers.") +(defcustom gnus-server-mode-hook nil + "Hook run in `gnus-server-mode' buffers." + :group 'gnus-server + :type 'hook) -(defconst gnus-server-line-format " {%(%h:%w%)} %s\n" +(defcustom gnus-server-exit-hook nil + "Hook run when exiting the server buffer." + :group 'gnus-server + :type 'hook) + +(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n" "Format of server lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -47,13 +54,25 @@ %h backend %n name %w address -%s status") +%s status +%a agent covered + +General format specifiers can also be used. +See Info node `(gnus)Formatting Variables'." + :link '(custom-manual "(gnus)Formatting Variables") + :group 'gnus-server-visual + :type 'string) -(defvar gnus-server-mode-line-format "Gnus: %%b" - "The format specification for the server mode line.") +(defcustom gnus-server-mode-line-format "Gnus: %%b" + "The format specification for the server mode line." + :group 'gnus-server-visual + :type 'string) -(defvar gnus-server-exit-hook nil - "*Hook run when exiting the server buffer.") +(defcustom gnus-server-browse-in-group-buffer nil + "Whether server browsing should take place in the group buffer. +If nil, a faster, but more primitive, buffer is used instead." + :group 'gnus-server-visual + :type 'boolean) ;;; Internal variables. @@ -63,7 +82,8 @@ `((?h gnus-tmp-how ?s) (?n gnus-tmp-name ?s) (?w gnus-tmp-where ?s) - (?s gnus-tmp-status ?s))) + (?s gnus-tmp-status ?s) + (?a gnus-tmp-agent ?s))) (defvar gnus-server-mode-line-format-alist `((?S gnus-tmp-news-server ?s) @@ -85,7 +105,7 @@ (easy-menu-define gnus-server-server-menu gnus-server-mode-map "" '("Server" - ["Add" gnus-server-add-server t] + ["Add..." gnus-server-add-server t] ["Browse" gnus-server-read-server t] ["Scan" gnus-server-scan-server t] ["List" gnus-server-list-servers t] @@ -101,6 +121,7 @@ '("Connections" ["Open" gnus-server-open-server t] ["Close" gnus-server-close-server t] + ["Offline" gnus-server-offline-server t] ["Deny" gnus-server-deny-server t] "---" ["Open All" gnus-server-open-all-servers t] @@ -117,7 +138,7 @@ (suppress-keymap gnus-server-mode-map) (gnus-define-keys gnus-server-mode-map - " " gnus-server-read-server + " " gnus-server-read-server-in-server-buffer "\r" gnus-server-read-server gnus-mouse-2 gnus-server-pick-server "q" gnus-server-exit @@ -134,6 +155,7 @@ "C" gnus-server-close-server "\M-c" gnus-server-close-all-servers "D" gnus-server-deny-server + "L" gnus-server-offline-server "R" gnus-server-remove-denials "n" next-line @@ -144,6 +166,75 @@ "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) +(defface gnus-server-agent-face + '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t)) + (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t)) + (t (:bold t))) + "Face used for displaying AGENTIZED servers" + :group 'gnus-server-visual) + +(defface gnus-server-opened-face + '((((class color) (background light)) (:foreground "Green3" :bold t)) + (((class color) (background dark)) (:foreground "Green1" :bold t)) + (t (:bold t))) + "Face used for displaying OPENED servers" + :group 'gnus-server-visual) + +(defface gnus-server-closed-face + '((((class color) (background light)) (:foreground "Steel Blue" :italic t)) + (((class color) (background dark)) + (:foreground "Light Steel Blue" :italic t)) + (t (:italic t))) + "Face used for displaying CLOSED servers" + :group 'gnus-server-visual) + +(defface gnus-server-denied-face + '((((class color) (background light)) (:foreground "Red" :bold t)) + (((class color) (background dark)) (:foreground "Pink" :bold t)) + (t (:inverse-video t :bold t))) + "Face used for displaying DENIED servers" + :group 'gnus-server-visual) + +(defface gnus-server-offline-face + '((((class color) (background light)) (:foreground "Orange" :bold t)) + (((class color) (background dark)) (:foreground "Yellow" :bold t)) + (t (:inverse-video t :bold t))) + "Face used for displaying OFFLINE servers" + :group 'gnus-server-visual) + +(defcustom gnus-server-agent-face 'gnus-server-agent-face + "Face name to use on AGENTIZED servers." + :group 'gnus-server-visual + :type 'face) + +(defcustom gnus-server-opened-face 'gnus-server-opened-face + "Face name to use on OPENED servers." + :group 'gnus-server-visual + :type 'face) + +(defcustom gnus-server-closed-face 'gnus-server-closed-face + "Face name to use on CLOSED servers." + :group 'gnus-server-visual + :type 'face) + +(defcustom gnus-server-denied-face 'gnus-server-denied-face + "Face name to use on DENIED servers." + :group 'gnus-server-visual + :type 'face) + +(defcustom gnus-server-offline-face 'gnus-server-offline-face + "Face name to use on OFFLINE servers." + :group 'gnus-server-visual + :type 'face) + +(defvar gnus-server-font-lock-keywords + (list + '("(\\(agent\\))" 1 gnus-server-agent-face) + '("(\\(opened\\))" 1 gnus-server-opened-face) + '("(\\(closed\\))" 1 gnus-server-closed-face) + '("(\\(offline\\))" 1 gnus-server-offline-face) + '("(\\(denied\\))" 1 gnus-server-denied-face))) + (defun gnus-server-mode () "Major mode for listing and editing servers. @@ -168,6 +259,10 @@ (buffer-disable-undo) (setq truncate-lines t) (setq buffer-read-only t) + (if (featurep 'xemacs) + (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t)) + (set (make-local-variable 'font-lock-defaults) + '(gnus-server-font-lock-keywords t))) (gnus-run-hooks 'gnus-server-mode-hook)) (defun gnus-server-insert-server-line (gnus-tmp-name method) @@ -175,21 +270,28 @@ (gnus-tmp-where (nth 1 method)) (elem (assoc method gnus-opened-servers)) (gnus-tmp-status - (if (eq (nth 1 elem) 'denied) - "(denied)" + (cond + ((eq (nth 1 elem) 'denied) "(denied)") + ((eq (nth 1 elem) 'offline) "(offline)") + (t (condition-case nil (if (or (gnus-server-opened method) (eq (nth 1 elem) 'ok)) "(opened)" "(closed)") ((error) "(error)"))))) + (gnus-tmp-agent (if (and gnus-agent + (gnus-agent-method-p method)) + " (agent)" + ""))) (beginning-of-line) (gnus-add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. (eval gnus-server-line-format-spec)) - (list 'gnus-server (intern gnus-tmp-name))))) + (list 'gnus-server (intern gnus-tmp-name) + 'gnus-named-server (intern (gnus-method-to-server method)))))) (defun gnus-enter-server-buffer () "Set up the server buffer." @@ -243,6 +345,12 @@ (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) (and server (symbol-name server)))) +(defun gnus-server-named-server () + "Returns a server name that matches one of the names returned by +gnus-method-to-server." + (let ((server (get-text-property (gnus-point-at-bol) 'gnus-named-server))) + (and server (symbol-name server)))) + (defalias 'gnus-server-position-point 'gnus-goto-colon) (defconst gnus-server-edit-buffer "*Gnus edit server*") @@ -257,7 +365,7 @@ (when entry (gnus-dribble-enter (concat "(gnus-server-set-info \"" server "\" '" - (prin1-to-string (cdr entry)) ")\n"))) + (gnus-prin1-to-string (cdr entry)) ")\n"))) (when (or entry oentry) ;; Buffer may be narrowed. (save-restriction @@ -276,9 +384,13 @@ (when (and server info) (gnus-dribble-enter (concat "(gnus-server-set-info \"" server "\" '" - (prin1-to-string info) ")")) + (gnus-prin1-to-string info) ")")) (let* ((server (nth 1 info)) - (entry (assoc server gnus-server-alist))) + (entry (assoc server gnus-server-alist)) + (cached (assoc server gnus-server-method-cache))) + (if cached + (setq gnus-server-method-cache + (delq cached gnus-server-method-cache))) (if entry (setcdr entry info) (setq gnus-server-alist (nconc gnus-server-alist (list (cons server info)))))))) @@ -330,7 +442,7 @@ (setq alist (cdr alist))) (if alist (setcdr alist (cons killed (cdr alist))) - (setq gnus-server-alist (list killed))))) + (setq gnus-server-alist (list killed))))) (gnus-server-update-server (car killed)) (setq gnus-server-killed-servers (cdr gnus-server-killed-servers)) (gnus-server-position-point))) @@ -339,7 +451,7 @@ "Return to the group buffer." (interactive) (gnus-run-hooks 'gnus-server-exit-hook) - (kill-buffer (current-buffer)) + (gnus-kill-buffer (current-buffer)) (gnus-configure-windows 'group t)) (defun gnus-server-list-servers () @@ -396,12 +508,23 @@ (gnus-server-update-server server) (gnus-server-position-point)))) +(defun gnus-server-offline-server (server) + "Set SERVER to offline." + (interactive (list (gnus-server-server-name))) + (let ((method (gnus-server-to-method server))) + (unless method + (error "No such server: %s" server)) + (prog1 + (gnus-close-server method) + (gnus-server-set-status method 'offline) + (gnus-server-update-server server) + (gnus-server-position-point)))) + (defun gnus-server-close-all-servers () "Close all servers." (interactive) - (let ((servers gnus-inserted-opened-servers)) - (while servers - (gnus-server-close-server (car (pop servers)))))) + (dolist (server gnus-inserted-opened-servers) + (gnus-server-close-server (car server)))) (defun gnus-server-deny-server (server) "Make sure SERVER will never be attempted opened." @@ -417,11 +540,9 @@ (defun gnus-server-remove-denials () "Make all denied servers into closed servers." (interactive) - (let ((servers gnus-opened-servers)) - (while servers - (when (eq (nth 1 (car servers)) 'denied) - (setcar (nthcdr 1 (car servers)) 'closed)) - (setq servers (cdr servers)))) + (dolist (server gnus-opened-servers) + (when (eq (nth 1 server) 'denied) + (setcar (nthcdr 1 server) 'closed))) (gnus-server-list-servers)) (defun gnus-server-copy-server (from to) @@ -491,6 +612,12 @@ (gnus-request-scan nil method) (gnus-message 3 "Scanning %s...done" server)))) +(defun gnus-server-read-server-in-server-buffer (server) + "Browse a server in server buffer." + (interactive (list (gnus-server-server-name))) + (let (gnus-server-browse-in-group-buffer) + (gnus-server-read-server server))) + (defun gnus-server-read-server (server) "Browse a server." (interactive (list (gnus-server-server-name))) @@ -541,6 +668,7 @@ "L" gnus-browse-exit "q" gnus-browse-exit "Q" gnus-browse-exit + "d" gnus-browse-describe-group "\C-c\C-c" gnus-browse-exit "?" gnus-browse-describe-briefly @@ -556,6 +684,7 @@ ["Subscribe" gnus-browse-unsubscribe-current-group t] ["Read" gnus-browse-read-group t] ["Select" gnus-browse-select-group t] + ["Describe" gnus-browse-describe-group t] ["Next" gnus-browse-next-group t] ["Prev" gnus-browse-prev-group t] ["Exit" gnus-browse-exit t])) @@ -571,6 +700,7 @@ (setq gnus-browse-current-method (gnus-server-to-method server)) (setq gnus-browse-return-buffer return-buffer) (let* ((method gnus-browse-current-method) + (orig-select-method gnus-select-method) (gnus-select-method method) groups group) (gnus-message 5 "Connecting to %s..." (nth 1 method)) @@ -589,58 +719,97 @@ 1 "Couldn't request list: %s" (gnus-status-message method)) nil) (t - (gnus-get-buffer-create gnus-browse-buffer) - (when gnus-carpal - (gnus-carpal-setup-buffer 'browse)) - (gnus-configure-windows 'browse) - (buffer-disable-undo) - (let ((buffer-read-only nil)) - (erase-buffer)) - (gnus-browse-mode) - (setq mode-line-buffer-identification - (list - (format - "Gnus: %%b {%s:%s}" (car method) (cadr method)))) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (let ((cur (current-buffer))) (goto-char (point-min)) (unless (string= gnus-ignored-newsgroups "") (delete-matching-lines gnus-ignored-newsgroups)) - (while (not (eobp)) - (ignore-errors - (push (cons - (if (eq (char-after) ?\") - (read cur) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) + ;; We treat NNTP as a special case to avoid problems with + ;; garbage group names like `"foo' that appear in some badly + ;; managed active files. -jh. + (if (eq (car method) 'nntp) + (while (not (eobp)) + (ignore-errors + (push (cons + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + (let ((last (read cur))) + (cons (read cur) last))) + groups)) + (forward-line)) + (while (not (eobp)) + (ignore-errors + (push (cons + (if (eq (char-after) ?\") + (read cur) + (let ((p (point)) (name "")) (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - name)) - (max 0 (- (1+ (read cur)) (read cur)))) - groups)) - (forward-line)))) + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + name)) + (let ((last (read cur))) + (cons (read cur) last))) + groups)) + (forward-line))))) (setq groups (sort groups (lambda (l1 l2) (string< (car l1) (car l2))))) - (let ((buffer-read-only nil) charset) - (while groups - (setq group (car groups)) - (setq charset (gnus-group-name-charset method group)) - (gnus-add-text-properties - (point) - (prog1 (1+ (point)) - (insert - (format "K%7d: %s\n" (cdr group) - (gnus-group-name-decode (car group) charset)))) - (list 'gnus-group (car group))) - (setq groups (cdr groups)))) - (switch-to-buffer (current-buffer)) + (if gnus-server-browse-in-group-buffer + (let* ((gnus-select-method orig-select-method) + (gnus-group-listed-groups + (mapcar (lambda (group) + (let ((name + (gnus-group-prefixed-name + (car group) method))) + (gnus-set-active name (cdr group)) + name)) + groups))) + (gnus-configure-windows 'group) + (funcall gnus-group-prepare-function + gnus-level-killed 'ignore 1 'ignore)) + (gnus-get-buffer-create gnus-browse-buffer) + (when gnus-carpal + (gnus-carpal-setup-buffer 'browse)) + (gnus-configure-windows 'browse) + (buffer-disable-undo) + (let ((buffer-read-only nil)) + (erase-buffer)) + (gnus-browse-mode) + (setq mode-line-buffer-identification + (list + (format + "Gnus: %%b {%s:%s}" (car method) (cadr method)))) + (let ((buffer-read-only nil) + name + (prefix (let ((gnus-select-method orig-select-method)) + (gnus-group-prefixed-name "" method)))) + (while (setq group (pop groups)) + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + (insert + (format "%c%7d: %s\n" + (let ((level (gnus-group-level + (concat prefix (setq name (car group)))))) + (cond + ((<= level gnus-level-subscribed) ? ) + ((<= level gnus-level-unsubscribed) ?U) + ((= level gnus-level-zombie) ?Z) + (t ?K))) + (max 0 (- (1+ (cddr group)) (cadr group))) + (mm-decode-coding-string + name + (inline (gnus-group-name-charset method name)))))) + (list 'gnus-group name)))) + (switch-to-buffer (current-buffer))) (goto-char (point-min)) (gnus-group-position-point) (gnus-message 5 "Connecting to %s...done" (nth 1 method)) @@ -683,7 +852,7 @@ (if (or (not (gnus-get-info group)) (gnus-ephemeral-group-p group)) (unless (gnus-group-read-ephemeral-group - (gnus-group-real-name group) gnus-browse-current-method nil + group gnus-browse-current-method nil (cons (current-buffer) 'browse)) (error "Couldn't enter %s" group)) (unless (gnus-group-read-group nil no-article group) @@ -728,10 +897,14 @@ (beginning-of-line) (let ((name (get-text-property (point) 'gnus-group))) (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) - (gnus-group-prefixed-name - (or name - (match-string-no-properties 1)) - gnus-browse-current-method))))) + (concat (gnus-method-to-server-name gnus-browse-current-method) ":" + (or name + (match-string-no-properties 1))))))) + +(defun gnus-browse-describe-group (group) + "Describe the current group." + (interactive (list (gnus-browse-group-name))) + (gnus-group-describe-group nil group)) (defun gnus-browse-unsubscribe-group () "Toggle subscription of the current group in the browse buffer." @@ -741,13 +914,11 @@ (save-excursion (beginning-of-line) ;; If this group it killed, then we want to subscribe it. - (when (eq (char-after) ?K) + (unless (eq (char-after) ? ) (setq sub t)) (setq group (gnus-browse-group-name)) - (when (and sub - (cadr (gnus-gethash group gnus-newsrc-hashtb))) - (error "Group already subscribed")) - (delete-char 1) + (when (gnus-server-equal gnus-browse-current-method "native") + (setq group (gnus-group-real-name group))) (if sub (progn ;; Make sure the group has been properly removed before we @@ -760,22 +931,24 @@ nil (gnus-method-simplify gnus-browse-current-method))) - gnus-level-default-subscribed gnus-level-killed + gnus-level-default-subscribed (gnus-group-level group) (and (car (nth 1 gnus-newsrc-alist)) (gnus-gethash (car (nth 1 gnus-newsrc-alist)) gnus-newsrc-hashtb)) t) + (delete-char 1) (insert ? )) (gnus-group-change-level - group gnus-level-killed gnus-level-default-subscribed) - (insert ?K))) + group gnus-level-unsubscribed gnus-level-default-subscribed) + (delete-char 1) + (insert ?U))) t)) (defun gnus-browse-exit () "Quit browsing and return to the group buffer." (interactive) (when (eq major-mode 'gnus-browse-mode) - (kill-buffer (current-buffer))) + (gnus-kill-buffer (current-buffer))) ;; Insert the newly subscribed groups in the group buffer. (save-excursion (set-buffer gnus-group-buffer) @@ -796,15 +969,17 @@ (let ((server (gnus-server-server-name))) (unless server (error "No server on the current line")) - (if (not (gnus-check-backend-function - 'request-regenerate (car (gnus-server-to-method server)))) - (error "This backend doesn't support regeneration") - (gnus-message 5 "Requesting regeneration of %s..." server) - (unless (gnus-open-server server) - (error "Couldn't open server")) - (if (gnus-request-regenerate server) - (gnus-message 5 "Requesting regeneration of %s...done" server) - (gnus-message 5 "Couldn't regenerate %s" server))))) + (condition-case () + (gnus-get-function (gnus-server-to-method server) + 'request-regenerate) + (error + (error "This backend doesn't support regeneration"))) + (gnus-message 5 "Requesting regeneration of %s..." server) + (unless (gnus-open-server server) + (error "Couldn't open server")) + (if (gnus-request-regenerate server) + (gnus-message 5 "Requesting regeneration of %s...done" server) + (gnus-message 5 "Couldn't regenerate %s" server)))) (provide 'gnus-srvr)
--- a/lisp/gnus/gnus-start.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-start.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-start.el --- startup functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -32,7 +32,9 @@ (require 'gnus-spec) (require 'gnus-range) (require 'gnus-util) -(require 'message) +(autoload 'message-make-date "message") +(autoload 'gnus-agent-read-servers-validate "gnus-agent") +(autoload 'gnus-agent-possibly-alter-active "gnus-agent") (eval-when-compile (require 'cl)) (defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc") @@ -41,6 +43,24 @@ :group 'gnus-start :type 'file) +(defcustom gnus-backup-startup-file 'never + "Whether to create backup files. +This variable takes the same values as the `version-control' +variable." + :group 'gnus-start + :type '(choice (const :tag "Never" never) + (const :tag "If existing" nil) + (other :tag "Always" t))) + +(defcustom gnus-save-startup-file-via-temp-buffer t + "Whether to write the startup file contents to a buffer then save +the buffer or write directly to the file. The buffer is faster +because all of the contents are written at once. The direct write +uses considerably less memory." + :group 'gnus-start + :type '(choice (const :tag "Write via buffer" t) + (const :tag "Write directly to file" nil))) + (defcustom gnus-init-file (nnheader-concat gnus-home-directory ".gnus") "Your Gnus Emacs-Lisp startup file name. If a file with the `.el' or `.elc' suffixes exists, it will be read instead." @@ -224,12 +244,17 @@ This variable can also be a regexp. In that case, all groups that do not match this regexp will be removed before saving the list." :group 'gnus-newsrc - :type 'boolean) + :type '(radio (sexp :format "Non-nil\n" + :match (lambda (widget value) + (and value (not (stringp value)))) + :value t) + (const nil) + (regexp :format "%t: %v\n" :size 0))) (defcustom gnus-ignored-newsgroups (mapconcat 'identity '("^to\\." ; not "real" groups - "^[0-9. \t]+ " ; all digits in name + "^[0-9. \t]+\\( \\|$\\)" ; all digits in name "^[\"][]\"[#'()]" ; bogus characters ) "\\|") @@ -241,7 +266,7 @@ :type 'regexp) (defcustom gnus-subscribe-newsgroup-method 'gnus-subscribe-zombies - "*Function called with a group name when new group is detected. + "*Function(s) called with a group name when new group is detected. A few pre-made functions are supplied: `gnus-subscribe-randomly' inserts new groups at the beginning of the list of groups; `gnus-subscribe-alphabetically' inserts new groups in strict @@ -259,11 +284,18 @@ (function-item gnus-subscribe-killed) (function-item gnus-subscribe-zombies) (function-item gnus-subscribe-topics) - function)) + function + (repeat function))) + +(defcustom gnus-subscribe-newsgroup-hooks nil + "*Hooks run after you subscribe to a new group. +The hooks will be called with new group's name as argument." + :group 'gnus-group-new + :type 'hook) (defcustom gnus-subscribe-options-newsgroup-method 'gnus-subscribe-alphabetically - "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines. + "*Function(s) called to subscribe newsgroups mentioned on \"options -n\" lines. If, for instance, you want to subscribe to all newsgroups in the \"no\" and \"alt\" hierarchies, you'd put the following in your .newsrc file: @@ -279,7 +311,9 @@ (function-item gnus-subscribe-interactively) (function-item gnus-subscribe-killed) (function-item gnus-subscribe-zombies) - function)) + (function-item gnus-subscribe-topics) + function + (repeat function))) (defcustom gnus-subscribe-hierarchical-interactive nil "*If non-nil, Gnus will offer to subscribe hierarchically. @@ -294,7 +328,7 @@ :type 'boolean) (defcustom gnus-auto-subscribed-groups - "nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl" + "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir" "*All new groups that match this regexp will be subscribed automatically. Note that this variable only deals with new groups. It has no effect whatsoever on old groups. @@ -354,23 +388,34 @@ :group 'gnus-start :type 'hook) -(defcustom gnus-setup-news-hook nil +(defcustom gnus-setup-news-hook + '(gnus-fixup-nnimap-unread-after-getting-new-news) "A hook after reading the .newsrc file, but before generating the buffer." :group 'gnus-start :type 'hook) +(defcustom gnus-get-top-new-news-hook nil + "A hook run just before Gnus checks for new news globally." + :group 'gnus-group-new + :type 'hook) + (defcustom gnus-get-new-news-hook nil "A hook run just before Gnus checks for new news." :group 'gnus-group-new :type 'hook) (defcustom gnus-after-getting-new-news-hook - (when (gnus-boundp 'display-time-timer) - '(display-time-event-handler)) + '(gnus-display-time-event-handler + gnus-fixup-nnimap-unread-after-getting-new-news) "*A hook run after Gnus checks for new news when Gnus is already running." :group 'gnus-group-new :type 'hook) +(defcustom gnus-read-newsrc-el-hook nil + "A hook called after reading the newsrc.eld? file." + :group 'gnus-newsrc + :type 'hook) + (defcustom gnus-save-newsrc-hook nil "A hook called before saving any of the newsrc files." :group 'gnus-newsrc @@ -388,6 +433,12 @@ :group 'gnus-newsrc :type 'hook) +(defcustom gnus-group-mode-hook nil + "Hook for Gnus group mode." + :group 'gnus-group-various + :options '(gnus-topic-mode) + :type 'hook) + (defcustom gnus-always-read-dribble-file nil "Unconditionally read the dribble file." :group 'gnus-newsrc @@ -432,7 +483,7 @@ (condition-case var (load file nil t) (error - (error "Error in %s: %s" file var))))))))) + (error "Error in %s: %s" file (cadr var)))))))))) ;; For subscribing new newsgroup @@ -508,7 +559,7 @@ (gnus-subscribe-newsgroup newsgroup)) (defun gnus-subscribe-alphabetically (newgroup) - "Subscribe new NEWSGROUP and insert it in alphabetical order." + "Subscribe new NEWGROUP and insert it in alphabetical order." (let ((groups (cdr gnus-newsrc-alist)) before) (while (and (not before) groups) @@ -518,26 +569,26 @@ (gnus-subscribe-newsgroup newgroup before))) (defun gnus-subscribe-hierarchically (newgroup) - "Subscribe new NEWSGROUP and insert it in hierarchical newsgroup order." + "Subscribe new NEWGROUP and insert it in hierarchical newsgroup order." ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) (save-excursion (set-buffer (nnheader-find-file-noselect gnus-current-startup-file)) - (let ((groupkey newgroup) - before) - (while (and (not before) groupkey) - (goto-char (point-min)) - (let ((groupkey-re - (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]"))) - (while (and (re-search-forward groupkey-re nil t) - (progn - (setq before (match-string 1)) - (string< before newgroup))))) - ;; Remove tail of newsgroup name (eg. a.b.c -> a.b) - (setq groupkey - (when (string-match "^\\(.*\\)\\.[^.]+$" groupkey) - (substring groupkey (match-beginning 1) (match-end 1))))) - (gnus-subscribe-newsgroup newgroup before)) - (kill-buffer (current-buffer)))) + (prog1 + (let ((groupkey newgroup) before) + (while (and (not before) groupkey) + (goto-char (point-min)) + (let ((groupkey-re + (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]"))) + (while (and (re-search-forward groupkey-re nil t) + (progn + (setq before (match-string 1)) + (string< before newgroup))))) + ;; Remove tail of newsgroup name (eg. a.b.c -> a.b) + (setq groupkey + (when (string-match "^\\(.*\\)\\.[^.]+$" groupkey) + (substring groupkey (match-beginning 1) (match-end 1))))) + (gnus-subscribe-newsgroup newgroup before)) + (kill-buffer (current-buffer))))) (defun gnus-subscribe-interactively (group) "Subscribe the new GROUP interactively. @@ -566,7 +617,9 @@ newsgroup gnus-level-default-subscribed gnus-level-killed (gnus-gethash (or next "dummy.group") gnus-newsrc-hashtb)) - (gnus-message 5 "Subscribe newsgroup: %s" newsgroup))) + (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) + (run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup) + t)) (defun gnus-read-active-file-p () "Say whether the active file has been read from `gnus-select-method'." @@ -575,27 +628,40 @@ ;;; General various misc type functions. ;; Silence byte-compiler. -(defvar gnus-current-headers) -(defvar gnus-thread-indent-array) -(defvar gnus-newsgroup-name) -(defvar gnus-newsgroup-headers) -(defvar gnus-group-list-mode) -(defvar gnus-group-mark-positions) -(defvar gnus-newsgroup-data) -(defvar gnus-newsgroup-unreads) -(defvar nnoo-state-alist) -(defvar gnus-current-select-method) +(eval-when-compile + (defvar gnus-current-headers) + (defvar gnus-thread-indent-array) + (defvar gnus-newsgroup-name) + (defvar gnus-newsgroup-headers) + (defvar gnus-group-list-mode) + (defvar gnus-group-mark-positions) + (defvar gnus-newsgroup-data) + (defvar gnus-newsgroup-unreads) + (defvar nnoo-state-alist) + (defvar gnus-current-select-method) + (defvar mail-sources) + (defvar nnmail-scan-directory-mail-source-once) + (defvar nnmail-split-history) + (defvar nnmail-spool-file)) + +(defun gnus-close-all-servers () + "Close all servers." + (interactive) + (dolist (server gnus-opened-servers) + (gnus-close-server (car server)))) (defun gnus-clear-system () "Clear all variables and buffers." ;; Clear Gnus variables. - (let ((variables gnus-variable-list)) + (let ((variables (remove 'gnus-format-specs gnus-variable-list))) (while variables (set (car variables) nil) (setq variables (cdr variables)))) ;; Clear other internal variables. (setq gnus-list-of-killed-groups nil gnus-have-read-active-file nil + gnus-agent-covered-methods nil + gnus-server-method-cache nil gnus-newsrc-alist nil gnus-newsrc-hashtb nil gnus-killed-list nil @@ -630,9 +696,8 @@ (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil)))) (gnus-kill-buffer nntp-server-buffer) ;; Kill Gnus buffers. - (let ((buffers (gnus-buffers))) - (when buffers - (mapcar 'kill-buffer buffers))) + (dolist (buffer (gnus-buffers)) + (gnus-kill-buffer buffer)) ;; Remove Gnus frames. (gnus-kill-gnus-frames)) @@ -670,6 +735,8 @@ (nnheader-init-server-buffer) (setq gnus-slave slave) (gnus-read-init-file) + (if gnus-agent + (gnus-agentize)) (when gnus-simple-splash (setq gnus-simple-splash nil) @@ -707,6 +774,9 @@ (add-hook 'gnus-summary-mode-hook 'gnus-grouplens-mode)) ;; Do the actual startup. + (if gnus-agent + (gnus-request-create-group "queue" '(nndraft ""))) + (gnus-request-create-group "drafts" '(nndraft "")) (gnus-setup-news nil level dont-connect) (gnus-run-hooks 'gnus-setup-news-hook) (gnus-start-draft-setup) @@ -726,17 +796,6 @@ (gnus-group-set-parameter "nndraft:drafts" 'gnus-dummy '((gnus-draft-mode))))) -;;;###autoload -(defun gnus-unload () - "Unload all Gnus features. -\(For some value of `all' or `Gnus'.) Currently, features whose names -have prefixes `gnus-', `nn', `mm-' or `rfc' are unloaded. Use -cautiously -- unloading may cause trouble." - (interactive) - (dolist (feature features) - (if (string-match "^\\(gnus-\\|nn\\|mm-\\|rfc\\)" (symbol-name feature)) - (unload-feature feature 'force)))) - ;;; ;;; Dribble file @@ -763,7 +822,11 @@ (set-buffer gnus-dribble-buffer) (goto-char (point-max)) (insert string "\n") - (set-window-point (get-buffer-window (current-buffer)) (point-max)) + ;; This has been commented by Josh Huber <huber@alum.wpi.edu> + ;; It causes problems with both XEmacs and Emacs 21, and doesn't + ;; seem to be of much value. (FIXME: remove this after we make sure + ;; it's not needed). + ;; (set-window-point (get-buffer-window (current-buffer)) (point-max)) (bury-buffer gnus-dribble-buffer) (save-excursion (set-buffer gnus-group-buffer) @@ -789,6 +852,7 @@ (set-buffer-modified-p nil) (let ((auto (make-auto-save-file-name)) (gnus-dribble-ignore t) + (purpose nil) modes) (when (or (file-exists-p auto) (file-exists-p dribble-file)) ;; Load whichever file is newest -- the auto save file @@ -804,10 +868,15 @@ (file-exists-p dribble-file) (setq modes (file-modes gnus-current-startup-file))) (set-file-modes dribble-file modes)) + (goto-char (point-min)) + (when (search-forward "Gnus was exited on purpose" nil t) + (setq purpose t)) ;; Possibly eval the file later. (when (or gnus-always-read-dribble-file (gnus-y-or-n-p - "Gnus auto-save file exists. Do you want to read it? ")) + (if purpose + "Gnus exited on purpose without saving; read auto-save file anyway? " + "Gnus auto-save file exists. Do you want to read it? "))) (setq gnus-dribble-eval-file t))))))) (defun gnus-dribble-eval-file () @@ -869,10 +938,17 @@ ;; Make sure the archive server is available to all and sundry. (when gnus-message-archive-method - (setq gnus-server-alist (delq (assoc "archive" gnus-server-alist) - gnus-server-alist)) - (push (cons "archive" gnus-message-archive-method) - gnus-server-alist)) + (unless (assoc "archive" gnus-server-alist) + (push `("archive" + nnfolder + "archive" + (nnfolder-directory + ,(nnheader-concat message-directory "archive")) + (nnfolder-active-file + ,(nnheader-concat message-directory "archive/active")) + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t)) + gnus-server-alist))) ;; If we don't read the complete active file, we fill in the ;; hashtb here. @@ -880,6 +956,15 @@ (eq gnus-read-active-file 'some)) (gnus-update-active-hashtb-from-killed)) + ;; Validate agent covered methods now that gnus-server-alist has + ;; been initialized. + ;; NOTE: This is here for one purpose only. By validating the + ;; agentized server's, it converts the old 5.10.3, and earlier, + ;; format to the current format. That enables the agent code + ;; within gnus-read-active-file to function correctly. + (if gnus-agent + (gnus-agent-read-servers-validate)) + ;; Read the active file and create `gnus-active-hashtb'. ;; If `gnus-read-active-file' is nil, then we just create an empty ;; hash table. The partial filling out of the hash table will be @@ -908,6 +993,7 @@ ;; See whether we need to read the description file. (when (and (boundp 'gnus-group-line-format) + (stringp gnus-group-line-format) (let ((case-fold-search nil)) (string-match "%[-,0-9]*D" gnus-group-line-format)) (not gnus-description-hashtb) @@ -922,6 +1008,12 @@ gnus-plugged) (gnus-find-new-newsgroups)) + ;; Check and remove bogus newsgroups. + (when (and init gnus-check-bogus-newsgroups + gnus-read-active-file (not level) + (gnus-server-opened gnus-select-method)) + (gnus-check-bogus-newsgroups)) + ;; We might read in new NoCeM messages here. (when (and gnus-use-nocem (not level) @@ -933,12 +1025,22 @@ ;; Find the number of unread articles in each non-dead group. (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) - (gnus-get-unread-articles level)) + (gnus-get-unread-articles level)))) - (when (and init gnus-check-bogus-newsgroups - gnus-read-active-file (not level) - (gnus-server-opened gnus-select-method)) - (gnus-check-bogus-newsgroups)))) +(defun gnus-call-subscribe-functions (method group) + "Call METHOD to subscribe GROUP. +If no function returns `non-nil', call `gnus-subscribe-zombies'." + (unless (cond + ((functionp method) + (funcall method group)) + ((listp method) + (catch 'found + (dolist (func method) + (if (funcall func group) + (throw 'found t))) + nil)) + (t nil)) + (gnus-subscribe-zombies group))) (defun gnus-find-new-newsgroups (&optional arg) "Search for new newsgroups and add them. @@ -992,7 +1094,8 @@ ((eq do-sub 'subscribe) (setq groups (1+ groups)) (gnus-sethash group group gnus-killed-hashtb) - (funcall gnus-subscribe-options-newsgroup-method group)) + (gnus-call-subscribe-functions + gnus-subscribe-options-newsgroup-method group)) ((eq do-sub 'ignore) nil) (t @@ -1000,7 +1103,8 @@ (gnus-sethash group group gnus-killed-hashtb) (if gnus-subscribe-hierarchical-interactive (push group new-newsgroups) - (funcall gnus-subscribe-newsgroup-method group))))))) + (gnus-call-subscribe-functions + gnus-subscribe-newsgroup-method group))))))) gnus-active-hashtb) (when new-newsgroups (gnus-subscribe-hierarchical-interactive new-newsgroups)) @@ -1085,7 +1189,8 @@ ((eq do-sub 'subscribe) (incf groups) (gnus-sethash group group gnus-killed-hashtb) - (funcall gnus-subscribe-options-newsgroup-method group)) + (gnus-call-subscribe-functions + gnus-subscribe-options-newsgroup-method group)) ((eq do-sub 'ignore) nil) (t @@ -1093,7 +1198,8 @@ (gnus-sethash group group gnus-killed-hashtb) (if gnus-subscribe-hierarchical-interactive (push group new-newsgroups) - (funcall gnus-subscribe-newsgroup-method group))))))) + (gnus-call-subscribe-functions + gnus-subscribe-newsgroup-method group))))))) hashtb)) (when new-newsgroups (gnus-subscribe-hierarchical-interactive new-newsgroups))) @@ -1109,10 +1215,8 @@ (catch 'ended ;; First check if any of the following files exist. If they do, ;; it's not the first time the user has used Gnus. - (dolist (file (list gnus-current-startup-file - (concat gnus-current-startup-file ".el") + (dolist (file (list (concat gnus-current-startup-file ".el") (concat gnus-current-startup-file ".eld") - gnus-startup-file (concat gnus-startup-file ".el") (concat gnus-startup-file ".eld"))) (when (file-exists-p file) @@ -1126,21 +1230,22 @@ (let ((groups (or gnus-default-subscribed-newsgroups gnus-backup-default-subscribed-newsgroups)) group) - (when (eq groups t) - ;; If t, we subscribe (or not) all groups as if they were new. - (mapatoms - (lambda (sym) - (when (setq group (symbol-name sym)) - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (gnus-sethash group group gnus-killed-hashtb) - (funcall gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (push group gnus-killed-list)))))) - gnus-active-hashtb) + (if (eq groups t) + ;; If t, we subscribe (or not) all groups as if they were new. + (mapatoms + (lambda (sym) + (when (setq group (symbol-name sym)) + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (gnus-sethash group group gnus-killed-hashtb) + (gnus-call-subscribe-functions + gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (push group gnus-killed-list)))))) + gnus-active-hashtb) (dolist (group groups) ;; Only subscribe the default groups that are activated. (when (gnus-active group) @@ -1148,12 +1253,14 @@ group gnus-level-default-subscribed gnus-level-killed))) (save-excursion (set-buffer gnus-group-buffer) - (gnus-group-make-help-group)) + ;; Don't error if the group already exists. This happens when a + ;; first-time user types 'F'. -- didier + (gnus-group-make-help-group t)) (when gnus-novice-user (gnus-message 7 "`A k' to list killed groups")))))) (defun gnus-subscribe-group (group &optional previous method) - "Subcribe GROUP and put it after PREVIOUS." + "Subscribe GROUP and put it after PREVIOUS." (gnus-group-change-level (if method (list t group gnus-level-default-subscribed nil nil method) @@ -1213,9 +1320,9 @@ ;; it from the newsrc hash table and assoc. (cond ((>= oldlevel gnus-level-zombie) - (if (= oldlevel gnus-level-zombie) - (setq gnus-zombie-list (delete group gnus-zombie-list)) - (setq gnus-killed-list (delete group gnus-killed-list)))) + ;; oldlevel could be wrong. + (setq gnus-zombie-list (delete group gnus-zombie-list)) + (setq gnus-killed-list (delete group gnus-killed-list))) (t (when (and (>= level gnus-level-zombie) entry) @@ -1238,7 +1345,11 @@ (unless (gnus-group-foreign-p group) (if (= level gnus-level-zombie) (push group gnus-zombie-list) - (push group gnus-killed-list)))) + (if (= oldlevel gnus-level-killed) + ;; Remove from active hashtb. + (unintern group gnus-active-hashtb) + ;; Don't add it into killed-list if it was killed. + (push group gnus-killed-list))))) (t ;; If the list is to be entered into the newsrc assoc, and ;; it was killed, we have to create an entry in the newsrc @@ -1306,7 +1417,9 @@ (setq info (pop newsrc) group (gnus-info-group info)) (unless (or (gnus-active group) ; Active - (gnus-info-method info)) ; Foreign + (and (gnus-info-method info) + (not (gnus-secondary-method-p + (gnus-info-method info))))) ; Foreign ;; Found a bogus newsgroup. (push group bogus))) (if confirm @@ -1377,24 +1490,28 @@ (gnus-check-backend-function 'request-scan (car method)) (gnus-request-scan group method)) t) - (condition-case () + (if (or debug-on-error debug-on-quit) (inline (gnus-request-group group dont-check method)) - ;;(error nil) - (quit - (message "Quit activating %s" group) - nil)) - (setq active (gnus-parse-active)) - ;; If there are no articles in the group, the GROUP - ;; command may have responded with the `(0 . 0)'. We - ;; ignore this if we already have an active entry - ;; for the group. - (if (and (zerop (car active)) - (zerop (cdr active)) - (gnus-active group)) - (gnus-active group) - (gnus-set-active group active) - ;; Return the new active info. - active)))) + (condition-case nil + (inline (gnus-request-group group dont-check method)) + ;;(error nil) + (quit + (message "Quit activating %s" group) + nil))) + (unless dont-check + (setq active (gnus-parse-active)) + ;; If there are no articles in the group, the GROUP + ;; command may have responded with the `(0 . 0)'. We + ;; ignore this if we already have an active entry + ;; for the group. + (if (and (zerop (car active)) + (zerop (cdr active)) + (gnus-active group)) + (gnus-active group) + + (gnus-set-active group active) + ;; Return the new active info. + active))))) (defun gnus-get-unread-articles-in-group (info active &optional update) (when active @@ -1411,6 +1528,12 @@ (when (and gnus-use-cache info) (inline (gnus-cache-possibly-alter-active (gnus-info-group info) active))) + + ;; If the agent is enabled, we may have to alter the active info. + (when (and gnus-agent info) + (gnus-agent-possibly-alter-active + (gnus-info-group info) active)) + ;; Modify the list of read articles according to what articles ;; are available; then tally the unread articles and add the ;; number to the group hash table entry. @@ -1477,13 +1600,15 @@ (setq range (cdr range))) (setq num (max 0 (- (cdr active) num))))) ;; Set the number of unread articles. - (when info + (when (and info + (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb)) (setcar (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb) num)) num))) ;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' ;; and compute how many unread articles there are in each group. (defun gnus-get-unread-articles (&optional level) + (setq gnus-server-method-cache nil) (let* ((newsrc (cdr gnus-newsrc-alist)) (level (or level gnus-activate-level (1+ gnus-level-subscribed))) (foreign-level @@ -1495,8 +1620,11 @@ gnus-activate-foreign-newsgroups) (t 0)) level)) - scanned-methods info group active method retrievegroups) - (gnus-message 5 "Checking new news...") + (methods-cache nil) + (type-cache nil) + scanned-methods info group active method retrieve-groups cmethod + method-type) + (gnus-message 6 "Checking new news...") (while newsrc (setq active (gnus-active (setq group (gnus-info-group @@ -1514,17 +1642,30 @@ ;; nil for non-foreign groups that the user has requested not be checked ;; t for unchecked foreign groups or bogus groups, or groups that can't ;; be checked, for one reason or other. - (if (and (setq method (gnus-info-method info)) - (not (inline - (gnus-server-equal - gnus-select-method - (setq method (gnus-server-get-method nil method))))) - (not (gnus-secondary-method-p method))) + (when (setq method (gnus-info-method info)) + (if (setq cmethod (assoc method methods-cache)) + (setq method (cdr cmethod)) + (setq cmethod (inline (gnus-server-get-method nil method))) + (push (cons method cmethod) methods-cache) + (setq method cmethod))) + (when (and method + (not (setq method-type (cdr (assoc method type-cache))))) + (setq method-type + (cond + ((gnus-secondary-method-p method) + 'secondary) + ((inline (gnus-server-equal gnus-select-method method)) + 'primary) + (t + 'foreign))) + (push (cons method method-type) type-cache)) + (if (and method + (eq method-type 'foreign)) ;; These groups are foreign. Check the level. (when (and (<= (gnus-info-level info) foreign-level) - (setq active (gnus-activate-group group 'scan))) + (setq active (gnus-activate-group group 'scan))) ;; Let the Gnus agent save the active file. - (when (and gnus-agent gnus-plugged active) + (when (and gnus-agent active (gnus-online method)) (gnus-agent-save-group-info method (gnus-group-real-name group) active)) (unless (inline (gnus-virtual-group-p group)) @@ -1542,10 +1683,10 @@ (if (gnus-check-backend-function 'retrieve-groups group) ;; if server support gnus-retrieve-groups we push ;; the group onto retrievegroups for later checking - (if (assoc method retrievegroups) - (setcdr (assoc method retrievegroups) - (cons group (cdr (assoc method retrievegroups)))) - (push (list method group) retrievegroups)) + (if (assoc method retrieve-groups) + (setcdr (assoc method retrieve-groups) + (cons group (cdr (assoc method retrieve-groups)))) + (push (list method group) retrieve-groups)) ;; hack: `nnmail-get-new-mail' changes the mail-source depending ;; on the group, so we must perform a scan for every group ;; if the users has any directory mail sources. @@ -1563,8 +1704,8 @@ (setq active (gnus-activate-group group)) (setq active (gnus-activate-group group 'scan)) (push method scanned-methods)) - (when active - (gnus-close-group group)))))) + (when active + (gnus-close-group group)))))) ;; Get the number of unread articles in the group. (cond @@ -1578,33 +1719,33 @@ ;; unread articles and stuff. (gnus-set-active group nil) (let ((tmp (gnus-gethash group gnus-newsrc-hashtb))) - (if tmp (setcar tmp t)))))) + (when tmp + (setcar tmp t)))))) ;; iterate through groups on methods which support gnus-retrieve-groups ;; and fetch a partial active file and use it to find new news. - (while retrievegroups - (let* ((mg (pop retrievegroups)) - (method (or (car mg) gnus-select-method)) - (groups (cdr mg))) + (dolist (rg retrieve-groups) + (let ((method (or (car rg) gnus-select-method)) + (groups (cdr rg))) (when (gnus-check-server method) - ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan nil method)) - (gnus-read-active-file-2 (mapcar (lambda (group) - (gnus-group-real-name group)) - groups) method) - (dolist (group groups) - (cond - ((setq active (gnus-active (gnus-info-group - (setq info (gnus-get-info group))))) - (inline (gnus-get-unread-articles-in-group info active t))) - (t - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (setcar (gnus-gethash group gnus-newsrc-hashtb) t))))))) + ;; Request that the backend scan its incoming messages. + (when (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan nil method)) + (gnus-read-active-file-2 + (mapcar (lambda (group) (gnus-group-real-name group)) groups) + method) + (dolist (group groups) + (cond + ((setq active (gnus-active (gnus-info-group + (setq info (gnus-get-info group))))) + (inline (gnus-get-unread-articles-in-group info active t))) + (t + ;; The group couldn't be reached, so we nix out the number of + ;; unread articles and stuff. + (gnus-set-active group nil) + (setcar (gnus-gethash group gnus-newsrc-hashtb) t))))))) - (gnus-message 5 "Checking new news...done"))) + (gnus-message 6 "Checking new news...done"))) ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys. @@ -1664,8 +1805,82 @@ (setq article (pop articles)) ranges) (push article news))) (when news + ;; Enter this list into the group info. (gnus-info-set-read info (gnus-remove-from-range (gnus-info-read info) (nreverse news))) + + ;; Set the number of unread articles in gnus-newsrc-hashtb. + (gnus-get-unread-articles-in-group info (gnus-active group)) + + ;; Insert the change into the group buffer and the dribble file. + (gnus-group-update-group group t)))) + +(defun gnus-make-ascending-articles-unread (group articles) + "Mark ascending ARTICLES in GROUP as unread." + (let* ((entry (or (gnus-gethash group gnus-newsrc-hashtb) + (gnus-gethash (gnus-group-real-name group) + gnus-newsrc-hashtb))) + (info (nth 2 entry)) + (ranges (gnus-info-read info)) + (r ranges) + modified) + + (while articles + (let ((article (pop articles))) ; get the next article to remove from ranges + (while (let ((range (car ranges))) ; note the current range + (if (atom range) ; single value range + (cond ((not range) + ;; the articles extend past the end of the ranges + ;; OK - I'm done + (setq articles nil)) + ((< range article) + ;; this range preceeds the article. Leave the range unmodified. + (pop ranges) + ranges) + ((= range article) + ;; this range exactly matches the article; REMOVE THE RANGE. + ;; NOTE: When the range being removed is the last range, the list is corrupted by inserting null at its end. + (setcar ranges (cadr ranges)) + (setcdr ranges (cddr ranges)) + (setq modified (if (car ranges) t 'remove-null)) + nil)) + (let ((min (car range)) + (max (cdr range))) + ;; I have a min/max range to consider + (cond ((> min max) ; invalid range introduced by splitter + (setcar ranges (cadr ranges)) + (setcdr ranges (cddr ranges)) + (setq modified (if (car ranges) t 'remove-null)) + ranges) + ((= min max) + ;; replace min/max range with a single-value range + (setcar ranges min) + ranges) + ((< max article) + ;; this range preceeds the article. Leave the range unmodified. + (pop ranges) + ranges) + ((< article min) + ;; this article preceeds the range. Return null to move to the + ;; next article + nil) + (t + ;; this article splits the range into two parts + (setcdr ranges (cons (cons (1+ article) max) (cdr ranges))) + (setcdr range (1- article)) + (setq modified t) + ranges)))))))) + + (when modified + (when (eq modified 'remove-null) + (setq r (delq nil r))) + ;; Enter this list into the group info. + (gnus-info-set-read info r) + + ;; Set the number of unread articles in gnus-newsrc-hashtb. + (gnus-get-unread-articles-in-group info (gnus-active group)) + + ;; Insert the change into the group buffer and the dribble file. (gnus-group-update-group group t)))) ;; Enter all dead groups into the hashtb. @@ -1731,13 +1946,15 @@ ;; Only do each method once, in case the methods appear more ;; than once in this list. (unless (member method methods) - (condition-case () + (if (or debug-on-error debug-on-quit) (gnus-read-active-file-1 method force) - ;; We catch C-g so that we can continue past servers - ;; that do not respond. - (quit - (message "Quit reading the active file") - nil))))))) + (condition-case () + (gnus-read-active-file-1 method force) + ;; We catch C-g so that we can continue past servers + ;; that do not respond. + (quit + (message "Quit reading the active file") + nil)))))))) (defun gnus-read-active-file-1 (method force) (let (where mesg) @@ -1782,7 +1999,7 @@ (gnus-message 5 "%sdone" mesg))))))) (defun gnus-read-active-file-2 (groups method) - "Read an active file for GROUPS in METHOD using gnus-retrieve-groups." + "Read an active file for GROUPS in METHOD using `gnus-retrieve-groups'." (when groups (save-excursion (set-buffer nntp-server-buffer) @@ -1829,7 +2046,7 @@ (insert ?\\))) ;; Let the Gnus agent save the active file. - (when (and gnus-agent real-active gnus-plugged) + (when (and gnus-agent real-active (gnus-online method)) (gnus-agent-save-active method)) ;; If these are groups from a foreign select method, we insert the @@ -1849,7 +2066,7 @@ (goto-char (point-min)) (let (group max min) (while (not (eobp)) - (condition-case err + (condition-case () (progn (narrow-to-region (point) (gnus-point-at-eol)) ;; group gets set to a symbol interned in the hash table @@ -1905,7 +2122,7 @@ ;; Let the Gnus agent save the active file. (if (and gnus-agent real-active - gnus-plugged + (gnus-online method) (gnus-agent-method-p method)) (progn (gnus-agent-save-groups method) @@ -1946,7 +2163,7 @@ "Read startup file. If FORCE is non-nil, the .newsrc file is read." ;; Reset variables that might be defined in the .newsrc.eld file. - (let ((variables gnus-variable-list)) + (let ((variables (remove 'gnus-format-specs gnus-variable-list))) (while variables (set (car variables) nil) (setq variables (cdr variables)))) @@ -2009,28 +2226,48 @@ (nconc (gnus-uncompress-range dormant) (gnus-uncompress-range ticked))))))))) +(defun gnus-load (file) + "Load FILE, but in such a way that read errors can be reported." + (with-temp-buffer + (insert-file-contents file) + (while (not (eobp)) + (condition-case type + (let ((form (read (current-buffer)))) + (eval form)) + (error + (unless (eq (car type) 'end-of-file) + (let ((error (format "Error in %s line %d" file + (count-lines (point-min) (point))))) + (ding) + (unless (gnus-yes-or-no-p (concat error "; continue? ")) + (error "%s" error))))))))) + (defun gnus-read-newsrc-el-file (file) (let ((ding-file (concat file "d"))) - ;; We always, always read the .eld file. - (gnus-message 5 "Reading %s..." ding-file) - (let (gnus-newsrc-assoc) - (condition-case nil - (let ((coding-system-for-read gnus-ding-file-coding-system)) - (load ding-file t t t)) - (error - (ding) - (unless (gnus-yes-or-no-p - (format "Error in %s; continue? " ding-file)) - (error "Error in %s" ding-file)))) - (when gnus-newsrc-assoc - (setq gnus-newsrc-alist gnus-newsrc-assoc))) + (when (file-exists-p ding-file) + ;; We always, always read the .eld file. + (gnus-message 5 "Reading %s..." ding-file) + (let (gnus-newsrc-assoc) + (let ((coding-system-for-read gnus-ding-file-coding-system)) + (gnus-load ding-file)) + ;; Older versions of `gnus-format-specs' are no longer valid + ;; in Oort Gnus 0.01. + (let ((version + (and gnus-newsrc-file-version + (gnus-continuum-version gnus-newsrc-file-version)))) + (when (or (not version) + (< version 5.090009)) + (setq gnus-format-specs gnus-default-format-specs))) + (when gnus-newsrc-assoc + (setq gnus-newsrc-alist gnus-newsrc-assoc)))) (gnus-make-hashtable-from-newsrc-alist) (when (file-newer-than-file-p file ding-file) ;; Old format quick file (gnus-message 5 "Reading %s..." file) ;; The .el file is newer than the .eld file, so we read that one ;; as well. - (gnus-read-old-newsrc-el-file file)))) + (gnus-read-old-newsrc-el-file file))) + (gnus-run-hooks 'gnus-read-newsrc-el-hook)) ;; Parse the old-style quick startup file (defun gnus-read-old-newsrc-el-file (file) @@ -2156,7 +2393,7 @@ reads nil) (if (eolp) ;; If the line ends here, this is clearly a buggy line, so - ;; we put point at the beginning of line and let the cond + ;; we put point a the beginning of line and let the cond ;; below do the error handling. (beginning-of-line) ;; We skip to the beginning of the ranges. @@ -2342,6 +2579,12 @@ (setq gnus-newsrc-options-n out)))) +(eval-and-compile + (defalias 'gnus-long-file-names + (if (fboundp 'msdos-long-file-names) + 'msdos-long-file-names + (lambda () t)))) + (defun gnus-save-newsrc-file (&optional force) "Save .newsrc file." ;; Note: We cannot save .newsrc file if all newsgroups are removed @@ -2368,45 +2611,100 @@ ;; Save .newsrc.eld. (set-buffer (gnus-get-buffer-create " *Gnus-newsrc*")) (make-local-variable 'version-control) - (setq version-control 'never) + (setq version-control gnus-backup-startup-file) (setq buffer-file-name (concat gnus-current-startup-file ".eld")) (setq default-directory (file-name-directory buffer-file-name)) (buffer-disable-undo) (erase-buffer) - (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) - (gnus-gnus-to-quick-newsrc-format) - (gnus-run-hooks 'gnus-save-quick-newsrc-hook) - (let ((coding-system-for-write gnus-ding-file-coding-system)) - (save-buffer)) - (kill-buffer (current-buffer)) + (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) + + (if gnus-save-startup-file-via-temp-buffer + (let ((coding-system-for-write gnus-ding-file-coding-system) + (standard-output (current-buffer))) + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook) + (save-buffer)) + (let ((coding-system-for-write gnus-ding-file-coding-system) + (version-control gnus-backup-startup-file) + (startup-file (concat gnus-current-startup-file ".eld")) + (working-dir (file-name-directory gnus-current-startup-file)) + working-file + (i -1)) + ;; Generate the name of a non-existent file. + (while (progn (setq working-file + (format + (if (and (eq system-type 'ms-dos) + (not (gnus-long-file-names))) + "%s#%d.tm#" ; MSDOS limits files to 8+3 + (if (memq system-type '(vax-vms axp-vms)) + "%s$tmp$%d" + "%s#tmp#%d")) + working-dir (setq i (1+ i)))) + (file-exists-p working-file))) + + (unwind-protect + (progn + (gnus-with-output-to-file working-file + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) + + ;; These bindings will mislead the current buffer + ;; into thinking that it is visiting the startup + ;; file. + (let ((buffer-backed-up nil) + (buffer-file-name startup-file) + (file-precious-flag t) + (setmodes (file-modes startup-file))) + ;; Backup the current version of the startup file. + (backup-buffer) + + ;; Replace the existing startup file with the temp file. + (rename-file working-file startup-file t) + (set-file-modes startup-file setmodes))) + (condition-case nil + (delete-file working-file) + (file-error nil))))) + + (gnus-kill-buffer (current-buffer)) (gnus-message 5 "Saving %s.eld...done" gnus-current-startup-file)) (gnus-dribble-delete-file) (gnus-group-set-mode-line))))) -(defun gnus-gnus-to-quick-newsrc-format () - "Insert Gnus variables such as gnus-newsrc-alist in lisp format." - (let ((print-quoted t) - (print-escape-newlines t)) +(defun gnus-gnus-to-quick-newsrc-format (&optional minimal name &rest specific-variables) + "Print Gnus variables such as `gnus-newsrc-alist' in Lisp format." + (princ ";; -*- emacs-lisp -*-\n") + (if name + (princ (format ";; %s\n" name)) + (princ ";; Gnus startup file.\n")) - (insert ";; -*- emacs-lisp -*-\n") - (insert ";; Gnus startup file.\n") - (insert "\ + (unless minimal + (princ "\ ;; Never delete this file -- if you want to force Gnus to read the ;; .newsrc file (if you have one), touch .newsrc instead.\n") - (insert "(setq gnus-newsrc-file-version " - (prin1-to-string gnus-version) ")\n") - (let* ((gnus-killed-list + (princ "(setq gnus-newsrc-file-version ") + (princ (gnus-prin1-to-string gnus-version)) + (princ ")\n")) + + (let* ((print-quoted t) + (print-readably t) + (print-escape-multibyte nil) + (print-escape-nonascii t) + (print-length nil) + (print-level nil) + (print-escape-newlines t) + (gnus-killed-list (if (and gnus-save-killed-list (stringp gnus-save-killed-list)) (gnus-strip-killed-list) gnus-killed-list)) (variables - (if gnus-save-killed-list gnus-variable-list - ;; Remove the `gnus-killed-list' from the list of variables - ;; to be saved, if required. - (delq 'gnus-killed-list (copy-sequence gnus-variable-list)))) + (or specific-variables + (if gnus-save-killed-list gnus-variable-list + ;; Remove the `gnus-killed-list' from the list of variables + ;; to be saved, if required. + (delq 'gnus-killed-list (copy-sequence gnus-variable-list))))) ;; Peel off the "dummy" group. (gnus-newsrc-alist (cdr gnus-newsrc-alist)) variable) @@ -2414,9 +2712,11 @@ (while variables (when (and (boundp (setq variable (pop variables))) (symbol-value variable)) - (insert "(setq " (symbol-name variable) " '") - (gnus-prin1 (symbol-value variable)) - (insert ")\n")))))) + (princ "(setq ") + (princ (symbol-name variable)) + (princ " '") + (prin1 (symbol-value variable)) + (princ ")\n"))))) (defun gnus-strip-killed-list () "Return the killed list minus the groups that match `gnus-save-killed-list'." @@ -2624,16 +2924,16 @@ (skip-chars-forward " \t") ;; ... which leads to this line being effectively ignored. (when (symbolp group) - (let ((str (buffer-substring - (point) (progn (end-of-line) (point)))) - (coding - (and (or (featurep 'xemacs) - (and (boundp 'enable-multibyte-characters) - enable-multibyte-characters)) - (fboundp 'gnus-mule-get-coding-system) - (gnus-mule-get-coding-system (symbol-name group))))) - (when coding - (setq str (mm-decode-coding-string str (car coding)))) + (let* ((str (buffer-substring + (point) (progn (end-of-line) (point)))) + (name (symbol-name group)) + (charset + (or (gnus-group-name-charset method name) + (gnus-parameter-charset name) + gnus-default-charset))) + ;; Fixme: Don't decode in unibyte mode. + (when (and str charset (featurep 'mule)) + (setq str (mm-decode-coding-string str charset))) (set group str))) (forward-line 1)))) (gnus-message 5 "Reading descriptions file...done") @@ -2650,7 +2950,7 @@ ;;;###autoload (defun gnus-declare-backend (name &rest abilities) - "Declare backend NAME with ABILITIES as a Gnus backend." + "Declare back end NAME with ABILITIES as a Gnus back end." (setq gnus-valid-select-methods (nconc gnus-valid-select-methods (list (apply 'list name abilities)))) @@ -2665,7 +2965,31 @@ (file-name-as-directory (expand-file-name gnus-default-directory)) default-directory))) +(eval-and-compile +(defalias 'gnus-display-time-event-handler + (if (gnus-boundp 'display-time-timer) + 'display-time-event-handler + (lambda () "Does nothing as `display-time-timer' is not bound. +Would otherwise be an alias for `display-time-event-handler'." nil)))) + +;;;###autoload +(defun gnus-fixup-nnimap-unread-after-getting-new-news () + (let (server group info) + (mapatoms + (lambda (sym) + (when (and (setq group (symbol-name sym)) + (gnus-group-entry group) + (setq info (symbol-value sym))) + (gnus-sethash group (cons (nth 2 info) (cdr (gnus-group-entry group))) + gnus-newsrc-hashtb))) + (if (boundp 'nnimap-mailbox-info) + (symbol-value 'nnimap-mailbox-info) + (make-vector 1 0))))) + + (provide 'gnus-start) ;;; arch-tag: f4584a22-b7b7-4853-abfc-a637329af5d2 ;;; gnus-start.el ends here + +
--- a/lisp/gnus/gnus-sum.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-sum.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-sum.el --- summary mode commands for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -26,7 +26,9 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (defvar tool-bar-map)) (require 'gnus) (require 'gnus-group) @@ -36,12 +38,19 @@ (require 'gnus-undo) (require 'gnus-util) (require 'mm-decode) -;; Recursive :-(. -;; (require 'gnus-art) (require 'nnoo) + (autoload 'gnus-summary-limit-include-cached "gnus-cache" nil t) (autoload 'gnus-cache-write-active "gnus-cache") +(autoload 'gnus-mailing-list-insinuate "gnus-ml" nil t) +(autoload 'turn-on-gnus-mailing-list-mode "gnus-ml" nil t) (autoload 'mm-uu-dissect "mm-uu") +(autoload 'gnus-article-outlook-deuglify-article "deuglify" + "Deuglify broken Outlook (Express) articles and redisplay." + t) +(autoload 'gnus-article-outlook-unwrap-lines "deuglify" nil t) +(autoload 'gnus-article-outlook-repair-attribution "deuglify" nil t) +(autoload 'gnus-article-outlook-rearrange-citation "deuglify" nil t) (defcustom gnus-kill-summary-on-exit t "*If non-nil, kill the summary buffer when you exit from it. @@ -105,6 +114,11 @@ (const adopt) (const empty))) +(defcustom gnus-summary-make-false-root-always nil + "Always make a false dummy root." + :group 'gnus-thread + :type 'boolean) + (defcustom gnus-summary-gather-exclude-subject "^ *$\\|^(none)$" "*A regexp to match subjects to be excluded from loose thread gathering. As loose thread gathering is done on subjects only, that means that @@ -132,13 +146,14 @@ "List of functions taking a string argument that simplify subjects. The functions are applied recursively. -Useful functions to put in this list include: `gnus-simplify-subject-re', -`gnus-simplify-subject-fuzzy' and `gnus-simplify-whitespace'." +Useful functions to put in this list include: +`gnus-simplify-subject-re', `gnus-simplify-subject-fuzzy', +`gnus-simplify-whitespace', and `gnus-simplify-all-whitespace'." :group 'gnus-thread :type '(repeat function)) (defcustom gnus-simplify-ignored-prefixes nil - "*Regexp, matches for which are removed from subject lines when simplifying fuzzily." + "*Remove matches for this regexp from subject lines when simplifying fuzzily." :group 'gnus-thread :type '(choice (const :tag "off" nil) regexp)) @@ -197,6 +212,20 @@ :type '(choice (const :tag "disable") integer)) +(defcustom gnus-summary-default-high-score 0 + "*Default threshold for a high scored article. +An article will be highlighted as high scored if its score is greater +than this score." + :group 'gnus-score-default + :type 'integer) + +(defcustom gnus-summary-default-low-score 0 + "*Default threshold for a low scored article. +An article will be highlighted as low scored if its score is smaller +than this score." + :group 'gnus-score-default + :type 'integer) + (defcustom gnus-summary-zcore-fuzz 0 "*Fuzziness factor for the zcore in the summary buffer. Articles with scores closer than this to `gnus-summary-default-score' @@ -219,11 +248,17 @@ (defcustom gnus-thread-hide-subtree nil "*If non-nil, hide all threads initially. +This can be a predicate specifier which says which threads to hide. If threads are hidden, you have to run the command `gnus-summary-show-thread' by hand or use `gnus-select-article-hook' to expose hidden threads." :group 'gnus-thread - :type 'boolean) + :type '(radio (sexp :format "Non-nil\n" + :match (lambda (widget value) + (not (or (consp value) (functionp value)))) + :value t) + (const nil) + (sexp :tag "Predicate specifier" :size 0))) (defcustom gnus-thread-hide-killed t "*If non-nil, hide killed threads automatically." @@ -262,36 +297,44 @@ :type 'boolean) (defcustom gnus-auto-select-first t - "*If nil, don't select the first unread article when entering a group. -If this variable is `best', select the highest-scored unread article -in the group. If t, select the first unread article. - -This variable can also be a function to place point on a likely -subject line. Useful values include `gnus-summary-first-unread-subject', -`gnus-summary-first-unread-article' and -`gnus-summary-best-unread-article'. - -If you want to prevent automatic selection of the first unread article -in some newsgroups, set the variable to nil in -`gnus-select-group-hook'." + "*If non-nil, select the article under point. +Which article this is is controlled by the `gnus-auto-select-subject' +variable. + +If you want to prevent automatic selection of articles in some +newsgroups, set the variable to nil in `gnus-select-group-hook'." :group 'gnus-group-select :type '(choice (const :tag "none" nil) - (const best) - (sexp :menu-tag "first" t) - (function-item gnus-summary-first-unread-subject) - (function-item gnus-summary-first-unread-article) - (function-item gnus-summary-best-unread-article))) + (sexp :menu-tag "first" t))) + +(defcustom gnus-auto-select-subject 'unread + "*Says what subject to place under point when entering a group. + +This variable can either be the symbols `first' (place point on the +first subject), `unread' (place point on the subject line of the first +unread article), `best' (place point on the subject line of the +higest-scored article), `unseen' (place point on the subject line of +the first unseen article), 'unseen-or-unread' (place point on the subject +line of the first unseen article or, if all article have been seen, on the +subject line of the first unread article), or a function to be called to +place point on some subject line." + :group 'gnus-group-select + :type '(choice (const best) + (const unread) + (const first) + (const unseen) + (const unseen-or-unread))) (defcustom gnus-auto-select-next t "*If non-nil, offer to go to the next group from the end of the previous. If the value is t and the next newsgroup is empty, Gnus will exit -summary mode and go back to group mode. If the value is neither nil -nor t, Gnus will select the following unread newsgroup. In +summary mode and go back to group mode. If the value is neither nil +nor t, Gnus will select the following unread newsgroup. In particular, if the value is the symbol `quietly', the next unread newsgroup will be selected without any confirmation, and if it is `almost-quietly', the next group will be selected without any confirmation if you are located on the last article in the group. -Finally, if this variable is `slightly-quietly', the `Z n' command +Finally, if this variable is `slightly-quietly', the `\\<gnus-summary-mode-map>\\[gnus-summary-catchup-and-goto-next-group]' command will go to the next group without confirmation." :group 'gnus-summary-maneuvering :type '(choice (const :tag "off" nil) @@ -307,6 +350,23 @@ :group 'gnus-summary-maneuvering :type 'boolean) +(defcustom gnus-auto-goto-ignores 'unfetched + "*Says how to handle unfetched articles when maneuvering. + +This variable can either be the symbols nil (maneuver to any +article), `undownloaded' (maneuvering while unplugged ignores articles +that have not been fetched), `always-undownloaded' (maneuvering always +ignores articles that have not been fetched), `unfetched' (maneuvering +ignores articles whose headers have not been fetched). + +NOTE: The list of unfetched articles will always be nil when plugged +and, when unplugged, a subset of the undownloaded article list." + :group 'gnus-summary-maneuvering + :type '(choice (const :tag "None" nil) + (const :tag "Undownloaded when unplugged" undownloaded) + (const :tag "Undownloaded" always-undownloaded) + (const :tag "Unfetched" unfetched))) + (defcustom gnus-summary-check-current nil "*If non-nil, consider the current article when moving. The \"unread\" movement commands will stay on the same line if the @@ -324,6 +384,9 @@ (integer :tag "height") (sexp :menu-tag "both" t))) +(defvar gnus-auto-center-group t + "*If non-nil, always center the group buffer.") + (defcustom gnus-show-all-headers nil "*If non-nil, don't hide any headers." :group 'gnus-article-hiding @@ -350,13 +413,15 @@ (defcustom gnus-move-split-methods nil "*Variable used to suggest where articles are to be moved to. -It uses the same syntax as the `gnus-split-methods' variable." +It uses the same syntax as the `gnus-split-methods' variable. +However, whereas `gnus-split-methods' specifies file names as targets, +this variable specifies group names." :group 'gnus-summary-mail :type '(repeat (choice (list :value (fun) function) (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) -(defcustom gnus-unread-mark ? ;Whitespace +(defcustom gnus-unread-mark ? ;Whitespace "*Mark used for unread articles." :group 'gnus-summary-marks :type 'character) @@ -391,8 +456,13 @@ :group 'gnus-summary-marks :type 'character) +(defcustom gnus-spam-mark ?$ + "*Mark used for spam articles." + :group 'gnus-summary-marks + :type 'character) + (defcustom gnus-souped-mark ?F - "*Mark used for killed articles." + "*Mark used for souped articles." :group 'gnus-summary-marks :type 'character) @@ -416,13 +486,33 @@ :group 'gnus-summary-marks :type 'character) +(defcustom gnus-forwarded-mark ?F + "*Mark used for articles that have been forwarded." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-recent-mark ?N + "*Mark used for articles that are recent." + :group 'gnus-summary-marks + :type 'character) + (defcustom gnus-cached-mark ?* "*Mark used for articles that are in the cache." :group 'gnus-summary-marks :type 'character) (defcustom gnus-saved-mark ?S - "*Mark used for articles that have been saved to." + "*Mark used for articles that have been saved." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-unseen-mark ?. + "*Mark used for articles that haven't been seen." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-no-mark ? ;Whitespace + "*Mark used for articles that have no other secondary mark." :group 'gnus-summary-marks :type 'character) @@ -446,11 +536,16 @@ :group 'gnus-summary-marks :type 'character) -(defcustom gnus-undownloaded-mark ?@ +(defcustom gnus-undownloaded-mark ?- "*Mark used for articles that weren't downloaded." :group 'gnus-summary-marks :type 'character) +(defcustom gnus-downloaded-mark ?+ + "*Mark used for articles that were downloaded." + :group 'gnus-summary-marks + :type 'character) + (defcustom gnus-downloadable-mark ?% "*Mark used for articles that are to be downloaded." :group 'gnus-summary-marks @@ -471,7 +566,7 @@ :group 'gnus-summary-marks :type 'character) -(defcustom gnus-empty-thread-mark ? ;Whitespace +(defcustom gnus-empty-thread-mark ? ;Whitespace "*There is no thread under the article." :group 'gnus-summary-marks :type 'character) @@ -523,12 +618,16 @@ :type 'boolean) (defcustom gnus-summary-dummy-line-format - " %(: :%) %S\n" + " %(: :%) %S\n" "*The format specification for the dummy roots in the summary buffer. It works along the same lines as a normal formatting string, with some simple extensions. -%S The subject" +%S The subject + +General format specifiers can also be used. +See `(gnus)Formatting Variables'." + :link '(custom-manual "(gnus)Formatting Variables") :group 'gnus-threading :type 'string) @@ -574,29 +673,55 @@ (defcustom gnus-article-sort-functions '(gnus-article-sort-by-number) "*List of functions used for sorting articles in the summary buffer. -This variable is only used when not using a threaded display." + +Each function takes two articles and returns non-nil if the first +article should be sorted before the other. If you use more than one +function, the primary sort function should be the last. You should +probably always include `gnus-article-sort-by-number' in the list of +sorting functions -- preferably first. Also note that sorting by date +is often much slower than sorting by number, and the sorting order is +very similar. (Sorting by date means sorting by the time the message +was sent, sorting by number means sorting by arrival time.) + +Ready-made functions include `gnus-article-sort-by-number', +`gnus-article-sort-by-author', `gnus-article-sort-by-subject', +`gnus-article-sort-by-date', `gnus-article-sort-by-random' +and `gnus-article-sort-by-score'. + +When threading is turned on, the variable `gnus-thread-sort-functions' +controls how articles are sorted." :group 'gnus-summary-sort :type '(repeat (choice (function-item gnus-article-sort-by-number) (function-item gnus-article-sort-by-author) (function-item gnus-article-sort-by-subject) (function-item gnus-article-sort-by-date) (function-item gnus-article-sort-by-score) + (function-item gnus-article-sort-by-random) (function :tag "other")))) (defcustom gnus-thread-sort-functions '(gnus-thread-sort-by-number) "*List of functions used for sorting threads in the summary buffer. By default, threads are sorted by article number. -Each function takes two threads and return non-nil if the first thread -should be sorted before the other. If you use more than one function, -the primary sort function should be the last. You should probably -always include `gnus-thread-sort-by-number' in the list of sorting -functions -- preferably first. +Each function takes two threads and returns non-nil if the first +thread should be sorted before the other. If you use more than one +function, the primary sort function should be the last. You should +probably always include `gnus-thread-sort-by-number' in the list of +sorting functions -- preferably first. Also note that sorting by date +is often much slower than sorting by number, and the sorting order is +very similar. (Sorting by date means sorting by the time the message +was sent, sorting by number means sorting by arrival time.) Ready-made functions include `gnus-thread-sort-by-number', `gnus-thread-sort-by-author', `gnus-thread-sort-by-subject', -`gnus-thread-sort-by-date', `gnus-thread-sort-by-score' and -`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function')." +`gnus-thread-sort-by-date', `gnus-thread-sort-by-score', +`gnus-thread-sort-by-most-recent-number', +`gnus-thread-sort-by-most-recent-date', +`gnus-thread-sort-by-random', and +`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function'). + +When threading is turned off, the variable +`gnus-article-sort-functions' controls how articles are sorted." :group 'gnus-summary-sort :type '(repeat (choice (function-item gnus-thread-sort-by-number) (function-item gnus-thread-sort-by-author) @@ -604,6 +729,7 @@ (function-item gnus-thread-sort-by-date) (function-item gnus-thread-sort-by-score) (function-item gnus-thread-sort-by-total-score) + (function-item gnus-thread-sort-by-random) (function :tag "other")))) (defcustom gnus-thread-score-function '+ @@ -637,10 +763,17 @@ (defcustom gnus-summary-mode-hook nil "*A hook for Gnus summary mode. This hook is run before any variables are set in the summary buffer." - :options '(turn-on-gnus-mailing-list-mode) + :options '(turn-on-gnus-mailing-list-mode gnus-pick-mode) :group 'gnus-summary-various :type 'hook) +;; Extracted from gnus-xmas-redefine in order to preserve user settings +(when (featurep 'xemacs) + (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) + (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) + (add-hook 'gnus-summary-mode-hook + 'gnus-xmas-switch-horizontal-scrollbar-off)) + (defcustom gnus-summary-menu-hook nil "*Hook run after the creation of the summary mode menu." :group 'gnus-summary-visual @@ -677,21 +810,21 @@ `gnus-summary-next-same-subject' command does, you can use the following hook: - (setq gnus-select-group-hook - (list - (lambda () - (mapcar (lambda (header) - (mail-header-set-subject - header - (gnus-simplify-subject - (mail-header-subject header) 're-only))) - gnus-newsgroup-headers))))" + (add-hook gnus-select-group-hook + (lambda () + (mapcar (lambda (header) + (mail-header-set-subject + header + (gnus-simplify-subject + (mail-header-subject header) 're-only))) + gnus-newsgroup-headers)))" :group 'gnus-group-select :type 'hook) (defcustom gnus-select-article-hook nil "*A hook called when an article is selected." :group 'gnus-summary-choose + :options '(gnus-agent-fetch-selected-article) :type 'hook) (defcustom gnus-visual-mark-article-hook @@ -741,64 +874,90 @@ :group 'gnus-summary :type 'hook) +(defcustom gnus-summary-article-move-hook nil + "*A hook called after an article is moved, copied, respooled, or crossposted." + :group 'gnus-summary + :type 'hook) + +(defcustom gnus-summary-article-delete-hook nil + "*A hook called after an article is deleted." + :group 'gnus-summary + :type 'hook) + +(defcustom gnus-summary-article-expire-hook nil + "*A hook called after an article is expired." + :group 'gnus-summary + :type 'hook) + +(defcustom gnus-summary-display-arrow + (and (fboundp 'display-graphic-p) + (display-graphic-p)) + "*If non-nil, display an arrow highlighting the current article." + :version "21.1" + :group 'gnus-summary + :type 'boolean) + (defcustom gnus-summary-selected-face 'gnus-summary-selected-face "Face used for highlighting the current article in the summary buffer." :group 'gnus-summary-visual :type 'face) +(defvar gnus-tmp-downloaded nil) + (defcustom gnus-summary-highlight - '(((= mark gnus-canceled-mark) + '(((eq mark gnus-canceled-mark) . gnus-summary-cancelled-face) - ((and (> score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) + ((and uncached (> score default-high)) + . gnus-summary-high-undownloaded-face) + ((and uncached (< score default-low)) + . gnus-summary-low-undownloaded-face) + (uncached + . gnus-summary-normal-undownloaded-face) + ((and (> score default-high) + (or (eq mark gnus-dormant-mark) + (eq mark gnus-ticked-mark))) . gnus-summary-high-ticked-face) - ((and (< score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) + ((and (< score default-low) + (or (eq mark gnus-dormant-mark) + (eq mark gnus-ticked-mark))) . gnus-summary-low-ticked-face) - ((or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark)) + ((or (eq mark gnus-dormant-mark) + (eq mark gnus-ticked-mark)) . gnus-summary-normal-ticked-face) - ((and (> score default) (= mark gnus-ancient-mark)) + ((and (> score default-high) (eq mark gnus-ancient-mark)) . gnus-summary-high-ancient-face) - ((and (< score default) (= mark gnus-ancient-mark)) + ((and (< score default-low) (eq mark gnus-ancient-mark)) . gnus-summary-low-ancient-face) - ((= mark gnus-ancient-mark) + ((eq mark gnus-ancient-mark) . gnus-summary-normal-ancient-face) - ((and (> score default) (= mark gnus-unread-mark)) + ((and (> score default-high) (eq mark gnus-unread-mark)) . gnus-summary-high-unread-face) - ((and (< score default) (= mark gnus-unread-mark)) + ((and (< score default-low) (eq mark gnus-unread-mark)) . gnus-summary-low-unread-face) - ((= mark gnus-unread-mark) + ((eq mark gnus-unread-mark) . gnus-summary-normal-unread-face) - ((and (> score default) (memq mark (list gnus-downloadable-mark - gnus-undownloaded-mark))) - . gnus-summary-high-unread-face) - ((and (< score default) (memq mark (list gnus-downloadable-mark - gnus-undownloaded-mark))) - . gnus-summary-low-unread-face) - ((memq mark (list gnus-downloadable-mark gnus-undownloaded-mark)) - . gnus-summary-normal-unread-face) - ((> score default) + ((> score default-high) . gnus-summary-high-read-face) - ((< score default) + ((< score default-low) . gnus-summary-low-read-face) (t . gnus-summary-normal-read-face)) "*Controls the highlighting of summary buffer lines. -A list of (FORM . FACE) pairs. When deciding how a particular summary -line should be displayed, each form is evaluated. The content of the -face field after the first true form is used. You can change how those -summary lines are displayed, by editing the face field. +A list of (FORM . FACE) pairs. When deciding how a a particular +summary line should be displayed, each form is evaluated. The content +of the face field after the first true form is used. You can change +how those summary lines are displayed, by editing the face field. You can use the following variables in the FORM field. -score: The articles score -default: The default article score. -below: The score below which articles are automatically marked as read. -mark: The articles mark." +score: The article's score +default: The default article score. +default-high: The default score for high scored articles. +default-low: The default score for low scored articles. +below: The score below which articles are automatically marked as read. +mark: The article's mark. +uncached: Non-nil if the article is uncached." :group 'gnus-summary-visual :type '(repeat (cons (sexp :tag "Form" nil) face))) @@ -814,7 +973,7 @@ (defvar gnus-decode-encoded-word-function 'mail-decode-encoded-word-string "Variable that says which function should be used to decode a string with encoded words.") -(defcustom gnus-extra-headers nil +(defcustom gnus-extra-headers '(To Newsgroups) "*Extra headers to parse." :version "21.1" :group 'gnus-summary @@ -827,25 +986,6 @@ :group 'gnus-summary :type 'regexp) -(defcustom gnus-group-charset-alist - '(("^hk\\>\\|^tw\\>\\|\\<big5\\>" cn-big5) - ("^cn\\>\\|\\<chinese\\>" cn-gb-2312) - ("^fj\\>\\|^japan\\>" iso-2022-jp-2) - ("^tnn\\>\\|^pin\\>\\|^sci.lang.japan" iso-2022-7bit) - ("^relcom\\>" koi8-r) - ("^fido7\\>" koi8-r) - ("^\\(cz\\|hun\\|pl\\|sk\\|hr\\)\\>" iso-8859-2) - ("^israel\\>" iso-8859-1) - ("^han\\>" euc-kr) - ("^alt.chinese.text.big5\\>" chinese-big5) - ("^soc.culture.vietnamese\\>" vietnamese-viqr) - ("^\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1) - (".*" iso-8859-1)) - "Alist of regexps (to match group names) and default charsets to be used when reading." - :type '(repeat (list (regexp :tag "Group") - (symbol :tag "Charset"))) - :group 'gnus-charset) - (defcustom gnus-newsgroup-ignored-charsets '(unknown-8bit x-unknown) "List of charsets that should be ignored. When these charsets are used in the \"charset\" parameter, the @@ -854,14 +994,29 @@ :type '(repeat symbol) :group 'gnus-charset) -(defcustom gnus-group-ignored-charsets-alist - '(("alt\\.chinese\\.text" iso-8859-1)) - "Alist of regexps (to match group names) and charsets that should be ignored. +(gnus-define-group-parameter + ignored-charsets + :type list + :function-document + "Return the ignored charsets of GROUP." + :variable gnus-group-ignored-charsets-alist + :variable-default + '(("alt\\.chinese\\.text" iso-8859-1)) + :variable-document + "Alist of regexps (to match group names) and charsets that should be ignored. When these charsets are used in the \"charset\" parameter, the default charset will be used instead." - :type '(repeat (cons (regexp :tag "Group") - (repeat symbol))) - :group 'gnus-charset) + :variable-group gnus-charset + :variable-type '(repeat (cons (regexp :tag "Group") + (repeat symbol))) + :parameter-type '(choice :tag "Ignored charsets" + :value nil + (repeat (symbol))) + :parameter-document "\ +List of charsets that should be ignored. + +When these charsets are used in the \"charset\" parameter, the +default charset will be used instead.") (defcustom gnus-group-highlight-words-alist nil "Alist of group regexps and highlight regexps. @@ -904,20 +1059,54 @@ integer)) (defcustom gnus-summary-save-parts-default-mime "image/.*" - "*A regexp to match MIME parts when saving multiple parts of a message -with gnus-summary-save-parts (X m). This regexp will be used by default -when prompting the user for which type of files to save." + "*A regexp to match MIME parts when saving multiple parts of a +message with `gnus-summary-save-parts' (\\<gnus-summary-mode-map>\\[gnus-summary-save-parts]). +This regexp will be used by default when prompting the user for which +type of files to save." :group 'gnus-summary :type 'regexp) +(defcustom gnus-read-all-available-headers nil + "Whether Gnus should parse all headers made available to it. +This is mostly relevant for slow back ends where the user may +wish to widen the summary buffer to include all headers +that were fetched. Say, for nnultimate groups." + :group 'gnus-summary + :type '(choice boolean regexp)) + +(defcustom gnus-summary-muttprint-program "muttprint" + "Command (and optional arguments) used to run Muttprint." + :version "21.3" + :group 'gnus-summary + :type 'string) + +(defcustom gnus-article-loose-mime nil + "If non-nil, don't require MIME-Version header. +Some brain-damaged MUA/MTA, e.g. Lotus Domino 5.0.6 clients, does not +supply the MIME-Version header or deliberately strip it From the mail. +Set it to non-nil, Gnus will treat some articles as MIME even if +the MIME-Version header is missed." + :version "21.3" + :type 'boolean + :group 'gnus-article-mime) + +(defcustom gnus-article-emulate-mime t + "If non-nil, use MIME emulation for uuencode and the like. +This means that Gnus will search message bodies for text that look +like uuencoded bits, yEncoded bits, and so on, and present that using +the normal Gnus MIME machinery." + :type 'boolean + :group 'gnus-article-mime) ;;; Internal variables +(defvar gnus-summary-display-cache nil) (defvar gnus-article-mime-handles nil) (defvar gnus-article-decoded-p nil) +(defvar gnus-article-charset nil) +(defvar gnus-article-ignored-charsets nil) (defvar gnus-scores-exclude-files nil) (defvar gnus-page-broken nil) -(defvar gnus-inhibit-mime-unbuttonizing nil) (defvar gnus-original-article nil) (defvar gnus-article-internal-prepare-hook nil) @@ -929,7 +1118,7 @@ "Function called to sort the articles within a thread after it has been gathered together.") (defvar gnus-summary-save-parts-type-history nil) -(defvar gnus-summary-save-parts-last-directory nil) +(defvar gnus-summary-save-parts-last-directory mm-default-directory) ;; Avoid highlighting in kill files. (defvar gnus-summary-inhibit-highlight nil) @@ -940,6 +1129,7 @@ (defvar gnus-current-move-group nil) (defvar gnus-current-copy-group nil) (defvar gnus-current-crosspost-group nil) +(defvar gnus-newsgroup-display nil) (defvar gnus-newsgroup-dependencies nil) (defvar gnus-newsgroup-adaptive nil) @@ -964,7 +1154,9 @@ (?M ,(macroexpand '(mail-header-id gnus-tmp-header)) ?s) (?r ,(macroexpand '(mail-header-references gnus-tmp-header)) ?s) (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) - (?L gnus-tmp-lines ?d) + (?k (gnus-summary-line-message-size gnus-tmp-header) ?s) + (?L gnus-tmp-lines ?s) + (?O gnus-tmp-downloaded ?c) (?I gnus-tmp-indentation ?s) (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) (?R gnus-tmp-replied ?c) @@ -977,7 +1169,8 @@ (?l (bbb-grouplens-score gnus-tmp-header) ?s) (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) (?U gnus-tmp-unread ?c) - (?f (gnus-summary-from-or-to-or-newsgroups gnus-tmp-header) ?s) + (?f (gnus-summary-from-or-to-or-newsgroups gnus-tmp-header gnus-tmp-from) + ?s) (?t (gnus-summary-number-of-articles-in-thread (and (boundp 'thread) (car thread)) gnus-tmp-level) ?d) @@ -985,7 +1178,10 @@ (and (boundp 'thread) (car thread)) gnus-tmp-level t) ?c) (?u gnus-tmp-user-defined ?s) - (?P (gnus-pick-line-number) ?d)) + (?P (gnus-pick-line-number) ?d) + (?B gnus-tmp-thread-tree-header-string ?s) + (user-date (gnus-user-date + ,(macroexpand '(mail-header-date gnus-tmp-header))) ?s)) "An alist of format specifications that can appear in summary lines. These are paired with what variables they correspond with, along with the type of the variable (string, integer, character, etc).") @@ -1008,6 +1204,7 @@ (?u gnus-tmp-user-defined ?s) (?d (length gnus-newsgroup-dormant) ?d) (?t (length gnus-newsgroup-marked) ?d) + (?h (length gnus-newsgroup-spam-marked) ?d) (?r (length gnus-newsgroup-reads) ?d) (?z (gnus-summary-article-score gnus-tmp-article-number) ?d) (?E gnus-newsgroup-expunged-tally ?d) @@ -1019,6 +1216,8 @@ (defvar gnus-last-shell-command nil "Default shell command on article.") +(defvar gnus-newsgroup-agentized nil + "Locally bound in each summary buffer to indicate whether the server has been agentized.") (defvar gnus-newsgroup-begin nil) (defvar gnus-newsgroup-end nil) (defvar gnus-newsgroup-last-rmail nil) @@ -1032,12 +1231,13 @@ (defvar gnus-newsgroup-data-reverse nil) (defvar gnus-newsgroup-limit nil) (defvar gnus-newsgroup-limits nil) +(defvar gnus-summary-use-undownloaded-faces nil) (defvar gnus-newsgroup-unreads nil - "List of unread articles in the current newsgroup.") + "Sorted list of unread articles in the current newsgroup.") (defvar gnus-newsgroup-unselected nil - "List of unselected unread articles in the current newsgroup.") + "Sorted list of unselected unread articles in the current newsgroup.") (defvar gnus-newsgroup-reads nil "Alist of read articles and article marks in the current newsgroup.") @@ -1045,13 +1245,16 @@ (defvar gnus-newsgroup-expunged-tally nil) (defvar gnus-newsgroup-marked nil - "List of ticked articles in the current newsgroup (a subset of unread art).") + "Sorted list of ticked articles in the current newsgroup (a subset of unread art).") + +(defvar gnus-newsgroup-spam-marked nil + "List of ranges of articles that have been marked as spam.") (defvar gnus-newsgroup-killed nil "List of ranges of articles that have been through the scoring process.") (defvar gnus-newsgroup-cached nil - "List of articles that come from the article cache.") + "Sorted list of articles that come from the article cache.") (defvar gnus-newsgroup-saved nil "List of articles that have been saved.") @@ -1061,17 +1264,29 @@ (defvar gnus-newsgroup-replied nil "List of articles that have been replied to in the current newsgroup.") +(defvar gnus-newsgroup-forwarded nil + "List of articles that have been forwarded in the current newsgroup.") + +(defvar gnus-newsgroup-recent nil + "List of articles that have are recent in the current newsgroup.") + (defvar gnus-newsgroup-expirable nil - "List of articles in the current newsgroup that can be expired.") + "Sorted list of articles in the current newsgroup that can be expired.") (defvar gnus-newsgroup-processable nil "List of articles in the current newsgroup that can be processed.") (defvar gnus-newsgroup-downloadable nil - "List of articles in the current newsgroup that can be processed.") + "Sorted list of articles in the current newsgroup that can be processed.") + +(defvar gnus-newsgroup-unfetched nil + "Sorted list of articles in the current newsgroup whose headers have +not been fetched into the agent. + +This list will always be a subset of gnus-newsgroup-undownloaded.") (defvar gnus-newsgroup-undownloaded nil - "List of articles in the current newsgroup that haven't been downloaded..") + "List of articles in the current newsgroup that haven't been downloaded.") (defvar gnus-newsgroup-unsendable nil "List of articles in the current newsgroup that won't be sent.") @@ -1080,7 +1295,16 @@ "List of articles in the current newsgroup that have bookmarks.") (defvar gnus-newsgroup-dormant nil - "List of dormant articles in the current newsgroup.") + "Sorted list of dormant articles in the current newsgroup.") + +(defvar gnus-newsgroup-unseen nil + "List of unseen articles in the current newsgroup.") + +(defvar gnus-newsgroup-seen nil + "Range of seen articles in the current newsgroup.") + +(defvar gnus-newsgroup-articles nil + "List of articles in the current newsgroup.") (defvar gnus-newsgroup-scored nil "List of scored articles in the current newsgroup.") @@ -1108,18 +1332,25 @@ (defvar gnus-newsgroup-ephemeral-charset nil) (defvar gnus-newsgroup-ephemeral-ignored-charsets nil) -(defconst gnus-summary-local-variables +(defvar gnus-article-before-search nil) + +(defvar gnus-summary-local-variables '(gnus-newsgroup-name gnus-newsgroup-begin gnus-newsgroup-end gnus-newsgroup-last-rmail gnus-newsgroup-last-mail gnus-newsgroup-last-folder gnus-newsgroup-last-file gnus-newsgroup-auto-expire gnus-newsgroup-unreads gnus-newsgroup-unselected gnus-newsgroup-marked + gnus-newsgroup-spam-marked gnus-newsgroup-reads gnus-newsgroup-saved - gnus-newsgroup-replied gnus-newsgroup-expirable + gnus-newsgroup-replied gnus-newsgroup-forwarded + gnus-newsgroup-recent + gnus-newsgroup-expirable gnus-newsgroup-processable gnus-newsgroup-killed gnus-newsgroup-downloadable gnus-newsgroup-undownloaded - gnus-newsgroup-unsendable + gnus-newsgroup-unfetched + gnus-newsgroup-unsendable gnus-newsgroup-unseen + gnus-newsgroup-seen gnus-newsgroup-articles gnus-newsgroup-bookmarks gnus-newsgroup-dormant gnus-newsgroup-headers gnus-newsgroup-threads gnus-newsgroup-prepared gnus-summary-highlight-line-function @@ -1141,11 +1372,41 @@ gnus-cache-removable-articles gnus-newsgroup-cached gnus-newsgroup-data gnus-newsgroup-data-reverse gnus-newsgroup-limit gnus-newsgroup-limits - gnus-newsgroup-charset) + gnus-newsgroup-charset gnus-newsgroup-display + gnus-summary-use-undownloaded-faces) "Variables that are buffer-local to the summary buffers.") +(defvar gnus-newsgroup-variables nil + "A list of variables that have separate values in different newsgroups. +A list of newsgroup (summary buffer) local variables, or cons of +variables and their default values (when the default values are not +nil), that should be made global while the summary buffer is active. +These variables can be used to set variables in the group parameters +while still allowing them to affect operations done in other +buffers. For example: + +\(setq gnus-newsgroup-variables + '(message-use-followup-to + (gnus-visible-headers . + \"^From:\\\\|^Newsgroups:\\\\|^Subject:\\\\|^Date:\\\\|^To:\"))) +") + ;; Byte-compiler warning. -(eval-when-compile (defvar gnus-article-mode-map)) +(eval-when-compile + ;; Bind features so that require will believe that gnus-sum has + ;; already been loaded (avoids infinite recursion) + (let ((features (cons 'gnus-sum features))) + ;; Several of the declarations in gnus-sum are needed to load the + ;; following files. Right now, these definitions have been + ;; compiled but not defined (evaluated). We could either do a + ;; eval-and-compile about all of the declarations or evaluate the + ;; source file. + (if (boundp 'gnus-newsgroup-variables) + nil + (load "gnus-sum.el" t t t)) + (require 'gnus) + (require 'gnus-agent) + (require 'gnus-art))) ;; MIME stuff. @@ -1153,13 +1414,13 @@ '(mail-decode-encoded-word-string) "List of methods used to decode encoded words. -This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is -FUNCTION, FUNCTION will be apply to all newsgroups. If item is a -(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups +This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item +is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a +\(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups whose names match REGEXP. For example: -((\"chinese\" . gnus-decode-encoded-word-string-by-guess) +\((\"chinese\" . gnus-decode-encoded-word-string-by-guess) mail-decode-encoded-word-string (\"chinese\" . rfc1843-decode-string))") @@ -1178,7 +1439,7 @@ (string-match (car x) gnus-newsgroup-name)) (nconc gnus-decode-encoded-word-methods-cache (list (cdr x)))))) - gnus-decode-encoded-word-methods)) + gnus-decode-encoded-word-methods)) (let ((xlist gnus-decode-encoded-word-methods-cache)) (pop xlist) (while xlist @@ -1189,23 +1450,28 @@ (defun gnus-simplify-whitespace (str) "Remove excessive whitespace from STR." - (let ((mystr str)) - ;; Multiple spaces. - (while (string-match "[ \t][ \t]+" mystr) - (setq mystr (concat (substring mystr 0 (match-beginning 0)) - " " - (substring mystr (match-end 0))))) - ;; Leading spaces. - (when (string-match "^[ \t]+" mystr) - (setq mystr (substring mystr (match-end 0)))) - ;; Trailing spaces. - (when (string-match "[ \t]+$" mystr) - (setq mystr (substring mystr 0 (match-beginning 0)))) - mystr)) + ;; Multiple spaces. + (while (string-match "[ \t][ \t]+" str) + (setq str (concat (substring str 0 (match-beginning 0)) + " " + (substring str (match-end 0))))) + ;; Leading spaces. + (when (string-match "^[ \t]+" str) + (setq str (substring str (match-end 0)))) + ;; Trailing spaces. + (when (string-match "[ \t]+$" str) + (setq str (substring str 0 (match-beginning 0)))) + str) + +(defun gnus-simplify-all-whitespace (str) + "Remove all whitespace from STR." + (while (string-match "[ \t\n]+" str) + (setq str (replace-match "" nil nil str))) + str) (defsubst gnus-simplify-subject-re (subject) "Remove \"Re:\" from subject lines." - (if (string-match "^[Rr][Ee]: *" subject) + (if (string-match message-subject-re-regexp subject) (substring subject (match-end 0)) subject)) @@ -1279,7 +1545,7 @@ (buffer-string)))) (defsubst gnus-simplify-subject-fully (subject) - "Simplify a subject string according to gnus-summary-gather-subject-limit." + "Simplify a subject string according to `gnus-summary-gather-subject-limit'." (cond (gnus-simplify-subject-functions (gnus-map-function gnus-simplify-subject-functions subject)) @@ -1295,7 +1561,7 @@ (defsubst gnus-subject-equal (s1 s2 &optional simple-first) "Check whether two subjects are equal. -If optional argument simple-first is t, first argument is already +If optional argument SIMPLE-FIRST is t, first argument is already simplified." (cond ((null simple-first) @@ -1320,352 +1586,467 @@ (defvar gnus-article-commands-menu) -(when t - ;; Non-orthogonal keys - - (gnus-define-keys gnus-summary-mode-map - " " gnus-summary-next-page - "\177" gnus-summary-prev-page - [delete] gnus-summary-prev-page - [backspace] gnus-summary-prev-page - "\r" gnus-summary-scroll-up - "\M-\r" gnus-summary-scroll-down - "n" gnus-summary-next-unread-article - "p" gnus-summary-prev-unread-article - "N" gnus-summary-next-article - "P" gnus-summary-prev-article - "\M-\C-n" gnus-summary-next-same-subject - "\M-\C-p" gnus-summary-prev-same-subject - "\M-n" gnus-summary-next-unread-subject - "\M-p" gnus-summary-prev-unread-subject - "." gnus-summary-first-unread-article - "," gnus-summary-best-unread-article - "\M-s" gnus-summary-search-article-forward - "\M-r" gnus-summary-search-article-backward - "<" gnus-summary-beginning-of-article - ">" gnus-summary-end-of-article - "j" gnus-summary-goto-article - "^" gnus-summary-refer-parent-article - "\M-^" gnus-summary-refer-article - "u" gnus-summary-tick-article-forward - "!" gnus-summary-tick-article-forward - "U" gnus-summary-tick-article-backward - "d" gnus-summary-mark-as-read-forward - "D" gnus-summary-mark-as-read-backward - "E" gnus-summary-mark-as-expirable - "\M-u" gnus-summary-clear-mark-forward - "\M-U" gnus-summary-clear-mark-backward - "k" gnus-summary-kill-same-subject-and-select - "\C-k" gnus-summary-kill-same-subject - "\M-\C-k" gnus-summary-kill-thread - "\M-\C-l" gnus-summary-lower-thread - "e" gnus-summary-edit-article - "#" gnus-summary-mark-as-processable - "\M-#" gnus-summary-unmark-as-processable - "\M-\C-t" gnus-summary-toggle-threads - "\M-\C-s" gnus-summary-show-thread - "\M-\C-h" gnus-summary-hide-thread - "\M-\C-f" gnus-summary-next-thread - "\M-\C-b" gnus-summary-prev-thread - [(meta down)] gnus-summary-next-thread - [(meta up)] gnus-summary-prev-thread - "\M-\C-u" gnus-summary-up-thread - "\M-\C-d" gnus-summary-down-thread - "&" gnus-summary-execute-command - "c" gnus-summary-catchup-and-exit - "\C-w" gnus-summary-mark-region-as-read - "\C-t" gnus-summary-toggle-truncation - "?" gnus-summary-mark-as-dormant - "\C-c\M-\C-s" gnus-summary-limit-include-expunged - "\C-c\C-s\C-n" gnus-summary-sort-by-number - "\C-c\C-s\C-l" gnus-summary-sort-by-lines - "\C-c\C-s\C-c" gnus-summary-sort-by-chars - "\C-c\C-s\C-a" gnus-summary-sort-by-author - "\C-c\C-s\C-s" gnus-summary-sort-by-subject - "\C-c\C-s\C-d" gnus-summary-sort-by-date - "\C-c\C-s\C-i" gnus-summary-sort-by-score - "=" gnus-summary-expand-window - "\C-x\C-s" gnus-summary-reselect-current-group - "\M-g" gnus-summary-rescan-group - "w" gnus-summary-stop-page-breaking - "\C-c\C-r" gnus-summary-caesar-message - "f" gnus-summary-followup - "F" gnus-summary-followup-with-original - "C" gnus-summary-cancel-article - "r" gnus-summary-reply - "R" gnus-summary-reply-with-original - "\C-c\C-f" gnus-summary-mail-forward - "o" gnus-summary-save-article - "\C-o" gnus-summary-save-article-mail - "|" gnus-summary-pipe-output - "\M-k" gnus-summary-edit-local-kill - "\M-K" gnus-summary-edit-global-kill - ;; "V" gnus-version - "\C-c\C-d" gnus-summary-describe-group - "q" gnus-summary-exit - "Q" gnus-summary-exit-no-update - "\C-c\C-i" gnus-info-find-node - gnus-mouse-2 gnus-mouse-pick-article - "m" gnus-summary-mail-other-window - "a" gnus-summary-post-news - "x" gnus-summary-limit-to-unread - "s" gnus-summary-isearch-article - "t" gnus-summary-toggle-header - "g" gnus-summary-show-article - "l" gnus-summary-goto-last-article - "\C-c\C-v\C-v" gnus-uu-decode-uu-view - "\C-d" gnus-summary-enter-digest-group - "\M-\C-d" gnus-summary-read-document - "\M-\C-e" gnus-summary-edit-parameters - "\M-\C-a" gnus-summary-customize-parameters - "\C-c\C-b" gnus-bug - "*" gnus-cache-enter-article - "\M-*" gnus-cache-remove-article - "\M-&" gnus-summary-universal-argument - "\C-l" gnus-recenter - "I" gnus-summary-increase-score - "L" gnus-summary-lower-score - "\M-i" gnus-symbolic-argument - "h" gnus-summary-select-article-buffer - - "b" gnus-article-view-part - "\M-t" gnus-summary-toggle-display-buttonized - - "V" gnus-summary-score-map - "X" gnus-uu-extract-map - "S" gnus-summary-send-map) - - ;; Sort of orthogonal keymap - (gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map) - "t" gnus-summary-tick-article-forward - "!" gnus-summary-tick-article-forward - "d" gnus-summary-mark-as-read-forward - "r" gnus-summary-mark-as-read-forward - "c" gnus-summary-clear-mark-forward - " " gnus-summary-clear-mark-forward - "e" gnus-summary-mark-as-expirable - "x" gnus-summary-mark-as-expirable - "?" gnus-summary-mark-as-dormant - "b" gnus-summary-set-bookmark - "B" gnus-summary-remove-bookmark - "#" gnus-summary-mark-as-processable - "\M-#" gnus-summary-unmark-as-processable - "S" gnus-summary-limit-include-expunged - "C" gnus-summary-catchup - "H" gnus-summary-catchup-to-here - "\C-c" gnus-summary-catchup-all - "k" gnus-summary-kill-same-subject-and-select - "K" gnus-summary-kill-same-subject - "P" gnus-uu-mark-map) - - (gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mark-map) - "c" gnus-summary-clear-above - "u" gnus-summary-tick-above - "m" gnus-summary-mark-above - "k" gnus-summary-kill-below) - - (gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) - "/" gnus-summary-limit-to-subject - "n" gnus-summary-limit-to-articles - "w" gnus-summary-pop-limit - "s" gnus-summary-limit-to-subject - "a" gnus-summary-limit-to-author - "u" gnus-summary-limit-to-unread - "m" gnus-summary-limit-to-marks - "M" gnus-summary-limit-exclude-marks - "v" gnus-summary-limit-to-score - "*" gnus-summary-limit-include-cached - "D" gnus-summary-limit-include-dormant - "T" gnus-summary-limit-include-thread - "d" gnus-summary-limit-exclude-dormant - "t" gnus-summary-limit-to-age - "x" gnus-summary-limit-to-extra - "E" gnus-summary-limit-include-expunged - "c" gnus-summary-limit-exclude-childless-dormant - "C" gnus-summary-limit-mark-excluded-as-read) - - (gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) - "n" gnus-summary-next-unread-article - "p" gnus-summary-prev-unread-article - "N" gnus-summary-next-article - "P" gnus-summary-prev-article - "\C-n" gnus-summary-next-same-subject - "\C-p" gnus-summary-prev-same-subject - "\M-n" gnus-summary-next-unread-subject - "\M-p" gnus-summary-prev-unread-subject - "f" gnus-summary-first-unread-article - "b" gnus-summary-best-unread-article - "j" gnus-summary-goto-article - "g" gnus-summary-goto-subject - "l" gnus-summary-goto-last-article - "o" gnus-summary-pop-article) - - (gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) - "k" gnus-summary-kill-thread - "l" gnus-summary-lower-thread - "i" gnus-summary-raise-thread - "T" gnus-summary-toggle-threads - "t" gnus-summary-rethread-current - "^" gnus-summary-reparent-thread - "s" gnus-summary-show-thread - "S" gnus-summary-show-all-threads - "h" gnus-summary-hide-thread - "H" gnus-summary-hide-all-threads - "n" gnus-summary-next-thread - "p" gnus-summary-prev-thread - "u" gnus-summary-up-thread - "o" gnus-summary-top-thread - "d" gnus-summary-down-thread - "#" gnus-uu-mark-thread - "\M-#" gnus-uu-unmark-thread) - - (gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map) - "g" gnus-summary-prepare - "c" gnus-summary-insert-cached-articles) - - (gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) - "c" gnus-summary-catchup-and-exit - "C" gnus-summary-catchup-all-and-exit - "E" gnus-summary-exit-no-update - "Q" gnus-summary-exit - "Z" gnus-summary-exit - "n" gnus-summary-catchup-and-goto-next-group - "R" gnus-summary-reselect-current-group - "G" gnus-summary-rescan-group - "N" gnus-summary-next-group - "s" gnus-summary-save-newsrc - "P" gnus-summary-prev-group) - - (gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map) - " " gnus-summary-next-page - "n" gnus-summary-next-page - "\177" gnus-summary-prev-page - [delete] gnus-summary-prev-page - "p" gnus-summary-prev-page - "\r" gnus-summary-scroll-up - "\M-\r" gnus-summary-scroll-down - "<" gnus-summary-beginning-of-article - ">" gnus-summary-end-of-article - "b" gnus-summary-beginning-of-article - "e" gnus-summary-end-of-article - "^" gnus-summary-refer-parent-article - "r" gnus-summary-refer-parent-article - "D" gnus-summary-enter-digest-group - "R" gnus-summary-refer-references - "T" gnus-summary-refer-thread - "g" gnus-summary-show-article - "s" gnus-summary-isearch-article - "P" gnus-summary-print-article - "t" gnus-article-babel) - - (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) - "b" gnus-article-add-buttons - "B" gnus-article-add-buttons-to-head - "o" gnus-article-treat-overstrike - "e" gnus-article-emphasize - "w" gnus-article-fill-cited-article - "Q" gnus-article-fill-long-lines - "C" gnus-article-capitalize-sentences - "c" gnus-article-remove-cr - "q" gnus-article-de-quoted-unreadable - "6" gnus-article-de-base64-unreadable - "Z" gnus-article-decode-HZ - "h" gnus-article-wash-html - "f" gnus-article-display-x-face - "l" gnus-summary-stop-page-breaking - "r" gnus-summary-caesar-message - "t" gnus-summary-toggle-header - "v" gnus-summary-verbose-headers - "H" gnus-article-strip-headers-in-body - "d" gnus-article-treat-dumbquotes) - - (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) - "a" gnus-article-hide - "h" gnus-article-hide-headers - "b" gnus-article-hide-boring-headers - "s" gnus-article-hide-signature - "c" gnus-article-hide-citation - "C" gnus-article-hide-citation-in-followups - "l" gnus-article-hide-list-identifiers - "p" gnus-article-hide-pgp - "B" gnus-article-strip-banner - "P" gnus-article-hide-pem - "\C-c" gnus-article-hide-citation-maybe) - - (gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map) - "a" gnus-article-highlight - "h" gnus-article-highlight-headers - "c" gnus-article-highlight-citation - "s" gnus-article-highlight-signature) - - (gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) - "w" gnus-article-decode-mime-words - "c" gnus-article-decode-charset - "v" gnus-mime-view-all-parts - "b" gnus-article-view-part) - - (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) - "z" gnus-article-date-ut - "u" gnus-article-date-ut - "l" gnus-article-date-local - "e" gnus-article-date-lapsed - "o" gnus-article-date-original - "i" gnus-article-date-iso8601 - "s" gnus-article-date-user) - - (gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) - "t" gnus-article-remove-trailing-blank-lines - "l" gnus-article-strip-leading-blank-lines - "m" gnus-article-strip-multiple-blank-lines - "a" gnus-article-strip-blank-lines - "A" gnus-article-strip-all-blank-lines - "s" gnus-article-strip-leading-space - "e" gnus-article-strip-trailing-space) - - (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) - "v" gnus-version - "f" gnus-summary-fetch-faq - "d" gnus-summary-describe-group - "h" gnus-summary-describe-briefly - "i" gnus-info-find-node) - - (gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map) - "e" gnus-summary-expire-articles - "\M-\C-e" gnus-summary-expire-articles-now - "\177" gnus-summary-delete-article - [delete] gnus-summary-delete-article - [backspace] gnus-summary-delete-article - "m" gnus-summary-move-article - "r" gnus-summary-respool-article - "w" gnus-summary-edit-article - "c" gnus-summary-copy-article - "B" gnus-summary-crosspost-article - "q" gnus-summary-respool-query - "t" gnus-summary-respool-trace - "i" gnus-summary-import-article - "p" gnus-summary-article-posted-p) - - (gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map) - "o" gnus-summary-save-article - "m" gnus-summary-save-article-mail - "F" gnus-summary-write-article-file - "r" gnus-summary-save-article-rmail - "f" gnus-summary-save-article-file - "b" gnus-summary-save-article-body-file - "h" gnus-summary-save-article-folder - "v" gnus-summary-save-article-vm - "p" gnus-summary-pipe-output - "s" gnus-soup-add-article) - - (gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map) - "b" gnus-summary-display-buttonized - "m" gnus-summary-repair-multipart - "v" gnus-article-view-part - "o" gnus-article-save-part - "c" gnus-article-copy-part - "e" gnus-article-externalize-part - "i" gnus-article-inline-part - "|" gnus-article-pipe-part)) +;; Non-orthogonal keys + +(gnus-define-keys gnus-summary-mode-map + " " gnus-summary-next-page + "\177" gnus-summary-prev-page + [delete] gnus-summary-prev-page + [backspace] gnus-summary-prev-page + "\r" gnus-summary-scroll-up + "\M-\r" gnus-summary-scroll-down + "n" gnus-summary-next-unread-article + "p" gnus-summary-prev-unread-article + "N" gnus-summary-next-article + "P" gnus-summary-prev-article + "\M-\C-n" gnus-summary-next-same-subject + "\M-\C-p" gnus-summary-prev-same-subject + "\M-n" gnus-summary-next-unread-subject + "\M-p" gnus-summary-prev-unread-subject + "." gnus-summary-first-unread-article + "," gnus-summary-best-unread-article + "\M-s" gnus-summary-search-article-forward + "\M-r" gnus-summary-search-article-backward + "<" gnus-summary-beginning-of-article + ">" gnus-summary-end-of-article + "j" gnus-summary-goto-article + "^" gnus-summary-refer-parent-article + "\M-^" gnus-summary-refer-article + "u" gnus-summary-tick-article-forward + "!" gnus-summary-tick-article-forward + "U" gnus-summary-tick-article-backward + "d" gnus-summary-mark-as-read-forward + "D" gnus-summary-mark-as-read-backward + "E" gnus-summary-mark-as-expirable + "\M-u" gnus-summary-clear-mark-forward + "\M-U" gnus-summary-clear-mark-backward + "k" gnus-summary-kill-same-subject-and-select + "\C-k" gnus-summary-kill-same-subject + "\M-\C-k" gnus-summary-kill-thread + "\M-\C-l" gnus-summary-lower-thread + "e" gnus-summary-edit-article + "#" gnus-summary-mark-as-processable + "\M-#" gnus-summary-unmark-as-processable + "\M-\C-t" gnus-summary-toggle-threads + "\M-\C-s" gnus-summary-show-thread + "\M-\C-h" gnus-summary-hide-thread + "\M-\C-f" gnus-summary-next-thread + "\M-\C-b" gnus-summary-prev-thread + [(meta down)] gnus-summary-next-thread + [(meta up)] gnus-summary-prev-thread + "\M-\C-u" gnus-summary-up-thread + "\M-\C-d" gnus-summary-down-thread + "&" gnus-summary-execute-command + "c" gnus-summary-catchup-and-exit + "\C-w" gnus-summary-mark-region-as-read + "\C-t" gnus-summary-toggle-truncation + "?" gnus-summary-mark-as-dormant + "\C-c\M-\C-s" gnus-summary-limit-include-expunged + "\C-c\C-s\C-n" gnus-summary-sort-by-number + "\C-c\C-s\C-l" gnus-summary-sort-by-lines + "\C-c\C-s\C-c" gnus-summary-sort-by-chars + "\C-c\C-s\C-a" gnus-summary-sort-by-author + "\C-c\C-s\C-s" gnus-summary-sort-by-subject + "\C-c\C-s\C-d" gnus-summary-sort-by-date + "\C-c\C-s\C-i" gnus-summary-sort-by-score + "\C-c\C-s\C-o" gnus-summary-sort-by-original + "\C-c\C-s\C-r" gnus-summary-sort-by-random + "=" gnus-summary-expand-window + "\C-x\C-s" gnus-summary-reselect-current-group + "\M-g" gnus-summary-rescan-group + "w" gnus-summary-stop-page-breaking + "\C-c\C-r" gnus-summary-caesar-message + "f" gnus-summary-followup + "F" gnus-summary-followup-with-original + "C" gnus-summary-cancel-article + "r" gnus-summary-reply + "R" gnus-summary-reply-with-original + "\C-c\C-f" gnus-summary-mail-forward + "o" gnus-summary-save-article + "\C-o" gnus-summary-save-article-mail + "|" gnus-summary-pipe-output + "\M-k" gnus-summary-edit-local-kill + "\M-K" gnus-summary-edit-global-kill + ;; "V" gnus-version + "\C-c\C-d" gnus-summary-describe-group + "q" gnus-summary-exit + "Q" gnus-summary-exit-no-update + "\C-c\C-i" gnus-info-find-node + gnus-mouse-2 gnus-mouse-pick-article + "m" gnus-summary-mail-other-window + "a" gnus-summary-post-news + "i" gnus-summary-news-other-window + "x" gnus-summary-limit-to-unread + "s" gnus-summary-isearch-article + "t" gnus-summary-toggle-header + "g" gnus-summary-show-article + "l" gnus-summary-goto-last-article + "\C-c\C-v\C-v" gnus-uu-decode-uu-view + "\C-d" gnus-summary-enter-digest-group + "\M-\C-d" gnus-summary-read-document + "\M-\C-e" gnus-summary-edit-parameters + "\M-\C-a" gnus-summary-customize-parameters + "\C-c\C-b" gnus-bug + "*" gnus-cache-enter-article + "\M-*" gnus-cache-remove-article + "\M-&" gnus-summary-universal-argument + "\C-l" gnus-recenter + "I" gnus-summary-increase-score + "L" gnus-summary-lower-score + "\M-i" gnus-symbolic-argument + "h" gnus-summary-select-article-buffer + + "b" gnus-article-view-part + "\M-t" gnus-summary-toggle-display-buttonized + + "V" gnus-summary-score-map + "X" gnus-uu-extract-map + "S" gnus-summary-send-map) + +;; Sort of orthogonal keymap +(gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map) + "t" gnus-summary-tick-article-forward + "!" gnus-summary-tick-article-forward + "d" gnus-summary-mark-as-read-forward + "r" gnus-summary-mark-as-read-forward + "c" gnus-summary-clear-mark-forward + " " gnus-summary-clear-mark-forward + "e" gnus-summary-mark-as-expirable + "x" gnus-summary-mark-as-expirable + "?" gnus-summary-mark-as-dormant + "b" gnus-summary-set-bookmark + "B" gnus-summary-remove-bookmark + "#" gnus-summary-mark-as-processable + "\M-#" gnus-summary-unmark-as-processable + "S" gnus-summary-limit-include-expunged + "C" gnus-summary-catchup + "H" gnus-summary-catchup-to-here + "h" gnus-summary-catchup-from-here + "\C-c" gnus-summary-catchup-all + "k" gnus-summary-kill-same-subject-and-select + "K" gnus-summary-kill-same-subject + "P" gnus-uu-mark-map) + +(gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mark-map) + "c" gnus-summary-clear-above + "u" gnus-summary-tick-above + "m" gnus-summary-mark-above + "k" gnus-summary-kill-below) + +(gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) + "/" gnus-summary-limit-to-subject + "n" gnus-summary-limit-to-articles + "w" gnus-summary-pop-limit + "s" gnus-summary-limit-to-subject + "a" gnus-summary-limit-to-author + "u" gnus-summary-limit-to-unread + "m" gnus-summary-limit-to-marks + "M" gnus-summary-limit-exclude-marks + "v" gnus-summary-limit-to-score + "*" gnus-summary-limit-include-cached + "D" gnus-summary-limit-include-dormant + "T" gnus-summary-limit-include-thread + "d" gnus-summary-limit-exclude-dormant + "t" gnus-summary-limit-to-age + "." gnus-summary-limit-to-unseen + "x" gnus-summary-limit-to-extra + "p" gnus-summary-limit-to-display-predicate + "E" gnus-summary-limit-include-expunged + "c" gnus-summary-limit-exclude-childless-dormant + "C" gnus-summary-limit-mark-excluded-as-read + "o" gnus-summary-insert-old-articles + "N" gnus-summary-insert-new-articles) + +(gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) + "n" gnus-summary-next-unread-article + "p" gnus-summary-prev-unread-article + "N" gnus-summary-next-article + "P" gnus-summary-prev-article + "\C-n" gnus-summary-next-same-subject + "\C-p" gnus-summary-prev-same-subject + "\M-n" gnus-summary-next-unread-subject + "\M-p" gnus-summary-prev-unread-subject + "f" gnus-summary-first-unread-article + "b" gnus-summary-best-unread-article + "j" gnus-summary-goto-article + "g" gnus-summary-goto-subject + "l" gnus-summary-goto-last-article + "o" gnus-summary-pop-article) + +(gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) + "k" gnus-summary-kill-thread + "l" gnus-summary-lower-thread + "i" gnus-summary-raise-thread + "T" gnus-summary-toggle-threads + "t" gnus-summary-rethread-current + "^" gnus-summary-reparent-thread + "s" gnus-summary-show-thread + "S" gnus-summary-show-all-threads + "h" gnus-summary-hide-thread + "H" gnus-summary-hide-all-threads + "n" gnus-summary-next-thread + "p" gnus-summary-prev-thread + "u" gnus-summary-up-thread + "o" gnus-summary-top-thread + "d" gnus-summary-down-thread + "#" gnus-uu-mark-thread + "\M-#" gnus-uu-unmark-thread) + +(gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map) + "g" gnus-summary-prepare + "c" gnus-summary-insert-cached-articles + "d" gnus-summary-insert-dormant-articles) + +(gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) + "c" gnus-summary-catchup-and-exit + "C" gnus-summary-catchup-all-and-exit + "E" gnus-summary-exit-no-update + "Q" gnus-summary-exit + "Z" gnus-summary-exit + "n" gnus-summary-catchup-and-goto-next-group + "R" gnus-summary-reselect-current-group + "G" gnus-summary-rescan-group + "N" gnus-summary-next-group + "s" gnus-summary-save-newsrc + "P" gnus-summary-prev-group) + +(gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map) + " " gnus-summary-next-page + "n" gnus-summary-next-page + "\177" gnus-summary-prev-page + [delete] gnus-summary-prev-page + "p" gnus-summary-prev-page + "\r" gnus-summary-scroll-up + "\M-\r" gnus-summary-scroll-down + "<" gnus-summary-beginning-of-article + ">" gnus-summary-end-of-article + "b" gnus-summary-beginning-of-article + "e" gnus-summary-end-of-article + "^" gnus-summary-refer-parent-article + "r" gnus-summary-refer-parent-article + "D" gnus-summary-enter-digest-group + "R" gnus-summary-refer-references + "T" gnus-summary-refer-thread + "g" gnus-summary-show-article + "s" gnus-summary-isearch-article + "P" gnus-summary-print-article + "M" gnus-mailing-list-insinuate + "t" gnus-article-babel) + +(gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) + "b" gnus-article-add-buttons + "B" gnus-article-add-buttons-to-head + "o" gnus-article-treat-overstrike + "e" gnus-article-emphasize + "w" gnus-article-fill-cited-article + "Q" gnus-article-fill-long-lines + "C" gnus-article-capitalize-sentences + "c" gnus-article-remove-cr + "q" gnus-article-de-quoted-unreadable + "6" gnus-article-de-base64-unreadable + "Z" gnus-article-decode-HZ + "h" gnus-article-wash-html + "u" gnus-article-unsplit-urls + "s" gnus-summary-force-verify-and-decrypt + "f" gnus-article-display-x-face + "l" gnus-summary-stop-page-breaking + "r" gnus-summary-caesar-message + "m" gnus-summary-morse-message + "t" gnus-summary-toggle-header + "g" gnus-treat-smiley + "v" gnus-summary-verbose-headers + "a" gnus-article-strip-headers-in-body ;; mnemonic: wash archive + "p" gnus-article-verify-x-pgp-sig + "d" gnus-article-treat-dumbquotes) + +(gnus-define-keys (gnus-summary-wash-deuglify-map "Y" gnus-summary-wash-map) + ;; mnemonic: deuglif*Y* + "u" gnus-article-outlook-unwrap-lines + "a" gnus-article-outlook-repair-attribution + "c" gnus-article-outlook-rearrange-citation + "f" gnus-article-outlook-deuglify-article) ;; mnemonic: full deuglify + +(gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) + "a" gnus-article-hide + "h" gnus-article-hide-headers + "b" gnus-article-hide-boring-headers + "s" gnus-article-hide-signature + "c" gnus-article-hide-citation + "C" gnus-article-hide-citation-in-followups + "l" gnus-article-hide-list-identifiers + "B" gnus-article-strip-banner + "P" gnus-article-hide-pem + "\C-c" gnus-article-hide-citation-maybe) + +(gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map) + "a" gnus-article-highlight + "h" gnus-article-highlight-headers + "c" gnus-article-highlight-citation + "s" gnus-article-highlight-signature) + +(gnus-define-keys (gnus-summary-wash-header-map "G" gnus-summary-wash-map) + "f" gnus-article-treat-fold-headers + "u" gnus-article-treat-unfold-headers + "n" gnus-article-treat-fold-newsgroups) + +(gnus-define-keys (gnus-summary-wash-display-map "D" gnus-summary-wash-map) + "x" gnus-article-display-x-face + "d" gnus-article-display-face + "s" gnus-treat-smiley + "D" gnus-article-remove-images + "f" gnus-treat-from-picon + "m" gnus-treat-mail-picon + "n" gnus-treat-newsgroups-picon) + +(gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) + "w" gnus-article-decode-mime-words + "c" gnus-article-decode-charset + "v" gnus-mime-view-all-parts + "b" gnus-article-view-part) + +(gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) + "z" gnus-article-date-ut + "u" gnus-article-date-ut + "l" gnus-article-date-local + "p" gnus-article-date-english + "e" gnus-article-date-lapsed + "o" gnus-article-date-original + "i" gnus-article-date-iso8601 + "s" gnus-article-date-user) + +(gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) + "t" gnus-article-remove-trailing-blank-lines + "l" gnus-article-strip-leading-blank-lines + "m" gnus-article-strip-multiple-blank-lines + "a" gnus-article-strip-blank-lines + "A" gnus-article-strip-all-blank-lines + "s" gnus-article-strip-leading-space + "e" gnus-article-strip-trailing-space + "w" gnus-article-remove-leading-whitespace) + +(gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) + "v" gnus-version + "f" gnus-summary-fetch-faq + "d" gnus-summary-describe-group + "h" gnus-summary-describe-briefly + "i" gnus-info-find-node + "c" gnus-group-fetch-charter + "C" gnus-group-fetch-control) + +(gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map) + "e" gnus-summary-expire-articles + "\M-\C-e" gnus-summary-expire-articles-now + "\177" gnus-summary-delete-article + [delete] gnus-summary-delete-article + [backspace] gnus-summary-delete-article + "m" gnus-summary-move-article + "r" gnus-summary-respool-article + "w" gnus-summary-edit-article + "c" gnus-summary-copy-article + "B" gnus-summary-crosspost-article + "q" gnus-summary-respool-query + "t" gnus-summary-respool-trace + "i" gnus-summary-import-article + "I" gnus-summary-create-article + "p" gnus-summary-article-posted-p) + +(gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map) + "o" gnus-summary-save-article + "m" gnus-summary-save-article-mail + "F" gnus-summary-write-article-file + "r" gnus-summary-save-article-rmail + "f" gnus-summary-save-article-file + "b" gnus-summary-save-article-body-file + "h" gnus-summary-save-article-folder + "v" gnus-summary-save-article-vm + "p" gnus-summary-pipe-output + "P" gnus-summary-muttprint + "s" gnus-soup-add-article) + +(gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map) + "b" gnus-summary-display-buttonized + "m" gnus-summary-repair-multipart + "v" gnus-article-view-part + "o" gnus-article-save-part + "c" gnus-article-copy-part + "C" gnus-article-view-part-as-charset + "e" gnus-article-view-part-externally + "E" gnus-article-encrypt-body + "i" gnus-article-inline-part + "|" gnus-article-pipe-part) + +(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) + "p" gnus-summary-mark-as-processable + "u" gnus-summary-unmark-as-processable + "U" gnus-summary-unmark-all-processable + "v" gnus-uu-mark-over + "s" gnus-uu-mark-series + "r" gnus-uu-mark-region + "g" gnus-uu-unmark-region + "R" gnus-uu-mark-by-regexp + "G" gnus-uu-unmark-by-regexp + "t" gnus-uu-mark-thread + "T" gnus-uu-unmark-thread + "a" gnus-uu-mark-all + "b" gnus-uu-mark-buffer + "S" gnus-uu-mark-sparse + "k" gnus-summary-kill-process-mark + "y" gnus-summary-yank-process-mark + "w" gnus-summary-save-process-mark + "i" gnus-uu-invert-processable) + +(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) + ;;"x" gnus-uu-extract-any + "m" gnus-summary-save-parts + "u" gnus-uu-decode-uu + "U" gnus-uu-decode-uu-and-save + "s" gnus-uu-decode-unshar + "S" gnus-uu-decode-unshar-and-save + "o" gnus-uu-decode-save + "O" gnus-uu-decode-save + "b" gnus-uu-decode-binhex + "B" gnus-uu-decode-binhex + "p" gnus-uu-decode-postscript + "P" gnus-uu-decode-postscript-and-save) + +(gnus-define-keys + (gnus-uu-extract-view-map "v" gnus-uu-extract-map) + "u" gnus-uu-decode-uu-view + "U" gnus-uu-decode-uu-and-save-view + "s" gnus-uu-decode-unshar-view + "S" gnus-uu-decode-unshar-and-save-view + "o" gnus-uu-decode-save-view + "O" gnus-uu-decode-save-view + "b" gnus-uu-decode-binhex-view + "B" gnus-uu-decode-binhex-view + "p" gnus-uu-decode-postscript-view + "P" gnus-uu-decode-postscript-and-save-view) + +(defvar gnus-article-post-menu nil) + +(defconst gnus-summary-menu-maxlen 20) + +(defun gnus-summary-menu-split (menu) + ;; If we have lots of elements, divide them into groups of 20 + ;; and make a pane (or submenu) for each one. + (if (> (length menu) (/ (* gnus-summary-menu-maxlen 3) 2)) + (let ((menu menu) sublists next + (i 1)) + (while menu + ;; Pull off the next gnus-summary-menu-maxlen elements + ;; and make them the next element of sublist. + (setq next (nthcdr gnus-summary-menu-maxlen menu)) + (if next + (setcdr (nthcdr (1- gnus-summary-menu-maxlen) menu) + nil)) + (setq sublists (cons (cons (format "%s ... %s" (aref (car menu) 0) + (aref (car (last menu)) 0)) menu) + sublists)) + (setq i (1+ i)) + (setq menu next)) + (nreverse sublists)) + ;; Few elements--put them all in one pane. + menu)) (defun gnus-summary-make-menu-bar () (gnus-turn-off-edit-menu 'summary) @@ -1673,152 +2054,224 @@ (unless (boundp 'gnus-summary-misc-menu) (easy-menu-define - gnus-summary-kill-menu gnus-summary-mode-map "" - (cons - "Score" - (nconc - (list - ["Enter score..." gnus-summary-score-entry t] - ["Customize" gnus-score-customize t]) - (gnus-make-score-map 'increase) - (gnus-make-score-map 'lower) - '(("Mark" - ["Kill below" gnus-summary-kill-below t] - ["Mark above" gnus-summary-mark-above t] - ["Tick above" gnus-summary-tick-above t] - ["Clear above" gnus-summary-clear-above t]) - ["Current score" gnus-summary-current-score t] - ["Set score" gnus-summary-set-score t] - ["Switch current score file..." gnus-score-change-score-file t] - ["Set mark below..." gnus-score-set-mark-below t] - ["Set expunge below..." gnus-score-set-expunge-below t] - ["Edit current score file" gnus-score-edit-current-scores t] - ["Edit score file" gnus-score-edit-file t] - ["Trace score" gnus-score-find-trace t] - ["Find words" gnus-score-find-favourite-words t] - ["Rescore buffer" gnus-summary-rescore t] - ["Increase score..." gnus-summary-increase-score t] - ["Lower score..." gnus-summary-lower-score t])))) - - ;; Define both the Article menu in the summary buffer and the equivalent - ;; Commands menu in the article buffer here for consistency. + gnus-summary-kill-menu gnus-summary-mode-map "" + (cons + "Score" + (nconc + (list + ["Customize" gnus-score-customize t]) + (gnus-make-score-map 'increase) + (gnus-make-score-map 'lower) + '(("Mark" + ["Kill below" gnus-summary-kill-below t] + ["Mark above" gnus-summary-mark-above t] + ["Tick above" gnus-summary-tick-above t] + ["Clear above" gnus-summary-clear-above t]) + ["Current score" gnus-summary-current-score t] + ["Set score" gnus-summary-set-score t] + ["Switch current score file..." gnus-score-change-score-file t] + ["Set mark below..." gnus-score-set-mark-below t] + ["Set expunge below..." gnus-score-set-expunge-below t] + ["Edit current score file" gnus-score-edit-current-scores t] + ["Edit score file" gnus-score-edit-file t] + ["Trace score" gnus-score-find-trace t] + ["Find words" gnus-score-find-favourite-words t] + ["Rescore buffer" gnus-summary-rescore t] + ["Increase score..." gnus-summary-increase-score t] + ["Lower score..." gnus-summary-lower-score t])))) + + ;; Define both the Article menu in the summary buffer and the + ;; equivalent Commands menu in the article buffer here for + ;; consistency. (let ((innards - '(("Hide" - ["All" gnus-article-hide t] - ["Headers" gnus-article-hide-headers t] - ["Signature" gnus-article-hide-signature t] - ["Citation" gnus-article-hide-citation t] + `(("Hide" + ["All" gnus-article-hide t] + ["Headers" gnus-article-hide-headers t] + ["Signature" gnus-article-hide-signature t] + ["Citation" gnus-article-hide-citation t] ["List identifiers" gnus-article-hide-list-identifiers t] - ["PGP" gnus-article-hide-pgp t] ["Banner" gnus-article-strip-banner t] - ["Boring headers" gnus-article-hide-boring-headers t]) - ("Highlight" - ["All" gnus-article-highlight t] - ["Headers" gnus-article-highlight-headers t] - ["Signature" gnus-article-highlight-signature t] - ["Citation" gnus-article-highlight-citation t]) + ["Boring headers" gnus-article-hide-boring-headers t]) + ("Highlight" + ["All" gnus-article-highlight t] + ["Headers" gnus-article-highlight-headers t] + ["Signature" gnus-article-highlight-signature t] + ["Citation" gnus-article-highlight-citation t]) ("MIME" ["Words" gnus-article-decode-mime-words t] ["Charset" gnus-article-decode-charset t] ["QP" gnus-article-de-quoted-unreadable t] ["Base64" gnus-article-de-base64-unreadable t] - ["View all" gnus-mime-view-all-parts t]) - ("Date" - ["Local" gnus-article-date-local t] - ["ISO8601" gnus-article-date-iso8601 t] - ["UT" gnus-article-date-ut t] - ["Original" gnus-article-date-original t] - ["Lapsed" gnus-article-date-lapsed t] - ["User-defined" gnus-article-date-user t]) - ("Washing" - ("Remove Blanks" - ["Leading" gnus-article-strip-leading-blank-lines t] - ["Multiple" gnus-article-strip-multiple-blank-lines t] - ["Trailing" gnus-article-remove-trailing-blank-lines t] - ["All of the above" gnus-article-strip-blank-lines t] - ["All" gnus-article-strip-all-blank-lines t] - ["Leading space" gnus-article-strip-leading-space t] - ["Trailing space" gnus-article-strip-trailing-space t]) - ["Overstrike" gnus-article-treat-overstrike t] - ["Dumb quotes" gnus-article-treat-dumbquotes t] - ["Emphasis" gnus-article-emphasize t] - ["Word wrap" gnus-article-fill-cited-article t] + ["View MIME buttons" gnus-summary-display-buttonized t] + ["View all" gnus-mime-view-all-parts t] + ["Verify and Decrypt" gnus-summary-force-verify-and-decrypt t] + ["Encrypt body" gnus-article-encrypt-body + :active (not (gnus-group-read-only-p)) + ,@(if (featurep 'xemacs) nil + '(:help "Encrypt the message body on disk"))] + ["Extract all parts..." gnus-summary-save-parts t] + ("Multipart" + ["Repair multipart" gnus-summary-repair-multipart t] + ["Pipe part..." gnus-article-pipe-part t] + ["Inline part" gnus-article-inline-part t] + ["Encrypt body" gnus-article-encrypt-body + :active (not (gnus-group-read-only-p)) + ,@(if (featurep 'xemacs) nil + '(:help "Encrypt the message body on disk"))] + ["View part externally" gnus-article-view-part-externally t] + ["View part with charset..." gnus-article-view-part-as-charset t] + ["Copy part" gnus-article-copy-part t] + ["Save part..." gnus-article-save-part t] + ["View part" gnus-article-view-part t])) + ("Date" + ["Local" gnus-article-date-local t] + ["ISO8601" gnus-article-date-iso8601 t] + ["UT" gnus-article-date-ut t] + ["Original" gnus-article-date-original t] + ["Lapsed" gnus-article-date-lapsed t] + ["User-defined" gnus-article-date-user t]) + ("Display" + ["Remove images" gnus-article-remove-images t] + ["Toggle smiley" gnus-treat-smiley t] + ["Show X-Face" gnus-article-display-x-face t] + ["Show picons in From" gnus-treat-from-picon t] + ["Show picons in mail headers" gnus-treat-mail-picon t] + ["Show picons in news headers" gnus-treat-newsgroups-picon t] + ("View as different encoding" + ,@(gnus-summary-menu-split + (mapcar + (lambda (cs) + ;; Since easymenu under Emacs doesn't allow + ;; lambda forms for menu commands, we should + ;; provide intern'ed function symbols. + (let ((command (intern (format "\ +gnus-summary-show-article-from-menu-as-charset-%s" cs)))) + (fset command + `(lambda () + (interactive) + (let ((gnus-summary-show-article-charset-alist + '((1 . ,cs)))) + (gnus-summary-show-article 1)))) + `[,(symbol-name cs) ,command t])) + (sort (if (fboundp 'coding-system-list) + (coding-system-list) + (mapcar 'car mm-mime-mule-charset-alist)) + 'string<))))) + ("Washing" + ("Remove Blanks" + ["Leading" gnus-article-strip-leading-blank-lines t] + ["Multiple" gnus-article-strip-multiple-blank-lines t] + ["Trailing" gnus-article-remove-trailing-blank-lines t] + ["All of the above" gnus-article-strip-blank-lines t] + ["All" gnus-article-strip-all-blank-lines t] + ["Leading space" gnus-article-strip-leading-space t] + ["Trailing space" gnus-article-strip-trailing-space t] + ["Leading space in headers" + gnus-article-remove-leading-whitespace t]) + ["Overstrike" gnus-article-treat-overstrike t] + ["Dumb quotes" gnus-article-treat-dumbquotes t] + ["Emphasis" gnus-article-emphasize t] + ["Word wrap" gnus-article-fill-cited-article t] ["Fill long lines" gnus-article-fill-long-lines t] ["Capitalize sentences" gnus-article-capitalize-sentences t] - ["CR" gnus-article-remove-cr t] - ["Show X-Face" gnus-article-display-x-face t] - ["Quoted-Printable" gnus-article-de-quoted-unreadable t] - ["Base64" gnus-article-de-base64-unreadable t] - ["Rot 13" gnus-summary-caesar-message - :help "\"Caesar rotate\" article by 13"] - ["Unix pipe" gnus-summary-pipe-message t] - ["Add buttons" gnus-article-add-buttons t] - ["Add buttons to head" gnus-article-add-buttons-to-head t] - ["Stop page breaking" gnus-summary-stop-page-breaking t] - ["Verbose header" gnus-summary-verbose-headers t] - ["Toggle header" gnus-summary-toggle-header t] + ["Remove CR" gnus-article-remove-cr t] + ["Quoted-Printable" gnus-article-de-quoted-unreadable t] + ["Base64" gnus-article-de-base64-unreadable t] + ["Rot 13" gnus-summary-caesar-message + ,@(if (featurep 'xemacs) '(t) + '(:help "\"Caesar rotate\" article by 13"))] + ["Morse decode" gnus-summary-morse-message t] + ["Unix pipe..." gnus-summary-pipe-message t] + ["Add buttons" gnus-article-add-buttons t] + ["Add buttons to head" gnus-article-add-buttons-to-head t] + ["Stop page breaking" gnus-summary-stop-page-breaking t] + ["Verbose header" gnus-summary-verbose-headers t] + ["Toggle header" gnus-summary-toggle-header t] + ["Unfold headers" gnus-article-treat-unfold-headers t] + ["Fold newsgroups" gnus-article-treat-fold-newsgroups t] ["Html" gnus-article-wash-html t] - ["HZ" gnus-article-decode-HZ t]) - ("Output" - ["Save in default format" gnus-summary-save-article - :help "Save article using default method"] - ["Save in file" gnus-summary-save-article-file - :help "Save article in file"] - ["Save in Unix mail format" gnus-summary-save-article-mail t] - ["Save in MH folder" gnus-summary-save-article-folder t] - ["Save in VM folder" gnus-summary-save-article-vm t] - ["Save in RMAIL mbox" gnus-summary-save-article-rmail t] - ["Save body in file" gnus-summary-save-article-body-file t] - ["Pipe through a filter" gnus-summary-pipe-output t] - ["Add to SOUP packet" gnus-soup-add-article t] - ["Print" gnus-summary-print-article t]) - ("Backend" - ["Respool article..." gnus-summary-respool-article t] - ["Move article..." gnus-summary-move-article - (gnus-check-backend-function - 'request-move-article gnus-newsgroup-name)] - ["Copy article..." gnus-summary-copy-article t] - ["Crosspost article..." gnus-summary-crosspost-article - (gnus-check-backend-function - 'request-replace-article gnus-newsgroup-name)] - ["Import file..." gnus-summary-import-article t] - ["Check if posted" gnus-summary-article-posted-p t] - ["Edit article" gnus-summary-edit-article - (not (gnus-group-read-only-p))] - ["Delete article" gnus-summary-delete-article - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)] - ["Query respool" gnus-summary-respool-query t] + ["Unsplit URLs" gnus-article-unsplit-urls t] + ["Verify X-PGP-Sig" gnus-article-verify-x-pgp-sig t] + ["Decode HZ" gnus-article-decode-HZ t] + ("(Outlook) Deuglify" + ["Unwrap lines" gnus-article-outlook-unwrap-lines t] + ["Repair attribution" gnus-article-outlook-repair-attribution t] + ["Rearrange citation" gnus-article-outlook-rearrange-citation t] + ["Full (Outlook) deuglify" + gnus-article-outlook-deuglify-article t]) + ) + ("Output" + ["Save in default format..." gnus-summary-save-article + ,@(if (featurep 'xemacs) '(t) + '(:help "Save article using default method"))] + ["Save in file..." gnus-summary-save-article-file + ,@(if (featurep 'xemacs) '(t) + '(:help "Save article in file"))] + ["Save in Unix mail format..." gnus-summary-save-article-mail t] + ["Save in MH folder..." gnus-summary-save-article-folder t] + ["Save in VM folder..." gnus-summary-save-article-vm t] + ["Save in RMAIL mbox..." gnus-summary-save-article-rmail t] + ["Save body in file..." gnus-summary-save-article-body-file t] + ["Pipe through a filter..." gnus-summary-pipe-output t] + ["Add to SOUP packet" gnus-soup-add-article t] + ["Print with Muttprint..." gnus-summary-muttprint t] + ["Print" gnus-summary-print-article t]) + ("Backend" + ["Respool article..." gnus-summary-respool-article t] + ["Move article..." gnus-summary-move-article + (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name)] + ["Copy article..." gnus-summary-copy-article t] + ["Crosspost article..." gnus-summary-crosspost-article + (gnus-check-backend-function + 'request-replace-article gnus-newsgroup-name)] + ["Import file..." gnus-summary-import-article + (gnus-check-backend-function + 'request-accept-article gnus-newsgroup-name)] + ["Create article..." gnus-summary-create-article + (gnus-check-backend-function + 'request-accept-article gnus-newsgroup-name)] + ["Check if posted" gnus-summary-article-posted-p t] + ["Edit article" gnus-summary-edit-article + (not (gnus-group-read-only-p))] + ["Delete article" gnus-summary-delete-article + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)] + ["Query respool" gnus-summary-respool-query t] ["Trace respool" gnus-summary-respool-trace t] - ["Delete expirable articles" gnus-summary-expire-articles-now - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)]) - ("Extract" - ["Uudecode" gnus-uu-decode-uu - :help "Decode uuencoded article(s)"] - ["Uudecode and save" gnus-uu-decode-uu-and-save t] - ["Unshar" gnus-uu-decode-unshar t] - ["Unshar and save" gnus-uu-decode-unshar-and-save t] - ["Save" gnus-uu-decode-save t] - ["Binhex" gnus-uu-decode-binhex t] - ["Postscript" gnus-uu-decode-postscript t]) - ("Cache" - ["Enter article" gnus-cache-enter-article t] - ["Remove article" gnus-cache-remove-article t]) + ["Delete expirable articles" gnus-summary-expire-articles-now + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)]) + ("Extract" + ["Uudecode" gnus-uu-decode-uu + ,@(if (featurep 'xemacs) '(t) + '(:help "Decode uuencoded article(s)"))] + ["Uudecode and save" gnus-uu-decode-uu-and-save t] + ["Unshar" gnus-uu-decode-unshar t] + ["Unshar and save" gnus-uu-decode-unshar-and-save t] + ["Save" gnus-uu-decode-save t] + ["Binhex" gnus-uu-decode-binhex t] + ["Postscript" gnus-uu-decode-postscript t] + ["All MIME parts" gnus-summary-save-parts t]) + ("Cache" + ["Enter article" gnus-cache-enter-article t] + ["Remove article" gnus-cache-remove-article t]) ["Translate" gnus-article-babel t] - ["Select article buffer" gnus-summary-select-article-buffer t] - ["Enter digest buffer" gnus-summary-enter-digest-group t] - ["Isearch article..." gnus-summary-isearch-article t] - ["Beginning of the article" gnus-summary-beginning-of-article t] - ["End of the article" gnus-summary-end-of-article t] - ["Fetch parent of article" gnus-summary-refer-parent-article t] - ["Fetch referenced articles" gnus-summary-refer-references t] - ["Fetch current thread" gnus-summary-refer-thread t] - ["Fetch article with id..." gnus-summary-refer-article t] - ["Redisplay" gnus-summary-show-article t]))) + ["Select article buffer" gnus-summary-select-article-buffer t] + ["Enter digest buffer" gnus-summary-enter-digest-group t] + ["Isearch article..." gnus-summary-isearch-article t] + ["Beginning of the article" gnus-summary-beginning-of-article t] + ["End of the article" gnus-summary-end-of-article t] + ["Fetch parent of article" gnus-summary-refer-parent-article t] + ["Fetch referenced articles" gnus-summary-refer-references t] + ["Fetch current thread" gnus-summary-refer-thread t] + ["Fetch article with id..." gnus-summary-refer-article t] + ["Setup Mailing List Params" gnus-mailing-list-insinuate t] + ["Redisplay" gnus-summary-show-article t] + ["Raw article" gnus-summary-show-raw-article :keys "C-u g"]))) (easy-menu-define - gnus-summary-article-menu gnus-summary-mode-map "" - (cons "Article" innards)) + gnus-summary-article-menu gnus-summary-mode-map "" + (cons "Article" innards)) (if (not (keymapp gnus-summary-article-menu)) (easy-menu-define @@ -1831,199 +2284,239 @@ (cons "Commands" gnus-article-commands-menu)))) (easy-menu-define - gnus-summary-thread-menu gnus-summary-mode-map "" - '("Threads" - ["Toggle threading" gnus-summary-toggle-threads t] - ["Hide threads" gnus-summary-hide-all-threads t] - ["Show threads" gnus-summary-show-all-threads t] - ["Hide thread" gnus-summary-hide-thread t] - ["Show thread" gnus-summary-show-thread t] - ["Go to next thread" gnus-summary-next-thread t] - ["Go to previous thread" gnus-summary-prev-thread t] - ["Go down thread" gnus-summary-down-thread t] - ["Go up thread" gnus-summary-up-thread t] - ["Top of thread" gnus-summary-top-thread t] - ["Mark thread as read" gnus-summary-kill-thread t] - ["Lower thread score" gnus-summary-lower-thread t] - ["Raise thread score" gnus-summary-raise-thread t] - ["Rethread current" gnus-summary-rethread-current t])) + gnus-summary-thread-menu gnus-summary-mode-map "" + '("Threads" + ["Find all messages in thread" gnus-summary-refer-thread t] + ["Toggle threading" gnus-summary-toggle-threads t] + ["Hide threads" gnus-summary-hide-all-threads t] + ["Show threads" gnus-summary-show-all-threads t] + ["Hide thread" gnus-summary-hide-thread t] + ["Show thread" gnus-summary-show-thread t] + ["Go to next thread" gnus-summary-next-thread t] + ["Go to previous thread" gnus-summary-prev-thread t] + ["Go down thread" gnus-summary-down-thread t] + ["Go up thread" gnus-summary-up-thread t] + ["Top of thread" gnus-summary-top-thread t] + ["Mark thread as read" gnus-summary-kill-thread t] + ["Lower thread score" gnus-summary-lower-thread t] + ["Raise thread score" gnus-summary-raise-thread t] + ["Rethread current" gnus-summary-rethread-current t])) (easy-menu-define - gnus-summary-post-menu gnus-summary-mode-map "" - '("Post" - ["Post an article" gnus-summary-post-news - :help "Post an article"] - ["Followup" gnus-summary-followup - :help "Post followup to this article"] - ["Followup and yank" gnus-summary-followup-with-original - :help "Post followup to this article, quoting its contents"] - ["Supersede article" gnus-summary-supersede-article t] - ["Cancel article" gnus-summary-cancel-article - :help "Cancel an article you posted"] - ["Reply" gnus-summary-reply t] - ["Reply and yank" gnus-summary-reply-with-original t] - ["Wide reply" gnus-summary-wide-reply t] - ["Wide reply and yank" gnus-summary-wide-reply-with-original - :help "Mail a reply, quoting this article"] - ["Mail forward" gnus-summary-mail-forward t] - ["Post forward" gnus-summary-post-forward t] - ["Digest and mail" gnus-uu-digest-mail-forward t] - ["Digest and post" gnus-uu-digest-post-forward t] - ["Resend message" gnus-summary-resend-message t] - ["Send bounced mail" gnus-summary-resend-bounced-mail t] - ["Send a mail" gnus-summary-mail-other-window t] - ["Uuencode and post" gnus-uu-post-news - :help "Post a uuencoded article"] - ["Followup via news" gnus-summary-followup-to-mail t] - ["Followup via news and yank" - gnus-summary-followup-to-mail-with-original t] - ;;("Draft" - ;;["Send" gnus-summary-send-draft t] - ;;["Send bounced" gnus-resend-bounced-mail t]) - )) + gnus-summary-post-menu gnus-summary-mode-map "" + `("Post" + ["Send a message (mail or news)" gnus-summary-post-news + ,@(if (featurep 'xemacs) '(t) + '(:help "Post an article"))] + ["Followup" gnus-summary-followup + ,@(if (featurep 'xemacs) '(t) + '(:help "Post followup to this article"))] + ["Followup and yank" gnus-summary-followup-with-original + ,@(if (featurep 'xemacs) '(t) + '(:help "Post followup to this article, quoting its contents"))] + ["Supersede article" gnus-summary-supersede-article t] + ["Cancel article" gnus-summary-cancel-article + ,@(if (featurep 'xemacs) '(t) + '(:help "Cancel an article you posted"))] + ["Reply" gnus-summary-reply t] + ["Reply and yank" gnus-summary-reply-with-original t] + ["Wide reply" gnus-summary-wide-reply t] + ["Wide reply and yank" gnus-summary-wide-reply-with-original + ,@(if (featurep 'xemacs) '(t) + '(:help "Mail a reply, quoting this article"))] + ["Very wide reply" gnus-summary-very-wide-reply t] + ["Very wide reply and yank" gnus-summary-very-wide-reply-with-original + ,@(if (featurep 'xemacs) '(t) + '(:help "Mail a very wide reply, quoting this article"))] + ["Mail forward" gnus-summary-mail-forward t] + ["Post forward" gnus-summary-post-forward t] + ["Digest and mail" gnus-uu-digest-mail-forward t] + ["Digest and post" gnus-uu-digest-post-forward t] + ["Resend message" gnus-summary-resend-message t] + ["Resend message edit" gnus-summary-resend-message-edit t] + ["Send bounced mail" gnus-summary-resend-bounced-mail t] + ["Send a mail" gnus-summary-mail-other-window t] + ["Create a local message" gnus-summary-news-other-window t] + ["Uuencode and post" gnus-uu-post-news + ,@(if (featurep 'xemacs) '(t) + '(:help "Post a uuencoded article"))] + ["Followup via news" gnus-summary-followup-to-mail t] + ["Followup via news and yank" + gnus-summary-followup-to-mail-with-original t] + ;;("Draft" + ;;["Send" gnus-summary-send-draft t] + ;;["Send bounced" gnus-resend-bounced-mail t]) + )) + + (cond + ((not (keymapp gnus-summary-post-menu)) + (setq gnus-article-post-menu gnus-summary-post-menu)) + ((not gnus-article-post-menu) + ;; Don't share post menu. + (setq gnus-article-post-menu + (copy-keymap gnus-summary-post-menu)))) + (define-key gnus-article-mode-map [menu-bar post] + (cons "Post" gnus-article-post-menu)) (easy-menu-define - gnus-summary-misc-menu gnus-summary-mode-map "" - '("Misc" - ("Mark Read" - ["Mark as read" gnus-summary-mark-as-read-forward t] - ["Mark same subject and select" - gnus-summary-kill-same-subject-and-select t] - ["Mark same subject" gnus-summary-kill-same-subject t] - ["Catchup" gnus-summary-catchup - :help "Mark unread articles in this group as read"] - ["Catchup all" gnus-summary-catchup-all t] - ["Catchup to here" gnus-summary-catchup-to-here t] - ["Catchup region" gnus-summary-mark-region-as-read t] - ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t]) - ("Mark Various" - ["Tick" gnus-summary-tick-article-forward t] - ["Mark as dormant" gnus-summary-mark-as-dormant t] - ["Remove marks" gnus-summary-clear-mark-forward t] - ["Set expirable mark" gnus-summary-mark-as-expirable t] - ["Set bookmark" gnus-summary-set-bookmark t] - ["Remove bookmark" gnus-summary-remove-bookmark t]) - ("Mark Limit" - ["Marks..." gnus-summary-limit-to-marks t] - ["Subject..." gnus-summary-limit-to-subject t] - ["Author..." gnus-summary-limit-to-author t] - ["Age..." gnus-summary-limit-to-age t] - ["Extra..." gnus-summary-limit-to-extra t] - ["Score" gnus-summary-limit-to-score t] - ["Unread" gnus-summary-limit-to-unread t] - ["Non-dormant" gnus-summary-limit-exclude-dormant t] - ["Articles" gnus-summary-limit-to-articles t] - ["Pop limit" gnus-summary-pop-limit t] - ["Show dormant" gnus-summary-limit-include-dormant t] - ["Hide childless dormant" - gnus-summary-limit-exclude-childless-dormant t] - ;;["Hide thread" gnus-summary-limit-exclude-thread t] - ["Hide marked" gnus-summary-limit-exclude-marks t] - ["Show expunged" gnus-summary-show-all-expunged t]) - ("Process Mark" - ["Set mark" gnus-summary-mark-as-processable t] - ["Remove mark" gnus-summary-unmark-as-processable t] - ["Remove all marks" gnus-summary-unmark-all-processable t] - ["Mark above" gnus-uu-mark-over t] - ["Mark series" gnus-uu-mark-series t] - ["Mark region" gnus-uu-mark-region t] - ["Unmark region" gnus-uu-unmark-region t] - ["Mark by regexp..." gnus-uu-mark-by-regexp t] - ["Unmark by regexp..." gnus-uu-unmark-by-regexp t] - ["Mark all" gnus-uu-mark-all t] - ["Mark buffer" gnus-uu-mark-buffer t] - ["Mark sparse" gnus-uu-mark-sparse t] - ["Mark thread" gnus-uu-mark-thread t] - ["Unmark thread" gnus-uu-unmark-thread t] - ("Process Mark Sets" - ["Kill" gnus-summary-kill-process-mark t] - ["Yank" gnus-summary-yank-process-mark - gnus-newsgroup-process-stack] - ["Save" gnus-summary-save-process-mark t])) - ("Scroll article" - ["Page forward" gnus-summary-next-page - :help "Show next page of article"] - ["Page backward" gnus-summary-prev-page - :help "Show previous page of article"] - ["Line forward" gnus-summary-scroll-up t]) - ("Move" - ["Next unread article" gnus-summary-next-unread-article t] - ["Previous unread article" gnus-summary-prev-unread-article t] - ["Next article" gnus-summary-next-article t] - ["Previous article" gnus-summary-prev-article t] - ["Next unread subject" gnus-summary-next-unread-subject t] - ["Previous unread subject" gnus-summary-prev-unread-subject t] - ["Next article same subject" gnus-summary-next-same-subject t] - ["Previous article same subject" gnus-summary-prev-same-subject t] - ["First unread article" gnus-summary-first-unread-article t] - ["Best unread article" gnus-summary-best-unread-article t] - ["Go to subject number..." gnus-summary-goto-subject t] - ["Go to article number..." gnus-summary-goto-article t] - ["Go to the last article" gnus-summary-goto-last-article t] - ["Pop article off history" gnus-summary-pop-article t]) - ("Sort" - ["Sort by number" gnus-summary-sort-by-number t] - ["Sort by author" gnus-summary-sort-by-author t] - ["Sort by subject" gnus-summary-sort-by-subject t] - ["Sort by date" gnus-summary-sort-by-date t] - ["Sort by score" gnus-summary-sort-by-score t] - ["Sort by lines" gnus-summary-sort-by-lines t] - ["Sort by characters" gnus-summary-sort-by-chars t]) - ("Help" - ["Fetch group FAQ" gnus-summary-fetch-faq t] - ["Describe group" gnus-summary-describe-group t] - ["Read manual" gnus-info-find-node t]) - ("Modes" - ["Pick and read" gnus-pick-mode t] - ["Binary" gnus-binary-mode t]) - ("Regeneration" - ["Regenerate" gnus-summary-prepare t] - ["Insert cached articles" gnus-summary-insert-cached-articles t] - ["Toggle threading" gnus-summary-toggle-threads t]) - ["Filter articles..." gnus-summary-execute-command t] - ["Run command on subjects..." gnus-summary-universal-argument t] - ["Search articles forward..." gnus-summary-search-article-forward t] - ["Search articles backward..." gnus-summary-search-article-backward t] - ["Toggle line truncation" gnus-summary-toggle-truncation t] - ["Expand window" gnus-summary-expand-window t] - ["Expire expirable articles" gnus-summary-expire-articles - (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name)] - ["Edit local kill file" gnus-summary-edit-local-kill t] - ["Edit main kill file" gnus-summary-edit-global-kill t] - ["Edit group parameters" gnus-summary-edit-parameters t] - ["Customize group parameters" gnus-summary-customize-parameters t] - ["Send a bug report" gnus-bug t] - ("Exit" - ["Catchup and exit" gnus-summary-catchup-and-exit - :help "Mark unread articles in this group as read, then exit"] - ["Catchup all and exit" gnus-summary-catchup-all-and-exit t] - ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] - ["Exit group" gnus-summary-exit - :help "Exit current group, return to group selection mode"] - ["Exit group without updating" gnus-summary-exit-no-update t] - ["Exit and goto next group" gnus-summary-next-group t] - ["Exit and goto prev group" gnus-summary-prev-group t] - ["Reselect group" gnus-summary-reselect-current-group t] - ["Rescan group" gnus-summary-rescan-group t] - ["Update dribble" gnus-summary-save-newsrc t]))) + gnus-summary-misc-menu gnus-summary-mode-map "" + `("Gnus" + ("Mark Read" + ["Mark as read" gnus-summary-mark-as-read-forward t] + ["Mark same subject and select" + gnus-summary-kill-same-subject-and-select t] + ["Mark same subject" gnus-summary-kill-same-subject t] + ["Catchup" gnus-summary-catchup + ,@(if (featurep 'xemacs) '(t) + '(:help "Mark unread articles in this group as read"))] + ["Catchup all" gnus-summary-catchup-all t] + ["Catchup to here" gnus-summary-catchup-to-here t] + ["Catchup from here" gnus-summary-catchup-from-here t] + ["Catchup region" gnus-summary-mark-region-as-read + (gnus-mark-active-p)] + ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t]) + ("Mark Various" + ["Tick" gnus-summary-tick-article-forward t] + ["Mark as dormant" gnus-summary-mark-as-dormant t] + ["Remove marks" gnus-summary-clear-mark-forward t] + ["Set expirable mark" gnus-summary-mark-as-expirable t] + ["Set bookmark" gnus-summary-set-bookmark t] + ["Remove bookmark" gnus-summary-remove-bookmark t]) + ("Limit to" + ["Marks..." gnus-summary-limit-to-marks t] + ["Subject..." gnus-summary-limit-to-subject t] + ["Author..." gnus-summary-limit-to-author t] + ["Age..." gnus-summary-limit-to-age t] + ["Extra..." gnus-summary-limit-to-extra t] + ["Score..." gnus-summary-limit-to-score t] + ["Display Predicate" gnus-summary-limit-to-display-predicate t] + ["Unread" gnus-summary-limit-to-unread t] + ["Unseen" gnus-summary-limit-to-unseen t] + ["Non-dormant" gnus-summary-limit-exclude-dormant t] + ["Next articles" gnus-summary-limit-to-articles t] + ["Pop limit" gnus-summary-pop-limit t] + ["Show dormant" gnus-summary-limit-include-dormant t] + ["Hide childless dormant" + gnus-summary-limit-exclude-childless-dormant t] + ;;["Hide thread" gnus-summary-limit-exclude-thread t] + ["Hide marked" gnus-summary-limit-exclude-marks t] + ["Show expunged" gnus-summary-limit-include-expunged t]) + ("Process Mark" + ["Set mark" gnus-summary-mark-as-processable t] + ["Remove mark" gnus-summary-unmark-as-processable t] + ["Remove all marks" gnus-summary-unmark-all-processable t] + ["Mark above" gnus-uu-mark-over t] + ["Mark series" gnus-uu-mark-series t] + ["Mark region" gnus-uu-mark-region (gnus-mark-active-p)] + ["Unmark region" gnus-uu-unmark-region (gnus-mark-active-p)] + ["Mark by regexp..." gnus-uu-mark-by-regexp t] + ["Unmark by regexp..." gnus-uu-unmark-by-regexp t] + ["Mark all" gnus-uu-mark-all t] + ["Mark buffer" gnus-uu-mark-buffer t] + ["Mark sparse" gnus-uu-mark-sparse t] + ["Mark thread" gnus-uu-mark-thread t] + ["Unmark thread" gnus-uu-unmark-thread t] + ("Process Mark Sets" + ["Kill" gnus-summary-kill-process-mark t] + ["Yank" gnus-summary-yank-process-mark + gnus-newsgroup-process-stack] + ["Save" gnus-summary-save-process-mark t] + ["Run command on marked..." gnus-summary-universal-argument t])) + ("Scroll article" + ["Page forward" gnus-summary-next-page + ,@(if (featurep 'xemacs) '(t) + '(:help "Show next page of article"))] + ["Page backward" gnus-summary-prev-page + ,@(if (featurep 'xemacs) '(t) + '(:help "Show previous page of article"))] + ["Line forward" gnus-summary-scroll-up t]) + ("Move" + ["Next unread article" gnus-summary-next-unread-article t] + ["Previous unread article" gnus-summary-prev-unread-article t] + ["Next article" gnus-summary-next-article t] + ["Previous article" gnus-summary-prev-article t] + ["Next unread subject" gnus-summary-next-unread-subject t] + ["Previous unread subject" gnus-summary-prev-unread-subject t] + ["Next article same subject" gnus-summary-next-same-subject t] + ["Previous article same subject" gnus-summary-prev-same-subject t] + ["First unread article" gnus-summary-first-unread-article t] + ["Best unread article" gnus-summary-best-unread-article t] + ["Go to subject number..." gnus-summary-goto-subject t] + ["Go to article number..." gnus-summary-goto-article t] + ["Go to the last article" gnus-summary-goto-last-article t] + ["Pop article off history" gnus-summary-pop-article t]) + ("Sort" + ["Sort by number" gnus-summary-sort-by-number t] + ["Sort by author" gnus-summary-sort-by-author t] + ["Sort by subject" gnus-summary-sort-by-subject t] + ["Sort by date" gnus-summary-sort-by-date t] + ["Sort by score" gnus-summary-sort-by-score t] + ["Sort by lines" gnus-summary-sort-by-lines t] + ["Sort by characters" gnus-summary-sort-by-chars t] + ["Randomize" gnus-summary-sort-by-random t] + ["Original sort" gnus-summary-sort-by-original t]) + ("Help" + ["Fetch group FAQ" gnus-summary-fetch-faq t] + ["Describe group" gnus-summary-describe-group t] + ["Fetch charter" gnus-group-fetch-charter + ,@(if (featurep 'xemacs) nil + '(:help "Display the charter of the current group"))] + ["Fetch control message" gnus-group-fetch-control + ,@(if (featurep 'xemacs) nil + '(:help "Display the archived control message for the current group"))] + ["Read manual" gnus-info-find-node t]) + ("Modes" + ["Pick and read" gnus-pick-mode t] + ["Binary" gnus-binary-mode t]) + ("Regeneration" + ["Regenerate" gnus-summary-prepare t] + ["Insert cached articles" gnus-summary-insert-cached-articles t] + ["Insert dormant articles" gnus-summary-insert-dormant-articles t] + ["Toggle threading" gnus-summary-toggle-threads t]) + ["See old articles" gnus-summary-insert-old-articles t] + ["See new articles" gnus-summary-insert-new-articles t] + ["Filter articles..." gnus-summary-execute-command t] + ["Run command on articles..." gnus-summary-universal-argument t] + ["Search articles forward..." gnus-summary-search-article-forward t] + ["Search articles backward..." gnus-summary-search-article-backward t] + ["Toggle line truncation" gnus-summary-toggle-truncation t] + ["Expand window" gnus-summary-expand-window t] + ["Expire expirable articles" gnus-summary-expire-articles + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)] + ["Edit local kill file" gnus-summary-edit-local-kill t] + ["Edit main kill file" gnus-summary-edit-global-kill t] + ["Edit group parameters" gnus-summary-edit-parameters t] + ["Customize group parameters" gnus-summary-customize-parameters t] + ["Send a bug report" gnus-bug t] + ("Exit" + ["Catchup and exit" gnus-summary-catchup-and-exit + ,@(if (featurep 'xemacs) '(t) + '(:help "Mark unread articles in this group as read, then exit"))] + ["Catchup all and exit" gnus-summary-catchup-all-and-exit t] + ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] + ["Exit group" gnus-summary-exit + ,@(if (featurep 'xemacs) '(t) + '(:help "Exit current group, return to group selection mode"))] + ["Exit group without updating" gnus-summary-exit-no-update t] + ["Exit and goto next group" gnus-summary-next-group t] + ["Exit and goto prev group" gnus-summary-prev-group t] + ["Reselect group" gnus-summary-reselect-current-group t] + ["Rescan group" gnus-summary-rescan-group t] + ["Update dribble" gnus-summary-save-newsrc t]))) (gnus-run-hooks 'gnus-summary-menu-hook))) (defvar gnus-summary-tool-bar-map nil) ;; Emacs 21 tool bar. Should be no-op otherwise. -;; NB: A new function tool-bar-local-item-from-menu is added in Emacs -;; 21.2.50+. Considering many users use Emacs 21, use -;; tool-bar-add-item-from-menu here. (defun gnus-summary-make-tool-bar () - (if (and - (condition-case nil (require 'tool-bar) (error nil)) - (fboundp 'tool-bar-add-item-from-menu) - (default-value 'tool-bar-mode) - (not gnus-summary-tool-bar-map)) + (if (and (fboundp 'tool-bar-add-item-from-menu) + (default-value 'tool-bar-mode) + (not gnus-summary-tool-bar-map)) (setq gnus-summary-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) + (let ((tool-bar-map (make-sparse-keymap)) + (load-path (mm-image-load-path))) (tool-bar-add-item-from-menu 'gnus-summary-prev-unread "prev-ur" gnus-summary-mode-map) (tool-bar-add-item-from-menu @@ -2156,7 +2649,7 @@ respectively. You can also post articles and send mail from this buffer. To -follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author +follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author of an article, type `\\[gnus-summary-reply]'. There are approx. one gazillion commands you can execute in this @@ -2171,6 +2664,8 @@ (gnus-summary-make-menu-bar) (gnus-summary-make-tool-bar)) (gnus-summary-make-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-make-local-variables)) (gnus-make-thread-indent-array) (gnus-simplify-mode-line) (setq major-mode 'gnus-summary-mode) @@ -2190,9 +2685,10 @@ (make-local-variable 'gnus-summary-dummy-line-format) (make-local-variable 'gnus-summary-dummy-line-format-spec) (make-local-variable 'gnus-summary-mark-positions) - (make-local-hook 'pre-command-hook) + (gnus-make-local-hook 'pre-command-hook) (add-hook 'pre-command-hook 'gnus-set-global-variables nil t) (gnus-run-hooks 'gnus-summary-mode-hook) + (turn-on-gnus-mailing-list-mode) (mm-enable-multibyte) (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) (gnus-update-summary-mark-positions)) @@ -2290,7 +2786,7 @@ (setq gnus-newsgroup-data (nconc list gnus-newsgroup-data)) (when offset (gnus-data-update-list odata offset))) - ;; Find the last element in the list to be spliced into the main + ;; Find the last element in the list to be spliced into the main ;; list. (while (cdr list) (setq list (cdr list))) @@ -2352,7 +2848,7 @@ (defun gnus-article-parent-p (number) "Say whether this article is a parent or not." (let ((data (gnus-data-find-list number))) - (and (cdr data) ; There has to be an article after... + (and (cdr data) ; There has to be an article after... (< (gnus-data-level (car data)) ; And it has to have a higher level. (gnus-data-level (nth 1 data)))))) @@ -2380,6 +2876,7 @@ (defun gnus-article-read-p (article) "Say whether ARTICLE is read or not." (not (or (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-spam-marked) (memq article gnus-newsgroup-unreads) (memq article gnus-newsgroup-unselected) (memq article gnus-newsgroup-dormant)))) @@ -2470,6 +2967,7 @@ This is all marks except unread, ticked, dormant, and expirable." (not (or (= mark gnus-unread-mark) (= mark gnus-ticked-mark) + (= mark gnus-spam-mark) (= mark gnus-dormant-mark) (= mark gnus-expirable-mark)))) @@ -2481,10 +2979,10 @@ marks of articles." `(cond ((memq ,number gnus-newsgroup-unsendable) gnus-unsendable-mark) - ((memq ,number gnus-newsgroup-undownloaded) gnus-undownloaded-mark) ((memq ,number gnus-newsgroup-downloadable) gnus-downloadable-mark) ((memq ,number gnus-newsgroup-unreads) gnus-unread-mark) ((memq ,number gnus-newsgroup-marked) gnus-ticked-mark) + ((memq ,number gnus-newsgroup-spam-marked) gnus-spam-mark) ((memq ,number gnus-newsgroup-dormant) gnus-dormant-mark) ((memq ,number gnus-newsgroup-expirable) gnus-expirable-mark) (t (or (cdr (assq ,number gnus-newsgroup-reads)) @@ -2492,9 +2990,6 @@ ;; Saving hidden threads. -(put 'gnus-save-hidden-threads 'lisp-indent-function 0) -(put 'gnus-save-hidden-threads 'edebug-form-spec '(body)) - (defmacro gnus-save-hidden-threads (&rest forms) "Save hidden threads, eval FORMS, and restore the hidden threads." (let ((config (make-symbol "config"))) @@ -2503,6 +2998,8 @@ (save-excursion ,@forms) (gnus-restore-hidden-threads-configuration ,config))))) +(put 'gnus-save-hidden-threads 'lisp-indent-function 0) +(put 'gnus-save-hidden-threads 'edebug-form-spec '(body)) (defun gnus-data-compute-positions () "Compute the positions of all articles." @@ -2558,7 +3055,7 @@ ;; Nix out all the control chars... (while (>= (setq i (1- i)) 0) (aset table i [??])) - ;; ... but not newline and cr, of course. (cr is necessary for the + ;; ... but not newline and cr, of course. (cr is necessary for the ;; selective display). (aset table ?\n nil) (aset table ?\r nil) @@ -2572,9 +3069,29 @@ (aset table i [??])))) (setq buffer-display-table table))) +(defun gnus-summary-set-article-display-arrow (pos) + "Update the overlay arrow to point to line at position POS." + (when (and gnus-summary-display-arrow + (boundp 'overlay-arrow-position) + (boundp 'overlay-arrow-string)) + (save-excursion + (goto-char pos) + (beginning-of-line) + (unless overlay-arrow-position + (setq overlay-arrow-position (make-marker))) + (setq overlay-arrow-string "=>" + overlay-arrow-position (set-marker overlay-arrow-position + (point) + (current-buffer)))))) + (defun gnus-summary-setup-buffer (group) "Initialize summary buffer." - (let ((buffer (concat "*Summary " group "*"))) + (let ((buffer (gnus-summary-buffer-name group)) + (dead-name (concat "*Dead Summary " + (gnus-group-decoded-name group) "*"))) + ;; If a dead summary buffer exists, we kill it. + (when (gnus-buffer-live-p dead-name) + (gnus-kill-buffer dead-name)) (if (get-buffer buffer) (progn (set-buffer buffer) @@ -2590,6 +3107,8 @@ (make-local-variable 'gnus-article-current) (make-local-variable 'gnus-original-article-buffer)) (setq gnus-newsgroup-name group) + ;; Set any local variables in the group parameters. + (gnus-summary-set-local-parameters gnus-newsgroup-name) t))) (defun gnus-set-global-variables () @@ -2600,6 +3119,7 @@ (setq gnus-summary-buffer (current-buffer)) (let ((name gnus-newsgroup-name) (marked gnus-newsgroup-marked) + (spam gnus-newsgroup-spam-marked) (unread gnus-newsgroup-unreads) (headers gnus-current-headers) (data gnus-newsgroup-data) @@ -2609,11 +3129,20 @@ (gac gnus-article-current) (reffed gnus-reffed-article-number) (score-file gnus-current-score-file) - (default-charset gnus-newsgroup-charset)) + (default-charset gnus-newsgroup-charset) + vlist) + (let ((locals gnus-newsgroup-variables)) + (while locals + (if (consp (car locals)) + (push (eval (caar locals)) vlist) + (push (eval (car locals)) vlist)) + (setq locals (cdr locals))) + (setq vlist (nreverse vlist))) (save-excursion (set-buffer gnus-group-buffer) (setq gnus-newsgroup-name name gnus-newsgroup-marked marked + gnus-newsgroup-spam-marked spam gnus-newsgroup-unreads unread gnus-current-headers headers gnus-newsgroup-data data @@ -2624,6 +3153,12 @@ gnus-reffed-article-number reffed gnus-current-score-file score-file gnus-newsgroup-charset default-charset) + (let ((locals gnus-newsgroup-variables)) + (while locals + (if (consp (car locals)) + (set (caar locals) (pop vlist)) + (set (car locals) (pop vlist))) + (setq locals (cdr locals)))) ;; The article buffer also has local variables. (when (gnus-buffer-live-p gnus-article-buffer) (set-buffer gnus-article-buffer) @@ -2665,15 +3200,16 @@ (let ((gnus-replied-mark 129) (gnus-score-below-mark 130) (gnus-score-over-mark 130) - (gnus-download-mark 131) + (gnus-undownloaded-mark 131) (spec gnus-summary-line-format-spec) gnus-visual pos) (save-excursion (gnus-set-work-buffer) (let ((gnus-summary-line-format-spec spec) - (gnus-newsgroup-downloadable '((0 . t)))) + (gnus-newsgroup-downloadable '(0))) (gnus-summary-insert-line - [0 "" "" "" "" "" 0 0 "" nil] 0 nil 128 t nil "" nil 1) + [0 "" "" "05 Apr 2001 23:33:09 +0400" "" "" 0 0 "" nil] + 0 nil t 128 t nil "" nil 1) (goto-char (point-min)) (setq pos (list (cons 'unread (and (search-forward "\200" nil t) (- (point) (point-min) 1))))) @@ -2699,36 +3235,36 @@ (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) -(defun gnus-summary-from-or-to-or-newsgroups (header) - (let ((to (cdr (assq 'To (mail-header-extra header)))) - (newsgroups (cdr (assq 'Newsgroups (mail-header-extra header)))) - (mail-parse-charset gnus-newsgroup-charset) +(defun gnus-summary-extract-address-component (from) + (or (car (funcall gnus-extract-address-components from)) + from)) + +(defun gnus-summary-from-or-to-or-newsgroups (header gnus-tmp-from) + (let ((mail-parse-charset gnus-newsgroup-charset) + ; Is it really necessary to do this next part for each summary line? + ; Luckily, doesn't seem to slow things down much. (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-ignored-charsets))) - (cond - ((and to - gnus-ignored-from-addresses - (string-match gnus-ignored-from-addresses - (mail-header-from header))) - (concat "-> " - (or (car (funcall gnus-extract-address-components - (funcall - gnus-decode-encoded-word-function to))) - (funcall gnus-decode-encoded-word-function to)))) - ((and newsgroups - gnus-ignored-from-addresses - (string-match gnus-ignored-from-addresses - (mail-header-from header))) - (concat "=> " newsgroups)) - (t - (or (car (funcall gnus-extract-address-components - (mail-header-from header))) - (mail-header-from header)))))) + (or + (and gnus-ignored-from-addresses + (string-match gnus-ignored-from-addresses gnus-tmp-from) + (let ((extra-headers (mail-header-extra header)) + to + newsgroups) + (cond + ((setq to (cdr (assq 'To extra-headers))) + (concat "-> " + (inline + (gnus-summary-extract-address-component + (funcall gnus-decode-encoded-word-function to))))) + ((setq newsgroups (cdr (assq 'Newsgroups extra-headers))) + (concat "=> " newsgroups))))) + (inline (gnus-summary-extract-address-component gnus-tmp-from))))) (defun gnus-summary-insert-line (gnus-tmp-header gnus-tmp-level gnus-tmp-current - gnus-tmp-unread gnus-tmp-replied + undownloaded gnus-tmp-unread gnus-tmp-replied gnus-tmp-expirable gnus-tmp-subject-or-nil &optional gnus-tmp-dummy gnus-tmp-score gnus-tmp-process) @@ -2739,43 +3275,58 @@ (if (or (null gnus-summary-default-score) (<= (abs (- gnus-tmp-score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? ;Whitespace + ? ;Whitespace (if (< gnus-tmp-score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark))) + (gnus-tmp-number (mail-header-number gnus-tmp-header)) (gnus-tmp-replied (cond (gnus-tmp-process gnus-process-mark) ((memq gnus-tmp-current gnus-newsgroup-cached) gnus-cached-mark) (gnus-tmp-replied gnus-replied-mark) + ((memq gnus-tmp-current gnus-newsgroup-forwarded) + gnus-forwarded-mark) ((memq gnus-tmp-current gnus-newsgroup-saved) gnus-saved-mark) - (t gnus-unread-mark))) + ((memq gnus-tmp-number gnus-newsgroup-recent) + gnus-recent-mark) + ((memq gnus-tmp-number gnus-newsgroup-unseen) + gnus-unseen-mark) + (t gnus-no-mark))) + (gnus-tmp-downloaded + (cond (undownloaded + gnus-undownloaded-mark) + (gnus-newsgroup-agentized + gnus-downloaded-mark) + (t + gnus-no-mark))) (gnus-tmp-from (mail-header-from gnus-tmp-header)) (gnus-tmp-name (cond ((string-match "<[^>]+> *$" gnus-tmp-from) (let ((beg (match-beginning 0))) - (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) - (substring gnus-tmp-from (1+ (match-beginning 0)) - (1- (match-end 0)))) + (or (and (string-match "^\".+\"" gnus-tmp-from) + (substring gnus-tmp-from 1 (1- (match-end 0)))) (substring gnus-tmp-from 0 beg)))) ((string-match "(.+)" gnus-tmp-from) (substring gnus-tmp-from (1+ (match-beginning 0)) (1- (match-end 0)))) (t gnus-tmp-from))) (gnus-tmp-subject (mail-header-subject gnus-tmp-header)) - (gnus-tmp-number (mail-header-number gnus-tmp-header)) (gnus-tmp-opening-bracket (if gnus-tmp-dummy ?\< ?\[)) (gnus-tmp-closing-bracket (if gnus-tmp-dummy ?\> ?\])) (buffer-read-only nil)) (when (string= gnus-tmp-name "") (setq gnus-tmp-name gnus-tmp-from)) (unless (numberp gnus-tmp-lines) - (setq gnus-tmp-lines 0)) - (gnus-put-text-property + (setq gnus-tmp-lines -1)) + (if (= gnus-tmp-lines -1) + (setq gnus-tmp-lines "?") + (setq gnus-tmp-lines (number-to-string gnus-tmp-lines))) + (gnus-put-text-property (point) (progn (eval gnus-summary-line-format-spec) (point)) - 'gnus-number gnus-tmp-number) + 'gnus-number gnus-tmp-number) (when (gnus-visual-p 'summary-highlight 'highlight) (forward-line -1) (gnus-run-hooks 'gnus-summary-update-hook) @@ -2804,7 +3355,7 @@ (if (or (null gnus-summary-default-score) (<= (abs (- score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? ;Whitespace + ? ;Whitespace (if (< score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark)) 'score)) @@ -2819,7 +3370,7 @@ This may be 0 in some cases -- if none of the articles in the thread are to be displayed." (let* ((number - ;; Fix by Luc Van Eycken <Luc.VanEycken@esat.kuleuven.ac.be>. + ;; Fix by Luc Van Eycken <Luc.VanEycken@esat.kuleuven.ac.be>. (cond ((not (listp thread)) 1) @@ -2842,9 +3393,22 @@ gnus-empty-thread-mark) number))) +(defsubst gnus-summary-line-message-size (head) + "Return pretty-printed version of message size. +This function is intended to be used in +`gnus-summary-line-format-alist'." + (let ((c (or (mail-header-chars head) -1))) + (cond ((< c 0) "n/a") ; chars not available + ((< c (* 1000 10)) (format "%1.1fk" (/ c 1024.0))) + ((< c (* 1000 100)) (format "%dk" (/ c 1024.0))) + ((< c (* 1000 10000)) (format "%1.1fM" (/ c (* 1024.0 1024)))) + (t (format "%dM" (/ c (* 1024.0 1024))))))) + + (defun gnus-summary-set-local-parameters (group) "Go through the local params of GROUP and set all variable specs in that list." (let ((params (gnus-group-find-parameter group)) + (vars '(quit-config)) ; Ignore quit-config. elem) (while params (setq elem (car params) @@ -2852,8 +3416,9 @@ (and (consp elem) ; Has to be a cons. (consp (cdr elem)) ; The cdr has to be a list. (symbolp (car elem)) ; Has to be a symbol in there. - (not (memq (car elem) '(quit-config))) ; Ignore quit-config. + (not (memq (car elem) vars)) (ignore-errors ; So we set it. + (push (car elem) vars) (make-local-variable (car elem)) (set (car elem) (eval (nth 1 elem)))))))) @@ -2890,10 +3455,11 @@ kill-buffer no-display &optional select-articles) ;; Killed foreign groups can't be entered. - (when (and (not (gnus-group-native-p group)) - (not (gnus-gethash group gnus-newsrc-hashtb))) - (error "Dead non-native groups can't be entered")) - (gnus-message 5 "Retrieving newsgroup: %s..." group) + ;; (when (and (not (gnus-group-native-p group)) + ;; (not (gnus-gethash group gnus-newsrc-hashtb))) + ;; (error "Dead non-native groups can't be entered")) + (gnus-message 5 "Retrieving newsgroup: %s..." + (gnus-group-decoded-name group)) (let* ((new-group (gnus-summary-setup-buffer group)) (quit-config (gnus-group-quit-config group)) (did-select (and new-group (gnus-select-newsgroup @@ -2923,7 +3489,11 @@ (gnus-group-jump-to-group group) (gnus-group-next-unread-group 1)) (gnus-handle-ephemeral-exit quit-config))) - (gnus-message 3 "Can't select group") + (let ((grpinfo (gnus-get-info group))) + (if (null (gnus-info-read grpinfo)) + (gnus-message 3 "Group %s contains no messages" + (gnus-group-decoded-name group)) + (gnus-message 3 "Can't select group"))) nil) ;; The user did a `C-g' while prompting for number of articles, ;; so we exit this group. @@ -2951,8 +3521,6 @@ (gnus-active gnus-newsgroup-name))) ;; You can change the summary buffer in some way with this hook. (gnus-run-hooks 'gnus-select-group-hook) - ;; Set any local variables in the group parameters. - (gnus-summary-set-local-parameters gnus-newsgroup-name) (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) (gnus-update-summary-mark-positions) @@ -3004,11 +3572,10 @@ ;; Hide conversation thread subtrees. We cannot do this in ;; gnus-summary-prepare-hook since kill processing may not ;; work with hidden articles. - (and gnus-show-threads - gnus-thread-hide-subtree - (gnus-summary-hide-all-threads)) + (gnus-summary-maybe-hide-threads) (when kill-buffer (gnus-kill-or-deaden-summary kill-buffer)) + (gnus-summary-auto-select-subject) ;; Show first unread article if requested. (if (and (not no-article) (not no-display) @@ -3016,20 +3583,17 @@ gnus-auto-select-first) (progn (gnus-configure-windows 'summary) - (cond - ((eq gnus-auto-select-first 'best) - (gnus-summary-best-unread-article)) - ((eq gnus-auto-select-first t) - (gnus-summary-first-unread-article)) - ((gnus-functionp gnus-auto-select-first) - (funcall gnus-auto-select-first)))) - ;; Don't select any articles, just move point to the first - ;; article in the group. - (goto-char (point-min)) + (let ((art (gnus-summary-article-number))) + (unless (and (not gnus-plugged) + (or (memq art gnus-newsgroup-undownloaded) + (memq art gnus-newsgroup-downloadable))) + (gnus-summary-goto-article art)))) + ;; Don't select any articles. (gnus-summary-position-point) (gnus-configure-windows 'summary 'force) (gnus-set-mode-line 'summary)) - (when (get-buffer-window gnus-group-buffer t) + (when (and gnus-auto-center-group + (get-buffer-window gnus-group-buffer t)) ;; Gotta use windows, because recenter does weird stuff if ;; the current buffer ain't the displayed window. (let ((owin (selected-window))) @@ -3040,8 +3604,28 @@ ;; Mark this buffer as "prepared". (setq gnus-newsgroup-prepared t) (gnus-run-hooks 'gnus-summary-prepared-hook) + (unless (gnus-ephemeral-group-p group) + (gnus-group-update-group group)) t))))) +(defun gnus-summary-auto-select-subject () + "Select the subject line on initial group entry." + (goto-char (point-min)) + (cond + ((eq gnus-auto-select-subject 'best) + (gnus-summary-best-unread-subject)) + ((eq gnus-auto-select-subject 'unread) + (gnus-summary-first-unread-subject)) + ((eq gnus-auto-select-subject 'unseen) + (gnus-summary-first-unseen-subject)) + ((eq gnus-auto-select-subject 'unseen-or-unread) + (gnus-summary-first-unseen-or-unread-subject)) + ((eq gnus-auto-select-subject 'first) + ;; Do nothing. + ) + ((functionp gnus-auto-select-subject) + (funcall gnus-auto-select-subject)))) + (defun gnus-summary-prepare () "Generate the summary buffer." (interactive) @@ -3066,7 +3650,7 @@ (gnus-run-hooks 'gnus-summary-prepare-hook))) (defsubst gnus-general-simplify-subject (subject) - "Simply subject by the same rules as gnus-gather-threads-by-subject." + "Simplify subject by the same rules as `gnus-gather-threads-by-subject'." (setq subject (cond ;; Truncate the subject. @@ -3086,7 +3670,7 @@ (if (and gnus-summary-gather-exclude-subject (string-match gnus-summary-gather-exclude-subject subject)) - nil ; This article shouldn't be gathered + nil ; This article shouldn't be gathered subject)) (defun gnus-summary-simplify-subject-query () @@ -3122,7 +3706,16 @@ (setcdr prev (cdr threads)) (setq threads prev)) ;; Enter this thread into the hash table. - (gnus-sethash subject threads hashtb))) + (gnus-sethash subject + (if gnus-summary-make-false-root-always + (progn + ;; If you want a dummy root above all + ;; threads... + (setcar threads (list whole-subject + (car threads))) + threads) + threads) + hashtb))) (setq prev threads) (setq threads (cdr threads))) result))) @@ -3137,7 +3730,7 @@ (while threads (when (setq references (mail-header-references (caar threads))) (setq id (mail-header-id (caar threads)) - ids (gnus-split-references references) + ids (inline (gnus-split-references references)) entered nil) (while (setq ref (pop ids)) (setq ids (delete ref ids)) @@ -3221,8 +3814,8 @@ (setq threads nil) (throw 'infloop t)) (unless (car (symbol-value refs)) - ;; These threads do not refer back to any other articles, - ;; so they're roots. + ;; These threads do not refer back to any other + ;; articles, so they're roots. (setq threads (append (cdr (symbol-value refs)) threads)))) gnus-newsgroup-dependencies))) threads)) @@ -3236,13 +3829,13 @@ If `gnus-summary-ignore-duplicates' is nil then duplicate Message-IDs will not be entered in the DEPENDENCIES table. Otherwise duplicate -Message-IDs will be renamed be renamed to a unique Message-ID before -being entered. +Message-IDs will be renamed to a unique Message-ID before being +entered. Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (let* ((id (mail-header-id header)) (id-dep (and id (intern id dependencies))) - ref ref-dep ref-header) + parent-id ref ref-dep ref-header replaced) ;; Enter this `header' in the `dependencies' table. (cond ((not id-dep) @@ -3259,7 +3852,8 @@ (force-new ;; Overrides an existing entry; ;; just set the header part of the entry. - (setcar (symbol-value id-dep) header)) + (setcar (symbol-value id-dep) header) + (setq replaced t)) ;; Renames the existing `header' to a unique Message-ID. ((not gnus-summary-ignore-duplicates) @@ -3282,9 +3876,10 @@ (or (mail-header-xref header) ""))) (setq header nil))) - (when header - ;; First check if that we are not creating a References loop. - (setq ref (gnus-parent-id (mail-header-references header))) + (when (and header (not replaced)) + ;; First check that we are not creating a References loop. + (setq parent-id (gnus-parent-id (mail-header-references header))) + (setq ref parent-id) (while (and ref (setq ref-dep (intern-soft ref dependencies)) (boundp ref-dep) @@ -3294,10 +3889,10 @@ ;; root article. (progn (mail-header-set-references (car (symbol-value id-dep)) "none") - (setq ref nil)) + (setq ref nil) + (setq parent-id nil)) (setq ref (gnus-parent-id (mail-header-references ref-header))))) - (setq ref (gnus-parent-id (mail-header-references header))) - (setq ref-dep (intern (or ref "none") dependencies)) + (setq ref-dep (intern (or parent-id "none") dependencies)) (if (boundp ref-dep) (setcdr (symbol-value ref-dep) (nconc (cdr (symbol-value ref-dep)) @@ -3305,6 +3900,11 @@ (set ref-dep (list nil (symbol-value id-dep))))) header)) +(defun gnus-extract-message-id-from-in-reply-to (string) + (if (string-match "<[^>]+>" string) + (substring string (match-beginning 0) (match-end 0)) + nil)) + (defun gnus-build-sparse-threads () (let ((headers gnus-newsgroup-headers) (mail-parse-charset gnus-newsgroup-charset) @@ -3376,16 +3976,23 @@ (setq heads nil))))) gnus-newsgroup-dependencies))) +(defsubst gnus-remove-odd-characters (string) + "Translate STRING into something that doesn't contain weird characters." + (mm-subst-char-in-string + ?\r ?\- + (mm-subst-char-in-string + ?\n ?\- string))) + ;; This function has to be called with point after the article number ;; on the beginning of the line. (defsubst gnus-nov-parse-line (number dependencies &optional force-new) (let ((eol (gnus-point-at-eol)) (buffer (current-buffer)) - header) + header references in-reply-to) ;; overview: [num subject from date id refs chars lines misc] (unwind-protect - (progn + (let (x) (narrow-to-region (point) eol) (unless (eobp) (forward-char)) @@ -3393,13 +4000,19 @@ (setq header (make-full-mail-header number ; number - (funcall gnus-decode-encoded-word-function - (nnheader-nov-field)) ; subject - (funcall gnus-decode-encoded-word-function - (nnheader-nov-field)) ; from + (condition-case () ; subject + (gnus-remove-odd-characters + (funcall gnus-decode-encoded-word-function + (setq x (nnheader-nov-field)))) + (error x)) + (condition-case () ; from + (gnus-remove-odd-characters + (funcall gnus-decode-encoded-word-function + (setq x (nnheader-nov-field)))) + (error x)) (nnheader-nov-field) ; date (nnheader-nov-read-message-id) ; id - (nnheader-nov-field) ; refs + (setq references (nnheader-nov-field)) ; refs (nnheader-nov-read-integer) ; chars (nnheader-nov-read-integer) ; lines (unless (eobp) @@ -3410,6 +4023,12 @@ (widen)) + (when (and (string= references "") + (setq in-reply-to (mail-header-extra header)) + (setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to)))) + (mail-header-set-references + header (gnus-extract-message-id-from-in-reply-to in-reply-to))) + (when gnus-alter-header-function (funcall gnus-alter-header-function header)) (gnus-dependencies-add-header header dependencies force-new))) @@ -3444,7 +4063,9 @@ (push header gnus-newsgroup-headers) (if (memq number gnus-newsgroup-unselected) (progn - (push number gnus-newsgroup-unreads) + (setq gnus-newsgroup-unreads + (gnus-add-to-sorted-list gnus-newsgroup-unreads + number)) (setq gnus-newsgroup-unselected (delq number gnus-newsgroup-unselected))) (push number gnus-newsgroup-ancient))))))) @@ -3470,14 +4091,16 @@ (if (memq (setq article (mail-header-number header)) gnus-newsgroup-unselected) (progn - (push article gnus-newsgroup-unreads) + (setq gnus-newsgroup-unreads + (gnus-add-to-sorted-list + gnus-newsgroup-unreads article)) (setq gnus-newsgroup-unselected (delq article gnus-newsgroup-unselected))) (push article gnus-newsgroup-ancient))) (forward-line 1))))))) (defun gnus-summary-update-article-line (article header) - "Update the line for ARTICLE using HEADERS." + "Update the line for ARTICLE using HEADER." (let* ((id (mail-header-id header)) (thread (gnus-id-to-thread id))) (unless thread @@ -3487,38 +4110,41 @@ (gnus-summary-goto-subject article) (let* ((datal (gnus-data-find-list article)) (data (car datal)) - (length (when (cdr datal) - (- (gnus-data-pos data) - (gnus-data-pos (cadr datal))))) (buffer-read-only nil) (level (gnus-summary-thread-level))) (gnus-delete-line) - (gnus-summary-insert-line - header level nil (gnus-article-mark article) - (memq article gnus-newsgroup-replied) - (memq article gnus-newsgroup-expirable) - ;; Only insert the Subject string when it's different - ;; from the previous Subject string. - (if (and - gnus-show-threads - (gnus-subject-equal - (condition-case () - (mail-header-subject - (gnus-data-header - (cadr - (gnus-data-find-list - article - (gnus-data-list t))))) - ;; Error on the side of excessive subjects. - (error "")) - (mail-header-subject header))) - "" - (mail-header-subject header)) - nil (cdr (assq article gnus-newsgroup-scored)) - (memq article gnus-newsgroup-processable)) - (when length - (gnus-data-update-list - (cdr datal) (- length (- (gnus-data-pos data) (point)))))))) + (let ((inserted (- (point) + (progn + (gnus-summary-insert-line + header level nil + (memq article gnus-newsgroup-undownloaded) + (gnus-article-mark article) + (memq article gnus-newsgroup-replied) + (memq article gnus-newsgroup-expirable) + ;; Only insert the Subject string when it's different + ;; from the previous Subject string. + (if (and + gnus-show-threads + (gnus-subject-equal + (condition-case () + (mail-header-subject + (gnus-data-header + (cadr + (gnus-data-find-list + article + (gnus-data-list t))))) + ;; Error on the side of excessive subjects. + (error "")) + (mail-header-subject header))) + "" + (mail-header-subject header)) + nil (cdr (assq article gnus-newsgroup-scored)) + (memq article gnus-newsgroup-processable)) + (point))))) + (when (cdr datal) + (gnus-data-update-list + (cdr datal) + (- (gnus-data-pos data) (gnus-data-pos (cadr datal)) inserted))))))) (defun gnus-summary-update-article (article &optional iheader) "Update ARTICLE in the summary buffer." @@ -3756,11 +4382,11 @@ (if (not gnus-thread-sort-functions) threads (gnus-message 8 "Sorting threads...") - (prog1 - (gnus-sort-threads-1 + (let ((max-lisp-eval-depth 5000)) + (prog1 (gnus-sort-threads-1 threads (gnus-make-sort-function gnus-thread-sort-functions)) - (gnus-message 8 "Sorting threads...done")))) + (gnus-message 8 "Sorting threads...done"))))) (defun gnus-sort-articles (articles) "Sort ARTICLES." @@ -3792,6 +4418,15 @@ (gnus-article-sort-by-number (gnus-thread-header h1) (gnus-thread-header h2))) +(defsubst gnus-article-sort-by-random (h1 h2) + "Sort articles by article number." + (zerop (random 2))) + +(defun gnus-thread-sort-by-random (h1 h2) + "Sort threads by root article number." + (gnus-article-sort-by-random + (gnus-thread-header h1) (gnus-thread-header h2))) + (defsubst gnus-article-sort-by-lines (h1 h2) "Sort articles by article Lines header." (< (mail-header-lines h1) @@ -3873,15 +4508,47 @@ (defun gnus-thread-total-score (thread) ;; This function find the total score of THREAD. - (cond ((null thread) - 0) - ((consp thread) - (if (stringp (car thread)) - (apply gnus-thread-score-function 0 - (mapcar 'gnus-thread-total-score-1 (cdr thread))) - (gnus-thread-total-score-1 thread))) - (t - (gnus-thread-total-score-1 (list thread))))) + (cond + ((null thread) + 0) + ((consp thread) + (if (stringp (car thread)) + (apply gnus-thread-score-function 0 + (mapcar 'gnus-thread-total-score-1 (cdr thread))) + (gnus-thread-total-score-1 thread))) + (t + (gnus-thread-total-score-1 (list thread))))) + +(defun gnus-thread-sort-by-most-recent-number (h1 h2) + "Sort threads such that the thread with the most recently arrived article comes first." + (> (gnus-thread-highest-number h1) (gnus-thread-highest-number h2))) + +(defun gnus-thread-highest-number (thread) + "Return the highest article number in THREAD." + (apply 'max (mapcar (lambda (header) + (mail-header-number header)) + (message-flatten-list thread)))) + +(defun gnus-thread-sort-by-most-recent-date (h1 h2) + "Sort threads such that the thread with the most recently dated article comes first." + (> (gnus-thread-latest-date h1) (gnus-thread-latest-date h2))) + +(defun gnus-thread-latest-date (thread) + "Return the highest article date in THREAD." + (let ((previous-time 0)) + (apply 'max + (mapcar + (lambda (header) + (setq previous-time + (condition-case () + (time-to-seconds (mail-header-parse-date + (mail-header-date header))) + (error previous-time)))) + (sort + (message-flatten-list thread) + (lambda (h1 h2) + (< (mail-header-number h1) + (mail-header-number h2)))))))) (defun gnus-thread-total-score-1 (root) ;; This function find the total score of the thread below ROOT. @@ -3909,6 +4576,40 @@ (or (cdr (assq type (mail-header-extra (or header gnus-tmp-header)))) "")) +(defvar gnus-tmp-thread-tree-header-string "") + +(defcustom gnus-sum-thread-tree-root "> " + "With %B spec, used for the root of a thread. +If nil, use subject instead." + :type '(radio (const :format "%v " nil) (string :size 0)) + :group 'gnus-thread) +(defcustom gnus-sum-thread-tree-false-root "> " + "With %B spec, used for a false root of a thread. +If nil, use subject instead." + :type '(radio (const :format "%v " nil) (string :size 0)) + :group 'gnus-thread) +(defcustom gnus-sum-thread-tree-single-indent "" + "With %B spec, used for a thread with just one message. +If nil, use subject instead." + :type '(radio (const :format "%v " nil) (string :size 0)) + :group 'gnus-thread) +(defcustom gnus-sum-thread-tree-vertical "| " + "With %B spec, used for drawing a vertical line." + :type 'string + :group 'gnus-thread) +(defcustom gnus-sum-thread-tree-indent " " + "With %B spec, used for indenting." + :type 'string + :group 'gnus-thread) +(defcustom gnus-sum-thread-tree-leaf-with-other "+-> " + "With %B spec, used for a leaf with brothers." + :type 'string + :group 'gnus-thread) +(defcustom gnus-sum-thread-tree-single-leaf "\\-> " + "With %B spec, used for a leaf without brothers." + :type 'string + :group 'gnus-thread) + (defun gnus-summary-prepare-threads (threads) "Prepare summary buffer from THREADS and indentation LEVEL. THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])' @@ -3921,15 +4622,19 @@ (let ((gnus-tmp-level 0) (default-score (or gnus-summary-default-score 0)) (gnus-visual-p (gnus-visual-p 'summary-highlight 'highlight)) + (building-line-count gnus-summary-display-while-building) + (building-count (integerp gnus-summary-display-while-building)) thread number subject stack state gnus-tmp-gathered beg-match - new-roots gnus-tmp-new-adopts thread-end - gnus-tmp-header gnus-tmp-unread + new-roots gnus-tmp-new-adopts thread-end simp-subject + gnus-tmp-header gnus-tmp-unread gnus-tmp-downloaded gnus-tmp-replied gnus-tmp-subject-or-nil gnus-tmp-dummy gnus-tmp-indentation gnus-tmp-lines gnus-tmp-score gnus-tmp-score-char gnus-tmp-from gnus-tmp-name - gnus-tmp-number gnus-tmp-opening-bracket gnus-tmp-closing-bracket) - - (setq gnus-tmp-prev-subject nil) + gnus-tmp-number gnus-tmp-opening-bracket gnus-tmp-closing-bracket + tree-stack) + + (setq gnus-tmp-prev-subject nil + gnus-tmp-thread-tree-header-string "") (if (vectorp (car threads)) ;; If this is a straight (sic) list of headers, then a @@ -3939,6 +4644,8 @@ ;; Do the threaded display. + (if gnus-summary-display-while-building + (switch-to-buffer (buffer-name))) (while (or threads stack gnus-tmp-new-adopts new-roots) (if (and (= gnus-tmp-level 0) @@ -3965,7 +4672,8 @@ ;; the stack. (setq state (car stack) gnus-tmp-level (car state) - thread (cdr state) + tree-stack (cadr state) + thread (caddr state) stack (cdr stack) gnus-tmp-header (caar thread)))) @@ -4009,7 +4717,8 @@ (setq gnus-tmp-level -1))) (setq number (mail-header-number gnus-tmp-header) - subject (mail-header-subject gnus-tmp-header)) + subject (mail-header-subject gnus-tmp-header) + simp-subject (gnus-simplify-subject-fully subject)) (cond ;; If the thread has changed subject, we might want to make @@ -4017,8 +4726,7 @@ ((and (null gnus-thread-ignore-subject) (not (zerop gnus-tmp-level)) gnus-tmp-prev-subject - (not (inline - (gnus-subject-equal gnus-tmp-prev-subject subject)))) + (not (string= gnus-tmp-prev-subject simp-subject))) (setq new-roots (nconc new-roots (list (car thread))) thread-end t gnus-tmp-header nil)) @@ -4049,7 +4757,9 @@ (setq gnus-newsgroup-unreads (delq number gnus-newsgroup-unreads)) (if gnus-newsgroup-auto-expire - (push number gnus-newsgroup-expirable) + (setq gnus-newsgroup-expirable + (gnus-add-to-sorted-list + gnus-newsgroup-expirable number)) (push (cons number gnus-low-score-mark) gnus-newsgroup-reads)))) @@ -4077,15 +4787,13 @@ (cond ((and gnus-thread-ignore-subject gnus-tmp-prev-subject - (not (inline (gnus-subject-equal - gnus-tmp-prev-subject subject)))) + (not (string= gnus-tmp-prev-subject simp-subject))) subject) ((zerop gnus-tmp-level) (if (and (eq gnus-summary-make-false-root 'empty) (memq number gnus-tmp-gathered) gnus-tmp-prev-subject - (inline (gnus-subject-equal - gnus-tmp-prev-subject subject))) + (string= gnus-tmp-prev-subject simp-subject)) gnus-summary-same-subject subject)) (t gnus-summary-same-subject))) @@ -4106,7 +4814,7 @@ (if (or (null gnus-summary-default-score) (<= (abs (- gnus-tmp-score gnus-summary-default-score)) gnus-summary-zcore-fuzz)) - ? ;Whitespace + ? ;Whitespace (if (< gnus-tmp-score gnus-summary-default-score) gnus-score-below-mark gnus-score-over-mark)) gnus-tmp-replied @@ -4116,41 +4824,93 @@ gnus-cached-mark) ((memq number gnus-newsgroup-replied) gnus-replied-mark) + ((memq number gnus-newsgroup-forwarded) + gnus-forwarded-mark) ((memq number gnus-newsgroup-saved) gnus-saved-mark) - (t gnus-unread-mark)) + ((memq number gnus-newsgroup-recent) + gnus-recent-mark) + ((memq number gnus-newsgroup-unseen) + gnus-unseen-mark) + (t gnus-no-mark)) + gnus-tmp-downloaded + (cond ((memq number gnus-newsgroup-undownloaded) + gnus-undownloaded-mark) + (gnus-newsgroup-agentized + gnus-downloaded-mark) + (t + gnus-no-mark)) gnus-tmp-from (mail-header-from gnus-tmp-header) gnus-tmp-name (cond ((string-match "<[^>]+> *$" gnus-tmp-from) (setq beg-match (match-beginning 0)) - (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) - (substring gnus-tmp-from (1+ (match-beginning 0)) - (1- (match-end 0)))) + (or (and (string-match "^\".+\"" gnus-tmp-from) + (substring gnus-tmp-from 1 (1- (match-end 0)))) (substring gnus-tmp-from 0 beg-match))) ((string-match "(.+)" gnus-tmp-from) (substring gnus-tmp-from (1+ (match-beginning 0)) (1- (match-end 0)))) - (t gnus-tmp-from))) + (t gnus-tmp-from)) + + ;; Do the %B string + gnus-tmp-thread-tree-header-string + (cond + ((not gnus-show-threads) "") + ((zerop gnus-tmp-level) + (cond ((cdar thread) + (or gnus-sum-thread-tree-root subject)) + (gnus-tmp-new-adopts + (or gnus-sum-thread-tree-false-root subject)) + (t + (or gnus-sum-thread-tree-single-indent subject)))) + (t + (concat (apply 'concat + (mapcar (lambda (item) + (if (= item 1) + gnus-sum-thread-tree-vertical + gnus-sum-thread-tree-indent)) + (cdr (reverse tree-stack)))) + (if (nth 1 thread) + gnus-sum-thread-tree-leaf-with-other + gnus-sum-thread-tree-single-leaf))))) (when (string= gnus-tmp-name "") (setq gnus-tmp-name gnus-tmp-from)) (unless (numberp gnus-tmp-lines) - (setq gnus-tmp-lines 0)) - (gnus-put-text-property + (setq gnus-tmp-lines -1)) + (if (= gnus-tmp-lines -1) + (setq gnus-tmp-lines "?") + (setq gnus-tmp-lines (number-to-string gnus-tmp-lines))) + (gnus-put-text-property (point) (progn (eval gnus-summary-line-format-spec) (point)) - 'gnus-number number) + 'gnus-number number) (when gnus-visual-p (forward-line -1) (gnus-run-hooks 'gnus-summary-update-hook) (forward-line 1)) - (setq gnus-tmp-prev-subject subject))) + (setq gnus-tmp-prev-subject simp-subject))) (when (nth 1 thread) - (push (cons (max 0 gnus-tmp-level) (nthcdr 1 thread)) stack)) + (push (list (max 0 gnus-tmp-level) + (copy-sequence tree-stack) + (nthcdr 1 thread)) + stack)) + (push (if (nth 1 thread) 1 0) tree-stack) (incf gnus-tmp-level) (setq threads (if thread-end nil (cdar thread))) + (if gnus-summary-display-while-building + (if building-count + (progn + ;; use a set frequency + (setq building-line-count (1- building-line-count)) + (when (= building-line-count 0) + (sit-for 0) + (setq building-line-count + gnus-summary-display-while-building))) + ;; always + (sit-for 0))) (unless threads (setq gnus-tmp-level 0))))) (gnus-message 7 "Generating summary...done")) @@ -4184,6 +4944,7 @@ gnus-newsgroup-data) (gnus-summary-insert-line header 0 number + (memq number gnus-newsgroup-undownloaded) mark (memq number gnus-newsgroup-replied) (memq number gnus-newsgroup-expirable) (mail-header-subject header) nil @@ -4192,21 +4953,50 @@ (defun gnus-summary-remove-list-identifiers () "Remove list identifiers in `gnus-list-identifiers' from articles in the current group." - (let ((regexp (if (stringp gnus-list-identifiers) - gnus-list-identifiers - (mapconcat 'identity gnus-list-identifiers " *\\|")))) - (dolist (header gnus-newsgroup-headers) - (when (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp - " *\\)\\)+\\(Re: +\\)?\\)") - (mail-header-subject header)) - (mail-header-set-subject - header (concat (substring (mail-header-subject header) - 0 (match-beginning 1)) - (or - (match-string 3 (mail-header-subject header)) - (match-string 5 (mail-header-subject header))) - (substring (mail-header-subject header) - (match-end 1)))))))) + (let ((regexp (if (consp gnus-list-identifiers) + (mapconcat 'identity gnus-list-identifiers " *\\|") + gnus-list-identifiers)) + changed subject) + (when regexp + (dolist (header gnus-newsgroup-headers) + (setq subject (mail-header-subject header) + changed nil) + (while (string-match + (concat "^\\(R[Ee]: +\\)*\\(" regexp " *\\)") + subject) + (setq subject + (concat (substring subject 0 (match-beginning 2)) + (substring subject (match-end 0))) + changed t)) + (when (and changed + (string-match + "^\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" subject)) + (setq subject + (concat (substring subject 0 (match-beginning 1)) + (substring subject (match-end 1))))) + (when changed + (mail-header-set-subject header subject)))))) + +(defun gnus-fetch-headers (articles) + "Fetch headers of ARTICLES." + (let ((name (gnus-group-decoded-name gnus-newsgroup-name))) + (gnus-message 5 "Fetching headers for %s..." name) + (prog1 + (if (eq 'nov + (setq gnus-headers-retrieved-by + (gnus-retrieve-headers + articles gnus-newsgroup-name + ;; We might want to fetch old headers, but + ;; not if there is only 1 article. + (and (or (and + (not (eq gnus-fetch-old-headers 'some)) + (not (numberp gnus-fetch-old-headers))) + (> (length articles) 1)) + gnus-fetch-old-headers)))) + (gnus-get-newsgroup-headers-xover + articles nil nil gnus-newsgroup-name t) + (gnus-get-newsgroup-headers)) + (gnus-message 5 "Fetching headers for %s...done" name)))) (defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. @@ -4215,7 +5005,7 @@ (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) ;;!!! Dirty hack; should be removed. (gnus-summary-ignore-duplicates - (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) + (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual) t gnus-summary-ignore-duplicates)) (info (nth 2 entry)) @@ -4230,43 +5020,91 @@ (gnus-activate-group group) ; Or we can activate it... (progn ; Or we bug out. (when (equal major-mode 'gnus-summary-mode) - (kill-buffer (current-buffer))) - (error "Couldn't request group %s: %s" + (gnus-kill-buffer (current-buffer))) + (error "Couldn't activate group %s: %s" group (gnus-status-message group)))) (unless (gnus-request-group group t) (when (equal major-mode 'gnus-summary-mode) - (kill-buffer (current-buffer))) + (gnus-kill-buffer (current-buffer))) (error "Couldn't request group %s: %s" group (gnus-status-message group))) - (setq gnus-newsgroup-name group) - (setq gnus-newsgroup-unselected nil) - (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) + (when gnus-agent + ;; The agent may be storing articles that are no longer in the + ;; server's active range. If that is the case, the active range + ;; needs to be expanded such that the agent's articles can be + ;; included in the summary. + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (alist (gnus-agent-load-alist group)) + (active (gnus-active group))) + (if (and (car alist) + (< (caar alist) (car active))) + (gnus-set-active group (cons (caar alist) (cdr active))))) + + (setq gnus-summary-use-undownloaded-faces + (gnus-agent-find-parameter + group + 'agent-enable-undownloaded-faces))) + + (setq gnus-newsgroup-name group + gnus-newsgroup-unselected nil + gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) + + (let ((display (gnus-group-find-parameter group 'display))) + (setq gnus-newsgroup-display + (cond + ((not (zerop (or (car-safe read-all) 0))) + ;; The user entered the group with C-u SPC/RET, let's show + ;; all articles. + 'gnus-not-ignore) + ((eq display 'all) + 'gnus-not-ignore) + ((arrayp display) + (gnus-summary-display-make-predicate (mapcar 'identity display))) + ((numberp display) + ;; The following is probably the "correct" solution, but + ;; it makes Gnus fetch all headers and then limit the + ;; articles (which is slow), so instead we hack the + ;; select-articles parameter instead. -- Simon Josefsson + ;; <jas@kth.se> + ;; + ;; (gnus-byte-compile + ;; `(lambda () (> number ,(- (cdr (gnus-active group)) + ;; display))))) + (setq select-articles + (gnus-uncompress-range + (cons (let ((tmp (- (cdr (gnus-active group)) display))) + (if (> tmp 0) + tmp + 1)) + (cdr (gnus-active group))))) + nil) + (t + nil)))) + (gnus-summary-setup-default-charset) - ;; Adjust and set lists of article marks. - (when info - (gnus-adjust-marked-articles info)) - ;; Kludge to avoid having cached articles nixed out in virtual groups. (when (gnus-virtual-group-p group) (setq cached gnus-newsgroup-cached)) (setq gnus-newsgroup-unreads - (gnus-set-difference - (gnus-set-difference gnus-newsgroup-unreads gnus-newsgroup-marked) + (gnus-sorted-ndifference + (gnus-sorted-ndifference gnus-newsgroup-unreads + gnus-newsgroup-marked) gnus-newsgroup-dormant)) (setq gnus-newsgroup-processable nil) (gnus-update-read-articles group gnus-newsgroup-unreads) + ;; Adjust and set lists of article marks. + (when info + (gnus-adjust-marked-articles info)) (if (setq articles select-articles) (setq gnus-newsgroup-unselected - (gnus-sorted-intersection - gnus-newsgroup-unreads - (gnus-sorted-complement gnus-newsgroup-unreads articles))) + (gnus-sorted-difference gnus-newsgroup-unreads articles)) (setq articles (gnus-articles-to-read group read-all))) (cond @@ -4280,23 +5118,8 @@ (gnus-make-hashtable (length articles))) (gnus-set-global-variables) ;; Retrieve the headers and read them in. - (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) - (setq gnus-newsgroup-headers - (if (eq 'nov - (setq gnus-headers-retrieved-by - (gnus-retrieve-headers - articles gnus-newsgroup-name - ;; We might want to fetch old headers, but - ;; not if there is only 1 article. - (and (or (and - (not (eq gnus-fetch-old-headers 'some)) - (not (numberp gnus-fetch-old-headers))) - (> (length articles) 1)) - gnus-fetch-old-headers)))) - (gnus-get-newsgroup-headers-xover - articles nil nil gnus-newsgroup-name t) - (gnus-get-newsgroup-headers))) - (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name) + + (setq gnus-newsgroup-headers (gnus-fetch-headers articles)) ;; Kludge to avoid having cached articles nixed out in virtual groups. (when cached @@ -4309,15 +5132,18 @@ ;; Set the initial limit. (setq gnus-newsgroup-limit (copy-sequence articles)) ;; Remove canceled articles from the list of unread articles. + (setq fetched-articles + (mapcar (lambda (headers) (mail-header-number headers)) + gnus-newsgroup-headers)) + (setq gnus-newsgroup-articles fetched-articles) (setq gnus-newsgroup-unreads - (gnus-set-sorted-intersection - gnus-newsgroup-unreads - (setq fetched-articles - (mapcar (lambda (headers) (mail-header-number headers)) - gnus-newsgroup-headers)))) + (gnus-sorted-nintersection + gnus-newsgroup-unreads fetched-articles)) + (gnus-compute-unseen-list) + ;; Removed marked articles that do not exist. (gnus-update-missing-marks - (gnus-sorted-complement fetched-articles articles)) + (gnus-sorted-difference articles fetched-articles)) ;; We might want to build some more threads first. (when (and gnus-fetch-old-headers (eq gnus-headers-retrieved-by 'nov)) @@ -4346,22 +5172,97 @@ ;; GROUP is successfully selected. (or gnus-newsgroup-headers t))))) +(defun gnus-compute-unseen-list () + ;; The `seen' marks are treated specially. + (if (not gnus-newsgroup-seen) + (setq gnus-newsgroup-unseen gnus-newsgroup-articles) + (setq gnus-newsgroup-unseen + (gnus-inverse-list-range-intersection + gnus-newsgroup-articles gnus-newsgroup-seen)))) + +(defun gnus-summary-display-make-predicate (display) + (require 'gnus-agent) + (when (= (length display) 1) + (setq display (car display))) + (unless gnus-summary-display-cache + (dolist (elem (append '((unread . unread) + (read . read) + (unseen . unseen)) + gnus-article-mark-lists)) + (push (cons (cdr elem) + (gnus-byte-compile + `(lambda () (gnus-article-marked-p ',(cdr elem))))) + gnus-summary-display-cache))) + (let ((gnus-category-predicate-alist gnus-summary-display-cache) + (gnus-category-predicate-cache gnus-summary-display-cache)) + (gnus-get-predicate display))) + +;; Uses the dynamically bound `number' variable. +(eval-when-compile + (defvar number)) +(defun gnus-article-marked-p (type &optional article) + (let ((article (or article number))) + (cond + ((eq type 'tick) + (memq article gnus-newsgroup-marked)) + ((eq type 'spam) + (memq article gnus-newsgroup-spam-marked)) + ((eq type 'unsend) + (memq article gnus-newsgroup-unsendable)) + ((eq type 'undownload) + (memq article gnus-newsgroup-undownloaded)) + ((eq type 'download) + (memq article gnus-newsgroup-downloadable)) + ((eq type 'unread) + (memq article gnus-newsgroup-unreads)) + ((eq type 'read) + (memq article gnus-newsgroup-reads)) + ((eq type 'dormant) + (memq article gnus-newsgroup-dormant) ) + ((eq type 'expire) + (memq article gnus-newsgroup-expirable)) + ((eq type 'reply) + (memq article gnus-newsgroup-replied)) + ((eq type 'killed) + (memq article gnus-newsgroup-killed)) + ((eq type 'bookmark) + (assq article gnus-newsgroup-bookmarks)) + ((eq type 'score) + (assq article gnus-newsgroup-scored)) + ((eq type 'save) + (memq article gnus-newsgroup-saved)) + ((eq type 'cache) + (memq article gnus-newsgroup-cached)) + ((eq type 'forward) + (memq article gnus-newsgroup-forwarded)) + ((eq type 'seen) + (not (memq article gnus-newsgroup-unseen))) + ((eq type 'recent) + (memq article gnus-newsgroup-recent)) + (t t)))) + (defun gnus-articles-to-read (group &optional read-all) "Find out what articles the user wants to read." - (let* ((articles + (let* ((display (gnus-group-find-parameter group 'display)) + (articles ;; Select all articles if `read-all' is non-nil, or if there ;; are no unread articles. (if (or read-all (and (zerop (length gnus-newsgroup-marked)) (zerop (length gnus-newsgroup-unreads))) - (eq (gnus-group-find-parameter group 'display) - 'all)) + ;; Fetch all if the predicate is non-nil. + gnus-newsgroup-display) + ;; We want to select the headers for all the articles in + ;; the group, so we select either all the active + ;; articles in the group, or (if that's nil), the + ;; articles in the cache. (or (gnus-uncompress-range (gnus-active group)) (gnus-cache-articles-in-group group)) - (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked - (copy-sequence gnus-newsgroup-unreads)) - '<))) + ;; Select only the "normal" subset of articles. + (gnus-sorted-nunion + (gnus-sorted-union gnus-newsgroup-dormant gnus-newsgroup-marked) + gnus-newsgroup-unreads))) (scored-list (gnus-killed-articles gnus-newsgroup-killed articles)) (scored (length scored-list)) (number (length articles)) @@ -4371,18 +5272,29 @@ (cond ((numberp read-all) read-all) + ((numberp gnus-newsgroup-display) + gnus-newsgroup-display) (t (condition-case () (cond ((and (or (<= scored marked) (= scored number)) (numberp gnus-large-newsgroup) (> number gnus-large-newsgroup)) - (let ((input - (read-string - (format - "How many articles from %s (default %d): " - (gnus-limit-string gnus-newsgroup-name 35) - number)))) + (let* ((cursor-in-echo-area nil) + (initial (gnus-parameter-large-newsgroup-initial + gnus-newsgroup-name)) + (input + (read-string + (format + "How many articles from %s (%s %d): " + (gnus-limit-string + (gnus-group-decoded-name gnus-newsgroup-name) + 35) + (if initial "max" "default") + number) + (if initial + (cons (number-to-string initial) + 0))))) (if (string-match "^[ \t]*$" input) number input))) ((and (> scored marked) (< scored number) (> (- scored number) 20)) @@ -4390,7 +5302,8 @@ (read-string (format "%s %s (%d scored, %d total): " "How many articles from" - group scored number)))) + (gnus-group-decoded-name group) + scored number)))) (if (string-match "^[ \t]*$" input) number input))) (t number)) @@ -4413,14 +5326,12 @@ ;; Select the N most recent articles. (setq articles (nthcdr (- number select) articles)))) (setq gnus-newsgroup-unselected - (gnus-sorted-intersection - gnus-newsgroup-unreads - (gnus-sorted-complement gnus-newsgroup-unreads articles))) + (gnus-sorted-difference gnus-newsgroup-unreads articles)) (when gnus-alter-articles-to-read-function - (setq gnus-newsgroup-unreads + (setq articles (sort (funcall gnus-alter-articles-to-read-function - gnus-newsgroup-name gnus-newsgroup-unreads) + gnus-newsgroup-name articles) '<))) articles))) @@ -4443,6 +5354,15 @@ (setq marks (cdr marks))) out)) +(defun gnus-article-mark-to-type (mark) + "Return the type of MARK." + (or (cadr (assq mark gnus-article-special-mark-lists)) + 'list)) + +(defun gnus-article-unpropagatable-p (mark) + "Return whether MARK should be propagated to back end." + (memq mark gnus-article-unpropagated-mark-lists)) + (defun gnus-adjust-marked-articles (info) "Set all article lists and remove all marks that are no longer valid." (let* ((marked-lists (gnus-info-marks info)) @@ -4450,28 +5370,26 @@ (min (car active)) (max (cdr active)) (types gnus-article-mark-lists) - (uncompressed '(score bookmark killed)) - marks var articles article mark) - - (while marked-lists - (setq marks (pop marked-lists)) - (set (setq var (intern (format "gnus-newsgroup-%s" - (car (rassq (setq mark (car marks)) - types))))) - (if (memq (car marks) uncompressed) (cdr marks) - (gnus-uncompress-range (cdr marks)))) - - (setq articles (symbol-value var)) - - ;; All articles have to be subsets of the active articles. + marks var articles article mark mark-type) + + (dolist (marks marked-lists) + (setq mark (car marks) + mark-type (gnus-article-mark-to-type mark) + var (intern (format "gnus-newsgroup-%s" (car (rassq mark types))))) + + ;; We set the variable according to the type of the marks list, + ;; and then adjust the marks to a subset of the active articles. (cond ;; Adjust "simple" lists. - ((memq mark '(tick dormant expire reply save)) - (while articles - (when (or (< (setq article (pop articles)) min) (> article max)) - (set var (delq article (symbol-value var)))))) + ((eq mark-type 'list) + (set var (setq articles (gnus-uncompress-range (cdr marks)))) + (when (memq mark '(tick dormant expire reply save)) + (while articles + (when (or (< (setq article (pop articles)) min) (> article max)) + (set var (delq article (symbol-value var))))))) ;; Adjust assocs. - ((memq mark uncompressed) + ((eq mark-type 'tuple) + (set var (setq articles (cdr marks))) (when (not (listp (cdr (symbol-value var)))) (set var (list (symbol-value var)))) (when (not (listp (cdr articles))) @@ -4480,36 +5398,50 @@ (when (or (not (consp (setq article (pop articles)))) (< (car article) min) (> (car article) max)) - (set var (delq article (symbol-value var)))))))))) + (set var (delq article (symbol-value var)))))) + ;; Adjust ranges (sloppily). + ((eq mark-type 'range) + (cond + ((eq mark 'seen) + ;; Fix the record for `seen' if it looks like (seen NUM1 . NUM2). + ;; It should be (seen (NUM1 . NUM2)). + (when (numberp (cddr marks)) + (setcdr marks (list (cdr marks)))) + (setq articles (cdr marks)) + (while (and articles + (or (and (consp (car articles)) + (> min (cdar articles))) + (and (numberp (car articles)) + (> min (car articles))))) + (pop articles)) + (set var articles)))))))) (defun gnus-update-missing-marks (missing) "Go through the list of MISSING articles and remove them from the mark lists." (when missing - (let ((types gnus-article-mark-lists) - var m) + (let (var m) ;; Go through all types. - (while types - (setq var (intern (format "gnus-newsgroup-%s" (car (pop types))))) - (when (symbol-value var) - ;; This list has articles. So we delete all missing articles - ;; from it. - (setq m missing) - (while m - (set var (delq (pop m) (symbol-value var))))))))) + (dolist (elem gnus-article-mark-lists) + (when (eq (gnus-article-mark-to-type (cdr elem)) 'list) + (setq var (intern (format "gnus-newsgroup-%s" (car elem)))) + (when (symbol-value var) + ;; This list has articles. So we delete all missing + ;; articles from it. + (setq m missing) + (while m + (set var (delq (pop m) (symbol-value var)))))))))) (defun gnus-update-marks () "Enter the various lists of marked articles into the newsgroup info list." (let ((types gnus-article-mark-lists) (info (gnus-get-info gnus-newsgroup-name)) - (uncompressed '(score bookmark killed)) type list newmarked symbol delta-marks) (when info ;; Add all marks lists to the list of marks lists. (while (setq type (pop types)) (setq list (symbol-value (setq symbol - (intern (format "gnus-newsgroup-%s" - (car type)))))) + (intern (format "gnus-newsgroup-%s" (car type)))))) (when list ;; Get rid of the entries of the articles that have the @@ -4528,27 +5460,23 @@ (setq arts (cdr arts))) (setq list (cdr all))))) - (unless (memq (cdr type) uncompressed) + (when (eq (cdr type) 'seen) + (setq list (gnus-range-add list gnus-newsgroup-unseen))) + + (when (eq (gnus-article-mark-to-type (cdr type)) 'list) (setq list (gnus-compress-sequence (set symbol (sort list '<)) t))) - (when (gnus-check-backend-function - 'request-set-mark gnus-newsgroup-name) - ;; propagate flags to server, with the following exceptions: - ;; uncompressed:s are not proper flags (they are cons cells) - ;; cache is a internal gnus flag - ;; download are local to one gnus installation (well) - ;; unsend are for nndraft groups only - ;; xxx: generality of this? this suits nnimap anyway - (unless (memq (cdr type) (append '(cache download unsend) - uncompressed)) - (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) - (del (gnus-remove-from-range (gnus-copy-sequence old) list)) - (add (gnus-remove-from-range - (gnus-copy-sequence list) old))) - (when add - (push (list add 'add (list (cdr type))) delta-marks)) - (when del - (push (list del 'del (list (cdr type))) delta-marks))))) + (when (and (gnus-check-backend-function + 'request-set-mark gnus-newsgroup-name) + (not (gnus-article-unpropagatable-p (cdr type)))) + (let* ((old (cdr (assq (cdr type) (gnus-info-marks info)))) + (del (gnus-remove-from-range (gnus-copy-sequence old) list)) + (add (gnus-remove-from-range + (gnus-copy-sequence list) old))) + (when add + (push (list add 'add (list (cdr type))) delta-marks)) + (when del + (push (list del 'del (list (cdr type))) delta-marks)))) (when list (push (cons (cdr type) list) newmarked))) @@ -4584,16 +5512,13 @@ ;; We evaluate this in the summary buffer since these ;; variables are buffer-local to that buffer. (set-buffer gnus-summary-buffer) - ;; We bind all these variables that are used in the `eval' form + ;; We bind all these variables that are used in the `eval' form ;; below. (let* ((mformat (symbol-value (intern (format "gnus-%s-mode-line-format-spec" where)))) - (gnus-tmp-group-name (gnus-group-name-decode - gnus-newsgroup-name - (gnus-group-name-charset - nil - gnus-newsgroup-name))) + (gnus-tmp-group-name (gnus-group-decoded-name + gnus-newsgroup-name)) (gnus-tmp-article-number (or gnus-current-article 0)) (gnus-tmp-unread gnus-newsgroup-unreads) (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) @@ -4614,7 +5539,7 @@ (mail-header-subject gnus-current-headers)) "")) bufname-length max-len - gnus-tmp-header);; passed as argument to any user-format-funcs + gnus-tmp-header) ;; passed as argument to any user-format-funcs (setq mode-string (eval mformat)) (setq bufname-length (if (string-match "%b" mode-string) (- (length @@ -4755,9 +5680,11 @@ (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) + (gnus-request-set-mark ,group (list (list ',range 'del '(read)))) (gnus-group-update-group ,group t)))) ;; Add the read articles to the range. (gnus-info-set-read info range) + (gnus-request-set-mark group (list (list range 'add '(read)))) ;; Then we have to re-compute how many unread ;; articles there are in this group. (when active @@ -4777,7 +5704,8 @@ ;; Update the number of unread articles. (setcar entry num) ;; Update the group buffer. - (gnus-group-update-group group t))))) + (unless (gnus-ephemeral-group-p group) + (gnus-group-update-group group t)))))) (defvar gnus-newsgroup-none-id 0) @@ -4799,6 +5727,7 @@ ;; Translate all TAB characters into SPACE characters. (subst-char-in-region (point-min) (point-max) ?\t ? t) (subst-char-in-region (point-min) (point-max) ?\r ? t) + (ietf-drums-unfold-fws) (gnus-run-hooks 'gnus-parse-headers-hook) (let ((case-fold-search t) in-reply-to header p lines chars) @@ -4829,22 +5758,21 @@ ;; Subject. (progn (goto-char p) - (if (search-forward "\nsubject: " nil t) + (if (search-forward "\nsubject:" nil t) (funcall gnus-decode-encoded-word-function (nnheader-header-value)) "(none)")) ;; From. (progn (goto-char p) - (if (or (search-forward "\nfrom: " nil t) - (search-forward "\nfrom:" nil t)) + (if (search-forward "\nfrom:" nil t) (funcall gnus-decode-encoded-word-function (nnheader-header-value)) "(nobody)")) ;; Date. (progn (goto-char p) - (if (search-forward "\ndate: " nil t) + (if (search-forward "\ndate:" nil t) (nnheader-header-value) "")) ;; Message-ID. (progn @@ -4861,7 +5789,7 @@ ;; References. (progn (goto-char p) - (if (search-forward "\nreferences: " nil t) + (if (search-forward "\nreferences:" nil t) (progn (setq end (point)) (prog1 @@ -4878,7 +5806,7 @@ ;; Get the references from the in-reply-to header if there ;; were no references and the in-reply-to header looks ;; promising. - (if (and (search-forward "\nin-reply-to: " nil t) + (if (and (search-forward "\nin-reply-to:" nil t) (setq in-reply-to (nnheader-header-value)) (string-match "<[^>]+>" in-reply-to)) (let (ref2) @@ -4896,19 +5824,19 @@ (goto-char p) (if (search-forward "\nchars: " nil t) (if (numberp (setq chars (ignore-errors (read cur)))) - chars 0) - 0)) + chars -1) + -1)) ;; Lines. (progn (goto-char p) (if (search-forward "\nlines: " nil t) (if (numberp (setq lines (ignore-errors (read cur)))) - lines 0) - 0)) + lines -1) + -1)) ;; Xref. (progn (goto-char p) - (and (search-forward "\nxref: " nil t) + (and (search-forward "\nxref:" nil t) (nnheader-header-value))) ;; Extra. (when gnus-extra-headers @@ -4917,7 +5845,7 @@ (while extra (goto-char p) (when (search-forward - (concat "\n" (symbol-name (car extra)) ": ") nil t) + (concat "\n" (symbol-name (car extra)) ":") nil t) (push (cons (car extra) (nnheader-header-value)) out)) (pop extra)) @@ -4952,6 +5880,13 @@ (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) (cur nntp-server-buffer) (dependencies (or dependencies gnus-newsgroup-dependencies)) + (allp (cond + ((eq gnus-read-all-available-headers t) + t) + ((stringp gnus-read-all-available-headers) + (string-match gnus-read-all-available-headers group)) + (t + nil))) number headers header) (save-excursion (set-buffer nntp-server-buffer) @@ -4959,26 +5894,24 @@ ;; Allow the user to mangle the headers before parsing them. (gnus-run-hooks 'gnus-parse-headers-hook) (goto-char (point-min)) - (while (not (eobp)) - (condition-case () - (while (and sequence (not (eobp))) - (setq number (read cur)) - (while (and sequence - (< (car sequence) number)) - (setq sequence (cdr sequence))) - (and sequence - (eq number (car sequence)) - (progn - (setq sequence (cdr sequence)) - (setq header (inline - (gnus-nov-parse-line - number dependencies force-new)))) - (push header headers)) - (forward-line 1)) - (error - (gnus-error 4 "Strange nov line (%d)" - (count-lines (point-min) (point))))) - (forward-line 1)) + (gnus-parse-without-error + (while (and (or sequence allp) + (not (eobp))) + (setq number (read cur)) + (when (not allp) + (while (and sequence + (< (car sequence) number)) + (setq sequence (cdr sequence)))) + (when (and (or allp + (and sequence + (eq number (car sequence)))) + (progn + (setq sequence (cdr sequence)) + (setq header (inline + (gnus-nov-parse-line + number dependencies force-new))))) + (push header headers)) + (forward-line 1))) ;; A common bug in inn is that if you have posted an article and ;; then retrieves the active file, it will answer correctly -- ;; the new article is included. However, a NOV entry for the @@ -4992,7 +5925,7 @@ (let ((gnus-nov-is-evil t)) (nconc (nreverse headers) - (when (gnus-retrieve-headers sequence group) + (when (eq (gnus-retrieve-headers sequence group) 'headers) (gnus-get-newsgroup-headers)))))))) (defun gnus-article-get-xrefs () @@ -5014,8 +5947,7 @@ (looking-at "Xref:")) (search-forward "\nXref:" nil t)) (goto-char (1+ (match-end 0))) - (setq xref (buffer-substring (point) - (progn (end-of-line) (point)))) + (setq xref (buffer-substring (point) (gnus-point-at-eol))) (mail-header-set-xref headers xref))))))) (defun gnus-summary-insert-subject (id &optional old-header use-old-header) @@ -5177,53 +6109,77 @@ (save-excursion (gnus-group-best-unread-group exclude-group)))) -(defun gnus-summary-find-next (&optional unread article backward undownloaded) - (if backward (gnus-summary-find-prev) +(defun gnus-summary-find-next (&optional unread article backward) + (if backward + (gnus-summary-find-prev unread article) (let* ((dummy (gnus-summary-article-intangible-p)) (article (or article (gnus-summary-article-number))) - (arts (gnus-data-find-list article)) + (data (gnus-data-find-list article)) result) (when (and (not dummy) (or (not gnus-summary-check-current) (not unread) - (not (gnus-data-unread-p (car arts))))) - (setq arts (cdr arts))) + (not (gnus-data-unread-p (car data))))) + (setq data (cdr data))) (when (setq result (if unread (progn - (while arts - (when (or (and undownloaded - (eq gnus-undownloaded-mark - (gnus-data-mark (car arts)))) - (gnus-data-unread-p (car arts))) - (setq result (car arts) - arts nil)) - (setq arts (cdr arts))) + (while data + (unless (memq (gnus-data-number (car data)) + (cond + ((eq gnus-auto-goto-ignores + 'always-undownloaded) + gnus-newsgroup-undownloaded) + (gnus-plugged + nil) + ((eq gnus-auto-goto-ignores + 'unfetched) + gnus-newsgroup-unfetched) + ((eq gnus-auto-goto-ignores + 'undownloaded) + gnus-newsgroup-undownloaded))) + (when (gnus-data-unread-p (car data)) + (setq result (car data) + data nil))) + (setq data (cdr data))) result) - (car arts))) + (car data))) (goto-char (gnus-data-pos result)) (gnus-data-number result))))) (defun gnus-summary-find-prev (&optional unread article) (let* ((eobp (eobp)) (article (or article (gnus-summary-article-number))) - (arts (gnus-data-find-list article (gnus-data-list 'rev))) + (data (gnus-data-find-list article (gnus-data-list 'rev))) result) (when (and (not eobp) (or (not gnus-summary-check-current) (not unread) - (not (gnus-data-unread-p (car arts))))) - (setq arts (cdr arts))) + (not (gnus-data-unread-p (car data))))) + (setq data (cdr data))) (when (setq result (if unread (progn - (while arts - (when (gnus-data-unread-p (car arts)) - (setq result (car arts) - arts nil)) - (setq arts (cdr arts))) + (while data + (unless (memq (gnus-data-number (car data)) + (cond + ((eq gnus-auto-goto-ignores + 'always-undownloaded) + gnus-newsgroup-undownloaded) + (gnus-plugged + nil) + ((eq gnus-auto-goto-ignores + 'unfetched) + gnus-newsgroup-unfetched) + ((eq gnus-auto-goto-ignores + 'undownloaded) + gnus-newsgroup-undownloaded))) + (when (gnus-data-unread-p (car data)) + (setq result (car data) + data nil))) + (setq data (cdr data))) result) - (car arts))) + (car data))) (goto-char (gnus-data-pos result)) (gnus-data-number result)))) @@ -5274,18 +6230,18 @@ ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. (interactive) - (let* ((top (cond ((< (window-height) 4) 0) - ((< (window-height) 7) 1) - (t (if (numberp gnus-auto-center-summary) - gnus-auto-center-summary - 2)))) - (height (1- (window-height))) - (bottom (save-excursion (goto-char (point-max)) - (forward-line (- height)) - (point))) - (window (get-buffer-window (current-buffer)))) - ;; The user has to want it. - (when gnus-auto-center-summary + ;; The user has to want it. + (when gnus-auto-center-summary + (let* ((top (cond ((< (window-height) 4) 0) + ((< (window-height) 7) 1) + (t (if (numberp gnus-auto-center-summary) + gnus-auto-center-summary + 2)))) + (height (1- (window-height))) + (bottom (save-excursion (goto-char (point-max)) + (forward-line (- height)) + (point))) + (window (get-buffer-window (current-buffer)))) (when (get-buffer-window gnus-article-buffer) ;; Only do recentering when the article buffer is displayed, ;; Set the window start to either `bottom', which is the biggest @@ -5377,13 +6333,13 @@ (marked (gnus-info-marks info)) (active (gnus-active group))) (and info active - (gnus-set-difference - (gnus-sorted-complement - (gnus-uncompress-range active) - (gnus-list-of-unread-articles group)) - (append - (gnus-uncompress-range (cdr (assq 'dormant marked))) - (gnus-uncompress-range (cdr (assq 'tick marked)))))))) + (gnus-list-range-difference + (gnus-list-range-difference + (gnus-sorted-complement + (gnus-uncompress-range active) + (gnus-list-of-unread-articles group)) + (cdr (assq 'dormant marked))) + (cdr (assq 'tick marked)))))) ;; Various summary commands @@ -5419,23 +6375,40 @@ (defun gnus-summary-toggle-truncation (&optional arg) "Toggle truncation of summary lines. -With arg, turn line truncation on if arg is positive." +With ARG, turn line truncation on if ARG is positive." (interactive "P") (setq truncate-lines (if (null arg) (not truncate-lines) (> (prefix-numeric-value arg) 0))) (redraw-display)) +(defun gnus-summary-find-for-reselect () + "Return the number of an article to stay on across a reselect. +The current article is considered, then following articles, then previous +articles. An article is sought which is not cancelled and isn't a temporary +insertion from another group. If there's no such then return a dummy 0." + (let (found) + (dolist (rev '(nil t)) + (unless found ; don't demand the reverse list if we don't need it + (let ((data (gnus-data-find-list + (gnus-summary-article-number) (gnus-data-list rev)))) + (while (and data (not found)) + (if (and (< 0 (gnus-data-number (car data))) + (not (eq gnus-canceled-mark (gnus-data-mark (car data))))) + (setq found (gnus-data-number (car data)))) + (setq data (cdr data)))))) + (or found 0))) + (defun gnus-summary-reselect-current-group (&optional all rescan) "Exit and then reselect the current newsgroup. The prefix argument ALL means to select all articles." (interactive "P") (when (gnus-ephemeral-group-p gnus-newsgroup-name) (error "Ephemeral groups can't be reselected")) - (let ((current-subject (gnus-summary-article-number)) + (let ((current-subject (gnus-summary-find-for-reselect)) (group gnus-newsgroup-name)) (setq gnus-newsgroup-begin nil) - (gnus-summary-exit) + (gnus-summary-exit nil 'leave-hidden) ;; We have to adjust the point of group mode buffer because ;; point was moved to the next unread newsgroup by exiting. (gnus-summary-jump-to-group group) @@ -5457,13 +6430,10 @@ (when gnus-newsgroup-kill-headers (setq gnus-newsgroup-killed (gnus-compress-sequence - (nconc - (gnus-set-sorted-intersection - (gnus-uncompress-range gnus-newsgroup-killed) - (setq gnus-newsgroup-unselected - (sort gnus-newsgroup-unselected '<))) - (setq gnus-newsgroup-unreads - (sort gnus-newsgroup-unreads '<))) + (gnus-sorted-union + (gnus-list-range-intersection + gnus-newsgroup-unselected gnus-newsgroup-killed) + gnus-newsgroup-unreads) t))) (unless (listp (cdr gnus-newsgroup-killed)) (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) @@ -5473,7 +6443,8 @@ (set-buffer gnus-group-buffer) (gnus-undo-force-boundary)) (gnus-update-read-articles - group (append gnus-newsgroup-unreads gnus-newsgroup-unselected)) + group (gnus-sorted-union + gnus-newsgroup-unreads gnus-newsgroup-unselected)) ;; Set the current article marks. (let ((gnus-newsgroup-scored (if (and (not gnus-save-score) @@ -5500,7 +6471,7 @@ (gnus-save-newsrc-file) (gnus-dribble-save))) -(defun gnus-summary-exit (&optional temporary) +(defun gnus-summary-exit (&optional temporary leave-hidden) "Exit reading current newsgroup, and then return to group selection mode. `gnus-exit-group-hook' is called with no arguments if that value is non-nil." (interactive) @@ -5516,8 +6487,9 @@ (gnus-async-halt-prefetch) (let* ((group gnus-newsgroup-name) (quit-config (gnus-group-quit-config gnus-newsgroup-name)) + (gnus-group-is-exiting-p t) (mode major-mode) - (group-point nil) + (group-point nil) (buf (current-buffer))) (unless quit-config ;; Do adaptive scoring, and possibly save score files. @@ -5567,27 +6539,36 @@ (setq gnus-article-current nil)) (set-buffer buf) (if (not gnus-kill-summary-on-exit) - (gnus-deaden-summary) + (progn + (gnus-deaden-summary) + (setq mode nil)) ;; We set all buffer-local variables to nil. It is unclear why ;; this is needed, but if we don't, buffer-local variables are ;; not garbage-collected, it seems. This would the lead to en ;; ever-growing Emacs. (gnus-summary-clear-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) (when (get-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer)) ;; We clear the global counterparts of the buffer-local ;; variables as well, just to be on the safe side. (set-buffer gnus-group-buffer) (gnus-summary-clear-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) ;; Return to group mode buffer. (when (eq mode 'gnus-summary-mode) (gnus-kill-buffer buf))) (setq gnus-current-select-method gnus-select-method) - (pop-to-buffer gnus-group-buffer) + (if leave-hidden + (set-buffer gnus-group-buffer) + (pop-to-buffer gnus-group-buffer)) (if (not quit-config) (progn (goto-char group-point) - (gnus-configure-windows 'group 'force)) + (unless leave-hidden + (gnus-configure-windows 'group 'force))) (gnus-handle-ephemeral-exit quit-config)) ;; Clear the current group name. (unless quit-config @@ -5598,14 +6579,14 @@ "Quit reading current newsgroup without updating read article info." (interactive) (let* ((group gnus-newsgroup-name) + (gnus-group-is-exiting-p t) + (gnus-group-is-exiting-without-update-p t) (quit-config (gnus-group-quit-config group))) (when (or no-questions gnus-expert-user (gnus-y-or-n-p "Discard changes to this group and exit? ")) (gnus-async-halt-prefetch) - (mapcar 'funcall - (delq 'gnus-summary-expire-articles - (copy-sequence gnus-summary-prepare-exit-hook))) + (run-hooks 'gnus-summary-prepare-exit-hook) (when (gnus-buffer-live-p gnus-article-buffer) (save-excursion (set-buffer gnus-article-buffer) @@ -5622,10 +6603,13 @@ (gnus-deaden-summary) (gnus-close-group group) (gnus-summary-clear-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) (set-buffer gnus-group-buffer) (gnus-summary-clear-local-variables) - (when (get-buffer gnus-summary-buffer) - (kill-buffer gnus-summary-buffer))) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) + (gnus-kill-buffer gnus-summary-buffer)) (unless gnus-single-article-buffer (setq gnus-article-current nil)) (when gnus-use-trees @@ -5637,10 +6621,12 @@ (gnus-configure-windows 'group 'force) ;; Clear the current group name. (setq gnus-newsgroup-name nil) + (unless (gnus-ephemeral-group-p group) + (gnus-group-update-group group)) (when (equal (gnus-group-group-name) group) (gnus-group-next-unread-group 1)) (when quit-config - (gnus-handle-ephemeral-exit quit-config))))) + (gnus-handle-ephemeral-exit quit-config))))) (defun gnus-handle-ephemeral-exit (quit-config) "Handle movement when leaving an ephemeral group. @@ -5649,25 +6635,28 @@ (gnus-configure-windows 'group 'force) (set-buffer (car quit-config)) (cond ((eq major-mode 'gnus-summary-mode) - (gnus-set-global-variables)) - ((eq major-mode 'gnus-article-mode) - (save-excursion - ;; The `gnus-summary-buffer' variable may point - ;; to the old summary buffer when using a single - ;; article buffer. - (unless (gnus-buffer-live-p gnus-summary-buffer) - (set-buffer gnus-group-buffer)) - (set-buffer gnus-summary-buffer) - (gnus-set-global-variables)))) + (gnus-set-global-variables)) + ((eq major-mode 'gnus-article-mode) + (save-excursion + ;; The `gnus-summary-buffer' variable may point + ;; to the old summary buffer when using a single + ;; article buffer. + (unless (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-group-buffer)) + (set-buffer gnus-summary-buffer) + (gnus-set-global-variables)))) (if (or (eq (cdr quit-config) 'article) - (eq (cdr quit-config) 'pick)) - (progn - ;; The current article may be from the ephemeral group - ;; thus it is best that we reload this article - (gnus-summary-show-article) - (if (and (boundp 'gnus-pick-mode) (symbol-value 'gnus-pick-mode)) - (gnus-configure-windows 'pick 'force) - (gnus-configure-windows (cdr quit-config) 'force))) + (eq (cdr quit-config) 'pick)) + (progn + ;; The current article may be from the ephemeral group + ;; thus it is best that we reload this article + ;; + ;; If we're exiting from a large digest, this can be + ;; extremely slow. So, it's better not to reload it. -- jh. + ;;(gnus-summary-show-article) + (if (and (boundp 'gnus-pick-mode) (symbol-value 'gnus-pick-mode)) + (gnus-configure-windows 'pick 'force) + (gnus-configure-windows (cdr quit-config) 'force))) (gnus-configure-windows (cdr quit-config) 'force)) (when (eq major-mode 'gnus-summary-mode) (gnus-summary-next-subject 1 nil t) @@ -5683,10 +6672,11 @@ (suppress-keymap gnus-dead-summary-mode-map) (substitute-key-definition 'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map) - (let ((keys '("\C-d" "\r" "\177" [delete]))) - (while keys - (define-key gnus-dead-summary-mode-map - (pop keys) 'gnus-summary-wake-up-the-dead)))) + (dolist (key '("\C-d" "\r" "\177" [delete])) + (define-key gnus-dead-summary-mode-map + key 'gnus-summary-wake-up-the-dead)) + (dolist (key '("q" "Q")) + (define-key gnus-dead-summary-mode-map key 'bury-buffer))) (defvar gnus-dead-summary-mode nil "Minor mode for Gnus summary buffers.") @@ -5732,17 +6722,20 @@ (set-buffer buffer) (gnus-kill-buffer gnus-article-buffer) (gnus-kill-buffer gnus-original-article-buffer))) - (cond (gnus-kill-summary-on-exit - (when (and gnus-use-trees - (gnus-buffer-exists-p buffer)) - (save-excursion - (set-buffer buffer) - (gnus-tree-close gnus-newsgroup-name))) - (gnus-kill-buffer buffer)) - ((gnus-buffer-exists-p buffer) - (save-excursion - (set-buffer buffer) - (gnus-deaden-summary)))))) + (cond + ;; Kill the buffer. + (gnus-kill-summary-on-exit + (when (and gnus-use-trees + (gnus-buffer-exists-p buffer)) + (save-excursion + (set-buffer buffer) + (gnus-tree-close gnus-newsgroup-name))) + (gnus-kill-buffer buffer)) + ;; Deaden the buffer. + ((gnus-buffer-exists-p buffer) + (save-excursion + (set-buffer buffer) + (gnus-deaden-summary)))))) (defun gnus-summary-wake-up-the-dead (&rest args) "Wake up the dead summary buffer." @@ -5789,7 +6782,7 @@ (defun gnus-summary-next-group (&optional no-article target-group backward) "Exit current newsgroup and then select next unread newsgroup. If prefix argument NO-ARTICLE is non-nil, no article is selected -initially. If NEXT-GROUP, go to this group. If BACKWARD, go to +initially. If TARGET-GROUP, go to this group. If BACKWARD, go to previous group instead." (interactive "P") ;; Stop pre-fetching. @@ -5826,10 +6819,10 @@ (let ((unreads (gnus-group-group-unread))) (if (and (or (eq t unreads) (and unreads (not (zerop unreads)))) - (gnus-summary-read-group - target-group nil no-article - (and (buffer-name current-buffer) current-buffer) - nil backward)) + (gnus-summary-read-group + target-group nil no-article + (and (buffer-name current-buffer) current-buffer) + nil backward)) (setq entered t) (setq current-group target-group target-group nil))))))) @@ -5842,38 +6835,56 @@ ;; Walking around summary lines. -(defun gnus-summary-first-subject (&optional unread undownloaded) - "Go to the first unread subject. -If UNREAD is non-nil, go to the first unread article. -Returns the article selected or nil if there are no unread articles." +(defun gnus-summary-first-subject (&optional unread undownloaded unseen) + "Go to the first subject satisfying any non-nil constraint. +If UNREAD is non-nil, the article should be unread. +If UNDOWNLOADED is non-nil, the article should be undownloaded. +If UNSEEN is non-nil, the article should be unseen. +Returns the article selected or nil if there are no matching articles." (interactive "P") - (prog1 - (cond - ;; Empty summary. - ((null gnus-newsgroup-data) - (gnus-message 3 "No articles in the group") - nil) - ;; Pick the first article. - ((not unread) - (goto-char (gnus-data-pos (car gnus-newsgroup-data))) - (gnus-data-number (car gnus-newsgroup-data))) - ;; No unread articles. - ((null gnus-newsgroup-unreads) - (gnus-message 3 "No more unread articles") - nil) - ;; Find the first unread article. - (t - (let ((data gnus-newsgroup-data)) - (while (and data - (and (not (and undownloaded - (eq gnus-undownloaded-mark - (gnus-data-mark (car data))))) - (not (gnus-data-unread-p (car data))))) - (setq data (cdr data))) - (when data - (goto-char (gnus-data-pos (car data))) - (gnus-data-number (car data)))))) - (gnus-summary-position-point))) + (cond + ;; Empty summary. + ((null gnus-newsgroup-data) + (gnus-message 3 "No articles in the group") + nil) + ;; Pick the first article. + ((not (or unread undownloaded unseen)) + (goto-char (gnus-data-pos (car gnus-newsgroup-data))) + (gnus-data-number (car gnus-newsgroup-data))) + ;; Find the first unread article. + (t + (let ((data gnus-newsgroup-data)) + (while (and data + (let ((num (gnus-data-number (car data)))) + (or (memq num gnus-newsgroup-unfetched) + (not (or (and unread + (memq num gnus-newsgroup-unreads)) + (and undownloaded + (memq num gnus-newsgroup-undownloaded)) + (and unseen + (memq num gnus-newsgroup-unseen))))))) + (setq data (cdr data))) + (prog1 + (if data + (progn + (goto-char (gnus-data-pos (car data))) + (gnus-data-number (car data))) + (gnus-message 3 "No more%s articles" + (let* ((r (when unread " unread")) + (d (when undownloaded " undownloaded")) + (s (when unseen " unseen")) + (l (delq nil (list r d s)))) + (cond ((= 3 (length l)) + (concat r "," d ", or" s)) + ((= 2 (length l)) + (concat (car l) ", or" (cadr l))) + ((= 1 (length l)) + (car l)) + (t + "")))) + nil + ) + (gnus-summary-position-point)))))) (defun gnus-summary-next-subject (n &optional unread dont-display) "Go to next N'th summary line. @@ -5914,10 +6925,20 @@ (interactive "p") (gnus-summary-next-subject (- n) t)) +(defun gnus-summary-goto-subjects (articles) + "Insert the subject header for ARTICLES in the current buffer." + (save-excursion + (dolist (article articles) + (gnus-summary-goto-subject article t))) + (gnus-summary-limit (append articles gnus-newsgroup-limit)) + (gnus-summary-position-point)) + (defun gnus-summary-goto-subject (article &optional force silent) "Go the subject line of ARTICLE. If FORCE, also allow jumping to articles not currently shown." (interactive "nArticle number: ") + (unless (numberp article) + (error "Article %s is not a number" article)) (let ((b (point)) (data (gnus-data-find article))) ;; We read in the article if we have to. @@ -5934,7 +6955,9 @@ (unless silent (gnus-message 3 "Can't find article %d" article)) nil) - (goto-char (gnus-data-pos data)) + (let ((pt (gnus-data-pos data))) + (goto-char pt) + (gnus-summary-set-article-display-arrow pt)) (gnus-summary-position-point) article))) @@ -5954,6 +6977,11 @@ (with-current-buffer gnus-article-buffer (mm-enable-multibyte))) (gnus-set-global-variables) + (when (gnus-buffer-live-p gnus-article-buffer) + (with-current-buffer gnus-article-buffer + (setq gnus-article-charset gnus-newsgroup-charset) + (setq gnus-article-ignored-charsets gnus-newsgroup-ignored-charsets) + (mm-enable-multibyte))) (if (null article) nil (prog1 @@ -6004,18 +7032,25 @@ (progn (gnus-summary-display-article article all-headers) (when (gnus-buffer-live-p gnus-article-buffer) - (with-current-buffer gnus-article-buffer + (with-current-buffer gnus-article-buffer (if (not gnus-article-decoded-p) ;; a local variable (mm-disable-multibyte)))) - (when (or all-headers gnus-show-all-headers) - (gnus-article-show-all-headers)) (gnus-article-set-window-start (cdr (assq article gnus-newsgroup-bookmarks))) article) - (when (or all-headers gnus-show-all-headers) - (gnus-article-show-all-headers)) 'old)))) +(defun gnus-summary-force-verify-and-decrypt () + "Display buttons for signed/encrypted parts and verify/decrypt them." + (interactive) + (let ((mm-verify-option 'known) + (mm-decrypt-option 'known) + (gnus-article-emulate-mime t) + (gnus-buttonized-mime-types (append (list "multipart/signed" + "multipart/encrypted") + gnus-buttonized-mime-types))) + (gnus-summary-select-article nil 'force))) + (defun gnus-summary-set-current-mark (&optional current-mark) "Obsolete function." nil) @@ -6087,7 +7122,7 @@ (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1)) (?\C-p (gnus-group-prev-unread-group 1)))) (cursor-in-echo-area t) - keve key group ended) + keve key group ended prompt) (save-excursion (set-buffer gnus-group-buffer) (goto-char start) @@ -6096,19 +7131,20 @@ (gnus-summary-best-group gnus-newsgroup-name) (gnus-summary-search-group backward gnus-keep-same-level)))) (while (not ended) - (gnus-message - 5 "No more%s articles%s" (if unread " unread" "") - (if (and group - (not (gnus-ephemeral-group-p gnus-newsgroup-name))) - (format " (Type %s for %s [%s])" - (single-key-description cmd) group - (car (gnus-gethash group gnus-newsrc-hashtb))) - (format " (Type %s to exit %s)" - (single-key-description cmd) - gnus-newsgroup-name))) + (setq prompt + (format + "No more%s articles%s " (if unread " unread" "") + (if (and group + (not (gnus-ephemeral-group-p gnus-newsgroup-name))) + (format " (Type %s for %s [%s])" + (single-key-description cmd) group + (car (gnus-gethash group gnus-newsrc-hashtb))) + (format " (Type %s to exit %s)" + (single-key-description cmd) + gnus-newsgroup-name)))) ;; Confirm auto selection. - (setq key (car (setq keve (gnus-read-event-char)))) - (setq ended t) + (setq key (car (setq keve (gnus-read-event-char prompt))) + ended t) (cond ((assq key keystrokes) (let ((obuf (current-buffer))) @@ -6151,14 +7187,18 @@ (and gnus-auto-select-same (gnus-summary-article-subject)))) -(defun gnus-summary-next-page (&optional lines circular) +(defun gnus-summary-next-page (&optional lines circular stop) "Show next page of the selected article. If at the end of the current article, select the next article. LINES says how many lines should be scrolled up. If CIRCULAR is non-nil, go to the start of the article instead of selecting the next article when reaching the end of the current -article." +article. + +If STOP is non-nil, just stop when reaching the end of the message. + +Also see the variable `gnus-article-skip-boring'." (interactive "P") (setq gnus-summary-buffer (current-buffer)) (gnus-set-global-variables) @@ -6182,9 +7222,12 @@ (gnus-summary-display-article article) (when article-window (gnus-eval-in-buffer-window gnus-article-buffer - (setq endp (gnus-article-next-page lines))) + (setq endp (or (gnus-article-next-page lines) + (gnus-article-only-boring-p)))) (when endp - (cond (circular + (cond (stop + (gnus-message 3 "End of message")) + (circular (gnus-summary-beginning-of-article)) (lines (gnus-message 3 "End of message")) @@ -6296,6 +7339,30 @@ (gnus-summary-first-subject t)) (gnus-summary-position-point))) +(defun gnus-summary-first-unseen-subject () + "Place the point on the subject line of the first unseen article. +Return nil if there are no unseen articles." + (interactive) + (prog1 + (when (gnus-summary-first-subject nil nil t) + (gnus-summary-show-thread) + (gnus-summary-first-subject nil nil t)) + (gnus-summary-position-point))) + +(defun gnus-summary-first-unseen-or-unread-subject () + "Place the point on the subject line of the first unseen article or, +if all article have been seen, on the subject line of the first unread +article." + (interactive) + (prog1 + (unless (when (gnus-summary-first-subject nil nil t) + (gnus-summary-show-thread) + (gnus-summary-first-subject nil nil t)) + (when (gnus-summary-first-subject t) + (gnus-summary-show-thread) + (gnus-summary-first-subject t))) + (gnus-summary-position-point))) + (defun gnus-summary-first-article () "Select the first article. Return nil if there are no articles." @@ -6307,8 +7374,20 @@ (gnus-summary-display-article (gnus-summary-article-number))) (gnus-summary-position-point))) -(defun gnus-summary-best-unread-article () - "Select the unread article with the highest score." +(defun gnus-summary-best-unread-article (&optional arg) + "Select the unread article with the highest score. +If given a prefix argument, select the next unread article that has a +score higher than the default score." + (interactive "P") + (let ((article (if arg + (gnus-summary-better-unread-subject) + (gnus-summary-best-unread-subject)))) + (if article + (gnus-summary-goto-article article) + (error "No unread articles")))) + +(defun gnus-summary-best-unread-subject () + "Select the unread subject with the highest score." (interactive) (let ((best -1000000) (data gnus-newsgroup-data) @@ -6321,11 +7400,25 @@ (setq best score article (gnus-data-number (car data)))) (setq data (cdr data))) - (prog1 - (if article - (gnus-summary-goto-article article) - (error "No unread articles")) - (gnus-summary-position-point)))) + (when article + (gnus-summary-goto-subject article)) + (gnus-summary-position-point) + article)) + +(defun gnus-summary-better-unread-subject () + "Select the first unread subject that has a score over the default score." + (interactive) + (let ((data gnus-newsgroup-data) + article score) + (while (and (setq article (gnus-data-number (car data))) + (or (gnus-data-read-p (car data)) + (not (> (gnus-summary-article-score article) + gnus-summary-default-score)))) + (setq data (cdr data))) + (when article + (gnus-summary-goto-subject article)) + (gnus-summary-position-point) + article)) (defun gnus-summary-last-subject () "Go to the last displayed subject line in the group." @@ -6348,7 +7441,7 @@ t)) (prog1 (if (and (stringp article) - (string-match "@" article)) + (string-match "@\\|%40" article)) (gnus-summary-refer-article article) (when (stringp article) (setq article (string-to-number article))) @@ -6443,12 +7536,18 @@ days) (while (not days-got) (setq days (if younger - (read-string "Limit to articles within (in days): ") - (read-string "Limit to articles old than (in days): "))) + (read-string "Limit to articles younger than (in days, older when negative): ") + (read-string + "Limit to articles older than (in days, younger when negative): "))) (when (> (length days) 0) (setq days (read days))) (if (numberp days) - (setq days-got t) + (progn + (setq days-got t) + (if (< days 0) + (progn + (setq younger (not younger)) + (setq days (* days -1))))) (message "Please enter a number.") (sleep-for 1))) (list days younger))) @@ -6476,7 +7575,7 @@ (interactive (let ((header (intern - (gnus-completing-read + (gnus-completing-read-with-default (symbol-name (car gnus-extra-headers)) (if current-prefix-arg "Exclude extra header:" @@ -6501,6 +7600,18 @@ (gnus-summary-limit articles)) (gnus-summary-position-point)))) +(defun gnus-summary-limit-to-display-predicate () + "Limit the summary buffer to the predicated in the `display' group parameter." + (interactive) + (unless gnus-newsgroup-display + (error "There is no `display' group parameter")) + (let (articles) + (dolist (number gnus-newsgroup-articles) + (when (funcall gnus-newsgroup-display) + (push number articles))) + (gnus-summary-limit articles)) + (gnus-summary-position-point)) + (defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) (make-obsolete 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) @@ -6515,7 +7626,7 @@ ;; Concat all the marks that say that an article is read and have ;; those removed. (list gnus-del-mark gnus-read-mark gnus-ancient-mark - gnus-killed-mark gnus-kill-file-mark + gnus-killed-mark gnus-spam-mark gnus-kill-file-mark gnus-low-score-mark gnus-expirable-mark gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark gnus-duplicate-mark gnus-souped-mark) @@ -6553,12 +7664,9 @@ (gnus-summary-limit articles)) (gnus-summary-position-point))) -(defun gnus-summary-limit-to-score (&optional score) +(defun gnus-summary-limit-to-score (score) "Limit to articles with score at or above SCORE." - (interactive "P") - (setq score (if score - (prefix-numeric-value score) - (or gnus-summary-default-score 0))) + (interactive "NLimit to articles with score of at least: ") (let ((data gnus-newsgroup-data) articles) (while data @@ -6570,15 +7678,45 @@ (gnus-summary-limit articles) (gnus-summary-position-point)))) +(defun gnus-summary-limit-to-unseen () + "Limit to unseen articles." + (interactive) + (prog1 + (gnus-summary-limit gnus-newsgroup-unseen) + (gnus-summary-position-point))) + (defun gnus-summary-limit-include-thread (id) - "Display all the hidden articles that in the current thread." + "Display all the hidden articles that is in the thread with ID in it. +When called interactively, ID is the Message-ID of the current +article." (interactive (list (mail-header-id (gnus-summary-article-header)))) (let ((articles (gnus-articles-in-thread (gnus-id-to-thread (gnus-root-id id))))) (prog1 (gnus-summary-limit (nconc articles gnus-newsgroup-limit)) + (gnus-summary-limit-include-matching-articles + "subject" + (regexp-quote (gnus-simplify-subject-re + (mail-header-subject (gnus-id-to-header id))))) (gnus-summary-position-point)))) +(defun gnus-summary-limit-include-matching-articles (header regexp) + "Display all the hidden articles that have HEADERs that match REGEXP." + (interactive (list (read-string "Match on header: ") + (read-string "Regexp: "))) + (let ((articles (gnus-find-matching-articles header regexp))) + (prog1 + (gnus-summary-limit (nconc articles gnus-newsgroup-limit)) + (gnus-summary-position-point)))) + +(defun gnus-summary-insert-dormant-articles () + "Insert all the dormant articles for this group into the current buffer." + (interactive) + (let ((gnus-verbose (max 6 gnus-verbose))) + (if (not gnus-newsgroup-dormant) + (gnus-message 3 "No cached articles for this group") + (gnus-summary-goto-subjects gnus-newsgroup-dormant)))) + (defun gnus-summary-limit-include-dormant () "Display all the hidden articles that are marked as dormant. Note that this command only works on a subset of the articles currently @@ -6625,15 +7763,17 @@ "Mark all unread excluded articles as read. If ALL, mark even excluded ticked and dormants as read." (interactive "P") - (let ((articles (gnus-sorted-complement + (setq gnus-newsgroup-limit (sort gnus-newsgroup-limit '<)) + (let ((articles (gnus-sorted-ndifference (sort (mapcar (lambda (h) (mail-header-number h)) gnus-newsgroup-headers) '<) - (sort gnus-newsgroup-limit '<))) + gnus-newsgroup-limit)) article) (setq gnus-newsgroup-unreads - (gnus-intersection gnus-newsgroup-unreads gnus-newsgroup-limit)) + (gnus-sorted-intersection gnus-newsgroup-unreads + gnus-newsgroup-limit)) (if all (setq gnus-newsgroup-dormant nil gnus-newsgroup-marked nil @@ -6663,9 +7803,7 @@ ;; according to the new limit. (gnus-summary-prepare) ;; Hide any threads, possibly. - (and gnus-show-threads - gnus-thread-hide-subtree - (gnus-summary-hide-all-threads)) + (gnus-summary-maybe-hide-threads) ;; Try to return to the article you were at, or one in the ;; neighborhood. (when data @@ -6725,7 +7863,7 @@ thread) (defun gnus-cut-threads (threads) - "Cut off all uninteresting articles from the beginning of threads." + "Cut off all uninteresting articles from the beginning of THREADS." (when (or (eq gnus-fetch-old-headers 'some) (eq gnus-fetch-old-headers 'invisible) (numberp gnus-fetch-old-headers) @@ -6745,6 +7883,7 @@ ;; Most groups have nothing to remove. (if (or gnus-inhibit-limiting (and (null gnus-newsgroup-dormant) + (eq gnus-newsgroup-display 'gnus-not-ignore) (not (eq gnus-fetch-old-headers 'some)) (not (numberp gnus-fetch-old-headers)) (not (eq gnus-fetch-old-headers 'invisible)) @@ -6784,7 +7923,8 @@ ;; will really go down to a leaf article first, before slowly ;; working its way up towards the root. (when thread - (let ((children + (let* ((max-lisp-eval-depth 5000) + (children (if (cdr thread) (apply '+ (mapcar 'gnus-summary-limit-children (cdr thread))) @@ -6833,6 +7973,9 @@ (push (cons number gnus-low-score-mark) gnus-newsgroup-reads))) t) + ;; Do the `display' group parameter. + (and gnus-newsgroup-display + (not (funcall gnus-newsgroup-display))) ;; Check NoCeM things. (if (and gnus-use-nocem (gnus-nocem-unwanted-article-p @@ -6890,7 +8033,8 @@ (set-buffer gnus-original-article-buffer) (nnheader-narrow-to-headers) (unless (setq ref (message-fetch-field "references")) - (setq ref (message-fetch-field "in-reply-to"))) + (when (setq ref (message-fetch-field "in-reply-to")) + (setq ref (gnus-extract-message-id-from-in-reply-to ref)))) (widen)) (setq ref ;; It's not the current article, so we take a bet on @@ -6936,19 +8080,24 @@ (let ((id (mail-header-id (gnus-summary-article-header))) (limit (if limit (prefix-numeric-value limit) gnus-refer-thread-limit))) - ;; We want to fetch LIMIT *old* headers, but we also have to - ;; re-fetch all the headers in the current buffer, because many of - ;; them may be undisplayed. So we adjust LIMIT. - (when (numberp limit) - (incf limit (- gnus-newsgroup-end gnus-newsgroup-begin))) (unless (eq gnus-fetch-old-headers 'invisible) (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) ;; Retrieve the headers and read them in. - (if (eq (gnus-retrieve-headers - (list gnus-newsgroup-end) gnus-newsgroup-name limit) + (if (eq (if (numberp limit) + (gnus-retrieve-headers + (list (min + (+ (mail-header-number + (gnus-summary-article-header)) + limit) + gnus-newsgroup-end)) + gnus-newsgroup-name (* limit 2)) + ;; gnus-refer-thread-limit is t, i.e. fetch _all_ + ;; headers. + (gnus-retrieve-headers (list gnus-newsgroup-end) + gnus-newsgroup-name limit)) 'nov) (gnus-build-all-threads) - (error "Can't fetch thread from backends that don't support NOV")) + (error "Can't fetch thread from back ends that don't support NOV")) (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)) (gnus-summary-limit-include-thread id))) @@ -6957,12 +8106,16 @@ (interactive "sMessage-ID: ") (when (and (stringp message-id) (not (zerop (length message-id)))) + (setq message-id (gnus-replace-in-string message-id " " "")) ;; Construct the correct Message-ID if necessary. ;; Suggested by tale@pawl.rpi.edu. (unless (string-match "^<" message-id) (setq message-id (concat "<" message-id))) (unless (string-match ">$" message-id) (setq message-id (concat message-id ">"))) + ;; People often post MIDs from URLs, so unhex it: + (unless (string-match "@" message-id) + (setq message-id (gnus-url-unhex-string message-id))) (let* ((header (gnus-id-to-header message-id)) (sparse (and header (gnus-summary-article-sparse-p @@ -6985,9 +8138,10 @@ ;; We fetch the article. (catch 'found (dolist (gnus-override-method (gnus-refer-article-methods)) - (gnus-check-server gnus-override-method) - ;; Fetch the header, and display the article. - (when (setq number (gnus-summary-insert-subject message-id)) + (when (and (gnus-check-server gnus-override-method) + ;; Fetch the header, + (setq number (gnus-summary-insert-subject message-id))) + ;; and display the article. (gnus-summary-select-article nil nil nil number) (throw 'found t))) (gnus-message 3 "Couldn't fetch article %s" message-id))))))) @@ -7031,8 +8185,12 @@ to guess what the document format is." (interactive "P") (let ((conf gnus-current-window-configuration)) - (save-excursion - (gnus-summary-select-article)) + (save-window-excursion + (save-excursion + (let (gnus-article-prepare-hook + gnus-display-mime-function + gnus-break-pages) + (gnus-summary-select-article)))) (setq gnus-current-window-configuration conf) (let* ((name (format "%s-%d" (gnus-group-prefixed-name @@ -7043,6 +8201,7 @@ (ogroup gnus-newsgroup-name) (params (append (gnus-info-params (gnus-get-info ogroup)) (list (cons 'to-group ogroup)) + (list (cons 'parent-group ogroup)) (list (cons 'save-article-group ogroup)))) (case-fold-search t) (buf (current-buffer)) @@ -7051,8 +8210,8 @@ (set-buffer gnus-original-article-buffer) ;; Have the digest group inherit the main mail address of ;; the parent article. - (when (setq to-address (or (message-fetch-field "reply-to") - (message-fetch-field "from"))) + (when (setq to-address (or (gnus-fetch-field "reply-to") + (gnus-fetch-field "from"))) (setq params (append (list (cons 'to-address (funcall gnus-decode-encoded-word-function @@ -7068,21 +8227,24 @@ (delete-matching-lines "^Path:\\|^From ") (widen)) (unwind-protect - (if (let ((gnus-newsgroup-ephemeral-charset gnus-newsgroup-charset) + (if (let ((gnus-newsgroup-ephemeral-charset gnus-newsgroup-charset) (gnus-newsgroup-ephemeral-ignored-charsets gnus-newsgroup-ignored-charsets)) (gnus-group-read-ephemeral-group name `(nndoc ,name (nndoc-address ,(get-buffer dig)) (nndoc-article-type - ,(if force 'mbox 'guess))) t)) + ,(if force 'mbox 'guess))) + t nil nil nil + `((adapt-file . ,(gnus-score-file-name gnus-newsgroup-name + "ADAPT"))))) ;; Make all postings to this group go to the parent group. - (nconc (gnus-info-params (gnus-get-info name)) - params) - ;; Couldn't select this doc group. - (switch-to-buffer buf) - (gnus-set-global-variables) - (gnus-configure-windows 'summary) - (gnus-message 3 "Article couldn't be entered?")) + (nconc (gnus-info-params (gnus-get-info name)) + params) + ;; Couldn't select this doc group. + (switch-to-buffer buf) + (gnus-set-global-variables) + (gnus-configure-windows 'summary) + (gnus-message 3 "Article couldn't be entered?")) (kill-buffer dig))))) (defun gnus-summary-read-document (n) @@ -7115,7 +8277,7 @@ (nndoc-article-type guess)) t nil t)) (progn - ;; Make all postings to this group go to the parent group. + ;; Make all postings to this group go to the parent group. (nconc (gnus-info-params (gnus-get-info egroup)) params) (push egroup groups)) @@ -7159,10 +8321,14 @@ current-prefix-arg)) (if (string-equal regexp "") (setq regexp (or gnus-last-search-regexp "")) - (setq gnus-last-search-regexp regexp)) - (if (gnus-summary-search-article regexp backward) - (gnus-summary-show-thread) - (error "Search failed: \"%s\"" regexp))) + (setq gnus-last-search-regexp regexp) + (setq gnus-article-before-search gnus-current-article)) + ;; Intentionally set gnus-last-article. + (setq gnus-last-article gnus-article-before-search) + (let ((gnus-last-article gnus-last-article)) + (if (gnus-summary-search-article regexp backward) + (gnus-summary-show-thread) + (error "Search failed: \"%s\"" regexp)))) (defun gnus-summary-search-article-backward (regexp) "Search for an article containing REGEXP backward." @@ -7188,6 +8354,12 @@ (gnus-use-article-prefetch nil) (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay. (gnus-use-trees nil) ;Inhibit updating tree buffer. + (gnus-visual nil) + (gnus-keep-backlog nil) + (gnus-break-pages nil) + (gnus-summary-display-arrow nil) + (gnus-updated-mode-lines nil) + (gnus-auto-center-summary nil) (sum (current-buffer)) (gnus-display-mime-function nil) (found nil) @@ -7241,6 +8413,18 @@ (gnus-summary-position-point) t))) +(defun gnus-find-matching-articles (header regexp) + "Return a list of all articles that match REGEXP on HEADER. +This search includes all articles in the current group that Gnus has +fetched headers for, whether they are displayed or not." + (let ((articles nil) + (func `(lambda (h) (,(intern (concat "mail-header-" header)) h))) + (case-fold-search t)) + (dolist (header gnus-newsgroup-headers) + (when (string-match regexp (funcall func header)) + (push (mail-header-number header) articles))) + (nreverse articles))) + (defun gnus-summary-find-matching (header regexp &optional backward unread not-case-fold not-matching) "Return a list of all articles that match REGEXP on HEADER. @@ -7287,9 +8471,11 @@ (list (let ((completion-ignore-case t)) (completing-read "Header name: " - (mapcar (lambda (string) (list string)) - '("Number" "Subject" "From" "Lines" "Date" - "Message-ID" "Xref" "References" "Body")) + (mapcar (lambda (header) (list (format "%s" header))) + (append + '("Number" "Subject" "From" "Lines" "Date" + "Message-ID" "Xref" "References" "Body") + gnus-extra-headers)) nil 'require-match)) (read-string "Regexp: ") (read-key-sequence "Command: ") @@ -7301,12 +8487,19 @@ ;; We don't want to change current point nor window configuration. (save-excursion (save-window-excursion - (gnus-message 6 "Executing %s..." (key-description command)) - ;; We'd like to execute COMMAND interactively so as to give arguments. - (gnus-execute header regexp - `(call-interactively ',(key-binding command)) - backward) - (gnus-message 6 "Executing %s...done" (key-description command))))) + (let (gnus-visual + gnus-treat-strip-trailing-blank-lines + gnus-treat-strip-leading-blank-lines + gnus-treat-strip-multiple-blank-lines + gnus-treat-hide-boring-headers + gnus-treat-fold-newsgroups + gnus-article-prepare-hook) + (gnus-message 6 "Executing %s..." (key-description command)) + ;; We'd like to execute COMMAND interactively so as to give arguments. + (gnus-execute header regexp + `(call-interactively ',(key-binding command)) + backward) + (gnus-message 6 "Executing %s...done" (key-description command)))))) (defun gnus-summary-beginning-of-article () "Scroll the article back to the beginning." @@ -7316,7 +8509,7 @@ (gnus-eval-in-buffer-window gnus-article-buffer (widen) (goto-char (point-min)) - (when gnus-page-broken + (when gnus-break-pages (gnus-narrow-to-page)))) (defun gnus-summary-end-of-article () @@ -7328,14 +8521,29 @@ (widen) (goto-char (point-max)) (recenter -3) - (when gnus-page-broken + (when gnus-break-pages + (when (re-search-backward page-delimiter nil t) + (narrow-to-region (match-end 0) (point-max))) (gnus-narrow-to-page)))) +(defun gnus-summary-print-truncate-and-quote (string &optional len) + "Truncate to LEN and quote all \"(\"'s in STRING." + (gnus-replace-in-string (if (and len (> (length string) len)) + (substring string 0 len) + string) + "[()]" "\\\\\\&")) + (defun gnus-summary-print-article (&optional filename n) - "Generate and print a PostScript image of the N next (mail) articles. - -If N is negative, print the N previous articles. If N is nil and articles -have been marked with the process mark, print these instead. + "Generate and print a PostScript image of the process-marked (mail) articles. + +If used interactively, print the current article if none are +process-marked. With prefix arg, prompt the user for the name of the +file to save in. + +When used from Lisp, accept two optional args FILENAME and N. N means +to print the next N articles. If N is negative, print the N previous +articles. If N is nil and articles have been marked with the process +mark, print these instead. If the optional first argument FILENAME is nil, send the image to the printer. If FILENAME is a string, save the PostScript image in a file with @@ -7345,45 +8553,95 @@ (dolist (article (gnus-summary-work-articles n)) (gnus-summary-select-article nil nil 'pseudo article) (gnus-eval-in-buffer-window gnus-article-buffer - (let ((buffer (generate-new-buffer " *print*"))) - (unwind-protect - (progn - (copy-to-buffer buffer (point-min) (point-max)) - (set-buffer buffer) - (gnus-article-delete-invisible-text) - (let ((ps-left-header - (list - (concat "(" - (mail-header-subject gnus-current-headers) ")") - (concat "(" - (mail-header-from gnus-current-headers) ")"))) - (ps-right-header - (list - "/pagenumberstring load" - (concat "(" - (mail-header-date gnus-current-headers) ")")))) - (gnus-run-hooks 'gnus-ps-print-hook) - (save-excursion - (ps-spool-buffer-with-faces)))) - (kill-buffer buffer)))) + (gnus-print-buffer)) (gnus-summary-remove-process-mark article)) (ps-despool filename)) +(defun gnus-print-buffer () + (let ((buffer (generate-new-buffer " *print*"))) + (unwind-protect + (progn + (copy-to-buffer buffer (point-min) (point-max)) + (set-buffer buffer) + (gnus-remove-text-with-property 'gnus-decoration) + (when (gnus-visual-p 'article-highlight 'highlight) + ;; Copy-to-buffer doesn't copy overlay. So redo + ;; highlight. + (let ((gnus-article-buffer buffer)) + (gnus-article-highlight-citation t) + (gnus-article-highlight-signature) + (gnus-article-emphasize) + (gnus-article-delete-invisible-text))) + (let ((ps-left-header + (list + (concat "(" + (gnus-summary-print-truncate-and-quote + (mail-header-subject gnus-current-headers) + 66) ")") + (concat "(" + (gnus-summary-print-truncate-and-quote + (mail-header-from gnus-current-headers) + 45) ")"))) + (ps-right-header + (list + "/pagenumberstring load" + (concat "(" + (mail-header-date gnus-current-headers) ")")))) + (gnus-run-hooks 'gnus-ps-print-hook) + (save-excursion + (if window-system + (ps-spool-buffer-with-faces) + (ps-spool-buffer))))) + (kill-buffer buffer)))) + (defun gnus-summary-show-article (&optional arg) - "Force re-fetching of the current article. + "Force redisplaying of the current article. If ARG (the prefix) is a number, show the article with the charset defined in `gnus-summary-show-article-charset-alist', or the charset -inputed. +input. If ARG (the prefix) is non-nil and not a number, show the raw article -without any article massaging functions being run." +without any article massaging functions being run. Normally, the key +strokes are `C-u g'." (interactive "P") (cond ((numberp arg) + (gnus-summary-show-article t) (let ((gnus-newsgroup-charset (or (cdr (assq arg gnus-summary-show-article-charset-alist)) - (read-coding-system "Charset: "))) + (mm-read-coding-system + "View as charset: " ;; actually it is coding system. + (save-excursion + (set-buffer gnus-article-buffer) + (mm-detect-coding-region (point) (point-max)))))) (gnus-newsgroup-ignored-charsets 'gnus-all)) - (gnus-summary-select-article nil 'force))) + (gnus-summary-select-article nil 'force) + (let ((deps gnus-newsgroup-dependencies) + head header lines) + (save-excursion + (set-buffer gnus-original-article-buffer) + (save-restriction + (message-narrow-to-head) + (setq head (buffer-string)) + (goto-char (point-min)) + (unless (re-search-forward "^lines:[ \t]\\([0-9]+\\)" nil t) + (goto-char (point-max)) + (widen) + (setq lines (1- (count-lines (point) (point-max)))))) + (with-temp-buffer + (insert (format "211 %d Article retrieved.\n" + (cdr gnus-article-current))) + (insert head) + (if lines (insert (format "Lines: %d\n" lines))) + (insert ".\n") + (let ((nntp-server-buffer (current-buffer))) + (setq header (car (gnus-get-newsgroup-headers deps t)))))) + (gnus-data-set-header + (gnus-data-find (cdr gnus-article-current)) + header) + (gnus-summary-update-article-line + (cdr gnus-article-current) header) + (when (gnus-summary-goto-subject (cdr gnus-article-current) nil t) + (gnus-summary-update-secondary-mark (cdr gnus-article-current)))))) ((not arg) ;; Select the article the normal way. (gnus-summary-select-article nil 'force)) @@ -7410,6 +8668,11 @@ (gnus-summary-goto-subject gnus-current-article) (gnus-summary-position-point)) +(defun gnus-summary-show-raw-article () + "Show the raw article without any article massaging functions being run." + (interactive) + (gnus-summary-show-article t)) + (defun gnus-summary-verbose-headers (&optional arg) "Toggle permanent full header display. If ARG is a positive number, turn header display on. @@ -7428,42 +8691,46 @@ If ARG is a positive number, show the entire header. If ARG is a negative number, hide the unwanted header lines." (interactive "P") - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction + (let ((window (and (gnus-buffer-live-p gnus-article-buffer) + (get-buffer-window gnus-article-buffer t)))) + (with-current-buffer gnus-article-buffer + (widen) + (article-narrow-to-head) (let* ((buffer-read-only nil) (inhibit-point-motion-hooks t) - hidden s e) - (setq hidden - (if (numberp arg) - (>= arg 0) - (save-restriction - (article-narrow-to-head) - (gnus-article-hidden-text-p 'headers)))) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (delete-region (point-min) (1- (point)))) - (goto-char (point-min)) + (hidden (if (numberp arg) + (>= arg 0) + (gnus-article-hidden-text-p 'headers))) + s e) + (delete-region (point-min) (point-max)) (with-current-buffer gnus-original-article-buffer (goto-char (setq s (point-min))) - (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) + (setq e (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max)))) (insert-buffer-substring gnus-original-article-buffer s e) - (save-restriction - (narrow-to-region (point-min) (point)) - (article-decode-encoded-words) - (if hidden - (let ((gnus-treat-hide-headers nil) - (gnus-treat-hide-boring-headers nil)) - (setq gnus-article-wash-types - (delq 'headers gnus-article-wash-types)) - (gnus-treat-article 'head)) - (gnus-treat-article 'head))) + (run-hooks 'gnus-article-decode-hook) + (if hidden + (let ((gnus-treat-hide-headers nil) + (gnus-treat-hide-boring-headers nil)) + (gnus-delete-wash-type 'headers) + (gnus-treat-article 'head)) + (gnus-treat-article 'head)) + (widen) + (if window + (set-window-start window (goto-char (point-min)))) + (if gnus-break-pages + (gnus-narrow-to-page) + (when (gnus-visual-p 'page-marker) + (let ((buffer-read-only nil)) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next)))) (gnus-set-mode-line 'article))))) (defun gnus-summary-show-all-headers () "Make all header lines visible." (interactive) - (gnus-article-show-all-headers)) + (gnus-summary-toggle-header 1)) (defun gnus-summary-caesar-message (&optional arg) "Caesar rotate the current article by 13. @@ -7480,6 +8747,31 @@ (message-caesar-buffer-body arg) (set-window-start (get-buffer-window (current-buffer)) start)))))) +(autoload 'unmorse-region "morse" + "Convert morse coded text in region to ordinary ASCII text." + t) + +(defun gnus-summary-morse-message (&optional arg) + "Morse decode the current article." + (interactive "P") + (gnus-summary-select-article) + (let ((mail-header-separator "")) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-excursion + (save-restriction + (widen) + (let ((pos (window-start)) + buffer-read-only) + (goto-char (point-min)) + (when (message-goto-body) + (gnus-narrow-to-body)) + (goto-char (point-min)) + (while (re-search-forward "·" (point-max) t) + (replace-match ".")) + (unmorse-region (point-min) (point-max)) + (widen) + (set-window-start (get-buffer-window (current-buffer)) pos))))))) + (defun gnus-summary-stop-page-breaking () "Stop page breaking in the current article." (interactive) @@ -7503,6 +8795,10 @@ If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but re-spool using this method. +When called interactively with TO-NEWSGROUP being nil, the value of +the variable `gnus-move-split-methods' is used for finding a default +for the target newsgroup. + For this function to work, both the current newsgroup and the newsgroup that you want to move to have to support the `request-move' and `request-accept' functions. @@ -7511,10 +8807,6 @@ (interactive "P") (unless action (setq action 'move)) - ;; Disable marking as read. - (let (gnus-mark-article-hook) - (save-window-excursion - (gnus-summary-select-article))) ;; Check whether the source group supports the required functions. (cond ((and (eq action 'move) (not (gnus-check-backend-function @@ -7526,7 +8818,7 @@ (error "The current group does not support article editing"))) (let ((articles (gnus-summary-work-articles n)) (prefix (if (gnus-check-backend-function - 'request-move-article gnus-newsgroup-name) + 'request-move-article gnus-newsgroup-name) (gnus-group-real-prefix gnus-newsgroup-name) "")) (names '((move "Move" "Moving") @@ -7540,6 +8832,18 @@ ;; Read the newsgroup name. (when (and (not to-newsgroup) (not select-method)) + (if (and gnus-move-split-methods + (not + (and (memq gnus-current-article articles) + (gnus-buffer-live-p gnus-original-article-buffer)))) + ;; When `gnus-move-split-methods' is non-nil, we have to + ;; select an article to give `gnus-read-move-group-name' an + ;; opportunity to suggest an appropriate default. However, + ;; we needn't render or mark the article. + (let ((gnus-display-mime-function nil) + (gnus-article-prepare-hook nil) + (gnus-mark-article-hook nil)) + (gnus-summary-select-article nil nil nil (car articles)))) (setq to-newsgroup (gnus-read-move-group-name (cadr (assq action names)) @@ -7589,7 +8893,7 @@ (mail-header-xref (gnus-summary-article-header article)) " "))) (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) - ":" article)) + ":" (number-to-string article))) (unless xref (setq xref (list (system-name)))) (setq new-xref @@ -7606,7 +8910,8 @@ (gnus-request-accept-article to-newsgroup select-method (not articles)))) (setq new-xref (concat new-xref " " (car art-group) - ":" (cdr art-group))) + ":" + (number-to-string (cdr art-group)))) ;; Now we have the new Xrefs header, so we insert ;; it and replace the new article. (nnheader-replace-header "Xref" new-xref) @@ -7621,14 +8926,21 @@ ((eq art-group 'junk) (when (eq action 'move) (gnus-summary-mark-article article gnus-canceled-mark) - (gnus-message 4 "Deleted article %s" article))) + (gnus-message 4 "Deleted article %s" article) + ;; run the delete hook + (run-hook-with-args 'gnus-summary-article-delete-hook + action + (gnus-data-header + (assoc article (gnus-data-list nil))) + gnus-newsgroup-name nil + select-method))) (t (let* ((pto-group (gnus-group-prefixed-name (car art-group) to-method)) (entry (gnus-gethash pto-group gnus-newsrc-hashtb)) (info (nth 2 entry)) - (to-group (gnus-info-group info)) + (to-group (gnus-info-group info)) to-marks) ;; Update the group that has been moved to. (when (and info @@ -7643,7 +8955,10 @@ (list (cdr art-group))))) ;; See whether the article is to be put in the cache. - (let ((marks gnus-article-mark-lists) + (let ((marks (if (gnus-group-auto-expirable-p to-group) + gnus-article-mark-lists + (delete '(expirable . expire) + (copy-sequence gnus-article-mark-lists)))) (to-article (cdr art-group))) ;; Enter the article into the cache in the new group, @@ -7665,26 +8980,26 @@ (setcdr gnus-newsgroup-active to-article)) (while marks - (when (memq article (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))) - (push (cdar marks) to-marks) - ;; If the other group is the same as this group, - ;; then we have to add the mark to the list. - (when (equal to-group gnus-newsgroup-name) - (set (intern (format "gnus-newsgroup-%s" (caar marks))) - (cons to-article - (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))))) - ;; Copy the marks to other group. - (gnus-add-marked-articles - to-group (cdar marks) (list to-article) info)) + (when (eq (gnus-article-mark-to-type (cdar marks)) 'list) + (when (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + (push (cdar marks) to-marks) + ;; If the other group is the same as this group, + ;; then we have to add the mark to the list. + (when (equal to-group gnus-newsgroup-name) + (set (intern (format "gnus-newsgroup-%s" (caar marks))) + (cons to-article + (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))))) + ;; Copy the marks to other group. + (gnus-add-marked-articles + to-group (cdar marks) (list to-article) info))) (setq marks (cdr marks))) - (gnus-request-set-mark to-group (list (list (list to-article) - 'set - to-marks)))) + (gnus-request-set-mark + to-group (list (list (list to-article) 'add to-marks)))) (gnus-dribble-enter (concat "(gnus-group-set-info '" @@ -7699,22 +9014,29 @@ (gnus-request-article-this-buffer article gnus-newsgroup-name) (nnheader-replace-header "Xref" new-xref) (gnus-request-replace-article - article gnus-newsgroup-name (current-buffer))))) + article gnus-newsgroup-name (current-buffer)))) + + ;; run the move/copy/crosspost/respool hook + (run-hook-with-args 'gnus-summary-article-move-hook + action + (gnus-data-header + (assoc article (gnus-data-list nil))) + gnus-newsgroup-name + to-newsgroup + select-method)) ;;;!!!Why is this necessary? (set-buffer gnus-summary-buffer) - + (gnus-summary-goto-subject article) (when (eq action 'move) (gnus-summary-mark-article article gnus-canceled-mark)))) (gnus-summary-remove-process-mark article)) ;; Re-activate all groups that have been moved to. - (while to-groups - (save-excursion - (set-buffer gnus-group-buffer) - (when (gnus-group-goto-group (car to-groups) t) - (gnus-group-get-new-news-this-group 1 t)) - (pop to-groups))) + (save-excursion + (set-buffer gnus-group-buffer) + (let ((gnus-group-marked to-groups)) + (gnus-group-get-new-news-this-group nil t))) (gnus-kill-buffer copy-buf) (gnus-summary-position-point) @@ -7723,6 +9045,9 @@ (defun gnus-summary-copy-article (&optional n to-newsgroup select-method) "Move the current article to a different newsgroup. If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to. +When called interactively, if TO-NEWSGROUP is nil, use the value of +the variable `gnus-move-split-methods' for finding a default target +newsgroup. If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but re-spool using this method." (interactive "P") @@ -7734,12 +9059,20 @@ (gnus-summary-move-article n nil nil 'crosspost)) (defcustom gnus-summary-respool-default-method nil - "Default method for respooling an article. + "Default method type for respooling an article. If nil, use to the current newsgroup method." - :type '(choice (gnus-select-method :value (nnml "")) - (const nil)) + :type 'symbol :group 'gnus-summary-mail) +(defcustom gnus-summary-display-while-building nil + "If non-nil, show and update the summary buffer as it's being built. +If the value is t, update the buffer after every line is inserted. If +the value is an integer (N), update the display every N lines." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + number + (const :tag "frequently" t))) + (defun gnus-summary-respool-article (&optional n method) "Respool the current article. The article will be squeezed through the mail spooling process again, @@ -7762,7 +9095,7 @@ (car (gnus-find-method-for-group gnus-newsgroup-name))))) (method - (gnus-completing-read + (gnus-completing-read-with-default methname "What backend do you want to use when respooling?" methods nil t nil 'gnus-mail-method-history)) ms) @@ -7784,12 +9117,12 @@ (gnus-summary-move-article n nil method) (gnus-summary-copy-article n nil method))) -(defun gnus-summary-import-article (file) +(defun gnus-summary-import-article (file &optional edit) "Import an arbitrary file into a mail newsgroup." - (interactive "fImport file: ") + (interactive "fImport file: \nP") (let ((group gnus-newsgroup-name) (now (current-time)) - atts lines) + atts lines group-art) (unless (gnus-check-backend-function 'request-accept-article group) (error "%s does not support article importing" group)) (or (file-readable-p file) @@ -7800,19 +9133,55 @@ (erase-buffer) (nnheader-insert-file-contents file) (goto-char (point-min)) - (unless (nnheader-article-p) - ;; This doesn't look like an article, so we fudge some headers. + (if (nnheader-article-p) + (save-restriction + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (narrow-to-region (point-min) (1- (point))) + (goto-char (point-min)) + (unless (re-search-forward "^date:" nil t) + (goto-char (point-max)) + (insert "Date: " (message-make-date (nth 5 atts)) "\n"))) + ;; This doesn't look like an article, so we fudge some headers. (setq atts (file-attributes file) lines (count-lines (point-min) (point-max))) (insert "From: " (read-string "From: ") "\n" "Subject: " (read-string "Subject: ") "\n" - "Date: " (message-make-date (nth 5 atts)) - "\n" + "Date: " (message-make-date (nth 5 atts)) "\n" "Message-ID: " (message-make-message-id) "\n" "Lines: " (int-to-string lines) "\n" "Chars: " (int-to-string (nth 7 atts)) "\n\n")) - (gnus-request-accept-article group nil t) - (kill-buffer (current-buffer))))) + (setq group-art (gnus-request-accept-article group nil t)) + (kill-buffer (current-buffer))) + (setq gnus-newsgroup-active (gnus-activate-group group)) + (forward-line 1) + (gnus-summary-goto-article (cdr group-art) nil t) + (when edit + (gnus-summary-edit-article)))) + +(defun gnus-summary-create-article () + "Create an article in a mail newsgroup." + (interactive) + (let ((group gnus-newsgroup-name) + (now (current-time)) + group-art) + (unless (gnus-check-backend-function 'request-accept-article group) + (error "%s does not support article importing" group)) + (save-excursion + (set-buffer (gnus-get-buffer-create " *import file*")) + (erase-buffer) + (goto-char (point-min)) + ;; This doesn't look like an article, so we fudge some headers. + (insert "From: " (read-string "From: ") "\n" + "Subject: " (read-string "Subject: ") "\n" + "Date: " (message-make-date now) "\n" + "Message-ID: " (message-make-message-id) "\n") + (setq group-art (gnus-request-accept-article group nil t)) + (kill-buffer (current-buffer))) + (setq gnus-newsgroup-active (gnus-activate-group group)) + (forward-line 1) + (gnus-summary-goto-article (cdr group-art) nil t) + (gnus-summary-edit-article))) (defun gnus-summary-article-posted-p () "Say whether the current (mail) article is available from news as well. @@ -7830,8 +9199,9 @@ (defun gnus-summary-expire-articles (&optional now) "Expire all articles that are marked as expirable in the current group." (interactive) - (when (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name) + (when (and (not gnus-group-is-exiting-without-update-p) + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)) ;; This backend supports expiry. (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) (expirable (if total @@ -7865,19 +9235,24 @@ (setq es (gnus-request-expire-articles expirable gnus-newsgroup-name))) (setq es (gnus-request-expire-articles - expirable gnus-newsgroup-name)))) - (unless total - (setq gnus-newsgroup-expirable es)) - ;; We go through the old list of expirable, and mark all - ;; really expired articles as nonexistent. - (unless (eq es expirable) ;If nothing was expired, we don't mark. - (let ((gnus-use-cache nil)) - (while expirable - (unless (memq (car expirable) es) - (when (gnus-data-find (car expirable)) - (gnus-summary-mark-article - (car expirable) gnus-canceled-mark))) - (setq expirable (cdr expirable))))) + expirable gnus-newsgroup-name))) + (unless total + (setq gnus-newsgroup-expirable es)) + ;; We go through the old list of expirable, and mark all + ;; really expired articles as nonexistent. + (unless (eq es expirable) ;If nothing was expired, we don't mark. + (let ((gnus-use-cache nil)) + (dolist (article expirable) + (when (and (not (memq article es)) + (gnus-data-find article)) + (gnus-summary-mark-article article gnus-canceled-mark) + (run-hook-with-args 'gnus-summary-article-expire-hook + 'delete + (gnus-data-header + (assoc article (gnus-data-list nil))) + gnus-newsgroup-name + nil + nil)))))) (gnus-message 6 "Expiring articles...done"))))) (defun gnus-summary-expire-articles-now () @@ -7897,9 +9272,13 @@ This command actually deletes articles. This is not a marking command. The article will disappear forever from your life, never to return. + If N is negative, delete backwards. If N is nil and articles have been marked with the process mark, -delete these instead." +delete these instead. + +If `gnus-novice-user' is non-nil you will be asked for +confirmation before the articles are deleted." (interactive "P") (unless (gnus-check-backend-function 'request-expire-articles gnus-newsgroup-name) @@ -7908,6 +9287,7 @@ (error "Couldn't open server")) ;; Compute the list of articles to delete. (let ((articles (sort (copy-sequence (gnus-summary-work-articles n)) '<)) + (nnmail-expiry-target 'delete) not-deleted) (if (and gnus-novice-user (not (gnus-yes-or-no-p @@ -7925,6 +9305,12 @@ ;; after all. (unless (memq (car articles) not-deleted) (gnus-summary-mark-article (car articles) gnus-canceled-mark)) + (let* ((article (car articles)) + (id (mail-header-id (gnus-data-header + (assoc article (gnus-data-list nil)))))) + (run-hook-with-args 'gnus-summary-article-delete-hook + 'delete id gnus-newsgroup-name nil + nil)) (setq articles (cdr articles))) (when not-deleted (gnus-message 4 "Couldn't delete articles %s" not-deleted))) @@ -7938,18 +9324,33 @@ If ARG is nil, edit the decoded articles. If ARG is 1, edit the raw articles. If ARG is 2, edit the raw articles even in read-only groups. +If ARG is 3, edit the articles with the current handles. Otherwise, allow editing of articles even in read-only groups." (interactive "P") - (let (force raw) + (let (force raw current-handles) (cond ((null arg)) - ((eq arg 1) (setq raw t)) - ((eq arg 2) (setq raw t - force t)) - (t (setq force t))) - (if (and raw (not force) (equal gnus-newsgroup-name "nndraft:drafts")) - (error "Can't edit the raw article in group nndraft:drafts")) + ((eq arg 1) + (setq raw t)) + ((eq arg 2) + (setq raw t + force t)) + ((eq arg 3) + (setq current-handles + (and (gnus-buffer-live-p gnus-article-buffer) + (with-current-buffer gnus-article-buffer + (prog1 + gnus-article-mime-handles + (setq gnus-article-mime-handles nil)))))) + (t + (setq force t))) + (when (and raw (not force) + (member gnus-newsgroup-name '("nndraft:delayed" + "nndraft:drafts" + "nndraft:queue"))) + (error "Can't edit the raw article in group %s" + gnus-newsgroup-name)) (save-excursion (set-buffer gnus-summary-buffer) (let ((mail-parse-charset gnus-newsgroup-charset) @@ -7962,21 +9363,23 @@ (when (and (not raw) (gnus-buffer-live-p gnus-article-buffer)) (with-current-buffer gnus-article-buffer (mm-enable-multibyte))) - (if (equal gnus-newsgroup-name "nndraft:drafts") + (if (member gnus-newsgroup-name '("nndraft:delayed" "nndraft:drafts")) (setq raw t)) (gnus-article-edit-article (if raw 'ignore - #'(lambda () - (let ((mbl mml-buffer-list)) - (setq mml-buffer-list nil) - (mime-to-mml) - (make-local-hook 'kill-buffer-hook) - (let ((mml-buffer-list mml-buffer-list)) - (setq mml-buffer-list mbl) - (make-local-variable 'mml-buffer-list)) - (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))) + `(lambda () + (let ((mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (mime-to-mml ,'current-handles) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (gnus-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))) `(lambda (no-highlight) (let ((mail-parse-charset ',gnus-newsgroup-charset) + (message-options message-options) + (message-options-set-recipient) (mail-parse-ignored-charsets ',gnus-newsgroup-ignored-charsets)) ,(if (not raw) '(progn @@ -7996,10 +9399,31 @@ no-highlight) "Make edits to the current article permanent." (interactive) + (save-excursion + ;; The buffer restriction contains the entire article if it exists. + (when (article-goto-body) + (let ((lines (count-lines (point) (point-max))) + (length (- (point-max) (point))) + (case-fold-search t) + (body (copy-marker (point)))) + (goto-char (point-min)) + (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string length))) + (goto-char (point-min)) + (when (re-search-forward + "^x-content-length:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string length))) + (goto-char (point-min)) + (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string lines)))))) ;; Replace the article. (let ((buf (current-buffer))) (with-temp-buffer (insert-buffer-substring buf) + (if (and (not read-only) (not (gnus-request-replace-article (cdr gnus-article-current) (car gnus-article-current) @@ -8023,20 +9447,24 @@ (insert ".\n") (let ((nntp-server-buffer (current-buffer))) (setq header (car (gnus-get-newsgroup-headers - (save-excursion - (set-buffer gnus-summary-buffer) - gnus-newsgroup-dependencies) - t)))) + nil t)))) (save-excursion (set-buffer gnus-summary-buffer) (gnus-data-set-header (gnus-data-find (cdr gnus-article-current)) header) (gnus-summary-update-article-line - (cdr gnus-article-current) header)))))) + (cdr gnus-article-current) header) + (if (gnus-summary-goto-subject + (cdr gnus-article-current) nil t) + (gnus-summary-update-secondary-mark + (cdr gnus-article-current)))))))) ;; Update threads. (set-buffer (or buffer gnus-summary-buffer)) - (gnus-summary-update-article (cdr gnus-article-current))) + (gnus-summary-update-article (cdr gnus-article-current)) + (if (gnus-summary-goto-subject (cdr gnus-article-current) nil t) + (gnus-summary-update-secondary-mark + (cdr gnus-article-current)))) ;; Prettify the article buffer again. (unless no-highlight (save-excursion @@ -8072,15 +9500,13 @@ (gnus-summary-select-article) (save-excursion (set-buffer gnus-original-article-buffer) - (save-restriction - (message-narrow-to-head) - (let ((groups (nnmail-article-group 'identity trace))) - (unless silent - (if groups - (message "This message would go to %s" - (mapconcat 'car groups ", ")) - (message "This message would go to no groups")) - groups)))))) + (let ((groups (nnmail-article-group 'identity trace))) + (unless silent + (if groups + (message "This message would go to %s" + (mapconcat 'car groups ", ")) + (message "This message would go to no groups")) + groups))))) (defun gnus-summary-respool-trace () "Trace where the respool algorithm would put this article. @@ -8162,28 +9588,31 @@ If N is negative, mark backward instead. If UNMARK is non-nil, remove the process mark instead. The difference between N and the actual number of articles marked is returned." - (interactive "p") - (let ((backward (< n 0)) - (n (abs n))) - (while (and - (> n 0) - (if unmark - (gnus-summary-remove-process-mark - (gnus-summary-article-number)) - (gnus-summary-set-process-mark (gnus-summary-article-number))) - (zerop (gnus-summary-next-subject (if backward -1 1) nil t))) - (setq n (1- n))) - (when (/= 0 n) - (gnus-message 7 "No more articles")) - (gnus-summary-recenter) - (gnus-summary-position-point) - n)) + (interactive "P") + (if (and (null n) (gnus-region-active-p)) + (gnus-uu-mark-region (region-beginning) (region-end) unmark) + (setq n (prefix-numeric-value n)) + (let ((backward (< n 0)) + (n (abs n))) + (while (and + (> n 0) + (if unmark + (gnus-summary-remove-process-mark + (gnus-summary-article-number)) + (gnus-summary-set-process-mark (gnus-summary-article-number))) + (zerop (gnus-summary-next-subject (if backward -1 1) nil t))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more articles")) + (gnus-summary-recenter) + (gnus-summary-position-point) + n))) (defun gnus-summary-unmark-as-processable (n) "Remove the process mark from the next N articles. If N is negative, unmark backward instead. The difference between N and the actual number of articles unmarked is returned." - (interactive "p") + (interactive "P") (gnus-summary-mark-as-processable n t)) (defun gnus-summary-unmark-all-processable () @@ -8194,6 +9623,20 @@ (gnus-summary-remove-process-mark (car gnus-newsgroup-processable)))) (gnus-summary-position-point)) +(defun gnus-summary-add-mark (article type) + "Mark ARTICLE with a mark of TYPE." + (let ((vtype (car (assq type gnus-article-mark-lists))) + var) + (if (not vtype) + (error "No such mark type: %s" type) + (setq var (intern (format "gnus-newsgroup-%s" type))) + (set var (cons article (symbol-value var))) + (if (memq type '(processable cached replied forwarded recent saved)) + (gnus-summary-update-secondary-mark article) + ;;; !!! This is bogus. We should find out what primary + ;;; !!! mark we want to set. + (gnus-summary-update-mark gnus-del-mark 'unread))))) + (defun gnus-summary-mark-as-expirable (n) "Mark N articles forward as expirable. If N is negative, mark backward instead. The difference between N and @@ -8201,12 +9644,35 @@ (interactive "p") (gnus-summary-mark-forward n gnus-expirable-mark)) +(defun gnus-summary-mark-as-spam (n) + "Mark N articles forward as spam. +If N is negative, mark backward instead. The difference between N and +the actual number of articles marked is returned." + (interactive "p") + (gnus-summary-mark-forward n gnus-spam-mark)) + (defun gnus-summary-mark-article-as-replied (article) - "Mark ARTICLE replied and update the summary line." - (push article gnus-newsgroup-replied) - (let ((buffer-read-only nil)) - (when (gnus-summary-goto-subject article nil t) - (gnus-summary-update-secondary-mark article)))) + "Mark ARTICLE as replied to and update the summary line. +ARTICLE can also be a list of articles." + (interactive (list (gnus-summary-article-number))) + (let ((articles (if (listp article) article (list article)))) + (dolist (article articles) + (unless (numberp article) + (error "%s is not a number" article)) + (push article gnus-newsgroup-replied) + (let ((buffer-read-only nil)) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-secondary-mark article)))))) + +(defun gnus-summary-mark-article-as-forwarded (article) + "Mark ARTICLE as forwarded and update the summary line. +ARTICLE can also be a list of articles." + (let ((articles (if (listp article) article (list article)))) + (dolist (article articles) + (push article gnus-newsgroup-forwarded) + (let ((buffer-read-only nil)) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-secondary-mark article)))))) (defun gnus-summary-set-bookmark (article) "Set a bookmark in current article." @@ -8217,10 +9683,7 @@ (not (equal gnus-newsgroup-name (car gnus-article-current)))) (error "No current article selected")) ;; Remove old bookmark, if one exists. - (let ((old (assq article gnus-newsgroup-bookmarks))) - (when old - (setq gnus-newsgroup-bookmarks - (delq old gnus-newsgroup-bookmarks)))) + (gnus-pull article gnus-newsgroup-bookmarks) ;; Set the new bookmark, which is on the form ;; (article-number . line-number-in-body). (push @@ -8230,8 +9693,7 @@ (count-lines (min (point) (save-excursion - (goto-char (point-min)) - (search-forward "\n\n" nil t) + (article-goto-body) (point))) (point)))) gnus-newsgroup-bookmarks) @@ -8241,13 +9703,10 @@ "Remove the bookmark from the current article." (interactive (list (gnus-summary-article-number))) ;; Remove old bookmark, if one exists. - (let ((old (assq article gnus-newsgroup-bookmarks))) - (if old - (progn - (setq gnus-newsgroup-bookmarks - (delq old gnus-newsgroup-bookmarks)) - (gnus-message 6 "Removed bookmark.")) - (gnus-message 6 "No bookmark in current article.")))) + (if (not (assq article gnus-newsgroup-bookmarks)) + (gnus-message 6 "No bookmark in current article.") + (gnus-pull article gnus-newsgroup-bookmarks) + (gnus-message 6 "Removed bookmark."))) ;; Suggested by Daniel Quinlan <quinlan@best.com>. (defun gnus-summary-mark-as-dormant (n) @@ -8293,7 +9752,7 @@ (gnus-summary-goto-unread (and gnus-summary-goto-unread (not (eq gnus-summary-goto-unread 'never)) - (not (memq mark (list gnus-unread-mark + (not (memq mark (list gnus-unread-mark gnus-spam-mark gnus-ticked-mark gnus-dormant-mark))))) (n (abs n)) (mark (or mark gnus-del-mark))) @@ -8317,6 +9776,7 @@ (let ((article (gnus-summary-article-number))) (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-spam-marked (delq article gnus-newsgroup-spam-marked)) (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) (push (cons article mark) gnus-newsgroup-reads) ;; Possibly remove from cache, if that is used. @@ -8348,15 +9808,27 @@ (gnus-error 1 "Can't mark negative article numbers") nil) (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-spam-marked + (delq article gnus-newsgroup-spam-marked)) (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads)) (cond ((= mark gnus-ticked-mark) - (push article gnus-newsgroup-marked)) + (setq gnus-newsgroup-marked + (gnus-add-to-sorted-list gnus-newsgroup-marked + article))) + ((= mark gnus-spam-mark) + (setq gnus-newsgroup-spam-marked + (gnus-add-to-sorted-list gnus-newsgroup-spam-marked + article))) ((= mark gnus-dormant-mark) - (push article gnus-newsgroup-dormant)) + (setq gnus-newsgroup-dormant + (gnus-add-to-sorted-list gnus-newsgroup-dormant + article))) (t - (push article gnus-newsgroup-unreads))) + (setq gnus-newsgroup-unreads + (gnus-add-to-sorted-list gnus-newsgroup-unreads + article)))) (gnus-pull article gnus-newsgroup-reads) ;; See whether the article is to be put in the cache. @@ -8388,7 +9860,7 @@ (setq mark gnus-del-mark)) (when (and (not no-expire) gnus-newsgroup-auto-expire - (memq mark gnus-auto-expirable-marks)) + (memq mark gnus-auto-expirable-marks)) (setq mark gnus-expirable-mark)) (let ((article (or article (gnus-summary-article-number))) (old-mark (gnus-summary-article-mark article))) @@ -8400,6 +9872,7 @@ (error "No article on current line")) (if (not (if (or (= mark gnus-unread-mark) (= mark gnus-ticked-mark) + (= mark gnus-spam-mark) (= mark gnus-dormant-mark)) (gnus-mark-article-as-unread article mark) (gnus-mark-article-as-read article mark))) @@ -8430,17 +9903,36 @@ gnus-cached-mark) ((memq article gnus-newsgroup-replied) gnus-replied-mark) + ((memq article gnus-newsgroup-forwarded) + gnus-forwarded-mark) ((memq article gnus-newsgroup-saved) gnus-saved-mark) - (t gnus-unread-mark)) + ((memq article gnus-newsgroup-recent) + gnus-recent-mark) + ((memq article gnus-newsgroup-unseen) + gnus-unseen-mark) + (t gnus-no-mark)) 'replied) (when (gnus-visual-p 'summary-highlight 'highlight) (gnus-run-hooks 'gnus-summary-update-hook)) t) +(defun gnus-summary-update-download-mark (article) + "Update the download mark." + (gnus-summary-update-mark + (cond ((memq article gnus-newsgroup-undownloaded) + gnus-undownloaded-mark) + (gnus-newsgroup-agentized + gnus-downloaded-mark) + (t + gnus-no-mark)) + 'download) + (gnus-summary-update-line t) + t) + (defun gnus-summary-update-mark (mark type) (let ((forward (cdr (assq type gnus-summary-mark-positions))) - (buffer-read-only nil)) + (buffer-read-only nil)) (re-search-backward "[\n\r]" (gnus-point-at-bol) 'move-to-limit) (when forward (when (looking-at "\r") @@ -8460,12 +9952,14 @@ "Enter ARTICLE in the pertinent lists and remove it from others." ;; Make the article expirable. (let ((mark (or mark gnus-del-mark))) - (if (= mark gnus-expirable-mark) - (push article gnus-newsgroup-expirable) - (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))) + (setq gnus-newsgroup-expirable + (if (= mark gnus-expirable-mark) + (gnus-add-to-sorted-list gnus-newsgroup-expirable article) + (delq article gnus-newsgroup-expirable))) ;; Remove from unread and marked lists. (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-spam-marked (delq article gnus-newsgroup-spam-marked)) (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) (push (cons article mark) gnus-newsgroup-reads) ;; Possibly remove from cache, if that is used. @@ -8481,6 +9975,7 @@ (gnus-error 1 "Can't mark negative article numbers") nil) (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked) + gnus-newsgroup-spam-marked (delq article gnus-newsgroup-spam-marked) gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant) gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable) gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) @@ -8490,11 +9985,18 @@ (gnus-dup-unsuppress-article article)) (cond ((= mark gnus-ticked-mark) - (push article gnus-newsgroup-marked)) + (setq gnus-newsgroup-marked + (gnus-add-to-sorted-list gnus-newsgroup-marked article))) + ((= mark gnus-spam-mark) + (setq gnus-newsgroup-spam-marked + (gnus-add-to-sorted-list gnus-newsgroup-spam-marked + article))) ((= mark gnus-dormant-mark) - (push article gnus-newsgroup-dormant)) + (setq gnus-newsgroup-dormant + (gnus-add-to-sorted-list gnus-newsgroup-dormant article))) (t - (push article gnus-newsgroup-unreads))) + (setq gnus-newsgroup-unreads + (gnus-add-to-sorted-list gnus-newsgroup-unreads article)))) (gnus-pull article gnus-newsgroup-reads) t))) @@ -8569,12 +10071,26 @@ (when (memq gnus-current-article gnus-newsgroup-unreads) (gnus-summary-mark-article gnus-current-article gnus-read-mark))) -(defun gnus-summary-mark-read-and-unread-as-read () +(defun gnus-summary-mark-read-and-unread-as-read (&optional new-mark) "Intended to be used by `gnus-summary-mark-article-hook'." (let ((mark (gnus-summary-article-mark))) (when (or (gnus-unread-mark-p mark) (gnus-read-mark-p mark)) - (gnus-summary-mark-article gnus-current-article gnus-read-mark)))) + (gnus-summary-mark-article gnus-current-article + (or new-mark gnus-read-mark))))) + +(defun gnus-summary-mark-current-read-and-unread-as-read (&optional new-mark) + "Intended to be used by `gnus-summary-mark-article-hook'." + (let ((mark (gnus-summary-article-mark))) + (when (or (gnus-unread-mark-p mark) + (gnus-read-mark-p mark)) + (gnus-summary-mark-article (gnus-summary-article-number) + (or new-mark gnus-read-mark))))) + +(defun gnus-summary-mark-unread-as-ticked () + "Intended to be used by `gnus-summary-mark-article-hook'." + (when (memq gnus-current-article gnus-newsgroup-unreads) + (gnus-summary-mark-article gnus-current-article gnus-ticked-mark))) (defun gnus-summary-mark-region-as-read (point mark all) "Mark all unread articles between point and mark as read. @@ -8649,8 +10165,8 @@ (let ((scored gnus-newsgroup-scored) headers h) (while scored - (unless (gnus-summary-goto-subject (caar scored)) - (and (setq h (gnus-summary-article-header (caar scored))) + (unless (gnus-summary-article-header (caar scored)) + (and (setq h (gnus-number-to-header (caar scored))) (< (cdar scored) gnus-summary-expunge-below) (push h headers))) (setq scored (cdr scored))) @@ -8658,20 +10174,29 @@ (when (not no-error) (error "No expunged articles hidden")) (goto-char (point-min)) + (push gnus-newsgroup-limit gnus-newsgroup-limits) + (setq gnus-newsgroup-limit (copy-sequence gnus-newsgroup-limit)) + (mapcar (lambda (x) (push (mail-header-number x) + gnus-newsgroup-limit)) + headers) (gnus-summary-prepare-unthreaded (nreverse headers)) (goto-char (point-min)) (gnus-summary-position-point) t)))) -(defun gnus-summary-catchup (&optional all quietly to-here not-mark) +(defun gnus-summary-catchup (&optional all quietly to-here not-mark reverse) "Mark all unread articles in this newsgroup as read. If prefix argument ALL is non-nil, ticked and dormant articles will also be marked as read. If QUIETLY is non-nil, no questions will be asked. + If TO-HERE is non-nil, it should be a point in the buffer. All -articles before this point will be marked as read. +articles before (after, if REVERSE is set) this point will be marked +as read. + Note that this function will only catch up the unread article in the current summary buffer limitation. + The number of articles marked as read is returned." (interactive "P") (prog1 @@ -8692,16 +10217,28 @@ (progn (when all (setq gnus-newsgroup-marked nil + gnus-newsgroup-spam-marked nil gnus-newsgroup-dormant nil)) - (setq gnus-newsgroup-unreads gnus-newsgroup-downloadable)) + (setq gnus-newsgroup-unreads + (gnus-sorted-nunion + (gnus-intersection gnus-newsgroup-unreads + gnus-newsgroup-downloadable) + gnus-newsgroup-unfetched))) ;; We actually mark all articles as canceled, which we ;; have to do when using auto-expiry or adaptive scoring. (gnus-summary-show-all-threads) - (when (gnus-summary-first-subject (not all) t) - (while (and - (if to-here (< (point) to-here) t) - (gnus-summary-mark-article-as-read gnus-catchup-mark) - (gnus-summary-find-next (not all) nil nil t)))) + (if (and to-here reverse) + (progn + (goto-char to-here) + (gnus-summary-mark-current-read-and-unread-as-read + gnus-catchup-mark) + (while (gnus-summary-find-next (not all)) + (gnus-summary-mark-article-as-read gnus-catchup-mark))) + (when (gnus-summary-first-subject (not all)) + (while (and + (if to-here (< (point) to-here) t) + (gnus-summary-mark-article-as-read gnus-catchup-mark) + (gnus-summary-find-next (not all)))))) (gnus-set-mode-line 'summary)) t)) (gnus-summary-position-point))) @@ -8718,14 +10255,29 @@ (gnus-summary-catchup all t beg))))) (gnus-summary-position-point)) +(defun gnus-summary-catchup-from-here (&optional all) + "Mark all unticked articles after (and including) the current one as read. +If ALL is non-nil, also mark ticked and dormant articles as read." + (interactive "P") + (save-excursion + (gnus-save-hidden-threads + (let ((beg (point))) + ;; We check that there are unread articles. + (when (or all (gnus-summary-find-next)) + (gnus-summary-catchup all t beg nil t))))) + (gnus-summary-position-point)) + (defun gnus-summary-catchup-all (&optional quietly) - "Mark all articles in this newsgroup as read." + "Mark all articles in this newsgroup as read. +This command is dangerous. Normally, you want \\[gnus-summary-catchup] +instead, which marks only unread articles as read." (interactive "P") (gnus-summary-catchup t quietly)) (defun gnus-summary-catchup-and-exit (&optional all quietly) "Mark all unread articles in this group as read, then exit. -If prefix argument ALL is non-nil, all articles are marked as read." +If prefix argument ALL is non-nil, all articles are marked as read. +If QUIETLY is non-nil, no questions will be asked." (interactive "P") (when (gnus-summary-catchup all quietly nil 'fast) ;; Select next newsgroup or exit. @@ -8735,7 +10287,9 @@ (gnus-summary-exit)))) (defun gnus-summary-catchup-all-and-exit (&optional quietly) - "Mark all articles in this newsgroup as read, and then exit." + "Mark all articles in this newsgroup as read, and then exit. +This command is dangerous. Normally, you want \\[gnus-summary-catchup-and-exit] +instead, which marks only unread articles as read." (interactive "P") (gnus-summary-catchup-and-exit t quietly)) @@ -8870,6 +10424,8 @@ (set-buffer gnus-summary-buffer) (gnus-summary-unmark-all-processable) (gnus-summary-update-article current-article) + (if (gnus-summary-goto-subject (cdr gnus-article-current) nil t) + (gnus-summary-update-secondary-mark (cdr gnus-article-current))) (gnus-summary-rethread-current) (gnus-message 3 "Article %d is now the child of article %d" current-article parent-article))))) @@ -8901,8 +10457,8 @@ (interactive) (let ((buffer-read-only nil) (orig (point)) - ;; first goto end then to beg, to have point at beg after let - (end (progn (end-of-line) (point))) + (end (gnus-point-at-eol)) + ;; Leave point at bol (beg (progn (beginning-of-line) (point)))) (prog1 ;; Any hidden lines here? @@ -8911,18 +10467,49 @@ (goto-char orig) (gnus-summary-position-point)))) -(defun gnus-summary-hide-all-threads () - "Hide all thread subtrees." +(defun gnus-summary-maybe-hide-threads () + "If requested, hide the threads that should be hidden." + (when (and gnus-show-threads + gnus-thread-hide-subtree) + (gnus-summary-hide-all-threads + (if (or (consp gnus-thread-hide-subtree) + (functionp gnus-thread-hide-subtree)) + (gnus-make-predicate gnus-thread-hide-subtree) + nil)))) + +;;; Hiding predicates. + +(defun gnus-article-unread-p (header) + (memq (mail-header-number header) gnus-newsgroup-unreads)) + +(defun gnus-article-unseen-p (header) + (memq (mail-header-number header) gnus-newsgroup-unseen)) + +(defun gnus-map-articles (predicate articles) + "Map PREDICATE over ARTICLES and return non-nil if any predicate is non-nil." + (apply 'gnus-or (mapcar predicate + (mapcar 'gnus-summary-article-header articles)))) + +(defun gnus-summary-hide-all-threads (&optional predicate) + "Hide all thread subtrees. +If PREDICATE is supplied, threads that satisfy this predicate +will not be hidden." (interactive) (save-excursion (goto-char (point-min)) - (gnus-summary-hide-thread) - (while (zerop (gnus-summary-next-thread 1 t)) - (gnus-summary-hide-thread))) + (let ((end nil)) + (while (not end) + (when (or (not predicate) + (gnus-map-articles + predicate (gnus-summary-article-children))) + (gnus-summary-hide-thread)) + (setq end (not (zerop (gnus-summary-next-thread 1 t))))))) (gnus-summary-position-point)) (defun gnus-summary-hide-thread () "Hide thread subtrees. +If PREDICATE is supplied, threads that satisfy this predicate +will not be hidden. Returns nil if no threads were there to be hidden." (interactive) (let ((buffer-read-only nil) @@ -9020,7 +10607,7 @@ (defun gnus-summary-up-thread (n) "Go up thread N steps. -If N is negative, go up instead. +If N is negative, go down instead. Returns the difference between N and how many steps down that were taken." (interactive "p") @@ -9071,6 +10658,12 @@ (interactive "P") (gnus-summary-sort 'number reverse)) +(defun gnus-summary-sort-by-random (&optional reverse) + "Randomize the order in the summary buffer. +Argument REVERSE means to randomize in reverse order." + (interactive "P") + (gnus-summary-sort 'random reverse)) + (defun gnus-summary-sort-by-author (&optional reverse) "Sort the summary buffer by author name alphabetically. If `case-fold-search' is non-nil, case of letters is ignored. @@ -9109,6 +10702,17 @@ (interactive "P") (gnus-summary-sort 'chars reverse)) +(defun gnus-summary-sort-by-original (&optional reverse) + "Sort the summary buffer using the default sorting method. +Argument REVERSE means reverse order." + (interactive "P") + (let* ((buffer-read-only) + (gnus-summary-prepare-hook nil)) + ;; We do the sorting by regenerating the threads. + (gnus-summary-prepare) + ;; Hide subthreads if needed. + (gnus-summary-maybe-hide-threads))) + (defun gnus-summary-sort (predicate reverse) "Sort summary buffer by PREDICATE. REVERSE means reverse order." (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) @@ -9130,8 +10734,7 @@ ;; We do the sorting by regenerating the threads. (gnus-summary-prepare) ;; Hide subthreads if needed. - (when (and gnus-show-threads gnus-thread-hide-subtree) - (gnus-summary-hide-all-threads)))) + (gnus-summary-maybe-hide-threads))) ;; Summary saving commands. @@ -9173,17 +10776,22 @@ (gnus-set-mode-line 'summary) n)) -(defun gnus-summary-pipe-output (&optional arg) +(defun gnus-summary-pipe-output (&optional arg headers) "Pipe the current article to a subprocess. If N is a positive number, pipe the N next articles. If N is a negative number, pipe the N previous articles. If N is nil and any articles have been marked with the process mark, -pipe those articles instead." - (interactive "P") +pipe those articles instead. +If HEADERS (the symbolic prefix), include the headers, too." + (interactive (gnus-interactive "P\ny")) (require 'gnus-art) - (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe)) + (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe) + (gnus-save-all-headers (or headers gnus-save-all-headers))) (gnus-summary-save-article arg t)) - (gnus-configure-windows 'pipe)) + (let ((buffer (get-buffer "*Shell Command Output*"))) + (when (and buffer + (not (zerop (buffer-size buffer)))) + (gnus-configure-windows 'pipe)))) (defun gnus-summary-save-article-mail (&optional arg) "Append the current article to an mail file. @@ -9240,6 +10848,17 @@ (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file)) (gnus-summary-save-article arg))) +(defun gnus-summary-muttprint (&optional arg) + "Print the current article using Muttprint. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (require 'gnus-art) + (let ((gnus-default-article-saver 'gnus-summary-pipe-to-muttprint)) + (gnus-summary-save-article arg t))) + (defun gnus-summary-pipe-message (program) "Pipe the current article through PROGRAM." (interactive "sProgram: ") @@ -9247,11 +10866,11 @@ (let ((mail-header-separator "")) (gnus-eval-in-buffer-window gnus-article-buffer (save-restriction - (widen) - (let ((start (window-start)) - buffer-read-only) - (message-pipe-buffer-body program) - (set-window-start (get-buffer-window (current-buffer)) start)))))) + (widen) + (let ((start (window-start)) + buffer-read-only) + (message-pipe-buffer-body program) + (set-window-start (get-buffer-window (current-buffer)) start)))))) (defun gnus-get-split-value (methods) "Return a value based on the split METHODS." @@ -9270,7 +10889,7 @@ ;; Regular expression. (ignore-errors (re-search-forward match nil t))) - ((gnus-functionp match) + ((functionp match) ;; Function. (save-restriction (widen) @@ -9309,24 +10928,27 @@ (to-newsgroup (cond ((null split-name) - (gnus-completing-read default prom - gnus-active-hashtb - 'gnus-valid-move-group-p - nil prefix - 'gnus-group-history)) + (gnus-completing-read-with-default + default prom + gnus-active-hashtb + 'gnus-valid-move-group-p + nil prefix + 'gnus-group-history)) ((= 1 (length split-name)) - (gnus-completing-read (car split-name) prom - gnus-active-hashtb - 'gnus-valid-move-group-p - nil nil - 'gnus-group-history)) + (gnus-completing-read-with-default + (car split-name) prom + gnus-active-hashtb + 'gnus-valid-move-group-p + nil nil + 'gnus-group-history)) (t - (gnus-completing-read nil prom - (mapcar (lambda (el) (list el)) - (nreverse split-name)) - nil nil nil - 'gnus-group-history)))) - (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))) + (gnus-completing-read-with-default + nil prom + (mapcar (lambda (el) (list el)) + (nreverse split-name)) + nil nil nil + 'gnus-group-history)))) + (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))) (when to-newsgroup (if (or (string= to-newsgroup "") (string= to-newsgroup prefix)) @@ -9365,7 +10987,9 @@ (save-excursion (set-buffer gnus-article-buffer) (let ((handles (or gnus-article-mime-handles - (mm-dissect-buffer) (mm-uu-dissect)))) + (mm-dissect-buffer nil gnus-article-loose-mime) + (and gnus-article-emulate-mime + (mm-uu-dissect))))) (when handles (gnus-summary-save-parts-1 type dir handles reverse) (unless gnus-article-mime-handles ;; Don't destroy this case. @@ -9379,13 +11003,17 @@ (not (string-match type (mm-handle-media-type handle))) (string-match type (mm-handle-media-type handle))) (let ((file (expand-file-name - (file-name-nondirectory - (or - (mail-content-type-get - (mm-handle-disposition handle) 'filename) - (concat gnus-newsgroup-name - "." (number-to-string - (cdr gnus-article-current))))) + (gnus-map-function + mm-file-name-rewrite-functions + (file-name-nondirectory + (or + (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (mm-handle-type handle) 'name) + (concat gnus-newsgroup-name + "." (number-to-string + (cdr gnus-article-current)))))) dir))) (unless (file-exists-p file) (mm-save-part-to-file handle file)))))) @@ -9452,7 +11080,9 @@ (gnus-data-enter after-article gnus-reffed-article-number gnus-unread-mark b (car pslist) 0 (- e b)) - (push gnus-reffed-article-number gnus-newsgroup-unreads) + (setq gnus-newsgroup-unreads + (gnus-add-to-sorted-list gnus-newsgroup-unreads + gnus-reffed-article-number)) (setq gnus-reffed-article-number (1- gnus-reffed-article-number)) (setq pslist (cdr pslist))))))) @@ -9583,8 +11213,8 @@ ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>. (when gnus-summary-selected-face (save-excursion - (let* ((beg (progn (beginning-of-line) (point))) - (end (progn (end-of-line) (point))) + (let* ((beg (gnus-point-at-bol)) + (end (gnus-point-at-eol)) ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>. (from (if (get-text-property beg gnus-mouse-face-prop) beg @@ -9611,41 +11241,55 @@ (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to)) 'face gnus-summary-selected-face)))))) -;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>. +(defvar gnus-summary-highlight-line-cached nil) +(defvar gnus-summary-highlight-line-trigger nil) + +(defun gnus-summary-highlight-line-0 () + (if (and (eq gnus-summary-highlight-line-trigger + gnus-summary-highlight) + gnus-summary-highlight-line-cached) + gnus-summary-highlight-line-cached + (setq gnus-summary-highlight-line-trigger gnus-summary-highlight + gnus-summary-highlight-line-cached + (let* ((cond (list 'cond)) + (c cond) + (list gnus-summary-highlight)) + (while list + (setcdr c (cons (list (caar list) (list 'quote (cdar list))) + nil)) + (setq c (cdr c) + list (cdr list))) + (gnus-byte-compile (list 'lambda nil cond)))))) + (defun gnus-summary-highlight-line () "Highlight current line according to `gnus-summary-highlight'." - (let* ((list gnus-summary-highlight) - (p (point)) - (end (progn (end-of-line) (point))) - ;; now find out where the line starts and leave point there. - (beg (progn (beginning-of-line) (point))) - (article (gnus-summary-article-number)) - (score (or (cdr (assq (or article gnus-current-article) + (let* ((beg (gnus-point-at-bol)) + (article (or (gnus-summary-article-number) gnus-current-article)) + (score (or (cdr (assq article gnus-newsgroup-scored)) gnus-summary-default-score 0)) (mark (or (gnus-summary-article-mark) gnus-unread-mark)) - (inhibit-read-only t)) - ;; Eval the cars of the lists until we find a match. - (let ((default gnus-summary-default-score)) - (while (and list - (not (eval (caar list)))) - (setq list (cdr list)))) - (let ((face (cdar list))) + (inhibit-read-only t) + (default gnus-summary-default-score) + (default-high gnus-summary-default-high-score) + (default-low gnus-summary-default-low-score) + (uncached (and gnus-summary-use-undownloaded-faces + (memq article gnus-newsgroup-undownloaded)))) + (let ((face (funcall (gnus-summary-highlight-line-0)))) (unless (eq face (get-text-property beg 'face)) (gnus-put-text-property-excluding-characters-with-faces - beg end 'face + beg (gnus-point-at-eol) 'face (setq face (if (boundp face) (symbol-value face) face))) (when gnus-summary-highlight-line-function - (funcall gnus-summary-highlight-line-function article face)))) - (goto-char p))) + (funcall gnus-summary-highlight-line-function article face)))))) (defun gnus-update-read-articles (group unread &optional compute) - "Update the list of read articles in GROUP." + "Update the list of read articles in GROUP. +UNREAD is a sorted list." (let* ((active (or gnus-newsgroup-active (gnus-active group))) (entry (gnus-gethash group gnus-newsrc-hashtb)) (info (nth 2 entry)) (prev 1) - (unread (sort (copy-sequence unread) '<)) read) (if (or (not info) (not active)) ;; There is no info on this group if it was, in fact, @@ -9709,25 +11353,24 @@ (defun gnus-offer-save-summaries () "Offer to save all active summary buffers." - (save-excursion - (let ((buflist (buffer-list)) - buffers bufname) - ;; Go through all buffers and find all summaries. - (while buflist - (and (setq bufname (buffer-name (car buflist))) - (string-match "Summary" bufname) - (save-excursion - (set-buffer bufname) - ;; We check that this is, indeed, a summary buffer. - (and (eq major-mode 'gnus-summary-mode) - ;; Also make sure this isn't bogus. - gnus-newsgroup-prepared - ;; Also make sure that this isn't a dead summary buffer. - (not gnus-dead-summary-mode))) - (push bufname buffers)) - (setq buflist (cdr buflist))) - ;; Go through all these summary buffers and offer to save them. - (when buffers + (let (buffers) + ;; Go through all buffers and find all summaries. + (dolist (buffer (buffer-list)) + (when (and (setq buffer (buffer-name buffer)) + (string-match "Summary" buffer) + (save-excursion + (set-buffer buffer) + ;; We check that this is, indeed, a summary buffer. + (and (eq major-mode 'gnus-summary-mode) + ;; Also make sure this isn't bogus. + gnus-newsgroup-prepared + ;; Also make sure that this isn't a + ;; dead summary buffer. + (not gnus-dead-summary-mode)))) + (push buffer buffers))) + ;; Go through all these summary buffers and offer to save them. + (when buffers + (save-excursion (map-y-or-n-p "Update summary buffer %s? " (lambda (buf) @@ -9737,37 +11380,18 @@ (defun gnus-summary-setup-default-charset () "Setup newsgroup default charset." - (if (equal gnus-newsgroup-name "nndraft:drafts") + (if (member gnus-newsgroup-name '("nndraft:delayed" "nndraft:drafts")) (setq gnus-newsgroup-charset nil) - (let* ((name (and gnus-newsgroup-name - (gnus-group-real-name gnus-newsgroup-name))) - (ignored-charsets + (let* ((ignored-charsets (or gnus-newsgroup-ephemeral-ignored-charsets (append (and gnus-newsgroup-name - (or (gnus-group-find-parameter gnus-newsgroup-name - 'ignored-charsets t) - (let ((alist gnus-group-ignored-charsets-alist) - elem (charsets nil)) - (while (setq elem (pop alist)) - (when (and name - (string-match (car elem) name)) - (setq alist nil - charsets (cdr elem)))) - charsets))) + (gnus-parameter-ignored-charsets gnus-newsgroup-name)) gnus-newsgroup-ignored-charsets)))) (setq gnus-newsgroup-charset (or gnus-newsgroup-ephemeral-charset (and gnus-newsgroup-name - (or (gnus-group-find-parameter gnus-newsgroup-name 'charset) - (let ((alist gnus-group-charset-alist) - elem charset) - (while (setq elem (pop alist)) - (when (and name - (string-match (car elem) name)) - (setq alist nil - charset (cadr elem)))) - charset))) + (gnus-parameter-charset gnus-newsgroup-name)) gnus-default-charset)) (set (make-local-variable 'gnus-newsgroup-ignored-charsets) ignored-charsets)))) @@ -9791,17 +11415,17 @@ (interactive (list (gnus-summary-article-number))) (gnus-with-article article (message-narrow-to-head) + (message-remove-header "Mime-Version") (goto-char (point-max)) + (insert "Mime-Version: 1.0\n") (widen) (when (search-forward "\n--" nil t) (let ((separator (buffer-substring (point) (gnus-point-at-eol)))) (message-narrow-to-head) - (message-remove-header "Mime-Version") (message-remove-header "Content-Type") (goto-char (point-max)) (insert (format "Content-Type: multipart/mixed; boundary=\"%s\"\n" separator)) - (insert "Mime-Version: 1.0\n") (widen)))) (let (gnus-mark-article-hook) (gnus-summary-select-article t t nil article))) @@ -9892,6 +11516,137 @@ (gnus-set-mode-line 'summary) n)) +(defun gnus-summary-insert-articles (articles) + (when (setq articles + (gnus-sorted-difference articles + (mapcar (lambda (h) + (mail-header-number h)) + gnus-newsgroup-headers))) + (setq gnus-newsgroup-headers + (gnus-merge 'list + gnus-newsgroup-headers + (gnus-fetch-headers articles) + 'gnus-article-sort-by-number)) + ;; Suppress duplicates? + (when gnus-suppress-duplicates + (gnus-dup-suppress-articles)) + + ;; We might want to build some more threads first. + (when (and gnus-fetch-old-headers + (eq gnus-headers-retrieved-by 'nov)) + (if (eq gnus-fetch-old-headers 'invisible) + (gnus-build-all-threads) + (gnus-build-old-threads))) + ;; Let the Gnus agent mark articles as read. + (when gnus-agent + (gnus-agent-get-undownloaded-list)) + ;; Remove list identifiers from subject + (when gnus-list-identifiers + (gnus-summary-remove-list-identifiers)) + ;; First and last article in this newsgroup. + (when gnus-newsgroup-headers + (setq gnus-newsgroup-begin + (mail-header-number (car gnus-newsgroup-headers)) + gnus-newsgroup-end + (mail-header-number + (gnus-last-element gnus-newsgroup-headers)))) + (when gnus-use-scoring + (gnus-possibly-score-headers)))) + +(defun gnus-summary-insert-old-articles (&optional all) + "Insert all old articles in this group. +If ALL is non-nil, already read articles become readable. +If ALL is a number, fetch this number of articles." + (interactive "P") + (prog1 + (let ((old (sort (mapcar 'car gnus-newsgroup-data) '<)) + older len) + (setq older + ;; Some nntp servers lie about their active range. When + ;; this happens, the active range can be in the millions. + ;; Use a compressed range to avoid creating a huge list. + (gnus-range-difference (list gnus-newsgroup-active) old)) + (setq len (gnus-range-length older)) + (cond + ((null older) nil) + ((numberp all) + (if (< all len) + (let ((older-range (nreverse older))) + (setq older nil) + + (while (> all 0) + (let* ((r (pop older-range)) + (min (if (numberp r) r (car r))) + (max (if (numberp r) r (cdr r)))) + (while (and (<= min max) + (> all 0)) + (push max older) + (setq all (1- all) + max (1- max)))))) + (setq older (gnus-uncompress-range older)))) + (all + (setq older (gnus-uncompress-range older))) + (t + (when (and (numberp gnus-large-newsgroup) + (> len gnus-large-newsgroup)) + (let* ((cursor-in-echo-area nil) + (initial (gnus-parameter-large-newsgroup-initial + gnus-newsgroup-name)) + (input + (read-string + (format + "How many articles from %s (%s %d): " + (gnus-limit-string + (gnus-group-decoded-name gnus-newsgroup-name) 35) + (if initial "max" "default") + len) + (if initial + (cons (number-to-string initial) + 0))))) + (unless (string-match "^[ \t]*$" input) + (setq all (string-to-number input)) + (if (< all len) + (let ((older-range (nreverse older))) + (setq older nil) + + (while (> all 0) + (let* ((r (pop older-range)) + (min (if (numberp r) r (car r))) + (max (if (numberp r) r (cdr r)))) + (while (and (<= min max) + (> all 0)) + (push max older) + (setq all (1- all) + max (1- max)))))))))) + (setq older (gnus-uncompress-range older)))) + (if (not older) + (message "No old news.") + (gnus-summary-insert-articles older) + (gnus-summary-limit (gnus-sorted-nunion old older)))) + (gnus-summary-position-point))) + +(defun gnus-summary-insert-new-articles () + "Insert all new articles in this group." + (interactive) + (prog1 + (let ((old (sort (mapcar 'car gnus-newsgroup-data) '<)) + (old-active gnus-newsgroup-active) + (nnmail-fetched-sources (list t)) + i new) + (setq gnus-newsgroup-active + (gnus-activate-group gnus-newsgroup-name 'scan)) + (setq i (cdr gnus-newsgroup-active)) + (while (> i (cdr old-active)) + (push i new) + (decf i)) + (if (not new) + (message "No gnus is bad news.") + (gnus-summary-insert-articles new) + (setq gnus-newsgroup-unreads + (gnus-sorted-nunion gnus-newsgroup-unreads new)) + (gnus-summary-limit (gnus-sorted-nunion old new)))) + (gnus-summary-position-point))) + (gnus-summary-make-all-marking-commands) (gnus-ems-redefine) @@ -9900,5 +11655,9 @@ (run-hooks 'gnus-sum-load-hook) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; arch-tag: 17c6748f-6d00-4d36-bf01-835c42f31235 ;;; gnus-sum.el ends here
--- a/lisp/gnus/gnus-topic.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-topic.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Ilja Weis <kult@uni-paderborn.de> @@ -46,6 +46,9 @@ :type 'hook :group 'gnus-topic) +(when (featurep 'xemacs) + (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)) + (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" "Format of topic lines. It works along the same lines as a normal formatting string, @@ -57,7 +60,10 @@ %g Number of groups in the topic. %a Number of unread articles in the groups in the topic. %A Number of unread articles in the groups in the topic and its subtopics. -" + +General format specifiers can also be used. +See Info node `(gnus)Formatting Variables'." + :link '(custom-manual "(gnus)Formatting Variables") :type 'string :group 'gnus-topic) @@ -161,6 +167,7 @@ (mapcar 'list (gnus-topic-list)) nil t))) (dolist (topic (gnus-current-topics topic)) + (gnus-topic-goto-topic topic) (gnus-topic-fold t)) (gnus-topic-goto-topic topic)) @@ -196,7 +203,7 @@ "Return entries for all visible groups in TOPIC. If RECURSIVE is t, return groups in its subtopics too." (let ((groups (cdr (assoc topic gnus-topic-alist))) - info clevel unread group params visible-groups entry active) + info clevel unread group params visible-groups entry active) (setq lowest (or lowest 1)) (setq level (or level gnus-level-unsubscribed)) ;; We go through the newsrc to look for matches. @@ -245,6 +252,28 @@ (cdr recursive))) visible-groups)) +(defun gnus-topic-goto-previous-topic (n) + "Go to the N'th previous topic." + (interactive "p") + (gnus-topic-goto-next-topic (- n))) + +(defun gnus-topic-goto-next-topic (n) + "Go to the N'th next topic." + (interactive "p") + (let ((backward (< n 0)) + (n (abs n)) + (topic (gnus-current-topic))) + (while (and (> n 0) + (setq topic + (if backward + (gnus-topic-previous-topic topic) + (gnus-topic-next-topic topic)))) + (gnus-topic-goto-topic topic) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more topics")) + n)) + (defun gnus-topic-previous-topic (topic) "Return the previous topic on the same level as TOPIC." (let ((top (cddr (gnus-topic-find-topology @@ -351,9 +380,17 @@ "Compute the group parameters for GROUP taking into account inheritance from topics." (let ((params-list (copy-sequence (gnus-group-get-parameter group)))) (save-excursion - (gnus-group-goto-group group) (nconc params-list - (gnus-topic-hierarchical-parameters (gnus-current-topic)))))) + (gnus-topic-hierarchical-parameters + ;; First we try to go to the group within the group + ;; buffer and find the topic for the group that way. + ;; This hopefully copes well with groups that are in + ;; more than one topic. Failing that (i.e. when the + ;; group isn't visible in the group buffer) we find a + ;; topic for the group via gnus-group-topic. + (or (and (gnus-group-goto-group group) + (gnus-current-topic)) + (gnus-group-topic group))))))) (defun gnus-topic-hierarchical-parameters (topic) "Return a topic list computed for TOPIC." @@ -384,16 +421,22 @@ ;;; Generating group buffers -(defun gnus-group-prepare-topics (level &optional all lowest +(defun gnus-group-prepare-topics (level &optional predicate lowest regexp list-topic topic-level) "List all newsgroups with unread articles of level LEVEL or lower. Use the `gnus-group-topics' to sort the groups. -If ALL is non-nil, list groups that have no unread articles. +If PREDICTE is a function, list groups that the function returns non-nil; +if it is t, list groups that have no unread articles. If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (set-buffer gnus-group-buffer) (let ((buffer-read-only nil) - (lowest (or lowest 1))) + (lowest (or lowest 1)) + (not-in-list + (and gnus-group-listed-groups + (copy-sequence gnus-group-listed-groups)))) + (gnus-update-format-specifications nil 'topic) + (when (or (not gnus-topic-alist) (not gnus-topology-checked-p)) (gnus-topic-check-topology)) @@ -402,48 +445,63 @@ (erase-buffer)) ;; List dead groups? - (when (and (>= level gnus-level-zombie) - (<= lowest gnus-level-zombie)) + (when (or gnus-group-listed-groups + (and (>= level gnus-level-zombie) + (<= lowest gnus-level-zombie))) (gnus-group-prepare-flat-list-dead (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) gnus-level-zombie ?Z regexp)) - (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) + (when (or gnus-group-listed-groups + (and (>= level gnus-level-killed) + (<= lowest gnus-level-killed))) (gnus-group-prepare-flat-list-dead (setq gnus-killed-list (sort gnus-killed-list 'string<)) - gnus-level-killed ?K - regexp)) + gnus-level-killed ?K regexp) + (when not-in-list + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + (gnus-group-prepare-flat-list-dead + (gnus-remove-if (lambda (group) + (or (gnus-gethash group gnus-newsrc-hashtb) + (gnus-gethash group gnus-killed-hashtb))) + not-in-list) + gnus-level-killed ?K regexp))) ;; Use topics. (prog1 - (when (< lowest gnus-level-zombie) + (when (or (< lowest gnus-level-zombie) + gnus-group-listed-groups) (if list-topic (let ((top (gnus-topic-find-topology list-topic))) (gnus-topic-prepare-topic (cdr top) (car top) - (or topic-level level) all - nil lowest)) + (or topic-level level) predicate + nil lowest regexp)) (gnus-topic-prepare-topic gnus-topic-topology 0 - (or topic-level level) all - nil lowest))) - + (or topic-level level) predicate + nil lowest regexp))) (gnus-group-set-mode-line) - (setq gnus-group-list-mode (cons level all)) + (setq gnus-group-list-mode (cons level predicate)) (gnus-run-hooks 'gnus-group-prepare-hook)))) -(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent - lowest) +(defun gnus-topic-prepare-topic (topicl level &optional list-level + predicate silent + lowest regexp) "Insert TOPIC into the group buffer. If SILENT, don't insert anything. Return the number of unread articles in the topic and its subtopics." (let* ((type (pop topicl)) (entries (gnus-topic-find-groups - (car type) list-level - (or all + (car type) + (if gnus-group-listed-groups + gnus-level-killed + list-level) + (or predicate gnus-group-listed-groups (cdr (assq 'visible (gnus-topic-hierarchical-parameters (car type))))) - lowest)) + (if gnus-group-listed-groups 0 lowest))) (visiblep (and (eq (nth 1 type) 'visible) (not silent))) (gnus-group-indentation (make-string (* gnus-topic-indent-level level) ? )) @@ -458,32 +516,61 @@ (while topicl (incf unread (gnus-topic-prepare-topic - (pop topicl) (1+ level) list-level all - (not visiblep) lowest))) + (pop topicl) (1+ level) list-level predicate + (not visiblep) lowest regexp))) (setq end (point)) (goto-char beg) ;; Insert all the groups that belong in this topic. (while (setq entry (pop entries)) - (when visiblep - (if (stringp entry) - ;; Dead groups. - (gnus-group-insert-group-line - entry (if (member entry gnus-zombie-list) - gnus-level-zombie gnus-level-killed) - nil (- (1+ (cdr (setq active (gnus-active entry)))) - (car active)) - nil) - ;; Living groups. - (when (setq info (nth 2 entry)) - (gnus-group-insert-group-line - (gnus-info-group info) - (gnus-info-level info) (gnus-info-marks info) - (car entry) (gnus-info-method info))))) - (when (and (listp entry) - (numberp (car entry))) - (incf unread (car entry))) - (when (listp entry) - (setq tick t))) + (when (if (stringp entry) + (gnus-group-prepare-logic + entry + (and + (or (not gnus-group-listed-groups) + (if (< list-level gnus-level-zombie) nil + (let ((entry-level + (if (member entry gnus-zombie-list) + gnus-level-zombie gnus-level-killed))) + (and (<= entry-level list-level) + (>= entry-level lowest))))) + (cond + ((stringp regexp) + (string-match regexp entry)) + ((functionp regexp) + (funcall regexp entry)) + ((null regexp) t) + (t nil)))) + (setq info (nth 2 entry)) + (gnus-group-prepare-logic + (gnus-info-group info) + (and (or (not gnus-group-listed-groups) + (let ((entry-level (gnus-info-level info))) + (and (<= entry-level list-level) + (>= entry-level lowest)))) + (or (not (functionp predicate)) + (funcall predicate info)) + (or (not (stringp regexp)) + (string-match regexp (gnus-info-group info)))))) + (when visiblep + (if (stringp entry) + ;; Dead groups. + (gnus-group-insert-group-line + entry (if (member entry gnus-zombie-list) + gnus-level-zombie gnus-level-killed) + nil (- (1+ (cdr (setq active (gnus-active entry)))) + (car active)) + nil) + ;; Living groups. + (when (setq info (nth 2 entry)) + (gnus-group-insert-group-line + (gnus-info-group info) + (gnus-info-level info) (gnus-info-marks info) + (car entry) (gnus-info-method info))))) + (when (and (listp entry) + (numberp (car entry))) + (incf unread (car entry))) + (when (listp entry) + (setq tick t)))) (goto-char beg) ;; Insert the topic line. (when (and (not silent) @@ -593,7 +680,7 @@ (when (and (eq major-mode 'gnus-group-mode) gnus-topic-mode) (let ((group (gnus-group-group-name)) - (m (point-marker)) + (m (point-marker)) (buffer-read-only nil)) (when (and group (gnus-get-info group) @@ -611,7 +698,8 @@ (unfound t) entry) ;; Try to jump to a visible group. - (while (and g (not (gnus-group-goto-group (car g) t))) + (while (and g + (not (gnus-group-goto-group (car g) t))) (pop g)) ;; It wasn't visible, so we try to see where to insert it. (when (not g) @@ -623,20 +711,31 @@ (when (and unfound topic (not (gnus-topic-goto-missing-topic topic))) - (let* ((top (gnus-topic-find-topology topic)) - (children (cddr top)) - (type (cadr top)) - (unread 0) - (entries (gnus-topic-find-groups - (car type) (car gnus-group-list-mode) - (cdr gnus-group-list-mode)))) - (while children - (incf unread (gnus-topic-unread (caar (pop children))))) - (while (setq entry (pop entries)) - (when (numberp (car entry)) - (incf unread (car entry)))) - (gnus-topic-insert-topic-line - topic t t (car (gnus-topic-find-topology topic)) nil unread)))))) + (gnus-topic-display-missing-topic topic))))) + +(defun gnus-topic-display-missing-topic (topic) + "Insert topic lines recursively for missing topics." + (let ((parent (gnus-topic-find-topology + (gnus-topic-parent-topic topic)))) + (when (and parent + (not (gnus-topic-goto-missing-topic (caadr parent)))) + (gnus-topic-display-missing-topic (caadr parent)))) + (gnus-topic-goto-missing-topic topic) + (let* ((top (gnus-topic-find-topology topic)) + (children (cddr top)) + (type (cadr top)) + (unread 0) + (entries (gnus-topic-find-groups + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode))) + entry) + (while children + (incf unread (gnus-topic-unread (caar (pop children))))) + (while (setq entry (pop entries)) + (when (numberp (car entry)) + (incf unread (car entry)))) + (gnus-topic-insert-topic-line + topic t t (car (gnus-topic-find-topology topic)) nil unread))) (defun gnus-topic-goto-missing-topic (topic) (if (gnus-topic-goto-topic topic) @@ -830,8 +929,8 @@ ? )) (yanked (list group)) alist talist end) - ;; Then we enter the yanked groups into the topics they belong - ;; to. + ;; Then we enter the yanked groups into the topics + ;; they belong to. (when (setq alist (assoc (save-excursion (forward-line -1) (or @@ -949,6 +1048,7 @@ "\r" gnus-topic-select-group " " gnus-topic-read-group "\C-c\C-x" gnus-topic-expire-articles + "c" gnus-topic-catchup-articles "\C-k" gnus-topic-kill-group "\C-y" gnus-topic-yank-group "\M-g" gnus-topic-get-new-news-this-topic @@ -975,6 +1075,8 @@ "j" gnus-topic-jump-to-topic "M" gnus-topic-move-matching "C" gnus-topic-copy-matching + "\M-p" gnus-topic-goto-previous-topic + "\M-n" gnus-topic-goto-next-topic "\C-i" gnus-topic-indent [tab] gnus-topic-indent "r" gnus-topic-rename @@ -987,6 +1089,7 @@ "a" gnus-topic-sort-groups-by-alphabet "u" gnus-topic-sort-groups-by-unread "l" gnus-topic-sort-groups-by-level + "e" gnus-topic-sort-groups-by-server "v" gnus-topic-sort-groups-by-score "r" gnus-topic-sort-groups-by-rank "m" gnus-topic-sort-groups-by-method)) @@ -998,21 +1101,23 @@ '("Topics" ["Toggle topics" gnus-topic-mode t] ("Groups" - ["Copy" gnus-topic-copy-group t] - ["Move" gnus-topic-move-group t] + ["Copy..." gnus-topic-copy-group t] + ["Move..." gnus-topic-move-group t] ["Remove" gnus-topic-remove-group t] - ["Copy matching" gnus-topic-copy-matching t] - ["Move matching" gnus-topic-move-matching t]) + ["Copy matching..." gnus-topic-copy-matching t] + ["Move matching..." gnus-topic-move-matching t]) ("Topics" - ["Goto" gnus-topic-jump-to-topic t] + ["Goto..." gnus-topic-jump-to-topic t] ["Show" gnus-topic-show-topic t] ["Hide" gnus-topic-hide-topic t] ["Delete" gnus-topic-delete t] - ["Rename" gnus-topic-rename t] - ["Create" gnus-topic-create-topic t] + ["Rename..." gnus-topic-rename t] + ["Create..." gnus-topic-create-topic t] ["Mark" gnus-topic-mark-topic t] ["Indent" gnus-topic-indent t] ["Sort" gnus-topic-sort-topics t] + ["Previous topic" gnus-topic-goto-previous-topic t] + ["Next topic" gnus-topic-goto-next-topic t] ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] ["Edit parameters" gnus-topic-edit-parameters t]) ["List active" gnus-topic-list-active t])))) @@ -1027,7 +1132,7 @@ (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. (if (not gnus-topic-mode) - (setq gnus-goto-missing-group-function nil) + (setq gnus-goto-missing-group-function nil) (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) (gnus-set-format 'topic t) @@ -1050,8 +1155,9 @@ 'gnus-group-sort-topic) (setq gnus-group-change-level-function 'gnus-topic-change-level) (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) - (make-local-hook 'gnus-check-bogus-groups-hook) - (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) + (gnus-make-local-hook 'gnus-check-bogus-groups-hook) + (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist + nil 'local) (setq gnus-topology-checked-p nil) ;; We check the topology. (when gnus-newsrc-alist @@ -1070,11 +1176,14 @@ (defun gnus-topic-select-group (&optional all) "Select this newsgroup. No article is selected automatically. +If the group is opened, just switch the summary buffer. If ALL is non-nil, already read articles become readable. If ALL is a number, fetch this number of articles. If performed over a topic line, toggle folding the topic." (interactive "P") + (when (and (eobp) (not (gnus-group-group-name))) + (forward-line -1)) (if (gnus-group-topic-p) (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) @@ -1097,10 +1206,27 @@ (gnus-message 5 "Expiring groups in %s..." topic) (let ((gnus-group-marked (mapcar (lambda (entry) (car (nth 2 entry))) - (gnus-topic-find-groups topic gnus-level-killed t)))) + (gnus-topic-find-groups topic gnus-level-killed t + nil t)))) (gnus-group-expire-articles nil)) (gnus-message 5 "Expiring groups in %s...done" topic)))) +(defun gnus-topic-catchup-articles (topic) + "Catchup this topic or group. +Also see `gnus-group-catchup'." + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-catchup-current) + (save-excursion + (let* ((groups + (mapcar (lambda (entry) (car (nth 2 entry))) + (gnus-topic-find-groups topic gnus-level-killed t + nil t))) + (buffer-read-only nil) + (gnus-group-marked groups)) + (gnus-group-catchup-current) + (mapcar 'gnus-topic-update-topics-containing-group groups))))) + (defun gnus-topic-read-group (&optional all no-article group) "Read news in this newsgroup. If the prefix argument ALL is non-nil, already read articles become @@ -1157,7 +1283,8 @@ If COPYP, copy the groups instead." (interactive (list current-prefix-arg - (completing-read "Move to topic: " gnus-topic-alist nil t))) + (gnus-completing-read "Move to topic" gnus-topic-alist nil t + 'gnus-topic-history))) (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n)) @@ -1303,9 +1430,9 @@ (setcar (cdr (cadr topic)) 'visible) (gnus-group-list-groups))))) -(defun gnus-topic-mark-topic (topic &optional unmark recursive) +(defun gnus-topic-mark-topic (topic &optional unmark non-recursive) "Mark all groups in the TOPIC with the process mark. -If RECURSIVE is t, mark its subtopics too." +If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics." (interactive (list (gnus-group-topic-name) nil (and current-prefix-arg t))) @@ -1313,28 +1440,32 @@ (call-interactively 'gnus-group-mark-group) (save-excursion (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil - recursive))) + (not non-recursive)))) (while groups (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) (gnus-info-group (nth 2 (pop groups))))))))) -(defun gnus-topic-unmark-topic (topic &optional dummy recursive) +(defun gnus-topic-unmark-topic (topic &optional dummy non-recursive) "Remove the process mark from all groups in the TOPIC. -If RECURSIVE is t, unmark its subtopics too." +If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (interactive (list (gnus-group-topic-name) nil (and current-prefix-arg t))) (if (not topic) (call-interactively 'gnus-group-unmark-group) - (gnus-topic-mark-topic topic t recursive))) + (gnus-topic-mark-topic topic t non-recursive))) (defun gnus-topic-get-new-news-this-topic (&optional n) "Check for new news in the current topic." (interactive "P") (if (not (gnus-group-topic-p)) (gnus-group-get-new-news-this-group n) - (gnus-topic-mark-topic (gnus-group-topic-name) nil (and n t)) - (gnus-group-get-new-news-this-group))) + (let* ((topic (gnus-group-topic-name)) + (data (cadr (gnus-topic-find-topology topic)))) + (save-excursion + (gnus-topic-mark-topic topic nil (and n t)) + (gnus-group-get-new-news-this-group)) + (gnus-topic-remove-topic (eq 'visible (cadr data)))))) (defun gnus-topic-move-matching (regexp topic &optional copyp) "Move all groups that match REGEXP to some topic." @@ -1380,7 +1511,7 @@ (interactive (let ((topic (gnus-current-topic))) (list topic - (read-string (format "Rename %s to: " topic))))) + (read-string (format "Rename %s to: " topic) topic)))) ;; Check whether the new name exists. (when (gnus-topic-find-topology new-name) (error "Topic '%s' already exists" new-name)) @@ -1552,14 +1683,21 @@ (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) +(defun gnus-topic-sort-groups-by-server (&optional reverse) + "Sort the current topic alphabetically by server name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-server reverse)) + (defun gnus-topic-sort-topics-1 (top reverse) (if (cdr top) (let ((subtop - (mapcar `(lambda (top) - (gnus-topic-sort-topics-1 top ,reverse)) + (mapcar (gnus-byte-compile + `(lambda (top) + (gnus-topic-sort-topics-1 top ,reverse))) (sort (cdr top) - '(lambda (t1 t2) - (string-lessp (caar t1) (caar t2))))))) + (lambda (t1 t2) + (string-lessp (caar t1) (caar t2))))))) (setcdr top (if reverse (reverse subtop) subtop)))) top) @@ -1612,7 +1750,14 @@ (gnus-subscribe-alphabetically newsgroup) ;; Add the group to the topic. (nconc (assoc topic gnus-topic-alist) (list newsgroup)) - (throw 'end t)))))) + ;; if this topic specifies a default level, use it + (let ((subscribe-level (cdr (assq 'subscribe-level + (gnus-topic-parameters topic))))) + (when subscribe-level + (gnus-group-change-level newsgroup subscribe-level + gnus-level-default-subscribed))) + (throw 'end t))) + nil))) (provide 'gnus-topic)
--- a/lisp/gnus/gnus-undo.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-undo.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; gnus-undo.el --- minor mode for undoing in Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -114,7 +114,7 @@ (when (gnus-visual-p 'undo-menu 'menu) (gnus-undo-make-menu-bar)) (gnus-add-minor-mode 'gnus-undo-mode "" gnus-undo-mode-map) - (make-local-hook 'post-command-hook) + (gnus-make-local-hook 'post-command-hook) (add-hook 'post-command-hook 'gnus-undo-boundary nil t) (gnus-run-hooks 'gnus-undo-mode-hook)))
--- a/lisp/gnus/gnus-util.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-util.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -29,6 +29,9 @@ ;; used by Gnus and may be used by any other package without loading ;; Gnus first. +;; [Unfortunately, it does depend on other parts of Gnus, e.g. the +;; autoloads below...] + ;;; Code: (require 'custom) @@ -36,14 +39,38 @@ (require 'cl) ;; Fixme: this should be a gnus variable, not nnmail-. (defvar nnmail-pathname-coding-system)) -(require 'nnheader) (require 'time-date) +(require 'netrc) (eval-and-compile (autoload 'message-fetch-field "message") + (autoload 'gnus-get-buffer-window "gnus-win") (autoload 'rmail-insert-rmail-file-header "rmail") (autoload 'rmail-count-new-messages "rmail") - (autoload 'rmail-show-message "rmail")) + (autoload 'rmail-show-message "rmail") + (autoload 'nnheader-narrow-to-headers "nnheader") + (autoload 'nnheader-replace-chars-in-string "nnheader")) + +(eval-and-compile + (cond + ((fboundp 'replace-in-string) + (defalias 'gnus-replace-in-string 'replace-in-string)) + ((fboundp 'replace-regexp-in-string) + (defun gnus-replace-in-string (string regexp newtext &optional literal) + (replace-regexp-in-string regexp newtext string nil literal))) + (t + (defun gnus-replace-in-string (string regexp newtext &optional literal) + (let ((start 0) tail) + (while (string-match regexp string start) + (setq tail (- (length string) (match-end 0))) + (setq string (replace-match newtext nil literal string)) + (setq start (- (length string) tail)))) + string)))) + +;;; bring in the netrc functions as aliases +(defalias 'gnus-netrc-get 'netrc-get) +(defalias 'gnus-netrc-machine 'netrc-machine) +(defalias 'gnus-parse-netrc 'netrc-parse) (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." @@ -53,20 +80,20 @@ (defmacro gnus-eval-in-buffer-window (buffer &rest forms) "Pop to BUFFER, evaluate FORMS, and then return to the original window." (let ((tempvar (make-symbol "GnusStartBufferWindow")) - (w (make-symbol "w")) - (buf (make-symbol "buf"))) + (w (make-symbol "w")) + (buf (make-symbol "buf"))) `(let* ((,tempvar (selected-window)) - (,buf ,buffer) - (,w (get-buffer-window ,buf 'visible))) + (,buf ,buffer) + (,w (gnus-get-buffer-window ,buf 'visible))) (unwind-protect - (progn - (if ,w - (progn - (select-window ,w) - (set-buffer (window-buffer ,w))) - (pop-to-buffer ,buf)) - ,@forms) - (select-window ,tempvar))))) + (progn + (if ,w + (progn + (select-window ,w) + (set-buffer (window-buffer ,w))) + (pop-to-buffer ,buf)) + ,@forms) + (select-window ,tempvar))))) (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) @@ -81,17 +108,12 @@ ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way ;; to limit the length of a string. This function is necessary since ;; `(substr "abc" 0 30)' pukes with "Args out of range". +;; Fixme: Why not `truncate-string-to-width'? (defsubst gnus-limit-string (str width) (if (> (length str) width) (substring str 0 width) str)) -(defsubst gnus-functionp (form) - "Return non-nil if FORM is funcallable." - (or (and (symbolp form) (fboundp form)) - (and (listp form) (eq (car form) 'lambda)) - (byte-code-function-p form))) - (defsubst gnus-goto-char (point) (and point (goto-char point))) @@ -101,11 +123,6 @@ (funcall (if (stringp buffer) 'get-buffer 'buffer-name) buffer)))) -(defmacro gnus-kill-buffer (buffer) - `(let ((buf ,buffer)) - (when (gnus-buffer-exists-p buf) - (kill-buffer buf)))) - (defalias 'gnus-point-at-bol (if (fboundp 'point-at-bol) 'point-at-bol @@ -116,6 +133,16 @@ 'point-at-eol 'line-end-position)) +;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and +;; XEmacs. In Emacs we don't need to call `make-local-hook' first. +;; It's harmless, though, so the main purpose of this alias is to shut +;; up the byte compiler. +(defalias 'gnus-make-local-hook + (if (eq (get 'make-local-hook 'byte-compile) + 'byte-compile-obsolete) + 'ignore ; Emacs + 'make-local-hook)) ; XEmacs + (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." (if (equal (car list) elt) @@ -130,7 +157,7 @@ ;; Delete the current line (and the next N lines). (defmacro gnus-delete-line (&optional n) - `(delete-region (progn (beginning-of-line) (point)) + `(delete-region (gnus-point-at-bol) (progn (forward-line ,(or n 1)) (point)))) (defun gnus-byte-code (func) @@ -143,6 +170,11 @@ (cons 'progn (cddr fval))))) (defun gnus-extract-address-components (from) + "Extract address components from a From header. +Given an RFC-822 address FROM, extract full name and canonical address. +Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple +solution than `mail-extract-address-components', which works much better, but +is slower." (let (name address) ;; First find the address - the thing with the @ in it. This may ;; not be accurate in mail addresses, but does the trick most of @@ -155,7 +187,7 @@ (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) (and (setq name (substring from 0 (match-beginning 0))) ;; Strip any quotes from the name. - (string-match "\".*\"" name) + (string-match "^\".*\"$" name) (setq name (substring name 1 (1- (match-end 0)))))) ;; If not, then "address (name)" is used. (or name @@ -180,9 +212,26 @@ (nnheader-narrow-to-headers) (message-fetch-field field))))) +(defun gnus-fetch-original-field (field) + "Fetch FIELD from the original version of the current article." + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field field))) + + (defun gnus-goto-colon () (beginning-of-line) - (search-forward ":" (gnus-point-at-eol) t)) + (let ((eol (gnus-point-at-eol))) + (goto-char (or (text-property-any (point) eol 'gnus-position t) + (search-forward ":" eol t) + (point))))) + +(defun gnus-decode-newsgroups (newsgroups group &optional method) + (let ((method (or method (gnus-find-method-for-group group)))) + (mapconcat (lambda (group) + (gnus-group-name-decode group (gnus-group-name-charset + method group))) + (message-tokenize-header newsgroups) + ","))) (defun gnus-remove-text-with-property (prop) "Delete all text in the current buffer with text property PROP." @@ -195,20 +244,14 @@ (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." - (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) - (len (length newsgroup)) - idx) - ;; If this is a foreign group, we don't want to translate the - ;; entire name. - (if (setq idx (string-match ":" newsgroup)) - (aset newsgroup idx ?/) - (setq idx 0)) - ;; Replace all occurrences of `.' with `/'. - (while (< idx len) - (when (= (aref newsgroup idx) ?.) - (aset newsgroup idx ?/)) - (setq idx (1+ idx))) - newsgroup)) + (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) + (idx (string-match ":" newsgroup))) + (concat + (if idx (substring newsgroup 0 idx)) + (if idx "/") + (nnheader-replace-chars-in-string + (if idx (substring newsgroup (1+ idx)) newsgroup) + ?. ?/)))) (defun gnus-newsgroup-savable-name (group) ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) @@ -271,7 +314,7 @@ (define-key keymap key (pop plist)) (pop plist))))) -(defun gnus-completing-read (default prompt &rest args) +(defun gnus-completing-read-with-default (default prompt &rest args) ;; Like `completing-read', except that DEFAULT is the default argument. (let* ((prompt (if default (concat prompt " (default " default ") ") @@ -293,6 +336,74 @@ (yes-or-no-p prompt) (message ""))) +;; By Frank Schmitt <ich@Frank-Schmitt.net>. Allows to have +;; age-depending date representations. (e.g. just the time if it's +;; from today, the day of the week if it's within the last 7 days and +;; the full date if it's older) + +(defun gnus-seconds-today () + "Return the number of seconds passed today." + (let ((now (decode-time (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) + +(defun gnus-seconds-month () + "Return the number of seconds passed this month." + (let ((now (decode-time (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (* (- (car (nthcdr 3 now)) 1) 3600 24)))) + +(defun gnus-seconds-year () + "Return the number of seconds passed this year." + (let ((now (decode-time (current-time))) + (days (format-time-string "%j" (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (* (- (string-to-number days) 1) 3600 24)))) + +(defvar gnus-user-date-format-alist + '(((gnus-seconds-today) . "%k:%M") + (604800 . "%a %k:%M") ;;that's one week + ((gnus-seconds-month) . "%a %d") + ((gnus-seconds-year) . "%b %d") + (t . "%b %d '%y")) ;;this one is used when no + ;;other does match + "Specifies date format depending on age of article. +This is an alist of items (AGE . FORMAT). AGE can be a number (of +seconds) or a Lisp expression evaluating to a number. When the age of +the article is less than this number, then use `format-time-string' +with the corresponding FORMAT for displaying the date of the article. +If AGE is not a number or a Lisp expression evaluating to a +non-number, then the corresponding FORMAT is used as a default value. + +Note that the list is processed from the beginning, so it should be +sorted by ascending AGE. Also note that items following the first +non-number AGE will be ignored. + +You can use the functions `gnus-seconds-today', `gnus-seconds-month' +and `gnus-seconds-year' in the AGE spec. They return the number of +seconds passed since the start of today, of this month, of this year, +respectively.") + +(defun gnus-user-date (messy-date) + "Format the messy-date according to gnus-user-date-format-alist. +Returns \" ? \" if there's bad input or if an other error occurs. +Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." + (condition-case () + (let* ((messy-date (time-to-seconds (safe-date-to-time messy-date))) + (now (time-to-seconds (current-time))) + ;;If we don't find something suitable we'll use this one + (my-format "%b %d '%y")) + (let* ((difference (- now messy-date)) + (templist gnus-user-date-format-alist) + (top (eval (caar templist)))) + (while (if (numberp top) (< top difference) (not top)) + (progn + (setq templist (cdr templist)) + (setq top (eval (caar templist))))) + (if (stringp (cdr (car templist))) + (setq my-format (cdr (car templist))))) + (format-time-string (eval my-format) (seconds-to-time messy-date))) + (error " ? "))) + (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." (condition-case () @@ -325,13 +436,7 @@ (defun gnus-mode-string-quote (string) "Quote all \"%\"'s in STRING." - (save-excursion - (gnus-set-work-buffer) - (insert string) - (goto-char (point-min)) - (while (search-forward "%" nil t) - (insert "%")) - (buffer-string))) + (gnus-replace-in-string string "%" "%%")) ;; Make a hash table (default and minimum size is 256). ;; Optional argument HASHSIZE specifies the table size. @@ -359,12 +464,13 @@ :group 'gnus-start :type 'integer) -;; Show message if message has a lower level than `gnus-verbose'. -;; Guideline for numbers: -;; 1 - error messages, 3 - non-serious error messages, 5 - messages -;; for things that take a long time, 7 - not very important messages -;; on stuff, 9 - messages inside loops. (defun gnus-message (level &rest args) + "If LEVEL is lower than `gnus-verbose' print ARGS using `message'. + +Guideline for numbers: +1 - error messages, 3 - non-serious error messages, 5 - messages for things +that take a long time, 7 - not very important messages on stuff, 9 - messages +inside loops." (if (<= level gnus-verbose) (apply 'message args) ;; We have to do this format thingy here even if the result isn't @@ -387,7 +493,7 @@ "Return a list of Message-IDs in REFERENCES." (let ((beg 0) ids) - (while (string-match "<[^>]+>" references beg) + (while (string-match "<[^<]+[^< \t]" references beg) (push (substring references (match-beginning 0) (setq beg (match-end 0))) ids)) (nreverse ids))) @@ -395,13 +501,17 @@ (defsubst gnus-parent-id (references &optional n) "Return the last Message-ID in REFERENCES. If N, return the Nth ancestor instead." - (when references - (let ((ids (inline (gnus-split-references references)))) - (while (nthcdr (or n 1) ids) - (setq ids (cdr ids))) - (car ids)))) + (when (and references + (not (zerop (length references)))) + (if n + (let ((ids (inline (gnus-split-references references)))) + (while (nthcdr n ids) + (setq ids (cdr ids))) + (car ids)) + (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) + (match-string 1 references))))) -(defsubst gnus-buffer-live-p (buffer) +(defun gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." (and buffer (get-buffer buffer) @@ -410,9 +520,9 @@ (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." (if (< (current-column) (/ (window-width) 2)) - (set-window-hscroll (get-buffer-window (current-buffer) t) 0) + (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0) (let* ((orig (point)) - (end (window-end (get-buffer-window (current-buffer) t))) + (end (window-end (gnus-get-buffer-window (current-buffer) t))) (max 0)) (when end ;; Find the longest line currently displayed in the window. @@ -426,15 +536,15 @@ ;; Scroll horizontally to center (sort of) the point. (if (> max (window-width)) (set-window-hscroll - (get-buffer-window (current-buffer) t) + (gnus-get-buffer-window (current-buffer) t) (min (- (current-column) (/ (window-width) 3)) (+ 2 (- max (window-width))))) - (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) + (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0)) max)))) -(defun gnus-read-event-char () +(defun gnus-read-event-char (&optional prompt) "Get the next event." - (let ((event (read-event))) + (let ((event (read-event prompt))) ;; should be gnus-characterp, but this can't be called in XEmacs anyway (cons (and (numberp event) event) event))) @@ -474,23 +584,24 @@ gname))) (defun gnus-make-sort-function (funs) - "Return a composite sort condition based on the functions in FUNC." + "Return a composite sort condition based on the functions in FUNS." (cond ;; Just a simple function. - ((gnus-functionp funs) funs) + ((functionp funs) funs) ;; No functions at all. ((null funs) funs) ;; A list of functions. ((or (cdr funs) (listp (car funs))) - `(lambda (t1 t2) - ,(gnus-make-sort-function-1 (reverse funs)))) + (gnus-byte-compile + `(lambda (t1 t2) + ,(gnus-make-sort-function-1 (reverse funs))))) ;; A list containing just one function. (t (car funs)))) (defun gnus-make-sort-function-1 (funs) - "Return a composite sort condition based on the functions in FUNC." + "Return a composite sort condition based on the functions in FUNS." (let ((function (car funs)) (first 't1) (last 't2)) @@ -501,7 +612,7 @@ (setq function (cadr function) first 't2 last 't1)) - ((gnus-functionp function) + ((functionp function) ;; Do nothing. ) (t @@ -527,9 +638,13 @@ (prin1 form (current-buffer)))) (defun gnus-prin1-to-string (form) - "The same as `prin1', but bind `print-quoted' and `print-readably' to t." + "The same as `prin1'. +Bind `print-quoted' and `print-readably' to t, and `print-length' +and `print-level' to nil." (let ((print-quoted t) - (print-readably t)) + (print-readably t) + (print-length nil) + (print-level nil)) (prin1-to-string form))) (defun gnus-make-directory (directory) @@ -571,6 +686,19 @@ (setq beg (point))) (gnus-put-text-property beg (point) prop val))))) +(defsubst gnus-put-overlay-excluding-newlines (beg end prop val) + "The same as `put-text-property', but don't put this prop on any newlines in the region." + (save-match-data + (save-excursion + (save-restriction + (goto-char beg) + (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) + (gnus-overlay-put + (gnus-make-overlay beg (match-beginning 0)) + prop val) + (setq beg (point))) + (gnus-overlay-put (gnus-make-overlay beg (point)) prop val))))) + (defun gnus-put-text-property-excluding-characters-with-faces (beg end prop val) "The same as `put-text-property', but don't put props on characters with the `gnus-face' property." @@ -579,9 +707,23 @@ (when (get-text-property b 'gnus-face) (setq b (next-single-property-change b 'gnus-face nil end))) (when (/= b end) - (gnus-put-text-property - b (setq b (next-single-property-change b 'gnus-face nil end)) - prop val))))) + (inline + (gnus-put-text-property + b (setq b (next-single-property-change b 'gnus-face nil end)) + prop val)))))) + +(defmacro gnus-faces-at (position) + "Return a list of faces at POSITION." + (if (featurep 'xemacs) + `(let ((pos ,position)) + (mapcar-extents 'extent-face + nil (current-buffer) pos pos nil 'face)) + `(let ((pos ,position)) + (delq nil (cons (get-text-property pos 'face) + (mapcar + (lambda (overlay) + (overlay-get overlay 'face)) + (overlays-at pos))))))) ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 ;;; The primary idea here is to try to protect internal datastructures @@ -660,10 +802,31 @@ ;;; Functions for saving to babyl/mail files. -(defvar rmail-default-rmail-file) +(eval-when-compile + (condition-case nil + (progn + (require 'rmail) + (autoload 'rmail-update-summary "rmailsum")) + (error + (define-compiler-macro rmail-select-summary (&rest body) + ;; Rmail of the XEmacs version is supplied by the package, and + ;; requires tm and apel packages. However, there may be those + ;; who haven't installed those packages. This macro helps such + ;; people even if they install those packages later. + `(eval '(rmail-select-summary ,@body))) + ;; If there's rmail but there's no tm (or there's apel of the + ;; mainstream, not the XEmacs version), loading rmail of the XEmacs + ;; version fails halfway, however it provides the rmail-select-summary + ;; macro which uses the following functions: + (autoload 'rmail-summary-displayed "rmail") + (autoload 'rmail-maybe-display-summary "rmail"))) + (defvar rmail-default-rmail-file) + (defvar mm-text-coding-system)) + (defun gnus-output-to-rmail (filename &optional ask) "Append the current article to an Rmail file named FILENAME." (require 'rmail) + (require 'mm-util) ;; Most of these codes are borrowed from rmailout.el. (setq filename (expand-file-name filename)) (setq rmail-default-rmail-file filename) @@ -706,10 +869,10 @@ (when msg (goto-char (point-min)) (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max)) - (rmail-count-new-messages t) - (when (rmail-summary-exists) + (search-backward "\n\^_") + (narrow-to-region (point) (point-max)) + (rmail-count-new-messages t) + (when (rmail-summary-exists) (rmail-select-summary (rmail-update-summary))) (rmail-count-new-messages t) @@ -785,106 +948,16 @@ (insert "\^_"))) (defun gnus-map-function (funs arg) - "Applies the result of the first function in FUNS to the second, and so on. + "Apply the result of the first function in FUNS to the second, and so on. ARG is passed to the first function." - (let ((myfuns funs)) - (while myfuns - (setq arg (funcall (pop myfuns) arg))) - arg)) + (while funs + (setq arg (funcall (pop funs) arg))) + arg) (defun gnus-run-hooks (&rest funcs) - "Does the same as `run-hooks', but saves excursion." - (let ((buf (current-buffer))) - (unwind-protect - (apply 'run-hooks funcs) - (set-buffer buf)))) - -;;; -;;; .netrc and .authinforc parsing -;;; - -(defun gnus-parse-netrc (file) - "Parse FILE and return a 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) (gnus-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 gnus-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 (gnus-netrc-get (car result) "port") - defaultport "nntp")))) - (pop result)) - (car result)))) - -(defun gnus-netrc-get (alist type) - "Return the value of token TYPE from ALIST." - (cdr (assoc type alist))) + "Does the same as `run-hooks', but saves the current buffer." + (save-current-buffer + (apply 'run-hooks funcs))) ;;; Various @@ -898,28 +971,31 @@ (eq major-mode 'gnus-group-mode)))) (defun gnus-remove-duplicates (list) - (let (new (tail list)) - (while tail - (or (member (car tail) new) - (setq new (cons (car tail) new))) - (setq tail (cdr tail))) + (let (new) + (while list + (or (member (car list) new) + (setq new (cons (car list) new))) + (setq list (cdr list))) (nreverse new))) -(defun gnus-delete-if (predicate list) - "Delete elements from LIST that satisfy PREDICATE." +(defun gnus-remove-if (predicate list) + "Return a copy of LIST with all items satisfying PREDICATE removed." (let (out) (while list (unless (funcall predicate (car list)) (push (car list) out)) - (pop list)) + (setq list (cdr list))) (nreverse out))) -(defun gnus-delete-alist (key alist) - "Delete all entries in ALIST that have a key eq to KEY." - (let (entry) - (while (setq entry (assq key alist)) - (setq alist (delq entry alist))) - alist)) +(if (fboundp 'assq-delete-all) + (defalias 'gnus-delete-alist 'assq-delete-all) + (defun gnus-delete-alist (key alist) + "Delete from ALIST all elements whose car is KEY. +Return the modified alist." + (let (entry) + (while (setq entry (assq key alist)) + (setq alist (delq entry alist))) + alist))) (defmacro gnus-pull (key alist &optional assoc-p) "Modify ALIST to be without KEY." @@ -929,14 +1005,14 @@ `(setq ,alist (delq (,fun ,key ,alist) ,alist)))) (defun gnus-globalify-regexp (re) - "Returns a regexp that matches a whole line, iff RE matches a part of it." + "Return a regexp that matches a whole line, iff RE matches a part of it." (concat (unless (string-match "^\\^" re) "^.*") re (unless (string-match "\\$$" re) ".*$"))) (defun gnus-set-window-start (&optional point) "Set the window start to POINT, or (point) if nil." - (let ((win (get-buffer-window (current-buffer) t))) + (let ((win (gnus-get-buffer-window (current-buffer) t))) (when win (set-window-start win (or point (point)))))) @@ -980,11 +1056,55 @@ (while (search-backward "\\." nil t) (delete-char 1))))) +;; Fixme: Why not use `with-output-to-temp-buffer'? +(defmacro gnus-with-output-to-file (file &rest body) + (let ((buffer (make-symbol "output-buffer")) + (size (make-symbol "output-buffer-size")) + (leng (make-symbol "output-buffer-length")) + (append (make-symbol "output-buffer-append"))) + `(let* ((,size 131072) + (,buffer (make-string ,size 0)) + (,leng 0) + (,append nil) + (standard-output + (lambda (c) + (aset ,buffer ,leng c) + + (if (= ,size (setq ,leng (1+ ,leng))) + (progn (write-region ,buffer nil ,file ,append 'no-msg) + (setq ,leng 0 + ,append t)))))) + ,@body + (when (> ,leng 0) + (let ((coding-system-for-write 'no-conversion)) + (write-region (substring ,buffer 0 ,leng) nil ,file + ,append 'no-msg)))))) + +(put 'gnus-with-output-to-file 'lisp-indent-function 1) +(put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) + +(if (fboundp 'union) + (defalias 'gnus-union 'union) + (defun gnus-union (l1 l2) + "Set union of lists L1 and L2." + (cond ((null l1) l2) + ((null l2) l1) + ((equal l1 l2) l1) + (t + (or (>= (length l1) (length l2)) + (setq l1 (prog1 l2 (setq l2 l1)))) + (while l2 + (or (member (car l2) l1) + (push (car l2) l1)) + (pop l2)) + l1)))) + (defun gnus-add-text-properties-when (property value start end properties &optional object) "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." (let (point) (while (and start + (< start end) ;; XEmacs will loop for every when start=end. (setq point (text-property-not-all start end property value))) (gnus-add-text-properties start point properties object) (setq start (text-property-any point end property value))) @@ -996,6 +1116,7 @@ "Like `remove-text-properties', only applied on where PROPERTY is VALUE." (let (point) (while (and start + (< start end) (setq point (text-property-not-all start end property value))) (remove-text-properties start point properties object) (setq start (text-property-any point end property value))) @@ -1003,11 +1124,369 @@ (remove-text-properties start end properties object)) t)) +;; This might use `compare-strings' to reduce consing in the +;; case-insensitive case, but it has to cope with null args. +;; (`string-equal' uses symbol print names.) +(defun gnus-string-equal (x y) + "Like `string-equal', except it compares case-insensitively." + (and (= (length x) (length y)) + (or (string-equal x y) + (string-equal (downcase x) (downcase y))))) + +(defcustom gnus-use-byte-compile t + "If non-nil, byte-compile crucial run-time code. +Setting it to nil has no effect after the first time `gnus-byte-compile' +is run." + :type 'boolean + :version "21.1" + :group 'gnus-various) + +(defun gnus-byte-compile (form) + "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." + (if gnus-use-byte-compile + (progn + (condition-case nil + ;; Work around a bug in XEmacs 21.4 + (require 'byte-optimize) + (error)) + (require 'bytecomp) + (defalias 'gnus-byte-compile + (lambda (form) + (let ((byte-compile-warnings '(unresolved callargs redefine))) + (byte-compile form)))) + (gnus-byte-compile form)) + form)) + +(defun gnus-remassoc (key alist) + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member +of LIST has a car that is `equal' to KEY, there is no way to remove it +by side effect; therefore, write `(setq foo (remassoc key foo))' to be +sure of changing the value of `foo'." + (when alist + (if (equal key (caar alist)) + (cdr alist) + (setcdr alist (gnus-remassoc key (cdr alist))) + alist))) + +(defun gnus-update-alist-soft (key value alist) + (if value + (cons (cons key value) (gnus-remassoc key alist)) + (gnus-remassoc key alist))) + +(defun gnus-create-info-command (node) + "Create a command that will go to info NODE." + `(lambda () + (interactive) + ,(concat "Enter the info system at node " node) + (Info-goto-node ,node) + (setq gnus-info-buffer (current-buffer)) + (gnus-configure-windows 'info))) + +(defun gnus-not-ignore (&rest args) + t) + (defvar gnus-directory-sep-char-regexp "/" "The regexp of directory separator character. If you find some problem with the directory separator character, try \"[/\\\\\]\" for some systems.") +(defun gnus-url-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +;; Fixme: Do it like QP. +(defun gnus-url-unhex-string (str &optional allow-newlines) + "Remove %XX, embedded spaces, etc in a url. +If optional second argument ALLOW-NEWLINES is non-nil, then allow the +decoding of carriage returns and line feeds in the string, which is normally +forbidden in URL encoding." + (let ((tmp "") + (case-fold-search t)) + (while (string-match "%[0-9a-f][0-9a-f]" str) + (let* ((start (match-beginning 0)) + (ch1 (gnus-url-unhex (elt str (+ start 1)))) + (code (+ (* 16 ch1) + (gnus-url-unhex (elt str (+ start 2)))))) + (setq tmp (concat + tmp (substring str 0 start) + (cond + (allow-newlines + (char-to-string code)) + ((or (= code ?\n) (= code ?\r)) + " ") + (t (char-to-string code)))) + str (substring str (match-end 0))))) + (setq tmp (concat tmp str)) + tmp)) + +(defun gnus-make-predicate (spec) + "Transform SPEC into a function that can be called. +SPEC is a predicate specifier that contains stuff like `or', `and', +`not', lists and functions. The functions all take one parameter." + `(lambda (elem) ,(gnus-make-predicate-1 spec))) + +(defun gnus-make-predicate-1 (spec) + (cond + ((symbolp spec) + `(,spec elem)) + ((listp spec) + (if (memq (car spec) '(or and not)) + `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) + (error "Invalid predicate specifier: %s" spec))))) + +(defun gnus-local-map-property (map) + "Return a list suitable for a text property list specifying keymap MAP." + (cond + ((featurep 'xemacs) + (list 'keymap map)) + ((>= emacs-major-version 21) + (list 'keymap map)) + (t + (list 'local-map map)))) + +(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate + require-match initial-contents + history default) + "Like `completing-read', allowing for non-existent 7th arg in older XEmacsen." + `(completing-read ,prompt ,table ,predicate ,require-match + ,initial-contents ,history + ,@(if (and (featurep 'xemacs) (< emacs-minor-version 2)) + () + (list default)))) + +(defun gnus-completing-read (prompt table &optional predicate require-match + history) + (when (and history + (not (boundp history))) + (set history nil)) + (gnus-completing-read-maybe-default + (if (symbol-value history) + (concat prompt " (" (car (symbol-value history)) "): ") + (concat prompt ": ")) + table + predicate + require-match + nil + history + (car (symbol-value history)))) + +(defun gnus-graphic-display-p () + (or (and (fboundp 'display-graphic-p) + (display-graphic-p)) + ;;;!!!This is bogus. Fixme! + (and (featurep 'xemacs) + t))) + +(put 'gnus-parse-without-error 'lisp-indent-function 0) +(put 'gnus-parse-without-error 'edebug-form-spec '(body)) + +(defmacro gnus-parse-without-error (&rest body) + "Allow continuing onto the next line even if an error occurs." + `(while (not (eobp)) + (condition-case () + (progn + ,@body + (goto-char (point-max))) + (error + (gnus-error 4 "Invalid data on line %d" + (count-lines (point-min) (point))) + (forward-line 1))))) + +(defun gnus-cache-file-contents (file variable function) + "Cache the contents of FILE in VARIABLE. The contents come from FUNCTION." + (let ((time (nth 5 (file-attributes file))) + contents value) + (if (or (null (setq value (symbol-value variable))) + (not (equal (car value) file)) + (not (equal (nth 1 value) time))) + (progn + (setq contents (funcall function file)) + (set variable (list file time contents)) + contents) + (nth 2 value)))) + +(defun gnus-multiple-choice (prompt choice &optional idx) + "Ask user a multiple choice question. +CHOICE is a list of the choice char and help message at IDX." + (let (tchar buf) + (save-window-excursion + (save-excursion + (while (not tchar) + (message "%s (%s): " + prompt + (concat + (mapconcat (lambda (s) (char-to-string (car s))) + choice ", ") ", ?")) + (setq tchar (read-char)) + (when (not (assq tchar choice)) + (setq tchar nil) + (setq buf (get-buffer-create "*Gnus Help*")) + (pop-to-buffer buf) + (fundamental-mode) ; for Emacs 20.4+ + (buffer-disable-undo) + (erase-buffer) + (insert prompt ":\n\n") + (let ((max -1) + (list choice) + (alist choice) + (idx (or idx 1)) + (i 0) + n width pad format) + ;; find the longest string to display + (while list + (setq n (length (nth idx (car list)))) + (unless (> max n) + (setq max n)) + (setq list (cdr list))) + (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end + (setq n (/ (1- (window-width)) max)) ; items per line + (setq width (/ (1- (window-width)) n)) ; width of each item + ;; insert `n' items, each in a field of width `width' + (while alist + (if (< i n) + () + (setq i 0) + (delete-char -1) ; the `\n' takes a char + (insert "\n")) + (setq pad (- width 3)) + (setq format (concat "%c: %-" (int-to-string pad) "s")) + (insert (format format (caar alist) (nth idx (car alist)))) + (setq alist (cdr alist)) + (setq i (1+ i)))))))) + (if (buffer-live-p buf) + (kill-buffer buf)) + tchar)) + +(defun gnus-select-frame-set-input-focus (frame) + "Select FRAME, raise it, and set input focus, if possible." + (cond ((featurep 'xemacs) + (raise-frame frame) + (select-frame frame) + (focus-frame frame)) + ;; The function `select-frame-set-input-focus' won't set + ;; the input focus under Emacs 21.2 and X window system. + ;;((fboundp 'select-frame-set-input-focus) + ;; (defalias 'gnus-select-frame-set-input-focus + ;; 'select-frame-set-input-focus) + ;; (select-frame-set-input-focus frame)) + (t + (raise-frame frame) + (select-frame frame) + (cond ((and (eq window-system 'x) + (fboundp 'x-focus-frame)) + (x-focus-frame frame)) + ((eq window-system 'w32) + (w32-focus-frame frame))) + (when focus-follows-mouse + (set-mouse-position frame (1- (frame-width frame)) 0))))) + +(defun gnus-frame-or-window-display-name (object) + "Given a frame or window, return the associated display name. +Return nil otherwise." + (if (featurep 'xemacs) + (device-connection (dfw-device object)) + (if (or (framep object) + (and (windowp object) + (setq object (window-frame object)))) + (let ((display (frame-parameter object 'display))) + (if (and (stringp display) + ;; Exclude invalid display names. + (string-match "\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" + display)) + display))))) + +;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile. +(defmacro gnus-mapcar (function seq1 &rest seqs2_n) + "Apply FUNCTION to each element of the sequences, and make a list of the results. +If there are several sequences, FUNCTION is called with that many arguments, +and mapping stops as soon as the shortest sequence runs out. With just one +sequence, this is like `mapcar'. With several, it is like the Common Lisp +`mapcar' function extended to arbitrary sequence types." + + (if seqs2_n + (let* ((seqs (cons seq1 seqs2_n)) + (cnt 0) + (heads (mapcar (lambda (seq) + (make-symbol (concat "head" + (int-to-string + (setq cnt (1+ cnt)))))) + seqs)) + (result (make-symbol "result")) + (result-tail (make-symbol "result-tail"))) + `(let* ,(let* ((bindings (cons nil nil)) + (heads heads)) + (nconc bindings (list (list result '(cons nil nil)))) + (nconc bindings (list (list result-tail result))) + (while heads + (nconc bindings (list (list (pop heads) (pop seqs))))) + (cdr bindings)) + (while (and ,@heads) + (setcdr ,result-tail (cons (funcall ,function + ,@(mapcar (lambda (h) (list 'car h)) + heads)) + nil)) + (setq ,result-tail (cdr ,result-tail) + ,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads)))) + (cdr ,result))) + `(mapcar ,function ,seq1))) + +(if (fboundp 'merge) + (defalias 'gnus-merge 'merge) + ;; Adapted from cl-seq.el + (defun gnus-merge (type list1 list2 pred) + "Destructively merge lists LIST1 and LIST2 to produce a new list. +Argument TYPE is for compatibility and ignored. +Ordering of the elements is preserved according to PRED, a `less-than' +predicate on the elements." + (let ((res nil)) + (while (and list1 list2) + (if (funcall pred (car list2) (car list1)) + (push (pop list2) res) + (push (pop list1) res))) + (nconc (nreverse res) list1 list2)))) + +(eval-when-compile + (defvar xemacs-codename)) + +(defun gnus-emacs-version () + "Stringified Emacs version." + (let ((system-v + (cond + ((eq gnus-user-agent 'emacs-gnus-config) + system-configuration) + ((eq gnus-user-agent 'emacs-gnus-type) + (symbol-name system-type)) + (t nil)))) + (cond + ((eq gnus-user-agent 'gnus) + nil) + ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) + (concat "Emacs/" (match-string 1 emacs-version) + (if system-v + (concat " (" system-v ")") + ""))) + ((string-match + "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" + emacs-version) + (concat + (match-string 1 emacs-version) + (format "/%d.%d" emacs-major-version emacs-minor-version) + (if (match-beginning 3) + (match-string 3 emacs-version) + "") + (if (boundp 'xemacs-codename) + (concat + " (" xemacs-codename + (if system-v + (concat ", " system-v ")") + ")")) + ""))) + (t emacs-version)))) + (provide 'gnus-util) ;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
--- a/lisp/gnus/gnus-uu.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-uu.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; gnus-uu.el --- extract (uu)encoded files in Gnus ;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, 2000, -;; 2001 Free Software Foundation, Inc. +;; 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Created: 2 Oct 1993 @@ -299,7 +299,8 @@ "^MIME-Version:" "^Content-Disposition:" "^Content-Description:" "^Content-ID:") "*List of regexps to match headers included in digested messages. -The headers will be included in the sequence they are matched." +The headers will be included in the sequence they are matched. If nil +include all headers." :group 'gnus-extract :type '(repeat regexp)) @@ -321,7 +322,7 @@ (defvar gnus-uu-saved-article-name nil) -(defvar gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") +(defvar gnus-uu-begin-string "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+\\(.*\\)$") (defvar gnus-uu-end-string "^end[ \t]*$") (defvar gnus-uu-body-line "^M") @@ -336,7 +337,7 @@ (defvar gnus-uu-shar-file-name nil) (defvar gnus-uu-shar-name-marker - "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)") + "begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)") (defvar gnus-uu-postscript-begin-string "^%!PS-") (defvar gnus-uu-postscript-end-string "^%%EOF$") @@ -353,56 +354,6 @@ (defvar gnus-uu-digest-from-subject nil) (defvar gnus-uu-digest-buffer nil) -;; Keymaps - -(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) - "p" gnus-summary-mark-as-processable - "u" gnus-summary-unmark-as-processable - "U" gnus-summary-unmark-all-processable - "v" gnus-uu-mark-over - "s" gnus-uu-mark-series - "r" gnus-uu-mark-region - "g" gnus-uu-unmark-region - "R" gnus-uu-mark-by-regexp - "G" gnus-uu-unmark-by-regexp - "t" gnus-uu-mark-thread - "T" gnus-uu-unmark-thread - "a" gnus-uu-mark-all - "b" gnus-uu-mark-buffer - "S" gnus-uu-mark-sparse - "k" gnus-summary-kill-process-mark - "y" gnus-summary-yank-process-mark - "w" gnus-summary-save-process-mark - "i" gnus-uu-invert-processable) - -(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) - ;;"x" gnus-uu-extract-any - "m" gnus-summary-save-parts - "u" gnus-uu-decode-uu - "U" gnus-uu-decode-uu-and-save - "s" gnus-uu-decode-unshar - "S" gnus-uu-decode-unshar-and-save - "o" gnus-uu-decode-save - "O" gnus-uu-decode-save - "b" gnus-uu-decode-binhex - "B" gnus-uu-decode-binhex - "p" gnus-uu-decode-postscript - "P" gnus-uu-decode-postscript-and-save) - -(gnus-define-keys - (gnus-uu-extract-view-map "v" gnus-uu-extract-map) - "u" gnus-uu-decode-uu-view - "U" gnus-uu-decode-uu-and-save-view - "s" gnus-uu-decode-unshar-view - "S" gnus-uu-decode-unshar-and-save-view - "o" gnus-uu-decode-save-view - "O" gnus-uu-decode-save-view - "b" gnus-uu-decode-binhex-view - "B" gnus-uu-decode-binhex-view - "p" gnus-uu-decode-postscript-view - "P" gnus-uu-decode-postscript-and-save-view) - - ;; Commands. (defun gnus-uu-decode-uu (&optional n) @@ -529,43 +480,44 @@ (if (and n (not (numberp n))) (setq message-forward-as-mime (not message-forward-as-mime) n nil)) - (gnus-setup-message 'forward - (setq gnus-uu-digest-from-subject nil) - (setq gnus-uu-digest-buffer - (gnus-get-buffer-create " *gnus-uu-forward*")) - (gnus-uu-decode-save n file) - (switch-to-buffer gnus-uu-digest-buffer) - (let ((fs gnus-uu-digest-from-subject)) - (when fs - (setq from (caar fs) - subject (gnus-simplify-subject-fuzzy (cdar fs)) - fs (cdr fs)) - (while (and fs (or from subject)) - (when from - (unless (string= from (caar fs)) - (setq from nil))) - (when subject - (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) - subject) - (setq subject nil))) - (setq fs (cdr fs)))) - (unless subject - (setq subject "Digested Articles")) - (unless from - (setq from - (if (gnus-news-group-p gnus-newsgroup-name) - gnus-newsgroup-name - "Various")))) - (goto-char (point-min)) - (when (re-search-forward "^Subject: ") - (delete-region (point) (gnus-point-at-eol)) - (insert subject)) - (goto-char (point-min)) - (when (re-search-forward "^From:") - (delete-region (point) (gnus-point-at-eol)) - (insert " " from)) - (let ((message-forward-decoded-p t)) - (message-forward post t))) + (let ((gnus-article-reply (gnus-summary-work-articles n))) + (gnus-setup-message 'forward + (setq gnus-uu-digest-from-subject nil) + (setq gnus-uu-digest-buffer + (gnus-get-buffer-create " *gnus-uu-forward*")) + (gnus-uu-decode-save n file) + (switch-to-buffer gnus-uu-digest-buffer) + (let ((fs gnus-uu-digest-from-subject)) + (when fs + (setq from (caar fs) + subject (gnus-simplify-subject-fuzzy (cdar fs)) + fs (cdr fs)) + (while (and fs (or from subject)) + (when from + (unless (string= from (caar fs)) + (setq from nil))) + (when subject + (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) + subject) + (setq subject nil))) + (setq fs (cdr fs)))) + (unless subject + (setq subject "Digested Articles")) + (unless from + (setq from + (if (gnus-news-group-p gnus-newsgroup-name) + gnus-newsgroup-name + "Various")))) + (goto-char (point-min)) + (when (re-search-forward "^Subject: ") + (delete-region (point) (gnus-point-at-eol)) + (insert subject)) + (goto-char (point-min)) + (when (re-search-forward "^From:") + (delete-region (point) (gnus-point-at-eol)) + (insert " " from)) + (let ((message-forward-decoded-p t)) + (message-forward post t)))) (setq gnus-uu-digest-from-subject nil))) (defun gnus-uu-digest-post-forward (&optional n) @@ -575,17 +527,40 @@ ;; Process marking. +(defun gnus-message-process-mark (unmarkp new-marked) + (let ((old (- (length gnus-newsgroup-processable) (length new-marked)))) + (message "%d mark%s %s%s" + (length new-marked) + (if (= (length new-marked) 1) "" "s") + (if unmarkp "removed" "added") + (cond + ((and (zerop old) + (not unmarkp)) + "") + (unmarkp + (format ", %d remain marked" + (length gnus-newsgroup-processable))) + (t + (format ", %d already marked" old)))))) + +(defun gnus-new-processable (unmarkp articles) + (if unmarkp + (gnus-intersection gnus-newsgroup-processable articles) + (gnus-set-difference articles gnus-newsgroup-processable))) + (defun gnus-uu-mark-by-regexp (regexp &optional unmark) "Set the process mark on articles whose subjects match REGEXP. When called interactively, prompt for REGEXP. Optional UNMARK non-nil means unmark instead of mark." (interactive "sMark (regexp): \nP") - (let ((articles (gnus-uu-find-articles-matching regexp))) - (while articles - (if unmark - (gnus-summary-remove-process-mark (pop articles)) - (gnus-summary-set-process-mark (pop articles)))) - (message "")) + (save-excursion + (let* ((articles (gnus-uu-find-articles-matching regexp)) + (new-marked (gnus-new-processable unmark articles))) + (while articles + (if unmark + (gnus-summary-remove-process-mark (pop articles)) + (gnus-summary-set-process-mark (pop articles)))) + (gnus-message-process-mark unmark new-marked))) (gnus-summary-position-point)) (defun gnus-uu-unmark-by-regexp (regexp) @@ -597,11 +572,12 @@ (defun gnus-uu-mark-series () "Mark the current series with the process mark." (interactive) - (let ((articles (gnus-uu-find-articles-matching))) + (let* ((articles (gnus-uu-find-articles-matching)) + (l (length articles))) (while articles (gnus-summary-set-process-mark (car articles)) (setq articles (cdr articles))) - (message "")) + (message "Marked %d articles" l)) (gnus-summary-position-point)) (defun gnus-uu-mark-region (beg end &optional unmark) @@ -862,9 +838,7 @@ "Date: %s\nFrom: %s\nSubject: %s Digest\n\n" (current-time-string) name name)) (when (and message-forward-as-mime gnus-uu-digest-buffer) - ;; The default part in multipart/digest is message/rfc822. - ;; Subject is a fake head. - (insert "<#part type=text/plain>\nSubject: Topics\n\n")) + (insert "<#part type=message/rfc822>\nSubject: Topics\n\n")) (insert "Topics:\n"))) (when (not (eq in-state 'end)) (setq state (list 'middle)))) @@ -896,7 +870,7 @@ (setq body (buffer-substring (1- (point)) (point-max))) (narrow-to-region (point-min) (point)) (if (not (setq headers gnus-uu-digest-headers)) - (setq sorthead (buffer-substring (point-min) (point-max))) + (setq sorthead (buffer-string)) (while headers (setq headline (car headers)) (setq headers (cdr headers)) @@ -1116,7 +1090,7 @@ (while (re-search-forward "[ \t]+" nil t) (replace-match "[ \t]+" t t)) - (buffer-substring (point-min) (point-max)))) + (buffer-string))) (defun gnus-uu-get-list-of-articles (n) ;; If N is non-nil, the article numbers of the N next articles @@ -1208,11 +1182,12 @@ ;; Expand numbers. (goto-char (point-min)) (while (re-search-forward "[0-9]+" nil t) - (replace-match - (format "%06d" - (string-to-int (buffer-substring - (match-beginning 0) (match-end 0)))))) - (setq string (buffer-substring (point-min) (point-max))) + (ignore-errors + (replace-match + (format "%06d" + (string-to-int (buffer-substring + (match-beginning 0) (match-end 0))))))) + (setq string (buffer-substring 1 (point-max))) (setcar (car string-list) string) (setq string-list (cdr string-list)))) out-list)) @@ -1377,27 +1352,27 @@ (setq process-state (list 'error)) (gnus-message 2 "No begin part at the beginning") (sleep-for 2)) - (setq state 'middle))) - + (setq state 'middle)))) + ;; When there are no result-files, then something must be wrong. - (if result-files - (message "") - (cond - ((not has-been-begin) - (gnus-message 2 "Wrong type file")) - ((memq 'error process-state) - (gnus-message 2 "An error occurred during decoding")) - ((not (or (memq 'ok process-state) - (memq 'end process-state))) - (gnus-message 2 "End of articles reached before end of file"))) - ;; Make unsuccessfully decoded articles unread. - (when gnus-uu-unmark-articles-not-decoded - (while article-series - (gnus-summary-tick-article (pop article-series) t))))) + (if result-files + (message "") + (cond + ((not has-been-begin) + (gnus-message 2 "Wrong type file")) + ((memq 'error process-state) + (gnus-message 2 "An error occurred during decoding")) + ((not (or (memq 'ok process-state) + (memq 'end process-state))) + (gnus-message 2 "End of articles reached before end of file"))) + ;; Make unsuccessfully decoded articles unread. + (when gnus-uu-unmark-articles-not-decoded + (while article-series + (gnus-summary-tick-article (pop article-series) t)))) ;; The original article buffer is hosed, shoot it down. (gnus-kill-buffer gnus-original-article-buffer) - + (setq gnus-current-article nil) result-files)) (defun gnus-uu-grab-view (file) @@ -1463,10 +1438,10 @@ ;; This is the beginning of a uuencoded article. ;; We replace certain characters that could make things messy. (setq gnus-uu-file-name - (let ((nnheader-file-name-translation-alist - '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) - (nnheader-translate-file-chars (match-string 1)))) - (replace-match (concat "begin 644 " gnus-uu-file-name) t t) + (gnus-map-function + mm-file-name-rewrite-functions + (file-name-nondirectory (match-string 1)))) + (replace-match (concat "begin 644 " gnus-uu-file-name) t t) ;; Remove any non gnus-uu-body-line right after start. (forward-line 1) @@ -1655,7 +1630,7 @@ (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) - (if (= 0 (call-process shell-file-name nil + (if (eq 0 (call-process shell-file-name nil (gnus-get-buffer-create gnus-uu-output-buffer-name) nil shell-command-switch command)) (message "") @@ -1820,9 +1795,13 @@ (if (file-directory-p file) (gnus-uu-delete-work-dir file) (gnus-message 9 "Deleting file %s..." file) - (delete-file file)))) - (delete-directory dir))) - (gnus-message 7 "")) + (condition-case err + (delete-file file) + (error (gnus-message 3 "Deleting file %s failed... %s" file err)))))) + (condition-case err + (delete-directory dir) + (error (gnus-message 3 "Deleting directory %s failed... %s" file err)))) + (gnus-message 7 ""))) ;; Initializing @@ -1900,7 +1879,7 @@ (let ((map (make-sparse-keymap))) (set-keymap-parent map (current-local-map)) (use-local-map map)) - (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) + ;;(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) (local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) @@ -1933,8 +1912,8 @@ ;; Encodes with base64 and adds MIME headers (defun gnus-uu-post-encode-mime (path file-name) - (when (zerop (call-process shell-file-name nil t nil shell-command-switch - (format "%s %s -o %s" "mmencode" path file-name))) + (when (eq 0 (call-process shell-file-name nil t nil shell-command-switch + (format "%s %s -o %s" "mmencode" path file-name))) (gnus-uu-post-make-mime file-name "base64") t)) @@ -1959,8 +1938,8 @@ ;; Encodes a file PATH with COMMAND, leaving the result in the ;; current buffer. (defun gnus-uu-post-encode-file (command path file-name) - (= 0 (call-process shell-file-name nil t nil shell-command-switch - (format "%s %s %s" command path file-name)))) + (eq 0 (call-process shell-file-name nil t nil shell-command-switch + (format "%s %s %s" command path file-name)))) (defun gnus-uu-post-news-inews () "Posts the composed news article and encoded file.
--- a/lisp/gnus/gnus-vm.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-vm.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; gnus-vm.el --- vm interface for Gnus -;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Per Persson <pp@gnu.ai.mit.edu>
--- a/lisp/gnus/gnus-win.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus-win.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; gnus-win.el --- window configuration functions for Gnus -;; Copyright (C) 1996, 97, 98, 1999, 2000, 02, 2004 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -29,6 +29,7 @@ (eval-when-compile (require 'cl)) (require 'gnus) +(require 'gnus-util) (defgroup gnus-windows nil "Window configuration." @@ -57,6 +58,13 @@ :group 'gnus-windows :type 'boolean) +(defcustom gnus-use-frames-on-any-display nil + "*If non-nil, frames on all displays will be considered useable by Gnus. +When nil, only frames on the same display as the selected frame will be +used to display Gnus windows." + :group 'gnus-windows + :type 'boolean) + (defvar gnus-buffer-configuration '((group (vertical 1.0 @@ -68,17 +76,6 @@ (if gnus-carpal '(summary-carpal 4)))) (article (cond - ((and gnus-use-picons - (eq gnus-picons-display-where 'picons)) - '(frame 1.0 - (vertical 1.0 - (summary 0.25 point) - (if gnus-carpal '(summary-carpal 4)) - (article 1.0)) - (vertical ((height . 5) (width . 15) - (user-position . t) - (left . -1) (top . 1)) - (picons 1.0)))) (gnus-use-trees '(vertical 1.0 (summary 0.25 point) @@ -126,7 +123,7 @@ (post 1.0 point))) (reply (vertical 1.0 - (article-copy 0.5) + (article 0.5) (message 1.0 point))) (forward (vertical 1.0 @@ -165,7 +162,10 @@ (compose-bounce (vertical 1.0 (article 0.5) - (message 1.0 point)))) + (message 1.0 point))) + (display-term + (vertical 1.0 + ("*display*" 1.0)))) "Window configuration for all possible Gnus buffers. See the Gnus manual for an explanation of the syntax used.") @@ -187,7 +187,6 @@ (mail . gnus-message-buffer) (post-news . gnus-message-buffer) (faq . gnus-faq-buffer) - (picons . gnus-picons-buffer-name) (tree . gnus-tree-buffer) (score-trace . "*Score Trace*") (split-trace . "*Split Trace*") @@ -197,6 +196,11 @@ (draft . gnus-draft-buffer)) "Mapping from short symbols to buffer names or buffer variables.") +(defcustom gnus-configure-windows-hook nil + "*A hook called when configuring windows." + :group 'gnus-windows + :type 'hook) + ;;; Internal variables. (defvar gnus-current-window-configuration nil @@ -301,7 +305,7 @@ ;; The SPLIT might be something that is to be evaled to ;; return a new SPLIT. (while (and (not (assq (car split) gnus-window-to-buffer)) - (gnus-functionp (car split))) + (functionp (car split))) (setq split (eval split))) (let* ((type (car split)) (subs (cddr split)) @@ -364,7 +368,7 @@ (while subs (setq sub (append (pop subs) nil)) (while (and (not (assq (car sub) gnus-window-to-buffer)) - (gnus-functionp (car sub))) + (functionp (car sub))) (setq sub (eval sub))) (when sub (push sub comp-subs) @@ -447,7 +451,7 @@ ;; This is not a `frame' split, so we ignore the ;; other frames. (delete-other-windows) - ;; This is a `frame' split, so we delete all windows + ;; This is a `frame' split, so we delete all windows ;; on all frames. (gnus-delete-windows-in-gnusey-frames)) ;; Just remove some windows. @@ -462,6 +466,7 @@ (switch-to-buffer nntp-server-buffer) (set-buffer nntp-server-buffer)) (gnus-configure-frame split) + (run-hooks 'gnus-configure-windows-hook) (when gnus-window-frame-focus (select-frame (window-frame gnus-window-frame-focus)))))))) @@ -502,7 +507,7 @@ ;; The SPLIT might be something that is to be evaled to ;; return a new SPLIT. (while (and (not (assq (car split) gnus-window-to-buffer)) - (gnus-functionp (car split))) + (functionp (car split))) (setq split (eval split))) (setq type (elt split 0)) @@ -516,7 +521,7 @@ (unless buffer (error "Invalid buffer type: %s" type)) (if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer))) - (setq win (get-buffer-window buf 0))) + (setq win (gnus-get-buffer-window buf t))) (if (memq 'point split) (setq all-visible win)) (setq all-visible nil))) @@ -548,7 +553,29 @@ (if (featurep 'xemacs) (switch-to-buffer nntp-server-buffer) (set-buffer nntp-server-buffer))) - (mapcar (lambda (b) (delete-windows-on b t)) bufs)))) + (mapcar (lambda (b) (delete-windows-on b t)) + (delq lowest-buf bufs))))) + +(eval-and-compile + (cond + ((fboundp 'frames-on-display-list) + (defalias 'gnus-frames-on-display-list 'frames-on-display-list)) + ((and (featurep 'xemacs) (fboundp 'frame-device)) + (defun gnus-frames-on-display-list () + (apply 'filtered-frame-list 'identity (list (frame-device nil))))) + (t + (defalias 'gnus-frames-on-display-list 'frame-list)))) + +(defun gnus-get-buffer-window (buffer &optional frame) + (cond ((and (null gnus-use-frames-on-any-display) + (memq frame '(t 0 visible))) + (car + (let ((frames (gnus-frames-on-display-list))) + (gnus-remove-if (lambda (win) (not (memq (window-frame win) + frames))) + (get-buffer-window-list buffer nil frame))))) + (t + (get-buffer-window buffer frame)))) (provide 'gnus-win)
--- a/lisp/gnus/gnus.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/gnus.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,7 @@ ;;; gnus.el --- a newsreader for GNU Emacs + ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, -;; 1998, 2000, 2001, 2002 Free Software Foundation, Inc. +;; 1998, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -30,13 +31,19 @@ (eval '(run-hooks 'gnus-load-hook)) (eval-when-compile (require 'cl)) +(require 'wid-edit) (require 'mm-util) +(require 'nnheader) (defgroup gnus nil "The coffee-brewing, all singing, all dancing, kitchen sink newsreader." :group 'news :group 'mail) +(defgroup gnus-format nil + "Dealing with formatting issues." + :group 'gnus) + (defgroup gnus-charset nil "Group character set issues." :link '(custom-manual "(gnus)Charsets") @@ -45,6 +52,11 @@ (defgroup gnus-cache nil "Cache interface." + :link '(custom-manual "(gnus)Article Caching") + :group 'gnus) + +(defgroup gnus-registry nil + "Article Registry." :group 'gnus) (defgroup gnus-start nil @@ -132,6 +144,10 @@ :link '(custom-manual "(gnus)Summary Maneuvering") :group 'gnus-summary) +(defgroup gnus-picon nil + "Show pictures of people, domains, and newsgroups." + :group 'gnus-visual) + (defgroup gnus-summary-mail nil "Mail group commands." :link '(custom-manual "(gnus)Mail Group Commands") @@ -207,7 +223,7 @@ ;; Other (defgroup gnus-visual nil - "Options controling the visual fluff." + "Options controlling the visual fluff." :group 'gnus :group 'faces) @@ -232,12 +248,17 @@ "Options related to newsservers and other servers used by Gnus." :group 'gnus) +(defgroup gnus-server-visual nil + "Highlighting and menus in the server buffer." + :group 'gnus-visual + :group 'gnus-server) + (defgroup gnus-message '((message custom-group)) "Composing replies and followups in Gnus." :group 'gnus) (defgroup gnus-meta nil - "Meta variables controling major portions of Gnus. + "Meta variables controlling major portions of Gnus. In general, modifying these variables does not take affect until Gnus is restarted, and sometimes reloaded." :group 'gnus) @@ -256,7 +277,12 @@ :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "5.9.0" +(defgroup gnus-fun nil + "Frivolous Gnus extensions." + :link '(custom-manual "(gnus)Exiting Gnus") + :group 'gnus) + +(defconst gnus-version-number "5.10.6" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) @@ -274,6 +300,12 @@ :group 'gnus-start :type 'boolean) +(unless (fboundp 'gnus-group-remove-excess-properties) + (defalias 'gnus-group-remove-excess-properties 'ignore)) + +(unless (fboundp 'gnus-set-text-properties) + (defalias 'gnus-set-text-properties 'set-text-properties)) + (unless (featurep 'gnus-xmas) (defalias 'gnus-make-overlay 'make-overlay) (defalias 'gnus-delete-overlay 'delete-overlay) @@ -284,11 +316,10 @@ (defalias 'gnus-overlay-end 'overlay-end) (defalias 'gnus-extent-detached-p 'ignore) (defalias 'gnus-extent-start-open 'ignore) - (defalias 'gnus-set-text-properties 'set-text-properties) - (defalias 'gnus-group-remove-excess-properties 'ignore) (defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window) (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names) (defalias 'gnus-character-to-event 'identity) + (defalias 'gnus-assq-delete-all 'assq-delete-all) (defalias 'gnus-add-text-properties 'add-text-properties) (defalias 'gnus-put-text-property 'put-text-property) (defvar gnus-mode-line-image-cache t) @@ -308,7 +339,9 @@ (:type xbm :file "gnus-pointer.xbm" :ascent center)))) gnus-mode-line-image-cache) - 'help-echo "This is Gnus") + 'help-echo (format + "This is %s, %s." + gnus-version (gnus-emacs-version))) str) (list str)) line))) @@ -317,7 +350,8 @@ (defalias 'gnus-deactivate-mark 'deactivate-mark) (defalias 'gnus-window-edges 'window-edges) (defalias 'gnus-key-press-event-p 'numberp) - (defalias 'gnus-decode-rfc1522 'ignore)) + ;;(defalias 'gnus-decode-rfc1522 'ignore) + ) ;; We define these group faces here to avoid the display ;; update forced when creating new faces. @@ -325,10 +359,10 @@ (defface gnus-group-news-1-face '((((class color) (background dark)) - (:foreground "PaleTurquoise" :weight bold)) + (:foreground "PaleTurquoise" :bold t)) (((class color) (background light)) - (:foreground "ForestGreen" :weight bold)) + (:foreground "ForestGreen" :bold t)) (t ())) "Level 1 newsgroup face.") @@ -347,10 +381,10 @@ (defface gnus-group-news-2-face '((((class color) (background dark)) - (:foreground "turquoise" :weight bold)) + (:foreground "turquoise" :bold t)) (((class color) (background light)) - (:foreground "CadetBlue4" :weight bold)) + (:foreground "CadetBlue4" :bold t)) (t ())) "Level 2 newsgroup face.") @@ -369,10 +403,10 @@ (defface gnus-group-news-3-face '((((class color) (background dark)) - (:weight bold)) + (:bold t)) (((class color) (background light)) - (:weight bold)) + (:bold t)) (t ())) "Level 3 newsgroup face.") @@ -391,10 +425,10 @@ (defface gnus-group-news-4-face '((((class color) (background dark)) - (:weight bold)) + (:bold t)) (((class color) (background light)) - (:weight bold)) + (:bold t)) (t ())) "Level 4 newsgroup face.") @@ -413,10 +447,10 @@ (defface gnus-group-news-5-face '((((class color) (background dark)) - (:weight bold)) + (:bold t)) (((class color) (background light)) - (:weight bold)) + (:bold t)) (t ())) "Level 5 newsgroup face.") @@ -435,10 +469,10 @@ (defface gnus-group-news-6-face '((((class color) (background dark)) - (:weight bold)) + (:bold t)) (((class color) (background light)) - (:weight bold)) + (:bold t)) (t ())) "Level 6 newsgroup face.") @@ -457,10 +491,10 @@ (defface gnus-group-news-low-face '((((class color) (background dark)) - (:foreground "DarkTurquoise" :weight bold)) + (:foreground "DarkTurquoise" :bold t)) (((class color) (background light)) - (:foreground "DarkGreen" :weight bold)) + (:foreground "DarkGreen" :bold t)) (t ())) "Low level newsgroup face.") @@ -479,12 +513,12 @@ (defface gnus-group-mail-1-face '((((class color) (background dark)) - (:foreground "aquamarine1" :weight bold)) + (:foreground "aquamarine1" :bold t)) (((class color) (background light)) - (:foreground "DeepPink3" :weight bold)) + (:foreground "DeepPink3" :bold t)) (t - (:weight bold))) + (:bold t))) "Level 1 mailgroup face.") (defface gnus-group-mail-1-empty-face @@ -495,18 +529,18 @@ (background light)) (:foreground "DeepPink3")) (t - (:slant italic :weight bold))) + (:italic t :bold t))) "Level 1 empty mailgroup face.") (defface gnus-group-mail-2-face '((((class color) (background dark)) - (:foreground "aquamarine2" :weight bold)) + (:foreground "aquamarine2" :bold t)) (((class color) (background light)) - (:foreground "HotPink3" :weight bold)) + (:foreground "HotPink3" :bold t)) (t - (:weight bold))) + (:bold t))) "Level 2 mailgroup face.") (defface gnus-group-mail-2-empty-face @@ -517,18 +551,18 @@ (background light)) (:foreground "HotPink3")) (t - (:weight bold))) + (:bold t))) "Level 2 empty mailgroup face.") (defface gnus-group-mail-3-face '((((class color) (background dark)) - (:foreground "aquamarine3" :weight bold)) + (:foreground "aquamarine3" :bold t)) (((class color) (background light)) - (:foreground "magenta4" :weight bold)) + (:foreground "magenta4" :bold t)) (t - (:weight bold))) + (:bold t))) "Level 3 mailgroup face.") (defface gnus-group-mail-3-empty-face @@ -545,12 +579,12 @@ (defface gnus-group-mail-low-face '((((class color) (background dark)) - (:foreground "aquamarine4" :weight bold)) + (:foreground "aquamarine4" :bold t)) (((class color) (background light)) - (:foreground "DeepPink4" :weight bold)) + (:foreground "DeepPink4" :bold t)) (t - (:weight bold))) + (:bold t))) "Low level mailgroup face.") (defface gnus-group-mail-low-empty-face @@ -561,7 +595,7 @@ (background light)) (:foreground "DeepPink4")) (t - (:weight bold))) + (:bold t))) "Low level empty mailgroup face.") ;; Summary mode faces. @@ -578,23 +612,23 @@ (defface gnus-summary-high-ticked-face '((((class color) (background dark)) - (:foreground "pink" :weight bold)) + (:foreground "pink" :bold t)) (((class color) (background light)) - (:foreground "firebrick" :weight bold)) + (:foreground "firebrick" :bold t)) (t - (:weight bold))) + (:bold t))) "Face used for high interest ticked articles.") (defface gnus-summary-low-ticked-face '((((class color) (background dark)) - (:foreground "pink" :slant italic)) + (:foreground "pink" :italic t)) (((class color) (background light)) - (:foreground "firebrick" :slant italic)) + (:foreground "firebrick" :italic t)) (t - (:slant italic))) + (:italic t))) "Face used for low interest ticked articles.") (defface gnus-summary-normal-ticked-face @@ -611,23 +645,23 @@ (defface gnus-summary-high-ancient-face '((((class color) (background dark)) - (:foreground "SkyBlue" :weight bold)) + (:foreground "SkyBlue" :bold t)) (((class color) (background light)) - (:foreground "RoyalBlue" :weight bold)) + (:foreground "RoyalBlue" :bold t)) (t - (:weight bold))) + (:bold t))) "Face used for high interest ancient articles.") (defface gnus-summary-low-ancient-face '((((class color) (background dark)) - (:foreground "SkyBlue" :slant italic)) + (:foreground "SkyBlue" :italic t)) (((class color) (background light)) - (:foreground "RoyalBlue" :slant italic)) + (:foreground "RoyalBlue" :italic t)) (t - (:slant italic))) + (:italic t))) "Face used for low interest ancient articles.") (defface gnus-summary-normal-ancient-face @@ -641,14 +675,41 @@ ())) "Face used for normal interest ancient articles.") +(defface gnus-summary-high-undownloaded-face + '((((class color) + (background light)) + (:bold t :foreground "cyan4")) + (((class color) (background dark)) + (:bold t :foreground "LightGray")) + (t (:inverse-video t :bold t))) + "Face used for high interest uncached articles.") + +(defface gnus-summary-low-undownloaded-face + '((((class color) + (background light)) + (:italic t :foreground "cyan4" :bold nil)) + (((class color) (background dark)) + (:italic t :foreground "LightGray" :bold nil)) + (t (:inverse-video t :italic t))) + "Face used for low interest uncached articles.") + +(defface gnus-summary-normal-undownloaded-face + '((((class color) + (background light)) + (:foreground "cyan4" :bold nil)) + (((class color) (background dark)) + (:foreground "LightGray" :bold nil)) + (t (:inverse-video t))) + "Face used for normal interest uncached articles.") + (defface gnus-summary-high-unread-face '((t - (:weight bold))) + (:bold t))) "Face used for high interest unread articles.") (defface gnus-summary-low-unread-face '((t - (:slant italic))) + (:italic t))) "Face used for low interest unread articles.") (defface gnus-summary-normal-unread-face @@ -660,26 +721,26 @@ '((((class color) (background dark)) (:foreground "PaleGreen" - :weight bold)) + :bold t)) (((class color) (background light)) (:foreground "DarkGreen" - :weight bold)) + :bold t)) (t - (:weight bold))) + (:bold t))) "Face used for high interest read articles.") (defface gnus-summary-low-read-face '((((class color) (background dark)) (:foreground "PaleGreen" - :slant italic)) + :italic t)) (((class color) (background light)) (:foreground "DarkGreen" - :slant italic)) + :italic t)) (t - (:slant italic))) + (:italic t))) "Face used for low interest read articles.") (defface gnus-summary-normal-read-face @@ -709,6 +770,13 @@ "Add the current buffer to the list of Gnus buffers." (push (current-buffer) gnus-buffers)) +(defmacro gnus-kill-buffer (buffer) + "Kill BUFFER and remove from the list of Gnus buffers." + `(let ((buf ,buffer)) + (when (gnus-buffer-exists-p buf) + (setq gnus-buffers (delete (get-buffer buf) gnus-buffers)) + (kill-buffer buf)))) + (defun gnus-buffers () "Return a list of live Gnus buffers." (while (and gnus-buffers @@ -731,13 +799,13 @@ (defface gnus-splash-face '((((class color) (background dark)) - (:foreground "Brown")) + (:foreground "#888888")) (((class color) (background light)) - (:foreground "Brown")) + (:foreground "#888888")) (t ())) - "Face of the splash screen.") + "Face for the splash screen.") (defun gnus-splash () (save-excursion @@ -765,6 +833,39 @@ (defvar gnus-simple-splash nil) +;;(format "%02x%02x%02x" 114 66 20) "724214" + +(defvar gnus-logo-color-alist + '((flame "#cc3300" "#ff2200") + (pine "#c0cc93" "#f8ffb8") + (moss "#a1cc93" "#d2ffb8") + (irish "#04cc90" "#05ff97") + (sky "#049acc" "#05deff") + (tin "#6886cc" "#82b6ff") + (velvet "#7c68cc" "#8c82ff") + (grape "#b264cc" "#cf7df") + (labia "#cc64c2" "#fd7dff") + (berry "#cc6485" "#ff7db5") + (dino "#724214" "#1e3f03") + (oort "#cccccc" "#888888") + (storm "#666699" "#99ccff") + (pdino "#9999cc" "#99ccff") + (purp "#9999cc" "#666699") + (no "#000000" "#ff0000") + (neutral "#b4b4b4" "#878787") + (september "#bf9900" "#ffcc00")) + "Color alist used for the Gnus logo.") + +(defcustom gnus-logo-color-style 'oort + "*Color styles used for the Gnus logo." + :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) + gnus-logo-color-alist)) + :group 'gnus-xmas) + +(defvar gnus-logo-colors + (cdr (assq gnus-logo-color-style gnus-logo-color-alist)) + "Colors used for the Gnus logo.") + (defun gnus-group-startup-message (&optional x y) "Insert startup message in current buffer." ;; Insert the message. @@ -773,16 +874,22 @@ ((and (fboundp 'find-image) (display-graphic-p) - (let ((image (find-image - `((:type xpm :file "gnus.xpm") - (:type pbm :file "gnus.pbm" - ;; Account for the pbm's blackground. - :background ,(face-foreground 'gnus-splash-face) - :foreground ,(face-background 'default)) - (:type xbm :file "gnus.xbm" - ;; Account for the xbm's blackground. - :background ,(face-foreground 'gnus-splash-face) - :foreground ,(face-background 'default)))))) + (let* ((data-directory (nnheader-find-etc-directory "gnus")) + (image (find-image + `((:type xpm :file "gnus.xpm" + :color-symbols + (("thing" . ,(car gnus-logo-colors)) + ("shadow" . ,(cadr gnus-logo-colors)) + ("oort" . "#eeeeee") + ("background" . ,(face-background 'default)))) + (:type pbm :file "gnus.pbm" + ;; Account for the pbm's blackground. + :background ,(face-foreground 'gnus-splash-face) + :foreground ,(face-background 'default)) + (:type xbm :file "gnus.xbm" + ;; Account for the xbm's blackground. + :background ,(face-foreground 'gnus-splash-face) + :foreground ,(face-background 'default)))))) (when image (let ((size (image-size image))) (insert-char ?\n (max 0 (round (- (window-height) @@ -843,6 +950,103 @@ (require 'gnus-util) (require 'nnheader) +(defcustom gnus-parameters nil + "Alist of group parameters. + +For example: + ((\"mail\\\\..*\" (gnus-show-threads nil) + (gnus-use-scoring nil) + (gnus-summary-line-format + \"%U%R%z%I%(%[%d:%ub%-23,23f%]%) %s\\n\") + (gcc-self . t) + (display . all)) + (\"mail\\\\.me\" (gnus-use-scoring t)) + (\"list\\\\..*\" (total-expire . t) + (broken-reply-to . t)))" + :group 'gnus-group-various + :type '(repeat (cons regexp + (repeat sexp)))) + +(defvar gnus-group-parameters-more nil) + +(defmacro gnus-define-group-parameter (param &rest rest) + "Define a group parameter PARAM. +REST is a plist of following: +:type One of `bool', `list' or nil. +:function The name of the function. +:function-document The documentation of the function. +:parameter-type The type for customizing the parameter. +:parameter-document The documentation for the parameter. +:variable The name of the variable. +:variable-document The documentation for the variable. +:variable-group The group for customizing the variable. +:variable-type The type for customizing the variable. +:variable-default The default value of the variable." + (let* ((type (plist-get rest :type)) + (parameter-type (plist-get rest :parameter-type)) + (parameter-document (plist-get rest :parameter-document)) + (function (or (plist-get rest :function) + (intern (format "gnus-parameter-%s" param)))) + (function-document (or (plist-get rest :function-document) "")) + (variable (or (plist-get rest :variable) + (intern (format "gnus-parameter-%s-alist" param)))) + (variable-document (or (plist-get rest :variable-document) "")) + (variable-group (plist-get rest :variable-group)) + (variable-type (or (plist-get rest :variable-type) + `(quote (repeat + (list (regexp :tag "Group") + ,(car (cdr parameter-type))))))) + (variable-default (plist-get rest :variable-default))) + (list + 'progn + `(defcustom ,variable ,variable-default + ,variable-document + :group 'gnus-group-parameter + :group ',variable-group + :type ,variable-type) + `(setq gnus-group-parameters-more + (delq (assq ',param gnus-group-parameters-more) + gnus-group-parameters-more)) + `(add-to-list 'gnus-group-parameters-more + (list ',param + ,parameter-type + ,parameter-document)) + (if (eq type 'bool) + `(defun ,function (name) + ,function-document + (let ((params (gnus-group-find-parameter name)) + val) + (cond + ((memq ',param params) + t) + ((setq val (assq ',param params)) + (cdr val)) + ((stringp ,variable) + (string-match ,variable name)) + (,variable + (let ((alist ,variable) + elem value) + (while (setq elem (pop alist)) + (when (and name + (string-match (car elem) name)) + (setq alist nil + value (cdr elem)))) + (if (consp value) (car value) value)))))) + `(defun ,function (name) + ,function-document + (and name + (or (gnus-group-find-parameter name ',param ,(and type t)) + (let ((alist ,variable) + elem value) + (while (setq elem (pop alist)) + (when (and name + (string-match (car elem) name)) + (setq alist nil + value (cdr elem)))) + ,(if type + 'value + '(if (consp value) (car value) value)))))))))) + (defcustom gnus-home-directory "~/" "Directory variable that specifies the \"home\" directory. All other Gnus file and directory variables are initialized from this variable." @@ -891,21 +1095,17 @@ :group 'gnus-server :type 'file) -;; This function is used to check both the environment variable -;; NNTPSERVER and the /etc/nntpserver file to see whether one can find -;; an nntp server name default. (defun gnus-getenv-nntpserver () + "Find default nntp server. +Check the NNTPSERVER environment variable and the +`gnus-nntpserver-file' file." (or (getenv "NNTPSERVER") (and (file-readable-p gnus-nntpserver-file) - (save-excursion - (set-buffer (gnus-get-buffer-create " *gnus nntp*")) + (with-temp-buffer (insert-file-contents gnus-nntpserver-file) (let ((name (buffer-string))) - (prog1 - (if (string-match "\\'[ \t\n]*$" name) - nil - name) - (kill-buffer (current-buffer)))))))) + (unless (string-match "\\`[ \t\n]*$" name) + name)))))) (defcustom gnus-select-method (condition-case nil @@ -926,8 +1126,8 @@ This variable should be a list, where the first element is how the news is to be fetched, the second is the address. -For instance, if you want to get your news via NNTP from -\"flab.flab.edu\", you could say: +For instance, if you want to get your news via \"flab.flab.edu\" using +NNTP, you could say: \(setq gnus-select-method '(nntp \"flab.flab.edu\")) @@ -942,26 +1142,13 @@ :group 'gnus-server :type 'gnus-select-method) -(defcustom gnus-message-archive-method - (progn - ;; Don't require it at top level to avoid circularity. - (require 'message) - `(nnfolder - "archive" - (nnfolder-directory ,(nnheader-concat message-directory "archive")) - (nnfolder-active-file - ,(nnheader-concat message-directory "archive/active")) - (nnfolder-get-new-mail nil) - (nnfolder-inhibit-expiry t))) +(defcustom gnus-message-archive-method "archive" "*Method used for archiving messages you've sent. -This should be a mail method. - -It's probably not very effective to change this variable once you've -run Gnus once. After doing that, you must edit this server from the -server buffer." +This should be a mail method." :group 'gnus-server :group 'gnus-message - :type 'gnus-select-method) + :type '(choice (const :tag "Default archive method" "archive") + gnus-select-method)) (defcustom gnus-message-archive-group nil "*Name of the group in which to save the messages you've written. @@ -974,9 +1161,9 @@ write in another group, you could say something like: \(setq gnus-message-archive-group - '((if (message-news-p) - \"misc-news\" - \"misc-mail\"))) + '((if (message-news-p) + \"misc-news\" + \"misc-mail\"))) Normally the group names returned by this variable should be unprefixed -- which implicitly means \"store on the archive server\". @@ -1009,7 +1196,7 @@ This is a list where each element is a complete select method (see `gnus-select-method'). -If, for instance, you want to read your mail with the nnml backend, +If, for instance, you want to read your mail with the nnml back end, you could set this variable: \(setq gnus-secondary-select-methods '((nnml \"\")))" @@ -1050,27 +1237,28 @@ list, Gnus will try all the methods in the list until it finds a match." :group 'gnus-server :type '(choice (const :tag "default" nil) - (const :tag "DejaNews" (nnweb "refer" (nnweb-type dejanews))) + (const current) + (const :tag "Google" (nnweb "refer" (nnweb-type google))) gnus-select-method (repeat :menu-tag "Try multiple" :tag "Multiple" - :value (current (nnweb "refer" (nnweb-type dejanews))) + :value (current (nnweb "refer" (nnweb-type google))) (choice :tag "Method" (const current) - (const :tag "DejaNews" - (nnweb "refer" (nnweb-type dejanews))) + (const :tag "Google" + (nnweb "refer" (nnweb-type google))) gnus-select-method)))) (defcustom gnus-group-faq-directory '("/ftp@mirrors.aol.com:/pub/rtfm/usenet/" - "/ftp@sunsite.auc.dk:/pub/usenet/" "/ftp@sunsite.doc.ic.ac.uk:/pub/usenet/news-faqs/" "/ftp@src.doc.ic.ac.uk:/usenet/news-FAQS/" "/ftp@ftp.seas.gwu.edu:/pub/rtfm/" + "/ftp@ftp.pasteur.fr:/pub/FAQ/" "/ftp@rtfm.mit.edu:/pub/usenet/" "/ftp@ftp.uni-paderborn.de:/pub/FAQ/" "/ftp@ftp.sunet.se:/pub/usenet/" - "/ftp@nctuccca.edu.tw:/USENET/FAQ/" + "/ftp@nctuccca.nctu.edu.tw:/pub/Documents/rtfm/usenet-by-group/" "/ftp@hwarang.postech.ac.kr:/pub/usenet/" "/ftp@ftp.hk.super.net:/mirror/faqs/") "*Directory where the group FAQs are stored. @@ -1091,16 +1279,50 @@ ftp.seas.gwu.edu /pub/rtfm rtfm.mit.edu /pub/usenet Europe: ftp.uni-paderborn.de /pub/FAQ - src.doc.ic.ac.uk /usenet/news-FAQS + src.doc.ic.ac.uk /usenet/news-FAQS ftp.sunet.se /pub/usenet - sunsite.auc.dk /pub/usenet - Asia: nctuccca.edu.tw /USENET/FAQ + ftp.pasteur.fr /pub/FAQ + Asia: nctuccca.nctu.edu.tw /pub/Documents/rtfm/usenet-by-group/ hwarang.postech.ac.kr /pub/usenet ftp.hk.super.net /mirror/faqs" :group 'gnus-group-various :type '(choice directory (repeat directory))) +(defcustom gnus-group-charter-alist + '(("no" . (concat "http://no.news-admin.org/charter/" name ".txt")) + ("de" . (concat "http://purl.net/charta/" name ".html")) + ("dk" . (concat "http://www.usenet.dk/grupper.pl?get=" name)) + ("england" . (concat "http://england.news-admin.org/charters/" name)) + ("fr" . (concat "http://www.usenet-fr.net/fur/chartes/" name ".html")) + ("europa" . (concat "http://www.europa.usenet.eu.org/chartas/charta-en-" + (gnus-replace-in-string name "europa\\." "") ".html")) + ("nl" . (concat "http://www.xs4all.nl/~sister/usenet/charters/" name)) + ("aus" . (concat "http://aus.news-admin.org/groupinfo.cgi/" name)) + ("pl" . (concat "http://www.usenet.pl/opisy/" name)) + ("ch" . (concat "http://www.use-net.ch/Usenet/charter.html#" name)) + ("at" . (concat "http://www.usenet.at/chartas/" name "/charta")) + ("uk" . (concat "http://www.usenet.org.uk/" name ".html")) + ("dfw" . (concat "http://www.cirr.com/dfw/charters/" name ".html")) + ("se" . (concat "http://www.usenet-se.net/Reglementen/" + (gnus-replace-in-string name "\\." "_") ".html")) + ("milw" . (concat "http://usenet.mil.wi.us/" + (gnus-replace-in-string name "milw\\." "") "-charter")) + ("ca" . (concat "http://www.sbay.org/ca/charter-" name ".html")) + ("netins" . (concat "http://www.netins.net/usenet/charter/" + (gnus-replace-in-string name "\\." "-") "-charter.html"))) + "*An alist of (HIERARCHY . FORM) pairs used to construct the URL of a charter. +When FORM is evaluated `name' is bound to the name of the group." + :group 'gnus-group-various + :type '(repeat (cons (string :tag "Hierarchy") (sexp :tag "Form")))) + +(defcustom gnus-group-fetch-control-use-browse-url nil + "*Non-nil means that control messages are displayed using `browse-url'. +Otherwise they are fetched with ange-ftp and displayed in an ephemeral +group." + :group 'gnus-group-various + :type 'boolean) + (defcustom gnus-use-cross-reference t "*Non-nil means that cross referenced articles will be marked as read. If nil, ignore cross references. If t, mark articles as read in @@ -1121,9 +1343,11 @@ (defcustom gnus-large-newsgroup 200 "*The number of articles which indicates a large newsgroup. If the number of articles in a newsgroup is greater than this value, -confirmation is required for selecting the newsgroup." +confirmation is required for selecting the newsgroup. +If it is nil, no confirmation is required." :group 'gnus-group-select - :type 'integer) + :type '(choice (const :tag "No limit" nil) + integer)) (defcustom gnus-use-long-file-name (not (memq system-type '(usg-unix-v xenix))) "*Non-nil means that the default name of a file to save articles in is the group name. @@ -1139,7 +1363,14 @@ type you're using. On `usg-unix-v' and `xenix' this variable defaults to nil while on all other systems it defaults to t." :group 'gnus-start - :type 'boolean) + :type '(radio (sexp :format "Non-nil\n" + :match (lambda (widget value) + (and value (not (listp value)))) + :value t) + (const nil) + (checklist (const :format "%v " not-score) + (const :format "%v " not-save) + (const not-kill)))) (defcustom gnus-kill-files-directory gnus-directory "*Name of the directory where kill files will be stored (default \"~/News\")." @@ -1188,7 +1419,7 @@ :group 'gnus-meta :type 'boolean) -(defcustom gnus-keep-backlog nil +(defcustom gnus-keep-backlog 20 "*If non-nil, Gnus will keep read articles for later re-retrieval. If it is a number N, then Gnus will only keep the last N articles read. If it is neither nil nor a number, Gnus will keep all read @@ -1214,11 +1445,6 @@ :group 'gnus-meta :type 'boolean) -(defcustom gnus-use-picons nil - "*If non-nil, display picons in a frame of their own." - :group 'gnus-meta - :type 'boolean) - (defcustom gnus-summary-prepare-exit-hook '(gnus-summary-expire-articles) "*A hook called when preparing to exit from the summary buffer. @@ -1227,7 +1453,7 @@ :type 'hook) (defcustom gnus-novice-user t - "*Non-nil means that you are a usenet novice. + "*Non-nil means that you are a Usenet novice. If non-nil, verbose messages may be displayed and confirmations may be required." :group 'gnus-meta @@ -1267,7 +1493,7 @@ :type 'boolean) (defcustom gnus-shell-command-separator ";" - "String used to separate to shell commands." + "String used to separate shell commands." :group 'gnus-files :type 'string) @@ -1276,7 +1502,7 @@ ("nnspool" post address) ("nnvirtual" post-mail virtual prompt-address) ("nnmbox" mail respool address) - ("nnml" mail respool address) + ("nnml" post-mail respool address) ("nnmh" mail respool address) ("nndir" post-mail prompt-address physical-address) ("nneething" none address prompt-address physical-address) @@ -1288,12 +1514,17 @@ ("nnfolder" mail respool address) ("nngateway" post-mail address prompt-address physical-address) ("nnweb" none) + ("nngoogle" post) ("nnslashdot" post) ("nnultimate" none) + ("nnrss" none) + ("nnwfm" none) ("nnwarchive" none) ("nnlistserv" none) ("nnagent" post-mail) - ("nnimap" post-mail address prompt-address physical-address)) + ("nnimap" post-mail address prompt-address physical-address) + ("nnmaildir" mail respool address) + ("nnnil" none)) "*An alist of valid select methods. The first element of each list lists should be a string with the name of the select method. The other elements may be the category of @@ -1332,8 +1563,7 @@ :inline t (list :format "%v" variable - (sexp :tag "Value")))) - )) + (sexp :tag "Value")))))) (gnus-redefine-select-method-widget) @@ -1353,29 +1583,582 @@ (defcustom gnus-mode-non-string-length nil "*Max length of mode-line non-string contents. If this is nil, Gnus will take space as is needed, leaving the rest -of the modeline intact. Note that the default of nil is unlikely +of the mode line intact. Note that the default of nil is unlikely to be desirable; see the manual for further details." :group 'gnus-various :type '(choice (const nil) integer)) -(defcustom gnus-auto-expirable-newsgroups nil - "*Groups in which to automatically mark read articles as expirable. +;; There should be special validation for this. +(define-widget 'gnus-email-address 'string + "An email address.") + +(gnus-define-group-parameter + to-address + :function-document + "Return GROUP's to-address." + :variable-document + "*Alist of group regexps and correspondent to-addresses." + :parameter-type '(gnus-email-address :tag "To Address") + :parameter-document "\ +This will be used when doing followups and posts. + +This is primarily useful in mail groups that represent closed +mailing lists--mailing lists where it's expected that everybody that +writes to the mailing list is subscribed to it. Since using this +parameter ensures that the mail only goes to the mailing list itself, +it means that members won't receive two copies of your followups. + +Using `to-address' will actually work whether the group is foreign or +not. Let's say there's a group on the server that is called +`fa.4ad-l'. This is a real newsgroup, but the server has gotten the +articles from a mail-to-news gateway. Posting directly to this group +is therefore impossible--you have to send mail to the mailing list +address instead. + +The gnus-group-split mail splitting mechanism will behave as if this +address was listed in gnus-group-split Addresses (see below).") + +(gnus-define-group-parameter + to-list + :function-document + "Return GROUP's to-list." + :variable-document + "*Alist of group regexps and correspondent to-lists." + :parameter-type '(gnus-email-address :tag "To List") + :parameter-document "\ +This address will be used when doing a `a' in the group. + +It is totally ignored when doing a followup--except that if it is +present in a news group, you'll get mail group semantics when doing +`f'. + +The gnus-group-split mail splitting mechanism will behave as if this +address was listed in gnus-group-split Addresses (see below).") + +(gnus-define-group-parameter + subscribed + :type bool + :function-document + "Return GROUP's subscription status." + :variable-document + "*Groups which are automatically considered subscribed." + :parameter-type '(const :tag "Subscribed" t) + :parameter-document "\ +Gnus assumed that you are subscribed to the To/List address. + +When constructing a list of subscribed groups using +`gnus-find-subscribed-addresses', Gnus includes the To address given +above, or the list address (if the To address has not been set).") + +(gnus-define-group-parameter + auto-expire + :type bool + :function gnus-group-auto-expirable-p + :function-document + "Check whether GROUP is auto-expirable or not." + :variable gnus-auto-expirable-newsgroups + :variable-default nil + :variable-document + "*Groups in which to automatically mark read articles as expirable. If non-nil, this should be a regexp that should match all groups in which to perform auto-expiry. This only makes sense for mail groups." - :group 'nnmail-expire - :type '(choice (const nil) - regexp)) - -(defcustom gnus-total-expirable-newsgroups nil - "*Groups in which to perform expiry of all read articles. + :variable-group nnmail-expire + :variable-type '(choice (const nil) + regexp) + :parameter-type '(const :tag "Automatic Expire" t) + :parameter-document + "All articles that are read will be marked as expirable.") + +(gnus-define-group-parameter + total-expire + :type bool + :function gnus-group-total-expirable-p + :function-document + "Check whether GROUP is total-expirable or not." + :variable gnus-total-expirable-newsgroups + :variable-default nil + :variable-document + "*Groups in which to perform expiry of all read articles. Use with extreme caution. All groups that match this regexp will be expiring - which means that all read articles will be deleted after \(say) one week. (This only goes for mail groups and the like, of course.)" - :group 'nnmail-expire - :type '(choice (const nil) - regexp)) + :variable-group nnmail-expire + :variable-type '(choice (const nil) + regexp) + :parameter-type '(const :tag "Total Expire" t) + :parameter-document + "All read articles will be put through the expiry process + +This happens even if they are not marked as expirable. +Use with caution.") + +(gnus-define-group-parameter + charset + :function-document + "Return the default charset of GROUP." + :variable gnus-group-charset-alist + :variable-default + '(("\\(^\\|:\\)hk\\>\\|\\(^\\|:\\)tw\\>\\|\\<big5\\>" cn-big5) + ("\\(^\\|:\\)cn\\>\\|\\<chinese\\>" cn-gb-2312) + ("\\(^\\|:\\)fj\\>\\|\\(^\\|:\\)japan\\>" iso-2022-jp-2) + ("\\(^\\|:\\)tnn\\>\\|\\(^\\|:\\)pin\\>\\|\\(^\\|:\\)sci.lang.japan" iso-2022-7bit) + ("\\(^\\|:\\)relcom\\>" koi8-r) + ("\\(^\\|:\\)fido7\\>" koi8-r) + ("\\(^\\|:\\)\\(cz\\|hun\\|pl\\|sk\\|hr\\)\\>" iso-8859-2) + ("\\(^\\|:\\)israel\\>" iso-8859-1) + ("\\(^\\|:\\)han\\>" euc-kr) + ("\\(^\\|:\\)alt.chinese.text.big5\\>" chinese-big5) + ("\\(^\\|:\\)soc.culture.vietnamese\\>" vietnamese-viqr) + ("\\(^\\|:\\)\\(comp\\|rec\\|alt\\|sci\\|soc\\|news\\|gnu\\|bofh\\)\\>" iso-8859-1)) + :variable-document + "Alist of regexps (to match group names) and default charsets to be used when reading." + :variable-group gnus-charset + :variable-type '(repeat (list (regexp :tag "Group") + (symbol :tag "Charset"))) + :parameter-type '(symbol :tag "Charset") + :parameter-document "\ +The default charset to use in the group.") + +(gnus-define-group-parameter + post-method + :type list + :function-document + "Return a posting method for GROUP." + :variable gnus-post-method-alist + :variable-document + "Alist of regexps (to match group names) and method to be used when +posting an article." + :variable-group gnus-group-foreign + :parameter-type + '(choice :tag "Posting Method" + (const :tag "Use native server" native) + (const :tag "Use current server" current) + (list :convert-widget + (lambda (widget) + (list 'sexp :tag "Methods" + :value gnus-select-method)))) + :parameter-document + "Posting method for this group.") + +(gnus-define-group-parameter + large-newsgroup-initial + :type integer + :function-document + "Return GROUP's initial input of the number of articles." + :variable-document + "*Alist of group regexps and its initial input of the number of articles." + :parameter-type '(choice :tag "Initial Input for Large Newsgroup" + (const :tag "All" nil) + (integer)) + :parameter-document "\ + +This number will be prompted as the initial value of the number of +articles to list when the group is a large newsgroup (see +`gnus-large-newsgroup'). If it is nil, the default value is the +total number of articles in the group.") + +;; The Gnus registry's ignored groups +(gnus-define-group-parameter + registry-ignore + :type list + :function-document + "Whether this group should be ignored by the registry." + :variable gnus-registry-ignored-groups + :variable-default nil + :variable-document + "*Groups in which the registry should be turned off." + :variable-group gnus-registry + :variable-type '(repeat + (list + (regexp :tag "Group Name Regular Expression") + (boolean :tag "Ignored"))) + + :parameter-type '(boolean :tag "Group Ignored by the Registry") + :parameter-document + "Whether the Gnus Registry should ignore this group.") + +;; group parameters for spam processing added by Ted Zlatanov <tzz@lifelogs.com> +(defcustom gnus-install-group-spam-parameters t + "*Disable the group parameters for spam detection. +Enable if `G c' in XEmacs is giving you trouble, and make sure to submit a bug report." + :type 'boolean + :group 'gnus-start) + +(when gnus-install-group-spam-parameters + (defvar gnus-group-spam-classification-spam t + "Spam group classification (requires spam.el). +This group contains spam messages. On summary entry, unread messages +will be marked as spam. On summary exit, the specified spam +processors will be invoked on spam-marked messages, then those +messages will be expired, so the spam processor will only see a +spam-marked message once.") + + (defvar gnus-group-spam-classification-ham 'ask + "The ham value for the spam group parameter (requires spam.el). +On summary exit, the specified ham processors will be invoked on +ham-marked messages. Exercise caution, since the ham processor will +see the same message more than once because there is no ham message +registry.") + + (gnus-define-group-parameter + spam-contents + :type list + :function-document + "The spam type (spam, ham, or neither) of the group." + :variable gnus-spam-newsgroup-contents + :variable-default nil + :variable-document + "*Groups in which to automatically mark new articles as spam on +summary entry. If non-nil, this should be a list of group name +regexps that should match all groups in which to do automatic spam +tagging, associated with a classification (spam, ham, or neither). +This only makes sense for mail groups." + :variable-group spam + :variable-type '(repeat + (list :tag "Group contents spam/ham classification" + (regexp :tag "Group") + (choice + (variable-item gnus-group-spam-classification-spam) + (variable-item gnus-group-spam-classification-ham) + (const :tag "Unclassified" nil)))) + + :parameter-type '(list :tag "Group contents spam/ham classification" + (choice :tag "Group contents classification for spam sorting" + (variable-item gnus-group-spam-classification-spam) + (variable-item gnus-group-spam-classification-ham) + (const :tag "Unclassified" nil))) + :parameter-document + "The spam classification (spam, ham, or neither) of this group. +When a spam group is entered, all unread articles are marked as spam.") + + (defvar gnus-group-spam-exit-processor-ifile "ifile" + "OBSOLETE: The ifile summary exit spam processor.") + + (defvar gnus-group-spam-exit-processor-stat "stat" + "OBSOLETE: The spam-stat summary exit spam processor.") + + (defvar gnus-group-spam-exit-processor-bogofilter "bogofilter" + "OBSOLETE: The Bogofilter summary exit spam processor.") + + (defvar gnus-group-spam-exit-processor-blacklist "blacklist" + "OBSOLETE: The Blacklist summary exit spam processor.") + + (defvar gnus-group-spam-exit-processor-report-gmane "report-gmane" + "OBSOLETE: The Gmane reporting summary exit spam processor. +Only applicable to NNTP groups with articles from Gmane. See spam-report.el") + + (defvar gnus-group-spam-exit-processor-spamoracle "spamoracle-spam" + "OBSOLETE: The spamoracle summary exit spam processor.") + + (defvar gnus-group-ham-exit-processor-ifile "ifile-ham" + "OBSOLETE: The ifile summary exit ham processor. +Only applicable to non-spam (unclassified and ham) groups.") + + (defvar gnus-group-ham-exit-processor-bogofilter "bogofilter-ham" + "OBSOLETE: The Bogofilter summary exit ham processor. +Only applicable to non-spam (unclassified and ham) groups.") + + (defvar gnus-group-ham-exit-processor-stat "stat-ham" + "OBSOLETE: The spam-stat summary exit ham processor. +Only applicable to non-spam (unclassified and ham) groups.") + + (defvar gnus-group-ham-exit-processor-whitelist "whitelist" + "OBSOLETE: The whitelist summary exit ham processor. +Only applicable to non-spam (unclassified and ham) groups.") + + (defvar gnus-group-ham-exit-processor-BBDB "bbdb" + "OBSOLETE: The BBDB summary exit ham processor. +Only applicable to non-spam (unclassified and ham) groups.") + + (defvar gnus-group-ham-exit-processor-copy "copy" + "OBSOLETE: The ham copy exit ham processor. +Only applicable to non-spam (unclassified and ham) groups.") + + (defvar gnus-group-ham-exit-processor-spamoracle "spamoracle-ham" + "OBSOLETE: The spamoracle summary exit ham processor. +Only applicable to non-spam (unclassified and ham) groups.") + + (gnus-define-group-parameter + spam-process + :type list + :parameter-type + '(choice + :tag "Spam Summary Exit Processor" + :value nil + (list :tag "Spam Summary Exit Processor Choices" + (set + (variable-item gnus-group-spam-exit-processor-ifile) + (variable-item gnus-group-spam-exit-processor-stat) + (variable-item gnus-group-spam-exit-processor-bogofilter) + (variable-item gnus-group-spam-exit-processor-blacklist) + (variable-item gnus-group-spam-exit-processor-spamoracle) + (variable-item gnus-group-spam-exit-processor-report-gmane) + (variable-item gnus-group-ham-exit-processor-bogofilter) + (variable-item gnus-group-ham-exit-processor-ifile) + (variable-item gnus-group-ham-exit-processor-stat) + (variable-item gnus-group-ham-exit-processor-whitelist) + (variable-item gnus-group-ham-exit-processor-BBDB) + (variable-item gnus-group-ham-exit-processor-spamoracle) + (variable-item gnus-group-ham-exit-processor-copy) + (const :tag "Spam: Gmane Report" (spam spam-use-gmane)) + (const :tag "Spam: Bogofilter" (spam spam-use-bogofilter)) + (const :tag "Spam: Blacklist" (spam spam-use-blacklist)) + (const :tag "Spam: ifile" (spam spam-use-ifile)) + (const :tag "Spam: Spam-stat" (spam spam-use-stat)) + (const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle)) + (const :tag "Ham: ifile" (ham spam-use-ifile)) + (const :tag "Ham: Bogofilter" (ham spam-use-bogofilter)) + (const :tag "Ham: Spam-stat" (ham spam-use-stat)) + (const :tag "Ham: Whitelist" (ham spam-use-whitelist)) + (const :tag "Ham: BBDB" (ham spam-use-BBDB)) + (const :tag "Ham: Copy" (ham spam-use-ham-copy)) + (const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle))))) + :function-document + "Which spam or ham processors will be applied when the summary is exited." + :variable gnus-spam-process-newsgroups + :variable-default nil + :variable-document + "*Groups in which to automatically process spam or ham articles with +a backend on summary exit. If non-nil, this should be a list of group +name regexps that should match all groups in which to do automatic +spam processing, associated with the appropriate processor." + :variable-group spam + :variable-type + '(repeat :tag "Spam/Ham Processors" + (list :tag "Spam Summary Exit Processor Choices" + (regexp :tag "Group Regexp") + (set + :tag "Spam/Ham Summary Exit Processor" + (variable-item gnus-group-spam-exit-processor-ifile) + (variable-item gnus-group-spam-exit-processor-stat) + (variable-item gnus-group-spam-exit-processor-bogofilter) + (variable-item gnus-group-spam-exit-processor-blacklist) + (variable-item gnus-group-spam-exit-processor-spamoracle) + (variable-item gnus-group-spam-exit-processor-report-gmane) + (variable-item gnus-group-ham-exit-processor-bogofilter) + (variable-item gnus-group-ham-exit-processor-ifile) + (variable-item gnus-group-ham-exit-processor-stat) + (variable-item gnus-group-ham-exit-processor-whitelist) + (variable-item gnus-group-ham-exit-processor-BBDB) + (variable-item gnus-group-ham-exit-processor-spamoracle) + (variable-item gnus-group-ham-exit-processor-copy) + (const :tag "Spam: Gmane Report" (spam spam-use-gmane)) + (const :tag "Spam: Bogofilter" (spam spam-use-bogofilter)) + (const :tag "Spam: Blacklist" (spam spam-use-blacklist)) + (const :tag "Spam: ifile" (spam spam-use-ifile)) + (const :tag "Spam: Spam-stat" (spam spam-use-stat)) + (const :tag "Spam: Spam Oracle" (spam spam-use-spamoracle)) + (const :tag "Ham: ifile" (ham spam-use-ifile)) + (const :tag "Ham: Bogofilter" (ham spam-use-bogofilter)) + (const :tag "Ham: Spam-stat" (ham spam-use-stat)) + (const :tag "Ham: Whitelist" (ham spam-use-whitelist)) + (const :tag "Ham: BBDB" (ham spam-use-BBDB)) + (const :tag "Ham: Copy" (ham spam-use-ham-copy)) + (const :tag "Ham: Spam Oracle" (ham spam-use-spamoracle))))) + + :parameter-document + "Which spam or ham processors will be applied when the summary is exited.") + + (gnus-define-group-parameter + spam-autodetect + :type list + :parameter-type + '(boolean :tag "Spam autodetection") + :function-document + "Should spam be autodetected (with spam-split) in this group?" + :variable gnus-spam-autodetect + :variable-default nil + :variable-document + "*Groups in which spam should be autodetected when they are entered. + Only unseen articles will be examined, unless + spam-autodetect-recheck-messages is set." + :variable-group spam + :variable-type + '(repeat + :tag "Autodetection setting" + (list + (regexp :tag "Group Regexp") + boolean)) + :parameter-document + "Spam autodetection. +Only unseen articles will be examined, unless +spam-autodetect-recheck-messages is set.") + + (gnus-define-group-parameter + spam-autodetect-methods + :type list + :parameter-type + '(choice :tag "Spam autodetection-specific methods" + (const none) + (const default) + (set :tag "Use specific methods" + (variable-item spam-use-blacklist) + (variable-item spam-use-regex-headers) + (variable-item spam-use-regex-body) + (variable-item spam-use-whitelist) + (variable-item spam-use-BBDB) + (variable-item spam-use-ifile) + (variable-item spam-use-spamoracle) + (variable-item spam-use-stat) + (variable-item spam-use-blackholes) + (variable-item spam-use-hashcash) + (variable-item spam-use-bogofilter-headers) + (variable-item spam-use-bogofilter))) + :function-document + "Methods to be used for autodetection in each group" + :variable gnus-spam-autodetect-methods + :variable-default nil + :variable-document + "*Methods for autodetecting spam per group. +Requires the spam-autodetect parameter. Only unseen articles +will be examined, unless spam-autodetect-recheck-messages is +set." + :variable-group spam + :variable-type + '(repeat + :tag "Autodetection methods" + (list + (regexp :tag "Group Regexp") + (choice + (const none) + (const default) + (set :tag "Use specific methods" + (variable-item spam-use-blacklist) + (variable-item spam-use-regex-headers) + (variable-item spam-use-regex-body) + (variable-item spam-use-whitelist) + (variable-item spam-use-BBDB) + (variable-item spam-use-ifile) + (variable-item spam-use-spamoracle) + (variable-item spam-use-stat) + (variable-item spam-use-blackholes) + (variable-item spam-use-hashcash) + (variable-item spam-use-bogofilter-headers) + (variable-item spam-use-bogofilter))))) + :parameter-document + "Spam autodetection methods. +Requires the spam-autodetect parameter. Only unseen articles +will be examined, unless spam-autodetect-recheck-messages is +set.") + + (gnus-define-group-parameter + spam-process-destination + :type list + :parameter-type + '(choice :tag "Destination for spam-processed articles at summary exit" + (string :tag "Move to a group") + (repeat :tag "Move to multiple groups" + (string :tag "Destination group")) + (const :tag "Expire" nil)) + :function-document + "Where spam-processed articles will go at summary exit." + :variable gnus-spam-process-destinations + :variable-default nil + :variable-document + "*Groups in which to explicitly send spam-processed articles to +another group, or expire them (the default). If non-nil, this should +be a list of group name regexps that should match all groups in which +to do spam-processed article moving, associated with the destination +group or nil for explicit expiration. This only makes sense for +mail groups." + :variable-group spam + :variable-type + '(repeat + :tag "Spam-processed articles destination" + (list + (regexp :tag "Group Regexp") + (choice + :tag "Destination for spam-processed articles at summary exit" + (string :tag "Move to a group") + (repeat :tag "Move to multiple groups" + (string :tag "Destination group")) + (const :tag "Expire" nil)))) + :parameter-document + "Where spam-processed articles will go at summary exit.") + + (gnus-define-group-parameter + ham-process-destination + :type list + :parameter-type + '(choice + :tag "Destination for ham articles at summary exit from a spam group" + (string :tag "Move to a group") + (repeat :tag "Move to multiple groups" + (string :tag "Destination group")) + (const :tag "Respool" respool) + (const :tag "Do nothing" nil)) + :function-document + "Where ham articles will go at summary exit from a spam group." + :variable gnus-ham-process-destinations + :variable-default nil + :variable-document + "*Groups in which to explicitly send ham articles to +another group, or do nothing (the default). If non-nil, this should +be a list of group name regexps that should match all groups in which +to do ham article moving, associated with the destination +group or nil for explicit ignoring. This only makes sense for +mail groups, and only works in spam groups." + :variable-group spam + :variable-type + '(repeat + :tag "Ham articles destination" + (list + (regexp :tag "Group Regexp") + (choice + :tag "Destination for ham articles at summary exit from spam group" + (string :tag "Move to a group") + (repeat :tag "Move to multiple groups" + (string :tag "Destination group")) + (const :tag "Respool" respool) + (const :tag "Expire" nil)))) + :parameter-document + "Where ham articles will go at summary exit from a spam group.") + + (gnus-define-group-parameter + ham-marks + :type 'list + :parameter-type '(list :tag "Ham mark choices" + (set + (variable-item gnus-del-mark) + (variable-item gnus-read-mark) + (variable-item gnus-ticked-mark) + (variable-item gnus-killed-mark) + (variable-item gnus-kill-file-mark) + (variable-item gnus-low-score-mark))) + + :parameter-document + "Marks considered ham (positively not spam). Such articles will be +processed as ham (non-spam) on group exit. When nil, the global +spam-ham-marks variable takes precedence." + :variable-default '((".*" ((gnus-del-mark + gnus-read-mark + gnus-killed-mark + gnus-kill-file-mark + gnus-low-score-mark)))) + :variable-group spam + :variable-document + "*Groups in which to explicitly set the ham marks to some value.") + + (gnus-define-group-parameter + spam-marks + :type 'list + :parameter-type '(list :tag "Spam mark choices" + (set + (variable-item gnus-spam-mark) + (variable-item gnus-killed-mark) + (variable-item gnus-kill-file-mark) + (variable-item gnus-low-score-mark))) + + :parameter-document + "Marks considered spam. +Such articles will be processed as spam on group exit. When nil, the global +spam-spam-marks variable takes precedence." + :variable-default '((".*" ((gnus-spam-mark)))) + :variable-group spam + :variable-document + "*Groups in which to explicitly set the spam marks to some value.")) (defcustom gnus-group-uncollapsed-levels 1 "Number of group name elements to leave alone when making a short group name." @@ -1466,6 +2249,18 @@ (const pick-menu) (const grouplens-menu))) +;; Byte-compiler warning. +(defvar gnus-visual) +;; Find out whether the gnus-visual TYPE is wanted. +(defun gnus-visual-p (&optional type class) + (and gnus-visual ; Has to be non-nil, at least. + (if (not type) ; We don't care about type. + gnus-visual + (if (listp gnus-visual) ; It's a list, so we check it. + (or (memq type gnus-visual) + (memq class gnus-visual)) + t)))) + (defcustom gnus-mouse-face (condition-case () (if (gnus-visual-p 'mouse-face 'highlight) @@ -1488,41 +2283,97 @@ (defvar gnus-plugged t "Whether Gnus is plugged or not.") -(defcustom gnus-default-charset 'iso-8859-1 +(defcustom gnus-agent-cache t + "Controls use of the agent cache while plugged. +When set, Gnus will prefer using the locally stored content rather +than re-fetching it from the server. You also need to enable +`gnus-agent' for this to have any affect." + :version "21.3" + :group 'gnus-agent + :type 'boolean) + +(defcustom gnus-default-charset 'undecided "Default charset assumed to be used when viewing non-ASCII characters. This variable is overridden on a group-to-group basis by the -gnus-group-charset-alist variable and is only used on groups not +`gnus-group-charset-alist' variable and is only used on groups not covered by that variable." :type 'symbol :group 'gnus-charset) -(defcustom gnus-default-posting-charset nil - "Default charset assumed to be used when posting non-ASCII characters. -This variable is overridden on a group-to-group basis by the -gnus-group-posting-charset-alist variable and is only used on groups not -covered by that variable. -If nil, no default charset is assumed when posting." - :type 'symbol - :group 'gnus-charset) +;; Fixme: Doc reference to agent. +(defcustom gnus-agent t + "Whether we want to use the Gnus agent or not. + +You may customize gnus-agent to disable its use. However, some +back ends have started to use the agent as a client-side cache. +Disabling the agent may result in noticeable loss of performance." + :version "21.3" + :group 'gnus-agent + :type 'boolean) + +(defcustom gnus-other-frame-function 'gnus + "Function called by the command `gnus-other-frame'." + :group 'gnus-start + :type '(choice (function-item gnus) + (function-item gnus-no-server) + (function-item gnus-slave) + (function-item gnus-slave-no-server))) + +(defcustom gnus-other-frame-parameters nil + "Frame parameters used by `gnus-other-frame' to create a Gnus frame. +This should be an alist for Emacs, or a plist for XEmacs." + :group 'gnus-start + :type (if (featurep 'xemacs) + '(repeat (list :inline t :format "%v" + (symbol :tag "Property") + (sexp :tag "Value"))) + '(repeat (cons :format "%v" + (symbol :tag "Parameter") + (sexp :tag "Value"))))) + +(defcustom gnus-user-agent 'emacs-gnus-type + "Which information should be exposed in the User-Agent header. + +It can be one of the symbols `gnus' \(show only Gnus version\), `emacs-gnus' +\(show only Emacs and Gnus versions\), `emacs-gnus-config' \(same as +`emacs-gnus' plus system configuration\), `emacs-gnus-type' \(same as +`emacs-gnus' plus system type\) or a custom string. If you set it to a +string, be sure to use a valid format, see RFC 2616." + :group 'gnus-message + :type '(choice + (item :tag "Show Gnus and Emacs versions and system type" + emacs-gnus-type) + (item :tag "Show Gnus and Emacs versions and system configuration" + emacs-gnus-config) + (item :tag "Show Gnus and Emacs versions" emacs-gnus) + (item :tag "Show only Gnus version" gnus) + (string :tag "Other"))) ;;; Internal variables (defvar gnus-agent-gcc-header "X-Gnus-Agent-Gcc") (defvar gnus-agent-meta-information-header "X-Gnus-Agent-Meta-Information") +(defvar gnus-agent-method-p-cache nil + ; Reset each time gnus-agent-covered-methods is changed else + ; gnus-agent-method-p may mis-report a methods status. + ) +(defvar gnus-agent-target-move-group-header "X-Gnus-Agent-Move-To") +(defvar gnus-draft-meta-information-header "X-Draft-From") (defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) (defvar gnus-original-article-buffer " *Original Article*") (defvar gnus-newsgroup-name nil) (defvar gnus-ephemeral-servers nil) - -(defvar gnus-agent nil - "Whether we want to use the Gnus agent or not.") +(defvar gnus-server-method-cache nil) (defvar gnus-agent-fetching nil "Whether Gnus agent is in fetching mode.") +(defvar gnus-agent-covered-methods nil + "A list of servers, NOT methods, showing which servers are covered by the agent.") + (defvar gnus-command-method nil - "Dynamically bound variable that says what the current backend is.") + "Dynamically bound variable that says what the current back end is.") (defvar gnus-current-select-method nil "The current method for selecting a newsgroup.") @@ -1560,7 +2411,7 @@ ,(nnheader-concat gnus-cache-directory "active")))) "List of predefined (convenience) servers.") -(defvar gnus-topic-indentation "");; Obsolete variable. +(defvar gnus-topic-indentation "") ;; Obsolete variable. (defconst gnus-article-mark-lists '((marked . tick) (replied . reply) @@ -1568,7 +2419,28 @@ (bookmarks . bookmark) (dormant . dormant) (scored . score) (saved . save) (cached . cache) (downloadable . download) - (unsendable . unsend))) + (unsendable . unsend) (forwarded . forward) + (recent . recent) (seen . seen))) + +(defconst gnus-article-special-mark-lists + '((seen range) + (killed range) + (bookmark tuple) + (score tuple))) + +;; Propagate flags to server, with the following exceptions: +;; `seen' is private to each gnus installation +;; `cache' is a internal gnus flag for each gnus installation +;; `download' is a agent flag private to each gnus installation +;; `unsend' are for nndraft groups only +;; `score' is not a proper mark +;; `bookmark': don't propagated it, or fix the bug in update-mark. +(defconst gnus-article-unpropagated-mark-lists + '(seen cache download unsend score bookmark) + "Marks that shouldn't be propagated to back ends. +Typical marks are those that make no sense in a standalone back end, +such as a mark that says whether an article is stored in the cache +\(which doesn't make sense in a standalone back end).") (defvar gnus-headers-retrieved-by nil) (defvar gnus-article-reply nil) @@ -1585,10 +2457,10 @@ "The mail address of the Gnus maintainers.") (defvar gnus-info-nodes - '((gnus-group-mode "(gnus)The Group Buffer") - (gnus-summary-mode "(gnus)The Summary Buffer") - (gnus-article-mode "(gnus)The Article Buffer") - (gnus-server-mode "(gnus)The Server Buffer") + '((gnus-group-mode "(gnus)Group Buffer") + (gnus-summary-mode "(gnus)Summary Buffer") + (gnus-article-mode "(gnus)Article Buffer") + (gnus-server-mode "(gnus)Server Buffer") (gnus-browse-mode "(gnus)Browse Foreign Server") (gnus-tree-mode "(gnus)Tree Display")) "Alist of major modes and related Info nodes.") @@ -1615,16 +2487,20 @@ (defvar gnus-newsrc-alist nil "Assoc list of read articles. -gnus-newsrc-hashtb should be kept so that both hold the same information.") +`gnus-newsrc-hashtb' should be kept so that both hold the same information.") + +(defvar gnus-registry-alist nil + "Assoc list of registry data. +gnus-registry.el will populate this if it's loaded.") (defvar gnus-newsrc-hashtb nil - "Hashtable of gnus-newsrc-alist.") + "Hashtable of `gnus-newsrc-alist'.") (defvar gnus-killed-list nil "List of killed newsgroups.") (defvar gnus-killed-hashtb nil - "Hash table equivalent of gnus-killed-list.") + "Hash table equivalent of `gnus-killed-list'.") (defvar gnus-zombie-list nil "List of almost dead newsgroups.") @@ -1654,6 +2530,9 @@ (defvar gnus-invalid-group-regexp "[: `'\"/]\\|^$" "Regexp matching invalid groups.") +(defvar gnus-other-frame-object nil + "A frame object which will be created by `gnus-other-frame'.") + ;;; End of variables. ;; Define some autoload functions Gnus might use. @@ -1704,6 +2583,9 @@ gnus-demon-remove-handler) ("gnus-demon" :interactive t gnus-demon-init gnus-demon-cancel) + ("gnus-fun" gnus-convert-gray-x-face-to-xpm gnus-display-x-face-in-from + gnus-convert-image-to-gray-x-face gnus-convert-face-to-png + gnus-face-from-file) ("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer) ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close @@ -1762,7 +2644,8 @@ ("gnus-msg" (gnus-summary-send-map keymap) gnus-article-mail gnus-copy-article-buffer gnus-extended-version) ("gnus-msg" :interactive t - gnus-group-post-news gnus-group-mail gnus-summary-post-news + gnus-group-post-news gnus-group-mail gnus-group-news + gnus-summary-post-news gnus-summary-news-other-window gnus-summary-followup gnus-summary-followup-with-original gnus-summary-cancel-article gnus-summary-supersede-article gnus-post-news gnus-summary-reply gnus-summary-reply-with-original @@ -1773,13 +2656,10 @@ gnus-summary-wide-reply-with-original gnus-summary-post-forward gnus-summary-wide-reply-with-original gnus-summary-post-forward) - ("gnus-picon" :interactive t gnus-article-display-picons - gnus-group-display-picons gnus-picons-article-display-x-face - gnus-picons-display-x-face) - ("gnus-picon" gnus-picons-buffer-name) + ("gnus-picon" :interactive t gnus-treat-from-picon) ("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p gnus-grouplens-mode) - ("smiley" :interactive t gnus-smiley-display) + ("smiley" :interactive t smiley-region) ("gnus-win" gnus-configure-windows gnus-add-configuration) ("gnus-sum" gnus-summary-insert-line gnus-summary-read-group gnus-list-of-unread-articles gnus-list-of-read-articles @@ -1809,11 +2689,11 @@ gnus-article-de-base64-unreadable gnus-article-decode-HZ gnus-article-wash-html - gnus-article-hide-pgp + gnus-article-unsplit-urls gnus-article-hide-pem gnus-article-hide-signature gnus-article-strip-leading-blank-lines gnus-article-date-local gnus-article-date-original gnus-article-date-lapsed - gnus-article-show-all-headers +;; gnus-article-show-all-headers gnus-article-edit-mode gnus-article-edit-article gnus-article-edit-done gnus-article-decode-encoded-words gnus-start-date-timer gnus-stop-date-timer @@ -1835,20 +2715,23 @@ ("gnus-agent" gnus-open-agent gnus-agent-get-function gnus-agent-save-groups gnus-agent-save-active gnus-agent-method-p gnus-agent-get-undownloaded-list gnus-agent-fetch-session - gnus-summary-set-agent-mark gnus-agent-save-group-info) + gnus-summary-set-agent-mark gnus-agent-save-group-info + gnus-agent-request-article gnus-agent-retrieve-headers) ("gnus-agent" :interactive t gnus-unplugged gnus-agentize gnus-agent-batch) ("gnus-vm" :interactive t gnus-summary-save-in-vm gnus-summary-save-article-vm) - ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-drafts) + ("compface" uncompface) + ("gnus-draft" :interactive t gnus-draft-mode gnus-group-send-queue) ("gnus-mlspl" gnus-group-split gnus-group-split-fancy) ("gnus-mlspl" :interactive t gnus-group-split-setup - gnus-group-split-update)))) + gnus-group-split-update) + ("gnus-delay" gnus-delay-initialize)))) ;;; gnus-sum.el thingies -(defcustom gnus-summary-line-format "%U%R%z%I%(%[%4L: %-20,20n%]%) %s\n" +(defcustom gnus-summary-line-format "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n" "*The format specification of the lines in the summary buffer. It works along the same lines as a normal formatting string, @@ -1865,11 +2748,16 @@ %x Contents of the Xref: header (string) %D Date of the article (string) %d Date of the article (string) in DD-MMM format +%o Date of the article (string) in YYYYMMDD`T'HHMMSS format %M Message-id of the article (string) %r References of the article (string) %c Number of characters in the article (integer) +%k Pretty-printed version of the above (string) + For example, \"1.2k\" or \"0.4M\". %L Number of lines in the article (integer) %I Indentation based on thread level (a string of spaces) +%B A complex trn-style thread tree (string) + The variables `gnus-sum-thread-*' can be used for customization. %T A string with two possible values: 80 spaces if the article is on thread level two or larger and 0 spaces on level one %R \"A\" if this article has been replied to, \" \" otherwise (character) @@ -1886,6 +2774,8 @@ %V Total thread score (number). %P The line number (number). %O Download mark (character). +%* If present, indicates desired cursor position + (instead of after first colon). %u User defined specifier. The next character in the format string should be a letter. Gnus will call the function gnus-user-format-function-X, where X is the letter following %u. The function will be passed the @@ -1893,10 +2783,6 @@ will be inserted into the summary just like information from any other summary specifier. -Text between %( and %) will be highlighted with `gnus-mouse-face' -when the mouse point is placed inside the area. There can only be one -such area. - The %U (status), %R (replied) and %z (zcore) specs have to be handled with care. For reasons of efficiency, Gnus will compute what column these characters will end up in, and \"hard-code\" that. This means that @@ -1904,10 +2790,14 @@ you might not be arrested, but your summary buffer will look strange, which is bad enough. -The smart choice is to have these specs as for to the left as +The smart choice is to have these specs as far to the left as possible. -This restriction may disappear in later versions of Gnus." +This restriction may disappear in later versions of Gnus. + +General format specifiers can also be used. +See Info node `(gnus)Formatting Variables'." + :link '(custom-manual "(gnus)Formatting Variables") :type 'string :group 'gnus-summary-format) @@ -1951,6 +2841,12 @@ "Get hash value of STRING in HASHTABLE." `(symbol-value (intern-soft ,string ,hashtable))) +(defmacro gnus-gethash-safe (string hashtable) + "Get hash value of STRING in HASHTABLE. +Return nil if not defined." + `(let ((sym (intern-soft ,string ,hashtable))) + (and (boundp sym) (symbol-value sym)))) + (defmacro gnus-sethash (string value hashtable) "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." `(set (intern ,string ,hashtable) ,value)) @@ -2036,18 +2932,6 @@ (defmacro gnus-get-info (group) `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb))) -;; Byte-compiler warning. -(defvar gnus-visual) -;; Find out whether the gnus-visual TYPE is wanted. -(defun gnus-visual-p (&optional type class) - (and gnus-visual ; Has to be non-nil, at least. - (if (not type) ; We don't care about type. - gnus-visual - (if (listp gnus-visual) ; It's a list, so we check it. - (or (memq type gnus-visual) - (memq class gnus-visual)) - t)))) - ;;; Load the compatibility functions. (require 'gnus-ems) @@ -2076,6 +2960,21 @@ ;;; Gnus Utility Functions ;;; +(defun gnus-find-subscribed-addresses () + "Return a regexp matching the addresses of all subscribed mail groups. +It consists of the `to-address' or `to-list' parameter of all groups +with a `subscribed' parameter." + (let (group address addresses) + (dolist (entry (cdr gnus-newsrc-alist)) + (setq group (car entry)) + (when (gnus-parameter-subscribed group) + (setq address (mail-strip-quoted-names + (or (gnus-group-fast-parameter group 'to-address) + (gnus-group-fast-parameter group 'to-list)))) + (when address + (add-to-list 'addresses address)))) + (when addresses + (list (mapconcat 'regexp-quote addresses "\\|"))))) (defmacro gnus-string-or (&rest strings) "Return the first element of STRINGS that is a non-blank string. @@ -2099,8 +2998,11 @@ (insert (message gnus-version)) (message gnus-version))) -(defun gnus-continuum-version (version) +(defun gnus-continuum-version (&optional version) "Return VERSION as a floating point number." + (interactive) + (unless version + (setq version gnus-version)) (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version) (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version)) (let ((alpha (and (match-beginning 1) (match-string 1 version))) @@ -2116,23 +3018,23 @@ 0)) (string-to-number (if (zerop major) - (format "%s00%02d%02d" - (if (member alpha '("(ding)" "d")) - "4.99" - (+ 5 (* 0.02 - (abs - (- (mm-char-int (aref (downcase alpha) 0)) - (mm-char-int ?t)))) - -0.01)) - minor least) + (format "%s00%02d%02d" + (if (member alpha '("(ding)" "d")) + "4.99" + (+ 5 (* 0.02 + (abs + (- (mm-char-int (aref (downcase alpha) 0)) + (mm-char-int ?t)))) + -0.01)) + minor least) (format "%d.%02d%02d" major minor least)))))) -(defun gnus-info-find-node () +(defun gnus-info-find-node (&optional nodename) "Find Info documentation of Gnus." (interactive) ;; Enlarge info window if needed. (let (gnus-info-buffer) - (Info-goto-node (cadr (assq major-mode gnus-info-nodes))) + (Info-goto-node (or nodename (cadr (assq major-mode gnus-info-nodes)))) (setq gnus-info-buffer (current-buffer)) (gnus-configure-windows 'info))) @@ -2274,30 +3176,6 @@ (let ((group (or group gnus-newsgroup-name))) (not (gnus-check-backend-function 'request-replace-article group)))) -(defun gnus-group-total-expirable-p (group) - "Check whether GROUP is total-expirable or not." - (let ((params (gnus-group-find-parameter group)) - val) - (cond - ((memq 'total-expire params) - t) - ((setq val (assq 'total-expire params)) ; (auto-expire . t) - (cdr val)) - (gnus-total-expirable-newsgroups ; Check var. - (string-match gnus-total-expirable-newsgroups group))))) - -(defun gnus-group-auto-expirable-p (group) - "Check whether GROUP is auto-expirable or not." - (let ((params (gnus-group-find-parameter group)) - val) - (cond - ((memq 'auto-expire params) - t) - ((setq val (assq 'auto-expire params)) ; (auto-expire . t) - (cdr val)) - (gnus-auto-expirable-newsgroups ; Check var. - (string-match gnus-auto-expirable-newsgroups group))))) - (defun gnus-virtual-group-p (group) "Say whether GROUP is virtual or not." (memq 'virtual (assoc (symbol-name (car (gnus-find-method-for-group group))) @@ -2305,16 +3183,18 @@ (defun gnus-news-group-p (group &optional article) "Return non-nil if GROUP (and ARTICLE) come from a news server." - (or (gnus-member-of-valid 'post group) ; Ordinary news group. - (and (gnus-member-of-valid 'post-mail group) ; Combined group. - (if (or (null article) - (not (< article 0))) - (eq (gnus-request-type group article) 'news) - (if (not (vectorp article)) - nil - ;; It's a real article. - (eq (gnus-request-type group (mail-header-id article)) - 'news)))))) + (cond ((gnus-member-of-valid 'post group) ;Ordinary news group + t) ;is news of course. + ((not (gnus-member-of-valid 'post-mail group)) ;Non-combined. + nil) ;must be mail then. + ((vectorp article) ;Has header info. + (eq (gnus-request-type group (mail-header-id article)) 'news)) + ((null article) ;Hasn't header info + (eq (gnus-request-type group) 'news)) ;(unknown ==> mail) + ((< article 0) ;Virtual message + nil) ;we don't know, guess mail. + (t ;Has positive number + (eq (gnus-request-type group article) 'news)))) ;use it. ;; Returns a list of writable groups. (defun gnus-writable-groups () @@ -2376,6 +3256,85 @@ (nth 1 method)))) method))) +(defsubst gnus-server-to-method (server) + "Map virtual server names to select methods." + (or (and server (listp server) server) + (cdr (assoc server gnus-server-method-cache)) + (let ((result + (or + ;; Perhaps this is the native server? + (and (equal server "native") gnus-select-method) + ;; It should be in the server alist. + (cdr (assoc server gnus-server-alist)) + ;; It could be in the predefined server alist. + (cdr (assoc server gnus-predefined-server-alist)) + ;; If not, we look through all the opened server + ;; to see whether we can find it there. + (let ((opened gnus-opened-servers)) + (while (and opened + (not (equal server (format "%s:%s" (caaar opened) + (cadaar opened))))) + (pop opened)) + (caar opened)) + ;; It could be a named method, search all servers + (let ((servers gnus-secondary-select-methods)) + (while (and servers + (not (equal server (format "%s:%s" (caar servers) + (cadar servers))))) + (pop servers)) + (car servers)) + ;; This could be some sort of foreign server that I + ;; simply haven't opened (yet). Do a brute-force scan + ;; of the entire gnus-newsrc-alist for the server name + ;; of every method. As a side-effect, loads the + ;; gnus-server-method-cache so this only happens once, + ;; if at all. + (let (match) + (mapcar + (lambda (info) + (let ((info-method (gnus-info-method info))) + (unless (stringp info-method) + (let ((info-server (gnus-method-to-server info-method))) + (when (equal server info-server) + (setq match info-method)))))) + (cdr gnus-newsrc-alist)) + match)))) + (when result + (push (cons server result) gnus-server-method-cache)) + result))) + +(defsubst gnus-method-to-server (method) + (catch 'server-name + (setq method (or method gnus-select-method)) + + ;; Perhaps it is already in the cache. + (mapc (lambda (name-method) + (if (equal (cdr name-method) method) + (throw 'server-name (car name-method)))) + gnus-server-method-cache) + + (mapc + (lambda (server-alist) + (mapc (lambda (name-method) + (when (gnus-methods-equal-p (cdr name-method) method) + (unless (member name-method gnus-server-method-cache) + (push name-method gnus-server-method-cache)) + (throw 'server-name (car name-method)))) + server-alist)) + (let ((alists (list gnus-server-alist + gnus-predefined-server-alist))) + (if gnus-select-method + (push (list (cons "native" gnus-select-method)) alists)) + alists)) + + (let* ((name (if (member (cadr method) '(nil "")) + (format "%s" (car method)) + (format "%s:%s" (car method) (cadr method)))) + (name-method (cons name method))) + (unless (member name-method gnus-server-method-cache) + (push name-method gnus-server-method-cache)) + name))) + (defsubst gnus-server-get-method (group method) ;; Input either a server name, and extended server name, or a ;; select method, and return a select method. @@ -2393,33 +3352,6 @@ (t (gnus-server-add-address method)))) -(defun gnus-server-to-method (server) - "Map virtual server names to select methods." - (or - ;; Is this a method, perhaps? - (and server (listp server) server) - ;; Perhaps this is the native server? - (and (equal server "native") gnus-select-method) - ;; It should be in the server alist. - (cdr (assoc server gnus-server-alist)) - ;; It could be in the predefined server alist. - (cdr (assoc server gnus-predefined-server-alist)) - ;; If not, we look through all the opened server - ;; to see whether we can find it there. - (let ((opened gnus-opened-servers)) - (while (and opened - (not (equal server (format "%s:%s" (caaar opened) - (cadaar opened))))) - (pop opened)) - (caar opened)) - ;; It could be a named method, search all servers - (let ((servers gnus-secondary-select-methods)) - (while (and servers - (not (equal server (format "%s:%s" (caar servers) - (cadar servers))))) - (pop servers)) - (car servers)))) - (defmacro gnus-method-equal (ss1 ss2) "Say whether two servers are equal." `(let ((s1 ,ss1) @@ -2474,27 +3406,77 @@ (and active (file-exists-p active)))))) -(defun gnus-group-prefixed-name (group method) - "Return the whole name from GROUP and METHOD." - (and (stringp method) (setq method (gnus-server-to-method method))) +(defsubst gnus-method-to-server-name (method) + (concat + (format "%s" (car method)) + (when (and + (or (assoc (format "%s" (car method)) + (gnus-methods-using 'address)) + (gnus-server-equal method gnus-message-archive-method)) + (nth 1 method) + (not (string= (nth 1 method) ""))) + (concat "+" (nth 1 method))))) + +(defsubst gnus-method-to-full-server-name (method) + (format "%s+%s" (car method) (nth 1 method))) + +(defun gnus-group-prefixed-name (group method &optional full) + "Return the whole name from GROUP and METHOD. +Call with full set to get the fully qualified group name (even if the +server is native)." + (when (stringp method) + (setq method (gnus-server-to-method method))) (if (or (not method) - (gnus-server-equal method "native")) + (and (not full) (gnus-server-equal method "native")) + ;;;!!! This might not be right. We'll see... + ;(string-match ":" group) + ) group - (concat (format "%s" (car method)) - (when (and - (or (assoc (format "%s" (car method)) - (gnus-methods-using 'address)) - (gnus-server-equal method gnus-message-archive-method)) - (nth 1 method) - (not (string= (nth 1 method) ""))) - (concat "+" (nth 1 method))) - ":" group))) + (concat (gnus-method-to-server-name method) ":" group))) + +(defun gnus-group-guess-prefixed-name (group) + "Guess the whole name from GROUP and METHOD." + (gnus-group-prefixed-name group (gnus-find-method-for-group + group))) + +(defun gnus-group-full-name (group method) + "Return the full name from GROUP and METHOD, even if the method is native." + (gnus-group-prefixed-name group method t)) + +(defun gnus-group-guess-full-name (group) + "Guess the full name from GROUP, even if the method is native." + (if (gnus-group-prefixed-p group) + group + (gnus-group-full-name group (gnus-find-method-for-group group)))) + +(defun gnus-group-guess-full-name-from-command-method (group) + "Guess the full name from GROUP, even if the method is native." + (if (gnus-group-prefixed-p group) + group + (gnus-group-full-name group gnus-command-method))) (defun gnus-group-real-prefix (group) "Return the prefix of the current group name." - (if (string-match "^[^:]+:" group) - (substring group 0 (match-end 0)) - "")) + (if (stringp group) + (if (string-match "^[^:]+:" group) + (substring group 0 (match-end 0)) + "") + nil)) + +(defun gnus-group-short-name (group) + "Return the short group name." + (let ((prefix (gnus-group-real-prefix group))) + (if (< 0 (length prefix)) + (substring group (length prefix) nil) + group))) + +(defun gnus-group-prefixed-p (group) + "Return the prefix of the current group name." + (< 0 (length (gnus-group-real-prefix group)))) + +(defun gnus-summary-buffer-name (group) + "Return the summary buffer name of GROUP." + (concat "*Summary " (gnus-group-decoded-name group) "*")) (defun gnus-group-method (group) "Return the server or method used for selecting GROUP. @@ -2528,10 +3510,10 @@ (defsubst gnus-secondary-method-p (method) "Return whether METHOD is a secondary select method." (let ((methods gnus-secondary-select-methods) - (gmethod (gnus-server-get-method nil method))) + (gmethod (inline (gnus-server-get-method nil method)))) (while (and methods (not (gnus-method-equal - (gnus-server-get-method nil (car methods)) + (inline (gnus-server-get-method nil (car methods))) gmethod))) (setq methods (cdr methods))) methods)) @@ -2569,15 +3551,88 @@ "Say whether the group is secondary or not." (gnus-secondary-method-p (gnus-find-method-for-group group))) +(defun gnus-parameters-get-parameter (group) + "Return the group parameters for GROUP from `gnus-parameters'." + (let (params-list) + (dolist (elem gnus-parameters) + (when (string-match (car elem) group) + (setq params-list + (nconc (gnus-expand-group-parameters + (car elem) (cdr elem) group) + params-list)))) + params-list)) + +(defun gnus-expand-group-parameter (match value group) + "Use MATCH to expand VALUE in GROUP." + (with-temp-buffer + (insert group) + (goto-char (point-min)) + (while (re-search-forward match nil t) + (replace-match value)) + (buffer-string))) + +(defun gnus-expand-group-parameters (match parameters group) + "Go through PARAMETERS and expand them according to the match data." + (let (new) + (dolist (elem parameters) + (if (and (stringp (cdr elem)) + (string-match "\\\\[0-9&]" (cdr elem))) + (push (cons (car elem) + (gnus-expand-group-parameter match (cdr elem) group)) + new) + (push elem new))) + new)) + +(defun gnus-group-fast-parameter (group symbol &optional allow-list) + "For GROUP, return the value of SYMBOL. + +You should call this in the `gnus-group-buffer' buffer. +The function `gnus-group-find-parameter' will do that for you." + ;; The speed trick: No cons'ing and quit early. + (let* ((params (funcall gnus-group-get-parameter-function group)) + ;; Start easy, check the "real" group parameters. + (simple-results + (gnus-group-parameter-value params symbol allow-list t))) + (if simple-results + ;; Found results; return them. + (car simple-results) + ;; We didn't found it there, try `gnus-parameters'. + (let ((result nil) + (head nil) + (tail gnus-parameters)) + ;; A good old-fashioned non-cl loop. + (while tail + (setq head (car tail) + tail (cdr tail)) + ;; The car is regexp matching for matching the group name. + (when (string-match (car head) group) + ;; The cdr is the parameters. + (setq result (gnus-group-parameter-value (cdr head) + symbol allow-list)) + (when result + ;; Expand if necessary. + (if (and (stringp result) (string-match "\\\\[0-9&]" result)) + (setq result (gnus-expand-group-parameter (car head) + result group))) + ;; Exit the loop early. + (setq tail nil)))) + ;; Done. + result)))) + (defun gnus-group-find-parameter (group &optional symbol allow-list) "Return the group parameters for GROUP. -If SYMBOL, return the value of that symbol in the group parameters." +If SYMBOL, return the value of that symbol in the group parameters. + +If you call this function inside a loop, consider using the faster +`gnus-group-fast-parameter' instead." (save-excursion (set-buffer gnus-group-buffer) - (let ((parameters (funcall gnus-group-get-parameter-function group))) - (if symbol - (gnus-group-parameter-value parameters symbol allow-list) - parameters)))) + (if symbol + (gnus-group-fast-parameter group symbol allow-list) + (nconc + (copy-sequence + (funcall gnus-group-get-parameter-function group)) + (gnus-parameters-get-parameter group))))) (defun gnus-group-get-parameter (group &optional symbol allow-list) "Return the group parameters for GROUP. @@ -2589,7 +3644,8 @@ (gnus-group-parameter-value params symbol allow-list) params))) -(defun gnus-group-parameter-value (params symbol &optional allow-list) +(defun gnus-group-parameter-value (params symbol &optional + allow-list present-p) "Return the value of SYMBOL in group PARAMS." ;; We only wish to return group parameters (dotted lists) and ;; not local variables, which may have the same names. @@ -2603,7 +3659,8 @@ (eq (car elem) symbol) (or allow-list (atom (cdr elem)))) - (throw 'found (cdr elem)))))))) + (throw 'found (if present-p (list (cdr elem)) + (cdr elem))))))))) (defun gnus-group-add-parameter (group param) "Add parameter PARAM to GROUP." @@ -2662,7 +3719,7 @@ depth (+ depth 1))) depth)))) ;; Separate foreign select method from group name and collapse. - ;; If method contains a server, collapse to non-domain server name, + ;; If method contains a server, collapse to non-domain server name, ;; otherwise collapse to select method. (let* ((colon (string-match ":" group)) (server (and colon (substring group 0 colon))) @@ -2809,12 +3866,21 @@ (list (intern server) ""))) gnus-select-method)) +(defun gnus-server-string (server) + "Return a readable string that describes SERVER." + (let* ((server (gnus-server-to-method server)) + (address (nth 1 server))) + (if (and address + (not (zerop (length address)))) + (format "%s using %s" address (car server)) + (format "%s" (car server))))) + (defun gnus-find-method-for-group (group &optional info) "Find the select method that GROUP uses." (or gnus-override-method (and (not group) gnus-select-method) - (and (not (gnus-group-entry group));; a new group + (and (not (gnus-group-entry group)) ;; a new group (gnus-group-name-to-method group)) (let ((info (or info (gnus-get-info group))) method) @@ -2857,18 +3923,40 @@ (setq group (read-string (concat prefix prompt) (cons (or default "") 0) 'gnus-group-history))) - (setq prefix (format "Invalid group name: \"%s\". " group) - group nil))) + (let ((match (match-string 0 group))) + ;; Might be okay (e.g. for nnimap), so ask the user: + (unless (and (not (string-match "^$\\|:" match)) + (message-y-or-n-p + "Proceed and create group anyway? " t +"The group name \"" group "\" contains a forbidden character: \"" match "\". + +Usually, it's dangerous to create a group with this name, because it's not +supported by all back ends and servers. On IMAP servers it should work, +though. If you are really sure, you can proceed anyway and create the group. + +You may customize the variable `gnus-invalid-group-regexp', which currently is +set to \"" gnus-invalid-group-regexp +"\", if you want to get rid of this query permanently.")) + (setq prefix (format "Invalid group name: \"%s\". " group) + group nil))))) group)) (defun gnus-read-method (prompt) "Prompt the user for a method. Allow completion over sensible values." - (let* ((servers - (append gnus-valid-select-methods - (mapcar (lambda (i) (list (format "%s:%s" (caar i) - (cadar i)))) - gnus-opened-servers) + (let* ((open-servers + (mapcar (lambda (i) (cons (format "%s:%s" (caar i) (cadar i)) i)) + gnus-opened-servers)) + (valid-methods + (let (methods) + (dolist (method gnus-valid-select-methods) + (if (or (memq 'prompt-address method) + (not (assoc (format "%s:" (car method)) open-servers))) + (push method methods))) + methods)) + (servers + (append valid-methods + open-servers gnus-predefined-server-alist gnus-server-alist)) (method @@ -2883,35 +3971,48 @@ (assoc method gnus-valid-select-methods)) (read-string "Address: ") ""))) - (or (let ((opened gnus-opened-servers)) - (while (and opened - (not (equal (format "%s:%s" method address) - (format "%s:%s" (caaar opened) - (cadaar opened))))) - (pop opened)) - (caar opened)) + (or (cadr (assoc (format "%s:%s" method address) open-servers)) (list (intern method) address)))) ((assoc method servers) method) (t (list (intern method) ""))))) +;;; Agent functions + +(defun gnus-agent-method-p (method) + "Say whether METHOD is covered by the agent." + (or (eq (car gnus-agent-method-p-cache) method) + (setq gnus-agent-method-p-cache + (cons method + (member (if (stringp method) + method + (gnus-method-to-server method)) gnus-agent-covered-methods)))) + (cdr gnus-agent-method-p-cache)) + +(defun gnus-online (method) + (not + (if gnus-plugged + (eq (cadr (assoc method gnus-opened-servers)) 'offline) + (gnus-agent-method-p method)))) + ;;; User-level commands. ;;;###autoload (defun gnus-slave-no-server (&optional arg) - "Read network news as a slave, without connecting to local server." + "Read network news as a slave, without connecting to the local server." (interactive "P") (gnus-no-server arg t)) ;;;###autoload (defun gnus-no-server (&optional arg slave) "Read network news. -If ARG is a positive number, Gnus will use that as the -startup level. If ARG is nil, Gnus will be started at level 2. -If ARG is non-nil and not a positive number, Gnus will -prompt the user for the name of an NNTP server to use. -As opposed to `gnus', this command will not connect to the local server." +If ARG is a positive number, Gnus will use that as the startup +level. If ARG is nil, Gnus will be started at level 2. If ARG is +non-nil and not a positive number, Gnus will prompt the user for the +name of an NNTP server to use. +As opposed to `gnus', this command will not connect to the local +server." (interactive "P") (gnus-no-server-1 arg slave)) @@ -2922,15 +4023,51 @@ (gnus arg nil 'slave)) ;;;###autoload -(defun gnus-other-frame (&optional arg) - "Pop up a frame to read news." +(defun gnus-other-frame (&optional arg display) + "Pop up a frame to read news. +This will call one of the Gnus commands which is specified by the user +option `gnus-other-frame-function' (default `gnus') with the argument +ARG if Gnus is not running, otherwise just pop up a Gnus frame. The +optional second argument DISPLAY should be a standard display string +such as \"unix:0\" to specify where to pop up a frame. If DISPLAY is +omitted or the function `make-frame-on-display' is not available, the +current display is used." (interactive "P") - (let ((window (get-buffer-window gnus-group-buffer))) - (cond (window - (select-frame (window-frame window))) - (t - (select-frame (make-frame))))) - (gnus arg)) + (if (fboundp 'make-frame-on-display) + (unless display + (setq display (gnus-frame-or-window-display-name (selected-frame)))) + (setq display nil)) + (let ((alive (gnus-alive-p))) + (unless (and alive + (catch 'found + (walk-windows + (lambda (window) + (when (and (or (not display) + (equal display + (gnus-frame-or-window-display-name + window))) + (with-current-buffer (window-buffer window) + (string-match "\\`gnus-" + (symbol-name major-mode)))) + (gnus-select-frame-set-input-focus + (setq gnus-other-frame-object (window-frame window))) + (select-window window) + (throw 'found t))) + 'ignore t))) + (gnus-select-frame-set-input-focus + (setq gnus-other-frame-object + (if display + (make-frame-on-display display gnus-other-frame-parameters) + (make-frame gnus-other-frame-parameters)))) + (if alive + (switch-to-buffer gnus-group-buffer) + (funcall gnus-other-frame-function arg) + (add-hook 'gnus-exit-gnus-hook + '(lambda nil + (when (and (frame-live-p gnus-other-frame-object) + (cdr (frame-list))) + (delete-frame gnus-other-frame-object)) + (setq gnus-other-frame-object nil))))))) ;;(setq thing ? ; this is a comment ;; more 'yes) @@ -2939,9 +4076,12 @@ (defun gnus (&optional arg dont-connect slave) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the -startup level. If ARG is non-nil and not a positive number, Gnus will +startup level. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use." (interactive "P") + (unless (byte-code-function-p (symbol-function 'gnus)) + (message "You should byte-compile Gnus") + (sit-for 2)) (gnus-1 arg dont-connect slave)) ;; Allow redefinition of Gnus functions.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus.xbm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,622 @@ +#define noname_width 271 +#define noname_height 273 +static char noname_bits[] = { + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfa,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x49,0xe0,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x97,0xaa,0x8a,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x57,0x2a,0x41,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa9,0x52,0x16,0xfe,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0x49,0x05, + 0xf9,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0x95,0xaa,0x58,0xf4,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xa5,0x54,0x26,0xe1,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x54,0x49,0x49,0xe4,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x2a,0xa5, + 0x2a,0xd1,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xaf,0x52,0x95,0x54,0xc4,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab, + 0x24,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x57,0x29,0xa9,0x92,0x11,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x57,0xd5,0xfa,0xff,0xff,0xab,0xea,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x4a,0x55,0x2a,0x41,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x25,0x29,0xe5,0xff,0xff,0x95,0xa4,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa7,0xa4, + 0x24,0xa5,0x14,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4a,0xa5,0xd4,0xff, + 0x3f,0x52,0xa9,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x29,0x55,0x55,0x55,0x41,0x7e,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xa9,0x54,0xea,0xff,0xdf,0x2a,0x55,0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x55,0x4a,0x49,0x12,0x7e,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0x55,0xa5,0x92,0xff,0x23,0xa5,0x4a,0xd6,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa5,0xa4,0x94,0xaa,0x42, + 0x7d,0xff,0xff,0xff,0xff,0xff,0xff,0x9f,0x4a,0x2a,0xa9,0xff,0xad,0x92,0x24, + 0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a, + 0x95,0x52,0x52,0x29,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x52,0x49,0x55, + 0xfe,0x91,0x54,0x55,0x55,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0x49,0x29,0x55,0x25,0x85,0x7c,0xff,0xff,0xff,0xff,0xff,0xff, + 0x4f,0x95,0xaa,0x92,0x7e,0x55,0x55,0xa9,0x4a,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2a,0x50,0x95,0xaa,0x24,0x7e,0xff,0xff, + 0xff,0xff,0xff,0xff,0x57,0x2a,0x95,0x54,0x79,0x95,0x92,0x92,0x94,0xfc,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xb9,0x62,0x29,0x49, + 0x85,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x49,0x49,0x95,0xba,0xa4,0x54, + 0xaa,0x52,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf, + 0x1a,0xf8,0xa7,0xaa,0x22,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0x55,0x52, + 0x2a,0x75,0x55,0xa5,0x24,0xa5,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xbf,0x5a,0xfd,0x57,0x92,0x94,0x7e,0xff,0xff,0xff,0xff,0xff, + 0xff,0x4a,0x4a,0x55,0x49,0x89,0x92,0x94,0xaa,0x94,0xf4,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x1a,0xfc,0x2f,0x55,0x05,0x7c,0xff, + 0xff,0xff,0xff,0xff,0xff,0x55,0xa9,0x4a,0x55,0x2a,0x55,0x55,0x55,0x55,0xe5, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x4e,0xfd,0x5f, + 0x29,0xa5,0x7c,0xff,0xff,0xff,0xff,0xff,0xff,0xa4,0x54,0x52,0x4a,0x55,0xa9, + 0xa4,0x24,0xa5,0x94,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x2f,0x1d,0xfe,0x3f,0x95,0x04,0x7c,0xff,0xfd,0xff,0xff,0xff,0x3f,0x49,0xa5, + 0x54,0xa9,0xa4,0x92,0x4a,0x49,0x4a,0x55,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xaf,0x44,0xfe,0x5f,0xa9,0x52,0x7d,0xff,0xe5,0xff,0xff, + 0xff,0x5f,0x55,0x92,0x2a,0x95,0x52,0x4a,0x52,0xaa,0x52,0x4a,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x16,0xff,0xbf,0x4a,0x05,0x7c, + 0xff,0xd9,0xff,0xff,0xff,0x5f,0x95,0x42,0xa5,0x52,0x95,0xaa,0xaa,0xaa,0x94, + 0x54,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x43,0xfe, + 0xbf,0x54,0x52,0x7d,0x7f,0x25,0xff,0xff,0xff,0xa7,0xa4,0x28,0x92,0x54,0x4a, + 0xa5,0x4a,0x92,0xaa,0x4a,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xab,0x12,0xfe,0x7f,0xa5,0x02,0x7c,0x7f,0x55,0xfd,0xff,0xff,0x95,0x2a, + 0x82,0x54,0xa5,0x54,0x2a,0xa9,0x2a,0xa5,0x52,0xf5,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x27,0x4b,0xff,0xff,0x4a,0x29,0x7d,0xff,0x92,0xfe, + 0xff,0xff,0x55,0x92,0x20,0xa8,0x94,0x2a,0xa5,0x94,0x52,0x29,0xa9,0xf4,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97,0x01,0xff,0x7f,0x52,0x42, + 0x7c,0xff,0x25,0xf9,0xff,0x7f,0xaa,0x02,0x8a,0x40,0x29,0x49,0x09,0x41,0x4a, + 0x55,0x25,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x57, + 0xff,0xff,0x95,0x12,0x7d,0xff,0xa9,0xfa,0xff,0x7f,0x25,0xa9,0x20,0x2a,0xa5, + 0xaa,0x42,0x92,0x54,0x92,0x54,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xaf,0x83,0xff,0xff,0xa9,0x42,0x7e,0xff,0xaa,0xf4,0xff,0xaf,0x54, + 0x01,0x82,0x80,0xaa,0x54,0x14,0x08,0xa2,0xaa,0x4a,0xd2,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xef,0xcf,0xd7,0xff,0xff,0x52,0x12,0x7f,0xff,0x4a, + 0xea,0xff,0x57,0x92,0xaa,0x28,0x24,0x29,0x25,0x81,0x82,0x08,0x49,0x52,0x55, + 0xff,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xdf,0xef,0xe7,0xff,0xff,0x2a, + 0x05,0x7e,0xff,0x55,0xd5,0xff,0xa5,0x2a,0x00,0x8e,0x10,0x4a,0x89,0x24,0x28, + 0xa0,0xaa,0x2a,0x49,0xff,0xff,0xff,0xff,0xbf,0xff,0xff,0xff,0xff,0xe7,0xff, + 0xef,0xff,0xff,0xa5,0x50,0x7e,0xff,0x25,0xe5,0xff,0x2a,0xa5,0x52,0x7f,0x85, + 0x54,0x35,0x08,0x82,0x0a,0x55,0x95,0xaa,0xfc,0xff,0xff,0xff,0xcf,0xff,0xff, + 0xff,0xff,0xd7,0xff,0xff,0xff,0x7f,0x52,0x85,0x7e,0xff,0xab,0x94,0x1e,0x55, + 0x2a,0xc8,0xff,0x10,0x90,0x92,0xa0,0x08,0x20,0x24,0x52,0x25,0xfd,0xff,0xff, + 0xff,0xef,0xff,0xff,0xff,0xff,0xe9,0xff,0xff,0xff,0xff,0x94,0x10,0x7e,0xff, + 0x93,0xaa,0x6a,0x49,0x49,0xf2,0xff,0x85,0x52,0x09,0x0a,0xa2,0x4a,0x92,0x29, + 0xa9,0xf2,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0x7f, + 0x55,0x25,0x7f,0xff,0x55,0x49,0x49,0x95,0x0a,0xf9,0xff,0x17,0x48,0x26,0x50, + 0x08,0x00,0xa9,0x4a,0x95,0xfa,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xf2, + 0xff,0xff,0xff,0xff,0x92,0x80,0x7e,0xff,0xa7,0x54,0xaa,0xa4,0x52,0xfc,0xff, + 0xaf,0x42,0x89,0xfa,0xbf,0x54,0x20,0xa9,0xa4,0xd4,0xff,0xff,0xff,0xcb,0xff, + 0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff,0x54,0x29,0x7f,0xff,0x4b,0xa5,0x92, + 0x2a,0x01,0xff,0xff,0x1f,0xa8,0x22,0xff,0xff,0x01,0xa5,0x2a,0x55,0xa9,0xff, + 0xff,0xff,0xd4,0xff,0xff,0xff,0x7f,0xfa,0xff,0xff,0xff,0x7f,0xa5,0x04,0x7f, + 0xff,0x57,0x2a,0x55,0xa9,0x54,0xfe,0xff,0x3f,0x05,0x89,0xff,0xff,0x5f,0x48, + 0x92,0x2a,0x95,0xff,0xff,0xff,0xea,0xff,0xff,0xff,0xff,0xd2,0xff,0xff,0xff, + 0x7f,0x2a,0x91,0x7f,0xff,0xa9,0x54,0x4a,0x52,0x02,0xff,0xff,0xff,0x50,0xd1, + 0xff,0xff,0x1f,0x81,0xaa,0xa4,0x52,0xfe,0xff,0x3f,0xe9,0xff,0xff,0xff,0x7f, + 0x1d,0xff,0xff,0xff,0xff,0x54,0x41,0x7f,0xff,0x93,0x92,0x52,0x95,0xc8,0xff, + 0xff,0xff,0x8b,0xc4,0xff,0xff,0x7f,0x24,0xa5,0x2a,0x49,0xf9,0xff,0x7f,0xd5, + 0xff,0xff,0xff,0xbf,0x4a,0xff,0xff,0xff,0xff,0x4a,0x14,0x7f,0xff,0x28,0xa5, + 0x94,0x2a,0xa0,0xff,0xff,0x7f,0x22,0xf0,0xff,0xff,0x7f,0x12,0x94,0xa4,0xaa, + 0xea,0xff,0xaf,0xea,0xff,0xff,0xff,0x5f,0x8e,0xff,0xff,0xff,0x7f,0xa9,0x40, + 0x7f,0xff,0x48,0x55,0x55,0x12,0xca,0xff,0xff,0xff,0x0a,0xf5,0xff,0xff,0xff, + 0x80,0x52,0x95,0x54,0xaa,0xfe,0x55,0xc4,0xff,0xff,0xff,0x5f,0xa5,0xff,0xff, + 0xff,0xff,0x94,0x14,0x7f,0xff,0x52,0x2a,0xa9,0x4a,0xe1,0xff,0xff,0xbf,0x24, + 0xf0,0xff,0xff,0xff,0x0b,0x28,0xa9,0x92,0x24,0x55,0x49,0xe5,0xd7,0xff,0xff, + 0xa7,0x8a,0xff,0xff,0xff,0x7f,0xa5,0xc0,0x7f,0xff,0x50,0x49,0x95,0x04,0xf8, + 0xff,0xff,0x5f,0x1f,0xfd,0xff,0xff,0xff,0x47,0x45,0x55,0xaa,0xaa,0x4a,0xaa, + 0xea,0xaf,0xff,0xff,0x2b,0xc3,0xff,0xff,0xff,0x7f,0x55,0x94,0x7f,0x7f,0x4a, + 0x55,0x52,0x51,0xfe,0xff,0xff,0x5f,0x4e,0xf8,0xff,0xff,0xff,0x1f,0x50,0x92, + 0x52,0x49,0xa9,0x92,0xe4,0xd3,0xff,0xff,0x4b,0xd5,0xff,0xff,0xff,0xff,0x94, + 0xc0,0x7f,0x3f,0xa0,0xa4,0xaa,0x04,0xfe,0xff,0xff,0xa7,0x1d,0xfd,0xff,0xff, + 0xff,0x9f,0x84,0xaa,0x4a,0xaa,0x24,0x55,0xf2,0x2b,0xff,0x7f,0xa9,0xc1,0xff, + 0xff,0xff,0x7f,0x4a,0x95,0x7f,0xbf,0x2a,0x95,0x24,0x50,0xff,0xff,0xff,0x97, + 0x5e,0xfe,0xff,0xff,0xff,0x3f,0x92,0x24,0x95,0x92,0xaa,0xa4,0xf2,0xcb,0xff, + 0x5f,0xd5,0xe5,0xff,0xff,0xff,0xff,0x52,0x80,0x7f,0x3f,0xa0,0x52,0x15,0x85, + 0xff,0xff,0xff,0xd7,0x38,0xfe,0xff,0xff,0xff,0xff,0x20,0xaa,0x52,0x55,0x55, + 0x55,0xf9,0x29,0xfd,0xab,0xa4,0xf0,0xff,0xff,0xff,0x7f,0x29,0xa9,0x7f,0xff, + 0x42,0x25,0x49,0xe8,0xff,0xff,0xff,0x69,0x7a,0xff,0xff,0xff,0xff,0xff,0x82, + 0x52,0xaa,0x24,0x89,0x4a,0xf8,0x55,0x2a,0x49,0x95,0xf5,0xff,0xff,0xff,0xbf, + 0x2a,0xc4,0x7f,0x7f,0x90,0x54,0x15,0xe2,0xff,0xff,0xff,0x25,0xbc,0xff,0xff, + 0xff,0xff,0xff,0x29,0x48,0x49,0xaa,0xaa,0xa4,0xfa,0x95,0x92,0x54,0x52,0xf0, + 0xff,0xff,0xff,0xbf,0x4a,0xd1,0x7f,0xff,0x05,0xaa,0x40,0xf8,0xff,0xff,0x7f, + 0xaa,0xfc,0xff,0xff,0xff,0xff,0xff,0x43,0xa9,0xaa,0x4a,0x52,0xa9,0xf8,0xa4, + 0xaa,0x52,0x95,0xfc,0xff,0xff,0xff,0x7f,0x52,0xc0,0x7f,0xff,0xa1,0x00,0x24, + 0xfa,0xff,0xff,0xff,0x0a,0xfe,0xff,0xff,0xff,0xff,0xff,0x17,0x92,0x24,0xa5, + 0x2a,0x55,0xfe,0xaa,0xa4,0x2a,0x29,0xf9,0xff,0xff,0xff,0xbf,0x2a,0xea,0x7f, + 0xff,0x05,0x92,0x90,0xfc,0xff,0xff,0xbf,0xa4,0xff,0xff,0xff,0xff,0xff,0xff, + 0x4f,0xa0,0xaa,0x54,0x49,0x25,0x7c,0x49,0x95,0xa4,0x12,0xfc,0xff,0xff,0xff, + 0x7f,0x8a,0xe0,0x7f,0xff,0xa3,0x04,0x05,0xfe,0xff,0xff,0xbf,0x06,0xff,0xff, + 0xff,0xff,0xff,0xff,0x1f,0x49,0x95,0x52,0xaa,0x12,0x7f,0x55,0x52,0x55,0x0a, + 0xfd,0xff,0xff,0xff,0x3f,0x29,0xe8,0x7f,0xff,0x0f,0x50,0x50,0xff,0xff,0xff, + 0x5f,0xca,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x04,0xa9,0x4a,0x25,0x45,0x3e, + 0xa9,0x2a,0xa9,0xa2,0xfc,0xff,0xff,0xff,0x7f,0x55,0xe1,0x7f,0xff,0x27,0x05, + 0xc4,0xff,0xff,0xff,0x9f,0x91,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x41,0x4a, + 0x29,0xa9,0x12,0x5e,0x95,0x94,0x4a,0x0a,0xfe,0xff,0xff,0xff,0xbf,0x12,0xf4, + 0x7f,0xff,0x8f,0x50,0xf1,0xff,0xff,0xff,0xa7,0xc2,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x14,0x92,0xaa,0x4a,0xa2,0xbf,0xa4,0x52,0x95,0x22,0xff,0xff,0xff, + 0xff,0x3f,0x45,0xf2,0x7f,0xff,0x3f,0x04,0xf4,0xff,0xff,0xff,0xd7,0xe8,0xff, + 0xff,0xff,0xff,0x5f,0xff,0xff,0x83,0xa8,0x94,0x54,0x09,0x2f,0x55,0x4a,0x52, + 0x49,0xff,0xff,0xff,0xff,0x5f,0x99,0xf0,0x7f,0xff,0x7f,0x51,0xfc,0xff,0xff, + 0xff,0x6b,0xf1,0xff,0xff,0xff,0xff,0x5f,0xfd,0xff,0x2b,0x2a,0xa9,0x12,0x20, + 0x5f,0xa9,0xaa,0x54,0x00,0xff,0xff,0xff,0xff,0x5f,0x15,0xf2,0x7f,0xff,0xff, + 0x8f,0xff,0xff,0xff,0xff,0x2b,0xfc,0xff,0xff,0xff,0xff,0x2f,0xfd,0xff,0x87, + 0xa0,0x4a,0xaa,0x8a,0x9f,0x4a,0x52,0x15,0xa9,0xff,0xff,0xff,0xff,0x5f,0x8a, + 0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xf8,0xff,0xff,0xff,0xff, + 0x57,0xf2,0xff,0x2f,0x82,0x52,0x05,0xd0,0x2f,0x95,0x4a,0x49,0x84,0xff,0xff, + 0xff,0xff,0xbf,0x24,0xf8,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x12,0xfd, + 0xff,0xff,0xff,0xff,0x4b,0xd5,0xff,0x9f,0x28,0x54,0x48,0xc5,0xbf,0x52,0x55, + 0x0a,0xe1,0xff,0xff,0xff,0xff,0x9f,0x4a,0xfa,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x1a,0xfe,0xff,0xff,0xff,0xff,0x57,0xa9,0xff,0x3f,0x82,0x00,0x21, + 0xf0,0x5f,0x2a,0x49,0x21,0xc4,0xff,0xff,0xff,0xff,0xaf,0x1a,0xfd,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0x3f,0x85,0xff,0xff,0xff,0xff,0xff,0x29,0xa5,0xff, + 0xff,0x24,0x52,0x88,0xfc,0xbf,0x92,0x2a,0x09,0xf1,0xff,0xff,0xff,0xff,0x9f, + 0x4c,0xfc,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x15,0xff,0xff,0xff,0x7f, + 0xff,0xa5,0x4a,0xff,0xff,0x90,0x08,0x01,0xfe,0x3f,0x55,0x52,0x24,0xf4,0xff, + 0xff,0xff,0xff,0xaf,0x02,0xfd,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xc6, + 0xff,0xff,0xff,0xbf,0xfe,0x95,0x54,0xff,0xff,0x05,0x42,0xa8,0xfe,0xbf,0xa4, + 0x2a,0x41,0xf9,0xff,0xff,0xff,0xff,0x5f,0x55,0xfc,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0x4f,0xd0,0xff,0xff,0xff,0xbf,0x7c,0xaa,0x92,0xfc,0xff,0x53,0x08, + 0x01,0xff,0x1f,0x4a,0x01,0x04,0xfc,0xff,0xff,0xff,0xff,0x27,0x05,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xc5,0xff,0xff,0xff,0x4f,0xbf,0x52,0xaa, + 0xfe,0xff,0x07,0x42,0xea,0xff,0xbf,0x50,0x54,0x51,0xff,0xff,0xff,0xff,0xff, + 0x97,0x56,0xfe,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xf0,0xff,0xff,0xff, + 0x2f,0x7f,0xa5,0x54,0xfd,0xff,0x3f,0x09,0xe0,0xff,0x1f,0x02,0x01,0x04,0xff, + 0xff,0xff,0xff,0xff,0xaf,0x02,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x4b, + 0xf5,0xff,0xff,0xff,0xab,0x9f,0x94,0x92,0xfc,0xff,0xff,0x40,0xfd,0xff,0x9f, + 0x48,0x48,0xa1,0xff,0xff,0xff,0xff,0xff,0xa7,0x56,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0x6b,0xf8,0xff,0xff,0xff,0xa4,0x5f,0xa9,0x2a,0xfd,0xff,0xff, + 0xff,0xff,0xff,0x3f,0x22,0x21,0xc4,0xff,0xff,0xff,0xff,0xff,0x2f,0x03,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0xfa,0xff,0xff,0x7f,0xd5,0x2f,0xa5, + 0xa4,0xfa,0xff,0xff,0xff,0xff,0xff,0xbf,0x08,0x08,0xf9,0xff,0xff,0xff,0xff, + 0xff,0x97,0x4a,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x94,0xfc,0xff,0xff, + 0x7f,0x69,0xac,0x2a,0x55,0xf9,0xff,0xff,0xff,0xff,0xff,0x7f,0xa2,0x22,0xf8, + 0xff,0xff,0xff,0xff,0xff,0x53,0x21,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0x15,0xfe,0xff,0xff,0x9f,0x2a,0x95,0x94,0x92,0xf4,0xff,0xff,0xff,0xff,0xff, + 0xff,0x08,0x88,0xfe,0xff,0xff,0xff,0xff,0xff,0x57,0x8b,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xa9,0xfe,0xff,0xff,0x5f,0x52,0xbc,0x52,0x55,0xf5,0xff, + 0xff,0xff,0xff,0xff,0xff,0x21,0x21,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xa1, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x7f,0x0d,0xff,0xff,0xff,0x57,0x15,0x3f, + 0x55,0x49,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xc8,0xff,0xff,0xff,0xff, + 0xff,0xff,0xd7,0x89,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xbf,0xd6,0xff,0xff, + 0xff,0x4b,0x45,0x3f,0x49,0xaa,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0x0f,0xf9, + 0xff,0xff,0xff,0xff,0xff,0xff,0xc9,0xe2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0x3f,0x81,0xff,0xff,0xff,0x29,0x11,0x5f,0x28,0x55,0xf5,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0xc8,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0x5f,0xd6,0xff,0xff,0x7f,0xaa,0xc2,0x0f,0x55,0x49,0xea, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa5, + 0xe2,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x9f,0xe1,0xff,0xff,0xbf,0x4a,0xd1, + 0x5f,0x48,0xa5,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xe9,0xe0,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x27,0xf4,0xff, + 0xff,0xbf,0x94,0xc4,0x07,0x91,0x2a,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xea,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xaf,0xf1,0xff,0xff,0x9f,0x52,0xe0,0x4b,0x44,0x52,0xe9,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x6a,0xe0,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0x4b,0xfc,0xff,0xff,0xab,0x2a,0xf5,0x0f,0x51,0xa5, + 0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0x69,0xe5,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x55,0xf8,0xff,0xff,0x95,0x14, + 0xf0,0x5f,0x84,0x54,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0x75,0xf0,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x13,0xfd, + 0xff,0xff,0xa5,0x42,0xf9,0x7f,0x91,0x4a,0xf5,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xb2,0xfa,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0x54,0xfe,0xff,0x7f,0x52,0x12,0xfa,0xff,0x20,0xa5,0xe4,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x34,0xf8,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0x25,0xff,0xff,0xaf,0xaa,0x48,0xfc,0xff,0x0b, + 0x29,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xb5,0xf8,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0x52,0xff,0xff,0x2f,0x49, + 0x02,0xfe,0xff,0x43,0xaa,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x3f,0x3a,0xfa,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x4a, + 0xff,0xff,0xa5,0x2a,0xa9,0xff,0xff,0x17,0x25,0xe9,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x9a,0xfc,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0x2a,0xff,0x7f,0x95,0x54,0x80,0xff,0xff,0x07,0xa9,0xea,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x1d,0xfc, + 0xff,0x7f,0xff,0xff,0xff,0xff,0x3f,0xa9,0xfe,0x7f,0xa9,0x12,0xe5,0xff,0xff, + 0x5f,0x4a,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x5f,0xad,0xfe,0xff,0x7f,0xff,0xff,0xff,0xff,0x7f,0x95,0xea,0x97,0x54, + 0x4a,0xf0,0xff,0xff,0x1f,0xa8,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x5f,0x0e,0xfe,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f, + 0x52,0x55,0xa9,0x92,0x02,0xfd,0xff,0xff,0x5f,0x53,0xf5,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x5e,0xfe,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xbf,0x2a,0x49,0x4a,0x55,0x49,0xfc,0xff,0xff,0x3f,0x94,0xf8, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x0f, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4f,0xa5,0xaa,0x92,0xa4,0x20,0xff,0xff, + 0xff,0xbf,0xa4,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x5f,0x57,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,0x52,0x52,0xaa, + 0x2a,0x0a,0xff,0xff,0xff,0x7f,0x54,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x8f,0x07,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xa7,0x94,0x4a,0x55,0x4a,0xa0,0xff,0xff,0xff,0xff,0xa8,0xfa,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x57,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0x2f,0x55,0xa9,0x92,0x12,0xe9,0xff,0xff,0xff,0x7f,0x24, + 0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf, + 0x87,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0xa5,0x4a,0xaa,0x44,0xf4,0xff, + 0xff,0xff,0xff,0x55,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0xab,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xab,0x94,0xa4, + 0x92,0x12,0xf9,0xff,0xff,0xff,0xff,0xa8,0xfa,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xab,0x83,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0x47,0xa9,0x2a,0x55,0x40,0xfc,0xff,0xff,0xff,0xff,0x25,0xf5,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xff,0xff,0xff,0xff,0xd7,0x97,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0x33,0x55,0xa9,0x24,0x15,0xfe,0xff,0xff,0xff,0xff, + 0x95,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xff, + 0x93,0xc3,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0x25,0xa5,0x2a,0x40,0xff, + 0xff,0xff,0xff,0xff,0xa9,0xf4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe3,0xff, + 0xff,0xff,0xff,0xff,0xe7,0xd5,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4b,0x92, + 0x54,0x92,0xd4,0xff,0xff,0xff,0xff,0xff,0x55,0xf5,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xe9,0xff,0xff,0xff,0xff,0xff,0xd5,0xc1,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0x97,0xaa,0x4a,0x05,0xe2,0xff,0xff,0xff,0xff,0xff,0x25,0xf1,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xe3,0xfd,0xff,0xff,0xff,0xff,0xd5,0xea,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0x57,0x55,0x25,0xa1,0xf0,0xff,0xff,0xff,0xff, + 0xff,0x95,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe8,0xfa,0xff,0xff,0xff, + 0xff,0xea,0xe0,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xa7,0x24,0x59,0x04,0xfa, + 0xff,0xff,0xff,0xff,0xff,0xa9,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe2, + 0xfd,0xff,0xff,0xff,0xff,0xc9,0xe9,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x4f, + 0x52,0x05,0xa1,0xfc,0xff,0xff,0xff,0xff,0xff,0xa5,0xfa,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x70,0xf9,0xff,0xff,0xff,0xff,0x74,0xe2,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0x47,0x95,0x92,0x04,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0xf8, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xe2,0xfa,0xff,0xff,0xff,0xff,0x72,0xe8, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x97,0xaa,0x20,0xd0,0xff,0xff,0xff,0xff, + 0xff,0xff,0x55,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xb8,0xfc,0xff,0xff, + 0xff,0xff,0xea,0xe2,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x07,0x04,0x82,0xc2, + 0xff,0xff,0xff,0xff,0xff,0xff,0x29,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0x71,0xfd,0xff,0xff,0xff,0x7f,0x2a,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0x4f,0x91,0x28,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0xfc,0xff,0xff,0xff, + 0xff,0xff,0xff,0x1f,0x54,0xfe,0xff,0xff,0xff,0x7f,0x75,0xf2,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0x27,0x44,0x82,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0x29, + 0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xb8,0xfc,0xff,0xff,0xff,0xbf,0x14, + 0xf1,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x0f,0x11,0x20,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x55,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x9a,0xfe,0xff, + 0xff,0xff,0x7f,0x5a,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0x5f,0x40,0x85, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x09,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x4f,0x2d,0xfd,0xff,0xff,0xff,0x9f,0x12,0xf9,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0x3f,0x14,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xfe,0xff,0xff, + 0xff,0xff,0xff,0xff,0x07,0xa6,0xfe,0xff,0xff,0xff,0x5f,0x4d,0xfa,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0x40,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x09,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x4b,0xfe,0xff,0xff,0xff,0xbf, + 0x2c,0xf8,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xf5,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x43,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0x57,0xff, + 0xff,0xff,0xff,0x5f,0x0a,0xfe,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x89,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xd5,0xa9,0xff,0xff,0xff,0xff,0xaf,0x5a,0xfc,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa3,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x81,0x95,0xff,0xff,0xff,0xff,0x9f,0x06,0xfd,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xca,0xa5,0xff,0xff,0xff,0xff, + 0x2f,0x95,0xfc,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe0,0xea, + 0xff,0xff,0xff,0xff,0xaf,0x26,0xfe,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd5,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xf5,0xf4,0xff,0xff,0xff,0xff,0xaf,0x86,0xfe,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc1,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0x70,0xe5,0xff,0xff,0xff,0xff,0x4f,0x2e,0xfe, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xeb,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xb2,0xfa,0xff,0xff,0xff, + 0xff,0x57,0x83,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xf3,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x78, + 0xf2,0xff,0xff,0xff,0xff,0xa7,0x22,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x5f,0x5d,0xfd,0xff,0xff,0xff,0xff,0x97,0x87,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x1f,0x3c,0xfd,0xff,0xff,0xff,0xff,0x53,0xa3, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xac,0xfe,0xff,0xff, + 0xff,0xff,0x57,0x95,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x0f, + 0x9e,0xfe,0xff,0xff,0xff,0xff,0x97,0x81,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x57,0xfe,0xff,0xff,0xff,0xff,0xa9,0xa5,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x03,0xaf,0xff,0xff,0xff,0xff,0xff,0x4b, + 0x89,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0x93,0xff,0xff, + 0xff,0xff,0xff,0x95,0xa2,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x83,0xab,0xff,0xff,0xff,0xff,0xff,0xd3,0xc8,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xff, + 0xff,0xff,0xff,0xff,0xe9,0xa5,0xff,0xff,0xff,0xff,0xff,0xa5,0xe1,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xc0,0xd5,0xff,0xff,0xff,0xff,0xff, + 0xd5,0xc8,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xea,0xea,0xff, + 0xff,0xff,0xff,0xff,0x14,0xc1,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff, + 0xff,0xe0,0xe4,0xff,0xff,0xff,0xff,0xff,0x65,0xe8,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xcf, + 0xff,0xff,0xff,0xff,0x3f,0x72,0xe9,0xff,0xff,0xff,0xff,0xff,0x6a,0xe1,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xef,0xff,0xff,0xff,0xff,0xbf,0xb8,0xfa,0xff,0xff,0xff,0xff, + 0xff,0x52,0xea,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd3,0xff,0xff,0xff,0xff,0x1f,0x7a,0xf5, + 0xff,0xff,0xff,0xff,0x7f,0x2a,0xe0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xeb,0xff,0xff,0xff, + 0xff,0x8f,0x58,0xfa,0xff,0xff,0xff,0xff,0x7f,0x25,0xf5,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xb5,0xff,0xff,0xdf,0xff,0x57,0x5e,0xfd,0xff,0xff,0xff,0xff,0xff,0x34,0xe0, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xca,0xff,0xff,0x8f,0xff,0x07,0xac,0xfc,0xff,0xff,0xff, + 0xff,0x7f,0x2a,0xf5,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd4,0xff,0xff,0x57,0xff,0x2b,0x2d, + 0xfd,0xff,0xff,0xff,0xff,0xff,0xb2,0xf0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd2,0xff,0xff, + 0x07,0xff,0x43,0x4a,0xff,0xff,0xff,0xff,0xff,0xbf,0x2a,0xf8,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x3f,0xc5,0xff,0xff,0x2b,0xfe,0x08,0xab,0xfe,0xff,0xff,0xff,0xff,0x7f,0xaa, + 0xf2,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xbf,0xea,0xff,0xff,0x83,0x36,0x20,0x55,0xff,0xff,0xff, + 0xff,0xff,0x3f,0x15,0xf0,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0xc2,0xff,0xff,0x48,0x4a,0x85, + 0x49,0xff,0xff,0xff,0xff,0xff,0x7f,0x59,0xfa,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0xf5,0xff, + 0x7f,0x10,0x29,0x50,0xa5,0xff,0xff,0xff,0xff,0xff,0x3f,0x15,0xf9,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x97,0xe4,0xff,0x7f,0x05,0x95,0x42,0xd5,0xff,0xff,0xff,0xff,0xff,0x7f, + 0x35,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xab,0xea,0xff,0xbf,0xa0,0x24,0xa8,0xd4,0xff,0xff, + 0xff,0xff,0xff,0x7f,0x19,0xf9,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x27,0xe5,0xff,0x3f,0x92,0xaa, + 0x50,0xe9,0xff,0xff,0xff,0xff,0xff,0x9f,0x4a,0xfc,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa9,0xe2, + 0xff,0x9f,0xa0,0xaa,0x2a,0xf5,0xff,0xff,0xff,0xff,0xff,0x5f,0x1a,0xf9,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x95,0xf8,0xff,0x5f,0x4a,0x92,0x4a,0xf5,0xff,0xff,0xff,0xff,0xff, + 0xbf,0x4a,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0x52,0xf2,0xff,0x1f,0x20,0x49,0xa5,0xfa,0xff, + 0xff,0xff,0xff,0xff,0x5f,0x1a,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaa,0xf8,0xff,0x47,0xa9, + 0x2a,0x29,0xf9,0xff,0xff,0xff,0xff,0xff,0xbf,0x0a,0xfc,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x49, + 0xf2,0xff,0x17,0x92,0xaa,0xaa,0xfe,0xff,0xff,0xff,0xff,0xff,0x9f,0xac,0xfe, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x9f,0x2a,0xf8,0xff,0x43,0xa8,0x24,0x25,0xff,0xff,0xff,0xff,0xff, + 0xff,0xaf,0x0a,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x94,0xfa,0xff,0x91,0x54,0xaa,0x52,0xff, + 0xff,0xff,0xff,0xff,0xff,0x2f,0x4d,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0x45,0xfc,0xff,0x03, + 0x92,0x52,0xaa,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x06,0xfc,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf, + 0x12,0xfe,0xff,0x50,0xaa,0x2a,0x95,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0xa5, + 0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x44,0xff,0xff,0x0a,0x25,0xa5,0xa4,0xff,0xff,0xff,0xff, + 0xff,0xff,0x97,0x06,0xfc,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2b,0x15,0xff,0xff,0x40,0xa9,0x92,0xea, + 0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x55,0xfd,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xa1,0xff,0x7f, + 0x92,0x4a,0xaa,0xd4,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x06,0xfc,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x95,0x8a,0xff,0x3f,0x84,0x54,0xa9,0xea,0xff,0xff,0xff,0xff,0xff,0xff,0x2f, + 0x25,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x52,0xe0,0xff,0xbf,0x50,0xa9,0x4a,0xf2,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x8e,0xfe,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa9,0xea,0xff,0x3f,0x24,0x95,0x54, + 0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0x57,0x23,0xfe,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x4a,0xf0,0xff, + 0x9f,0x50,0x69,0x49,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x8b,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xa5,0xf4,0xff,0x0f,0x2d,0x75,0xaa,0xfa,0xff,0xff,0xff,0xff,0xff,0xff, + 0xaf,0x03,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x9f,0x14,0xfa,0xff,0x2f,0xa8,0xfa,0x25,0xfd,0xff,0xff, + 0xff,0xff,0xff,0xff,0x97,0xd7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xaa,0xfc,0xff,0x0f,0x4d,0xfd, + 0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xcf,0x83,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x12,0xfc, + 0xff,0x27,0x92,0xfe,0xcb,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xd7,0xd7,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x97,0x0a,0xff,0xff,0x83,0x56,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xef,0xc7,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xab,0x24,0xff,0xff,0x2b,0xaa,0xfe,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xe7,0xef,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x45,0xff,0xff,0x05,0x95, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xe7,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0x82, + 0xff,0xff,0x51,0xa9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xf7, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xa9,0xe8,0xff,0xff,0x85,0xca,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0x52,0xc1,0xff,0xff,0x90,0xd5,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x4d,0xe8,0xff,0xff,0xa5, + 0xe4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x51, + 0xf2,0xff,0x7f,0x40,0xd5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x3f,0x95,0xf8,0xff,0x7f,0xa9,0xea,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x15,0xfa,0xff,0x3f,0xa4,0xf4,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xa4,0xfc,0xff,0x7f, + 0x71,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f, + 0x15,0xfe,0xff,0x3f,0x94,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xa7,0x0a,0xff,0xff,0x1f,0x79,0xf2,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xab,0xa4,0xff,0xff,0x5f,0x8c,0xfa,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x53,0x82,0xff,0xff, + 0x1f,0x5c,0xfd,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xa4,0x92,0xff,0xff,0xbf,0x56,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x9a,0xc4,0xff,0xff,0x0f,0x2e,0xfd,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa2,0xf0,0xff,0xff,0xaf,0xa7,0xfe, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x55,0xe4,0xff, + 0xff,0x0f,0x57,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xbf,0x54,0xf2,0xff,0xff,0x9f,0x4b,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x9f,0x92,0xf8,0xff,0xff,0xc7,0xab,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x15,0xfe,0xff,0xff,0x97,0xd7, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xa7,0x94,0xfc, + 0xff,0xff,0xc7,0xe3,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x2f,0x05,0xfe,0xff,0xff,0xcf,0xf5,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x53,0xa9,0xff,0xff,0xff,0xd3,0xeb,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x05,0xff,0xff,0xff,0xe3, + 0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x54,0xc2, + 0xff,0xff,0xff,0xeb,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x95,0xc8,0xff,0xff,0xff,0xf3,0xfa,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xd2,0xff,0xff,0xff,0xff,0xf5,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xaa,0xe0,0xff,0xff,0xff, + 0xff,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x49, + 0xf8,0xff,0xff,0xff,0xff,0xfa,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x9f,0x2a,0xf5,0xff,0xff,0xff,0xff,0xfd,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x4a,0xf8,0xff,0xff,0xff,0xff,0xfc,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x14,0xfd,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x97, + 0x4a,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xab,0x04,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x95,0x52,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x53,0x85,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x54,0xa2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x4a,0xc9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xa5,0xe0,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x94,0xe4,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x5f,0x55,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xbf,0x12,0xf9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4f,0x54,0xfa,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0x0a,0xfc, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x53,0x45,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x97,0x14,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x4b,0x45,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x54,0x82, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x4a,0xe9,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x52,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x55,0xe8,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x24, + 0xf1,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0x55,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0x24,0xf9,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0x15,0xfe,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f, + 0x49,0xfc,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x2f,0x95,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x5f,0x01,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x2f,0xd5,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x57,0x81,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x97,0xd4,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xaf,0xe0,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x93,0xf4,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x57,0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x2b,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x89,0xfc,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x55,0xfc, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x05,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x49,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x22,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0x89, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xe5,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xc1,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xbf,0xe9,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xf2,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff, + 0xff,0xff,0xff,0x9f,0xf8,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xf9,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xfc,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff, + 0x6f,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xbf,0xfe,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x3f,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff, + 0xff,0x9f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff, + 0xff,0xff,0xff,0xff,0xff,0xdf,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xef,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, + 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,284 @@ +/* XPM */ +static char *gnus[] = { +/* width height num_colors chars_per_pixel */ +" 271 273 3 1", +/* colors */ +". s thing c #bf9900", +"# s shadow c #ffcc00", +"a s None c None", +/* pixels */ +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........######aaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.............#######aaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa................######aaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..................######aaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....................#######aaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......................#######aaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........................#######aaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........................######aaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...........................######aaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa............................#######aaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..............................#######aaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..................aaaaaaaaaaaaaaaaaaaaaa...........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...............................#######aaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....................aaaaaaaaaaaaaaaaaaa...............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...............................#######aaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......................aaaaaaaaaaaaaaaa....................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa................................########aaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......................aaaaaaaaaaaaaa........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.................................#######aaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........................aaaaaaaaaaa............................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..................................########aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...........................aaaaaaaaa..............................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...................................#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.............................aaaaaaa................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....................................#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...............................aaaaa..................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......######.......................#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa................................aaaa...................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#######aa....................#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..................................aa.....................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaa.................#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....................................a......................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaa................#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.............................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaa...............#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..............................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaa...............#######aaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa................................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaa..............#######aaaaa", +"aaaaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..................................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaa..............#######aaaaa", +"aaaaaaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....................................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaa.............#######aaaaa", +"aaaaaaaa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaa..............####....................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaa............########aaaaa", +"aaaaaaa.........aaaaaaaaaaaaaaaaaaaaaaaaaaa.............########...................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a#######aaaaaaaaaaaaaa...........########aaaaa", +"aaaaaaa...........aaaaaaaaaaaaaaaaaaaaaaa.............############..................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaa...........########aaaaa", +"aaaaaaaa..........aaaaaaaaaaaaaaaaaaaaaa.............##############..................................................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaa...........########aaaaa", +"aaaaaaaa...........aaaaaaaaaaaaaaaaaaaa............##################.......................##########................................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaa..........########aaaaa", +"aaaaaaaa............aaaaaaaaaaaaaaaaaa............####################....................###############..............................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaa#####aaaaaaaaaaaaaaaaa..........#######aaaaaa", +"aaaaaaaa............aaaaaaaaaaaaaaaa..............#####################.................#####################..........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..aaaaaa..aaaaa###aaaaaaaaaaaaaaaaaa..........#######aaaaaa", +"aaaaaaaa.............aaaaaaaaaaaaaa..............#######################...............#######################..........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..aaaaaa..aaaaa##aaaaaaaaaaaaaaaaaaa..........#######aaaaaa", +"aaaaaaaaa.............aaaaaaaaaaa...............##########aa#############.............#########################..........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaa##aaaaaaaaaaaaaaaaaaa..........#######aaaaaa", +"aaaaaaaaa.............aaaaaaaaa................#########aaaaaaa###########............##########################..........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........########aaaaaa", +"aaaaaaaaa................aaaa..................#######aaaaaaaaaa###########..........############################..........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........########aaaaaa", +"aaaaaaaaa.....................................######aaaaaaaaaaaaa###########.........#############################..........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........########aaaaaa", +"aaaaaaaaa....................................######aaaaaaaaaaaaaaaa#########........###############################.........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........########aaaaaa", +"aaaaaaaaaa.................................#######aaaaaaaaaaaaaaaaaa#########.......#######aaaaaaaaaaa##############..........................aaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#######aaaaaaa", +"aaaaaaaaaa................................#######aaaaaaaaaaaaaaaaaaaa########......#####aaaaaaaaaaaaaaaaa############..........................aaaaaaaaaaaaaaaaaaaaaaaaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#######aaaaaaa", +"aaaaaaaaaa...............................########aaaaaaaaaaaaaaaaaaaaa########....#####aaaaaaaaaaaaaaaaaaaaa##########..........................aaaaaaaaaaaaaaaaaaaaaaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....a#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#######aaaaaaa", +"aaaaaaaaa#..............................########aaaaaaaaaaaaaaaaaaaaaaaa#.####...#####aaaaaaaaaaaaaaaaaaaaaaa##########...........................aaaaaaaaaaaaaaaaaaaa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#######aaaaaaa", +"aaaaaaaaa#.............................########aaaaaaaaaaaaaaaaaaaaaaaaa...###..######aaaaaaaaaaaaaaaaaaaaaaaa##########...........................aaaaaaaaaaaaaaaaaaa......a#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....a####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........########aaaaaaa", +"aaaaaaaa###...........................#########aaaaaaaaaaaaaaaaaaaaaaaa....##########aaaaaaaaaaaaaaaaaaaaaaaaaa##########............................aaaaaaaaaaaaaaa........##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........########aaaaaaa", +"aaaaaaaa###..........................#########aaaaaaaaaaaaaaaaaaaaaaaaa....#########aaaaaaaaaaaaaaaaaaaaaaaaaaaa##########...............................aaaaaaaa...........##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........########aaaaaaa", +"aaaaaaaa###.........................#########aaaaaaaaaaaaaaaaaaaaaaaaa....a#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaa##########................................................##aaaaaa...aaaaaaaaaaaaaaaaaaaaa......a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaa", +"aaaaaaa####........................#########aaaaaaaaaaaaaaaaaaaaaaaaa....aaa#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########...............................................##aaaaaa....aaaaaaaaaaaaaaaaaaa.......a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaa", +"aaaaaaa####.......................########aaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########..............................................##aaaaa.....aaaaaaaaaaaaaaaaaa.......a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaa", +"aaaaaa######....................#########aaaaaaaaaaaaaaaaaaaaaaaaaa.....a#aaa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########............................................##aaaaaa......aaaaaaaaaaaaaaa.........a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaa", +"aaaaaa######...................#########aaaaaaaaaaaaaaaaaaaaaaaaaa......##aaa####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########...........................................##aaaaa.......aaaaaaaaaaaaa..........aa####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaa", +"aaaaaa#######.................#########aaaaaaaaaaaaaaaaaaaaaaaaaaa.....a###aaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########.........................................###aaaaa.........aaaaaaa..............a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........########aaaaaaaa", +"aaaaaaa#######...............#########aaaaaaaaaaaaaaaaaaaaaaaaaaa.....a####aaa##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########........................................##aaaaa...............................a####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaaa", +"aaaaaaa########............##########aaaaaaaaaaaaaaaaaaaaaaaaaaa.....a####aaaa#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########.......................................##aaaaa...............................#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaaa", +"aaaaaaaa##########.......###########aaaaaaaaaaaaaaaaaaaaaaaaaaa......#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########.....................................###aaaaa..............................#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#######aaaaaaaaa", +"aaaaaaaaa##########################aaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########....................................##aaaaa...............................#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........########aaaaaaaaa", +"aaaaaaaaa#########################aaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########..................................###aaaaa..............................#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#######aaaaaaaaaa", +"aaaaaaaaaa#######################aaaaaaaaaaaaaaaaaaaaaaaaaaaa.....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########...............................####aaaaa..............................######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#######aaaaaaaaaa", +"aaaaaaaaaaa#####################aaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########.............................#####aaaaa.............................#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#######aaaaaaaaaa", +"aaaaaaaaaaa###################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########...........................######aaaa..............................######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......########aaaaaaaaaa", +"aaaaaaaaaaaa#################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########.........................######aaaaa.............................#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#######aaaaaaaaaaa", +"aaaaaaaaaaaaa###############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaa#########.......................#######aaaa.............................#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#######aaaaaaaaaaa", +"aaaaaaaaaaaaaaa###########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aaaaaaaaaaaaaaaa#########....................#########aaaa............................########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a#######aaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......aaaaaaaaaaaaaaaa#########..................#########aaaaa..........................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#######aaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........aaaaaaaaaaaaaaa###########.............###########aaaaa.........................##########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#######aaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa............aaaaaaaaaaaaaaa##############....###############aaaaaaa.......................##########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a#######aaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.............aaaaaaaaaaaaaaa##############################aaaaaaaaa.....................############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...............aaaaaaaaaaaaaaa############################aaaaaaaaaaa...................############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aaaaaaaa................aaaaaaaaaaaaaaaa##########################aaaaaaaaaaaa#................#############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#######aaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaaaaa.................aaaaaaaaaaaaaaaa########################aaaaaaaaaaaaa##..............#############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaa...................aaaaaaaaaaaaaaaa######################aaaaaaaaaaaaa#####.........###############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaa....................aaaaaaaaaaaaaaaaa###################aaaaaaaaaaaaaaa########..##################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaaaaa....................aaaaaaaaaaaaaaaaaaa################aaaaaaaaaaaaaaaa###########################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......aaaaa......................aaaaaaaaaaaaaaaaaaaaa###########aaaaaaaaaaaaaaaaaa##########################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a####aaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......aaaaa.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa########################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaaa.......aaaaaa.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaa........a###a.........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa####################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a####aaaaaaaaaaaaaaaaaaaaaaaaaaaa........a####a.........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#####aaaaaaaaaaaaaaaaaaaaaaaaaaa........a#####aaa.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....a####aaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaa#.....................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a####aaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaa##....................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaa..........######aaaaa#####..................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a####aaaaaaaaaaaaaaaaaaaaaaaaa...........#####aaaaa#######..................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....####aaaaaaaaaaaaaaaaaaaaaaaaa...........#####aaaaaa#######..................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....####aaaaaaaaaaaaaaaaaaaaaaaaa...........######aaaaa#########.................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....####aaaaaaaaaaaaaaaaaaaaaaaa...........######aaaaa###########................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....####aaaaaaaaaaaaaaaaaaaaaaa............#######aaaaaaa##########...............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......####aaaaaaaaaaaaaaaaaaaaaa............#######aaaaaaaaa#########...............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....####aaaaaaaaaaaaaaaaaaaaaa............#######aaaaaaaaaaaa########..............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......###aaaaaaaaaaaaaaaaaaaaa............#########aaaaaaaaaaaaa#######..............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......###aaaaaaaaaaaaaaaaaaa.............#########aaaaaaaaaaaaaaa#######.............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#aaaaaaaaaaaaaaaaaaa.............#########aaaaaaaaaaaaaaaaa######.............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#aaaaaaaaaaaaaaaaa..............#########aaaaaaaaaaaaaaaaaaa#####.............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#aaaaaaaaaaaaaaa...............#########aaaaaaaaaaaaaaaaaaaa#####.............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#####aaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...........aaaaaaaaaaaaa...............#########aaaaaaaaaaaaaaaaaaaaaa#####............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...............aaaaa..................########aaaaaaaaaaaaaaaaaaaaaaaaa####............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......................................########aaaaaaaaaaaaaaaaaaaaaaaaaa####...........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#####aaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....................................########aaaaaaaaaaaaaaaaaaaaaaaaaaaa###...........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa####aaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....................................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaa####..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaa#####aaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...................................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#####aaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...................................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#####aaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.................................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa####aaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa................................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaa#####aaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa................................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#####aaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..............................##########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#####aaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.............................##########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#.........#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa####aaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa............................##########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#.........#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaa#####aaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...........................#########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#.........#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aaa#####aaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........................##########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#........##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa####aaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......................###########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#........##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#...................############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#........#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##................#############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#.......##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###............##############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#......###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa####.........###############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#......###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######..###################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#.....###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#########################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#.....###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#######a.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa########################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#.....###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#....####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#######a......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##################aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#....###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##############aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#...####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###########aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##..####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa######aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....a#aaaaaaaaaaaaaaaaaaaaaa#aaaaaaaaaaaaa#######aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#aaaaaaaaaaaaaaaaaaaaaa###aaaaaaaaaaaa#######aa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......#aaaaaaaaaaaaaaaaaaaaa#####aaaaaaaaaa########a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......#aaaaaaaaaaaaaaaaaaaaa#####aaaaaaaaa########a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#aaaaaaaaaaaaaaaaaaaa#######aaaaaaa#########a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......##aaaaaaaaaaaaaaaaaaa########a..aa##########a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........##aaaaaaaaaaaaaaaaaa#########....##########a........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#aaaaaaaaaaaaaaaaaa#########......#########........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#aaaaaaaaaaaaaaaaaa#########......########a........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........##aaaaaaaaaaaaaaaaa#########.......#######.........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........##aaaaaaaaaaaaaaaaa########.........#####.........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........###aaaaaaaaaaaaaaaa########........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........###aaaaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........###aaaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........####aaaaaaaaaaaaaaa#########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaa#########......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaa#########......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaa#########......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......a######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaa#######........................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......aa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaa########.......................aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......a#######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaa#######.........a..............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaa#######a........aaa............aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....aa######aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaa#######........aaaaa..........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaa#######a.......aaaaaaa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....aaa#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaa######a........aaaaaaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaa#######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaa#######........aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..aaaaaa##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaa#######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aaaaaa##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaa#######.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaa######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaa#######a......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaa#######.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaa#######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaa#######.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaa#######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaa######aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaaa######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaa######aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaa######a.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaa#####aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaa####aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaa#####aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaa####aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaa####aa.......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaa###aaa......aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaa####aaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaaaaaaa####aaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaa###aaa.....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaa###aaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaaaaaaaa####aaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaa###aaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaa###aaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaa##aaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaa#aaaaa....aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa........#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.......#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa......#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa....#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa...#####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..a####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa..a####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.a####aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.aa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa###aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa##aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa#aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", +"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +}; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/hex-util.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,74 @@ +;;; 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) + +;;; arch-tag: fe8aaa79-6c86-400e-813f-5a8cc4cb3859 +;;; hex-util.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/html2text.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,550 @@ +;;; 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) + (delete-region (match-beginning 0) (match-end 0))))) + +(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> +;; + +;;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e +;;; html2text.el ends here
--- a/lisp/gnus/ietf-drums.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/ietf-drums.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ -;;; ietf-drums.el --- functions for parsing RFC822bis headers -;; Copyright (C) 1998, 1999, 2000, 2002 +;;; ietf-drums.el --- Functions for parsing RFC822bis headers +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -64,10 +64,14 @@ (modify-syntax-entry ?> ")" table) (modify-syntax-entry ?@ "w" table) (modify-syntax-entry ?/ "w" table) - (modify-syntax-entry ?= " " table) (modify-syntax-entry ?* " " table) (modify-syntax-entry ?\; " " table) (modify-syntax-entry ?\' " " table) + (if (featurep 'xemacs) + (let ((i 128)) + (while (< i 256) + (modify-syntax-entry i "w" table) + (setq i (1+ i))))) table)) (defun ietf-drums-token-to-list (token) @@ -129,7 +133,7 @@ (forward-sexp 1)) ((eq c ?\() (forward-sexp 1)) - ((memq c '(?\ ?\t ?\n)) + ((memq c '(? ?\t ?\n)) (delete-char 1)) (t (forward-char 1)))) @@ -200,25 +204,38 @@ (defun ietf-drums-parse-addresses (string) "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs." - (with-temp-buffer - (ietf-drums-init string) - (let ((beg (point)) - pairs c) - (while (not (eobp)) - (setq c (char-after)) - (cond - ((memq c '(?\" ?< ?\()) - (forward-sexp 1)) - ((eq c ?,) - (push (ietf-drums-parse-address (buffer-substring beg (point))) - pairs) - (forward-char 1) - (setq beg (point))) - (t - (forward-char 1)))) - (push (ietf-drums-parse-address (buffer-substring beg (point))) - pairs) - (nreverse pairs)))) + (if (null string) + nil + (with-temp-buffer + (ietf-drums-init string) + (let ((beg (point)) + pairs c address) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((memq c '(?\" ?< ?\()) + (condition-case nil + (forward-sexp 1) + (error + (skip-chars-forward "^,")))) + ((eq c ?,) + (setq address + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil))) + (if address (push address pairs)) + (forward-char 1) + (setq beg (point))) + (t + (forward-char 1)))) + (setq address + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil))) + (if address (push address pairs)) + (nreverse pairs))))) (defun ietf-drums-unfold-fws () "Unfold folding white space in the current buffer."
--- a/lisp/gnus/imap.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/imap.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Simon Josefsson <jas@pdc.kth.se> @@ -125,6 +125,7 @@ ;; o Don't use `read' at all (important places already fixed) ;; o Accept list of articles instead of message set string in most ;; imap-message-* functions. +;; o Send strings as literal if they contain, e.g., ". ;; ;; Revision history: ;; @@ -152,6 +153,7 @@ (autoload 'utf7-decode "utf7") (autoload 'format-spec "format-spec") (autoload 'format-spec-make "format-spec") + (autoload 'open-tls-stream "tls") ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These ;; days we have point-at-eol anyhow. (if (fboundp 'point-at-eol) @@ -178,7 +180,12 @@ :group 'imap :type '(repeat string)) -(defcustom imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s") +(defcustom imap-gssapi-program (list + (concat "gsasl --client --connect %s:%p " + "--imap --application-data " + "--mechanism GSSAPI " + "--authentication-id %l") + "imtest -m gssapi -u %l -p %p %s") "List of strings containing commands for GSSAPI (krb5) authentication. %s is replaced with server hostname, %p with port to connect to, and %l with the value of `imap-default-user'. The program should accept @@ -213,26 +220,67 @@ :group 'imap :type '(repeat string)) -(defvar imap-shell-host "gateway" - "Hostname of rlogin proxy.") +(defcustom imap-process-connection-type nil + "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL. +The `process-connection-type' variable control type of device +used to communicate with subprocesses. Values are nil to use a +pipe, or t or `pty' to use a pty. The value has no effect if the +system has no ptys or if all ptys are busy: then a pipe is used +in any case. The value takes effect when a IMAP server is +opened, changing it after that has no effect.." + :group 'imap + :type 'boolean) + +(defcustom imap-use-utf7 t + "If non-nil, do utf7 encoding/decoding of mailbox names. +Since the UTF7 decoding currently only decodes into ISO-8859-1 +characters, you may disable this decoding if you need to access UTF7 +encoded mailboxes which doesn't translate into ISO-8859-1." + :group 'imap + :type 'boolean) + +(defcustom imap-log nil + "If non-nil, a imap session trace is placed in *imap-log* buffer." + :group 'imap + :type 'boolean) -(defvar imap-default-user (user-login-name) - "Default username to use.") +(defcustom imap-debug nil + "If non-nil, random debug spews are placed in *imap-debug* buffer." + :group 'imap + :type 'boolean) + +(defcustom imap-shell-host "gateway" + "Hostname of rlogin proxy." + :group 'imap + :type 'string) -(defvar imap-error nil - "Error codes from the last command.") +(defcustom imap-default-user (user-login-name) + "Default username to use." + :group 'imap + :type 'string) + +(defcustom imap-read-timeout (if (string-match + "windows-nt\\|os/2\\|emx\\|cygwin" + (symbol-name system-type)) + 1.0 + 0.1) + "*How long to wait between checking for the end of output. +Shorter values mean quicker response, but is more CPU intensive." + :type 'number + :group 'imap) ;; Various variables. (defvar imap-fetch-data-hook nil "Hooks called after receiving each FETCH response.") -(defvar imap-streams '(gssapi kerberos4 starttls ssl network shell) +(defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell) "Priority of streams to consider when opening connection to server.") (defvar imap-stream-alist '((gssapi imap-gssapi-stream-p imap-gssapi-open) (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open) + (tls imap-tls-p imap-tls-open) (ssl imap-ssl-p imap-ssl-open) (network imap-network-p imap-network-open) (shell imap-shell-p imap-shell-open) @@ -242,7 +290,7 @@ \(NAME CHECK OPEN) NAME names the stream, CHECK is a function returning non-nil if the -server supports the stream and OPEN is a function for opening the +server support the stream and OPEN is a function for opening the stream.") (defvar imap-authenticators '(gssapi @@ -268,16 +316,14 @@ the server support the authenticator and AUTHENTICATE is a function for doing the actual authentication.") -(defvar imap-use-utf7 t - "If non-nil, do utf7 encoding/decoding of mailbox names. -Since the UTF7 decoding currently only decodes into ISO-8859-1 -characters, you may disable this decoding if you need to access UTF7 -encoded mailboxes which doesn't translate into ISO-8859-1.") +(defvar imap-error nil + "Error codes from the last command.") ;; Internal constants. Change theese and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) +(defconst imap-default-tls-port 993) (defconst imap-default-stream 'network) (defconst imap-coding-system-for-read 'binary) (defconst imap-coding-system-for-write 'binary) @@ -301,6 +347,8 @@ imap-process imap-calculate-literal-size-first imap-mailbox-data)) +(defconst imap-log-buffer "*imap-log*") +(defconst imap-debug-buffer "*imap-debug*") ;; Internal variables. @@ -368,38 +416,31 @@ "Non-nil indicates that the server emitted a continuation request. The actual value is really the text on the continuation line.") -(defvar imap-log nil - "Name of buffer for imap session trace. -For example: (setq imap-log \"*imap-log*\")") - -(defvar imap-debug nil ;"*imap-debug*" - "Name of buffer for random debug spew. -For example: (setq imap-debug \"*imap-debug*\")") +(defvar imap-callbacks nil + "List of response tags and callbacks, on the form `(number . function)'. +The function should take two arguments, the first the IMAP tag and the +second the status (OK, NO, BAD etc) of the command.") ;; Utility functions: +(defun imap-remassoc (key alist) + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member +of LIST has a car that is `equal' to KEY, there is no way to remove it +by side effect; therefore, write `(setq foo (remassoc key foo))' to be +sure of changing the value of `foo'." + (when alist + (if (equal key (caar alist)) + (cdr alist) + (setcdr alist (imap-remassoc key (cdr alist))) + alist))) + (defsubst imap-disable-multibyte () "Enable multibyte in the current buffer." (when (fboundp 'set-buffer-multibyte) (set-buffer-multibyte nil))) -(defun imap-read-passwd (prompt &rest args) - "Read a password using PROMPT. -If ARGS, PROMPT is used as an argument to `format'." - (let ((prompt (if args - (apply 'format prompt args) - prompt))) - (funcall (if (or (fboundp 'read-passwd) - (and (load "subr" t) - (fboundp 'read-passwd)) - (and (load "passwd" t) - (fboundp 'read-passwd))) - 'read-passwd - (autoload 'ange-ftp-read-passwd "ange-ftp") - 'ange-ftp-read-passwd) - prompt))) - (defsubst imap-utf7-encode (string) (if imap-use-utf7 (and string @@ -447,6 +488,7 @@ (let* ((port (or port imap-default-port)) (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) + (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch (format-spec @@ -461,9 +503,17 @@ (setq imap-client-eol "\n" imap-calculate-literal-size-first t) (while (and (memq (process-status process) '(open run)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) - ;; cyrus 1.6.x (13? < x <= 22) queries capabilities - (or (while (looking-at "^C:") + ;; Athena IMTEST can output SSL verify errors + (or (while (looking-at "^verify error:num=") + (forward-line)) + t) + (or (while (looking-at "^TLS connection established") + (forward-line)) + t) + ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + (or (while (looking-at "^C:") (forward-line)) t) ;; cyrus 1.6 imtest print "S: " before server greeting @@ -481,7 +531,7 @@ (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -493,7 +543,7 @@ (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) + (imap-send-command "LOGOUT")) (delete-process process) nil))))) done)) @@ -506,9 +556,11 @@ cmd done) (while (and (not done) (setq cmd (pop cmds))) (message "Opening GSSAPI IMAP connection with `%s'..." cmd) + (erase-buffer) (let* ((port (or port imap-default-port)) (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) + (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch (format-spec @@ -520,11 +572,13 @@ response) (when process (with-current-buffer buffer - (setq imap-client-eol "\n") + (setq imap-client-eol "\n" + imap-calculate-literal-size-first t) (while (and (memq (process-status process) '(open run)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) - ;; cyrus 1.6.x (13? < x <= 22) queries capabilities - (or (while (looking-at "^C:") + ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + (or (while (looking-at "^C:") (forward-line)) t) ;; cyrus 1.6 imtest print "S: " before server greeting @@ -534,12 +588,15 @@ (not (and (imap-parse-greeting) ;; success in imtest 1.6: (re-search-forward - "^\\(Authenticat.*\\)" nil t) + (concat "^\\(\\(Authenticat.*\\)\\|\\(" + "Client authentication " + "finished.*\\)\\)") + nil t) (setq response (match-string 1))))) (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -550,7 +607,7 @@ (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) + (imap-send-command "LOGOUT")) (delete-process process) nil))))) done)) @@ -565,16 +622,17 @@ cmd done) (while (and (not done) (setq cmd (pop cmds))) (message "imap: Opening SSL connection with `%s'..." cmd) + (erase-buffer) (let* ((port (or port imap-default-ssl-port)) (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) (process-connection-type nil) process) (when (progn - (setq process (start-process + (setq process (start-process name buffer shell-file-name shell-command-switch - (format-spec cmd + (format-spec cmd (format-spec-make ?s server ?p (number-to-string port))))) @@ -590,7 +648,7 @@ (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -602,9 +660,34 @@ (progn (message "imap: Opening SSL connection with `%s'...done" cmd) done) - (message "imap: Opening SSL connection with `%s'...failed" cmd) + (message "imap: Opening SSL connection with `%s'...failed" cmd) nil))) +(defun imap-tls-p (buffer) + nil) + +(defun imap-tls-open (name buffer server port) + (let* ((port (or port imap-default-tls-port)) + (coding-system-for-read imap-coding-system-for-read) + (coding-system-for-write imap-coding-system-for-write) + (process (open-tls-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-max)) + (forward-line -1) + (not (imap-parse-greeting))) + (accept-process-output process 1) + (sit-for 1)) + (and imap-log + (with-current-buffer (get-buffer-create imap-log-buffer) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer))) + (when (memq (process-status process) '(open run)) + process)))) + (defun imap-network-p (buffer) t) @@ -615,12 +698,13 @@ (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 (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -632,7 +716,8 @@ nil) (defun imap-shell-open (name buffer server port) - (let ((cmds imap-shell-program) + (let ((cmds (if (listp imap-shell-program) imap-shell-program + (list imap-shell-program))) cmd done) (while (and (not done) (setq cmd (pop cmds))) (message "imap: Opening IMAP connection with `%s'..." cmd) @@ -651,68 +736,66 @@ ?l imap-default-user))))) (when process (while (and (memq (process-status process) '(open run)) - (goto-char (point-min)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug + (goto-char (point-max)) + (forward-line -1) (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (erase-buffer) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring buffer))) + (erase-buffer) (when (memq (process-status process) '(open run)) (setq done process))))) (if done (progn (message "imap: Opening IMAP connection with `%s'...done" cmd) done) - (message "imap: Opening IMAP connection with `%s'...failed" cmd) + (message "imap: Opening IMAP connection with `%s'...failed" cmd) nil))) (defun imap-starttls-p (buffer) - (and (imap-capability 'STARTTLS buffer) - (condition-case () - (progn - (require 'starttls) - (call-process "starttls")) - (error nil)))) + (imap-capability 'STARTTLS buffer)) (defun imap-starttls-open (name buffer server port) (let* ((port (or port imap-default-port)) (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) (process (starttls-open-stream name buffer server port)) - done) + done tls-info) (message "imap: Connecting with STARTTLS...") (when process (while (and (memq (process-status process) '(open run)) - (goto-char (point-min)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug + (goto-char (point-max)) + (forward-line -1) (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) + (imap-send-command "STARTTLS") + (while (and (memq (process-status process) '(open run)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug + (goto-char (point-max)) + (forward-line -1) + (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) + (accept-process-output process 1) + (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring buffer))) - (let ((imap-process process)) - (unwind-protect - (progn - (set-process-filter imap-process 'imap-arrival-filter) - (when (and (eq imap-stream 'starttls) - (imap-ok-p (imap-send-command-wait "STARTTLS"))) - (starttls-negotiate imap-process))) - (set-process-filter imap-process nil))) - (when (memq (process-status process) '(open run)) + (when (and (setq tls-info (starttls-negotiate process)) + (memq (process-status process) '(open run))) (setq done process))) - (if done - (progn - (message "imap: Connecting with STARTTLS...done") - done) - (message "imap: Connecting with STARTTLS...failed") - nil))) + (if (stringp tls-info) + (message "imap: STARTTLS info: %s" tls-info)) + (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) + done)) ;; Server functions; authenticator stuff: @@ -729,12 +812,15 @@ (while (or (not user) (not passwd)) (setq user (or imap-username (read-from-minibuffer - (concat "IMAP username for " imap-server ": ") + (concat "IMAP username for " imap-server + " (using stream `" (symbol-name imap-stream) + "'): ") (or user imap-default-user)))) (setq passwd (or imap-password - (imap-read-passwd + (read-passwd (concat "IMAP password for " user "@" - imap-server ": ")))) + imap-server " (using authenticator `" + (symbol-name imap-auth) "'): ")))) (when (and user passwd) (if (funcall loginfunc user passwd) (progn @@ -745,6 +831,7 @@ (setq imap-password passwd))) (message "Login failed...") (setq passwd nil) + (setq imap-password nil) (sit-for 1)))) ;; (quit (with-current-buffer buffer ;; (setq user nil @@ -755,7 +842,7 @@ ret))) (defun imap-gssapi-auth-p (buffer) - (imap-capability 'AUTH=GSSAPI buffer)) + (eq imap-stream 'gssapi)) (defun imap-gssapi-auth (buffer) (message "imap: Authenticating using GSSAPI...%s" @@ -763,7 +850,8 @@ (eq imap-stream 'gssapi)) (defun imap-kerberos4-auth-p (buffer) - (imap-capability 'AUTH=KERBEROS_V4 buffer)) + (and (imap-capability 'AUTH=KERBEROS_V4 buffer) + (eq imap-stream 'kerberos4))) (defun imap-kerberos4-auth (buffer) (message "imap: Authenticating using Kerberos 4...%s" @@ -793,8 +881,6 @@ (message "imap: Authenticating using CRAM-MD5...done") (message "imap: Authenticating using CRAM-MD5...failed")))) - - (defun imap-login-p (buffer) (and (not (imap-capability 'LOGINDISABLED buffer)) (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) @@ -898,46 +984,53 @@ (setq imap-auth (or auth imap-auth)) (setq imap-stream (or stream imap-stream)) (message "imap: Connecting to %s..." imap-server) - (if (let ((imap-stream (or imap-stream imap-default-stream))) - (imap-open-1 buffer)) - ;; Choose stream. - (let (stream-changed) - (message "imap: Connecting to %s...done" imap-server) - (when (null imap-stream) - (let ((streams imap-streams)) - (while (setq stream (pop streams)) - (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) - (setq stream-changed (not (eq (or imap-stream - imap-default-stream) - stream)) - imap-stream stream - streams nil))) - (unless imap-stream - (error "Couldn't figure out a stream for server")))) - (when stream-changed - (message "imap: Reconnecting with stream `%s'..." imap-stream) - (imap-close buffer) - (if (imap-open-1 buffer) - (message "imap: Reconnecting with stream `%s'...done" - imap-stream) - (message "imap: Reconnecting with stream `%s'...failed" - imap-stream)) - (setq imap-capability nil)) - (if (imap-opened buffer) - ;; Choose authenticator - (when (and (null imap-auth) (not (eq imap-state 'auth))) - (let ((auths imap-authenticators)) - (while (setq auth (pop auths)) - (if (funcall (nth 1 (assq auth imap-authenticator-alist)) - buffer) - (setq imap-auth auth - auths nil))) - (unless imap-auth - (error "Couldn't figure out authenticator for server")))))) - (message "imap: Connecting to %s...failed" imap-server)) - (when (imap-opened buffer) - (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)) - buffer))) + (if (null (let ((imap-stream (or imap-stream imap-default-stream))) + (imap-open-1 buffer))) + (progn + (message "imap: Connecting to %s...failed" imap-server) + nil) + (when (null imap-stream) + ;; Need to choose stream. + (let ((streams imap-streams)) + (while (setq stream (pop streams)) + ;; OK to use this stream? + (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer) + ;; Stream changed? + (if (not (eq imap-default-stream stream)) + (with-current-buffer (get-buffer-create + (generate-new-buffer-name " *temp*")) + (mapcar 'make-local-variable imap-local-variables) + (imap-disable-multibyte) + (buffer-disable-undo) + (setq imap-server (or server imap-server)) + (setq imap-port (or port imap-port)) + (setq imap-auth (or auth imap-auth)) + (message "imap: Reconnecting with stream `%s'..." stream) + (if (null (let ((imap-stream stream)) + (imap-open-1 (current-buffer)))) + (progn + (kill-buffer (current-buffer)) + (message + "imap: Reconnecting with stream `%s'...failed" + stream)) + ;; We're done, kill the first connection + (imap-close buffer) + (kill-buffer buffer) + (rename-buffer buffer) + (message "imap: Reconnecting with stream `%s'...done" + stream) + (setq imap-stream stream) + (setq imap-capability nil) + (setq streams nil))) + ;; We're done + (message "imap: Connecting to %s...done" imap-server) + (setq imap-stream stream) + (setq imap-capability nil) + (setq streams nil)))))) + (when (imap-opened buffer) + (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) + (when imap-stream + buffer)))) (defun imap-opened (&optional buffer) "Return non-nil if connection to imap server in BUFFER is open. @@ -964,16 +1057,36 @@ (make-local-variable 'imap-password) (if user (setq imap-username user)) (if passwd (setq imap-password passwd)) - (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer) - (setq imap-state 'auth))))) + (if imap-auth + (and (funcall (nth 2 (assq imap-auth + imap-authenticator-alist)) buffer) + (setq imap-state 'auth)) + ;; Choose authenticator. + (let ((auths imap-authenticators) + auth) + (while (setq auth (pop auths)) + ;; OK to use authenticator? + (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer) + (message "imap: Authenticating to `%s' using `%s'..." + imap-server auth) + (setq imap-auth auth) + (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer) + (progn + (message "imap: Authenticating to `%s' using `%s'...done" + imap-server auth) + (setq auths nil)) + (message "imap: Authenticating to `%s' using `%s'...failed" + imap-server auth))))) + imap-state)))) (defun imap-close (&optional buffer) "Close connection to server in BUFFER. If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) - (and (imap-opened) - (not (imap-ok-p (imap-send-command-wait "LOGOUT"))) - (message "Server %s didn't let me log out" imap-server)) + (when (imap-opened) + (condition-case nil + (imap-send-command-wait "LOGOUT") + (quit nil))) (when (and imap-process (memq (process-status imap-process) '(open run))) (delete-process imap-process)) @@ -1105,22 +1218,38 @@ imap-state 'auth) t))) -(defun imap-mailbox-expunge (&optional buffer) +(defun imap-mailbox-expunge (&optional asynch buffer) "Expunge articles in current folder in BUFFER. +If ASYNCH, do not wait for succesful completion of the command. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when (and imap-current-mailbox (not (eq imap-state 'examine))) - (imap-ok-p (imap-send-command-wait "EXPUNGE"))))) + (if asynch + (imap-send-command "EXPUNGE") + (imap-ok-p (imap-send-command-wait "EXPUNGE")))))) -(defun imap-mailbox-close (&optional buffer) +(defun imap-mailbox-close (&optional asynch buffer) "Expunge articles and close current folder in BUFFER. +If ASYNCH, do not wait for succesful completion of the command. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) - (when (and imap-current-mailbox - (imap-ok-p (imap-send-command-wait "CLOSE"))) - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth) + (when imap-current-mailbox + (if asynch + (imap-add-callback (imap-send-command "CLOSE") + `(lambda (tag status) + (message "IMAP mailbox `%s' closed... %s" + imap-current-mailbox status) + (when (eq ,imap-current-mailbox + imap-current-mailbox) + ;; Don't wipe out data if another mailbox + ;; was selected... + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth)))) + (when (imap-ok-p (imap-send-command-wait "CLOSE")) + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth))) t))) (defun imap-mailbox-create-1 (mailbox) @@ -1225,16 +1354,31 @@ (imap-send-command-wait (list "STATUS \"" (imap-utf7-encode mailbox) "\" " - (format "%s" - (if (listp items) - items - (list items)))))) + (upcase + (format "%s" + (if (listp items) + items + (list items))))))) (if (listp items) (mapcar (lambda (item) (imap-mailbox-get item mailbox)) items) (imap-mailbox-get items mailbox))))) +(defun imap-mailbox-status-asynch (mailbox items &optional buffer) + "Send status item request ITEM on MAILBOX to server in BUFFER. +ITEMS can be a symbol or a list of symbols, valid symbols are one of +the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity +or 'unseen. The IMAP command tag is returned." + (with-current-buffer (or buffer (current-buffer)) + (imap-send-command (list "STATUS \"" + (imap-utf7-encode mailbox) + "\" " + (format "%s" + (if (listp items) + items + (list items))))))) + (defun imap-mailbox-acl-get (&optional mailbox buffer) "Get ACL on mailbox from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) @@ -1286,8 +1430,8 @@ (mapconcat (lambda (item) (if (consp item) - (format "%d:%d" - (car item) (cdr item)) + (format "%d:%d" + (car item) (cdr item)) (format "%d" item))) (if (and (listp range) (not (listp (cdr range)))) (list range) ;; make (1 . 2) into ((1 . 2)) @@ -1398,7 +1542,9 @@ (imap-mailbox-put 'search 'dummy) (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) - (error "Missing SEARCH response to a SEARCH command") + (progn + (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...") + nil) (imap-mailbox-get-1 'search imap-current-mailbox))))) (defun imap-message-flag-permanent-p (flag &optional mailbox buffer) @@ -1464,8 +1610,11 @@ (if (imap-ok-p (imap-send-command-wait cmd)) t (when (and (not dont-create) - (imap-mailbox-get-1 'trycreate mailbox)) - (imap-mailbox-create-1 mailbox) + ;; removed because of buggy Oracle server + ;; that doesn't send TRYCREATE tags (which + ;; is a MUST according to specifications): + ;;(imap-mailbox-get-1 'trycreate mailbox) + (imap-mailbox-create-1 mailbox)) (imap-ok-p (imap-send-command-wait cmd))))) (or no-copyuid (imap-message-copyuid-1 mailbox))))))) @@ -1530,10 +1679,13 @@ ;; Internal functions. +(defun imap-add-callback (tag func) + (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) + (defun imap-send-command-1 (cmdstr) (setq cmdstr (concat cmdstr imap-client-eol)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -1570,14 +1722,14 @@ (imap-send-command-1 cmdstr) (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil);; abort command if no cont-req + (setq command nil) ;; abort command if no cont-req (let ((process imap-process) (stream imap-stream) (eol imap-client-eol)) (with-current-buffer cmd (and imap-log (with-current-buffer (get-buffer-create - imap-log) + imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -1591,7 +1743,7 @@ (setq cmdstr nil) (unwind-protect (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil);; abort command if no cont-req + (setq command nil) ;; abort command if no cont-req (setq command (cons (funcall cmd imap-continuation) command))) (setq imap-continuation nil))) @@ -1603,15 +1755,34 @@ (defun imap-wait-for-tag (tag &optional buffer) (with-current-buffer (or buffer (current-buffer)) - (while (and (null imap-continuation) - (< imap-reached-tag tag)) - (or (and (not (memq (process-status imap-process) '(open run))) - (sit-for 1)) - (accept-process-output imap-process 1))) - (or (assq tag imap-failed-tags) - (if imap-continuation - 'INCOMPLETE - 'OK)))) + (let (imap-have-messaged) + (while (and (null imap-continuation) + (memq (process-status imap-process) '(open run)) + (< imap-reached-tag tag)) + (let ((len (/ (point-max) 1024)) + message-log-max) + (unless (< len 10) + (setq imap-have-messaged t) + (message "imap read: %dk" len)) + (accept-process-output imap-process + (truncate imap-read-timeout) + (truncate (* (- imap-read-timeout + (truncate imap-read-timeout)) + 1000))))) + ;; A process can die _before_ we have processed everything it + ;; has to say. Moreover, this can happen in between the call to + ;; accept-process-output and the call to process-status in an + ;; iteration of the loop above. + (when (and (null imap-continuation) + (< imap-reached-tag tag)) + (accept-process-output imap-process 0 0)) + (when imap-have-messaged + (message "")) + (and (memq (process-status imap-process) '(open run)) + (or (assq tag imap-failed-tags) + (if imap-continuation + 'INCOMPLETE + 'OK)))))) (defun imap-sentinel (process string) (delete-process process)) @@ -1631,34 +1802,37 @@ (defun imap-arrival-filter (proc string) "IMAP process filter." - (with-current-buffer (process-buffer proc) - (goto-char (point-max)) - (insert string) - (and imap-log - (with-current-buffer (get-buffer-create imap-log) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert string))) - (let (end) - (goto-char (point-min)) - (while (setq end (imap-find-next-line)) - (save-restriction - (narrow-to-region (point-min) end) - (delete-backward-char (length imap-server-eol)) - (goto-char (point-min)) - (unwind-protect - (cond ((eq imap-state 'initial) - (imap-parse-greeting)) - ((or (eq imap-state 'auth) - (eq imap-state 'nonauth) - (eq imap-state 'selected) - (eq imap-state 'examine)) - (imap-parse-response)) - (t - (message "Unknown state %s in arrival filter" - imap-state))) - (delete-region (point-min) (point-max)))))))) + ;; Sometimes, we are called even though the process has died. + ;; Better abstain from doing stuff in that case. + (when (buffer-name (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (goto-char (point-max)) + (insert string) + (and imap-log + (with-current-buffer (get-buffer-create imap-log-buffer) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert string))) + (let (end) + (goto-char (point-min)) + (while (setq end (imap-find-next-line)) + (save-restriction + (narrow-to-region (point-min) end) + (delete-backward-char (length imap-server-eol)) + (goto-char (point-min)) + (unwind-protect + (cond ((eq imap-state 'initial) + (imap-parse-greeting)) + ((or (eq imap-state 'auth) + (eq imap-state 'nonauth) + (eq imap-state 'selected) + (eq imap-state 'examine)) + (imap-parse-response)) + (t + (message "Unknown state %s in arrival filter" + imap-state))) + (delete-region (point-min) (point-max))))))))) ;; Imap parser. @@ -1803,8 +1977,7 @@ (when (eq (char-after) ?\)) (imap-forward) (nreverse addresses))) - ;; (assert (imap-parse-nil)) ; With assert, the code might not be eval'd. - (imap-parse-nil))) + (assert (imap-parse-nil) t "In imap-parse-address-list"))) ;; mailbox = "INBOX" / astring ;; ; INBOX is case-insensitive. All case variants of @@ -1857,7 +2030,7 @@ ;; resp-cond-bye = "BYE" SP resp-text ;; ;; mailbox-data = "FLAGS" SP flag-list / -;; "LIST" SP mailbox-list / +;; "LIST" SP mailbox-list / ;; "LSUB" SP mailbox-list / ;; "SEARCH" *(SP nz-number) / ;; "STATUS" SP mailbox SP "(" @@ -1895,9 +2068,9 @@ (read (concat "(" (buffer-substring (point) (point-max)) ")")))) (STATUS (imap-parse-status)) (CAPABILITY (setq imap-capability - (read (concat "(" (upcase (buffer-substring - (point) (point-max))) - ")")))) + (read (concat "(" (upcase (buffer-substring + (point) (point-max))) + ")")))) (ACL (imap-parse-acl)) (t (case (prog1 (read (current-buffer)) (imap-forward)) @@ -1939,7 +2112,11 @@ (push (list token status code text) imap-failed-tags) (error "Internal error, tag %s status %s code %s text %s" token status code text)))) - (t (message "Garbage: %s" (buffer-string)))))))))) + (t (message "Garbage: %s" (buffer-string)))) + (when (assq token imap-callbacks) + (funcall (cdr (assq token imap-callbacks)) token status) + (setq imap-callbacks + (imap-remassoc token imap-callbacks))))))))) ;; resp-text = ["[" resp-text-code "]" SP] text ;; @@ -1958,7 +2135,7 @@ ;; [flag-perm *(SP flag-perm)] ")" / ;; "READ-ONLY" / ;; "READ-WRITE" / -;; "TRYCREATE" / +;; "TRYCREATE" / ;; "UIDNEXT" SP nz-number / ;; "UIDVALIDITY" SP nz-number / ;; "UNSEEN" SP nz-number / @@ -2005,14 +2182,17 @@ ;; resp-text-atom = 1*<any ATOM-CHAR except "]"> (defun imap-parse-resp-text-code () + ;; xxx next line for stalker communigate pro 3.3.1 bug + (when (looking-at " \\[") + (imap-forward)) (when (eq (char-after) ?\[) (imap-forward) (cond ((search-forward "PERMANENTFLAGS " nil t) (imap-mailbox-put 'permanentflags (imap-parse-flag-list))) - ((search-forward "UIDNEXT " nil t) - (imap-mailbox-put 'uidnext (read (current-buffer)))) + ((search-forward "UIDNEXT \\([0-9]+\\)" nil t) + (imap-mailbox-put 'uidnext (match-string 1))) ((search-forward "UNSEEN " nil t) - (imap-mailbox-put 'unseen (read (current-buffer)))) + (imap-mailbox-put 'first-unseen (read (current-buffer)))) ((looking-at "UIDVALIDITY \\([0-9]+\\)") (imap-mailbox-put 'uidvalidity (match-string 1))) ((search-forward "READ-ONLY" nil t) @@ -2111,15 +2291,19 @@ (defun imap-parse-fetch (response) (when (eq (char-after) ?\() (let (uid flags envelope internaldate rfc822 rfc822header rfc822text - rfc822size body bodydetail bodystructure) + rfc822size body bodydetail bodystructure flags-empty) (while (not (eq (char-after) ?\))) (imap-forward) (let ((token (read (current-buffer)))) (imap-forward) (cond ((eq token 'UID) - (setq uid (ignore-errors (read (current-buffer))))) + (setq uid (condition-case () + (read (current-buffer)) + (error)))) ((eq token 'FLAGS) - (setq flags (imap-parse-flag-list))) + (setq flags (imap-parse-flag-list)) + (if (not flags) + (setq flags-empty 't))) ((eq token 'ENVELOPE) (setq envelope (imap-parse-envelope))) ((eq token 'INTERNALDATE) @@ -2148,7 +2332,7 @@ (when uid (setq imap-current-message uid) (imap-message-put uid 'UID uid) - (and flags (imap-message-put uid 'FLAGS flags)) + (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags)) (and envelope (imap-message-put uid 'ENVELOPE envelope)) (and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) (and rfc822 (imap-message-put uid 'RFC822 rfc822)) @@ -2171,24 +2355,32 @@ (defun imap-parse-status () (let ((mailbox (imap-parse-mailbox))) - (when (and mailbox (search-forward "(" nil t)) - (while (not (eq (char-after) ?\))) - (let ((token (read (current-buffer)))) - (cond ((eq token 'MESSAGES) + (if (eq (char-after) ? ) + (forward-char)) + (when (and mailbox (eq (char-after) ?\()) + (while (and (not (eq (char-after) ?\))) + (or (forward-char) t) + (looking-at "\\([A-Za-z]+\\) ")) + (let ((token (match-string 1))) + (goto-char (match-end 0)) + (cond ((string= token "MESSAGES") (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) - ((eq token 'RECENT) + ((string= token "RECENT") (imap-mailbox-put 'recent (read (current-buffer)) mailbox)) - ((eq token 'UIDNEXT) - (imap-mailbox-put 'uidnext (read (current-buffer)) mailbox)) - ((eq token 'UIDVALIDITY) - (and (looking-at " \\([0-9]+\\)") - (imap-mailbox-put 'uidvalidity (match-string 1) mailbox) - (goto-char (match-end 1)))) - ((eq token 'UNSEEN) + ((string= token "UIDNEXT") + (and (looking-at "[0-9]+") + (imap-mailbox-put 'uidnext (match-string 0) mailbox) + (goto-char (match-end 0)))) + ((string= token "UIDVALIDITY") + (and (looking-at "[0-9]+") + (imap-mailbox-put 'uidvalidity (match-string 0) mailbox) + (goto-char (match-end 0)))) + ((string= token "UNSEEN") (imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) (t (message "Unknown status data %s in mailbox %s ignored" - token mailbox)))))))) + token mailbox) + (read (current-buffer))))))))) ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE ;; rights) @@ -2226,12 +2418,16 @@ (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\()) + (assert (eq (char-after) ?\() t "In imap-parse-flag-list") (while (and (not (eq (char-after) ?\))) - (setq start (progn (imap-forward) (point))) + (setq start (progn + (imap-forward) + ;; next line for Courier IMAP bug. + (skip-chars-forward " ") + (point))) (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\))) + (assert (eq (char-after) ?\)) t "In imap-parse-flag-list") (imap-forward) (nreverse flag-list))) @@ -2262,31 +2458,31 @@ (defun imap-parse-envelope () (when (eq (char-after) ?\() (imap-forward) - (vector (prog1 (imap-parse-nstring);; date + (vector (prog1 (imap-parse-nstring) ;; date (imap-forward)) - (prog1 (imap-parse-nstring);; subject + (prog1 (imap-parse-nstring) ;; subject (imap-forward)) - (prog1 (imap-parse-address-list);; from + (prog1 (imap-parse-address-list) ;; from (imap-forward)) - (prog1 (imap-parse-address-list);; sender + (prog1 (imap-parse-address-list) ;; sender (imap-forward)) - (prog1 (imap-parse-address-list);; reply-to + (prog1 (imap-parse-address-list) ;; reply-to (imap-forward)) - (prog1 (imap-parse-address-list);; to + (prog1 (imap-parse-address-list) ;; to (imap-forward)) - (prog1 (imap-parse-address-list);; cc + (prog1 (imap-parse-address-list) ;; cc (imap-forward)) - (prog1 (imap-parse-address-list);; bcc + (prog1 (imap-parse-address-list) ;; bcc (imap-forward)) - (prog1 (imap-parse-nstring);; in-reply-to + (prog1 (imap-parse-nstring) ;; in-reply-to (imap-forward)) - (prog1 (imap-parse-nstring);; message-id + (prog1 (imap-parse-nstring) ;; message-id (imap-forward))))) ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil (defsubst imap-parse-string-list () - (cond ((eq (char-after) ?\();; body-fld-param + (cond ((eq (char-after) ?\() ;; body-fld-param (let (strlist str) (imap-forward) (while (setq str (imap-parse-string)) @@ -2316,7 +2512,7 @@ (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\))) + (assert (eq (char-after) ?\)) t "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2334,7 +2530,7 @@ (defsubst imap-parse-body-ext () (let (ext) - (when (eq (char-after) ?\ );; body-fld-dsp + (when (eq (char-after) ?\ ) ;; body-fld-dsp (imap-forward) (let (dsp) (if (eq (char-after) ?\() @@ -2344,15 +2540,14 @@ (imap-forward) (push (imap-parse-string-list) dsp) (imap-forward)) - ;; (assert (imap-parse-nil)) ; Code in assert might not be eval'd. - (imap-parse-nil)) + (assert (imap-parse-nil) t "In imap-parse-body-ext")) (push (nreverse dsp) ext)) - (when (eq (char-after) ?\ );; body-fld-lang + (when (eq (char-after) ?\ ) ;; body-fld-lang (imap-forward) (if (eq (char-after) ?\() (push (imap-parse-string-list) ext) (push (imap-parse-nstring) ext)) - (while (eq (char-after) ?\ );; body-extension + (while (eq (char-after) ?\ ) ;; body-extension (imap-forward) (setq ext (append (imap-parse-body-extension) ext))))) ext)) @@ -2426,91 +2621,90 @@ (let (subbody) (while (and (eq (char-after) ?\() (setq subbody (imap-parse-body))) - ;; buggy stalker communigate pro 3.0 insert a SPC between + ;; buggy stalker communigate pro 3.0 insert a SPC between ;; parts in multiparts (when (and (eq (char-after) ?\ ) (eq (char-after (1+ (point))) ?\()) (imap-forward)) (push subbody body)) (imap-forward) - (push (imap-parse-string) body);; media-subtype - (when (eq (char-after) ?\ );; body-ext-mpart: + (push (imap-parse-string) body) ;; media-subtype + (when (eq (char-after) ?\ ) ;; body-ext-mpart: (imap-forward) - (if (eq (char-after) ?\();; body-fld-param + (if (eq (char-after) ?\() ;; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (setq body - (append (imap-parse-body-ext) body)));; body-ext-... - (assert (eq (char-after) ?\))) + (append (imap-parse-body-ext) body))) ;; body-ext-... + (assert (eq (char-after) ?\)) t "In imap-parse-body") (imap-forward) (nreverse body)) - (push (imap-parse-string) body);; media-type + (push (imap-parse-string) body) ;; media-type (imap-forward) - (push (imap-parse-string) body);; media-subtype + (push (imap-parse-string) body) ;; media-subtype (imap-forward) ;; next line for Sun SIMS bug (and (eq (char-after) ? ) (imap-forward)) - (if (eq (char-after) ?\();; body-fld-param + (if (eq (char-after) ?\() ;; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (imap-forward) - (push (imap-parse-nstring) body);; body-fld-id + (push (imap-parse-nstring) body) ;; body-fld-id (imap-forward) - (push (imap-parse-nstring) body);; body-fld-desc + (push (imap-parse-nstring) body) ;; body-fld-desc (imap-forward) ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a ;; nstring and return nil instead of defaulting back to 7BIT ;; as the standard says. - (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc + (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc (imap-forward) - (push (imap-parse-number) body);; body-fld-octets + (push (imap-parse-number) body) ;; body-fld-octets - ;; ok, we're done parsing the required parts, what comes now is one + ;; ok, we're done parsing the required parts, what comes now is one ;; of three things: ;; ;; envelope (then we're parsing body-type-msg) ;; body-fld-lines (then we're parsing body-type-text) ;; body-ext-1part (then we're parsing body-type-basic) ;; - ;; the problem is that the two first are in turn optionally followed - ;; by the third. So we parse the first two here (if there are any)... + ;; the problem is that the two first are in turn optionally followed +;; by the third. So we parse the first two here (if there are any)... (when (eq (char-after) ?\ ) (imap-forward) (let (lines) - (cond ((eq (char-after) ?\();; body-type-msg: - (push (imap-parse-envelope) body);; envelope + (cond ((eq (char-after) ?\() ;; body-type-msg: + (push (imap-parse-envelope) body) ;; envelope (imap-forward) - (push (imap-parse-body) body);; body + (push (imap-parse-body) body) ;; body ;; buggy stalker communigate pro 3.0 doesn't print ;; number of lines in message/rfc822 attachment (if (eq (char-after) ?\)) (push 0 body) (imap-forward) (push (imap-parse-number) body))) ;; body-fld-lines - ((setq lines (imap-parse-number)) ;; body-type-text: - (push lines body)) ;; body-fld-lines + ((setq lines (imap-parse-number)) ;; body-type-text: + (push lines body)) ;; body-fld-lines (t - (backward-char))))) ;; no match... + (backward-char))))) ;; no match... ;; ...and then parse the third one here... - (when (eq (char-after) ?\ );; body-ext-1part: + (when (eq (char-after) ?\ ) ;; body-ext-1part: (imap-forward) - (push (imap-parse-nstring) body);; body-fld-md5 - (setq body (append (imap-parse-body-ext) body)));; body-ext-1part.. + (push (imap-parse-nstring) body) ;; body-fld-md5 + (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - (assert (eq (char-after) ?\))) + (assert (eq (char-after) ?\)) t "In imap-parse-body 2") (imap-forward) (nreverse body))))) (when imap-debug ; (untrace-all) (require 'trace) - (buffer-disable-undo (get-buffer-create imap-debug)) - (mapcar (lambda (f) (trace-function-background f imap-debug)) + (buffer-disable-undo (get-buffer-create imap-debug-buffer)) + (mapcar (lambda (f) (trace-function-background f imap-debug-buffer)) '( - imap-read-passwd imap-utf7-encode imap-utf7-decode imap-error-text
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/important.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,32 @@ +/* XPM */ +static char *magick[] = { +/* columns rows colors chars-per-pixel */ +"24 24 2 1", +"! c red", +"w c Gray75", +/* pixels */ +"wwwwwwwwwwwwwwwwwwwwwwww", +"wwwwwwwwwwwwwwwwwwwwwwww", +"wwwwwwwww!!!wwwwwwwwwwww", +"wwwwwwwww!!!wwwwwwwwwwww", +"wwwwwwww!!!!!wwwwwwwwwww", +"wwwwwwww!!!!!wwwwwwwwwww", +"wwwwwww!!!!!!!wwwwwwwwww", +"wwwwwww!!!!!!!wwwwwwwwww", +"wwwwwww!!!!!!!wwwwwwwwww", +"wwwwwww!!!!!!!wwwwwwwwww", +"wwwwwww!!!!!!!wwwwwwwwww", +"wwwwwww!!!!!!!wwwwwwwwww", +"wwwwwww!!!!!!!wwwwwwwwww", +"wwwwwwww!!!!!wwwwwwwwwww", +"wwwwwwww!!!!!wwwwwwwwwww", +"wwwwwwww!!!!!wwwwwwwwwww", +"wwwwwwwww!!!wwwwwwwwwwww", +"wwwwwwwwwwwwwwwwwwwwwwww", +"wwwwwwwww!!!wwwwwwwwwwww", +"wwwwwwww!!!!!wwwwwwwwwww", +"wwwwwwww!!!!!wwwwwwwwwww", +"wwwwwwwww!!!wwwwwwwwwwww", +"wwwwwwwwwwwwwwwwwwwwwwww", +"wwwwwwwwwwwwwwwwwwwwwwww" +};
--- a/lisp/gnus/kill-group.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/kill-group.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,50 +1,30 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 20 1", -" c Gray0", -". c Gray6", -"X c Gray12", -"o c #2ff42ff42ff4", -"O c #3fff3fff3fff", -"+ c Gray28", -"@ c #53e353e353e3", -"# c #5fe25fe25fe2", -"$ c #67e767e767e7", -"% c #6fff6fff6fff", -"& c #77d777d777d7", -"* c Gray50", -"= c Gray56", -"- c #9fff9fff9fff", -"; c Gray70", -": c Gray75", -"> c Gray81", -", c #dfffdfffdfff", -"< c #efffefffefff", -"1 c Gray100", -/* pixels */ -"::::::::::::::::::::::::", -"::::::::::::::::::::::::", -"::::::::::::::::::::::::", -"::::#oOOOOOOOOOo+;::::::", -"::::#:111111111:O$::::::", -"::::#:1111-O%11:*>@:::::", -"::::#:111=X.o#<>OOo#::::", -"::::#:111 OX# :111:#::::", -"::::#:111 = :111:#::::", -"::::#:111>Xo.-1111:#::::", -"::::#:1111*:O11111:#::::", -"::::#:11%1*oO->111:#::::", -"::::#:1-O:,1:*O111:#::::", -"::::#:111****:1111:#::::", -"::::#:1111* 111111:#::::", -"::::#:1,:O-1O*:111:#::::", -"::::#:1:X1111*#111:#::::", -"::::#:11>1111,<111:#::::", -"::::#:111111111111:#::::", -"::::#:111111111111:#::::", -"::::#:111111111111:#::::", -"::::&oooooooooooooo&::::", -"::::::::::::::::::::::::", -"::::::::::::::::::::::::" -}; +static char * kill_group_xpm[] = { +"24 24 3 1", +". c None", +"o c #000000000000", +"+ c #9A9A6C6C4E4E", +"o..o..o..o..o..o..o..o..", +"........................", +"........................", +"o..o..o..o..o..o..o..o..", +"........................", +"........................", +"o..o..o..o..++.o..o..o..", +".......++..++++.........", +"........++.+++..........", +"o..o..o.+++++..o..o..o..", +".........+++............", +".........++++...........", +"o..o..o.++++++.o..o..o..", +"........++.++++.........", +".......++...++++........", +"o..o...+.o...++o..o..o..", +"........................", +"........................", +"o..o..o..o..o..o..o..o..", +"........................", +"........................", +"o..o..o..o..o..o..o..o..", +"........................", +"........................"};
--- a/lisp/gnus/mail-parse.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mail-parse.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,4 +1,4 @@ -;;; mail-parse.el --- interface functions for parsing mail +;;; mail-parse.el --- Interface functions for parsing mail ;; Copyright (C) 1998, 1999, 2000 ;; Free Software Foundation, Inc. @@ -43,10 +43,11 @@ (require 'rfc2047) (require 'rfc2045) -(defalias 'mail-header-parse-content-type 'rfc2231-parse-string) -(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-string) +(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) +(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) (defalias 'mail-content-type-get 'rfc2231-get-value) -(defalias 'mail-header-encode-parameter 'rfc2045-encode-string) +;(defalias 'mail-header-encode-parameter 'rfc2045-encode-string) +(defalias 'mail-header-encode-parameter 'rfc2231-encode-string) (defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) (defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) @@ -58,7 +59,11 @@ (defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header) (defalias 'mail-quote-string 'ietf-drums-quote-string) +(defalias 'mail-header-fold-field 'rfc2047-fold-field) +(defalias 'mail-header-unfold-field 'rfc2047-unfold-field) (defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field) +(defalias 'mail-header-field-value 'rfc2047-field-value) + (defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region) (defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header) (defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string)
--- a/lisp/gnus/mail-prsvr.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mail-prsvr.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,4 +1,4 @@ -;;; mail-prsvr.el --- interface variables for parsing mail +;;; mail-prsvr.el --- Interface variables for parsing mail ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
--- a/lisp/gnus/mail-reply.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mail-reply.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,51 +1,32 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 21 1", -" c Gray0", -". c Gray6", -"X c Gray12", -"o c #2ff02ff02ff0", -"O c #3fff3fff3fff", -"+ c Gray28", -"@ c #53f353f353f3", -"# c #5ff95ff95ff9", -"$ c #67e767e767e7", -"% c #6fff6fff6fff", -"& c #77dc77dc77dc", -"* c Gray50", -"= c Gray56", -"- c #9beb9beb9beb", -"; c #9fff9fff9fff", -": c Gray70", -"> c Gray75", -", c Gray81", -"< c #dfffdfffdfff", -"1 c #efffefffefff", -"2 c Gray100", -/* pixels */ -">>>>>>>>>>>>>>>==:>>>>>>", -">>>>>>>>>>>>>>&**$&>>>>>", -">>>>>>>>>>>>>&-22,-o->>>", -">>>>>>>>>=$O@$,,2222O>>>", -">>>>>>>=#*>2*>2O222>$>>>", -">>>>>>o&>222O2%,22,$:>>>", -">>>:$O2222<#2*>222=+:>>>", -">>&$>;;2;2*>2><22;**$&>>", -">>o.;,,2,,*1%222;;,O;o>>", -">>o2;O><2O2,%221#o%22o>>", -">>o222***O2;22;**<222o>>", -">>o2222<>.;2,O;,22222o>>", -">>o2221>#2;O%;;,22222o>>", -">>o222**<22222;*>2222o>>", -">>o22%,222222221*,222o>>", -">>o;O,22222222222%#<2o>>", -">>o;22222222222222<**o>>", -">>oOOOOOOOOOOOOOOOOX o>>", -">>>>>>>>>>>>>>>>>>>>>>>>", -">>>>>>>>>>>>>>>>>>>>>>>>", -">>>>>>>>>>>>>>>>>>>>>>>>", -">>>>>>>>>>>>>>>>>>>>>>>>", -">>>>>>>>>>>>>>>>>>>>>>>>", -">>>>>>>>>>>>>>>>>>>>>>>>" -}; +static char * mail_reply_xpm[] = { +"24 24 5 1", +" c None", +". c #000000000000", +"X c #E1E1E0E0E0E0", +"O c #FFFFFFFFFFFF", +"o c #C7C7C6C6C6C6", +" .. ", +" .X. ", +" ..XX. ", +" ......XoXX.. ", +" ...OOO.XooXXX. ", +" ..OOOO.XooXXX. ", +" ...OOOOO.XooXXX... ", +" ..OOOOOO.XXooXX.OO.. ", +" ...OOOO.oooXXX...... ", +" .O...O.oXooXXX...OO. ", +" .OOO...oXoXX...OOOO. ", +" .OOOOO...X...OOOOOO. ", +" .OOOOO.O...OO.OOOOO. ", +" .OOO..OOOOOOOO..OOO. ", +" .OO.OOOOOOOOOOOO.OO. ", +" .O.OOOOOOOOOOOOOO.O. ", +" ..OOOOOOOOOOOOOOOO.. ", +" .................... ", +" ", +" ", +" ", +" ", +" ", +" "};
--- a/lisp/gnus/mail-source.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mail-source.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; mail-source.el --- functions for fetching mail -;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail @@ -32,9 +33,11 @@ (eval-and-compile (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") - (autoload 'nnheader-cancel-timer "nnheader")) + (autoload 'nnheader-cancel-timer "nnheader") + (autoload 'nnheader-run-at-time "nnheader")) (require 'format-spec) (require 'mm-util) +(require 'message) ;; for `message-directory' (defgroup mail-source nil "The mail-fetching library." @@ -58,6 +61,7 @@ This variable is a list of mail source specifiers. See Info node `(gnus)Mail Source Specifiers'." :group 'mail-source + :link '(custom-manual "(gnus)Mail Source Specifiers") :type `(repeat (choice :format "%[Value Menu%] %v" :value (file) @@ -81,10 +85,16 @@ (function :tag "Predicate")) (group :inline t (const :format "" :value :prescript) - (string :tag "Prescript")) + (choice :tag "Prescript" + :value nil + (string :format "%v") + (function :format "%v"))) (group :inline t (const :format "" :value :postscript) - (string :tag "Postscript")) + (choice :tag "Postscript" + :value nil + (string :format "%v") + (function :format "%v"))) (group :inline t (const :format "" :value :plugged) (boolean :tag "Plugged")))) @@ -111,10 +121,16 @@ (string :tag "Program")) (group :inline t (const :format "" :value :prescript) - (string :tag "Prescript")) + (choice :tag "Prescript" + :value nil + (string :format "%v") + (function :format "%v"))) (group :inline t (const :format "" :value :postscript) - (string :tag "Postscript")) + (choice :tag "Postscript" + :value nil + (string :format "%v") + (function :format "%v"))) (group :inline t (const :format "" :value :function) (function :tag "Function")) @@ -160,6 +176,9 @@ :value network ,@mail-source-imap-streams)) (group :inline t + (const :format "" :value :program) + (string :tag "Program")) + (group :inline t (const :format "" :value :authenticator) (choice :tag "Authenticator" @@ -213,18 +232,28 @@ (const :format "" :value :plugged) (boolean :tag "Plugged"))))))) +(defcustom mail-source-ignore-errors nil + "*Ignore errors when querying mail sources. +If nil, the user will be prompted when an error occurs. If non-nil, +the error will be ignored.") + (defcustom mail-source-primary-source nil "*Primary source for incoming mail. If non-nil, this maildrop will be checked periodically for new mail." :group 'mail-source :type 'sexp) +(defcustom mail-source-flash t + "*If non-nil, flash periodically when mail is available." + :group 'mail-source + :type 'boolean) + (defcustom mail-source-crash-box "~/.emacs-mail-crash-box" "File where mail will be stored while processing it." :group 'mail-source :type 'file) -(defcustom mail-source-directory "~/Mail/" +(defcustom mail-source-directory message-directory "Directory where files (if any) will be stored." :group 'mail-source :type 'directory) @@ -235,7 +264,23 @@ :type 'integer) (defcustom mail-source-delete-incoming t - "*If non-nil, delete incoming files after handling." + "*If non-nil, delete incoming files after handling. +If t, delete immediately, if nil, never delete. If a positive number, delete +files older than number of days." + ;; Note: The removing happens in `mail-source-callback', i.e. no old + ;; incoming files will be deleted, unless you receive new mail. + ;; + ;; You may also set this to `nil' and call `mail-source-delete-old-incoming' + ;; from a hook or interactively. + :group 'mail-source + :type '(choice (const :tag "immediately" t) + (const :tag "never" nil) + (integer :tag "days"))) + +(defcustom mail-source-delete-old-incoming-confirm t + "*If non-nil, ask for for confirmation before deleting old incoming files. +This variable only applies when `mail-source-delete-incoming' is a positive +number." :group 'mail-source :type 'boolean) @@ -254,6 +299,11 @@ :group 'mail-source :type 'number) +(defcustom mail-source-movemail-program nil + "If non-nil, name of program for fetching new mail." + :group 'mail-source + :type '(choice (const nil) string)) + ;;; Internal variables. (defvar mail-source-string "" @@ -295,18 +345,22 @@ (:authentication password)) (maildir (:path (or (getenv "MAILDIR") "~/Maildir/")) - (:subdirs ("new" "cur")) + (:subdirs ("cur" "new")) (:function)) (imap (:server (getenv "MAILHOST")) (:port) (:stream) + (:program) (:authentication) (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) (:password) (:mailbox "INBOX") (:predicate "UNSEEN UNDELETED") (:fetchflag "\\Deleted") + (:prescript) + (:prescript-delay) + (:postscript) (:dontexpunge)) (webmail (:subtype hotmail) @@ -365,7 +419,7 @@ ,@body)) (put 'mail-source-bind 'lisp-indent-function 1) -(put 'mail-source-bind 'edebug-form-spec '(form body)) +(put 'mail-source-bind 'edebug-form-spec '(sexp body)) (defun mail-source-set-1 (source) (let* ((type (pop source)) @@ -408,7 +462,7 @@ ,@body)) (put 'mail-source-bind-common 'lisp-indent-function 1) -(put 'mail-source-bind-common 'edebug-form-spec '(form body)) +(put 'mail-source-bind-common 'edebug-form-spec '(sexp body)) (defun mail-source-value (value) "Return the value of VALUE." @@ -442,24 +496,52 @@ (setq found (mail-source-callback callback mail-source-crash-box))) (+ found - (condition-case err + (if (or debug-on-quit debug-on-error) (funcall function source callback) - (error - (unless (yes-or-no-p - (format "Mail source error (%s). Continue? " err)) - (error "Cannot get new mail")) - 0)))))))) + (condition-case err + (funcall function source callback) + (error + (if (and (not mail-source-ignore-errors) + (not + (yes-or-no-p + (format "Mail source %s error (%s). Continue? " + (if (memq ':password source) + (let ((s (copy-sequence source))) + (setcar (cdr (memq ':password s)) + "********") + s) + source) + (cadr err))))) + (error "Cannot get new mail")) + 0))))))))) -(eval-and-compile - (if (fboundp 'make-temp-file) - (defalias 'mail-source-make-complex-temp-name 'make-temp-file) - (defun mail-source-make-complex-temp-name (prefix) - (let ((newname (make-temp-name prefix)) - (newprefix prefix)) - (while (file-exists-p newname) - (setq newprefix (concat newprefix "x")) - (setq newname (make-temp-name newprefix))) - newname)))) +(defun mail-source-delete-old-incoming (&optional age confirm) + "Remove incoming files older than AGE days. +If CONFIRM is non-nil, ask for confirmation before removing a file." + (interactive "P") + (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days + (low2days (/ 1.0 65536.0)) ;; convert low bits to days + (diff (if (natnump age) age 30));; fallback, if no valid AGE given + currday files) + (setq files (directory-files + mail-source-directory t + (concat mail-source-incoming-file-prefix "*")) + currday (* (car (current-time)) high2days) + currday (+ currday (* low2days (nth 1 (current-time))))) + (while files + (let* ((ffile (car files)) + (bfile (gnus-replace-in-string + ffile "\\`.*/\\([^/]+\\)\\'" "\\1")) + (filetime (nth 5 (file-attributes ffile))) + (fileday (* (car filetime) high2days)) + (fileday (+ fileday (* low2days (nth 1 filetime))))) + (setq files (cdr files)) + (when (and (> (- currday fileday) diff) + (gnus-message 8 "File `%s' is older than %s day(s)" + bfile diff) + (or (not confirm) + (y-or-n-p (concat "Remove file `" bfile "'? ")))) + (delete-file ffile)))))) (defun mail-source-callback (callback info) "Call CALLBACK on the mail file, and then remove the mail file. @@ -474,16 +556,21 @@ (funcall callback mail-source-crash-box info) (when (file-exists-p mail-source-crash-box) ;; Delete or move the incoming mail out of the way. - (if mail-source-delete-incoming + (if (eq mail-source-delete-incoming t) (delete-file mail-source-crash-box) (let ((incoming - (mail-source-make-complex-temp-name + (mm-make-temp-file (expand-file-name mail-source-incoming-file-prefix mail-source-directory)))) (unless (file-exists-p (file-name-directory incoming)) (make-directory (file-name-directory incoming) t)) - (rename-file mail-source-crash-box incoming t))))))) + (rename-file mail-source-crash-box incoming t) + ;; remove old incoming files? + (when (natnump mail-source-delete-incoming) + (mail-source-delete-old-incoming + mail-source-delete-incoming + mail-source-delete-old-incoming-confirm)))))))) (defun mail-source-movemail (from to) "Move FROM to TO using movemail." @@ -518,12 +605,15 @@ 'call-process (append (list - (expand-file-name "movemail" exec-directory) + (or mail-source-movemail-program + (expand-file-name "movemail" exec-directory)) nil errors nil from to))))) (when (file-exists-p to) (set-file-modes to mail-source-default-file-modes)) - (if (and (not (buffer-modified-p errors)) - (zerop result)) + (if (and (or (not (buffer-modified-p errors)) + (zerop (buffer-size errors))) + (and (numberp result) + (zerop result))) ;; No output => movemail won. t (set-buffer errors) @@ -540,8 +630,9 @@ (goto-char (point-min)) (when (looking-at "movemail: ") (delete-region (point-min) (match-end 0))) + ;; Result may be a signal description string. (unless (yes-or-no-p - (format "movemail: %s (%d return). Continue? " + (format "movemail: %s (%s return). Continue? " (buffer-string) result)) (error "%s" (buffer-string))) (setq to nil))))))) @@ -557,29 +648,13 @@ (not (zerop (nth 7 (file-attributes from)))) (delete-file from))) -(defvar mail-source-read-passwd nil) -(defun mail-source-read-passwd (prompt &rest args) - "Read a password using PROMPT. -If ARGS, PROMPT is used as an argument to `format'." - (let ((prompt - (if args - (apply 'format prompt args) - prompt))) - (unless mail-source-read-passwd - (if (or (fboundp 'read-passwd) (load "passwd" t)) - (setq mail-source-read-passwd 'read-passwd) - (unless (fboundp 'ange-ftp-read-passwd) - (autoload 'ange-ftp-read-passwd "ange-ftp")) - (setq mail-source-read-passwd 'ange-ftp-read-passwd))) - (funcall mail-source-read-passwd prompt))) - (defun mail-source-fetch-with-program (program) - (zerop (call-process shell-file-name nil nil nil - shell-command-switch program))) + (eq 0 (call-process shell-file-name nil nil nil + shell-command-switch program))) (defun mail-source-run-script (script spec &optional delay) (when script - (if (and (symbolp script) (fboundp script)) + (if (functionp script) (funcall script) (mail-source-call-script (format-spec script spec)))) @@ -616,8 +691,7 @@ "Fetcher for directory sources." (mail-source-bind (directory source) (mail-source-run-script - prescript (format-spec-make ?t path) - prescript-delay) + prescript (format-spec-make ?t path) prescript-delay) (let ((found 0) (mail-source-string (format "directory:%s" path))) (dolist (file (directory-files @@ -626,8 +700,7 @@ (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) (incf found (mail-source-callback callback file)))) - (mail-source-run-script - postscript (format-spec-make ?t path)) + (mail-source-run-script postscript (format-spec-make ?t path)) found))) (defun mail-source-fetch-pop (source callback) @@ -645,7 +718,7 @@ (setq password (or password (cdr (assoc from mail-source-password-cache)) - (mail-source-read-passwd + (read-passwd (format "Password for %s at %s: " user server))))) (when server (setenv "MAILHOST" server)) @@ -667,7 +740,17 @@ (pop3-port port) (pop3-authentication-scheme (if (eq authentication 'apop) 'apop 'pass))) - (save-excursion (pop3-movemail mail-source-crash-box)))))) + (if (or debug-on-quit debug-on-error) + (save-excursion (pop3-movemail mail-source-crash-box)) + (condition-case err + (save-excursion (pop3-movemail mail-source-crash-box)) + (error + ;; We nix out the password in case the error + ;; was because of a wrong password being given. + (setq mail-source-password-cache + (delq (assoc from mail-source-password-cache) + mail-source-password-cache)) + (signal (car err) (cdr err))))))))) (if result (progn (when (eq authentication 'password) @@ -699,7 +782,7 @@ (setq password (or password (cdr (assoc from mail-source-password-cache)) - (mail-source-read-passwd + (read-passwd (format "Password for %s at %s: " user server)))) (unless (assoc from mail-source-password-cache) (push (cons from password) mail-source-password-cache))) @@ -718,7 +801,17 @@ (pop3-port port) (pop3-authentication-scheme (if (eq authentication 'apop) 'apop 'pass))) - (save-excursion (pop3-get-message-count)))))) + (if (or debug-on-quit debug-on-error) + (save-excursion (pop3-get-message-count)) + (condition-case err + (save-excursion (pop3-get-message-count)) + (error + ;; We nix out the password in case the error + ;; was because of a wrong password being given. + (setq mail-source-password-cache + (delq (assoc from mail-source-password-cache) + mail-source-password-cache)) + (signal (car err) (cdr err))))))))) (if result ;; Inform display-time that we have new mail. (setq mail-source-new-mail-available (> result 0)) @@ -729,8 +822,30 @@ mail-source-password-cache))) result))) +(defun mail-source-touch-pop () + "Open and close a POP connection shortly. +POP server should be defined in `mail-source-primary-source' (which is +preferred) or `mail-sources'. You may use it for the POP-before-SMTP +authentication. To do that, you need to set the option +`message-send-mail-function' to `message-smtpmail-send-it' and put the +following line in .gnus file: + +\(add-hook 'message-send-mail-hook 'mail-source-touch-pop) +" + (let ((sources (if mail-source-primary-source + (list mail-source-primary-source) + mail-sources))) + (while sources + (if (eq 'pop (car (car sources))) + (mail-source-check-pop (car sources))) + (setq sources (cdr sources))))) + (defun mail-source-new-mail-p () "Handler for `display-time' to indicate when new mail is available." + ;; Flash (ie. ring the visible bell) if mail is available. + (if (and mail-source-flash mail-source-new-mail-available) + (let ((visible-bell t)) + (ding))) ;; Only report flag setting; flag is updated on a different schedule. mail-source-new-mail-available) @@ -753,8 +868,9 @@ mail-source-idle-time-delay nil (lambda () - (setq mail-source-report-new-mail-idle-timer nil) - (mail-source-check-pop mail-source-primary-source)))) + (unwind-protect + (mail-source-check-pop mail-source-primary-source) + (setq mail-source-report-new-mail-idle-timer nil))))) ;; Since idle timers created when Emacs is already in the idle ;; state don't get activated until Emacs _next_ becomes idle, we ;; need to force our timer to be considered active now. We do @@ -785,8 +901,10 @@ (setq display-time-mail-function #'mail-source-new-mail-p) ;; Set up the main timer. (setq mail-source-report-new-mail-timer - (run-at-time t (* 60 mail-source-report-new-mail-interval) - #'mail-source-start-idle-timer)) + (nnheader-run-at-time + (* 60 mail-source-report-new-mail-interval) + (* 60 mail-source-report-new-mail-interval) + #'mail-source-start-idle-timer)) ;; When you get new mail, clear "Mail" from the mode line. (add-hook 'nnmail-post-get-new-mail-hook 'display-time-event-handler) @@ -817,13 +935,13 @@ (with-temp-file mail-source-crash-box (insert-file-contents file) (goto-char (point-min)) -;;; ;; Unix mail format -;;; (unless (looking-at "\n*From ") -;;; (insert "From maildir " -;;; (current-time-string) "\n")) -;;; (while (re-search-forward "^From " nil t) -;;; (replace-match ">From ")) -;;; (goto-char (point-max)) +;;; ;; Unix mail format +;;; (unless (looking-at "\n*From ") +;;; (insert "From maildir " +;;; (current-time-string) "\n")) +;;; (while (re-search-forward "^From " nil t) +;;; (replace-match ">From ")) +;;; (goto-char (point-max)) ;;; (insert "\n\n") ;; MMDF mail format (insert "\001\001\001\001\n")) @@ -852,10 +970,15 @@ (defun mail-source-fetch-imap (source callback) "Fetcher for imap sources." (mail-source-bind (imap source) + (mail-source-run-script + prescript (format-spec-make ?p password ?t mail-source-crash-box + ?s server ?P port ?u user) + prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (found 0) - (buf (get-buffer-create (generate-new-buffer-name " *imap source*"))) + (buf (generate-new-buffer " *imap source*")) (mail-source-string (format "imap:%s:%s" server mailbox)) + (imap-shell-program (or (list program) imap-shell-program)) remove) (if (and (imap-open server port stream authentication buf) (imap-authenticate @@ -870,12 +993,16 @@ (mm-disable-multibyte) ;; remember password (with-current-buffer buf - (when (or imap-password - (assoc from mail-source-password-cache)) + (when (and imap-password + (not (assoc from mail-source-password-cache))) (push (cons from imap-password) mail-source-password-cache))) ;; if predicate is nil, use all uids (dolist (uid (imap-search (or predicate "1:*") buf)) - (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)) + (when (setq str + (if (imap-capability 'IMAP4rev1 buf) + (caddar (imap-fetch uid "BODY.PEEK[]" + 'BODYDETAIL nil buf)) + (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))) (push uid remove) (insert "From imap " (current-time-string) "\n") (save-excursion @@ -886,12 +1013,13 @@ (nnheader-ms-strip-cr)) (incf found (mail-source-callback callback server)) (when (and remove fetchflag) + (setq remove (nreverse remove)) (imap-message-flags-add (imap-range-to-message-set (gnus-compress-sequence remove)) fetchflag nil buf)) (if dontexpunge (imap-mailbox-unselect buf) - (imap-mailbox-close buf)) + (imap-mailbox-close nil buf)) (imap-close buf)) (imap-close buf) ;; We nix out the password in case the error @@ -899,8 +1027,12 @@ (setq mail-source-password-cache (delq (assoc from mail-source-password-cache) mail-source-password-cache)) - (error (imap-error-text buf))) + (error "IMAP error: %s" (imap-error-text buf))) (kill-buffer buf) + (mail-source-run-script + postscript + (format-spec-make ?p password ?t mail-source-crash-box + ?s server ?P port ?u user)) found))) (eval-and-compile @@ -917,7 +1049,7 @@ (or password (cdr (assoc (format "webmail:%s:%s" subtype user) mail-source-password-cache)) - (mail-source-read-passwd + (read-passwd (format "Password for %s at %s: " user subtype)))) (when (and password (not (assoc (format "webmail:%s:%s" subtype user)
--- a/lisp/gnus/mailcap.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mailcap.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; mailcap.el --- MIME media types configuration -;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: William M. Perry <wmperry@aventail.com> ;; Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -46,14 +47,36 @@ (modify-syntax-entry ?{ "(" table) (modify-syntax-entry ?} ")" table) table) - "A syntax table for parsing sgml attributes.") + "A syntax table for parsing SGML attributes.") + +(eval-and-compile + (when (featurep 'xemacs) + (condition-case nil + (require 'lpr) + (error nil)))) + +(defvar mailcap-print-command + (mapconcat 'identity + (cons (if (boundp 'lpr-command) + lpr-command + "lpr") + (when (boundp 'lpr-switches) + (if (stringp lpr-switches) + (list lpr-switches) + lpr-switches))) + " ") + "Shell command (including switches) used to print Postscript files.") ;; Postpone using defcustom for this as it's so big and we essentially ;; have to have two copies of the data around then. Perhaps just ;; customize the Lisp viewers and rely on the normal configuration ;; files for the rest? -- fx (defvar mailcap-mime-data - '(("application" + `(("application" + ("vnd.ms-excel" + (viewer . "gnumeric %s") + (test . (getenv "DISPLAY")) + (type . "application/vnd.ms-excel")) ("x-x509-ca-cert" (viewer . ssl-view-site-cert) (test . (fboundp 'ssl-view-site-cert)) @@ -66,23 +89,23 @@ (viewer . mailcap-save-binary-file) (non-viewer . t) (type . "application/octet-stream")) -;;; XEmacs says `ns' device-type not implemented. -;; ("dvi" -;; (viewer . "open %s") -;; (type . "application/dvi") -;; (test . (eq (mm-device-type) 'ns))) ("dvi" - (viewer . "xdvi %s") - (test . (eq (mm-device-type) 'x)) + (viewer . "xdvi -safer %s") + (test . (eq window-system 'x)) ("needsx11") - (type . "application/dvi")) + (type . "application/dvi") + ("print" . "dvips -qRP %s")) ("dvi" (viewer . "dvitty %s") (test . (not (getenv "DISPLAY"))) - (type . "application/dvi")) + (type . "application/dvi") + ("print" . "dvips -qRP %s")) ("emacs-lisp" (viewer . mailcap-maybe-eval) (type . "application/emacs-lisp")) + ("x-emacs-lisp" + (viewer . mailcap-maybe-eval) + (type . "application/x-emacs-lisp")) ("x-tar" (viewer . mailcap-save-binary-file) (non-viewer . t) @@ -114,36 +137,52 @@ ("copiousoutput")) ;; Prefer free viewers. ("pdf" - (viewer . "gv %s") + (viewer . "gv -safer %s") (type . "application/pdf") - (test . window-system)) + (test . window-system) + ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command))) ("pdf" (viewer . "xpdf %s") (type . "application/pdf") - (test . (eq (mm-device-type) 'x))) + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + (test . (eq window-system 'x))) ("pdf" (viewer . "acroread %s") - (type . "application/pdf")) -;;; XEmacs says `ns' device-type not implemented. -;; ("postscript" -;; (viewer . "open %s") -;; (type . "application/postscript") -;; (test . (eq (mm-device-type) 'ns))) + (type . "application/pdf") + ("print" . ,(concat "cat %s | acroread -toPostScript | " + mailcap-print-command)) + (test . window-system)) + ("pdf" + (viewer . ,(concat "pdftotext %s -")) + (type . "application/pdf") + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + ("copiousoutput")) ("postscript" (viewer . "gv -safer %s") (type . "application/postscript") (test . window-system) + ("print" . ,(concat mailcap-print-command " %s")) ("needsx11")) ("postscript" (viewer . "ghostview -dSAFER %s") (type . "application/postscript") - (test . (eq (mm-device-type) 'x)) + (test . (eq window-system 'x)) + ("print" . ,(concat mailcap-print-command " %s")) ("needsx11")) ("postscript" (viewer . "ps2ascii %s") (type . "application/postscript") (test . (not (getenv "DISPLAY"))) - ("copiousoutput"))) + ("print" . ,(concat mailcap-print-command " %s")) + ("copiousoutput")) + ("sieve" + (viewer . sieve-mode) + (test . (fboundp 'sieve-mode)) + (type . "application/sieve")) + ("pgp-keys" + (viewer . "gpg --import --interactive --verbose") + (type . "application/pgp-keys") + ("needsterminal"))) ("audio" ("x-mpeg" (viewer . "maplay %s") @@ -173,34 +212,29 @@ (viewer . "xwud -in %s") (type . "image/x-xwd") ("compose" . "xwd -frame > %s") - (test . (eq (mm-device-type) 'x)) + (test . (eq window-system 'x)) ("needsx11")) ("x11-dump" (viewer . "xwud -in %s") (type . "image/x-xwd") ("compose" . "xwd -frame > %s") - (test . (eq (mm-device-type) 'x)) + (test . (eq window-system 'x)) ("needsx11")) ("windowdump" (viewer . "xwud -in %s") (type . "image/x-xwd") ("compose" . "xwd -frame > %s") - (test . (eq (mm-device-type) 'x)) + (test . (eq window-system 'x)) ("needsx11")) -;;; XEmacs says `ns' device-type not implemented. -;; (".*" -;; (viewer . "aopen %s") -;; (type . "image/*") -;; (test . (eq (mm-device-type) 'ns))) (".*" (viewer . "display %s") (type . "image/*") - (test . (eq (mm-device-type) 'x)) + (test . (eq window-system 'x)) ("needsx11")) (".*" (viewer . "ee %s") (type . "image/*") - (test . (eq (mm-device-type) 'x)) + (test . (eq window-system 'x)) ("needsx11"))) ("text" ("plain" @@ -215,7 +249,7 @@ (viewer . fundamental-mode) (type . "text/plain")) ("enriched" - (viewer . enriched-decode-region) + (viewer . enriched-decode) (test . (fboundp 'enriched-decode)) (type . "text/enriched")) ("html" @@ -226,7 +260,7 @@ ("mpeg" (viewer . "mpeg_play %s") (type . "video/mpeg") - (test . (eq (mm-device-type) 'x)) + (test . (eq window-system 'x)) ("needsx11"))) ("x-world" ("x-vrml" @@ -271,7 +305,6 @@ whose car is a symbol, it is `eval'led to yield the validity. If it is a string or list of strings, it represents a shell command to run to return a true or false shell value for the validity.") -(put 'mailcap-mime-data 'risky-local-variable t) (defcustom mailcap-download-directory nil "*Directory to which `mailcap-save-binary-file' downloads files by default. @@ -280,6 +313,10 @@ directory) :group 'mailcap) +(defvar mailcap-poor-system-types + '(ms-dos ms-windows windows-nt win32 w32 mswindows) + "Systems that don't have a Unix-like directory hierarchy.") + ;;; ;;; Utility functions ;;; @@ -356,7 +393,7 @@ (cond (path nil) ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) - ((memq system-type '(ms-dos ms-windows windows-nt)) + ((memq system-type mailcap-poor-system-types) (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap"))) (t (setq path ;; This is per RFC 1524, specifically @@ -533,7 +570,7 @@ (cond ((equal (car (car major)) minor) (setq exact (cons (cdr (car major)) exact))) - ((and minor (string-match (car (car major)) minor)) + ((and minor (string-match (concat "^" (car (car major)) "$") minor)) (setq wildcard (cons (cdr (car major)) wildcard)))) (setq major (cdr major))) (nconc exact wildcard))) @@ -590,7 +627,7 @@ (defun mailcap-viewer-passes-test (viewer-info type-info) "Return non-nil iff viewer specified by VIEWER-INFO passes its test clause. -Also retun non-nil if it has no test clause. TYPE-INFO is an argument +Also return non-nil if it has no test clause. TYPE-INFO is an argument to supply to the test." (let* ((test-info (assq 'test viewer-info)) (test (cdr test-info)) @@ -619,7 +656,7 @@ test (list shell-file-name nil nil nil shell-command-switch test) status (apply 'call-process test)) - (= 0 status)))) + (eq 0 status)))) (push (list otest result) mailcap-viewer-test-cache) result))) @@ -629,18 +666,18 @@ (setq mailcap-mime-data (cons (cons major (list (cons minor info))) mailcap-mime-data)) - (let ((cur-minor (assoc minor old-major))) - (cond - ((or (null cur-minor) ; New minor area, or - (assq 'test info)) ; Has a test, insert at beginning - (setcdr old-major (cons (cons minor info) (cdr old-major)))) - ((and (not (assq 'test info)) ; No test info, replace completely - (not (assq 'test cur-minor)) + (let ((cur-minor (assoc minor old-major))) + (cond + ((or (null cur-minor) ; New minor area, or + (assq 'test info)) ; Has a test, insert at beginning + (setcdr old-major (cons (cons minor info) (cdr old-major)))) + ((and (not (assq 'test info)) ; No test info, replace completely + (not (assq 'test cur-minor)) (equal (assq 'viewer info) ; Keep alternative viewer (assq 'viewer cur-minor))) - (setcdr cur-minor info)) - (t - (setcdr old-major (cons (cons minor info) (cdr old-major)))))) + (setcdr cur-minor info)) + (t + (setcdr old-major (cons (cons minor info) (cdr old-major)))))) ))) (defun mailcap-add (type viewer &optional test) @@ -723,9 +760,8 @@ ((or (null request) (equal request "")) (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info)) ((stringp request) - (if (or (eq request 'test) (eq request 'viewer)) - (mailcap-unescape-mime-test - (cdr-safe (assoc request viewer)) info))) + (mailcap-unescape-mime-test + (cdr-safe (assoc request viewer)) info)) ((eq request 'all) passed) (t @@ -808,6 +844,7 @@ (".rtx" . "text/richtext") (".sh" . "application/x-sh") (".sit" . "application/x-stuffit") + (".siv" . "application/sieve") (".snd" . "audio/basic") (".src" . "application/x-wais-source") (".tar" . "archive/tar") @@ -825,6 +862,7 @@ (".vox" . "audio/basic") (".vrml" . "x-world/x-vrml") (".wav" . "audio/x-wav") + (".xls" . "application/vnd.ms-excel") (".wrl" . "x-world/x-vrml") (".xbm" . "image/xbm") (".xpm" . "image/xpm") @@ -851,7 +889,7 @@ (cond (path nil) ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES"))) - ((memq system-type '(ms-dos ms-windows windows-nt)) + ((memq system-type mailcap-poor-system-types) (setq path '("~/mime.typ" "~/etc/mime.typ"))) (t (setq path ;; mime.types seems to be the normal name, definitely so
--- a/lisp/gnus/message.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/message.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ -;;; message.el --- composing mail and news messages -*- coding: iso-latin-1 -*- -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 +;;; message.el --- composing mail and news messages +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -32,14 +32,25 @@ (eval-when-compile (require 'cl) - (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary + (defvar gnus-message-group-art) + (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary +(require 'canlock) (require 'mailheader) (require 'nnheader) -;; This is apparently necessary even though things are autoloaded: +;; This is apparently necessary even though things are autoloaded. +;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better +;; require mailabbrev here. (if (featurep 'xemacs) - (require 'mail-abbrevs)) + (require 'mail-abbrevs) + (require 'mailabbrev)) (require 'mail-parse) (require 'mml) +(require 'rfc822) +(eval-and-compile + (autoload 'sha1 "sha1-el") + (autoload 'gnus-find-method-for-group "gnus") + (autoload 'nnvirtual-find-group-art "nnvirtual") + (autoload 'gnus-group-decoded-name "gnus-group")) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -123,6 +134,11 @@ (function :tag "Other")) :group 'message-sending) +(defcustom message-fcc-externalize-attachments nil + "If non-nil, attachments are included as external parts in Fcc copies." + :type 'boolean + :group 'message-sending) + (defcustom message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" "*This is inserted at the start of a mailed copy of a posted message. @@ -130,9 +146,10 @@ the article has been posted to will be inserted there. If this variable is nil, no such courtesy message will be added." :group 'message-sending - :type 'string) - -(defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" + :type '(radio (string :format "%t: %v\n" :size 0) (const nil))) + +(defcustom message-ignored-bounced-headers + "^\\(Received\\|Return-Path\\|Delivered-To\\):" "*Regexp that matches headers to be removed in resent bounced mail." :group 'message-interface :type 'regexp) @@ -156,7 +173,14 @@ (const default)) :group 'message-headers) -(defcustom message-syntax-checks nil +(defcustom message-insert-canlock t + "Whether to insert a Cancel-Lock header in news postings." + :version "21.3" + :group 'message-headers + :type 'boolean) + +(defcustom message-syntax-checks + (if message-insert-canlock '((sender . disabled)) nil) ;; Guess this one shouldn't be easy to customize... "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add @@ -169,13 +193,32 @@ `new-text', `quoting-style', `redirected-followup', `signature', `approved', `sender', `empty', `empty-headers', `message-id', `from', `subject', `shorten-followup-to', `existing-newsgroups', -`buffer-file-name', `unchanged', `newsgroups'." +`buffer-file-name', `unchanged', `newsgroups', `reply-to', +`continuation-headers', `long-header-lines', `invisible-text' and +`illegible-text'." :group 'message-news :type '(repeat sexp)) ; Fixme: improve this +(defcustom message-required-headers '((optional . References) + From) + "*Headers to be generated or prompted for when sending a message. +Also see `message-required-news-headers' and +`message-required-mail-headers'." + :group 'message-news + :group 'message-headers + :link '(custom-manual "(message)Message Headers") + :type '(repeat sexp)) + +(defcustom message-draft-headers '(References From) + "*Headers to be generated when saving a draft message." + :group 'message-news + :group 'message-headers + :link '(custom-manual "(message)Message Headers") + :type '(repeat sexp)) + (defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID - (optional . Organization) Lines + (optional . Organization) (optional . User-Agent)) "*Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, @@ -184,64 +227,200 @@ header, remove it from this list." :group 'message-news :group 'message-headers + :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) (defcustom message-required-mail-headers - '(From Subject Date (optional . In-Reply-To) Message-ID Lines + '(From Subject Date (optional . In-Reply-To) Message-ID (optional . User-Agent)) "*Headers to be generated or prompted for when mailing a message. -RFC822 required that From, Date, To, Subject and Message-ID be -included. Organization, Lines and User-Agent are optional." +It is recommended that From, Date, To, Subject and Message-ID be +included. Organization and User-Agent are optional." :group 'message-mail :group 'message-headers + :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) (defcustom message-deletable-headers '(Message-ID Date Lines) "Headers to be deleted if they already exist and were generated by message previously." :group 'message-headers + :link '(custom-manual "(message)Message Headers") :type 'sexp) (defcustom message-ignored-news-headers - "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:" + "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" "*Regexp of headers to be removed unconditionally before posting." :group 'message-news :group 'message-headers + :link '(custom-manual "(message)Message Headers") :type 'regexp) -(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:" +(defcustom message-ignored-mail-headers + "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" "*Regexp of headers to be removed unconditionally before mailing." :group 'message-mail :group 'message-headers + :link '(custom-manual "(message)Mail Headers") :type 'regexp) -(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." :group 'message-interface + :link '(custom-manual "(message)Superseding") :type 'regexp) -(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" +(defcustom message-subject-re-regexp + "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*" "*Regexp matching \"Re: \" in the subject line." :group 'message-various + :link '(custom-manual "(message)Message Headers") :type 'regexp) +;;; Start of variables adopted from `message-utils.el'. + +(defcustom message-subject-trailing-was-query 'ask + "*What to do with trailing \"(was: <old subject>)\" in subject lines. +If nil, leave the subject unchanged. If it is the symbol `ask', query +the user what do do. In this case, the subject is matched against +`message-subject-trailing-was-ask-regexp'. If +`message-subject-trailing-was-query' is t, always strip the trailing +old subject. In this case, `message-subject-trailing-was-regexp' is +used." + :type '(choice (const :tag "never" nil) + (const :tag "always strip" t) + (const ask)) + :link '(custom-manual "(message)Message Headers") + :group 'message-various) + +(defcustom message-subject-trailing-was-ask-regexp + "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)" + "*Regexp matching \"(was: <old subject>)\" in the subject line. + +The function `message-strip-subject-trailing-was' uses this regexp if +`message-subject-trailing-was-query' is set to the symbol `ask'. If +the variable is t instead of `ask', use +`message-subject-trailing-was-regexp' instead. + +It is okay to create some false positives here, as the user is asked." + :group 'message-various + :link '(custom-manual "(message)Message Headers") + :type 'regexp) + +(defcustom message-subject-trailing-was-regexp + "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" + "*Regexp matching \"(was: <old subject>)\" in the subject line. + +If `message-subject-trailing-was-query' is set to t, the subject is +matched against `message-subject-trailing-was-regexp' in +`message-strip-subject-trailing-was'. You should use a regexp creating very +few false positives here." + :group 'message-various + :link '(custom-manual "(message)Message Headers") + :type 'regexp) + +;; Fixme: Why are all these things autoloaded? + +;;; marking inserted text + +;;;###autoload +(defcustom message-mark-insert-begin + "--8<---------------cut here---------------start------------->8---\n" + "How to mark the beginning of some inserted text." + :type 'string + :link '(custom-manual "(message)Insertion Variables") + :group 'message-various) + +;;;###autoload +(defcustom message-mark-insert-end + "--8<---------------cut here---------------end--------------->8---\n" + "How to mark the end of some inserted text." + :type 'string + :link '(custom-manual "(message)Insertion Variables") + :group 'message-various) + +;;;###autoload +(defcustom message-archive-header + "X-No-Archive: Yes\n" + "Header to insert when you don't want your article to be archived. +Archives \(such as groups.google.com\) respect this header." + :type 'string + :link '(custom-manual "(message)Header Commands") + :group 'message-various) + +;;;###autoload +(defcustom message-archive-note + "X-No-Archive: Yes - save http://groups.google.com/" + "Note to insert why you wouldn't want this posting archived. +If nil, don't insert any text in the body." + :type '(radio (string :format "%t: %v\n" :size 0) + (const nil)) + :link '(custom-manual "(message)Header Commands") + :group 'message-various) + +;;; Crossposts and Followups +;; inspired by JoH-followup-to by Jochem Huhman <joh at gmx.de> +;; new suggestions by R. Weikusat <rw at another.de> + +(defvar message-cross-post-old-target nil + "Old target for cross-posts or follow-ups.") +(make-variable-buffer-local 'message-cross-post-old-target) + +;;;###autoload +(defcustom message-cross-post-default t + "When non-nil `message-cross-post-followup-to' will perform a crosspost. +If nil, `message-cross-post-followup-to' will only do a followup. Note that +you can explicitly override this setting by calling +`message-cross-post-followup-to' with a prefix." + :type 'boolean + :group 'message-various) + +;;;###autoload +(defcustom message-cross-post-note + "Crosspost & Followup-To: " + "Note to insert before signature to notify of cross-post and follow-up." + :type 'string + :group 'message-various) + +;;;###autoload +(defcustom message-followup-to-note + "Followup-To: " + "Note to insert before signature to notify of follow-up only." + :type 'string + :group 'message-various) + +;;;###autoload +(defcustom message-cross-post-note-function + 'message-cross-post-insert-note + "Function to use to insert note about Crosspost or Followup-To. +The function will be called with four arguments. The function should not only +insert a note, but also ensure old notes are deleted. See the documentation +for `message-cross-post-insert-note'." + :type 'function + :group 'message-various) + +;;; End of variables adopted from `message-utils.el'. + ;;;###autoload (defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." :type 'regexp + :link '(custom-manual "(message)Various Message Variables") :group 'message-various) (defcustom message-elide-ellipsis "\n[...]\n\n" "*The string which is inserted for elided text." :type 'string + :link '(custom-manual "(message)Various Commands") :group 'message-various) -(defcustom message-interactive nil +(defcustom message-interactive t "Non-nil means when sending a message wait for and display errors. nil means let mailer mail back a message to report errors." :group 'message-sending :group 'message-mail + :link '(custom-manual "(message)Sending Variables") :type 'boolean) (defcustom message-generate-new-buffers 'unique @@ -250,6 +429,7 @@ the to address and the group name. (Any of these may be nil.) The function should return the new buffer name." :group 'message-buffers + :link '(custom-manual "(message)Message Buffers") :type '(choice (const :tag "off" nil) (const :tag "unique" unique) (const :tag "unsent" unsent) @@ -258,6 +438,7 @@ (defcustom message-kill-buffer-on-exit nil "*Non-nil means that the message buffer will be killed after sending a message." :group 'message-buffers + :link '(custom-manual "(message)Message Buffers") :type 'boolean) (eval-when-compile @@ -278,50 +459,68 @@ (defcustom message-user-organization-file "/usr/lib/news/organization" "*Local news organization file." :type 'file + :link '(custom-manual "(message)News Headers") :group 'message-headers) (defcustom message-make-forward-subject-function - 'message-forward-subject-author-subject + #'message-forward-subject-name-subject "*List of functions called to generate subject headers for forwarded messages. The subject generated by the previous function is passed into each successive function. The provided functions are: -* `message-forward-subject-author-subject' (Source of article (author or - newsgroup)), in brackets followed by the subject -* `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended +* `message-forward-subject-author-subject' Source of article (author or + newsgroup), in brackets followed by the subject +* `message-forward-subject-name-subject' Source of article (name of author + or newsgroup), in brackets followed by the subject +* `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended to it." :group 'message-forwarding + :link '(custom-manual "(message)Forwarding") :type '(radio (function-item message-forward-subject-author-subject) (function-item message-forward-subject-fwd) + (function-item message-forward-subject-name-subject) (repeat :tag "List of functions" function))) (defcustom message-forward-as-mime t - "*If non-nil, forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." + "*Non-nil means forward messages as an inline/rfc822 MIME section. +Otherwise, directly inline the old message in the forwarded message." :version "21.1" :group 'message-forwarding + :link '(custom-manual "(message)Forwarding") :type 'boolean) -(defcustom message-forward-show-mml t - "*If non-nil, forward messages are shown as mml. Otherwise, forward messages are unchanged." +(defcustom message-forward-show-mml 'best + "*Non-nil means show forwarded messages as MML (decoded from MIME). +Otherwise, forwarded messages are unchanged. +Can also be the symbol `best' to indicate that MML should be +used, except when it is a bad idea to use MML. One example where +it is a bad idea is when forwarding a signed or encrypted +message, because converting MIME to MML would invalidate the +digital signature." :version "21.1" :group 'message-forwarding - :type 'boolean) + :type '(choice (const :tag "use MML" t) + (const :tag "don't use MML " nil) + (const :tag "use MML when appropriate" best))) (defcustom message-forward-before-signature t - "*If non-nil, put forwarded message before signature, else after." + "*Non-nil means put forwarded message before signature, else after." :group 'message-forwarding :type 'boolean) (defcustom message-wash-forwarded-subjects nil - "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward." + "*Non-nil means try to remove as much cruft as possible from the subject. +Done before generating the new subject of a forward." :group 'message-forwarding + :link '(custom-manual "(message)Forwarding") :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:" +(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From " "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface + :link '(custom-manual "(message)Resending") :type 'regexp) (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" @@ -334,11 +533,36 @@ (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion + :link '(custom-manual "(message)Insertion Variables") + :type 'regexp) + +(defcustom message-cite-prefix-regexp + (if (string-match "[[:digit:]]" "1") ;; support POSIX? + "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+" + ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. + (let ((old-table (syntax-table)) + non-word-constituents) + (set-syntax-table text-mode-syntax-table) + (setq non-word-constituents + (concat + (if (string-match "\\w" "-") "" "-") + (if (string-match "\\w" "_") "" "_") + (if (string-match "\\w" ".") "" "."))) + (set-syntax-table old-table) + (if (equal non-word-constituents "") + "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+" + (concat "\\([ \t]*\\(\\w\\|[" + non-word-constituents + "]\\)+>+\\|[ \t]*[]>|}+]\\)+")))) + "*Regexp matching the longest possible citation prefix on a line." + :group 'message-insertion + :link '(custom-manual "(message)Insertion Variables") :type 'regexp) (defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." :group 'message-interface + :link '(custom-manual "(message)Canceling News") :type 'string) ;; Useful to set in site-init.el @@ -350,16 +574,18 @@ Valid values include `message-send-mail-with-sendmail' (the default), `message-send-mail-with-mh', `message-send-mail-with-qmail', -`smtpmail-send-it' and `feedmail-send-it'. +`message-smtpmail-send-it', `smtpmail-send-it' and `feedmail-send-it'. See also `send-mail-function'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) + (function-item message-smtpmail-send-it) (function-item smtpmail-send-it) (function-item feedmail-send-it) (function :tag "Other")) :group 'message-sending + :link '(custom-manual "(message)Mail Variables") :group 'message-mail) (defcustom message-send-news-function 'message-send-news @@ -368,6 +594,7 @@ variable `mail-header-separator'." :group 'message-sending :group 'message-news + :link '(custom-manual "(message)News Variables") :type 'function) (defcustom message-reply-to-function nil @@ -375,6 +602,7 @@ This function should pick out addresses from the To, Cc, and From headers and respond with new To and Cc headers." :group 'message-interface + :link '(custom-manual "(message)Reply") :type '(choice function (const nil))) (defcustom message-wide-reply-to-function nil @@ -382,6 +610,7 @@ This function should pick out addresses from the To, Cc, and From headers and respond with new To and Cc headers." :group 'message-interface + :link '(custom-manual "(message)Wide Reply") :type '(choice function (const nil))) (defcustom message-followup-to-function nil @@ -389,6 +618,7 @@ This function should pick out addresses from the To, Cc, and From headers and respond with new To and Cc headers." :group 'message-interface + :link '(custom-manual "(message)Followup") :type '(choice function (const nil))) (defcustom message-use-followup-to 'ask @@ -398,31 +628,108 @@ always query the user whether to use the value. If it is the symbol `use', always use the value." :group 'message-interface + :link '(custom-manual "(message)Followup") + :type '(choice (const :tag "ignore" nil) + (const :tag "use & query" t) + (const use) + (const ask))) + +(defcustom message-use-mail-followup-to 'use + "*Specifies what to do with Mail-Followup-To header. +If nil, always ignore the header. If it is the symbol `ask', always +query the user whether to use the value. If it is the symbol `use', +always use the value." + :group 'message-interface + :link '(custom-manual "(message)Mailing Lists") :type '(choice (const :tag "ignore" nil) (const use) (const ask))) +(defcustom message-subscribed-address-functions nil + "*Specifies functions for determining list subscription. +If nil, do not attempt to determine list subscription with functions. +If non-nil, this variable contains a list of functions which return +regular expressions to match lists. These functions can be used in +conjunction with `message-subscribed-regexps' and +`message-subscribed-addresses'." + :group 'message-interface + :link '(custom-manual "(message)Mailing Lists") + :type '(repeat sexp)) + +(defcustom message-subscribed-address-file nil + "*A file containing addresses the user is subscribed to. +If nil, do not look at any files to determine list subscriptions. If +non-nil, each line of this file should be a mailing list address." + :group 'message-interface + :link '(custom-manual "(message)Mailing Lists") + :type '(radio (file :format "%t: %v\n" :size 0) + (const nil))) + +(defcustom message-subscribed-addresses nil + "*Specifies a list of addresses the user is subscribed to. +If nil, do not use any predefined list subscriptions. This list of +addresses can be used in conjunction with +`message-subscribed-address-functions' and `message-subscribed-regexps'." + :group 'message-interface + :link '(custom-manual "(message)Mailing Lists") + :type '(repeat string)) + +(defcustom message-subscribed-regexps nil + "*Specifies a list of addresses the user is subscribed to. +If nil, do not use any predefined list subscriptions. This list of +regular expressions can be used in conjunction with +`message-subscribed-address-functions' and `message-subscribed-addresses'." + :group 'message-interface + :link '(custom-manual "(message)Mailing Lists") + :type '(repeat regexp)) + +(defcustom message-allow-no-recipients 'ask + "Specifies what to do when there are no recipients other than Gcc/Fcc. +If it is the symbol `always', the posting is allowed. If it is the +symbol `never', the posting is not allowed. If it is the symbol +`ask', you are prompted." + :group 'message-interface + :link '(custom-manual "(message)Message Headers") + :type '(choice (const always) + (const never) + (const ask))) + (defcustom message-sendmail-f-is-evil nil "*Non-nil means don't add \"-f username\" to the sendmail command line. Doing so would be even more evil than leaving it out." :group 'message-sending + :link '(custom-manual "(message)Mail Variables") :type 'boolean) +(defcustom message-sendmail-envelope-from nil + "*Envelope-from when sending mail with sendmail. +If this is nil, use `user-mail-address'. If it is the symbol +`header', use the From: header of the message." + :type '(choice (string :tag "From name") + (const :tag "Use From: header from message" header) + (const :tag "Use `user-mail-address'" nil)) + :link '(custom-manual "(message)Mail Variables") + :group 'message-sending) + ;; qmail-related stuff (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" "Location of the qmail-inject program." :group 'message-sending + :link '(custom-manual "(message)Mail Variables") :type 'file) (defcustom message-qmail-inject-args nil "Arguments passed to qmail-inject programs. -This should be a list of strings, one string for each argument. +This should be a list of strings, one string for each argument. It +may also be a function. For e.g., if you wish to set the envelope sender address so that bounces go to the right place or to deal with listserv's usage of that address, you might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending - :type '(repeat string)) + :link '(custom-manual "(message)Mail Variables") + :type '(choice (function) + (repeat string))) (defvar message-cater-to-broken-inn t "Non-nil means Gnus should not fold the `References' header. @@ -449,20 +756,37 @@ ;; create a dependence to `gnus.el'. :type 'sexp) -(defcustom message-generate-headers-first nil - "*If non-nil, generate all possible headers before composing." +;; FIXME: This should be a temporary workaround until someone implements a +;; proper solution. If a crash happens while replying, the auto-save file +;; will *not* have a `References:' header if `message-generate-headers-first' +;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138 +(defcustom message-generate-headers-first '(references) + "Which headers should be generated before starting to compose a message. +If `t', generate all required headers. This can also be a list of headers to +generate. The variables `message-required-news-headers' and +`message-required-mail-headers' specify which headers to generate. + +Note that the variable `message-deletable-headers' specifies headers which +are to be deleted and then re-generated before sending, so this variable +will not have a visible effect for those headers." :group 'message-headers - :type 'boolean) + :link '(custom-manual "(message)Message Headers") + :type '(choice (const :tag "None" nil) + (const :tag "References" '(references)) + (const :tag "All" t) + (repeat (sexp :tag "Header")))) (defcustom message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook." :group 'message-various + :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-cancel-hook nil "Hook run when cancelling articles." :group 'message-various + :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-signature-setup-hook nil @@ -470,6 +794,7 @@ It is run after the headers have been inserted and before the signature is inserted." :group 'message-various + :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-mode-hook nil @@ -485,24 +810,49 @@ (defcustom message-header-setup-hook nil "Hook called narrowed to the headers when setting up a message buffer." :group 'message-various + :link '(custom-manual "(message)Various Message Variables") :type 'hook) +(defcustom message-minibuffer-local-map + (let ((map (make-sparse-keymap 'message-minibuffer-local-map))) + (set-keymap-parent map minibuffer-local-map) + map) + "Keymap for `message-read-from-minibuffer'.") + ;;;###autoload (defcustom message-citation-line-function 'message-insert-citation-line - "*Function called to insert the \"Whomever writes:\" line." + "*Function called to insert the \"Whomever writes:\" line. + +Note that Gnus provides a feature where the reader can click on +`writes:' to hide the cited text. If you change this line too much, +people who read your message will have to change their Gnus +configuration. See the variable `gnus-cite-attribution-suffix'." :type 'function + :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) ;;;###autoload (defcustom message-yank-prefix "> " - "*Prefix inserted on the lines of yanked messages." + "*Prefix inserted on the lines of yanked messages. +Fix `message-cite-prefix-regexp' if it is set to an abnormal value. +See also `message-yank-cited-prefix'." :type 'string + :link '(custom-manual "(message)Insertion Variables") + :group 'message-insertion) + +(defcustom message-yank-cited-prefix ">" + "*Prefix inserted on cited or empty lines of yanked messages. +Fix `message-cite-prefix-regexp' if it is set to an abnormal value. +See also `message-yank-prefix'." + :type 'string + :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-indentation-spaces 3 "*Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'." :group 'message-insertion + :link '(custom-manual "(message)Insertion Variables") :type 'integer) ;;;###autoload @@ -515,6 +865,7 @@ (function-item message-cite-original-without-signature) (function-item sc-cite-original) (function :tag "Other")) + :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) ;;;###autoload @@ -524,10 +875,9 @@ citation between (point) and (mark t). And each function should leave point and mark around the citation text as modified." :type 'function + :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) -(defvar message-abbrevs-loaded nil) - ;;;###autoload (defcustom message-signature t "*String to be inserted at the end of the message buffer. @@ -535,6 +885,7 @@ If a function, the result from the function will be used instead. If a form, the result from the form will be used instead." :type 'sexp + :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) ;;;###autoload @@ -543,12 +894,21 @@ Ignored if the named file doesn't exist. If nil, don't insert a signature." :type '(choice file (const :tags "None" nil)) + :link '(custom-manual "(message)Insertion Variables") + :group 'message-insertion) + +;;;###autoload +(defcustom message-signature-insert-empty-line t + "*If non-nil, insert an empty line before the signature separator." + :type 'boolean + :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-distribution-function nil "*Function called to return a Distribution header." :group 'message-news :group 'message-headers + :link '(custom-manual "(message)News Headers") :type '(choice function (const nil))) (defcustom message-expires 14 @@ -569,7 +929,10 @@ (sexp :tag "none" :format "%t" t))) (defvar message-reply-buffer nil) -(defvar message-reply-headers nil) +(defvar message-reply-headers nil + "The headers of the current replied article. +It is a vector of the following headers: +\[number subject from date id references chars lines xref extra].") (defvar message-newsreader nil) (defvar message-mailer nil) (defvar message-sent-message-via nil) @@ -594,18 +957,21 @@ It is inserted before you edit the message, so you can edit or delete these lines." :group 'message-headers + :link '(custom-manual "(message)Message Headers") :type 'message-header-lines) (defcustom message-default-mail-headers "" "*A string of header lines to be inserted in outgoing mails." :group 'message-headers :group 'message-mail + :link '(custom-manual "(message)Mail Headers") :type 'message-header-lines) (defcustom message-default-news-headers "" "*A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news + :link '(custom-manual "(message)News Headers") :type 'message-header-lines) ;; Note: could use /usr/ucb/mail instead of sendmail; @@ -633,6 +999,7 @@ The value should be an expression to test whether the problem will actually occur." :group 'message-sending + :link '(custom-manual "(message)Mail Variables") :type 'sexp) ;;;###autoload @@ -671,33 +1038,52 @@ "*Directory where Message auto-saves buffers if Gnus isn't running. If nil, Message won't auto-save." :group 'message-buffers + :link '(custom-manual "(message)Various Message Variables") :type '(choice directory (const :tag "Don't auto-save" nil))) -(defcustom message-buffer-naming-style 'unique - "*The way new message buffers are named. -Valid values are `unique' and `unsent'." - :version "21.1" - :group 'message-buffers - :type '(choice (const :tag "unique" unique) - (const :tag "unsent" unsent))) - (defcustom message-default-charset (and (not (mm-multibyte-p)) 'iso-8859-1) "Default charset used in non-MULE Emacsen. If nil, you might be asked to input the charset." :version "21.1" :group 'message + :link '(custom-manual "(message)Various Message Variables") :type 'symbol) (defcustom message-dont-reply-to-names (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) - "*A regexp specifying names to prune when doing wide replies. -A value of nil means exclude your own name only." + "*A regexp specifying addresses to prune when doing wide replies. +A value of nil means exclude your own user name only." :version "21.1" :group 'message + :link '(custom-manual "(message)Wide Reply") :type '(choice (const :tag "Yourself" nil) regexp)) +(defvar message-shoot-gnksa-feet nil + "*A list of GNKSA feet you are allowed to shoot. +Gnus gives you all the opportunity you could possibly want for +shooting yourself in the foot. Also, Gnus allows you to shoot the +feet of Good Net-Keeping Seal of Approval. The following are foot +candidates: +`empty-article' Allow you to post an empty article; +`quoted-text-only' Allow you to post quoted text only; +`multiple-copies' Allow you to post multiple copies; +`cancel-messages' Allow you to cancel or supersede messages from + your other email addresses.") + +(defsubst message-gnksa-enable-p (feature) + (or (not (listp message-shoot-gnksa-feet)) + (memq feature message-shoot-gnksa-feet))) + +(defcustom message-hidden-headers nil + "Regexp of headers to be hidden when composing new messages. +This can also be a list of regexps to match headers. Or a list +starting with `not' and followed by regexps." + :group 'message + :link '(custom-manual "(message)Message Headers") + :type '(repeat regexp)) + ;;; Internal variables. ;;; Well, not really internal. @@ -709,31 +1095,27 @@ table) "Syntax table used while in Message mode.") -(defvar message-mode-abbrev-table text-mode-abbrev-table - "Abbrev table used in Message mode buffers. -Defaults to `text-mode-abbrev-table'.") - (defface message-header-to-face '((((class color) (background dark)) - (:foreground "green2" :weight bold)) + (:foreground "green2" :bold t)) (((class color) (background light)) - (:foreground "MidnightBlue" :weight bold)) + (:foreground "MidnightBlue" :bold t)) (t - (:weight bold :slant italic))) + (:bold t :italic t))) "Face used for displaying From headers." :group 'message-faces) (defface message-header-cc-face '((((class color) (background dark)) - (:foreground "green4" :weight bold)) + (:foreground "green4" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue")) (t - (:weight bold))) + (:bold t))) "Face used for displaying Cc headers." :group 'message-faces) @@ -743,21 +1125,21 @@ (:foreground "green3")) (((class color) (background light)) - (:foreground "navy blue" :weight bold)) + (:foreground "navy blue" :bold t)) (t - (:weight bold))) + (:bold t))) "Face used for displaying subject headers." :group 'message-faces) (defface message-header-newsgroups-face '((((class color) (background dark)) - (:foreground "yellow" :weight bold :slant italic)) + (:foreground "yellow" :bold t :italic t)) (((class color) (background light)) - (:foreground "blue4" :weight bold :slant italic)) + (:foreground "blue4" :bold t :italic t)) (t - (:weight bold :slant italic))) + (:bold t :italic t))) "Face used for displaying newsgroups headers." :group 'message-faces) @@ -769,7 +1151,7 @@ (background light)) (:foreground "steel blue")) (t - (:weight bold :slant italic))) + (:bold t :italic t))) "Face used for displaying newsgroups headers." :group 'message-faces) @@ -781,7 +1163,7 @@ (background light)) (:foreground "cornflower blue")) (t - (:weight bold))) + (:bold t))) "Face used for displaying header names." :group 'message-faces) @@ -793,7 +1175,7 @@ (background light)) (:foreground "blue")) (t - (:weight bold))) + (:bold t))) "Face used for displaying X-Header headers." :group 'message-faces) @@ -805,7 +1187,7 @@ (background light)) (:foreground "brown")) (t - (:weight bold))) + (:bold t))) "Face used for displaying the separator." :group 'message-faces) @@ -817,7 +1199,7 @@ (background light)) (:foreground "red")) (t - (:weight bold))) + (:bold t))) "Face used for displaying cited text names." :group 'message-faces) @@ -829,30 +1211,52 @@ (background light)) (:foreground "ForestGreen")) (t - (:weight bold))) + (:bold t))) "Face used for displaying MML." :group 'message-faces) +(defun message-font-lock-make-header-matcher (regexp) + (let ((form + `(lambda (limit) + (let ((start (point))) + (save-restriction + (widen) + (goto-char (point-min)) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (setq limit (min limit (match-beginning 0)))) + (goto-char start)) + (and (< start limit) + (re-search-forward ,regexp limit t)))))) + (if (featurep 'bytecomp) + (byte-compile form) + form))) + (defvar message-font-lock-keywords - (let* ((cite-prefix "[:alpha:]") - (cite-suffix (concat cite-prefix "0-9_.@-")) - (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) - `((,(concat "^\\([Tt]o:\\)" content) + (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) + `((,(message-font-lock-make-header-matcher + (concat "^\\([Tt]o:\\)" content)) (1 'message-header-name-face) (2 'message-header-to-face nil t)) - (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)) (1 'message-header-name-face) (2 'message-header-cc-face nil t)) - (,(concat "^\\([Ss]ubject:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\([Ss]ubject:\\)" content)) (1 'message-header-name-face) (2 'message-header-subject-face nil t)) - (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) (1 'message-header-name-face) (2 'message-header-newsgroups-face nil t)) - (,(concat "^\\([A-Z][^: \n\t]+:\\)" content) + (,(message-font-lock-make-header-matcher + (concat "^\\([A-Z][^: \n\t]+:\\)" content)) (1 'message-header-name-face) (2 'message-header-other-face nil t)) - (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content) + (,(message-font-lock-make-header-matcher + (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) (1 'message-header-name-face) (2 'message-header-name-face)) ,@(if (and mail-header-separator @@ -860,14 +1264,17 @@ `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") 1 'message-separator-face)) nil) - (,(concat "^[ \t]*" - "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "[:>|}].*") + ((lambda (limit) + (re-search-forward (concat "^\\(" + message-cite-prefix-regexp + "\\).*") + limit t)) (0 'message-cited-text-face)) - ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>" + ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>" (0 'message-mml-face)))) "Additional expressions to highlight in Message mode.") + ;; XEmacs does it like this. For Emacs, we have to set the ;; `font-lock-defaults' buffer-local variable. (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) @@ -882,19 +1289,27 @@ The cdr of each entry is a function for applying the face to a region.") (defcustom message-send-hook nil - "Hook run before sending messages." + "Hook run before sending messages. +This hook is run quite early when sending." :group 'message-various :options '(ispell-message) + :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-send-mail-hook nil - "Hook run before sending mail messages." + "Hook run before sending mail messages. +This hook is run very late -- just before the message is sent as +mail." :group 'message-various + :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-send-news-hook nil - "Hook run before sending news messages." + "Hook run before sending news messages. +This hook is run very late -- just before the message is sent as +news." :group 'message-various + :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-sent-hook nil @@ -907,7 +1322,10 @@ (defvar message-draft-coding-system mm-auto-save-coding-system - "Coding system to compose mail.") + "*Coding system to compose mail. +If you'd like to make it possible to share draft files between XEmacs +and Emacs, you may use `iso-2022-7bit' for this value at your own risk. +Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") (defcustom message-send-mail-partially-limit 1000000 "The limitation of messages sent as message/partial. @@ -915,6 +1333,7 @@ should be sent in several parts. If it is nil, the size is unlimited." :version "21.1" :group 'message-buffers + :link '(custom-manual "(message)Mail Variables") :type '(choice (const :tag "unlimited" nil) (integer 1000000))) @@ -922,9 +1341,23 @@ "A regexp to match the alternative email addresses. The first matched address (not primary one) is used in the From field." :group 'message-headers + :link '(custom-manual "(message)Message Headers") :type '(choice (const :tag "Always use primary" nil) regexp)) +(defcustom message-hierarchical-addresses nil + "A list of hierarchical mail address definitions. + +Inside each entry, the first address is the \"top\" address, and +subsequent addresses are subaddresses; this is used to indicate that +mail sent to the first address will automatically be delivered to the +subaddresses. So if the first address appears in the recipient list +for a message, the subaddresses will be removed (if present) before +the mail is sent. All addresses in this structure should be +downcased." + :group 'message-headers + :type '(repeat (repeat string))) + (defcustom message-mail-user-agent nil "Like `mail-user-agent'. Except if it is nil, use Gnus native MUA; if it is t, use @@ -945,6 +1378,37 @@ :version "21.1" :group 'message) +(defcustom message-wide-reply-confirm-recipients nil + "Whether to confirm a wide reply to multiple email recipients. +If this variable is nil, don't ask whether to reply to all recipients. +If this variable is non-nil, pose the question \"Reply to all +recipients?\" before a wide reply to multiple recipients. If the user +answers yes, reply to all recipients as usual. If the user answers +no, only reply back to the author." + :version "21.3" + :group 'message-headers + :link '(custom-manual "(message)Wide Reply") + :type 'boolean) + +(defcustom message-user-fqdn nil + "*Domain part of Messsage-Ids." + :group 'message-headers + :link '(custom-manual "(message)News Headers") + :type '(radio (const :format "%v " nil) + (string :format "FQDN: %v\n" :size 0))) + +(defcustom message-use-idna (and (condition-case nil (require 'idna) + (file-error)) + (mm-coding-system-p 'utf-8) + (executable-find idna-program) + 'ask) + "Whether to encode non-ASCII in domain names into ASCII according to IDNA." + :group 'message-headers + :link '(custom-manual "(message)IDNA") + :type '(choice (const :tag "Ask" ask) + (const :tag "Never" nil) + (const :tag "Always" t))) + ;;; Internal variables. (defvar message-sending-message "Sending...") @@ -954,6 +1418,7 @@ (defvar message-draft-article nil) (defvar message-mime-part nil) (defvar message-posting-charset nil) +(defvar message-inserted-headers nil) ;; Byte-compiler warning (eval-when-compile @@ -979,7 +1444,7 @@ ;; can be removed, e.g. ;; From: joe@y.z (Joe K ;; User) - ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and + ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and ;; From: Joe User ;; <joe@y.z> ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. @@ -991,7 +1456,7 @@ ;; We want to match the results of any of these manglings. ;; The following regexp rejects names whose first characters are ;; obviously bogus, but after that anything goes. - "\\([^\0-\b\n-\r\^?].*\\)? " + "\\([^\0-\b\n-\r\^?].*\\)?" ;; The time the message was sent. "\\([^\0-\r \^?]+\\) +" ; day of the week @@ -1044,6 +1509,28 @@ (User-Agent)) "Alist used for formatting headers.") +(defvar message-options nil + "Some saved answers when sending message.") + +(defvar message-send-mail-real-function nil + "Internal send mail function.") + +(defvar message-bogus-system-names "^localhost\\." + "The regexp of bogus system names.") + +(defcustom message-valid-fqdn-regexp + (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain. + ;; valid TLDs: + "\\([a-z][a-z]" ;; two letter country TDLs + "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org" + "\\|aero\\|coop\\|info\\|name\\|museum" + "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style? + "\\)") + "Regular expression that matches a valid FQDN." + ;; see also: gnus-button-valid-fqdn-regexp + :group 'message-headers + :type 'regexp) + (eval-and-compile (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-new-draft-name "mh-comp") @@ -1052,14 +1539,19 @@ (autoload 'gnus-point-at-bol "gnus-util") (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'gnus-output-to-mail "gnus-util") - (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") (autoload 'nndraft-request-expire-articles "nndraft") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-alive-p "gnus-util") + (autoload 'gnus-server-string "gnus") (autoload 'gnus-group-name-charset "gnus-group") - (autoload 'rmail-output "rmailout")) + (autoload 'gnus-group-name-decode "gnus-group") + (autoload 'gnus-groups-from-server "gnus") + (autoload 'rmail-output "rmailout") + (autoload 'gnus-delay-article "gnus-delay") + (autoload 'gnus-make-local-hook "gnus-util") + (autoload 'gnus-extract-address-components "gnus-util")) @@ -1076,14 +1568,18 @@ `(delete-region (progn (beginning-of-line) (point)) (progn (forward-line ,(or n 1)) (point)))) +(defun message-mark-active-p () + "Non-nil means the mark and region are currently active in this buffer." + mark-active) + (defun message-unquote-tokens (elems) "Remove double quotes (\") from strings in list ELEMS." (mapcar (lambda (item) - (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) - (setq item (concat (match-string 1 item) - (match-string 2 item)))) - item) - elems)) + (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) + (setq item (concat (match-string 1 item) + (match-string 2 item)))) + item) + elems)) (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. @@ -1095,8 +1591,8 @@ (beg 1) (first t) quoted elems paren) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (insert header) (goto-char (point-min)) (while (not (eobp)) @@ -1118,7 +1614,7 @@ ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) - (nreverse elems))))) + (nreverse elems))))) (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." @@ -1131,7 +1627,9 @@ (looking-at message-unix-mail-delimiter)))) (defun message-fetch-field (header &optional not-all) - "The same as `mail-fetch-field', only remove all newlines." + "The same as `mail-fetch-field', only remove all newlines. +The buffer is expected to be narrowed to just the header of the message; +see `message-narrow-to-headers-or-head'." (let* ((inhibit-point-motion-hooks t) (case-fold-search t) (value (mail-fetch-field header nil (not not-all)))) @@ -1141,6 +1639,13 @@ (set-text-properties 0 (length value) nil value) value))) +(defun message-field-value (header &optional not-all) + "The same as `message-fetch-field', only narrow to the headers first." + (save-excursion + (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field header not-all)))) + (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." (beginning-of-line) @@ -1165,33 +1670,30 @@ (save-restriction (message-narrow-to-headers) (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) - (insert (car headers) ?\n)))) + (goto-char (point-max)) + (if (string-match "\n$" (car headers)) + (insert (car headers)) + (insert (car headers) ?\n))))) (setq headers (cdr headers)))) +(defmacro message-with-reply-buffer (&rest forms) + "Evaluate FORMS in the reply buffer, if it exists." + `(when (and message-reply-buffer + (buffer-name message-reply-buffer)) + (save-excursion + (set-buffer message-reply-buffer) + ,@forms))) + +(put 'message-with-reply-buffer 'lisp-indent-function 0) +(put 'message-with-reply-buffer 'edebug-form-spec '(body)) (defun message-fetch-reply-field (header) "Fetch field HEADER from the message we're replying to." - (when (and message-reply-buffer - (buffer-name message-reply-buffer)) - (save-excursion - (set-buffer message-reply-buffer) + (message-with-reply-buffer + (save-restriction + (mail-narrow-to-head) (message-fetch-field header)))) -(defun message-set-work-buffer () - (if (get-buffer " *message work*") - (progn - (set-buffer " *message work*") - (erase-buffer)) - (set-buffer (get-buffer-create " *message work*")) - (kill-all-local-variables) - (mm-enable-multibyte))) - -(defun message-functionp (form) - "Return non-nil if FORM is funcallable." - (or (and (symbolp form) (fboundp form)) - (and (listp form) (eq (car form) 'lambda)) - (byte-code-function-p form))) - (defun message-strip-list-identifiers (subject) "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT." (require 'gnus-sum) ; for gnus-list-identifiers @@ -1199,7 +1701,7 @@ gnus-list-identifiers (mapconcat 'identity gnus-list-identifiers " *\\|")))) (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp - " *\\)\\)+\\(Re: +\\)?\\)") subject) + " *\\)\\)+\\(Re: +\\)?\\)") subject) (concat (substring subject 0 (match-beginning 1)) (or (match-string 3 subject) (match-string 5 subject)) @@ -1213,6 +1715,265 @@ (substring subject (match-end 0)) subject)) +;;; Start of functions adopted from `message-utils.el'. + +(defun message-strip-subject-trailing-was (subject) + "Remove trailing \"(Was: <old subject>)\" from SUBJECT lines. +Leading \"Re: \" is not stripped by this function. Use the function +`message-strip-subject-re' for this." + (let* ((query message-subject-trailing-was-query) + (new) (found)) + (setq found + (string-match + (if (eq query 'ask) + message-subject-trailing-was-ask-regexp + message-subject-trailing-was-regexp) + subject)) + (if found + (setq new (substring subject 0 (match-beginning 0)))) + (if (or (not found) (eq query nil)) + subject + (if (eq query 'ask) + (if (message-y-or-n-p + "Strip `(was: <old subject>)' in subject? " t + (concat + "Strip `(was: <old subject>)' in subject " + "and use the new one instead?\n\n" + "Current subject is: \"" + subject "\"\n\n" + "New subject would be: \"" + new "\"\n\n" + "See the variable `message-subject-trailing-was-query' " + "to get rid of this query." + )) + new subject) + new)))) + +;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/ + +;;;###autoload +(defun message-change-subject (new-subject) + "Ask for NEW-SUBJECT header, append (was: <Old Subject>)." + ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged> + (interactive + (list + (read-from-minibuffer "New subject: "))) + (cond ((and (not (or (null new-subject) ; new subject not empty + (zerop (string-width new-subject)) + (string-match "^[ \t]*$" new-subject)))) + (save-excursion + (let ((old-subject + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "Subject")))) + (cond ((not old-subject) + (error "No current subject")) + ((not (string-match + (concat "^[ \t]*" + (regexp-quote new-subject) + " \t]*$") + old-subject)) ; yes, it really is a new subject + ;; delete eventual Re: prefix + (setq old-subject + (message-strip-subject-re old-subject)) + (message-goto-subject) + (message-delete-line) + (insert (concat "Subject: " + new-subject + " (was: " + old-subject ")\n"))))))))) + +;;;###autoload +(defun message-mark-inserted-region (beg end) + "Mark some region in the current article with enclosing tags. +See `message-mark-insert-begin' and `message-mark-insert-end'." + (interactive "r") + (save-excursion + ;; add to the end of the region first, otherwise end would be invalid + (goto-char end) + (insert message-mark-insert-end) + (goto-char beg) + (insert message-mark-insert-begin))) + +;;;###autoload +(defun message-mark-insert-file (file) + "Insert FILE at point, marking it with enclosing tags. +See `message-mark-insert-begin' and `message-mark-insert-end'." + (interactive "fFile to insert: ") + ;; reverse insertion to get correct result. + (let ((p (point))) + (insert message-mark-insert-end) + (goto-char p) + (insert-file-contents file) + (goto-char p) + (insert message-mark-insert-begin))) + +;;;###autoload +(defun message-add-archive-header () + "Insert \"X-No-Archive: Yes\" in the header and a note in the body. +The note can be customized using `message-archive-note'. When called with a +prefix argument, ask for a text to insert. If you don't want the note in the +body, set `message-archive-note' to nil." + (interactive) + (if current-prefix-arg + (setq message-archive-note + (read-from-minibuffer "Reason for No-Archive: " + (cons message-archive-note 0)))) + (save-excursion + (if (message-goto-signature) + (re-search-backward message-signature-separator)) + (when message-archive-note + (insert message-archive-note) + (newline)) + (message-add-header message-archive-header) + (message-sort-headers))) + +;;;###autoload +(defun message-cross-post-followup-to-header (target-group) + "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP. +With prefix-argument just set Follow-Up, don't cross-post." + (interactive + (list ; Completion based on Gnus + (completing-read "Followup To: " + (if (boundp 'gnus-newsrc-alist) + gnus-newsrc-alist) + nil nil '("poster" . 0) + (if (boundp 'gnus-group-history) + 'gnus-group-history)))) + (message-remove-header "Follow[Uu]p-[Tt]o" t) + (message-goto-newsgroups) + (beginning-of-line) + ;; if we already did a crosspost before, kill old target + (if (and message-cross-post-old-target + (re-search-forward + (regexp-quote (concat "," message-cross-post-old-target)) + nil t)) + (replace-match "")) + ;; unless (followup is to poster or user explicitly asked not + ;; to cross-post, or target-group is already in Newsgroups) + ;; add target-group to Newsgroups line. + (cond ((and (or + ;; def: cross-post, req:no + (and message-cross-post-default (not current-prefix-arg)) + ;; def: no-cross-post, req:yes + (and (not message-cross-post-default) current-prefix-arg)) + (not (string-match "poster" target-group)) + (not (string-match (regexp-quote target-group) + (message-fetch-field "Newsgroups")))) + (end-of-line) + (insert (concat "," target-group)))) + (end-of-line) ; ensure Followup: comes after Newsgroups: + ;; unless new followup would be identical to Newsgroups line + ;; make a new Followup-To line + (if (not (string-match (concat "^[ \t]*" + target-group + "[ \t]*$") + (message-fetch-field "Newsgroups"))) + (insert (concat "\nFollowup-To: " target-group))) + (setq message-cross-post-old-target target-group)) + +;;;###autoload +(defun message-cross-post-insert-note (target-group cross-post in-old + old-groups) + "Insert a in message body note about a set Followup or Crosspost. +If there have been previous notes, delete them. TARGET-GROUP specifies the +group to Followup-To. When CROSS-POST is t, insert note about +crossposting. IN-OLD specifies whether TARGET-GROUP is a member of +OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have +been made to before the user asked for a Crosspost." + ;; start scanning body for previous uses + (message-goto-signature) + (let ((head (re-search-backward + (concat "^" mail-header-separator) + nil t))) ; just search in body + (message-goto-signature) + (while (re-search-backward + (concat "^" (regexp-quote message-cross-post-note) ".*") + head t) + (message-delete-line)) + (message-goto-signature) + (while (re-search-backward + (concat "^" (regexp-quote message-followup-to-note) ".*") + head t) + (message-delete-line)) + ;; insert new note + (if (message-goto-signature) + (re-search-backward message-signature-separator)) + (if (or in-old + (not cross-post) + (string-match "^[ \t]*poster[ \t]*$" target-group)) + (insert (concat message-followup-to-note target-group "\n")) + (insert (concat message-cross-post-note target-group "\n"))))) + +;;;###autoload +(defun message-cross-post-followup-to (target-group) + "Crossposts message and set Followup-To to TARGET-GROUP. +With prefix-argument just set Follow-Up, don't cross-post." + (interactive + (list ; Completion based on Gnus + (completing-read "Followup To: " + (if (boundp 'gnus-newsrc-alist) + gnus-newsrc-alist) + nil nil '("poster" . 0) + (if (boundp 'gnus-group-history) + 'gnus-group-history)))) + (cond ((not (or (null target-group) ; new subject not empty + (zerop (string-width target-group)) + (string-match "^[ \t]*$" target-group))) + (save-excursion + (let* ((old-groups (message-fetch-field "Newsgroups")) + (in-old (string-match + (regexp-quote target-group) + (or old-groups "")))) + ;; check whether target exactly matches old Newsgroups + (cond ((not old-groups) + (error "No current newsgroup")) + ((or (not in-old) + (not (string-match + (concat "^[ \t]*" + (regexp-quote target-group) + "[ \t]*$") + old-groups))) + ;; yes, Newsgroups line must change + (message-cross-post-followup-to-header target-group) + ;; insert note whether we do cross-post or followup-to + (funcall message-cross-post-note-function + target-group + (if (or (and message-cross-post-default + (not current-prefix-arg)) + (and (not message-cross-post-default) + current-prefix-arg)) t) + in-old old-groups)))))))) + +;;; Reduce To: to Cc: or Bcc: header + +;;;###autoload +(defun message-reduce-to-to-cc () + "Replace contents of To: header with contents of Cc: or Bcc: header." + (interactive) + (let ((cc-content + (save-restriction (message-narrow-to-headers) + (message-fetch-field "cc"))) + (bcc nil)) + (if (and (not cc-content) + (setq cc-content + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "bcc")))) + (setq bcc t)) + (cond (cc-content + (save-excursion + (message-goto-to) + (message-delete-line) + (insert (concat "To: " cc-content "\n")) + (save-restriction + (message-narrow-to-headers) + (message-remove-header (if bcc + "bcc" + "cc")))))))) + +;;; End of functions adopted from `message-utils.el'. + (defun message-remove-header (header &optional is-regexp first reverse) "Remove HEADER in the narrowed buffer. If IS-REGEXP, HEADER is a regular expression. @@ -1321,6 +2082,13 @@ (message-fetch-field "cc") (message-fetch-field "bcc"))))))) +(defun message-subscribed-p () + "Say whether we need to insert a MFT header." + (or message-subscribed-regexps + message-subscribed-addresses + message-subscribed-address-file + message-subscribed-address-functions)) + (defun message-next-header () "Go to the beginning of the next header." (beginning-of-line) @@ -1364,6 +2132,7 @@ (1+ max))))) (message-sort-headers-1)))) + ;;; @@ -1380,6 +2149,7 @@ (define-key message-mode-map "\C-c?" 'describe-mode) (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) + (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from) (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc) (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) @@ -1388,13 +2158,36 @@ (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) + (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to) (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords) (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) + (define-key message-mode-map "\C-c\C-f\C-i" + 'message-insert-or-toggle-importance) + (define-key message-mode-map "\C-c\C-f\C-a" + 'message-generate-unsubscribed-mail-followup-to) + + ;; modify headers (and insert notes in body) + (define-key message-mode-map "\C-c\C-fs" 'message-change-subject) + ;; + (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to) + ;; prefix+message-cross-post-followup-to = same w/o cross-post + (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc) + (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header) + ;; mark inserted text + (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region) + (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file) + (define-key message-mode-map "\C-c\C-b" 'message-goto-body) (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) (define-key message-mode-map "\C-c\C-t" 'message-insert-to) + (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply) (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) + (define-key message-mode-map "\C-c\C-l" 'message-to-list-only) + + (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance) + (define-key message-mode-map "\C-c\M-n" + 'message-insert-disposition-notification-to) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) @@ -1409,67 +2202,187 @@ (define-key message-mode-map "\C-c\C-s" 'message-send) (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) (define-key message-mode-map "\C-c\C-d" 'message-dont-send) + (define-key message-mode-map "\C-c\n" 'gnus-delay-article) (define-key message-mode-map "\C-c\C-e" 'message-elide-region) (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) + ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph) (define-key message-mode-map [remap split-line] 'message-split-line) (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) - (define-key message-mode-map "\t" 'message-tab)) + (define-key message-mode-map "\C-a" 'message-beginning-of-line) + (define-key message-mode-map "\t" 'message-tab) + (define-key message-mode-map "\M-;" 'comment-region)) + +(easy-menu-define + message-mode-menu message-mode-map "Message Menu." + `("Message" + ["Yank Original" message-yank-original message-reply-buffer] + ["Fill Yanked Message" message-fill-yanked-message t] + ["Insert Signature" message-insert-signature t] + ["Caesar (rot13) Message" message-caesar-buffer-body t] + ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)] + ["Elide Region" message-elide-region + :active (message-mark-active-p) + ,@(if (featurep 'xemacs) nil + '(:help "Replace text in region with an ellipsis"))] + ["Delete Outside Region" message-delete-not-region + :active (message-mark-active-p) + ,@(if (featurep 'xemacs) nil + '(:help "Delete all quoted text outside region"))] + ["Kill To Signature" message-kill-to-signature t] + ["Newline and Reformat" message-newline-and-reformat t] + ["Rename buffer" message-rename-buffer t] + ["Spellcheck" ispell-message + ,@(if (featurep 'xemacs) '(t) + '(:help "Spellcheck this message"))] + "----" + ["Insert Region Marked" message-mark-inserted-region + :active (message-mark-active-p) + ,@(if (featurep 'xemacs) nil + '(:help "Mark region with enclosing tags"))] + ["Insert File Marked..." message-mark-insert-file + ,@(if (featurep 'xemacs) '(t) + '(:help "Insert file at point marked with enclosing tags"))] + "----" + ["Send Message" message-send-and-exit + ,@(if (featurep 'xemacs) '(t) + '(:help "Send this message"))] + ["Postpone Message" message-dont-send + ,@(if (featurep 'xemacs) '(t) + '(:help "File this draft message and exit"))] + ["Send at Specific Time..." gnus-delay-article + ,@(if (featurep 'xemacs) '(t) + '(:help "Ask, then arrange to send message at that time"))] + ["Kill Message" message-kill-buffer + ,@(if (featurep 'xemacs) '(t) + '(:help "Delete this message without sending"))])) (easy-menu-define - message-mode-menu message-mode-map "Message Menu." - '("Message" - ["Sort Headers" message-sort-headers t] - ["Yank Original" message-yank-original t] - ["Fill Yanked Message" message-fill-yanked-message t] - ["Insert Signature" message-insert-signature t] - ["Caesar (rot13) Message" message-caesar-buffer-body t] - ["Caesar (rot13) Region" message-caesar-region (mark t)] - ["Elide Region" message-elide-region (mark t)] - ["Delete Outside Region" message-delete-not-region (mark t)] - ["Kill To Signature" message-kill-to-signature t] - ["Newline and Reformat" message-newline-and-reformat t] - ["Rename buffer" message-rename-buffer t] - ["Spellcheck" ispell-message - :help "Spellcheck this message"] - ["Attach file as MIME" mml-attach-file - :help "Attach a file at point"] - "----" - ["Send Message" message-send-and-exit - :help "Send this message"] - ["Abort Message" message-dont-send - :help "File this draft message and exit"] - ["Kill Message" message-kill-buffer - :help "Delete this message without sending"])) - -(easy-menu-define - message-mode-field-menu message-mode-map "" - '("Field" - ["Fetch To" message-insert-to t] - ["Fetch Newsgroups" message-insert-newsgroups t] - "----" - ["To" message-goto-to t] - ["Subject" message-goto-subject t] - ["Cc" message-goto-cc t] - ["Reply-To" message-goto-reply-to t] - ["Summary" message-goto-summary t] - ["Keywords" message-goto-keywords t] - ["Newsgroups" message-goto-newsgroups t] - ["Followup-To" message-goto-followup-to t] - ["Distribution" message-goto-distribution t] - ["Body" message-goto-body t] - ["Signature" message-goto-signature t])) + message-mode-field-menu message-mode-map "" + `("Field" + ["To" message-goto-to t] + ["From" message-goto-from t] + ["Subject" message-goto-subject t] + ["Change subject..." message-change-subject t] + ["Cc" message-goto-cc t] + ["Bcc" message-goto-bcc t] + ["Fcc" message-goto-fcc t] + ["Reply-To" message-goto-reply-to t] + ["Flag As Important" message-insert-importance-high + ,@(if (featurep 'xemacs) '(t) + '(:help "Mark this message as important"))] + ["Flag As Unimportant" message-insert-importance-low + ,@(if (featurep 'xemacs) '(t) + '(:help "Mark this message as unimportant"))] + ["Request Receipt" + message-insert-disposition-notification-to + ,@(if (featurep 'xemacs) '(t) + '(:help "Request a receipt notification"))] + "----" + ;; (typical) news stuff + ["Summary" message-goto-summary t] + ["Keywords" message-goto-keywords t] + ["Newsgroups" message-goto-newsgroups t] + ["Fetch Newsgroups" message-insert-newsgroups t] + ["Followup-To" message-goto-followup-to t] + ;; ["Followup-To (with note in body)" message-cross-post-followup-to t] + ["Crosspost / Followup-To..." message-cross-post-followup-to t] + ["Distribution" message-goto-distribution t] + ["X-No-Archive:" message-add-archive-header t ] + "----" + ;; (typical) mailing-lists stuff + ["Fetch To" message-insert-to + ,@(if (featurep 'xemacs) '(t) + '(:help "Insert a To header that points to the author."))] + ["Fetch To and Cc" message-insert-wide-reply + ,@(if (featurep 'xemacs) '(t) + '(:help + "Insert To and Cc headers as if you were doing a wide reply."))] + "----" + ["Send to list only" message-to-list-only t] + ["Mail-Followup-To" message-goto-mail-followup-to t] + ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to + ,@(if (featurep 'xemacs) '(t) + '(:help "Insert a reasonable `Mail-Followup-To:' header."))] + ["Reduce To: to Cc:" message-reduce-to-to-cc t] + "----" + ["Sort Headers" message-sort-headers t] + ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t] + ["Goto Body" message-goto-body t] + ["Goto Signature" message-goto-signature t])) + +(defvar message-tool-bar-map nil) (eval-when-compile (defvar facemenu-add-face-function) (defvar facemenu-remove-face-function)) +;;; Forbidden properties +;; +;; We use `after-change-functions' to keep special text properties +;; that interfer with the normal function of message mode out of the +;; buffer. + +(defcustom message-strip-special-text-properties t + "Strip special properties from the message buffer. + +Emacs has a number of special text properties which can break message +composing in various ways. If this option is set, message will strip +these properties from the message composition buffer. However, some +packages requires these properties to be present in order to work. +If you use one of these packages, turn this option off, and hope the +message composition doesn't break too bad." + :group 'message-various + :link '(custom-manual "(message)Various Message Variables") + :type 'boolean) + +(defconst message-forbidden-properties + ;; No reason this should be clutter up customize. We make it a + ;; property list (rather than a list of property symbols), to be + ;; directly useful for `remove-text-properties'. + '(field nil read-only nil invisible nil intangible nil + mouse-face nil modification-hooks nil insert-in-front-hooks nil + insert-behind-hooks nil point-entered nil point-left nil) + ;; Other special properties: + ;; category, face, display: probably doesn't do any harm. + ;; fontified: is used by font-lock. + ;; syntax-table, local-map: I dunno. + ;; We need to add XEmacs names to the list. + "Property list of with properties.forbidden in message buffers. +The values of the properties are ignored, only the property names are used.") + +(defun message-tamago-not-in-use-p (pos) + "Return t when tamago version 4 is not in use at the cursor position. +Tamago version 4 is a popular input method for writing Japanese text. +It uses the properties `intangible', `invisible', `modification-hooks' +and `read-only' when translating ascii or kana text to kanji text. +These properties are essential to work, so we should never strip them." + (not (and (boundp 'egg-modefull-mode) + (symbol-value 'egg-modefull-mode) + (or (memq (get-text-property pos 'intangible) + '(its-part-1 its-part-2)) + (get-text-property pos 'egg-end) + (get-text-property pos 'egg-lang) + (get-text-property pos 'egg-start))))) + +(defun message-strip-forbidden-properties (begin end &optional old-length) + "Strip forbidden properties between BEGIN and END, ignoring the third arg. +This function is intended to be called from `after-change-functions'. +See also `message-forbidden-properties'." + (when (and message-strip-special-text-properties + (message-tamago-not-in-use-p begin)) + (while (not (= begin end)) + (when (not (get-text-property begin 'message-hidden)) + (remove-text-properties begin (1+ begin) + message-forbidden-properties)) + (incf begin)))) + ;;;###autoload -(defun message-mode () +(define-derived-mode message-mode text-mode "Message" "Major mode for editing mail and news to be sent. Like Text Mode but with these additional commands:\\<message-mode-map> C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit' @@ -1480,8 +2393,16 @@ C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution + C-c C-f C-o move to From (\"Originator\") C-c C-f C-f move to Followup-To + C-c C-f C-m move to Mail-Followup-To + C-c C-f C-i cycle through Importance values + C-c C-f s change subject and append \"(was: <Old Subject>)\" + C-c C-f x crossposting with FollowUp-To header and note in body + C-c C-f t replace To: header with contents of Cc: or Bcc: + C-c C-f a Insert X-No-Archive: header and a note in the body C-c C-t `message-insert-to' (add a To header to a news followup) +C-c C-l `message-to-list-only' (removes all but list address in to/cc) C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) C-c C-b `message-goto-body' (move to beginning of message text). C-c C-i `message-goto-signature' (move to the beginning of the signature). @@ -1493,36 +2414,29 @@ C-c C-z `message-kill-to-signature' (kill the text up to the signature). C-c C-r `message-caesar-buffer-body' (rot13 the message body). C-c C-a `mml-attach-file' (attach a file as MIME). +C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance). +C-c M-n `message-insert-disposition-notification-to' (request receipt). +C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). +C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). M-RET `message-newline-and-reformat' (break the line and reformat)." - (interactive) - (if (local-variable-p 'mml-buffer-list (current-buffer)) - (mml-destroy-buffers)) - (kill-all-local-variables) + (setq local-abbrev-table text-mode-abbrev-table) (set (make-local-variable 'message-reply-buffer) nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) - (make-local-variable 'message-kill-actions) - (make-local-variable 'message-postpone-actions) - (make-local-variable 'message-draft-article) - (make-local-hook 'kill-buffer-hook) - (set-syntax-table message-mode-syntax-table) - (use-local-map message-mode-map) - (setq local-abbrev-table message-mode-abbrev-table) - (setq major-mode 'message-mode) - (setq mode-name "Message") + (set (make-local-variable 'message-inserted-headers) nil) + (set (make-local-variable 'message-send-actions) nil) + (set (make-local-variable 'message-exit-actions) nil) + (set (make-local-variable 'message-kill-actions) nil) + (set (make-local-variable 'message-postpone-actions) nil) + (set (make-local-variable 'message-draft-article) nil) (setq buffer-offer-save t) - (make-local-variable 'facemenu-add-face-function) - (make-local-variable 'facemenu-remove-face-function) - (setq facemenu-add-face-function - (lambda (face end) - (let ((face-fun (cdr (assq face message-face-alist)))) - (if face-fun - (funcall face-fun (point) end) - (error "Face %s not configured for %s mode" face mode-name))) - "") - facemenu-remove-face-function t) - (make-local-variable 'message-reply-headers) - (setq message-reply-headers nil) + (set (make-local-variable 'facemenu-add-face-function) + (lambda (face end) + (let ((face-fun (cdr (assq face message-face-alist)))) + (if face-fun + (funcall face-fun (point) end) + (error "Face %s not configured for %s mode" face mode-name))) + "")) + (set (make-local-variable 'facemenu-remove-face-function) t) + (set (make-local-variable 'message-reply-headers) nil) (make-local-variable 'message-newsreader) (make-local-variable 'message-mailer) (make-local-variable 'message-post-method) @@ -1530,66 +2444,81 @@ (set (make-local-variable 'message-checksum) nil) (set (make-local-variable 'message-mime-part) 0) (message-setup-fill-variables) + (set + (make-local-variable 'paragraph-separate) + (format "\\(%s\\)\\|\\(%s\\)" + paragraph-separate + "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)")) ;; Allow using comment commands to add/remove quoting. - (when message-yank-prefix - (set (make-local-variable 'comment-start) message-yank-prefix) - (set (make-local-variable 'comment-start-skip) - (concat "^" (regexp-quote message-yank-prefix) "[ \t]*"))) - ;;(when (fboundp 'mail-hist-define-keys) - ;; (mail-hist-define-keys)) + (set (make-local-variable 'comment-start) message-yank-prefix) (if (featurep 'xemacs) (message-setup-toolbar) (set (make-local-variable 'font-lock-defaults) '(message-font-lock-keywords t)) - (if (boundp 'message-tool-bar-map) - (set (make-local-variable 'tool-bar-map) message-tool-bar-map))) + (if (boundp 'tool-bar-map) + (set (make-local-variable 'tool-bar-map) (message-tool-bar-map)))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) + (gnus-make-local-hook 'after-change-functions) + ;; Mmmm... Forbidden properties... + (add-hook 'after-change-functions 'message-strip-forbidden-properties + nil 'local) ;; Allow mail alias things. (when (eq message-mail-alias-type 'abbrev) (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) - (mail-aliases-setup))) + (if (fboundp 'mail-aliases-setup) ; warning avoidance + (mail-aliases-setup)))) (unless buffer-file-name (message-set-auto-save-file-name)) - (mm-enable-multibyte) - (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation. - (setq indent-tabs-mode nil) - (mml-mode) - (run-hooks 'text-mode-hook 'message-mode-hook)) + (unless (buffer-base-buffer) + ;; Don't enable multibyte on an indirect buffer. Maybe enabling + ;; multibyte is not necessary at all. -- zsh + (mm-enable-multibyte)) + (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation. + (mml-mode)) (defun message-setup-fill-variables () "Setup message fill variables." + (set (make-local-variable 'fill-paragraph-function) + 'message-fill-paragraph) (make-local-variable 'paragraph-separate) (make-local-variable 'paragraph-start) (make-local-variable 'adaptive-fill-regexp) (unless (boundp 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp nil)) (make-local-variable 'adaptive-fill-first-line-regexp) - (make-local-variable 'auto-fill-inhibit-regexp) (let ((quote-prefix-regexp - (concat - "[ \t]*" ; possible initial space - "\\(\\(" (regexp-quote message-yank-prefix) "\\|" ; user's prefix - "\\w+>\\|" ; supercite-style prefix - "[|:>]" ; standard prefix - "\\)[ \t]*\\)+"))) ; possible space after each prefix + ;; User should change message-cite-prefix-regexp if + ;; message-yank-prefix is set to an abnormal value. + (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*"))) (setq paragraph-start - (concat - (regexp-quote mail-header-separator) "$\\|" - "[ \t]*$\\|" ; blank lines - "-- $\\|" ; signature delimiter - "---+$\\|" ; delimiters for forwarded messages - page-delimiter "$\\|" ; spoiler warnings - ".*wrote:$\\|" ; attribution lines - quote-prefix-regexp "$")) ; empty lines in quoted text + (concat + (regexp-quote mail-header-separator) "$\\|" + "[ \t]*$\\|" ; blank lines + "-- $\\|" ; signature delimiter + "---+$\\|" ; delimiters for forwarded messages + page-delimiter "$\\|" ; spoiler warnings + ".*wrote:$\\|" ; attribution lines + quote-prefix-regexp "$")) ; empty lines in quoted text (setq paragraph-separate paragraph-start) (setq adaptive-fill-regexp - (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) + (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) (setq adaptive-fill-first-line-regexp - (concat quote-prefix-regexp "\\|" - adaptive-fill-first-line-regexp)) - (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:"))) + (concat quote-prefix-regexp "\\|" + adaptive-fill-first-line-regexp))) + (make-local-variable 'auto-fill-inhibit-regexp) + ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") + (setq auto-fill-inhibit-regexp nil) + (make-local-variable 'normal-auto-fill-function) + (setq normal-auto-fill-function 'message-do-auto-fill) + ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'. + ;; In that case, ensure that it uses the right function. The real + ;; solution would be not to use `define-derived-mode', and run + ;; `text-mode-hook' ourself at the end of the mode. + ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19. + (when auto-fill-function + (setq auto-fill-function normal-auto-fill-function))) @@ -1604,6 +2533,11 @@ (interactive) (message-position-on-field "To")) +(defun message-goto-from () + "Move point to the From header." + (interactive) + (message-position-on-field "From")) + (defun message-goto-subject () "Move point to the Subject header." (interactive) @@ -1644,6 +2578,11 @@ (interactive) (message-position-on-field "Followup-To" "Newsgroups")) +(defun message-goto-mail-followup-to () + "Move point to the Mail-Followup-To header." + (interactive) + (message-position-on-field "Mail-Followup-To" "From")) + (defun message-goto-keywords () "Move point to the Keywords header." (interactive) @@ -1654,13 +2593,15 @@ (interactive) (message-position-on-field "Summary" "Subject")) -(defun message-goto-body () +(defun message-goto-body (&optional interactivep) "Move point to the beginning of the message body." - (interactive) - (if (looking-at "[ \t]*\n") (expand-abbrev)) + (interactive (list t)) + (when (and interactivep + (looking-at "[ \t]*\n")) + (expand-abbrev)) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) - (search-forward "\n\n" nil t))) + (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) (defun message-goto-eoh () "Move point to the end of the headers." @@ -1679,26 +2620,93 @@ (goto-char (point-max)) nil)) +(defun message-generate-unsubscribed-mail-followup-to (&optional include-cc) + "Insert a reasonable MFT header in a post to an unsubscribed list. +When making original posts to a mailing list you are not subscribed to, +you have to type in a MFT header by hand. The contents, usually, are +the addresses of the list and your own address. This function inserts +such a header automatically. It fetches the contents of the To: header +in the current mail buffer, and appends the current `user-mail-address'. + +If the optional argument INCLUDE-CC is non-nil, the addresses in the +Cc: header are also put into the MFT." + + (interactive "P") + (let* (cc tos) + (save-restriction + (message-narrow-to-headers) + (message-remove-header "Mail-Followup-To") + (setq cc (and include-cc (message-fetch-field "Cc"))) + (setq tos (if cc + (concat (message-fetch-field "To") "," cc) + (message-fetch-field "To")))) + (message-goto-mail-followup-to) + (insert (concat tos ", " user-mail-address)))) + (defun message-insert-to (&optional force) "Insert a To header that points to the author of the article being replied to. -If the original author requested not to be sent mail, the function signals -an error. -With the prefix argument FORCE, insert the header anyway." +If the original author requested not to be sent mail, don't insert unless the +prefix FORCE is given." (interactive "P") - (let ((co (message-fetch-reply-field "mail-copies-to"))) - (when (and (null force) - co - (or (equal (downcase co) "never") - (equal (downcase co) "nobody"))) - (error "The user has requested not to have copies sent via mail"))) - (when (and (message-position-on-field "To") - (mail-fetch-field "to") - (not (string-match "\\` *\\'" (mail-fetch-field "to")))) - (insert ", ")) - (insert (or (message-fetch-reply-field "reply-to") - (message-fetch-reply-field "from") ""))) + (let* ((mct (message-fetch-reply-field "mail-copies-to")) + (dont (and mct (or (equal (downcase mct) "never") + (equal (downcase mct) "nobody")))) + (to (or (message-fetch-reply-field "mail-reply-to") + (message-fetch-reply-field "reply-to") + (message-fetch-reply-field "from")))) + (when (and dont to) + (message + (if force + "Ignoring the user request not to have copies sent via mail" + "Complying with the user request not to have copies sent via mail"))) + (when (and force (not to)) + (error "No mail address in the article")) + (when (and to (or force (not dont))) + (message-carefully-insert-headers (list (cons 'To to)))))) + +(defun message-insert-wide-reply () + "Insert To and Cc headers as if you were doing a wide reply." + (interactive) + (let ((headers (message-with-reply-buffer + (message-get-reply-headers t)))) + (message-carefully-insert-headers headers))) + +(defcustom message-header-synonyms + '((To Cc Bcc)) + "List of lists of header synonyms. +E.g., if this list contains a member list with elements `Cc' and `To', +then `message-carefully-insert-headers' will not insert a `To' header +when the message is already `Cc'ed to the recipient." + :group 'message-headers + :link '(custom-manual "(message)Message Headers") + :type '(repeat sexp)) + +(defun message-carefully-insert-headers (headers) + "Insert the HEADERS, an alist, into the message buffer. +Does not insert the headers when they are already present there +or in the synonym headers, defined by `message-header-synonyms'." + ;; FIXME: Should compare only the address and not the full name. Comparison + ;; should be done case-folded (and with `string=' rather than + ;; `string-match'). + (dolist (header headers) + (let* ((header-name (symbol-name (car header))) + (new-header (cdr header)) + (synonyms (loop for synonym in message-header-synonyms + when (memq (car header) synonym) return synonym)) + (old-header + (loop for synonym in synonyms + for old-header = (mail-fetch-field (symbol-name synonym)) + when (and old-header (string-match new-header old-header)) + return synonym))) + (if old-header + (message "already have `%s' in `%s'" new-header old-header) + (when (and (message-position-on-field header-name) + (setq old-header (mail-fetch-field header-name)) + (not (string-match "\\` *\\'" old-header))) + (insert ", ")) + (insert new-header))))) (defun message-widen-reply () "Widen the reply to include maximum recipients." @@ -1734,17 +2742,25 @@ (defun message-delete-not-region (beg end) "Delete everything in the body of the current message outside of the region." (interactive "r") - (save-excursion - (goto-char end) - (delete-region (point) (if (not (message-goto-signature)) - (point) - (forward-line -2) - (point))) - (insert "\n") - (goto-char beg) - (delete-region beg (progn (message-goto-body) - (forward-line 2) - (point)))) + (let (citeprefix) + (save-excursion + (goto-char beg) + ;; snarf citation prefix, if appropriate + (unless (eq (point) (progn (beginning-of-line) (point))) + (when (looking-at message-cite-prefix-regexp) + (setq citeprefix (match-string 0)))) + (goto-char end) + (delete-region (point) (if (not (message-goto-signature)) + (point) + (forward-line -2) + (point))) + (insert "\n") + (goto-char beg) + (delete-region beg (progn (message-goto-body) + (forward-line 2) + (point))) + (when citeprefix + (insert citeprefix)))) (when (message-goto-signature) (forward-line -2))) @@ -1754,39 +2770,121 @@ (let ((point (point))) (message-goto-signature) (unless (eobp) - (forward-line -2)) + (end-of-line -1)) (kill-region point (point)) (unless (bolp) (insert "\n")))) -(defun message-newline-and-reformat () - "Insert four newlines, and then reformat if inside quoted text." - (interactive) - ;; The Latin-1 angle quote looks pretty dubious. -- fx - (let ((prefix "[]>»|:}+ \t]*") - (supercite-thing "[-._[:alnum:]]*[>]+[ \t]*") - quoted point) - (unless (bolp) - (save-excursion - (beginning-of-line) - (when (looking-at (concat prefix - supercite-thing)) - (setq quoted (match-string 0)))) - (insert "\n")) +(defun message-newline-and-reformat (&optional arg not-break) + "Insert four newlines, and then reformat if inside quoted text. +Prefix arg means justify as well." + (interactive (list (if current-prefix-arg 'full))) + (let (quoted point beg end leading-space bolp) (setq point (point)) - (insert "\n\n\n") - (delete-region (point) (re-search-forward "[ \t]*")) - (when quoted - (insert quoted)) - (fill-paragraph nil) + (beginning-of-line) + (setq beg (point)) + (setq bolp (= beg point)) + ;; Find first line of the paragraph. + (if not-break + (while (and (not (eobp)) + (not (looking-at message-cite-prefix-regexp)) + (looking-at paragraph-start)) + (forward-line 1))) + ;; Find the prefix + (when (looking-at message-cite-prefix-regexp) + (setq quoted (match-string 0)) + (goto-char (match-end 0)) + (looking-at "[ \t]*") + (setq leading-space (match-string 0))) + (if (and quoted + (not not-break) + (not bolp) + (< (- point beg) (length quoted))) + ;; break inside the cite prefix. + (setq quoted nil + end nil)) + (if quoted + (progn + (forward-line 1) + (while (and (not (eobp)) + (not (looking-at paragraph-separate)) + (looking-at message-cite-prefix-regexp) + (equal quoted (match-string 0))) + (goto-char (match-end 0)) + (looking-at "[ \t]*") + (if (> (length leading-space) (length (match-string 0))) + (setq leading-space (match-string 0))) + (forward-line 1)) + (setq end (point)) + (goto-char beg) + (while (and (if (bobp) nil (forward-line -1) t) + (not (looking-at paragraph-start)) + (looking-at message-cite-prefix-regexp) + (equal quoted (match-string 0))) + (setq beg (point)) + (goto-char (match-end 0)) + (looking-at "[ \t]*") + (if (> (length leading-space) (length (match-string 0))) + (setq leading-space (match-string 0))))) + (while (and (not (eobp)) + (not (looking-at paragraph-separate)) + (not (looking-at message-cite-prefix-regexp))) + (forward-line 1)) + (setq end (point)) + (goto-char beg) + (while (and (if (bobp) nil (forward-line -1) t) + (not (looking-at paragraph-start)) + (not (looking-at message-cite-prefix-regexp))) + (setq beg (point)))) (goto-char point) - (forward-line 1))) - -(defun message-split-line () - "Split current line, moving portion beyond point vertically down. -If the current line has `message-yank-prefix', insert it on the new line." - (interactive "*") - (split-line message-yank-prefix)) + (save-restriction + (narrow-to-region beg end) + (if not-break + (setq point nil) + (if bolp + (newline) + (newline) + (newline)) + (setq point (point)) + ;; (newline 2) doesn't mark both newline's as hard, so call + ;; newline twice. -jas + (newline) + (newline) + (delete-region (point) (re-search-forward "[ \t]*")) + (when (and quoted (not bolp)) + (insert quoted leading-space))) + (undo-boundary) + (if quoted + (let* ((adaptive-fill-regexp + (regexp-quote (concat quoted leading-space))) + (adaptive-fill-first-line-regexp + adaptive-fill-regexp )) + (fill-paragraph arg)) + (fill-paragraph arg)) + (if point (goto-char point))))) + +(defun message-fill-paragraph (&optional arg) + "Like `fill-paragraph'." + (interactive (list (if current-prefix-arg 'full))) + (if (if (boundp 'filladapt-mode) filladapt-mode) + nil + (message-newline-and-reformat arg t) + t)) + +;; Is it better to use `mail-header-end'? +(defun message-point-in-header-p () + "Return t if point is in the header." + (save-excursion + (let ((p (point))) + (goto-char (point-min)) + (not (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") + p t))))) + +(defun message-do-auto-fill () + "Like `do-auto-fill', but don't fill in message header." + (unless (message-point-in-header-p) + (do-auto-fill))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for variable `message-signature'." @@ -1801,7 +2899,7 @@ ((and (null message-signature) force) t) - ((message-functionp message-signature) + ((functionp message-signature) (funcall message-signature)) ((listp message-signature) (eval message-signature)) @@ -1818,13 +2916,71 @@ ;; Insert the signature. (unless (bolp) (insert "\n")) - (insert "\n-- \n") + (when message-signature-insert-empty-line + (insert "\n")) + (insert "-- \n") (if (eq signature t) (insert-file-contents message-signature-file) (insert signature)) (goto-char (point-max)) (or (bolp) (insert "\n"))))) +(defun message-insert-importance-high () + "Insert header to mark message as important." + (interactive) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-remove-header "Importance")) + (message-goto-eoh) + (insert "Importance: high\n"))) + +(defun message-insert-importance-low () + "Insert header to mark message as unimportant." + (interactive) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-remove-header "Importance")) + (message-goto-eoh) + (insert "Importance: low\n"))) + +(defun message-insert-or-toggle-importance () + "Insert a \"Importance: high\" header, or cycle through the header values. +The three allowed values according to RFC 1327 are `high', `normal' +and `low'." + (interactive) + (save-excursion + (let ((valid '("high" "normal" "low")) + (new "high") + cur) + (save-restriction + (message-narrow-to-headers) + (when (setq cur (message-fetch-field "Importance")) + (message-remove-header "Importance") + (setq new (cond ((string= cur "high") + "low") + ((string= cur "low") + "normal") + (t + "high"))))) + (message-goto-eoh) + (insert (format "Importance: %s\n" new))))) + +(defun message-insert-disposition-notification-to () + "Request a disposition notification (return receipt) to this message. +Note that this should not be used in newsgroups." + (interactive) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-remove-header "Disposition-Notification-To")) + (message-goto-eoh) + (insert (format "Disposition-Notification-To: %s\n" + (or (message-field-value "Reply-to") + (message-field-value "From") + (message-make-from)))))) + (defun message-elide-region (b e) "Elide the text in the region. An ellipsis (from `message-elide-ellipsis') will be inserted where the @@ -1845,7 +3001,7 @@ (prefix-numeric-value current-prefix-arg)))) (setq n (if (numberp n) (mod n 26) 13)) ;canonize N - (unless (or (zerop n) ; no action needed for a rot of 0 + (unless (or (zerop n) ; no action needed for a rot of 0 (= b e)) ; no region to rotate ;; We build the table, if necessary. (when (or (not message-caesar-translation-table) @@ -1888,7 +3044,7 @@ (save-excursion (save-restriction (when (message-goto-body) - (narrow-to-region (point) (point-max))) + (narrow-to-region (point) (point-max))) (shell-command-on-region (point-min) (point-max) program nil t)))) @@ -1968,7 +3124,9 @@ (save-excursion (goto-char start) (while (< (point) (mark t)) - (insert message-yank-prefix) + (if (or (looking-at ">") (looking-at "^$")) + (insert message-yank-cited-prefix) + (insert message-yank-prefix)) (forward-line 1)))) (goto-char start))) @@ -1999,7 +3157,7 @@ (defun message-yank-buffer (buffer) "Insert BUFFER into the current buffer and quote it." (interactive "bYank buffer: ") - (let ((message-reply-buffer buffer)) + (let ((message-reply-buffer (get-buffer buffer))) (save-window-excursion (message-yank-original)))) @@ -2016,13 +3174,27 @@ (defun message-cite-original-without-signature () "Cite function in the standard Message manner." - (let ((start (point)) - (end (mark t)) - (functions - (when message-indent-citation-function - (if (listp message-indent-citation-function) - message-indent-citation-function - (list message-indent-citation-function))))) + (let* ((start (point)) + (end (mark t)) + (functions + (when message-indent-citation-function + (if (listp message-indent-citation-function) + message-indent-citation-function + (list message-indent-citation-function)))) + ;; This function may be called by `gnus-summary-yank-message' and + ;; may insert a different article from the original. So, we will + ;; modify the value of `message-reply-headers' with that article. + (message-reply-headers + (save-restriction + (narrow-to-region start end) + (message-narrow-to-head-1) + (vector 0 + (or (message-fetch-field "subject") "none") + (message-fetch-field "from") + (message-fetch-field "date") + (message-fetch-field "message-id" t) + (message-fetch-field "references") + 0 0 "")))) (mml-quote-region start end) ;; Allow undoing. (undo-boundary) @@ -2045,19 +3217,33 @@ (insert "\n")) (funcall message-citation-line-function)))) -(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive +(eval-when-compile (defvar mail-citation-hook)) ;Compiler directive (defun message-cite-original () "Cite function in the standard Message manner." (if (and (boundp 'mail-citation-hook) mail-citation-hook) (run-hooks 'mail-citation-hook) - (let ((start (point)) - (end (mark t)) - (functions - (when message-indent-citation-function - (if (listp message-indent-citation-function) - message-indent-citation-function - (list message-indent-citation-function))))) + (let* ((start (point)) + (end (mark t)) + (functions + (when message-indent-citation-function + (if (listp message-indent-citation-function) + message-indent-citation-function + (list message-indent-citation-function)))) + ;; This function may be called by `gnus-summary-yank-message' and + ;; may insert a different article from the original. So, we will + ;; modify the value of `message-reply-headers' with that article. + (message-reply-headers + (save-restriction + (narrow-to-region start end) + (message-narrow-to-head-1) + (vector 0 + (or (message-fetch-field "subject") "none") + (message-fetch-field "from") + (message-fetch-field "date") + (message-fetch-field "message-id" t) + (message-fetch-field "references") + 0 0 "")))) (mml-quote-region start end) (goto-char start) (while functions @@ -2144,7 +3330,8 @@ t))) (defun message-dont-send () - "Don't send the message you have been editing." + "Don't send the message you have been editing. +Instead, just auto-save the buffer and then bury it." (interactive) (set-buffer-modified-p t) (save-buffer) @@ -2157,9 +3344,23 @@ (interactive) (when (or (not (buffer-modified-p)) (yes-or-no-p "Message modified; kill anyway? ")) - (let ((actions message-kill-actions)) + (let ((actions message-kill-actions) + (draft-article message-draft-article) + (auto-save-file-name buffer-auto-save-file-name) + (file-name buffer-file-name) + (modified (buffer-modified-p))) (setq buffer-file-name nil) (kill-buffer (current-buffer)) + (when (and (or (and auto-save-file-name + (file-exists-p auto-save-file-name)) + (and file-name + (file-exists-p file-name))) + (yes-or-no-p (format "Remove the backup file%s? " + (if modified " too" "")))) + (ignore-errors + (delete-file auto-save-file-name)) + (let ((message-draft-article draft-article)) + (message-disassociate-draft))) (message-do-actions actions)))) (defun message-bury (buffer) @@ -2190,21 +3391,40 @@ (message message-sending-message) (let ((alist message-send-method-alist) (success t) - elem sent) + elem sent dont-barf-on-no-method + (message-options message-options)) + (message-options-set-recipient) (while (and success (setq elem (pop alist))) (when (funcall (cadr elem)) (when (and (or (not (memq (car elem) message-sent-message-via)) - (y-or-n-p - (format - "Already sent message via %s; resend? " - (car elem)))) + (message-fetch-field "supersedes") + (if (or (message-gnksa-enable-p 'multiple-copies) + (not (eq (car elem) 'news))) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem))) + (error "Denied posting -- multiple copies"))) (setq success (funcall (caddr elem) arg))) (setq sent t)))) - (unless (or sent (not success)) + (unless (or sent + (not success) + (let ((fcc (message-fetch-field "Fcc")) + (gcc (message-fetch-field "Gcc"))) + (when (or fcc gcc) + (or (eq message-allow-no-recipients 'always) + (and (not (eq message-allow-no-recipients 'never)) + (setq dont-barf-on-no-method + (gnus-y-or-n-p + (format "No receiver, perform %s anyway? " + (cond ((and fcc gcc) "Fcc and Gcc") + (fcc "Fcc") + (t "Gcc")))))))))) (error "No methods specified to send by")) - (when (and success sent) + (when (or dont-barf-on-no-method + (and success sent)) (message-do-fcc) (save-excursion (run-hooks 'message-sent-hook)) @@ -2236,26 +3456,106 @@ (put 'message-check 'lisp-indent-function 1) (put 'message-check 'edebug-form-spec '(form body)) +(defun message-text-with-property (prop) + "Return a list of all points where the text has PROP." + (let ((points nil) + (point (point-min))) + (save-excursion + (while (< point (point-max)) + (when (get-text-property point prop) + (push point points)) + (incf point))) + (nreverse points))) + (defun message-fix-before-sending () "Do various things to make the message nice before sending it." ;; Make sure there's a newline at the end of the message. (goto-char (point-max)) (unless (bolp) (insert "\n")) - ;; Delete all invisible text. + ;; Make the hidden headers visible. + (let ((points (message-text-with-property 'message-hidden))) + (when points + (goto-char (car points)) + (dolist (point points) + (add-text-properties point (1+ point) + '(invisible nil intangible nil))))) + ;; Make invisible text visible. + ;; It doesn't seem as if this is useful, since the invisible property + ;; is clobbered by an after-change hook anyhow. (message-check 'invisible-text - (when (text-property-any (point-min) (point-max) 'invisible t) - (put-text-property (point-min) (point-max) 'invisible nil) - (unless (yes-or-no-p - "Invisible text found and made visible; continue posting? ") - (error "Invisible text found and made visible"))))) + (let ((points (message-text-with-property 'invisible))) + (when points + (goto-char (car points)) + (dolist (point points) + (put-text-property point (1+ point) 'invisible nil) + (message-overlay-put (message-make-overlay point (1+ point)) + 'face 'highlight)) + (unless (yes-or-no-p + "Invisible text found and made visible; continue sending? ") + (error "Invisible text found and made visible"))))) + (message-check 'illegible-text + (let (found choice) + (message-goto-body) + (skip-chars-forward mm-7bit-chars) + (while (not (eobp)) + (when (let ((char (char-after))) + (or (< (mm-char-int char) 128) + (and (mm-multibyte-p) + (memq (char-charset char) + '(eight-bit-control eight-bit-graphic + control-1)) + (not (get-text-property + (point) 'untranslated-utf-8))))) + (message-overlay-put (message-make-overlay (point) (1+ (point))) + 'face 'highlight) + (setq found t)) + (forward-char) + (skip-chars-forward mm-7bit-chars)) + (when found + (setq choice + (gnus-multiple-choice + "Non-printable characters found. Continue sending?" + '((?d "Remove non-printable characters and send") + (?r "Replace non-printable characters with dots and send") + (?i "Ignore non-printable characters and send") + (?e "Continue editing")))) + (if (eq choice ?e) + (error "Non-printable characters")) + (message-goto-body) + (skip-chars-forward mm-7bit-chars) + (while (not (eobp)) + (when (let ((char (char-after))) + (or (< (mm-char-int char) 128) + (and (mm-multibyte-p) + ;; Fixme: Wrong for Emacs 22 and for things + ;; like undecable utf-8. Should at least + ;; use find-coding-systems-region. + (memq (char-charset char) + '(eight-bit-control eight-bit-graphic + control-1)) + (not (get-text-property + (point) 'untranslated-utf-8))))) + (if (eq choice ?i) + (message-kill-all-overlays) + (delete-char 1) + (when (eq choice ?r) + (insert ".")))) + (forward-char) + (skip-chars-forward mm-7bit-chars)))))) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." + (while types + (add-to-list (intern (format "message-%s-actions" (pop types))) + action))) + +(defun message-delete-action (action &rest types) + "Delete ACTION from lists of actions performed when doing an exit of type TYPES." (let (var) (while types (set (setq var (intern (format "message-%s-actions" (pop types)))) - (nconc (symbol-value var) (list action)))))) + (delq action (symbol-value var)))))) (defun message-do-actions (actions) "Perform all actions in ACTIONS." @@ -2264,7 +3564,7 @@ (ignore-errors (cond ;; A simple function. - ((message-functionp (car actions)) + ((functionp (car actions)) (funcall (car actions))) ;; Something to be evaled. (t @@ -2272,7 +3572,7 @@ (pop actions))) (defun message-send-mail-partially () - "Sendmail as message/partial." + "Send mail as message/partial." ;; replace the header delimiter with a blank line (goto-char (point-min)) (re-search-forward @@ -2320,24 +3620,23 @@ (message-remove-header "Lines") (goto-char (point-max)) (insert "Mime-Version: 1.0\n") - (setq header (buffer-substring (point-min) (point-max)))) + (setq header (buffer-string))) (goto-char (point-max)) - (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n" + (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n" id n total)) + (forward-char -1) (let ((mail-header-separator "")) (when (memq 'Message-ID message-required-mail-headers) (insert "Message-ID: " (message-make-message-id) "\n")) (when (memq 'Lines message-required-mail-headers) - (let ((mail-header-separator "")) - (insert "Lines: " (message-make-lines) "\n"))) + (insert "Lines: " (message-make-lines) "\n")) (message-goto-subject) (end-of-line) (insert (format " (%d/%d)" n total)) - (goto-char (point-max)) - (insert "\n") (widen) (mm-with-unibyte-current-buffer - (funcall message-send-mail-function))) + (funcall (or message-send-mail-real-function + message-send-mail-function)))) (setq n (+ n 1)) (setq p (pop plist)) (erase-buffer))) @@ -2353,22 +3652,34 @@ (message-posting-charset (if (fboundp 'gnus-setup-posting-charset) (gnus-setup-posting-charset nil) - message-posting-charset))) + message-posting-charset)) + (headers message-required-mail-headers)) (save-restriction (message-narrow-to-headers) + ;; Generate the Mail-Followup-To header if the header is not there... + (if (and (message-subscribed-p) + (not (mail-fetch-field "mail-followup-to"))) + (setq headers + (cons + (cons "Mail-Followup-To" (message-make-mail-followup-to)) + message-required-mail-headers)) + ;; otherwise, delete the MFT header if the field is empty + (when (equal "" (mail-fetch-field "mail-followup-to")) + (message-remove-header "^Mail-Followup-To:"))) ;; Insert some headers. (let ((message-deletable-headers (if news nil message-deletable-headers))) - (message-generate-headers message-required-mail-headers)) + (message-generate-headers headers)) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect (save-excursion (set-buffer tembuf) (erase-buffer) - ;; Avoid copying text props. + ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer mailbuf - (buffer-substring-no-properties (point-min) (point-max)))) + (mml-buffer-substring-no-properties-except-hard-newlines + (point-min) (point-max)))) ;; Remove some headers. (message-encode-message-body) (save-restriction @@ -2384,25 +3695,59 @@ ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) + (message-cleanup-headers) + ;; FIXME: we're inserting the courtesy copy after encoding. + ;; This is wrong if the courtesy copy string contains + ;; non-ASCII characters. -- jh (when (save-restriction (message-narrow-to-headers) (and news (or (message-fetch-field "cc") + (message-fetch-field "bcc") (message-fetch-field "to")) - (let ((content-type (message-fetch-field "content-type"))) - (or - (not content-type) - (string= "text/plain" - (car - (mail-header-parse-content-type - content-type))))))) + (let ((content-type (message-fetch-field + "content-type"))) + (and + (or + (not content-type) + (string= "text/plain" + (car + (mail-header-parse-content-type + content-type)))) + (not + (string= "base64" + (message-fetch-field + "content-transfer-encoding"))))))) (message-insert-courtesy-copy)) (if (or (not message-send-mail-partially-limit) (< (point-max) message-send-mail-partially-limit) - (not (y-or-n-p "The message size is too large, should it be sent partially? "))) + (not (message-y-or-n-p + "The message size is too large, split? " + t + "\ +The message size, " + (/ (point-max) 1000) "KB, is too large. + +Some mail gateways (MTA's) bounce large messages. To avoid the +problem, answer `y', and the message will be split into several +smaller pieces, the size of each is about " + (/ message-send-mail-partially-limit 1000) + "KB except the last +one. + +However, some mail readers (MUA's) can't read split messages, i.e., +mails in message/partially format. Answer `n', and the message will be +sent in one piece. + +The size limit is controlled by `message-send-mail-partially-limit'. +If you always want Gnus to send messages in one piece, set +`message-send-mail-partially-limit' to nil. +"))) (mm-with-unibyte-current-buffer - (funcall message-send-mail-function)) + (message "Sending via mail...") + (funcall (or message-send-mail-real-function + message-send-mail-function))) (message-send-mail-partially))) (kill-buffer tembuf)) (set-buffer mailbuf) @@ -2415,61 +3760,67 @@ " sendmail errors") 0)) resend-to-addresses delimline) - (let ((case-fold-search t)) - (save-restriction - (message-narrow-to-headers) - (setq resend-to-addresses (message-fetch-field "resent-to"))) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) - (run-hooks 'message-send-mail-hook) - ;; Insert an extra newline if we need it to work around - ;; Sun's bug that swallows newlines. - (goto-char (1+ delimline)) - (when (eval message-mailer-swallows-blank-line) - (newline)) - (when message-interactive - (save-excursion - (set-buffer errbuf) - (erase-buffer)))) - (let ((default-directory "/") - (coding-system-for-write message-send-coding-system)) - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - ;; But some systems are more broken with -f, so - ;; we'll let users override this. - (if (null message-sendmail-f-is-evil) - (list "-f" (message-make-address))) - ;; These mean "report errors by mail" - ;; and "deliver in background". - (if (null message-interactive) '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (if resend-to-addresses - (list resend-to-addresses) - '("-t"))))) - (when message-interactive - (save-excursion - (set-buffer errbuf) - (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) - (replace-match "; ")) - (if (not (zerop (buffer-size))) - (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))) + (unwind-protect + (progn + (let ((case-fold-search t)) + (save-restriction + (message-narrow-to-headers) + (setq resend-to-addresses (message-fetch-field "resent-to"))) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + (run-hooks 'message-send-mail-hook) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (when (eval message-mailer-swallows-blank-line) + (newline)) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + (let* ((default-directory "/") + (coding-system-for-write message-send-coding-system) + (cpr (apply + 'call-process-region + (append + (list (point-min) (point-max) + (if (boundp 'sendmail-program) + sendmail-program + "/usr/lib/sendmail") + nil errbuf nil "-oi") + ;; Always specify who from, + ;; since some systems have broken sendmails. + ;; But some systems are more broken with -f, so + ;; we'll let users override this. + (if (null message-sendmail-f-is-evil) + (list "-f" (message-sendmail-envelope-from))) + ;; These mean "report errors by mail" + ;; and "deliver in background". + (if (null message-interactive) '("-oem" "-odb")) + ;; Get the addresses from the message + ;; unless this is a resend. + ;; We must not do that for a resend + ;; because we would find the original addresses. + ;; For a resend, include the specific addresses. + (if resend-to-addresses + (list resend-to-addresses) + '("-t")))))) + (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) + (error "Sending...failed with exit value %d" cpr))) + (when message-interactive + (save-excursion + (set-buffer errbuf) + (goto-char (point-min)) + (while (re-search-forward "\n\n* *" nil t) + (replace-match "; ")) + (if (not (zerop (buffer-size))) + (error "Sending...failed to %s" + (buffer-string)))))) (when (bufferp errbuf) (kill-buffer errbuf))))) @@ -2506,11 +3857,13 @@ ;; free for -inject-arguments -- a big win for the user and for us ;; since we don't have to play that double-guessing game and the user ;; gets full control (no gestapo'ish -f's, for instance). --sj - message-qmail-inject-args)) + (if (functionp message-qmail-inject-args) + (funcall message-qmail-inject-args) + message-qmail-inject-args))) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) - (1 (error "qmail-inject reported permanent failure")) + (100 (error "qmail-inject reported permanent failure")) (111 (error "qmail-inject reported transient failure")) ;; should never happen (t (error "qmail-inject reported unknown failure")))) @@ -2533,29 +3886,74 @@ ;; Pass it on to mh. (mh-send-letter))) +(defun message-smtpmail-send-it () + "Send the prepared message buffer with `smtpmail-send-it'. +This only differs from `smtpmail-send-it' that this command evaluates +`message-send-mail-hook' just before sending a message. It is useful +if your ISP requires the POP-before-SMTP authentication. See the +documentation for the function `mail-source-touch-pop'." + (run-hooks 'message-send-mail-hook) + (smtpmail-send-it)) + +(defun message-canlock-generate () + "Return a string that is non-trivial to guess. +Do not use this for anything important, it is cryptographically weak." + (let (sha1-maximum-internal-length) + (sha1 (concat (message-unique-id) + (format "%x%x%x" (random) (random t) (random)) + (prin1-to-string (recent-keys)) + (prin1-to-string (garbage-collect)))))) + +(defun message-canlock-password () + "The password used by message for cancel locks. +This is the value of `canlock-password', if that option is non-nil. +Otherwise, generate and save a value for `canlock-password' first." + (unless canlock-password + (customize-save-variable 'canlock-password (message-canlock-generate)) + (setq canlock-password-for-verify canlock-password)) + canlock-password) + +(defun message-insert-canlock () + (when message-insert-canlock + (message-canlock-password) + (canlock-insert-header))) + (defun message-send-news (&optional arg) (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) - (method (if (message-functionp message-post-method) + (method (if (functionp message-post-method) (funcall message-post-method arg) message-post-method)) - (group-name-charset (gnus-group-name-charset method "")) + (newsgroups-field (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups"))) + (followup-field (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Followup-To"))) + ;; BUG: We really need to get the charset for each name in the + ;; Newsgroups and Followup-To lines to allow crossposting + ;; between group namess with incompatible character sets. + ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08. + (group-field-charset + (gnus-group-name-charset method newsgroups-field)) + (followup-field-charset + (gnus-group-name-charset method (or followup-field ""))) (rfc2047-header-encoding-alist - (if group-name-charset - (cons (cons "Newsgroups" group-name-charset) - rfc2047-header-encoding-alist) - rfc2047-header-encoding-alist)) + (append (when group-field-charset + (list (cons "Newsgroups" group-field-charset))) + (when followup-field-charset + (list (cons "Followup-To" followup-field-charset))) + rfc2047-header-encoding-alist)) (messbuf (current-buffer)) (message-syntax-checks - (if arg + (if (and arg + (listp message-syntax-checks)) (cons '(existing-newsgroups . disabled) message-syntax-checks) message-syntax-checks)) (message-this-is-news t) - (message-posting-charset (gnus-setup-posting-charset - (save-restriction - (message-narrow-to-headers-or-head) - (message-fetch-field "Newsgroups")))) + (message-posting-charset + (gnus-setup-posting-charset newsgroups-field)) result) (if (not (message-check-news-body-syntax)) nil @@ -2563,24 +3961,30 @@ (message-narrow-to-headers) ;; Insert some headers. (message-generate-headers message-required-news-headers) + (message-insert-canlock) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) - (if group-name-charset - (setq message-syntax-checks + ;; Note: This check will be disabled by the ".*" default value for + ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07. + (when (and group-field-charset + (listp message-syntax-checks)) + (setq message-syntax-checks (cons '(valid-newsgroups . disabled) message-syntax-checks))) (message-cleanup-headers) - (if (not (message-check-news-syntax)) + (if (not (let ((message-post-method method)) + (message-check-news-syntax))) nil (unwind-protect (save-excursion (set-buffer tembuf) (buffer-disable-undo) (erase-buffer) - ;; Avoid copying text props. - (insert (with-current-buffer messbuf - (buffer-substring-no-properties - (point-min) (point-max)))) + ;; Avoid copying text props (except hard newlines). + (insert + (with-current-buffer messbuf + (mml-buffer-substring-no-properties-except-hard-newlines + (point-min) (point-max)))) (message-encode-message-body) ;; Remove some headers. (save-restriction @@ -2605,6 +4009,7 @@ (backward-char 1)) (run-hooks 'message-send-news-hook) (gnus-open-server method) + (message "Sending news via %s..." (gnus-server-string method)) (setq result (let ((mail-header-separator "")) (gnus-request-post method)))) (kill-buffer tembuf)) @@ -2665,6 +4070,24 @@ (y-or-n-p "The control code \"cmsg\" is in the subject. Really post? ") t)) + ;; Check long header lines. + (message-check 'long-header-lines + (let ((start (point)) + (header nil) + (length 0) + found) + (while (and (not found) + (re-search-forward "^\\([^ \t:]+\\): " nil t)) + (if (> (- (point) (match-beginning 0)) 998) + (setq found t + length (- (point) (match-beginning 0))) + (setq header (match-string-no-properties 1))) + (setq start (match-beginning 0)) + (forward-line 1)) + (if found + (y-or-n-p (format "Your %s header is too long (%d). Really post? " + header length)) + t))) ;; Check for multiple identical headers. (message-check 'multiple-headers (let (found) @@ -2703,8 +4126,8 @@ (zerop (length (setq to (completing-read - "Followups to: (default all groups) " - (mapcar (lambda (g) (list g)) + "Followups to (default: no Followup-To header) " + (mapcar #'list (cons "poster" (message-tokenize-header newsgroups))))))))) @@ -2714,7 +4137,7 @@ ;; Check "Shoot me". (message-check 'shoot (if (re-search-forward - "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t) + "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t) (y-or-n-p "You appear to have a misconfigured system. Really post? ") t)) ;; Check for Approved. @@ -2745,27 +4168,72 @@ (if followup-to (concat newsgroups "," followup-to) newsgroups))) - (hashtb (and (boundp 'gnus-active-hashtb) - gnus-active-hashtb)) + (post-method (if (functionp message-post-method) + (funcall message-post-method) + message-post-method)) + ;; KLUDGE to handle nnvirtual groups. Doing this right + ;; would probably involve a new nnoo function. + ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17. + (method (if (and (consp post-method) + (eq (car post-method) 'nnvirtual) + gnus-message-group-art) + (let ((group (car (nnvirtual-find-group-art + (car gnus-message-group-art) + (cdr gnus-message-group-art))))) + (gnus-find-method-for-group group)) + post-method)) + (known-groups + (mapcar (lambda (n) + (gnus-group-name-decode + (gnus-group-real-name n) + (gnus-group-name-charset method n))) + (gnus-groups-from-server method))) errors) - (if (or (not hashtb) - (not (boundp 'gnus-read-active-file)) - (not gnus-read-active-file) - (eq gnus-read-active-file 'some)) - t - (while groups - (when (and (not (boundp (intern (car groups) hashtb))) - (not (equal (car groups) "poster"))) - (push (car groups) errors)) - (pop groups)) - (if (not errors) - t - (y-or-n-p - (format - "Really post to %s unknown group%s: %s? " - (if (= (length errors) 1) "this" "these") - (if (= (length errors) 1) "" "s") - (mapconcat 'identity errors ", "))))))) + (while groups + (when (and (not (equal (car groups) "poster")) + (not (member (car groups) known-groups)) + (not (member (car groups) errors))) + (push (car groups) errors)) + (pop groups)) + (cond + ;; Gnus is not running. + ((or (not (and (boundp 'gnus-active-hashtb) + gnus-active-hashtb)) + (not (boundp 'gnus-read-active-file))) + t) + ;; We don't have all the group names. + ((and (or (not gnus-read-active-file) + (eq gnus-read-active-file 'some)) + errors) + (y-or-n-p + (format + "Really use %s possibly unknown group%s: %s? " + (if (= (length errors) 1) "this" "these") + (if (= (length errors) 1) "" "s") + (mapconcat 'identity errors ", ")))) + ;; There were no errors. + ((not errors) + t) + ;; There are unknown groups. + (t + (y-or-n-p + (format + "Really post to %s unknown group%s: %s? " + (if (= (length errors) 1) "this" "these") + (if (= (length errors) 1) "" "s") + (mapconcat 'identity errors ", "))))))) + ;; Check continuation headers. + (message-check 'continuation-headers + (goto-char (point-min)) + (let ((do-posting t)) + (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t) + (if (y-or-n-p "Fix continuation lines? ") + (progn + (goto-char (match-beginning 0)) + (insert " ")) + (unless (y-or-n-p "Send anyway? ") + (setq do-posting nil)))) + do-posting)) ;; Check the Newsgroups & Followup-To headers for syntax errors. (message-check 'valid-newsgroups (let ((case-fold-search t) @@ -2820,7 +4288,7 @@ "@[^\\.]*\\." (setq ad (nth 1 (mail-extract-address-components from))))) ;larsi@ifi - (string-match "\\.\\." ad) ;larsi@ifi..uio + (string-match "\\.\\." ad) ;larsi@ifi..uio (string-match "@\\." ad) ;larsi@.ifi.uio (string-match "\\.$" ad) ;larsi@ifi.uio. (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio @@ -2828,6 +4296,40 @@ (message "Denied posting -- the From looks strange: \"%s\"." from) nil) + ((let ((addresses (rfc822-addresses from))) + (while (and addresses + (not (eq (string-to-char (car addresses)) ?\())) + (setq addresses (cdr addresses))) + addresses) + (message + "Denied posting -- bad From address: \"%s\"." from) + nil) + (t t)))) + ;; Check the Reply-To header. + (message-check 'reply-to + (let* ((case-fold-search t) + (reply-to (message-fetch-field "reply-to")) + ad) + (cond + ((not reply-to) + t) + ((string-match "," reply-to) + (y-or-n-p + (format "Multiple Reply-To addresses: \"%s\". Really post? " + reply-to))) + ((or (not (string-match + "@[^\\.]*\\." + (setq ad (nth 1 (mail-extract-address-components + reply-to))))) ;larsi@ifi + (string-match "\\.\\." ad) ;larsi@ifi..uio + (string-match "@\\." ad) ;larsi@.ifi.uio + (string-match "\\.$" ad) ;larsi@ifi.uio. + (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio + (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars) + (y-or-n-p + (format + "The Reply-To looks strange: \"%s\". Really post? " + reply-to))) (t t)))))) (defun message-check-news-body-syntax () @@ -2837,10 +4339,13 @@ (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) (while (and - (progn - (end-of-line) - (< (current-column) 80)) + (or (looking-at + "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)") + (let ((p (point))) + (end-of-line) + (< (- (point) p) 80))) (zerop (forward-line 1)))) (or (bolp) (eobp) @@ -2857,7 +4362,10 @@ (re-search-backward message-signature-separator nil t) (beginning-of-line) (or (re-search-backward "[^ \n\t]" b t) - (y-or-n-p "Empty article. Really post? ")))) + (if (message-gnksa-enable-p 'empty-article) + (y-or-n-p "Empty article. Really post? ") + (message "Denied posting -- Empty article.") + nil)))) ;; Check for control characters. (message-check 'control-chars (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t) @@ -2876,8 +4384,11 @@ (or (not message-checksum) (not (eq (message-checksum) message-checksum)) - (y-or-n-p - "It looks like no new text has been added. Really post? "))) + (if (message-gnksa-enable-p 'quoted-text-only) + (y-or-n-p + "It looks like no new text has been added. Really post? ") + (message "Denied posting -- no new text has been added.") + nil))) ;; Check the length of the signature. (message-check 'signature (goto-char (point-max)) @@ -2891,15 +4402,20 @@ (message-check 'quoting-style (goto-char (point-max)) (let ((no-problem t)) - (when (search-backward-regexp "^>[^\n]*\n>" nil t) - (setq no-problem nil) - (while (not (eobp)) - (when (and (not (eolp)) (looking-at "[^> \t]")) - (setq no-problem t)) - (forward-line))) + (when (search-backward-regexp "^>[^\n]*\n" nil t) + (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t))) (if no-problem t - (y-or-n-p "Your text should follow quoted text. Really post? ")))))) + (if (message-gnksa-enable-p 'quoted-text-only) + (y-or-n-p "Your text should follow quoted text. Really post? ") + ;; Ensure that + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (if (search-forward-regexp "^[ \t]*[^>\n]" nil t) + (y-or-n-p "Your text should follow quoted text. Really post? ") + (message "Denied posting -- only quoted text.") + nil))))))) (defun message-checksum () "Return a \"checksum\" for the current buffer." @@ -2910,8 +4426,8 @@ (concat "^" (regexp-quote mail-header-separator) "$")) (while (not (eobp)) (when (not (looking-at "[ \t\n]")) - (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) - (char-after)))) + (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) + (char-after)))) (forward-char 1))) sum)) @@ -2919,49 +4435,52 @@ "Process Fcc headers in the current buffer." (let ((case-fold-search t) (buf (current-buffer)) - list file) + list file + (mml-externalize-attachments message-fcc-externalize-attachments)) (save-excursion - (set-buffer (get-buffer-create " *message temp*")) - (erase-buffer) - (insert-buffer-substring buf) - (save-restriction - (message-narrow-to-headers) - (while (setq file (message-fetch-field "fcc")) - (push file list) - (message-remove-header "fcc" nil t))) - (message-encode-message-body) (save-restriction (message-narrow-to-headers) - (let ((mail-parse-charset message-default-charset) - (rfc2047-header-encoding-alist - (cons '("Newsgroups" . default) - rfc2047-header-encoding-alist))) - (mail-encode-encoded-word-buffer))) - (goto-char (point-min)) - (when (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (replace-match "" t t )) - ;; Process FCC operations. - (while list - (setq file (pop list)) - (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) - ;; Pipe the article to the program in question. - (call-process-region (point-min) (point-max) shell-file-name - nil nil nil shell-command-switch - (match-string 1 file)) - ;; Save the article. - (setq file (expand-file-name file)) - (unless (file-exists-p (file-name-directory file)) - (make-directory (file-name-directory file) t)) - (if (and message-fcc-handler-function - (not (eq message-fcc-handler-function 'rmail-output))) - (funcall message-fcc-handler-function file) - (if (and (file-readable-p file) (mail-file-babyl-p file)) - (rmail-output file 1 nil t) - (let ((mail-use-rfc822 t)) - (rmail-output file 1 t t)))))) - (kill-buffer (current-buffer))))) + (setq file (message-fetch-field "fcc" t))) + (when file + (set-buffer (get-buffer-create " *message temp*")) + (erase-buffer) + (insert-buffer-substring buf) + (message-encode-message-body) + (save-restriction + (message-narrow-to-headers) + (while (setq file (message-fetch-field "fcc" t)) + (push file list) + (message-remove-header "fcc" nil t)) + (let ((mail-parse-charset message-default-charset) + (rfc2047-header-encoding-alist + (cons '("Newsgroups" . default) + rfc2047-header-encoding-alist))) + (mail-encode-encoded-word-buffer))) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t )) + ;; Process FCC operations. + (while list + (setq file (pop list)) + (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) + ;; Pipe the article to the program in question. + (call-process-region (point-min) (point-max) shell-file-name + nil nil nil shell-command-switch + (match-string 1 file)) + ;; Save the article. + (setq file (expand-file-name file)) + (unless (file-exists-p (file-name-directory file)) + (make-directory (file-name-directory file) t)) + (if (and message-fcc-handler-function + (not (eq message-fcc-handler-function 'rmail-output))) + (funcall message-fcc-handler-function file) + (if (and (file-readable-p file) (mail-file-babyl-p file)) + (rmail-output file 1 nil t) + (let ((mail-use-rfc822 t)) + (rmail-output file 1 t t)))))) + (kill-buffer (current-buffer)))))) (defun message-output (filename) "Append this article to Unix/babyl mail file FILENAME." @@ -2993,7 +4512,7 @@ (point))) (goto-char (point-min)) (while (re-search-forward "\n[ \t]+" nil t) - (replace-match " " t t)) ;No line breaks (too confusing) + (replace-match " " t t)) ;No line breaks (too confusing) (goto-char (point-min)) (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) (replace-match "," t t)) @@ -3012,6 +4531,9 @@ (setq sign "-") (setq zone (- zone))) (concat + ;; The day name of the %a spec is locale-specific. Pfff. + (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now)) + parse-time-weekdays)))) (format-time-string "%d" now) ;; The month name of the %b spec is locale-specific. Pfff. (format " %s " @@ -3063,13 +4585,13 @@ (aset user (match-beginning 0) ?_)) user) (message-number-base36 (user-uid) -1)) - (message-number-base36 (+ (car tm) + (message-number-base36 (+ (car tm) (lsh (% message-unique-id-char 25) 16)) 4) (message-number-base36 (+ (nth 1 tm) (lsh (/ message-unique-id-char 25) 16)) 4) - ;; Append the newsreader name, because while the generated - ;; ID is unique to this newsreader, other newsreaders might - ;; otherwise generate the same ID via another algorithm. + ;; Append a given name, because while the generated ID is unique + ;; to this newsreader, other newsreaders might otherwise generate + ;; the same ID via another algorithm. ".fsf"))) (defun message-number-base36 (num len) @@ -3085,11 +4607,11 @@ "Make an Organization header." (let* ((organization (when message-user-organization - (if (message-functionp message-user-organization) + (if (functionp message-user-organization) (funcall message-user-organization) message-user-organization)))) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (cond ((stringp organization) (insert organization)) ((and (eq t organization) @@ -3107,21 +4629,40 @@ (save-excursion (save-restriction (widen) - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$")) - (forward-line 1) + (message-goto-body) (int-to-string (count-lines (point) (point-max)))))) +(defun message-make-references () + "Return the References header for this message." + (when message-reply-headers + (let ((message-id (mail-header-message-id message-reply-headers)) + (references (mail-header-references message-reply-headers)) + new-references) + (if (or references message-id) + (concat (or references "") (and references " ") + (or message-id "")) + nil)))) + (defun message-make-in-reply-to () "Return the In-Reply-To header for this message." (when message-reply-headers - (mail-header-message-id message-reply-headers))) + (let ((from (mail-header-from message-reply-headers)) + (date (mail-header-date message-reply-headers)) + (msg-id (mail-header-message-id message-reply-headers))) + (when from + (let ((name (mail-extract-address-components from))) + (concat msg-id (if msg-id " (") + (or (car name) + (nth 1 name)) + "'s message of \"" + (if (or (not date) (string= date "")) + "(unknown date)" date) + "\"" (if msg-id ")"))))))) (defun message-make-distribution () "Make a Distribution header." (let ((orig-distribution (message-fetch-reply-field "distribution"))) - (cond ((message-functionp message-distribution-function) + (cond ((functionp message-distribution-function) (funcall message-distribution-function)) (t orig-distribution)))) @@ -3154,8 +4695,8 @@ (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (cond ((or (null style) (equal fullname "")) @@ -3172,15 +4713,15 @@ (string-match "[\\()]" tmp))))) (insert fullname) (goto-char (point-min)) - ;; Look for a character that cannot appear unquoted - ;; according to RFC 822. - (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) - ;; Quote fullname, escaping specials. - (goto-char (point-min)) - (insert "\"") - (while (re-search-forward "[\"\\]" nil 1) - (replace-match "\\\\\\&" t)) - (insert "\"")) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) + ;; Quote fullname, escaping specials. + (goto-char (point-min)) + (insert "\"") + (while (re-search-forward "[\"\\]" nil 1) + (replace-match "\\\\\\&" t)) + (insert "\"")) (insert " <" login ">")) (t ; 'parens or default (insert login " (") @@ -3216,32 +4757,58 @@ (defun message-user-mail-address () "Return the pertinent part of `user-mail-address'." - (when user-mail-address + (when (and user-mail-address + (string-match "@.*\\." user-mail-address)) (if (string-match " " user-mail-address) (nth 1 (mail-extract-address-components user-mail-address)) user-mail-address))) +(defun message-sendmail-envelope-from () + "Return the envelope from." + (cond ((eq message-sendmail-envelope-from 'header) + (nth 1 (mail-extract-address-components + (message-fetch-field "from")))) + ((stringp message-sendmail-envelope-from) + message-sendmail-envelope-from) + (t + (message-make-address)))) + (defun message-make-fqdn () "Return user's fully qualified domain name." - (let ((system-name (system-name)) - (user-mail (message-user-mail-address))) + (let* ((system-name (system-name)) + (user-mail (message-user-mail-address)) + (user-domain + (if (and user-mail + (string-match "@\\(.*\\)\\'" user-mail)) + (match-string 1 user-mail))) + (case-fold-search t)) (cond - ((string-match "[^.]\\.[^.]" system-name) + ((and message-user-fqdn + (stringp message-user-fqdn) + (string-match message-valid-fqdn-regexp message-user-fqdn) + (not (string-match message-bogus-system-names message-user-fqdn))) + message-user-fqdn) + ;; `message-user-fqdn' seems to be valid + ((and (string-match message-valid-fqdn-regexp system-name) + (not (string-match message-bogus-system-names system-name))) ;; `system-name' returned the right result. system-name) ;; Try `mail-host-address'. ((and (boundp 'mail-host-address) (stringp mail-host-address) - (string-match "\\." mail-host-address)) + (string-match message-valid-fqdn-regexp mail-host-address) + (not (string-match message-bogus-system-names mail-host-address))) mail-host-address) ;; We try `user-mail-address' as a backup. - ((and user-mail - (string-match "\\." user-mail) - (string-match "@\\(.*\\)\\'" user-mail)) - (match-string 1 user-mail)) + ((and user-domain + (stringp user-domain) + (string-match message-valid-fqdn-regexp user-domain) + (not (string-match message-bogus-system-names user-domain))) + user-domain) ;; Default to this bogus thing. (t - (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me"))))) + (concat system-name + ".i-did-not-set--mail-host-address--so-tickle-me"))))) (defun message-make-host-name () "Return the name of the host." @@ -3254,9 +4821,130 @@ (or mail-host-address (message-make-fqdn))) +(defun message-to-list-only () + "Send a message to the list only. +Remove all addresses but the list address from To and Cc headers." + (interactive) + (let ((listaddr (message-make-mail-followup-to t))) + (when listaddr + (save-excursion + (message-remove-header "to") + (message-remove-header "cc") + (message-position-on-field "To" "X-Draft-From") + (insert listaddr))))) + +(defun message-make-mail-followup-to (&optional only-show-subscribed) + "Return the Mail-Followup-To header. +If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the +subscribed address (and not the additional To and Cc header contents)." + (let* ((case-fold-search t) + (to (message-fetch-field "To")) + (cc (message-fetch-field "cc")) + (msg-recipients (concat to (and to cc ", ") cc)) + (recipients + (mapcar 'mail-strip-quoted-names + (message-tokenize-header msg-recipients))) + (file-regexps + (if message-subscribed-address-file + (let (begin end item re) + (save-excursion + (with-temp-buffer + (insert-file-contents message-subscribed-address-file) + (while (not (eobp)) + (setq begin (point)) + (forward-line 1) + (setq end (point)) + (if (bolp) (setq end (1- end))) + (setq item (regexp-quote (buffer-substring begin end))) + (if re (setq re (concat re "\\|" item)) + (setq re (concat "\\`\\(" item)))) + (and re (list (concat re "\\)\\'")))))))) + (mft-regexps (apply 'append message-subscribed-regexps + (mapcar 'regexp-quote + message-subscribed-addresses) + file-regexps + (mapcar 'funcall + message-subscribed-address-functions)))) + (save-match-data + (let ((subscribed-lists nil) + (list + (loop for recipient in recipients + when (loop for regexp in mft-regexps + when (string-match regexp recipient) return t) + return recipient))) + (when list + (if only-show-subscribed + list + msg-recipients)))))) + +(defun message-idna-inside-rhs-p () + "Return t iff point is inside a RHS (heuristically). +Only works properly if header contains mailbox-list or address-list. +I.e., calling it on a Subject: header is useless." + (save-restriction + (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t) + (point-min))) + (save-excursion (or (re-search-forward "^[^ \t]" nil t) + (point-max)))) + (if (re-search-backward "[\\\n\r\t ]" + (save-excursion (search-backward "@" nil t)) t) + ;; whitespace between @ and point + nil + (let ((dquote 1) (paren 1)) + (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote)) + (incf dquote)) + (while (save-excursion (re-search-backward "[^\\]\(" nil t paren)) + (incf paren)) + (and (= (% dquote 2) 1) (= (% paren 2) 1)))))) + +(autoload 'idna-to-ascii "idna") + +(defun message-idna-to-ascii-rhs-1 (header) + "Interactively potentially IDNA encode domain names in HEADER." + (let (rhs ace start startpos endpos ovl) + (goto-char (point-min)) + (while (re-search-forward (concat "^" header) nil t) + (while (re-search-forward "@\\([^ \t\r\n>,]+\\)" + (or (save-excursion + (re-search-forward "^[^ \t]" nil t)) + (point-max)) + t) + (setq rhs (match-string-no-properties 1) + startpos (match-beginning 1) + endpos (match-end 1)) + (when (save-match-data + (and (message-idna-inside-rhs-p) + (setq ace (idna-to-ascii rhs)) + (not (string= rhs ace)) + (if (eq message-use-idna 'ask) + (unwind-protect + (progn + (setq ovl (message-make-overlay startpos + endpos)) + (message-overlay-put ovl 'face 'highlight) + (y-or-n-p + (format "Replace with `%s'? " ace))) + (message "") + (message-delete-overlay ovl)) + message-use-idna))) + (replace-match (concat "@" ace))))))) + +(defun message-idna-to-ascii-rhs () + "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers. +See `message-idna-encode'." + (interactive) + (when message-use-idna + (save-excursion + (save-restriction + (message-narrow-to-head) + (message-idna-to-ascii-rhs-1 "From") + (message-idna-to-ascii-rhs-1 "To") + (message-idna-to-ascii-rhs-1 "Cc"))))) + (defun message-generate-headers (headers) "Prepare article HEADERS. Headers already prepared in the buffer are not modified." + (setq headers (append headers message-required-headers)) (save-restriction (message-narrow-to-headers) (let* ((Date (message-make-date)) @@ -3267,13 +4955,15 @@ (Subject nil) (Newsgroups nil) (In-Reply-To (message-make-in-reply-to)) + (References (message-make-references)) (To nil) (Distribution (message-make-distribution)) (Lines (message-make-lines)) (User-Agent message-newsreader) (Expires (message-make-expires)) (case-fold-search t) - header value elem) + (optionalp nil) + header value elem header-string) ;; First we remove any old generated headers. (let ((headers message-deletable-headers)) (unless (buffer-modified-p) @@ -3294,42 +4984,49 @@ (setq elem (pop headers)) (if (consp elem) (if (eq (car elem) 'optional) - (setq header (cdr elem)) + (setq header (cdr elem) + optionalp t) (setq header (car elem))) (setq header elem)) + (setq header-string (if (stringp header) + header + (symbol-name header))) (when (or (not (re-search-forward (concat "^" - (regexp-quote - (downcase - (if (stringp header) - header - (symbol-name header)))) + (regexp-quote (downcase header-string)) ":") nil t)) (progn ;; The header was found. We insert a space after the ;; colon, if there is none. (if (/= (char-after) ? ) (insert " ") (forward-char 1)) - ;; Find out whether the header is empty... + ;; Find out whether the header is empty. (looking-at "[ \t]*\n[^ \t]"))) ;; So we find out what value we should insert. (setq value (cond - ((and (consp elem) (eq (car elem) 'optional)) + ((and (consp elem) + (eq (car elem) 'optional) + (not (member header-string message-inserted-headers))) ;; This is an optional header. If the cdr of this ;; is something that is nil, then we do not insert ;; this header. (setq header (cdr elem)) - (or (and (fboundp (cdr elem)) (funcall (cdr elem))) - (and (boundp (cdr elem)) (symbol-value (cdr elem))))) + (or (and (functionp (cdr elem)) + (funcall (cdr elem))) + (and (boundp (cdr elem)) + (symbol-value (cdr elem))))) ((consp elem) ;; The element is a cons. Either the cdr is a ;; string to be inserted verbatim, or it is a ;; function, and we insert the value returned from ;; this function. - (or (and (stringp (cdr elem)) (cdr elem)) - (and (fboundp (cdr elem)) (funcall (cdr elem))))) - ((and (boundp header) (symbol-value header)) + (or (and (stringp (cdr elem)) + (cdr elem)) + (and (functionp (cdr elem)) + (funcall (cdr elem))))) + ((and (boundp header) + (symbol-value header)) ;; The element is a symbol. We insert the value ;; of this symbol, if any. (symbol-value header)) @@ -3346,13 +5043,24 @@ (progn ;; This header didn't exist, so we insert it. (goto-char (point-max)) - (insert (if (stringp header) header (symbol-name header)) - ": " value "\n") - (forward-line -1)) + (let ((formatter + (cdr (assq header message-header-format-alist)))) + (if formatter + (funcall formatter header value) + (insert header-string ": " value)) + ;; We check whether the value was ended by a + ;; newline. If now, we insert one. + (unless (bolp) + (insert "\n")) + (forward-line -1))) ;; The value of this header was empty, so we clear ;; totally and insert the new value. (delete-region (point) (gnus-point-at-eol)) - (insert value)) + ;; If the header is optional, and the header was + ;; empty, we con't insert it anyway. + (unless optionalp + (push header-string message-inserted-headers) + (insert value))) ;; Add the deletable property to the headers that require it. (and (memq header message-deletable-headers) (progn (beginning-of-line) (looking-at "[^:]+: ")) @@ -3383,7 +5091,9 @@ (beginning-of-line)) (when (or (message-news-p) (string-match "@.+\\.." secure-sender)) - (insert "Sender: " secure-sender "\n"))))))) + (insert "Sender: " secure-sender "\n")))) + ;; Check for IDNA + (message-idna-to-ascii-rhs)))) (defun message-insert-courtesy-copy () "Insert a courtesy message in mail copies of combined messages." @@ -3436,6 +5146,15 @@ (widen) (forward-line 1))) +(defun message-split-line () + "Split current line, moving portion beyond point vertically down. +If the current line has `message-yank-prefix', insert it on the new line." + (interactive "*") + (condition-case nil + (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg. + (error + (split-line)))) + (defun message-fill-header (header value) (let ((begin (point)) (fill-column 78) @@ -3463,12 +5182,12 @@ (nthcdr (+ (- cut 2) surplus 1) list))) (defun message-shorten-references (header references) - "Trim REFERENCES to be less than 31 Message-ID long, and fold them. + "Trim REFERENCES to be 21 Message-ID long or less, and fold them. If folding is disallowed, also check that the REFERENCES are less than 988 characters long, and if they are not, trim them until they are." - (let ((maxcount 31) + (let ((maxcount 21) (count 0) - (cut 6) + (cut 2) refs) (with-temp-buffer (insert references) @@ -3534,6 +5253,41 @@ (forward-line 2))) (sit-for 0))) +(defcustom message-beginning-of-line t + "Whether \\<message-mode-map>\\[message-beginning-of-line]\ + goes to beginning of header values." + :group 'message-buffers + :link '(custom-manual "(message)Movement") + :type 'boolean) + +(defun message-beginning-of-line (&optional n) + "Move point to beginning of header value or to beginning of line. +The prefix argument N is passed directly to `beginning-of-line'. + +This command is identical to `beginning-of-line' if point is +outside the message header or if the option `message-beginning-of-line' +is nil. + +If point is in the message header and on a (non-continued) header +line, move point to the beginning of the header value. If point +is already there, move point to beginning of line. Therefore, +repeated calls will toggle point between beginning of field and +beginning of line." + (interactive "p") + (let ((zrs 'zmacs-region-stays)) + (when (and (interactive-p) (boundp zrs)) + (set zrs t))) + (if (and message-beginning-of-line + (message-point-in-header-p)) + (let* ((here (point)) + (bol (progn (beginning-of-line n) (point))) + (eol (gnus-point-at-eol)) + (eoh (re-search-forward ": *" eol t))) + (if (or (not eoh) (equal here eoh)) + (goto-char bol) + (goto-char eoh))) + (beginning-of-line n))) + (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." (cond @@ -3550,7 +5304,7 @@ "*"))) ;; Check whether `message-generate-new-buffers' is a function, ;; and if so, call it. - ((message-functionp message-generate-new-buffers) + ((functionp message-generate-new-buffers) (funcall message-generate-new-buffers type to group)) ((eq message-generate-new-buffers 'unsent) (generate-new-buffer-name @@ -3587,7 +5341,7 @@ ;; list of buffers. (setq message-buffer-list (delq (current-buffer) message-buffer-list)) (while (and message-max-buffers - message-buffer-list + message-buffer-list (>= (length message-buffer-list) message-max-buffers)) ;; Kill the oldest buffer -- unless it has been changed. (let ((buffer (pop message-buffer-list))) @@ -3597,9 +5351,30 @@ ;; Rename the buffer. (if message-send-rename-function (funcall message-send-rename-function) - (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name)) - (rename-buffer - (concat "*sent " (substring (buffer-name) (match-end 0))) t))) + ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus. + (when (string-match + "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to " + (buffer-name)) + (let ((name (match-string 2 (buffer-name))) + to group) + (if (not (or (null name) + (string-equal name "mail") + (string-equal name "posting"))) + (setq name (concat "*sent " name "*")) + (message-narrow-to-headers) + (setq to (message-fetch-field "to")) + (setq group (message-fetch-field "newsgroups")) + (widen) + (setq name + (cond + (to (concat "*sent mail to " + (or (car (mail-extract-address-components to)) + to) "*")) + ((and group (not (string= group ""))) + (concat "*sent posting on " group "*")) + (t "*sent mail*")))) + (unless (string-equal name (buffer-name)) + (rename-buffer name t))))) ;; Push the current buffer onto the list. (when message-max-buffers (setq message-buffer-list @@ -3639,13 +5414,32 @@ headers) nil switch-function yank-action actions))))) -(eval-when-compile (defvar mc-modes-alist)) +(defun message-headers-to-generate (headers included-headers excluded-headers) + "Return a list that includes all headers from HEADERS. +If INCLUDED-HEADERS is a list, just include those headers. If if is +t, include all headers. In any case, headers from EXCLUDED-HEADERS +are not included." + (let ((result nil) + header-name) + (dolist (header headers) + (setq header-name (cond + ((and (consp header) + (eq (car header) 'optional)) + ;; On the form (optional . Header) + (cdr header)) + ((consp header) + ;; On the form (Header . function) + (car header)) + (t + ;; Just a Header. + header))) + (when (and (not (memq header-name excluded-headers)) + (or (eq included-headers t) + (memq header-name included-headers))) + (push header result))) + (nreverse result))) + (defun message-setup-1 (headers &optional replybuffer actions) - (when (and (boundp 'mc-modes-alist) - (not (assq 'message-mode mc-modes-alist))) - (push '(message-mode (encrypt . mc-encrypt-message) - (sign . mc-sign-message)) - mc-modes-alist)) (dolist (action actions) (condition-case nil (add-to-list 'message-send-actions @@ -3679,24 +5473,30 @@ (or (bolp) (insert ?\n))) (when message-generate-headers-first (message-generate-headers - (delq 'Lines - (delq 'Subject - (copy-sequence message-required-news-headers)))))) + (message-headers-to-generate + (append message-required-news-headers + message-required-headers) + message-generate-headers-first + '(Lines Subject))))) (when (message-mail-p) (when message-default-mail-headers (insert message-default-mail-headers) (or (bolp) (insert ?\n))) + (save-restriction + (message-narrow-to-headers) + (if message-alternative-emails + (message-use-alternative-email-as-from))) (when message-generate-headers-first (message-generate-headers - (delq 'Lines - (delq 'Subject - (copy-sequence message-required-mail-headers)))))) + (message-headers-to-generate + (append message-required-mail-headers + message-required-headers) + message-generate-headers-first + '(Lines Subject))))) (run-hooks 'message-signature-setup-hook) (message-insert-signature) (save-restriction (message-narrow-to-headers) - (if message-alternative-emails - (message-use-alternative-email-as-from)) (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) (setq buffer-undo-list nil) @@ -3713,8 +5513,14 @@ (if (gnus-alive-p) (setq message-draft-article (nndraft-request-associate-buffer "drafts")) - (setq buffer-file-name (expand-file-name "*message*" - message-auto-save-directory)) + (setq buffer-file-name (expand-file-name + (if (memq system-type + '(ms-dos ms-windows windows-nt + cygwin cygwin32 win32 w32 + mswindows)) + "message" + "*message*") + message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) (clear-visited-file-modtime) (setq buffer-file-coding-system message-draft-coding-system))) @@ -3775,18 +5581,30 @@ "Start editing a news article to be sent." (interactive) (let ((message-this-is-news t)) - (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)) + (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) -(defun message-get-reply-headers (wide &optional to-address) - (let (follow-to mct never-mct from to cc reply-to ccalist) +(defun message-get-reply-headers (wide &optional to-address address-headers) + (let (follow-to mct never-mct to cc author mft recipients) ;; Find all relevant headers we need. - (setq from (message-fetch-field "from") - to (message-fetch-field "to") - cc (message-fetch-field "cc") - mct (message-fetch-field "mail-copies-to") - reply-to (message-fetch-field "reply-to")) + (save-restriction + (message-narrow-to-headers-or-head) + ;; Gmane renames "To". Look at "Original-To", too, if it is present in + ;; message-header-synonyms. + (setq to (or (message-fetch-field "to") + (and (loop for synonym in message-header-synonyms + when (memq 'Original-To synonym) + return t) + (message-fetch-field "original-to"))) + cc (message-fetch-field "cc") + mct (message-fetch-field "mail-copies-to") + author (or (message-fetch-field "mail-reply-to") + (message-fetch-field "reply-to") + (message-fetch-field "from") + "") + mft (and message-use-mail-followup-to + (message-fetch-field "mail-followup-to")))) ;; Handle special values of Mail-Copies-To. (when mct @@ -3796,51 +5614,105 @@ (setq mct nil)) ((or (equal (downcase mct) "always") (equal (downcase mct) "poster")) - (setq mct (or reply-to from))))) - - (if (or (not wide) - to-address) - (progn - (setq follow-to (list (cons 'To (or to-address reply-to from)))) - (when (and wide mct) - (push (cons 'Cc mct) follow-to))) - (let (ccalist) - (save-excursion - (message-set-work-buffer) - (unless never-mct - (insert (or reply-to from ""))) - (insert (if to (concat (if (bolp) "" ", ") to "") "")) - (insert (if mct (concat (if (bolp) "" ", ") mct) "")) - (insert (if cc (concat (if (bolp) "" ", ") cc) "")) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+" nil t) - (replace-match " " t t)) - ;; Remove addresses that match `rmail-dont-reply-to-names'. - (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) - (insert (prog1 (rmail-dont-reply-to (buffer-string)) - (erase-buffer)))) - (goto-char (point-min)) - ;; Perhaps "Mail-Copies-To: never" removed the only address? - (when (eobp) - (insert (or reply-to from ""))) - (setq ccalist - (mapcar - (lambda (addr) - (cons (mail-strip-quoted-names addr) addr)) - (message-tokenize-header (buffer-string)))) - (let ((s ccalist)) - (while s - (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) - (setq follow-to (list (cons 'To (cdr (pop ccalist))))) - (when ccalist - (let ((ccs (cons 'Cc (mapconcat - (lambda (addr) (cdr addr)) ccalist ", ")))) - (when (string-match "^ +" (cdr ccs)) - (setcdr ccs (substring (cdr ccs) (match-end 0)))) - (push ccs follow-to))))) + (setq mct author)))) + + (save-match-data + ;; Build (textual) list of new recipient addresses. + (cond + ((not wide) + (setq recipients (concat ", " author))) + (address-headers + (dolist (header address-headers) + (let ((value (message-fetch-field header))) + (when value + (setq recipients (concat recipients ", " value)))))) + ((and mft + (string-match "[^ \t,]" mft) + (or (not (eq message-use-mail-followup-to 'ask)) + (message-y-or-n-p "Obey Mail-Followup-To? " t "\ +You should normally obey the Mail-Followup-To: header. In this +article, it has the value of + +" mft " + +which directs your response to " (if (string-match "," mft) + "the specified addresses" + "that address only") ". + +Most commonly, Mail-Followup-To is used by a mailing list poster to +express that responses should be sent to just the list, and not the +poster as well. + +If a message is posted to several mailing lists, Mail-Followup-To may +also be used to direct the following discussion to one list only, +because discussions that are spread over several lists tend to be +fragmented and very difficult to follow. + +Also, some source/announcement lists are not intended for discussion; +responses here are directed to other addresses."))) + (setq recipients (concat ", " mft))) + (to-address + (setq recipients (concat ", " to-address)) + ;; If the author explicitly asked for a copy, we don't deny it to them. + (if mct (setq recipients (concat recipients ", " mct)))) + (t + (setq recipients (if never-mct "" (concat ", " author))) + (if to (setq recipients (concat recipients ", " to))) + (if cc (setq recipients (concat recipients ", " cc))) + (if mct (setq recipients (concat recipients ", " mct))))) + (if (>= (length recipients) 2) + ;; Strip the leading ", ". + (setq recipients (substring recipients 2))) + ;; Squeeze whitespace. + (while (string-match "[ \t][ \t]+" recipients) + (setq recipients (replace-match " " t t recipients))) + ;; Remove addresses that match `rmail-dont-reply-to-names'. + (let ((rmail-dont-reply-to-names message-dont-reply-to-names)) + (setq recipients (rmail-dont-reply-to recipients))) + ;; Perhaps "Mail-Copies-To: never" removed the only address? + (if (string-equal recipients "") + (setq recipients author)) + ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...). + (setq recipients + (mapcar + (lambda (addr) + (cons (downcase (mail-strip-quoted-names addr)) addr)) + (message-tokenize-header recipients))) + ;; Remove first duplicates. (Why not all duplicates? Is this a bug?) + (let ((s recipients)) + (while s + (setq recipients (delq (assoc (car (pop s)) s) recipients)))) + + ;; Remove hierarchical lists that are contained within each other, + ;; if message-hierarchical-addresses is defined. + (when message-hierarchical-addresses + (let ((plain-addrs (mapcar 'car recipients)) + subaddrs recip) + (while plain-addrs + (setq subaddrs (assoc (car plain-addrs) + message-hierarchical-addresses) + plain-addrs (cdr plain-addrs)) + (when subaddrs + (setq subaddrs (cdr subaddrs)) + (while subaddrs + (setq recip (assoc (car subaddrs) recipients) + subaddrs (cdr subaddrs)) + (if recip + (setq recipients (delq recip recipients)))))))) + + ;; Build the header alist. Allow the user to be asked whether + ;; or not to reply to all recipients in a wide reply. + (setq follow-to (list (cons 'To (cdr (pop recipients))))) + (when (and recipients + (or (not message-wide-reply-confirm-recipients) + (y-or-n-p "Reply to all recipients? "))) + (setq recipients (mapconcat + (lambda (addr) (cdr addr)) recipients ", ")) + (if (string-match "^ +" recipients) + (setq recipients (substring recipients (match-end 0)))) + (push (cons 'Cc recipients) follow-to))) follow-to)) - ;;;###autoload (defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." @@ -3857,28 +5729,31 @@ ;; Allow customizations to have their say. (if (not wide) ;; This is a regular reply. - (if (message-functionp message-reply-to-function) - (setq follow-to (funcall message-reply-to-function))) + (when (functionp message-reply-to-function) + (save-excursion + (setq follow-to (funcall message-reply-to-function)))) ;; This is a followup. - (if (message-functionp message-wide-reply-to-function) - (save-excursion - (setq follow-to - (funcall message-wide-reply-to-function))))) + (when (functionp message-wide-reply-to-function) + (save-excursion + (setq follow-to + (funcall message-wide-reply-to-function))))) (setq message-id (message-fetch-field "message-id" t) references (message-fetch-field "references") date (message-fetch-field "date") from (message-fetch-field "from") subject (or (message-fetch-field "subject") "none")) - (if gnus-list-identifiers + (when gnus-list-identifiers (setq subject (message-strip-list-identifiers subject))) - (setq subject (concat "Re: " (message-strip-subject-re subject))) - - (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) - (string-match "<[^>]+>" gnus-warning)) - (setq message-id (match-string 0 gnus-warning))) - - (unless follow-to - (setq follow-to (message-get-reply-headers wide to-address)))) + (setq subject (concat "Re: " (message-strip-subject-re subject))) + (when message-subject-trailing-was-query + (setq subject (message-strip-subject-trailing-was subject))) + + (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) + (string-match "<[^>]+>" gnus-warning)) + (setq message-id (match-string 0 gnus-warning))) + + (unless follow-to + (setq follow-to (message-get-reply-headers wide to-address)))) (unless (message-mail-user-agent) (message-pop-to-buffer @@ -3891,11 +5766,7 @@ (message-setup `((Subject . ,subject) - ,@follow-to - ,@(if (or references message-id) - `((References . ,(concat (or references "") (and references " ") - (or message-id "")))) - nil)) + ,@follow-to) cur))) ;;;###autoload @@ -3911,7 +5782,7 @@ (interactive) (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) - from subject date reply-to mct + from subject date reply-to mrt mct references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-news t) @@ -3922,7 +5793,7 @@ (if (search-forward "\n\n" nil t) (1- (point)) (point-max))) - (when (message-functionp message-followup-to-function) + (when (functionp message-followup-to-function) (setq follow-to (funcall message-followup-to-function))) (setq from (message-fetch-field "from") @@ -3934,6 +5805,7 @@ newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") reply-to (message-fetch-field "reply-to") + mrt (message-fetch-field "mail-reply-to") distribution (message-fetch-field "distribution") mct (message-fetch-field "mail-copies-to")) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) @@ -3947,10 +5819,15 @@ (if gnus-list-identifiers (setq subject (message-strip-list-identifiers subject))) (setq subject (concat "Re: " (message-strip-subject-re subject))) + (when message-subject-trailing-was-query + (setq subject (message-strip-subject-trailing-was subject))) (widen)) (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) + (setq message-reply-headers + (vector 0 subject from date message-id references 0 0 "")) + (message-setup `((Subject . ,subject) ,@(cond @@ -3971,7 +5848,7 @@ does not read the newsgroup, so he wouldn't see any replies sent to it.")) (progn (setq message-this-is-news nil) - (cons 'To (or reply-to from ""))) + (cons 'To (or mrt reply-to from ""))) (cons 'Newsgroups newsgroups))) (t (if (or (equal followup-to newsgroups) @@ -3990,7 +5867,7 @@ because discussions that are spread over several newsgroup tend to be fragmented and very difficult to follow. -Also, some source/announcement newsgroups are not indented for discussion; +Also, some source/announcement newsgroups are not intended for discussion; responses here are directed to other newsgroups.")) (cons 'Newsgroups followup-to) (cons 'Newsgroups newsgroups)))))) @@ -3999,22 +5876,58 @@ (t `((Newsgroups . ,newsgroups)))) ,@(and distribution (list (cons 'Distribution distribution))) - ,@(if (or references message-id) - `((References . ,(concat (or references "") (and references " ") - (or message-id ""))))) ,@(when (and mct (not (or (equal (downcase mct) "never") (equal (downcase mct) "nobody")))) (list (cons 'Cc (if (or (equal (downcase mct) "always") (equal (downcase mct) "poster")) - (or reply-to from "") + (or mrt reply-to from "") mct))))) - cur) - - (setq message-reply-headers - (vector 0 subject from date message-id references 0 0 "")))) - + cur))) + +(defun message-is-yours-p () + "Non-nil means current article is yours. +If you have added 'cancel-messages to 'message-shoot-gnksa-feet', all articles +are yours except those that have Cancel-Lock header not belonging to you. +Instead of shooting GNKSA feet, you should modify 'message-alternative-emails' +regexp to match all of yours addresses." + ;; Canlock-logic as suggested by Per Abrahamsen + ;; <abraham@dina.kvl.dk> + ;; + ;; IF article has cancel-lock THEN + ;; IF we can verify it THEN + ;; issue cancel + ;; ELSE + ;; error: cancellock: article is not yours + ;; ELSE + ;; Use old rules, comparing sender... + (save-excursion + (save-restriction + (message-narrow-to-head-1) + (if (message-fetch-field "Cancel-Lock") + (if (null (canlock-verify)) + t + (error "Failed to verify Cancel-lock: This article is not yours")) + (let (sender from) + (or + (message-gnksa-enable-p 'cancel-messages) + (and (setq sender (message-fetch-field "sender")) + (string-equal (downcase sender) + (downcase (message-make-sender)))) + ;; Email address in From field equals to our address + (and (setq from (message-fetch-field "from")) + (string-equal + (downcase (cadr (mail-extract-address-components from))) + (downcase (cadr (mail-extract-address-components + (message-make-from)))))) + ;; Email address in From field matches + ;; 'message-alternative-emails' regexp + (and from + message-alternative-emails + (string-match + message-alternative-emails + (cadr (mail-extract-address-components from)))))))))) ;;;###autoload (defun message-cancel-news (&optional arg) @@ -4023,34 +5936,26 @@ (interactive "P") (unless (message-news-p) (error "This is not a news article; canceling is impossible")) - (when (yes-or-no-p "Do you really want to cancel this article? ") - (let (from newsgroups message-id distribution buf sender) - (save-excursion - ;; Get header info from original article. - (save-restriction - (message-narrow-to-head-1) - (setq from (message-fetch-field "from") - sender (message-fetch-field "sender") - newsgroups (message-fetch-field "newsgroups") - message-id (message-fetch-field "message-id" t) - distribution (message-fetch-field "distribution"))) - ;; Make sure that this article was written by the user. - (unless (or (and sender - (string-equal - (downcase sender) - (downcase (message-make-sender)))) - (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components - (message-make-from)))))) - (error "This article is not yours")) + (let (from newsgroups message-id distribution buf) + (save-excursion + ;; Get header info from original article. + (save-restriction + (message-narrow-to-head-1) + (setq from (message-fetch-field "from") + newsgroups (message-fetch-field "newsgroups") + message-id (message-fetch-field "message-id" t) + distribution (message-fetch-field "distribution"))) + ;; Make sure that this article was written by the user. + (unless (message-is-yours-p) + (error "This article is not yours")) + (when (yes-or-no-p "Do you really want to cancel this article? ") ;; Make control message. (if arg (message-news) (setq buf (set-buffer (get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" - "From: " from "\n" + "From: " from "\n" "Subject: cmsg cancel " message-id "\n" "Control: cancel " message-id "\n" (if distribution @@ -4073,18 +5978,9 @@ This is done simply by taking the old article and adding a Supersedes header line with the old Message-ID." (interactive) - (let ((cur (current-buffer)) - (sender (message-fetch-field "sender")) - (from (message-fetch-field "from"))) + (let ((cur (current-buffer))) ;; Check whether the user owns the article that is to be superseded. - (unless (or (and sender - (string-equal - (downcase sender) - (downcase (message-make-sender)))) - (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components - (message-make-from)))))) + (unless (message-is-yours-p) (error "This article is not yours")) ;; Get a normal message buffer. (message-pop-to-buffer (message-buffer-name "supersede")) @@ -4161,26 +6057,48 @@ (defvar message-forward-decoded-p nil "Non-nil means the original message is decoded.") +(defun message-forward-subject-name-subject (subject) + "Generate a SUBJECT for a forwarded message. +The form is: [Source] Subject, where if the original message was mail, +Source is the name of the sender, and if the original message was +news, Source is the list of newsgroups is was posted to." + (let* ((group (message-fetch-field "newsgroups")) + (from (message-fetch-field "from")) + (prefix + (if group + (gnus-group-decoded-name group) + (or (and from (car (gnus-extract-address-components from))) + "(nowhere)")))) + (concat "[" + (if message-forward-decoded-p + prefix + (mail-decode-encoded-word-string prefix)) + "] " subject))) + (defun message-forward-subject-author-subject (subject) "Generate a SUBJECT for a forwarded message. The form is: [Source] Subject, where if the original message was mail, Source is the sender, and if the original message was news, Source is the list of newsgroups is was posted to." - (concat "[" - (let ((prefix - (or (message-fetch-field "newsgroups") - (message-fetch-field "from") - "(nowhere)"))) - (if message-forward-decoded-p - prefix - (mail-decode-encoded-word-string prefix))) - "] " subject)) + (let* ((group (message-fetch-field "newsgroups")) + (prefix + (if group + (gnus-group-decoded-name group) + (or (message-fetch-field "from") + "(nowhere)")))) + (concat "[" + (if message-forward-decoded-p + prefix + (mail-decode-encoded-word-string prefix)) + "] " subject))) (defun message-forward-subject-fwd (subject) "Generate a SUBJECT for a forwarded message. The form is: Fwd: Subject, where Subject is the original subject of the message." - (concat "Fwd: " subject)) + (if (string-match "^Fwd: " subject) + subject + (concat "Fwd: " subject))) (defun message-make-forward-subject () "Return a Subject header suitable for the message in the current buffer." @@ -4204,7 +6122,7 @@ ;; Apply funcs in order, passing subject generated by previous ;; func to the next one. (while funcs - (when (message-functionp (car funcs)) + (when (functionp (car funcs)) (setq subject (funcall (car funcs) subject))) (setq funcs (cdr funcs))) subject)))) @@ -4230,6 +6148,108 @@ (message-mail nil subject)) (message-forward-make-body cur digest))) +(defun message-forward-make-body-plain (forward-buffer) + (insert + "\n-------------------- Start of forwarded message --------------------\n") + (let ((b (point)) e) + (insert + (with-temp-buffer + (mm-disable-multibyte) + (insert + (with-current-buffer forward-buffer + (mm-with-unibyte-current-buffer (buffer-string)))) + (mm-enable-multibyte) + (mime-to-mml) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (buffer-string))) + (setq e (point)) + (insert + "\n-------------------- End of forwarded message --------------------\n") + (when (and (not current-prefix-arg) + message-forward-ignored-headers) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (message-remove-header message-forward-ignored-headers t))))) + +(defun message-forward-make-body-mime (forward-buffer) + (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") + (let ((b (point)) e) + (save-restriction + (narrow-to-region (point) (point)) + (mml-insert-buffer forward-buffer) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (goto-char (point-max))) + (setq e (point)) + (insert "<#/part>\n"))) + +(defun message-forward-make-body-mml (forward-buffer) + (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") + (let ((b (point)) e) + (if (not message-forward-decoded-p) + (insert + (with-temp-buffer + (mm-disable-multibyte) + (insert + (with-current-buffer forward-buffer + (mm-with-unibyte-current-buffer (buffer-string)))) + (mm-enable-multibyte) + (mime-to-mml) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (buffer-string))) + (save-restriction + (narrow-to-region (point) (point)) + (mml-insert-buffer forward-buffer) + (goto-char (point-min)) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) + (goto-char (point-max)))) + (setq e (point)) + (insert "<#/mml>\n") + (when (and (not current-prefix-arg) + message-forward-ignored-headers) + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (message-remove-header message-forward-ignored-headers t))))) + +(defun message-forward-make-body-digest-plain (forward-buffer) + (insert + "\n-------------------- Start of forwarded message --------------------\n") + (let ((b (point)) e) + (mml-insert-buffer forward-buffer) + (setq e (point)) + (insert + "\n-------------------- End of forwarded message --------------------\n"))) + +(defun message-forward-make-body-digest-mime (forward-buffer) + (insert "\n<#multipart type=digest>\n") + (let ((b (point)) e) + (insert-buffer-substring forward-buffer) + (setq e (point)) + (insert "<#/multipart>\n") + (save-restriction + (narrow-to-region b e) + (goto-char b) + (narrow-to-region (point) + (or (search-forward "\n\n" nil t) (point))) + (delete-region (point-min) (point-max))))) + +(defun message-forward-make-body-digest (forward-buffer) + (if message-forward-as-mime + (message-forward-make-body-digest-mime forward-buffer) + (message-forward-make-body-digest-plain forward-buffer))) + ;;;###autoload (defun message-forward-make-body (forward-buffer &optional digest) ;; Put point where we want it before inserting the forwarded @@ -4237,75 +6257,37 @@ (if message-forward-before-signature (message-goto-body) (goto-char (point-max))) - (if message-forward-as-mime - (if digest - (insert "\n<#multipart type=digest>\n") - (if message-forward-show-mml - (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") - (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n"))) - (insert "\n-------------------- Start of forwarded message --------------------\n")) - (let ((b (point)) e) - (if digest - (if message-forward-as-mime - (insert-buffer-substring forward-buffer) - (mml-insert-buffer forward-buffer)) - (if (and message-forward-show-mml - (not message-forward-decoded-p)) - (insert - (with-temp-buffer - (mm-disable-multibyte) ;; Must copy buffer in unibyte mode - (insert - (with-current-buffer forward-buffer - (mm-string-as-unibyte (buffer-string)))) - (mm-enable-multibyte) - (mime-to-mml) - (goto-char (point-min)) - (when (looking-at "From ") - (replace-match "X-From-Line: ")) - (buffer-string))) - (save-restriction - (narrow-to-region (point) (point)) - (mml-insert-buffer forward-buffer) - (goto-char (point-min)) - (when (looking-at "From ") - (replace-match "X-From-Line: ")) - (goto-char (point-max))))) - (setq e (point)) + (if digest + (message-forward-make-body-digest forward-buffer) (if message-forward-as-mime - (if digest - (insert "<#/multipart>\n") - (if message-forward-show-mml - (insert "<#/mml>\n") - (insert "<#/part>\n"))) - (insert "\n-------------------- End of forwarded message --------------------\n")) - (if (and digest message-forward-as-mime) - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) - (or (search-forward "\n\n" nil t) (point))) - (delete-region (point-min) (point-max))) - (when (and (not current-prefix-arg) - message-forward-ignored-headers) - (save-restriction - (narrow-to-region b e) - (goto-char b) - (narrow-to-region (point) - (or (search-forward "\n\n" nil t) (point))) - (message-remove-header message-forward-ignored-headers t))))) + (if (and message-forward-show-mml + (not (and (eq message-forward-show-mml 'best) + (with-current-buffer forward-buffer + (goto-char (point-min)) + (re-search-forward + "Content-Type: *multipart/\\(signed\\|encrypted\\)" + nil t))))) + (message-forward-make-body-mml forward-buffer) + (message-forward-make-body-mime forward-buffer)) + (message-forward-make-body-plain forward-buffer))) (message-position-point)) ;;;###autoload (defun message-forward-rmail-make-body (forward-buffer) (save-window-excursion (set-buffer forward-buffer) + ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs + ;; 20. FIXIT, or we drop support for rmail in Emacs 20. (if (rmail-msg-is-pruned) (rmail-msg-restore-non-pruned-header))) (message-forward-make-body forward-buffer)) +(eval-when-compile (defvar rmail-enable-mime-composing)) + +;; Fixme: Should have defcustom. ;;;###autoload (defun message-insinuate-rmail () - "Let RMAIL uses message to forward." + "Let RMAIL use message to forward." (interactive) (setq rmail-enable-mime-composing t) (setq rmail-insert-mime-forwarded-message-function @@ -4324,12 +6306,16 @@ (unless (message-mail-user-agent) (set-buffer (get-buffer-create " *message resend*")) (erase-buffer)) - (let ((message-this-is-mail t)) + (let ((message-this-is-mail t) + message-setup-hook) (message-setup `((To . ,address)))) ;; Insert our usual headers. - (message-generate-headers '(From Date To)) + (message-generate-headers '(From Date To Message-ID)) (message-narrow-to-headers) + ;; Remove X-Draft-From header etc. + (message-remove-header message-ignored-mail-headers t) ;; Rename them all to "Resent-*". + (goto-char (point-min)) (while (re-search-forward "^[A-Za-z]" nil t) (forward-char -1) (insert "Resent-")) @@ -4380,18 +6366,23 @@ (mm-insert-part handles) (undo-boundary) (goto-char (point-min)) - (search-forward "\n\n" nil t) - (or (and (re-search-forward message-unsent-separator nil t) - (forward-line 1)) - (re-search-forward "^Return-Path:.*\n" nil t)) + (re-search-forward "\n\n+" nil t) + (setq boundary (point)) ;; We remove everything before the bounced mail. - (delete-region - (point-min) - (if (re-search-forward "^[^ \n\t]+:" nil t) - (match-beginning 0) - (point)))) + (if (or (re-search-forward message-unsent-separator nil t) + (progn + (search-forward "\n\n" nil 'move) + (re-search-backward "^Return-Path:.*\n" boundary t))) + (progn + (forward-line 1) + (delete-region (point-min) + (if (re-search-forward "^[^ \n\t]+:" nil t) + (match-beginning 0) + (point)))) + (goto-char boundary) + (when (re-search-backward "^.?From .*\n" nil t) + (delete-region (match-beginning 0) (match-end 0))))) (mm-enable-multibyte) - (mime-to-mml) (save-restriction (message-narrow-to-head-1) (message-remove-header message-ignored-bounced-headers t) @@ -4442,7 +6433,7 @@ (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) + (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) (let ((message-this-is-news t)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) @@ -4456,7 +6447,7 @@ (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) - (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))) + (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) (let ((message-this-is-news t)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) @@ -4496,48 +6487,105 @@ (delete-char -2)))))) (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) +(defalias 'message-make-overlay 'make-overlay) +(defalias 'message-delete-overlay 'delete-overlay) +(defalias 'message-overlay-put 'overlay-put) +(defun message-kill-all-overlays () + (if (featurep 'xemacs) + (map-extents (lambda (extent ignore) (delete-extent extent))) + (mapcar #'delete-overlay (overlays-in (point-min) (point-max))))) ;; Support for toolbar -(eval-when-compile (defvar tool-bar-map)) -(if (featurep 'xemacs) - (require 'messagexmas) - (when (and - (condition-case nil (require 'tool-bar) (error nil)) - (fboundp 'tool-bar-add-item-from-menu) - tool-bar-mode) - (defvar message-tool-bar-map - (let ((tool-bar-map (copy-keymap tool-bar-map))) - ;; Zap some items which aren't so relevant and take up space. - (dolist (key '(print-buffer kill-buffer save-buffer write-file - dired open-file)) - (define-key tool-bar-map (vector key) nil)) - - (tool-bar-add-item-from-menu - 'message-send-and-exit "mail_send" message-mode-map) - (tool-bar-add-item-from-menu - 'message-kill-buffer "close" message-mode-map) - (tool-bar-add-item-from-menu - 'message-dont-send "cancel" message-mode-map) - (tool-bar-add-item-from-menu - 'mml-attach-file "attach" message-mode-map) - (tool-bar-add-item-from-menu - 'ispell-message "spell" message-mode-map) - tool-bar-map)))) +(eval-when-compile + (defvar tool-bar-map) + (defvar tool-bar-mode)) + +(defun message-tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props) + ;; We need to make tool bar entries in local keymaps with + ;; `tool-bar-local-item-from-menu' in Emacs > 21.3 + (if (fboundp 'tool-bar-local-item-from-menu) + ;; This is for Emacs 21.3 + (tool-bar-local-item-from-menu command icon in-map from-map props) + (tool-bar-add-item-from-menu command icon from-map props))) + +(defun message-tool-bar-map () + (or message-tool-bar-map + (setq message-tool-bar-map + (and + (condition-case nil (require 'tool-bar) (error nil)) + (fboundp 'tool-bar-add-item-from-menu) + tool-bar-mode + (let ((tool-bar-map (copy-keymap tool-bar-map)) + (load-path (mm-image-load-path))) + ;; Zap some items which aren't so relevant and take + ;; up space. + (dolist (key '(print-buffer kill-buffer save-buffer + write-file dired open-file)) + (define-key tool-bar-map (vector key) nil)) + (message-tool-bar-local-item-from-menu + 'message-send-and-exit "mail_send" tool-bar-map message-mode-map) + (message-tool-bar-local-item-from-menu + 'message-kill-buffer "close" tool-bar-map message-mode-map) + (message-tool-bar-local-item-from-menu + 'message-dont-send "cancel" tool-bar-map message-mode-map) + (message-tool-bar-local-item-from-menu + 'mml-attach-file "attach" tool-bar-map mml-mode-map) + (message-tool-bar-local-item-from-menu + 'ispell-message "spell" tool-bar-map message-mode-map) + (message-tool-bar-local-item-from-menu + 'mml-preview "preview" + tool-bar-map mml-mode-map) + (message-tool-bar-local-item-from-menu + 'message-insert-importance-high "important" + tool-bar-map message-mode-map) + (message-tool-bar-local-item-from-menu + 'message-insert-importance-low "unimportant" + tool-bar-map message-mode-map) + (message-tool-bar-local-item-from-menu + 'message-insert-disposition-notification-to "receipt" + tool-bar-map message-mode-map) + tool-bar-map))))) ;;; Group name completion. -(defvar message-newgroups-header-regexp +(defcustom message-newgroups-header-regexp "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" - "Regexp that match headers that lists groups.") + "Regexp that match headers that lists groups." + :group 'message + :type 'regexp) + +(defcustom message-completion-alist + (list (cons message-newgroups-header-regexp 'message-expand-group) + '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) + '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" + . message-expand-name) + '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):" + . message-expand-name)) + "Alist of (RE . FUN). Use FUN for completion on header lines matching RE." + :group 'message + :type '(alist :key-type regexp :value-type function)) + +(defcustom message-tab-body-function nil + "*Function to execute when `message-tab' (TAB) is executed in the body. +If nil, the function bound in `text-mode-map' or `global-map' is executed." + :group 'message + :link '(custom-manual "(message)Various Commands") + :type 'function) (defun message-tab () - "Expand group names in Newsgroups and Followup-To headers. -Do a `tab-to-tab-stop' if not in those headers." + "Complete names according to `message-completion-alist'. +Execute function specified by `message-tab-body-function' when not in +those headers." (interactive) - (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp)) - (mail-abbrev-in-expansion-header-p)) - (message-expand-group) - (tab-to-tab-stop))) + (let ((alist message-completion-alist)) + (while (and alist + (let ((mail-abbrev-mode-regexp (caar alist))) + (not (mail-abbrev-in-expansion-header-p)))) + (setq alist (cdr alist))) + (funcall (or (cdar alist) message-tab-body-function + (lookup-key text-mode-map "\t") + (lookup-key global-map "\t") + 'indent-relative)))) (defun message-expand-group () "Expand the group name under point." @@ -4581,6 +6629,11 @@ (goto-char (point-min)) (delete-region (point) (progn (forward-line 3) (point)))))))))) +(defun message-expand-name () + (if (fboundp 'bbdb-complete-name) + (bbdb-complete-name) + (expand-abbrev))) + ;;; Help stuff. (defun message-talkative-question (ask question show &rest text) @@ -4610,10 +6663,10 @@ (list list)))) (defun message-generate-new-buffer-clone-locals (name &optional varstr) - "Create and return a buffer with name based on NAME using `generate-new-buffer.' + "Create and return a buffer with name based on NAME using `generate-new-buffer'. Then clone the local variables and values from the old buffer to the new one, cloning only the locals having a substring matching the -regexp varstr." +regexp VARSTR." (let ((oldbuf (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) @@ -4671,16 +6724,17 @@ (when lines (insert lines)) (setq content-type-p - (re-search-backward "^Content-Type:" nil t))) + (or mml-boundary + (re-search-backward "^Content-Type:" nil t)))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-first-header "Content-Type") (message-remove-first-header "Content-Transfer-Encoding")) - ;; We always make sure that the message has a Content-Type header. - ;; This is because some broken MTAs and MUAs get awfully confused - ;; when confronted with a message with a MIME-Version header and - ;; without a Content-Type header. For instance, Solaris' - ;; /usr/bin/mail. + ;; We always make sure that the message has a Content-Type + ;; header. This is because some broken MTAs and MUAs get + ;; awfully confused when confronted with a message with a + ;; MIME-Version header and without a Content-Type header. For + ;; instance, Solaris' /usr/bin/mail. (unless content-type-p (goto-char (point-min)) ;; For unknown reason, MIME-Version doesn't exist. @@ -4688,14 +6742,16 @@ (forward-line 1) (insert "Content-Type: text/plain; charset=us-ascii\n")))))) -(defun message-read-from-minibuffer (prompt) +(defun message-read-from-minibuffer (prompt &optional initial-contents) "Read from the minibuffer while providing abbrev expansion." (if (fboundp 'mail-abbrevs-setup) (let ((mail-abbrev-mode-regexp "") - (minibuffer-setup-hook 'mail-abbrevs-setup)) - (read-from-minibuffer prompt)) - (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) - (read-string prompt)))) + (minibuffer-setup-hook 'mail-abbrevs-setup) + (minibuffer-local-map message-minibuffer-local-map)) + (read-from-minibuffer prompt initial-contents)) + (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook) + (minibuffer-local-map message-minibuffer-local-map)) + (read-string prompt initial-contents)))) (defun message-use-alternative-email-as-from () (require 'mail-utils) @@ -4715,6 +6771,74 @@ (goto-char (point-max)) (insert "From: " email "\n")))) +(defun message-options-get (symbol) + (cdr (assq symbol message-options))) + +(defun message-options-set (symbol value) + (let ((the-cons (assq symbol message-options))) + (if the-cons + (if value + (setcdr the-cons value) + (setq message-options (delq the-cons message-options))) + (and value + (push (cons symbol value) message-options)))) + value) + +(defun message-options-set-recipient () + (save-restriction + (message-narrow-to-headers-or-head) + (message-options-set 'message-sender + (mail-strip-quoted-names + (message-fetch-field "from"))) + (message-options-set 'message-recipients + (mail-strip-quoted-names + (let ((to (message-fetch-field "to")) + (cc (message-fetch-field "cc")) + (bcc (message-fetch-field "bcc"))) + (concat + (or to "") + (if (and to cc) ", ") + (or cc "") + (if (and (or to cc) bcc) ", ") + (or bcc ""))))))) + +(defun message-hide-headers () + "Hide headers based on the `message-hidden-headers' variable." + (let ((regexps (if (stringp message-hidden-headers) + (list message-hidden-headers) + message-hidden-headers)) + (inhibit-point-motion-hooks t) + (after-change-functions nil)) + (when regexps + (save-excursion + (save-restriction + (message-narrow-to-headers) + (goto-char (point-min)) + (while (not (eobp)) + (if (not (message-hide-header-p regexps)) + (message-next-header) + (let ((begin (point))) + (message-next-header) + (add-text-properties + begin (point) + '(invisible t message-hidden t)))))))))) + +(defun message-hide-header-p (regexps) + (let ((result nil) + (reverse nil)) + (when (eq (car regexps) 'not) + (setq reverse t) + (pop regexps)) + (dolist (regexp regexps) + (setq result (or result (looking-at regexp)))) + (if reverse + (not result) + result))) + +(when (featurep 'xemacs) + (require 'messagexmas) + (message-xmas-redefine)) + (provide 'message) (run-hooks 'message-load-hook)
--- a/lisp/gnus/messcompat.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/messcompat.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; messcompat.el --- making message mode compatible with mail mode -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -40,7 +40,7 @@ (defvar message-from-style mail-from-style "*Specifies how \"From\" headers look. -If `nil', they contain just the return address like: +If nil, they contain just the return address like: king@grassland.com If `parens', they look like: king@grassland.com (Elvis Parsley)
--- a/lisp/gnus/mm-bodies.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mm-bodies.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,7 @@ -;;; mm-bodies.el --- functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000, 2002 Free Software Foundation, Inc. +;;; mm-bodies.el --- Functions for decoding MIME things + +;; Copyright (C) 1998, 1999, 2000, 2001, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> @@ -42,7 +44,14 @@ (defcustom mm-body-charset-encoding-alist '((iso-2022-jp . 7bit) - (iso-2022-jp-2 . 7bit)) + (iso-2022-jp-2 . 7bit) + ;; We MUST encode UTF-16 because it can contain \0's which is + ;; known to break servers. + ;; Note: UTF-16 variants are invalid for text parts [RFC 2781], + ;; so this can't happen :-/. + (utf-16 . base64) + (utf-16be . base64) + (utf-16le . base64)) "Alist of MIME charsets to encodings. Valid encodings are `7bit', `8bit', `quoted-printable' and `base64'." :type '(repeat (cons (symbol :tag "charset") @@ -53,51 +62,82 @@ (const base64)))) :group 'mime) -(defun mm-encode-body () +(defun mm-encode-body (&optional charset) "Encode a body. Should be called narrowed to the body that is to be encoded. -If there is more than one non-ASCII Mule charset, then the list of found -Mule charsets is returned. +If there is more than one non-ASCII MULE charset in the body, then the +list of MULE charsets found is returned. +If CHARSET is non-nil, it is used as the MIME charset to encode the body. If successful, the MIME charset is returned. If no encoding was done, nil is returned." (if (not (mm-multibyte-p)) ;; In the non-Mule case, we search for non-ASCII chars and ;; return the value of `mail-parse-charset' if any are found. - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "[^\x0-\x7f]" nil t) - (or mail-parse-charset - (mm-read-charset "Charset used in the article: ")) - ;; The logic in `mml-generate-mime-1' confirms that it's OK - ;; to return nil here. - nil)) + (or charset + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "[^\x0-\x7f]" nil t) + (or mail-parse-charset + (message-options-get 'mm-encody-body-charset) + (message-options-set + 'mm-encody-body-charset + (mm-read-coding-system "Charset used in the article: "))) + ;; The logic in `mml-generate-mime-1' confirms that it's OK + ;; to return nil here. + nil))) (save-excursion - (goto-char (point-min)) - (let ((charsets (mm-find-mime-charset-region (point-min) (point-max)))) - (cond - ;; No encoding. - ((null charsets) - nil) - ;; Too many charsets. - ((> (length charsets) 1) - charsets) - ;; We encode. - (t - (mm-encode-coding-region (point-min) (point-max) - (mm-charset-to-coding-system - (car charsets))) - (car charsets))))))) + (if charset + (progn + (mm-encode-coding-region (point-min) (point-max) charset) + charset) + (goto-char (point-min)) + (let ((charsets (mm-find-mime-charset-region (point-min) (point-max) + mm-hack-charsets))) + (cond + ;; No encoding. + ((null charsets) + nil) + ;; Too many charsets. + ((> (length charsets) 1) + charsets) + ;; We encode. + (t + (prog1 + (setq charset (car charsets)) + (mm-encode-coding-region (point-min) (point-max) + (mm-charset-to-coding-system charset)))) + )))))) -(eval-when-compile (defvar message-posting-charset)) +(defun mm-long-lines-p (length) + "Say whether any of the lines in the buffer is longer than LENGTH." + (save-excursion + (goto-char (point-min)) + (end-of-line) + (while (and (not (eobp)) + (not (> (current-column) length))) + (forward-line 1) + (end-of-line)) + (and (> (current-column) length) + (current-column)))) + +(defvar message-posting-charset) (defun mm-body-encoding (charset &optional encoding) "Do Content-Transfer-Encoding and return the encoding of the current buffer." - (let ((bits (mm-body-7-or-8))) + (when (stringp encoding) + (setq encoding (intern (downcase encoding)))) + (let ((bits (mm-body-7-or-8)) + (longp (mm-long-lines-p 1000))) (require 'message) (cond - ((and (not mm-use-ultra-safe-encoding) (eq bits '7bit)) + ((and (not longp) + (not (and mm-use-ultra-safe-encoding + (save-excursion (re-search-forward "^From " nil t)))) + (eq bits '7bit)) bits) ((and (not mm-use-ultra-safe-encoding) + (not longp) + (not (cdr (assq charset mm-body-charset-encoding-alist))) (or (eq t (cdr message-posting-charset)) (memq charset (cdr message-posting-charset)) (eq charset mail-parse-charset))) @@ -124,12 +164,17 @@ ;;; Functions for decoding ;;; +(eval-when-compile (defvar mm-uu-yenc-decode-function)) + (defun mm-decode-content-transfer-encoding (encoding &optional type) + "Decodes buffer encoded with ENCODING, returning success status. +If TYPE is `text/plain' CRLF->LF translation may occur." (prog1 (condition-case error (cond ((eq encoding 'quoted-printable) - (quoted-printable-decode-region (point-min) (point-max))) + (quoted-printable-decode-region (point-min) (point-max)) + t) ((eq encoding 'base64) (base64-decode-region (point-min) @@ -144,49 +189,57 @@ (delete-region (match-beginning 0) (match-end 0))) (goto-char (point-max)) (when (re-search-backward "^[A-Za-z0-9+/]+=*[\t ]*$" nil t) - (forward-line) - (delete-region (point) (point-max))) - (point-max)))) + (forward-line)) + (point)))) ((memq encoding '(7bit 8bit binary)) ;; Do nothing. - ) + t) ((null encoding) ;; Do nothing. - ) + t) ((memq encoding '(x-uuencode x-uue)) (require 'mm-uu) - (funcall mm-uu-decode-function (point-min) (point-max))) + (funcall mm-uu-decode-function (point-min) (point-max)) + t) ((eq encoding 'x-binhex) (require 'mm-uu) - (funcall mm-uu-binhex-decode-function (point-min) (point-max))) + (funcall mm-uu-binhex-decode-function (point-min) (point-max)) + t) + ((eq encoding 'x-yenc) + (require 'mm-uu) + (funcall mm-uu-yenc-decode-function (point-min) (point-max)) + ) ((functionp encoding) - (funcall encoding (point-min) (point-max))) + (funcall encoding (point-min) (point-max)) + t) (t (message "Unknown encoding %s; defaulting to 8bit" encoding))) (error (message "Error while decoding: %s" error) nil)) (when (and - (memq encoding '(base64 x-uuencode x-uue x-binhex)) + (memq encoding '(base64 x-uuencode x-uue x-binhex x-yenc)) (equal type "text/plain")) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n" t t))))) (defun mm-decode-body (charset &optional encoding type) - "Decode the current article that has been encoded with ENCODING. -The characters in CHARSET should then be decoded." - (if (stringp charset) - (setq charset (intern (downcase charset)))) - (if (or (not charset) - (eq 'gnus-all mail-parse-ignored-charsets) - (memq 'gnus-all mail-parse-ignored-charsets) - (memq charset mail-parse-ignored-charsets)) - (setq charset mail-parse-charset)) + "Decode the current article that has been encoded with ENCODING to CHARSET. +ENCODING is a MIME content transfer encoding. +CHARSET is the MIME charset with which to decode the data after transfer +decoding. If it is nil, default to `mail-parse-charset'." + (when (stringp charset) + (setq charset (intern (downcase charset)))) + (when (or (not charset) + (eq 'gnus-all mail-parse-ignored-charsets) + (memq 'gnus-all mail-parse-ignored-charsets) + (memq charset mail-parse-ignored-charsets)) + (setq charset mail-parse-charset)) (save-excursion (when encoding (mm-decode-content-transfer-encoding encoding type)) - (when (featurep 'mule) + (when (featurep 'mule) ; Fixme: Wrong test for unibyte session. (let ((coding-system (mm-charset-to-coding-system charset))) (if (and (not coding-system) (listp mail-parse-ignored-charsets) @@ -201,7 +254,12 @@ (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset)) (not (eq coding-system 'gnus-decoded))) - (mm-decode-coding-region (point-min) (point-max) coding-system)))))) + (mm-decode-coding-region (point-min) (point-max) + coding-system)) + (setq buffer-file-coding-system + (if (boundp 'last-coding-system-used) + (symbol-value 'last-coding-system-used) + coding-system)))))) (defun mm-decode-string (string charset) "Decode STRING with CHARSET."
--- a/lisp/gnus/mm-decode.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mm-decode.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ -;;; mm-decode.el --- functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +;;; mm-decode.el --- Functions for decoding MIME things +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> @@ -27,12 +28,17 @@ (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl) + (require 'term)) (eval-and-compile + (autoload 'executable-find "executable") (autoload 'mm-inline-partial "mm-partial") + (autoload 'mm-inline-external-body "mm-extern") (autoload 'mm-insert-inline "mm-view")) +(add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list) + (defgroup mime-display () "Display of MIME in mail and news articles." :link '(custom-manual "(emacs-mime)Customization") @@ -41,6 +47,13 @@ :group 'news :group 'multimedia) +(defgroup mime-security () + "MIME security in mail and news articles." + :link '(custom-manual "(emacs-mime)Customization") + :group 'mail + :group 'news + :group 'multimedia) + ;;; Convenience macros. (defmacro mm-handle-buffer (handle) @@ -71,14 +84,94 @@ `(setcar (nthcdr 6 ,handle) ,contents)) (defmacro mm-handle-id (handle) `(nth 7 ,handle)) +(defmacro mm-handle-multipart-original-buffer (handle) + `(get-text-property 0 'buffer (car ,handle))) +(defmacro mm-handle-multipart-from (handle) + `(get-text-property 0 'from (car ,handle))) +(defmacro mm-handle-multipart-ctl-parameter (handle parameter) + `(get-text-property 0 ,parameter (car ,handle))) + (defmacro mm-make-handle (&optional buffer type encoding undisplayer disposition description cache id) `(list ,buffer ,type ,encoding ,undisplayer ,disposition ,description ,cache ,id)) +(defcustom mm-text-html-renderer + (cond ((locate-library "w3") 'w3) + ((executable-find "w3m") (if (locate-library "w3m") + 'w3m + 'w3m-standalone)) + ((executable-find "links") 'links) + ((executable-find "lynx") 'lynx) + (t 'html2text)) + "Render of HTML contents. +It is one of defined renderer types, or a rendering function. +The defined renderer types are: +`w3' : use Emacs/W3; +`w3m' : use emacs-w3m; +`w3m-standalone': use w3m; +`links': use links; +`lynx' : use lynx; +`html2text' : use html2text; +nil : use external viewer." + :type '(choice (const w3) + (const w3m) + (const w3m-standalone) + (const links) + (const lynx) + (const html2text) + (const nil) + (function)) + :version "21.3" + :group 'mime-display) + +(defvar mm-inline-text-html-renderer nil + "Function used for rendering inline HTML contents. +It is suggested to customize `mm-text-html-renderer' instead.") + +(defcustom mm-inline-text-html-with-images nil + "If non-nil, Gnus will allow retrieving images in HTML contents with +the <img> tags. It has no effect on Emacs/w3. See also the +documentation for the `mm-w3m-safe-url-regexp' variable." + :type 'boolean + :group 'mime-display) + +(defcustom mm-w3m-safe-url-regexp "\\`cid:" + "Regexp matching URLs which are considered to be safe. +Some HTML mails might contain a nasty trick used by spammers, using +the <img> tag which is far more evil than the [Click Here!] button. +It is most likely intended to check whether the ominous spam mail has +reached your eyes or not, in which case the spammer knows for sure +that your email address is valid. It is done by embedding an +identifier string into a URL that you might automatically retrieve +when displaying the image. The default value is \"\\\\`cid:\" which only +matches parts embedded to the Multipart/Related type MIME contents and +Gnus will never connect to the spammer's site arbitrarily. You may +set this variable to nil if you consider all urls to be safe." + :type '(choice (regexp :tag "Regexp") + (const :tag "All URLs are safe" nil)) + :group 'mime-display) + +(defcustom mm-inline-text-html-with-w3m-keymap t + "If non-nil, use emacs-w3m command keys in the article buffer." + :type 'boolean + :group 'mime-display) + +(defcustom mm-enable-external t + "Indicate whether external MIME handlers should be used. + +If t, all defined external MIME handlers are used. If nil, files are saved by +`mailcap-save-binary-file'. If it is the symbol `ask', you are prompted +before the external MIME handler is invoked." + :version "21.4" + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :group 'mime-display) + (defcustom mm-inline-media-tests - '(("image/jpeg" + '(("image/p?jpeg" mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'jpeg handle))) @@ -106,7 +199,7 @@ mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) - ("image/x-pixmap" + ("image/x-xpixmap" mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) @@ -125,18 +218,21 @@ (lambda (handle) (locate-library "diff-mode"))) ("application/emacs-lisp" mm-display-elisp-inline identity) + ("application/x-emacs-lisp" mm-display-elisp-inline identity) ("text/html" - mm-inline-text + mm-inline-text-html (lambda (handle) - (locate-library "w3"))) + (or mm-inline-text-html-renderer + mm-text-html-renderer))) ("text/x-vcard" - mm-inline-text + mm-inline-text-vcard (lambda (handle) (or (featurep 'vcard) (locate-library "vcard")))) ("message/delivery-status" mm-inline-text identity) ("message/rfc822" mm-inline-message identity) ("message/partial" mm-inline-partial identity) + ("message/external-body" mm-inline-external-body identity) ("text/.*" mm-inline-text identity) ("audio/wav" mm-inline-audio (lambda (handle) @@ -148,20 +244,42 @@ (and (or (featurep 'nas-sound) (featurep 'native-sound)) (device-sound-enabled-p)))) ("application/pgp-signature" ignore identity) + ("application/x-pkcs7-signature" ignore identity) + ("application/pkcs7-signature" ignore identity) + ("application/x-pkcs7-mime" ignore identity) + ("application/pkcs7-mime" ignore identity) ("multipart/alternative" ignore identity) ("multipart/mixed" ignore identity) - ("multipart/related" ignore identity)) + ("multipart/related" ignore identity) + ;; Disable audio and image + ("audio/.*" ignore ignore) + ("image/.*" ignore ignore) + ;; Default to displaying as text + (".*" mm-inline-text mm-readable-p)) "Alist of media types/tests saying whether types can be displayed inline." - :type '(repeat (list (string :tag "MIME type") + :type '(repeat (list (regexp :tag "MIME type") (function :tag "Display function") (function :tag "Display test"))) :group 'mime-display) (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" - "message/partial" "application/emacs-lisp" - "application/pgp-signature") - "List of media types that are to be displayed inline." + "message/partial" "message/external-body" "application/emacs-lisp" + "application/x-emacs-lisp" + "application/pgp-signature" "application/x-pkcs7-signature" + "application/pkcs7-signature" "application/x-pkcs7-mime" + "application/pkcs7-mime") + "List of media types that are to be displayed inline. +See also `mm-inline-media-tests', which says how to display a media +type inline." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-keep-viewer-alive-types + '("application/postscript" "application/msword" "application/vnd.ms-excel" + "application/pdf" "application/x-dvi") + "List of media types for which the external viewer will not be killed +when selecting a different article." :type '(repeat string) :group 'mime-display) @@ -169,12 +287,19 @@ '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" "message/rfc822" "text/x-patch" "application/pgp-signature" - "application/emacs-lisp") + "application/emacs-lisp" "application/x-emacs-lisp" + "application/x-pkcs7-signature" + "application/pkcs7-signature" "application/x-pkcs7-mime" + "application/pkcs7-mime") "A list of MIME types to be displayed automatically." :type '(repeat string) :group 'mime-display) -(defcustom mm-attachment-override-types '("text/x-vcard") +(defcustom mm-attachment-override-types '("text/x-vcard" + "application/pkcs7-mime" + "application/x-pkcs7-mime" + "application/pkcs7-signature" + "application/x-pkcs7-signature") "Types to have \"attachment\" ignored if they can be displayed inline." :type '(repeat string) :group 'mime-display) @@ -202,28 +327,125 @@ :type '(repeat string) :group 'mime-display) -(defvar mm-tmp-directory - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - ("/tmp/")) - "Where mm will store its temporary files.") +(defcustom mm-tmp-directory + (if (fboundp 'temp-directory) + (temp-directory) + (if (boundp 'temporary-file-directory) + temporary-file-directory + "/tmp/")) + "Where mm will store its temporary files." + :type 'directory + :group 'mime-display) (defcustom mm-inline-large-images nil "If non-nil, then all images fit in the buffer." :type 'boolean :group 'mime-display) +(defvar mm-file-name-rewrite-functions + '(mm-file-name-delete-control mm-file-name-delete-gotchas) + "*List of functions used for rewriting file names of MIME parts. +Each function takes a file name as input and returns a file name. + +Ready-made functions include +`mm-file-name-delete-control' +`mm-file-name-delete-gotchas' +`mm-file-name-delete-whitespace', +`mm-file-name-trim-whitespace', +`mm-file-name-collapse-whitespace', +`mm-file-name-replace-whitespace', +`capitalize', `downcase', `upcase', and +`upcase-initials'.") + +(defvar mm-path-name-rewrite-functions nil + "*List of functions for rewriting the full file names of MIME parts. +This is used when viewing parts externally, and is meant for +transforming the absolute name so that non-compliant programs can find +the file where it's saved. + +Each function takes a file name as input and returns a file name.") + +(defvar mm-file-name-replace-whitespace nil + "String used for replacing whitespace characters; default is `\"_\"'.") + +(defcustom mm-default-directory nil + "The default directory where mm will save files. +If not set, `default-directory' will be used." + :type '(choice directory (const :tag "Default" nil)) + :group 'mime-display) + +(defcustom mm-attachment-file-modes 384 + "Set the mode bits of saved attachments to this integer." + :type 'integer + :group 'mime-display) + +(defcustom mm-external-terminal-program "xterm" + "The program to start an external terminal." + :type 'string + :group 'mime-display) + ;;; Internal variables. -(defvar mm-dissection-list nil) (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) +(defvar mm-postponed-undisplay-list nil) ;; According to RFC2046, in particular, in a digest, the default ;; Content-Type value for a body part is changed from "text/plain" to ;; "message/rfc822". (defvar mm-dissect-default-type "text/plain") +(autoload 'mml2015-verify "mml2015") +(autoload 'mml2015-verify-test "mml2015") +(autoload 'mml-smime-verify "mml-smime") +(autoload 'mml-smime-verify-test "mml-smime") + +(defvar mm-verify-function-alist + '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test) + ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP" + mm-uu-pgp-signed-test) + ("application/pkcs7-signature" mml-smime-verify "S/MIME" + mml-smime-verify-test) + ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" + mml-smime-verify-test))) + +(defcustom mm-verify-option 'never + "Option of verifying signed parts. +`never', not verify; `always', always verify; +`known', only verify known protocols. Otherwise, ask user." + :type '(choice (item always) + (item never) + (item :tag "only known protocols" known) + (item :tag "ask" nil)) + :group 'mime-security) + +(autoload 'mml2015-decrypt "mml2015") +(autoload 'mml2015-decrypt-test "mml2015") + +(defvar mm-decrypt-function-alist + '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test) + ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP" + mm-uu-pgp-encrypted-test))) + +(defcustom mm-decrypt-option nil + "Option of decrypting encrypted parts. +`never', not decrypt; `always', always decrypt; +`known', only decrypt known protocols. Otherwise, ask user." + :type '(choice (item always) + (item never) + (item :tag "only known protocols" known) + (item :tag "ask" nil)) + :group 'mime-security) + +(defvar mm-viewer-completion-map + (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) + (set-keymap-parent map minibuffer-local-completion-map) + map) + "Keymap for input viewer with completion.") + +;; Should we bind other key to minibuffer-complete-word? +(define-key mm-viewer-completion-map " " 'self-insert-command) + (defvar mm-viewer-completion-map (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) (set-keymap-parent map minibuffer-local-completion-map) @@ -235,20 +457,72 @@ ;;; The functions. -(defun mm-dissect-buffer (&optional no-strict-mime) +(defun mm-alist-to-plist (alist) + "Convert association list ALIST into the equivalent property-list form. +The plist is returned. This converts from + +\((a . 1) (b . 2) (c . 3)) + +into + +\(a 1 b 2 c 3) + +The original alist is not modified. See also `destructive-alist-to-plist'." + (let (plist) + (while alist + (let ((el (car alist))) + (setq plist (cons (cdr el) (cons (car el) plist)))) + (setq alist (cdr alist))) + (nreverse plist))) + +(defun mm-keep-viewer-alive-p (handle) + "Say whether external viewer for HANDLE should stay alive." + (let ((types mm-keep-viewer-alive-types) + (type (mm-handle-media-type handle)) + ty) + (catch 'found + (while (setq ty (pop types)) + (when (string-match ty type) + (throw 'found t)))))) + +(defun mm-handle-set-external-undisplayer (handle function) + "Set the undisplayer for HANDLE to FUNCTION. +Postpone undisplaying of viewers for types in +`mm-keep-viewer-alive-types'." + (if (mm-keep-viewer-alive-p handle) + (let ((new-handle (copy-sequence handle))) + (mm-handle-set-undisplayer new-handle function) + (mm-handle-set-undisplayer handle nil) + (push new-handle mm-postponed-undisplay-list)) + (mm-handle-set-undisplayer handle function))) + +(defun mm-destroy-postponed-undisplay-list () + (when mm-postponed-undisplay-list + (message "Destroying external MIME viewers") + (mm-destroy-parts mm-postponed-undisplay-list))) + +(defun mm-dissect-buffer (&optional no-strict-mime loose-mime) "Dissect the current buffer and return a list of MIME handles." (save-excursion - (let (ct ctl type subtype cte cd description id result) + (let (ct ctl type subtype cte cd description id result from) (save-restriction (mail-narrow-to-head) (when (or no-strict-mime + loose-mime (mail-fetch-field "mime-version")) (setq ct (mail-fetch-field "content-type") ctl (ignore-errors (mail-header-parse-content-type ct)) cte (mail-fetch-field "content-transfer-encoding") cd (mail-fetch-field "content-disposition") description (mail-fetch-field "content-description") - id (mail-fetch-field "content-id")))) + from (mail-fetch-field "from") + id (mail-fetch-field "content-id")) + ;; FIXME: In some circumstances, this code is running within + ;; an unibyte macro. mail-extract-address-components + ;; creates unibyte buffers. This `if', though not a perfect + ;; solution, avoids most of them. + (if from + (setq from (cadr (mail-extract-address-components from)))))) (when cte (setq cte (mail-header-strip cte))) (if (or (not ctl) @@ -270,17 +544,34 @@ ((equal type "multipart") (let ((mm-dissect-default-type (if (equal subtype "digest") "message/rfc822" - "text/plain"))) + "text/plain")) + (start (cdr (assq 'start (cdr ctl))))) + (add-text-properties 0 (length (car ctl)) + (mm-alist-to-plist (cdr ctl)) (car ctl)) + + ;; what really needs to be done here is a way to link a + ;; MIME handle back to it's parent MIME handle (in a multilevel + ;; MIME article). That would probably require changing + ;; the mm-handle API so we simply store the multipart buffert + ;; name as a text property of the "multipart/whatever" string. + (add-text-properties 0 (length (car ctl)) + (list 'buffer (mm-copy-to-buffer) + 'from from + 'start start) + (car ctl)) (cons (car ctl) (mm-dissect-multipart ctl)))) (t - (mm-dissect-singlepart - ctl - (and cte (intern (downcase (mail-header-remove-whitespace - (mail-header-remove-comments - cte))))) - no-strict-mime - (and cd (ignore-errors (mail-header-parse-content-disposition cd))) - description id)))) + (mm-possibly-verify-or-decrypt + (mm-dissect-singlepart + ctl + (and cte (intern (downcase (mail-header-remove-whitespace + (mail-header-remove-comments + cte))))) + no-strict-mime + (and cd (ignore-errors + (mail-header-parse-content-disposition cd))) + description id) + ctl)))) (when id (when (string-match " *<\\(.*\\)> *" id) (setq id (match-string 1 id))) @@ -292,16 +583,8 @@ (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) - (let ((res (mm-make-handle - (mm-copy-to-buffer) ctl cte nil cdl description nil id))) - (push (car res) mm-dissection-list) - res))) - -(defun mm-remove-all-parts () - "Remove all MIME handles." - (interactive) - (mapcar 'mm-remove-part mm-dissection-list) - (setq mm-dissection-list nil)) + (mm-make-handle + (mm-copy-to-buffer) ctl cte nil cdl description nil id))) (defun mm-dissect-multipart (ctl) (goto-char (point-min)) @@ -321,14 +604,16 @@ (save-restriction (narrow-to-region start (point)) (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) - (forward-line 2) + (end-of-line 2) + (or (looking-at boundary) + (forward-line 1)) (setq start (point))) (when (and start (< start end)) (save-excursion (save-restriction (narrow-to-region start end) (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) - (nreverse parts))) + (mm-possibly-verify-or-decrypt (nreverse parts) ctl))) (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." @@ -342,6 +627,16 @@ (insert-buffer-substring obuf beg) (current-buffer)))) +(defun mm-display-parts (handle &optional no-default) + (if (stringp (car handle)) + (mapcar 'mm-display-parts (cdr handle)) + (if (bufferp (car handle)) + (save-restriction + (narrow-to-region (point) (point)) + (mm-display-part handle) + (goto-char (point-max))) + (mapcar 'mm-display-parts handle)))) + (defun mm-display-part (handle &optional no-default) "Display the MIME part represented by HANDLE. Returns nil if the part is removed; inline if displayed inline; @@ -351,8 +646,15 @@ (if (mm-handle-displayed-p handle) (mm-remove-part handle) (let* ((type (mm-handle-media-type handle)) - (method (mailcap-mime-info type))) - (if (mm-inlined-p handle) + (method (mailcap-mime-info type)) + (filename (or (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (mm-handle-type handle) 'name) + "<file>")) + (external mm-enable-external)) + (if (and (mm-inlinable-p handle) + (mm-inlined-p handle)) (progn (forward-line 1) (mm-display-inline handle) @@ -365,8 +667,27 @@ (forward-line 1) (mm-insert-inline handle (mm-get-part handle)) 'inline) - (mm-display-external - handle (or method 'mailcap-save-binary-file))))))))) + (if (and method ;; If nil, we always use "save". + (stringp method) ;; 'mailcap-save-binary-file + (or (eq mm-enable-external t) + (and (eq mm-enable-external 'ask) + (y-or-n-p + (concat + "Display part (" type + ") using external program" + ;; Can non-string method ever happen? + (if (stringp method) + (concat + " \"" (format method filename) "\"") + "") + "? "))))) + (setq external t) + (setq external nil)) + (if external + (mm-display-external + handle (or method 'mailcap-save-binary-file)) + (mm-display-external + handle 'mailcap-save-binary-file))))))))) (defun mm-display-external (handle method) "Display HANDLE using METHOD." @@ -383,10 +704,12 @@ (when win (select-window win))) (switch-to-buffer (generate-new-buffer " *mm*"))) + (buffer-disable-undo) (mm-set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) (goto-char (point-min)) - (message "Viewing with %s" method) + (when method + (message "Viewing with %s" method)) (let ((mm (current-buffer)) (non-viewer (assq 'non-viewer (mailcap-mime-info @@ -400,10 +723,13 @@ (mm-handle-set-undisplayer handle mm))))) ;; The function is a string to be executed. (mm-insert-part handle) - (let* ((dir (mm-make-temp-file + (let* ((dir (mm-make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) - (filename (mail-content-type-get - (mm-handle-disposition handle) 'filename)) + (filename (or + (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (mm-handle-type handle) 'name))) (mime-info (mailcap-mime-info (mm-handle-media-type handle) t)) (needsterm (or (assoc "needsterm" mime-info) @@ -413,66 +739,89 @@ ;; We create a private sub-directory where we store our files. (set-file-modes dir 448) (if filename - (setq file (expand-file-name (file-name-nondirectory filename) - dir)) + (setq file (expand-file-name + (gnus-map-function mm-file-name-rewrite-functions + (file-name-nondirectory filename)) + dir)) (setq file (mm-make-temp-file (expand-file-name "mm." dir)))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) (message "Viewing with %s" method) - (cond (needsterm - (unwind-protect - (start-process "*display*" nil - "xterm" - "-e" shell-file-name - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle))) - (mm-handle-set-undisplayer handle (cons file buffer))) - (message "Displaying %s..." (format method file)) - 'external) - (copiousoutput - (with-current-buffer outbuf - (forward-line 1) - (mm-insert-inline - handle - (unwind-protect - (progn - (call-process shell-file-name nil - (setq buffer - (generate-new-buffer "*mm*")) - nil - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle))) - (if (buffer-live-p buffer) - (save-excursion - (set-buffer buffer) - (buffer-string)))) - (progn - (ignore-errors (delete-file file)) - (ignore-errors (delete-directory - (file-name-directory file))) - (ignore-errors (kill-buffer buffer)))))) - 'inline) - (t - (unwind-protect - (start-process "*display*" - (setq buffer - (generate-new-buffer "*mm*")) - shell-file-name - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle))) - (mm-handle-set-undisplayer handle (cons file buffer))) - (message "Displaying %s..." (format method file)) - 'external))))))) + (cond + (needsterm + (let ((command (mm-mailcap-command + method file (mm-handle-type handle)))) + (unwind-protect + (if window-system + (start-process "*display*" nil + mm-external-terminal-program + "-e" shell-file-name + shell-command-switch command) + (require 'term) + (require 'gnus-win) + (set-buffer + (setq buffer + (make-term "display" + shell-file-name + nil + shell-command-switch command))) + (term-mode) + (term-char-mode) + (set-process-sentinel + (get-buffer-process buffer) + `(lambda (process state) + (if (eq 'exit (process-status process)) + (gnus-configure-windows + ',gnus-current-window-configuration)))) + (gnus-configure-windows 'display-term)) + (mm-handle-set-external-undisplayer handle (cons file buffer))) + (message "Displaying %s..." command)) + 'external) + (copiousoutput + (with-current-buffer outbuf + (forward-line 1) + (mm-insert-inline + handle + (unwind-protect + (progn + (call-process shell-file-name nil + (setq buffer + (generate-new-buffer " *mm*")) + nil + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (if (buffer-live-p buffer) + (save-excursion + (set-buffer buffer) + (buffer-string)))) + (progn + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))) + (ignore-errors (kill-buffer buffer)))))) + 'inline) + (t + (let ((command (mm-mailcap-command + method file (mm-handle-type handle)))) + (unwind-protect + (start-process "*display*" + (setq buffer + (generate-new-buffer " *mm*")) + shell-file-name + shell-command-switch command) + (mm-handle-set-external-undisplayer + handle (cons file buffer))) + (message "Displaying %s..." command)) + 'external))))))) (defun mm-mailcap-command (method file type-list) (let ((ctl (cdr type-list)) (beg 0) (uses-stdin t) out sub total) - (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg) + (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%" + method beg) (push (substring method beg (match-beginning 0)) out) (setq beg (match-end 0) total (match-string 0 method) @@ -480,18 +829,23 @@ (cond ((string= total "%%") (push "%" out)) - ((string= total "%s") + ((or (string= total "%s") + ;; We do our own quoting. + (string= total "'%s'") + (string= total "\"%s\"")) (setq uses-stdin nil) - (push (mm-quote-arg file) out)) + (push (mm-quote-arg + (gnus-map-function mm-path-name-rewrite-functions file)) out)) ((string= total "%t") (push (mm-quote-arg (car type-list)) out)) (t (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) (push (substring method beg (length method)) out) - (if uses-stdin - (progn - (push "<" out) - (push (mm-quote-arg file) out))) + (when uses-stdin + (push "<" out) + (push (mm-quote-arg + (gnus-map-function mm-path-name-rewrite-functions file)) + out)) (mapconcat 'identity (nreverse out) ""))) (defun mm-remove-parts (handles) @@ -503,8 +857,8 @@ (while (setq handle (pop handles)) (cond ((stringp handle) - ;; Do nothing. - ) + (when (buffer-live-p (get-text-property 0 'buffer handle)) + (kill-buffer (get-text-property 0 'buffer handle)))) ((and (listp handle) (stringp (car handle))) (mm-remove-parts (cdr handle))) @@ -520,11 +874,11 @@ (while (setq handle (pop handles)) (cond ((stringp handle) - ;; Do nothing. - ) + (when (buffer-live-p (get-text-property 0 'buffer handle)) + (kill-buffer (get-text-property 0 'buffer handle)))) ((and (listp handle) (stringp (car handle))) - (mm-destroy-parts (cdr handle))) + (mm-destroy-parts handle)) (t (mm-destroy-part handle))))))) @@ -543,9 +897,18 @@ (funcall object)) ;; Externally displayed part. ((consp object) + (condition-case () + (while (get-buffer-process (cdr object)) + (interrupt-process (get-buffer-process (cdr object))) + (message "Waiting for external displayer to die...") + (sit-for 1)) + (quit) + (error)) + (ignore-errors (and (cdr object) (kill-buffer (cdr object)))) + (message "Waiting for external displayer to die...done") (ignore-errors (delete-file (car object))) - (ignore-errors (delete-directory (file-name-directory (car object)))) - (ignore-errors (kill-buffer (cdr object)))) + (ignore-errors (delete-directory (file-name-directory + (car object))))) ((bufferp object) (when (buffer-live-p object) (kill-buffer object))))) @@ -562,6 +925,18 @@ (when (string-match (car elem) type) (return elem)))) +(defun mm-automatic-display-p (handle) + "Say whether the user wants HANDLE to be displayed automatically." + (let ((methods mm-automatic-display) + (type (mm-handle-media-type handle)) + method result) + (while (setq method (pop methods)) + (when (and (not (mm-inline-override-p handle)) + (string-match method type)) + (setq result t + methods nil))) + result)) + (defun mm-inlinable-p (handle) "Say whether HANDLE can be displayed inline." (let ((alist mm-inline-media-tests) @@ -575,28 +950,14 @@ (pop alist)) test)) -(defun mm-automatic-display-p (handle) - "Say whether the user wants HANDLE to be displayed automatically." - (let ((methods mm-automatic-display) - (type (mm-handle-media-type handle)) - method result) - (while (setq method (pop methods)) - (when (and (not (mm-inline-override-p handle)) - (string-match method type) - (mm-inlinable-p handle)) - (setq result t - methods nil))) - result)) - (defun mm-inlined-p (handle) - "Say whether the user wants HANDLE to be displayed automatically." + "Say whether the user wants HANDLE to be displayed inline." (let ((methods mm-inlined-types) (type (mm-handle-media-type handle)) method result) (while (setq method (pop methods)) (when (and (not (mm-inline-override-p handle)) - (string-match method type) - (mm-inlinable-p handle)) + (string-match method type)) (setq result t methods nil))) result)) @@ -650,7 +1011,12 @@ (defun mm-get-part (handle) "Return the contents of HANDLE as a string." (mm-with-unibyte-buffer - (mm-insert-part handle) + (insert (with-current-buffer (mm-handle-buffer handle) + (mm-with-unibyte-current-buffer + (buffer-string)))) + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) (buffer-string))) (defun mm-insert-part (handle) @@ -659,23 +1025,61 @@ (save-excursion (if (member (mm-handle-media-supertype handle) '("text" "message")) (with-temp-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (mm-handle-media-type handle)) - (let ((temp (current-buffer))) - (set-buffer cur) - (insert-buffer-substring temp))) + (insert-buffer-substring (mm-handle-buffer handle)) + (prog1 + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) + (let ((temp (current-buffer))) + (set-buffer cur) + (insert-buffer-substring temp)))) (mm-with-unibyte-buffer (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (mm-handle-media-type handle)) - (let ((temp (current-buffer))) - (set-buffer cur) - (insert-buffer-substring temp))))))) + (prog1 + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) + (let ((temp (current-buffer))) + (set-buffer cur) + (insert-buffer-substring temp)))))))) + +(defun mm-file-name-delete-whitespace (file-name) + "Remove all whitespace characters from FILE-NAME." + (while (string-match "\\s-+" file-name) + (setq file-name (replace-match "" t t file-name))) + file-name) + +(defun mm-file-name-trim-whitespace (file-name) + "Remove leading and trailing whitespace characters from FILE-NAME." + (when (string-match "\\`\\s-+" file-name) + (setq file-name (substring file-name (match-end 0)))) + (when (string-match "\\s-+\\'" file-name) + (setq file-name (substring file-name 0 (match-beginning 0)))) + file-name) -(defvar mm-default-directory nil) +(defun mm-file-name-collapse-whitespace (file-name) + "Collapse multiple whitespace characters in FILE-NAME." + (while (string-match "\\s-\\s-+" file-name) + (setq file-name (replace-match " " t t file-name))) + file-name) + +(defun mm-file-name-replace-whitespace (file-name) + "Replace whitespace characters in FILE-NAME with underscores. +Set the option `mm-file-name-replace-whitespace' to any other +string if you do not like underscores." + (let ((s (or mm-file-name-replace-whitespace "_"))) + (while (string-match "\\s-" file-name) + (setq file-name (replace-match s t t file-name)))) + file-name) + +(defun mm-file-name-delete-control (filename) + "Delete control characters from FILENAME." + (gnus-replace-in-string filename "[\x00-\x1f\x7f]" "")) + +(defun mm-file-name-delete-gotchas (filename) + "Delete shell gotchas from FILENAME." + (setq filename (gnus-replace-in-string filename "[<>|]" "")) + (gnus-replace-in-string filename "^[.-]+" "")) (defun mm-save-part (handle) "Write HANDLE to a file." @@ -684,29 +1088,35 @@ (mm-handle-disposition handle) 'filename)) file) (when filename - (setq filename (file-name-nondirectory filename))) + (setq filename (gnus-map-function mm-file-name-rewrite-functions + (file-name-nondirectory filename)))) (setq file (read-file-name "Save MIME part to: " - (expand-file-name - (or filename name "") - (or mm-default-directory default-directory)))) + (or mm-default-directory default-directory) + nil nil (or filename name ""))) (setq mm-default-directory (file-name-directory file)) - (when (or (not (file-exists-p file)) - (yes-or-no-p (format "File %s already exists; overwrite? " - file))) - (mm-save-part-to-file handle file)))) + (and (or (not (file-exists-p file)) + (yes-or-no-p (format "File %s already exists; overwrite? " + file))) + (progn + (mm-save-part-to-file handle file) + file)))) (defun mm-save-part-to-file (handle file) (mm-with-unibyte-buffer (mm-insert-part handle) (let ((coding-system-for-write 'binary) + (current-file-modes (default-file-modes)) ;; Don't re-compress .gz & al. Arguably we should make ;; `file-name-handler-alist' nil, but that would chop ;; ange-ftp, which is reasonable to use here. (inhibit-file-name-operation 'write-region) (inhibit-file-name-handlers (cons 'jka-compr-handler inhibit-file-name-handlers))) - (write-region (point-min) (point-max) file)))) + (set-default-file-modes mm-attachment-file-modes) + (unwind-protect + (write-region (point-min) (point-max) file) + (set-default-file-modes current-file-modes))))) (defun mm-pipe-part (handle) "Pipe HANDLE to a process." @@ -715,7 +1125,8 @@ (read-string "Shell command on MIME part: " mm-last-shell-command))) (mm-with-unibyte-buffer (mm-insert-part handle) - (shell-command-on-region (point-min) (point-max) command nil)))) + (let ((coding-system-for-write 'binary)) + (shell-command-on-region (point-min) (point-max) command nil))))) (defun mm-interactively-view-part (handle) "Display HANDLE using METHOD." @@ -768,6 +1179,35 @@ "Return the handle(s) referred to by ID." (cdr (assoc id mm-content-id-alist))) +(defconst mm-image-type-regexps + '(("/\\*.*XPM.\\*/" . xpm) + ("P[1-6]" . pbm) + ("GIF8" . gif) + ("\377\330" . jpeg) + ("\211PNG\r\n" . png) + ("#define" . xbm) + ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff) + ("%!PS" . postscript)) + "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types. +When the first bytes of an image file match REGEXP, it is assumed to +be of image type IMAGE-TYPE.") + +;; Steal from image.el. image-type-from-data suffers multi-line matching bug. +(defun mm-image-type-from-buffer () + "Determine the image type from data in the current buffer. +Value is a symbol specifying the image type or nil if type cannot +be determined." + (let ((types mm-image-type-regexps) + type) + (goto-char (point-min)) + (while (and types (null type)) + (let ((regexp (car (car types))) + (image-type (cdr (car types)))) + (when (looking-at regexp) + (setq type image-type)) + (setq types (cdr types)))) + type)) + (defun mm-get-image (handle) "Return an image instance based on HANDLE." (let ((type (mm-handle-media-subtype handle)) @@ -788,31 +1228,40 @@ (prog1 (setq spec (ignore-errors - ;; Avoid testing `make-glyph' since W3 may define - ;; a bogus version of it. + ;; Avoid testing `make-glyph' since W3 may define + ;; a bogus version of it. (if (fboundp 'create-image) - (create-image (buffer-string) (intern type) 'data-p) - (cond - ((equal type "xbm") - ;; xbm images require special handling, since - ;; the only way to create glyphs from these - ;; (without a ton of work) is to write them - ;; out to a file, and then create a file - ;; specifier. - (let ((file (mm-make-temp-file - (expand-file-name "emm.xbm" - mm-tmp-directory)))) - (unwind-protect - (progn - (write-region (point-min) (point-max) file) - (make-glyph (list (cons 'x file)))) - (ignore-errors - (delete-file file))))) - (t - (make-glyph - (vector (intern type) :data (buffer-string)))))))) + (create-image (buffer-string) + (or (mm-image-type-from-buffer) + (intern type)) + 'data-p) + (mm-create-image-xemacs type)))) (mm-handle-set-cache handle spec)))))) +(defun mm-create-image-xemacs (type) + (cond + ((equal type "xbm") + ;; xbm images require special handling, since + ;; the only way to create glyphs from these + ;; (without a ton of work) is to write them + ;; out to a file, and then create a file + ;; specifier. + (let ((file (mm-make-temp-file + (expand-file-name "emm.xbm" + mm-tmp-directory)))) + (unwind-protect + (progn + (write-region (point-min) (point-max) file) + (make-glyph (list (cons 'x file)))) + (ignore-errors + (delete-file file))))) + (t + (make-glyph + (vector + (or (mm-image-type-from-buffer) + (intern type)) + :data (buffer-string)))))) + (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) @@ -848,6 +1297,182 @@ (and (mm-valid-image-format-p format) (mm-image-fit-p handle))) +(defun mm-find-part-by-type (handles type &optional notp recursive) + "Search in HANDLES for part with TYPE. +If NOTP, returns first non-matching part. +If RECURSIVE, search recursively." + (let (handle) + (while handles + (if (and recursive (stringp (caar handles))) + (if (setq handle (mm-find-part-by-type (cdar handles) type + notp recursive)) + (setq handles nil)) + (if (if notp + (not (equal (mm-handle-media-type (car handles)) type)) + (equal (mm-handle-media-type (car handles)) type)) + (setq handle (car handles) + handles nil))) + (setq handles (cdr handles))) + handle)) + +(defun mm-find-raw-part-by-type (ctl type &optional notp) + (goto-char (point-min)) + (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl + 'boundary))) + (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$")) + start + (end (save-excursion + (goto-char (point-max)) + (if (re-search-backward close-delimiter nil t) + (match-beginning 0) + (point-max)))) + result) + (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$")) + (while (and (not result) + (re-search-forward boundary end t)) + (goto-char (match-beginning 0)) + (when start + (save-excursion + (save-restriction + (narrow-to-region start (1- (point))) + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type + (mail-fetch-field "content-type"))))) + (if notp + (not (equal (car ctl) type)) + (equal (car ctl) type))) + (setq result (buffer-string)))))) + (forward-line 1) + (setq start (point))) + (when (and (not result) start) + (save-excursion + (save-restriction + (narrow-to-region start end) + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type + (mail-fetch-field "content-type"))))) + (if notp + (not (equal (car ctl) type)) + (equal (car ctl) type))) + (setq result (buffer-string)))))) + result)) + +(defvar mm-security-handle nil) + +(defsubst mm-set-handle-multipart-parameter (handle parameter value) + ;; HANDLE could be a CTL. + (when handle + (put-text-property 0 (length (car handle)) parameter value + (car handle)))) + +(defun mm-possibly-verify-or-decrypt (parts ctl) + (let ((type (car ctl)) + (subtype (cadr (split-string (car ctl) "/"))) + (mm-security-handle ctl) ;; (car CTL) is the type. + protocol func functest) + (cond + ((or (equal type "application/x-pkcs7-mime") + (equal type "application/pkcs7-mime")) + (with-temp-buffer + (when (and (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) t) + (t (y-or-n-p + (format "Decrypt (S/MIME) part? ")))) + (mm-view-pkcs7 parts)) + (setq parts (mm-dissect-buffer t))))) + ((equal subtype "signed") + (unless (and (setq protocol + (mm-handle-multipart-ctl-parameter ctl 'protocol)) + (not (equal protocol "multipart/mixed"))) + ;; The message is broken or draft-ietf-openpgp-multsig-01. + (let ((protocols mm-verify-function-alist)) + (while protocols + (if (and (or (not (setq functest (nth 3 (car protocols)))) + (funcall functest parts ctl)) + (mm-find-part-by-type parts (caar protocols) nil t)) + (setq protocol (caar protocols) + protocols nil) + (setq protocols (cdr protocols)))))) + (setq func (nth 1 (assoc protocol mm-verify-function-alist))) + (when (cond + ((eq mm-verify-option 'never) nil) + ((eq mm-verify-option 'always) t) + ((eq mm-verify-option 'known) + (and func + (or (not (setq functest + (nth 3 (assoc protocol + mm-verify-function-alist)))) + (funcall functest parts ctl)))) + (t + (y-or-n-p + (format "Verify signed (%s) part? " + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (format "protocol=%s" protocol)))))) + (save-excursion + (if func + (funcall func parts ctl) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown sign protocol (%s)" protocol)))))) + ((equal subtype "encrypted") + (unless (setq protocol + (mm-handle-multipart-ctl-parameter ctl 'protocol)) + ;; The message is broken. + (let ((parts parts)) + (while parts + (if (assoc (mm-handle-media-type (car parts)) + mm-decrypt-function-alist) + (setq protocol (mm-handle-media-type (car parts)) + parts nil) + (setq parts (cdr parts)))))) + (setq func (nth 1 (assoc protocol mm-decrypt-function-alist))) + (when (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) + (and func + (or (not (setq functest + (nth 3 (assoc protocol + mm-decrypt-function-alist)))) + (funcall functest parts ctl)))) + (t + (y-or-n-p + (format "Decrypt (%s) part? " + (or (nth 2 (assoc protocol mm-decrypt-function-alist)) + (format "protocol=%s" protocol)))))) + (save-excursion + (if func + (setq parts (funcall func parts ctl)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown encrypt protocol (%s)" protocol)))))) + (t nil)) + parts)) + +(defun mm-multiple-handles (handles) + (and (listp (car handles)) + (> (length handles) 1))) + +(defun mm-merge-handles (handles1 handles2) + (append + (if (listp (car handles1)) + handles1 + (list handles1)) + (if (listp (car handles2)) + handles2 + (list handles2)))) + +(defun mm-readable-p (handle) + "Say whether the content of HANDLE is readable." + (and (< (with-current-buffer (mm-handle-buffer handle) + (buffer-size)) 10000) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (and (eq (mm-body-7-or-8) '7bit) + (not (mm-long-lines-p 76)))))) + (provide 'mm-decode) ;;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b
--- a/lisp/gnus/mm-encode.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mm-encode.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ -;;; mm-encode.el --- functions for encoding MIME things -;; Copyright (C) 1998, 1999, 2000, 2002 Free Software Foundation, Inc. +;;; mm-encode.el --- Functions for encoding MIME things +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> @@ -28,9 +29,10 @@ (require 'mail-parse) (require 'mailcap) (eval-and-compile - (autoload 'mm-body-7-or-8 "mm-bodies")) + (autoload 'mm-body-7-or-8 "mm-bodies") + (autoload 'mm-long-lines-p "mm-bodies")) -(defvar mm-content-transfer-encoding-defaults +(defcustom mm-content-transfer-encoding-defaults '(("text/x-patch" 8bit) ("text/.*" qp-or-base64) ("message/rfc822" 8bit) @@ -40,7 +42,15 @@ (".*" base64)) "Alist of regexps that match MIME types and their encodings. If the encoding is `qp-or-base64', then either quoted-printable -or base64 will be used, depending on what is more efficient.") +or base64 will be used, depending on what is more efficient." + :type '(repeat (list (regexp :tag "MIME type") + (choice :tag "encoding" + (const 7bit) + (const 8bit) + (const qp-or-base64) + (const quoted-printable) + (const base64)))) + :group 'mime) (defvar mm-use-ultra-safe-encoding nil "If non-nil, use encodings aimed at Procrustean bed survival. @@ -76,7 +86,7 @@ (mailcap-extension-to-mime (match-string 0 file)))) (defun mm-safer-encoding (encoding) - "Return a safer but similar encoding." + "Return an encoding similar to ENCODING but safer than it." (cond ((memq encoding '(7bit 8bit quoted-printable)) 'quoted-printable) ;; The remaining encodings are binary and base64 (and perhaps some @@ -84,32 +94,38 @@ (t 'base64))) (defun mm-encode-content-transfer-encoding (encoding &optional type) + "Encode the current buffer with ENCODING for MIME type TYPE. +ENCODING can be: nil (do nothing); one of `quoted-printable', `base64'; +`7bit', `8bit' or `binary' (all do nothing); a function to do the encoding." (cond ((eq encoding 'quoted-printable) + ;; This used to try to make a multibyte buffer unibyte. That's + ;; completely wrong, since you'd get QP-encoded emacs-mule. If + ;; this gets run on multibyte text it's an error that needs + ;; fixing, and the encoding function will signal an error. + ;; Likewise base64 below. (quoted-printable-encode-region (point-min) (point-max) t)) ((eq encoding 'base64) (when (equal type "text/plain") (goto-char (point-min)) (while (search-forward "\n" nil t) (replace-match "\r\n" t t))) - (condition-case error - (base64-encode-region (point-min) (point-max)) - (error - (message "Error while decoding: %s" error) - nil))) + (base64-encode-region (point-min) (point-max))) ((memq encoding '(7bit 8bit binary)) ;; Do nothing. ) ((null encoding) ;; Do nothing. ) + ;; Fixme: Ignoring errors here looks bogus. ((functionp encoding) (ignore-errors (funcall encoding (point-min) (point-max)))) (t - (message "Unknown encoding %s; defaulting to 8bit" encoding)))) + (error "Unknown encoding %s" encoding)))) (defun mm-encode-buffer (type) - "Encode the buffer which contains data of TYPE. + "Encode the buffer which contains data of MIME type TYPE. +TYPE is a string or a list of the components. The encoding used is returned." (let* ((mime-type (if (stringp type) type (car type))) (encoding @@ -119,7 +135,8 @@ (bits (mm-body-7-or-8))) ;; We force buffers that are 7bit to be unencoded, no matter ;; what the preferred encoding is. - (when (eq bits '7bit) + ;; Only if the buffers don't contain lone lines. + (when (and (eq bits '7bit) (not (mm-long-lines-p 76))) (setq encoding bits)) (mm-encode-content-transfer-encoding encoding mime-type) encoding)) @@ -154,21 +171,26 @@ (pop rules))))) (defun mm-qp-or-base64 () - (save-excursion - (let ((limit (min (point-max) (+ 2000 (point-min)))) - (n8bit 0)) - (goto-char (point-min)) - (skip-chars-forward "\x20-\x7f\r\n\t" limit) - (while (< (point) limit) - (incf n8bit) - (forward-char 1) - (skip-chars-forward "\x20-\x7f\r\n\t" limit)) - (if (or (< (* 6 n8bit) (- limit (point-min))) - ;; Don't base64, say, a short line with a single - ;; non-ASCII char when splitting parts by charset. - (= n8bit 1)) - 'quoted-printable - 'base64)))) + "Return the type with which to encode the buffer. +This is either `base64' or `quoted-printable'." + (if (equal mm-use-ultra-safe-encoding '(sign . "pgp")) + ;; perhaps not always accurate? + 'quoted-printable + (save-excursion + (let ((limit (min (point-max) (+ 2000 (point-min)))) + (n8bit 0)) + (goto-char (point-min)) + (skip-chars-forward "\x20-\x7f\r\n\t" limit) + (while (< (point) limit) + (incf n8bit) + (forward-char 1) + (skip-chars-forward "\x20-\x7f\r\n\t" limit)) + (if (or (< (* 6 n8bit) (- limit (point-min))) + ;; Don't base64, say, a short line with a single + ;; non-ASCII char when splitting parts by charset. + (= n8bit 1)) + 'quoted-printable + 'base64))))) (provide 'mm-encode)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/mm-extern.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,169 @@ +;;; 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) + (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 + (mm-url-insert-file-contents url)) + (mm-disable-multibyte) + (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) + (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) + +;;; arch-tag: 9653808e-14d9-4172-86e6-adceaa05378e +;;; mm-extern.el ends here
--- a/lisp/gnus/mm-partial.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mm-partial.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; mm-partial.el --- showing message/partial -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> ;; Keywords: message partial @@ -25,8 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl)) (require 'gnus-sum) (require 'mm-util) @@ -43,7 +42,8 @@ (gnus-request-article-this-buffer (aref header 0) gnus-newsgroup-name) (when (search-forward id nil t) - (let ((nhandles (mm-dissect-buffer)) nid) + (let ((nhandles (mm-dissect-buffer + nil gnus-article-loose-mime)) nid) (if (consp (car nhandles)) (mm-destroy-parts nhandles) (setq nid (cdr (assq 'id @@ -83,10 +83,7 @@ (cdr (mm-handle-type b))))))) (< anumber bnumber))))) (setq gnus-article-mime-handles - (append (if (listp (car gnus-article-mime-handles)) - gnus-article-mime-handles - (list gnus-article-mime-handles)) - phandles)) + (mm-merge-handles gnus-article-mime-handles phandles)) (save-excursion (set-buffer (generate-new-buffer " *mm*")) (while (setq phandle (pop phandles)) @@ -117,6 +114,13 @@ (if (<= n total) (error "Missing part %d" n)) (kill-buffer (mm-handle-buffer handle)) + (goto-char (point-min)) + (let ((point (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max)))) + (goto-char (point-min)) + (unless (re-search-forward "^mime-version:" point t) + (insert "MIME-Version: 1.0\n"))) (setcar handle (current-buffer)) (mm-handle-set-cache handle t))) (unless no-display @@ -131,11 +135,7 @@ (when handles ;; It is in article buffer. (setq gnus-article-mime-handles - (nconc (if (listp (car gnus-article-mime-handles)) - gnus-article-mime-handles - (list gnus-article-mime-handles)) - (if (listp (car handles)) - handles (list handles))))) + (mm-merge-handles gnus-article-mime-handles handles))) (mm-handle-set-undisplayer handle `(lambda () @@ -149,5 +149,7 @@ (error nil)) (delete-region ,(point-min-marker) ,(point-max-marker)))))))))) +(provide 'mm-partial) + ;;; arch-tag: 460e7424-05f2-4a1d-a0f2-70ec081eff7d ;;; mm-partial.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/mm-url.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,450 @@ +;;; 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 'executable-find "executable")) + +(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" "--user-agent=mm-url" "-q" "-O" "-") + (w3m "w3m" "-dump_source") + (lynx "lynx" "-source") + (curl "curl"))) + +(defcustom mm-url-program + (cond + ((executable-find "wget") 'wget) + ((executable-find "w3m") 'w3m) + ((executable-find "lynx") 'lynx) + ((executable-find "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) + + +;;; 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))) + +;;;###autoload +(defun mm-url-insert-file-contents (url) + "Insert file contents of URL. +If `mm-url-use-external' is non-nil, use `mm-url-program'." + (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))) + +;;;###autoload +(defun mm-url-insert-file-contents-external (url) + "Insert file contents of URL using `mm-url-program'." + (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)))) + (unless (eq 0 (apply 'call-process program nil t nil args)) + (error "Couldn't fetch %s" url)))) + +(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)) + 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) + +;;; arch-tag: 0594f9b3-417c-48b0-adc2-5082e1e7917f +;;; mm-url.el ends here
--- a/lisp/gnus/mm-util.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mm-util.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; mm-util.el --- Utility functions for Mule and low level things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> @@ -24,9 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl) - (defvar mm-mime-mule-charset-alist)) +(eval-when-compile (require 'cl)) (require 'mail-prsvr) (eval-and-compile @@ -42,7 +41,6 @@ (coding-system-list . ignore) (decode-coding-region . ignore) (char-int . identity) - (device-type . ignore) (coding-system-equal . equal) (annotationp . ignore) (set-buffer-file-coding-system . ignore) @@ -71,10 +69,19 @@ (setq idx (1+ idx))) string))) (string-as-unibyte . identity) + (string-make-unibyte . identity) (string-as-multibyte . identity) (multibyte-string-p . ignore) - (point-at-bol . line-beginning-position) - (point-at-eol . line-end-position) + ;; It is not a MIME function, but some MIME functions use it. + (make-temp-file . (lambda (prefix &optional dir-flag) + (let ((file (expand-file-name + (make-temp-name prefix) + (if (fboundp 'temp-directory) + (temp-directory) + temporary-file-directory)))) + (if dir-flag + (make-directory file)) + file))) (insert-byte . insert-char) (multibyte-char-to-unibyte . identity)))) @@ -85,6 +92,14 @@ ((fboundp 'char-valid-p) 'char-valid-p) (t 'identity)))) +;; Fixme: This seems always to be used to read a MIME charset, so it +;; should be re-named and fixed (in Emacs) to offer completion only on +;; proper charset names (base coding systems which have a +;; mime-charset defined). XEmacs doesn't believe in mime-charset; +;; test with +;; `(or (coding-system-get 'iso-8859-1 'mime-charset) +;; (coding-system-get 'iso-8859-1 :mime-charset))' +;; Actually, there should be an `mm-coding-system-mime-charset'. (eval-and-compile (defalias 'mm-read-coding-system (cond @@ -106,10 +121,15 @@ (or mm-coding-system-list (setq mm-coding-system-list (mm-coding-system-list)))) -(defun mm-coding-system-p (sym) - "Return non-nil if SYM is a coding system." - (or (and (fboundp 'coding-system-p) (coding-system-p sym)) - (memq sym (mm-get-coding-system-list)))) +(defun mm-coding-system-p (cs) + "Return non-nil if CS is a symbol naming a coding system. +In XEmacs, also return non-nil if CS is a coding system object." + (if (fboundp 'find-coding-system) + (find-coding-system cs) + (if (fboundp 'coding-system-p) + (coding-system-p cs) + ;; Is this branch ever actually useful? + (memq cs (mm-get-coding-system-list))))) (defvar mm-charset-synonym-alist `( @@ -122,10 +142,12 @@ ;; Apparently not defined in Emacs 20, but is a valid MIME name. ,@(unless (mm-coding-system-p 'gb2312) '((gb2312 . cn-gb-2312))) - ;; ISO-8859-15 is very similar to ISO-8859-1. - ;; But this is just wrong. --fx - ,@(unless (mm-coding-system-p 'iso-8859-15) ; Emacs 21 defines it. + ;; ISO-8859-15 is very similar to ISO-8859-1. But it's _different_! + ,@(unless (mm-coding-system-p 'iso-8859-15) '((iso-8859-15 . iso-8859-1))) + ;; BIG-5HKSCS is similar to, but different than, BIG-5. + ,@(unless (mm-coding-system-p 'big5-hkscs) + '((big5-hkscs . big5))) ;; Windows-1252 is actually a superset of Latin-1. See also ;; `gnus-article-dumbquotes-map'. ,@(unless (mm-coding-system-p 'windows-1252) @@ -135,10 +157,6 @@ ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft ;; Outlook users in Czech republic. Use this to allow reading of their ;; e-mails. cp1250 should be defined by M-x codepage-setup. - - ;; This is not TRT, the MIME name, windows-1250, should be an - ;; alias, and cp1250 should have a mime-charset property, per - ;; code-page.el. -- fx ,@(if (and (not (mm-coding-system-p 'windows-1250)) (mm-coding-system-p 'cp1250)) '((windows-1250 . cp1250))) @@ -164,7 +182,7 @@ (defvar mm-auto-save-coding-system (cond - ((mm-coding-system-p 'utf-8-emacs) + ((mm-coding-system-p 'utf-8-emacs) ; Mule 7 (if (memq system-type '(windows-nt ms-dos ms-windows)) (if (mm-coding-system-p 'utf-8-emacs-dos) 'utf-8-emacs-dos mm-binary-coding-system) @@ -286,23 +304,29 @@ mm-iso-8859-15-compatible)) "A table of the difference character between ISO-8859-X and ISO-8859-15.") -(defvar mm-coding-system-priorities nil - "Preferred coding systems for encoding outgoing mails. +(defcustom mm-coding-system-priorities + (if (boundp 'current-language-environment) + (let ((lang (symbol-value 'current-language-environment))) + (cond ((string= lang "Japanese") + ;; Japanese users may prefer iso-2022-jp to shift-jis. + '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis + iso-latin-1 utf-8))))) + "Preferred coding systems for encoding outgoing messages. -More than one suitable coding systems may be found for some texts. By -default, a coding system with the highest priority is used to encode -outgoing mails (see `sort-coding-systems'). If this variable is set, -it overrides the default priority. For example, Japanese users may -prefer iso-2022-jp to japanese-shift-jis: +More than one suitable coding system may be found for some text. +By default, the coding system with the highest priority is used +to encode outgoing messages (see `sort-coding-systems'). If this +variable is set, it overrides the default priority." + :type '(repeat (symbol :tag "Coding system")) + :group 'mime) -\(setq mm-coding-system-priorities - '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis utf-8)) -") - -;; Why on earth was this broken out? -- fx +;; ?? (defvar mm-use-find-coding-systems-region (fboundp 'find-coding-systems-region) - "Use `find-coding-systems-region' to find proper coding systems.") + "Use `find-coding-systems-region' to find proper coding systems. + +Setting it to nil is useful on Emacsen supporting Unicode if sending +mail with multiple parts is preferred to sending a Unicode one.") ;;; Internal variables: @@ -310,9 +334,12 @@ (defun mm-mule-charset-to-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." - (if (fboundp 'find-coding-systems-for-charsets) + (if (and (fboundp 'find-coding-systems-for-charsets) + (fboundp 'sort-coding-systems)) (let (mime) - (dolist (cs (find-coding-systems-for-charsets (list charset))) + (dolist (cs (sort-coding-systems + (copy-sequence + (find-coding-systems-for-charsets (list charset))))) (unless mime (when cs (setq mime (or (coding-system-get cs :mime-charset) @@ -340,7 +367,8 @@ ((null charset) charset) ;; Running in a non-MULE environment. - ((null (mm-get-coding-system-list)) + ((or (null (mm-get-coding-system-list)) + (not (fboundp 'coding-system-get))) charset) ;; ascii ((eq charset 'us-ascii) @@ -356,7 +384,7 @@ charset) ;; Translate invalid charsets. ((let ((cs (cdr (assq charset mm-charset-synonym-alist)))) - (and cs (mm-coding-system-p charset) cs))) + (and cs (mm-coding-system-p cs) cs))) ;; Last resort: search the coding system list for entries which ;; have the right mime-charset in case the canonical name isn't ;; defined (though it should be). @@ -385,7 +413,7 @@ "Set the multibyte flag of the current buffer. Only do this if the default value of `enable-multibyte-characters' is non-nil. This is a no-op in XEmacs." - (set-buffer-multibyte t)) + (set-buffer-multibyte 'to)) (defalias 'mm-enable-multibyte 'ignore)) (if mm-emacs-mule @@ -400,6 +428,27 @@ (or (get-charset-property charset 'preferred-coding-system) (get-charset-property charset 'prefered-coding-system))) +;; Mule charsets shouldn't be used. +(defsubst mm-guess-charset () + "Guess Mule charset from the language environment." + (or + mail-parse-mule-charset ;; cached mule-charset + (progn + (setq mail-parse-mule-charset + (and (boundp 'current-language-environment) + (car (last + (assq 'charset + (assoc current-language-environment + language-info-alist)))))) + (if (or (not mail-parse-mule-charset) + (eq mail-parse-mule-charset 'ascii)) + (setq mail-parse-mule-charset + (or (car (last (assq mail-parse-charset + mm-mime-mule-charset-alist))) + ;; default + 'latin-iso8859-1))) + mail-parse-mule-charset))) + (defun mm-charset-after (&optional pos) "Return charset of a character in current buffer at position POS. If POS is nil, it defauls to the current point. @@ -416,23 +465,7 @@ (if (and charset (not (memq charset '(ascii eight-bit-control eight-bit-graphic)))) charset - (or - mail-parse-mule-charset ;; cached mule-charset - (progn - (setq mail-parse-mule-charset - (and (boundp 'current-language-environment) - (car (last - (assq 'charset - (assoc current-language-environment - language-info-alist)))))) - (if (or (not mail-parse-mule-charset) - (eq mail-parse-mule-charset 'ascii)) - (setq mail-parse-mule-charset - (or (car (last (assq mail-parse-charset - mm-mime-mule-charset-alist))) - ;; Fixme: don't fix that! - 'latin-iso8859-1))) - mail-parse-mule-charset))))))) + (mm-guess-charset)))))) (defun mm-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." @@ -462,14 +495,23 @@ (setq result (cons head result))) (nreverse result))) -;; It's not clear whether this is supposed to mean the global or local -;; setting. I think it's used inconsistently. -- fx -(defsubst mm-multibyte-p () - "Say whether multibyte is enabled." +;; Fixme: This is used in places when it should be testing the +;; default multibyteness. See mm-default-multibyte-p. +(eval-and-compile (if (and (not (featurep 'xemacs)) (boundp 'enable-multibyte-characters)) - enable-multibyte-characters - (featurep 'mule))) + (defun mm-multibyte-p () + "Non-nil if multibyte is enabled in the current buffer." + enable-multibyte-characters) + (defun mm-multibyte-p () (featurep 'mule)))) + +(defun mm-default-multibyte-p () + "Return non-nil if the session is multibyte. +This affects whether coding conversion should be attempted generally." + (if (featurep 'mule) + (if (boundp 'default-enable-multibyte-characters) + default-enable-multibyte-characters + t))) (defun mm-iso-8859-x-to-15-region (&optional b e) (if (fboundp 'char-charset) @@ -487,13 +529,20 @@ (setq inconvertible t) (forward-char)) (t - (insert (prog1 (+ c (car (cdr item))) (delete-char 1)))) - (skip-chars-forward "\0-\177")))) + (insert-before-markers (prog1 (+ c (car (cdr item))) + (delete-char 1))))) + (skip-chars-forward "\0-\177"))) (not inconvertible)))) (defun mm-sort-coding-systems-predicate (a b) - (> (length (memq a mm-coding-system-priorities)) - (length (memq b mm-coding-system-priorities)))) + (let ((priorities + (mapcar (lambda (cs) + ;; Note: invalid entries are dropped silently + (and (coding-system-p cs) + (coding-system-base cs))) + mm-coding-system-priorities))) + (> (length (memq a priorities)) + (length (memq b priorities))))) (defun mm-find-mime-charset-region (b e &optional hack-charsets) "Return the MIME charsets needed to encode the region between B and E. @@ -509,26 +558,42 @@ (when mm-coding-system-priorities (setq systems (sort systems 'mm-sort-coding-systems-predicate))) - ;; Fixme: The `mime-charset' (`x-ctext') of `compound-text' - ;; is not in the IANA list. (setq systems (delq 'compound-text systems)) (unless (equal systems '(undecided)) (while systems (let* ((head (pop systems)) (cs (or (coding-system-get head :mime-charset) (coding-system-get head 'mime-charset)))) - (if cs + ;; The mime-charset (`x-ctext') of + ;; `compound-text' is not in the IANA list. We + ;; shouldn't normally use anything here with a + ;; mime-charset having an `x-' prefix. + ;; Fixme: Allow this to be overridden, since + ;; there is existing use of x-ctext. + ;; Also people apparently need the coding system + ;; `iso-2022-jp-3' (which Mule-UCS defines with + ;; mime-charset, though it's not valid). + (if (and cs + (not (string-match "^[Xx]-" (symbol-name cs))) + ;; UTF-16 of any variety is invalid for + ;; text parts and, unfortunately, has + ;; mime-charset defined both in Mule-UCS + ;; and versions of Emacs. (The name + ;; might be `mule-utf-16...' or + ;; `utf-16...'.) + (not (string-match "utf-16" (symbol-name cs)))) (setq systems nil charsets (list cs)))))) charsets)) - ;; Otherwise we're not multibyte, XEmacs or a single coding - ;; system won't cover it. + ;; Otherwise we're not multibyte, we're XEmacs, or a single + ;; coding system won't cover it. (setq charsets (mm-delete-duplicates (mapcar 'mm-mime-charset (delq 'ascii (mm-find-charset-region b e)))))) - (if (and (memq 'iso-8859-15 charsets) + (if (and (> (length charsets) 1) + (memq 'iso-8859-15 charsets) (memq 'iso-8859-15 hack-charsets) (save-excursion (mm-iso-8859-x-to-15-region b e))) (mapcar (lambda (x) (setq charsets (delq (car x) charsets))) @@ -638,10 +703,10 @@ (defun mm-insert-file-contents (filename &optional visit beg end replace inhibit) - "Like `insert-file-contents', q.v., but only reads in the file. + "Like `insert-file-contents', but only reads in the file. A buffer may be modified in several ways after reading into the buffer due to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. +`find-file-hooks', etc. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'. This function ensures that none of these modifications will take place." (let ((format-alist nil) @@ -668,7 +733,7 @@ saying what text to write. Optional fourth argument specifies the coding system to use when encoding the file. -If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers." +If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (let ((coding-system-for-write (or codesys mm-text-coding-system-for-write mm-text-coding-system)) @@ -680,13 +745,14 @@ (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers))) - (append-to-file start end filename))) + (write-region start end filename t 'no-message) + (message "Appended to %s" filename))) (defun mm-write-region (start end filename &optional append visit lockname coding-system inhibit) "Like `write-region'. -If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers." +If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (let ((coding-system-for-write (or coding-system mm-text-coding-system-for-write mm-text-coding-system)) @@ -710,19 +776,32 @@ (push dir result)) (push path result)))) -;; It is not a MIME function, but some MIME functions use it. -(defalias 'mm-make-temp-file - (if (fboundp 'make-temp-file) - 'make-temp-file - (lambda (prefix &optional dir-flag) - (let ((file (expand-file-name - (make-temp-name prefix) - (if (fboundp 'temp-directory) - (temp-directory) - temporary-file-directory)))) - (if dir-flag - (make-directory file)) - file)))) +;; Fixme: This doesn't look useful where it's used. +(if (fboundp 'detect-coding-region) + (defun mm-detect-coding-region (start end) + "Like `detect-coding-region' except returning the best one." + (let ((coding-systems + (detect-coding-region (point) (point-max)))) + (or (car-safe coding-systems) + coding-systems))) + (defun mm-detect-coding-region (start end) + (let ((point (point))) + (goto-char start) + (skip-chars-forward "\0-\177" end) + (prog1 + (if (eq (point) end) 'ascii (mm-guess-charset)) + (goto-char point))))) + +(if (fboundp 'coding-system-get) + (defun mm-detect-mime-charset-region (start end) + "Detect MIME charset of the text in the region between START and END." + (let ((cs (mm-detect-coding-region start end))) + (coding-system-get cs 'mime-charset))) + (defun mm-detect-mime-charset-region (start end) + "Detect MIME charset of the text in the region between START and END." + (let ((cs (mm-detect-coding-region start end))) + cs))) + (provide 'mm-util)
--- a/lisp/gnus/mm-uu.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mm-uu.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,8 +1,8 @@ -;;; mm-uu.el --- return uu stuff as mm handles -;; Copyright (c) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +;;; mm-uu.el --- Return uu stuff as mm handles +;; Copyright (c) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> -;; Keywords: postscript uudecode binhex shar forward news +;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp ;; This file is part of GNU Emacs. @@ -30,194 +30,462 @@ (require 'nnheader) (require 'mm-decode) (require 'mailcap) -(require 'uudecode) -(require 'binhex) +(require 'mml2015) -(defun mm-uu-copy-to-buffer (from to) - "Copy the contents of the current buffer to a fresh buffer. -Return that buffer." - (save-excursion - (let ((obuf (current-buffer))) - (set-buffer (generate-new-buffer " *mm-uu*")) - (insert-buffer-substring obuf from to) - (current-buffer)))) +(autoload 'uudecode-decode-region "uudecode") +(autoload 'uudecode-decode-region-external "uudecode") +(autoload 'uudecode-decode-region-internal "uudecode") -;;; postscript - -(defconst mm-uu-postscript-begin-line "^%!PS-") -(defconst mm-uu-postscript-end-line "^%%EOF$") +(autoload 'binhex-decode-region "binhex") +(autoload 'binhex-decode-region-external "binhex") +(autoload 'binhex-decode-region-internal "binhex") -(defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+") -(defconst mm-uu-uu-end-line "^end[ \t]*$") +(autoload 'yenc-decode-region "yenc") +(autoload 'yenc-extract-filename "yenc") -;; This is not the right place for this. uudecode.el should decide -;; whether or not to use a program with a single interface, but I -;; guess it's too late now. Also the default should depend on a test -;; for the program. -- fx (defcustom mm-uu-decode-function 'uudecode-decode-region "*Function to uudecode. Internal function is done in Lisp by default, therefore decoding may appear to be horribly slow. You can make Gnus use an external decoder, such as uudecode." :type '(choice - (function-item :tag "Internal" uudecode-decode-region) + (function-item :tag "Auto detect" uudecode-decode-region) + (function-item :tag "Internal" uudecode-decode-region-internal) (function-item :tag "External" uudecode-decode-region-external)) :group 'gnus-article-mime) -(defconst mm-uu-binhex-begin-line - "^:...............................................................$") -(defconst mm-uu-binhex-end-line ":$") - (defcustom mm-uu-binhex-decode-function 'binhex-decode-region "*Function to binhex decode. -Internal function is done in Lisp by default, therefore decoding may -appear to be horribly slow. You can make Gnus use an external +Internal function is done in elisp by default, therefore decoding may +appear to be horribly slow . You can make Gnus use the external Unix decoder, such as hexbin." - :type '(choice - (function-item :tag "Internal" binhex-decode-region) - (function-item :tag "External" binhex-decode-region-external)) + :type '(choice (function-item :tag "Auto detect" binhex-decode-region) + (function-item :tag "Internal" binhex-decode-region-internal) + (function-item :tag "External" binhex-decode-region-external)) :group 'gnus-article-mime) -(defconst mm-uu-shar-begin-line "^#! */bin/sh") -(defconst mm-uu-shar-end-line "^exit 0\\|^$") +(defvar mm-uu-yenc-decode-function 'yenc-decode-region) -;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and -;;; Peter von der Ah\'e <pahe@daimi.au.dk> -(defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message") -(defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message") +(defvar mm-uu-pgp-beginning-signature + "^-----BEGIN PGP SIGNATURE-----") -(defvar mm-uu-begin-line nil) - -(defconst mm-uu-identifier-alist - '((?% . postscript) (?b . uu) (?: . binhex) (?# . shar) - (?- . forward))) +(defvar mm-uu-beginning-regexp nil) (defvar mm-dissect-disposition "inline" "The default disposition of uu parts. This can be either \"inline\" or \"attachment\".") +(defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources" + "The regexp of Emacs sources groups.") + +(defcustom mm-uu-diff-groups-regexp "gnus\\.commits" + "*Regexp matching diff groups." + :type 'regexp + :group 'gnus-article-mime) + +(defvar mm-uu-type-alist + '((postscript + "^%!PS-" + "^%%EOF$" + mm-uu-postscript-extract + nil) + (uu + "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+" + "^end[ \t]*$" + mm-uu-uu-extract + mm-uu-uu-filename) + (binhex + "^:...............................................................$" + ":$" + mm-uu-binhex-extract + nil + mm-uu-binhex-filename) + (yenc + "^=ybegin.*size=[0-9]+.*name=.*$" + "^=yend.*size=[0-9]+" + mm-uu-yenc-extract + mm-uu-yenc-filename) + (shar + "^#! */bin/sh" + "^exit 0$" + mm-uu-shar-extract) + (forward +;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and +;;; Peter von der Ah\'e <pahe@daimi.au.dk> + "^-+ \\(Start of \\)?Forwarded message" + "^-+ End \\(of \\)?forwarded message" + mm-uu-forward-extract + nil + mm-uu-forward-test) + (gnatsweb + "^----gnatsweb-attachment----" + nil + mm-uu-gnatsweb-extract) + (pgp-signed + "^-----BEGIN PGP SIGNED MESSAGE-----" + "^-----END PGP SIGNATURE-----" + mm-uu-pgp-signed-extract + nil + nil) + (pgp-encrypted + "^-----BEGIN PGP MESSAGE-----" + "^-----END PGP MESSAGE-----" + mm-uu-pgp-encrypted-extract + nil + nil) + (pgp-key + "^-----BEGIN PGP PUBLIC KEY BLOCK-----" + "^-----END PGP PUBLIC KEY BLOCK-----" + mm-uu-pgp-key-extract + mm-uu-gpg-key-skip-to-last + nil) + (emacs-sources + "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--" + "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here" + mm-uu-emacs-sources-extract + nil + mm-uu-emacs-sources-test) + (diff + "^Index: " + nil + mm-uu-diff-extract + nil + mm-uu-diff-test))) + +(defcustom mm-uu-configure-list '((shar . disabled)) + "A list of mm-uu configuration. +To disable dissecting shar codes, for instance, add +`(shar . disabled)' to this list." + :type 'alist + :options (mapcar (lambda (entry) + (list (car entry) '(const disabled))) + mm-uu-type-alist) + :group 'gnus-article-mime) + +;; functions + +(defsubst mm-uu-type (entry) + (car entry)) + +(defsubst mm-uu-beginning-regexp (entry) + (nth 1 entry)) + +(defsubst mm-uu-end-regexp (entry) + (nth 2 entry)) + +(defsubst mm-uu-function-extract (entry) + (nth 3 entry)) + +(defsubst mm-uu-function-1 (entry) + (nth 4 entry)) + +(defsubst mm-uu-function-2 (entry) + (nth 5 entry)) + +(defun mm-uu-copy-to-buffer (&optional from to) + "Copy the contents of the current buffer to a fresh buffer. +Return that buffer." + (save-excursion + (let ((obuf (current-buffer)) + (coding-system + ;; Might not exist in non-MULE XEmacs + (when (boundp 'buffer-file-coding-system) + buffer-file-coding-system))) + (set-buffer (generate-new-buffer " *mm-uu*")) + (setq buffer-file-coding-system coding-system) + (insert-buffer-substring obuf from to) + (current-buffer)))) + (defun mm-uu-configure-p (key val) (member (cons key val) mm-uu-configure-list)) (defun mm-uu-configure (&optional symbol value) (if symbol (set-default symbol value)) - (setq mm-uu-begin-line nil) - (mapcar (lambda (type) - (if (mm-uu-configure-p type 'disabled) - nil - (setq mm-uu-begin-line - (concat mm-uu-begin-line - (if mm-uu-begin-line "\\|") - (symbol-value - (intern (concat "mm-uu-" (symbol-name type) - "-begin-line"))))))) - '(uu postscript binhex shar forward))) - -;; Needs to come after mm-uu-configure. -(defcustom mm-uu-configure-list nil - "Alist of mm-uu configurations to disable. -To disable dissecting shar codes, for instance, add -`(shar . disabled)' to this list." - :type '(repeat (choice (const :tag "postscript" (postscript . disabled)) - (const :tag "uu" (uu . disabled)) - (const :tag "binhex" (binhex . disabled)) - (const :tag "shar" (shar . disabled)) - (const :tag "forward" (forward . disabled)))) - :group 'gnus-article-mime - :set 'mm-uu-configure) + (setq mm-uu-beginning-regexp nil) + (mapcar (lambda (entry) + (if (mm-uu-configure-p (mm-uu-type entry) 'disabled) + nil + (setq mm-uu-beginning-regexp + (concat mm-uu-beginning-regexp + (if mm-uu-beginning-regexp "\\|") + (mm-uu-beginning-regexp entry))))) + mm-uu-type-alist)) (mm-uu-configure) +(eval-when-compile + (defvar file-name) + (defvar start-point) + (defvar end-point) + (defvar entry)) + +(defun mm-uu-uu-filename () + (if (looking-at ".+") + (setq file-name + (let ((nnheader-file-name-translation-alist + '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_)))) + (nnheader-translate-file-chars (match-string 0)))))) + +(defun mm-uu-binhex-filename () + (setq file-name + (ignore-errors + (binhex-decode-region start-point end-point t)))) + +(defun mm-uu-yenc-filename () + (goto-char start-point) + (setq file-name + (ignore-errors + (yenc-extract-filename)))) + +(defun mm-uu-forward-test () + (save-excursion + (goto-char start-point) + (forward-line) + (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) + +(defun mm-uu-postscript-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + '("application/postscript"))) + +(defun mm-uu-emacs-sources-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + '("application/emacs-lisp") + nil nil + (list mm-dissect-disposition + (cons 'filename file-name)))) + +(eval-when-compile + (defvar gnus-newsgroup-name)) + +(defun mm-uu-emacs-sources-test () + (setq file-name (match-string 1)) + (and gnus-newsgroup-name + mm-uu-emacs-sources-regexp + (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name))) + +(defun mm-uu-diff-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + '("text/x-patch"))) + +(defun mm-uu-diff-test () + (and gnus-newsgroup-name + mm-uu-diff-groups-regexp + (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name))) + +(defun mm-uu-forward-extract () + (mm-make-handle (mm-uu-copy-to-buffer + (progn (goto-char start-point) (forward-line) (point)) + (progn (goto-char end-point) (forward-line -1) (point))) + '("message/rfc822" (charset . gnus-decoded)))) + +(defun mm-uu-uu-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + (list (or (and file-name + (string-match "\\.[^\\.]+$" + file-name) + (mailcap-extension-to-mime + (match-string 0 file-name))) + "application/octet-stream")) + 'x-uuencode nil + (if (and file-name (not (equal file-name ""))) + (list mm-dissect-disposition + (cons 'filename file-name))))) + +(defun mm-uu-binhex-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + (list (or (and file-name + (string-match "\\.[^\\.]+$" file-name) + (mailcap-extension-to-mime + (match-string 0 file-name))) + "application/octet-stream")) + 'x-binhex nil + (if (and file-name (not (equal file-name ""))) + (list mm-dissect-disposition + (cons 'filename file-name))))) + +(defun mm-uu-yenc-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + (list (or (and file-name + (string-match "\\.[^\\.]+$" file-name) + (mailcap-extension-to-mime + (match-string 0 file-name))) + "application/octet-stream")) + 'x-yenc nil + (if (and file-name (not (equal file-name ""))) + (list mm-dissect-disposition + (cons 'filename file-name))))) + + +(defun mm-uu-shar-extract () + (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + '("application/x-shar"))) + +(defun mm-uu-gnatsweb-extract () + (save-restriction + (goto-char start-point) + (forward-line) + (narrow-to-region (point) end-point) + (mm-dissect-buffer t))) + +(defun mm-uu-pgp-signed-test (&rest rest) + (and + mml2015-use + (mml2015-clear-verify-function) + (cond + ((eq mm-verify-option 'never) nil) + ((eq mm-verify-option 'always) t) + ((eq mm-verify-option 'known) t) + (t (y-or-n-p "Verify pgp signed part? "))))) + +(eval-when-compile + (defvar gnus-newsgroup-charset)) + +(defun mm-uu-pgp-signed-extract-1 (handles ctl) + (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))) + (with-current-buffer buf + (if (mm-uu-pgp-signed-test) + (progn + (mml2015-clean-buffer) + (let ((coding-system-for-write (or gnus-newsgroup-charset + 'iso-8859-1))) + (funcall (mml2015-clear-verify-function)))) + (when (and mml2015-use (null (mml2015-clear-verify-function))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Clear verification not supported by `%s'.\n" mml2015-use)))) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (delete-region (point-min) (point))) + (if (re-search-forward mm-uu-pgp-beginning-signature nil t) + (delete-region (match-beginning 0) (point-max))) + (goto-char (point-min)) + (while (re-search-forward "^- " nil t) + (replace-match "" t t) + (forward-line 1))) + (list (mm-make-handle buf '("text/plain" (charset . gnus-decoded)))))) + +(defun mm-uu-pgp-signed-extract () + (let ((mm-security-handle (list (format "multipart/signed")))) + (mm-set-handle-multipart-parameter + mm-security-handle 'protocol "application/x-gnus-pgp-signature") + (save-restriction + (narrow-to-region start-point end-point) + (add-text-properties 0 (length (car mm-security-handle)) + (list 'buffer (mm-uu-copy-to-buffer)) + (car mm-security-handle)) + (setcdr mm-security-handle + (mm-uu-pgp-signed-extract-1 nil + mm-security-handle))) + mm-security-handle)) + +(defun mm-uu-pgp-encrypted-test (&rest rest) + (and + mml2015-use + (mml2015-clear-decrypt-function) + (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) t) + (t (y-or-n-p "Decrypt pgp encrypted part? "))))) + +(defun mm-uu-pgp-encrypted-extract-1 (handles ctl) + (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))) + (if (mm-uu-pgp-encrypted-test) + (with-current-buffer buf + (mml2015-clean-buffer) + (funcall (mml2015-clear-decrypt-function)))) + (list + (mm-make-handle buf + '("text/plain" (charset . gnus-decoded)))))) + +(defun mm-uu-pgp-encrypted-extract () + (let ((mm-security-handle (list (format "multipart/encrypted")))) + (mm-set-handle-multipart-parameter + mm-security-handle 'protocol "application/x-gnus-pgp-encrypted") + (save-restriction + (narrow-to-region start-point end-point) + (add-text-properties 0 (length (car mm-security-handle)) + (list 'buffer (mm-uu-copy-to-buffer)) + (car mm-security-handle)) + (setcdr mm-security-handle + (mm-uu-pgp-encrypted-extract-1 nil + mm-security-handle))) + mm-security-handle)) + +(defun mm-uu-gpg-key-skip-to-last () + (let ((point (point)) + (end-regexp (mm-uu-end-regexp entry)) + (beginning-regexp (mm-uu-beginning-regexp entry))) + (when (and end-regexp + (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))) + (while (re-search-forward end-regexp nil t) + (skip-chars-forward " \t\n\r") + (if (looking-at beginning-regexp) + (setq point (match-end 0))))) + (goto-char point))) + +(defun mm-uu-pgp-key-extract () + (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (mm-make-handle buf + '("application/pgp-keys")))) + ;;;###autoload (defun mm-uu-dissect () "Dissect the current buffer and return a list of uu handles." - (let (text-start start-char end-char - type file-name end-line result text-plain-type - start-char-1 end-char-1 - (case-fold-search t)) + (let ((case-fold-search t) + text-start start-point end-point file-name result + text-plain-type entry func) (save-excursion - (save-restriction - (mail-narrow-to-head) - (goto-char (point-max))) - (forward-line) + (goto-char (point-min)) + (cond + ((looking-at "\n") + (forward-line)) + ((search-forward "\n\n" nil t) + t) + (t (goto-char (point-max)))) ;;; gnus-decoded is a fake charset, which means no further ;;; decoding. (setq text-start (point) text-plain-type '("text/plain" (charset . gnus-decoded))) - (while (re-search-forward mm-uu-begin-line nil t) - (setq start-char (match-beginning 0)) - (setq type (cdr (assq (aref (match-string 0) 0) - mm-uu-identifier-alist))) - (setq file-name - (if (and (eq type 'uu) - (looking-at "\\(.+\\)$")) - (and (match-string 1) - (let ((nnheader-file-name-translation-alist - '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_)))) - (nnheader-translate-file-chars (match-string 1)))))) + (while (re-search-forward mm-uu-beginning-regexp nil t) + (setq start-point (match-beginning 0)) + (let ((alist mm-uu-type-alist) + (beginning-regexp (match-string 0))) + (while (not entry) + (if (string-match (mm-uu-beginning-regexp (car alist)) + beginning-regexp) + (setq entry (car alist)) + (pop alist)))) + (if (setq func (mm-uu-function-1 entry)) + (funcall func)) (forward-line);; in case of failure - (setq start-char-1 (point)) - (setq end-line (symbol-value - (intern (concat "mm-uu-" (symbol-name type) - "-end-line")))) - (when (and (re-search-forward end-line nil t) - (not (eq (match-beginning 0) (match-end 0)))) - (setq end-char-1 (match-beginning 0)) - (forward-line) - (setq end-char (point)) - (when (cond - ((eq type 'binhex) - (setq file-name - (ignore-errors - (binhex-decode-region start-char end-char t)))) - ((eq type 'forward) - (save-excursion - (goto-char start-char-1) - (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) - (t t)) - (if (> start-char text-start) - (push - (mm-make-handle (mm-uu-copy-to-buffer text-start start-char) - text-plain-type) - result)) - (push - (cond - ((eq type 'postscript) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - '("application/postscript"))) - ((eq type 'forward) - (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1) - '("message/rfc822" (charset . gnus-decoded)))) - ((eq type 'uu) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - (list (or (and file-name - (string-match "\\.[^\\.]+$" - file-name) - (mailcap-extension-to-mime - (match-string 0 file-name))) - "application/octet-stream")) - 'x-uuencode nil - (if (and file-name (not (equal file-name ""))) - (list mm-dissect-disposition - (cons 'filename file-name))))) - ((eq type 'binhex) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - (list (or (and file-name - (string-match "\\.[^\\.]+$" file-name) - (mailcap-extension-to-mime - (match-string 0 file-name))) - "application/octet-stream")) - 'x-binhex nil - (if (and file-name (not (equal file-name ""))) - (list mm-dissect-disposition - (cons 'filename file-name))))) - ((eq type 'shar) - (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) - '("application/x-shar")))) - result) - (setq text-start end-char)))) + (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)) + (let ((end-regexp (mm-uu-end-regexp entry))) + (if (not end-regexp) + (or (setq end-point (point-max)) t) + (prog1 + (re-search-forward end-regexp nil t) + (forward-line) + (setq end-point (point))))) + (or (not (setq func (mm-uu-function-2 entry))) + (funcall func))) + (if (and (> start-point text-start) + (progn + (goto-char text-start) + (re-search-forward "." start-point t))) + (push + (mm-make-handle (mm-uu-copy-to-buffer text-start start-point) + text-plain-type) + result)) + (push + (funcall (mm-uu-function-extract entry)) + result) + (goto-char (setq text-start end-point)))) (when result - (if (> (point-max) (1+ text-start)) + (if (and (> (point-max) (1+ text-start)) + (save-excursion + (goto-char text-start) + (re-search-forward "." nil t))) (push (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) text-plain-type) @@ -225,26 +493,6 @@ (setq result (cons "multipart/mixed" (nreverse result)))) result))) -;;;###autoload -(defun mm-uu-test () - "Check whether the current buffer contains uu stuff." - (save-excursion - (goto-char (point-min)) - (let (type end-line result - (case-fold-search t)) - (while (and mm-uu-begin-line - (not result) (re-search-forward mm-uu-begin-line nil t)) - (forward-line) - (setq type (cdr (assq (aref (match-string 0) 0) - mm-uu-identifier-alist))) - (setq end-line (symbol-value - (intern (concat "mm-uu-" (symbol-name type) - "-end-line")))) - (if (and (re-search-forward end-line nil t) - (not (eq (match-beginning 0) (match-end 0)))) - (setq result t))) - result))) - (provide 'mm-uu) ;;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
--- a/lisp/gnus/mm-view.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mm-view.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; mm-view.el --- functions for viewing MIME objects -;; Copyright (C) 1998, 1999, 2000, 01, 2004 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; This file is part of GNU Emacs. @@ -34,34 +34,67 @@ (autoload 'vcard-parse-string "vcard") (autoload 'vcard-format-string "vcard") (autoload 'fill-flowed "flow-fill") + (autoload 'html2text "html2text") (unless (fboundp 'diff-mode) (autoload 'diff-mode "diff-mode" "" t nil))) +(defvar mm-text-html-renderer-alist + '((w3 . mm-inline-text-html-render-with-w3) + (w3m . mm-inline-text-html-render-with-w3m) + (w3m-standalone mm-inline-render-with-stdin nil + "w3m" "-dump" "-T" "text/html") + (links mm-inline-render-with-file + mm-links-remove-leading-blank + "links" "-dump" file) + (lynx mm-inline-render-with-stdin nil + "lynx" "-dump" "-force_html" "-stdin" "-nolist") + (html2text mm-inline-render-with-function html2text)) + "The attributes of renderer types for text/html.") + +(defvar mm-text-html-washer-alist + '((w3 . gnus-article-wash-html-with-w3) + (w3m . gnus-article-wash-html-with-w3m) + (w3m-standalone mm-inline-wash-with-stdin nil + "w3m" "-dump" "-T" "text/html") + (links mm-inline-wash-with-file + mm-links-remove-leading-blank + "links" "-dump" file) + (lynx mm-inline-wash-with-stdin nil + "lynx" "-dump" "-force_html" "-stdin" "-nolist") + (html2text html2text)) + "The attributes of washer types for text/html.") + +;;; Internal variables. + ;;; ;;; Functions for displaying various formats inline ;;; + (defun mm-inline-image-emacs (handle) (let ((b (point-marker)) buffer-read-only) - (insert "\n") (put-image (mm-get-image handle) b) + (insert "\n\n") (mm-handle-set-undisplayer handle - `(lambda () (remove-images ,b (1+ ,b)))))) + `(lambda () + (let ((b ,b) + buffer-read-only) + (remove-images b b) + (delete-region b (+ b 2))))))) (defun mm-inline-image-xemacs (handle) - (insert "\n") - (forward-char -1) - (let ((b (point)) - (annot (make-annotation (mm-get-image handle) nil 'text)) + (insert "\n\n") + (forward-char -2) + (let ((annot (make-annotation (mm-get-image handle) nil 'text)) buffer-read-only) (mm-handle-set-undisplayer handle `(lambda () - (let (buffer-read-only) + (let ((b ,(point-marker)) + buffer-read-only) (delete-annotation ,annot) - (delete-region ,(set-marker (make-marker) b) - ,(set-marker (make-marker) (point)))))) + (delete-region (- b 2) b)))) (set-extent-property annot 'mm t) (set-extent-property annot 'duplicable t))) @@ -80,125 +113,284 @@ (require 'url-vars) (setq mm-w3-setup t))) -(defun mm-inline-text (handle) - (let ((type (mm-handle-media-subtype handle)) - text buffer-read-only) - (cond - ((equal type "html") - (mm-setup-w3) - (setq text (mm-get-part handle)) - (let ((b (point)) - (url-standalone-mode t) - (url-gateway-unplugged t) - (url-current-object - (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) - (width (window-width)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (save-excursion - (insert text) +(defun mm-inline-text-html-render-with-w3 (handle) + (mm-setup-w3) + (let ((text (mm-get-part handle)) + (b (point)) + (url-standalone-mode t) + (url-gateway-unplugged t) + (w3-honor-stylesheets nil) + (url-current-object + (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) + (width (window-width)) + (charset (mail-content-type-get + (mm-handle-type handle) 'charset))) + (save-excursion + (insert text) + (save-restriction + (narrow-to-region b (point)) + (goto-char (point-min)) + (if (or (and (boundp 'w3-meta-content-type-charset-regexp) + (re-search-forward + w3-meta-content-type-charset-regexp nil t)) + (and (boundp 'w3-meta-charset-content-type-regexp) + (re-search-forward + w3-meta-charset-content-type-regexp nil t))) + (setq charset + (or (let ((bsubstr (buffer-substring-no-properties + (match-beginning 2) + (match-end 2)))) + (if (fboundp 'w3-coding-system-for-mime-charset) + (w3-coding-system-for-mime-charset bsubstr) + (mm-charset-to-coding-system bsubstr))) + charset))) + (delete-region (point-min) (point-max)) + (insert (mm-decode-string text charset)) + (save-window-excursion (save-restriction - (narrow-to-region b (point)) - (goto-char (point-min)) - (if (or (and (boundp 'w3-meta-content-type-charset-regexp) - (re-search-forward - w3-meta-content-type-charset-regexp nil t)) - (and (boundp 'w3-meta-charset-content-type-regexp) - (re-search-forward - w3-meta-charset-content-type-regexp nil t))) - (setq charset - (or (let ((bsubstr (buffer-substring-no-properties - (match-beginning 2) - (match-end 2)))) - (if (fboundp 'w3-coding-system-for-mime-charset) - (w3-coding-system-for-mime-charset bsubstr) - (mm-charset-to-coding-system bsubstr))) - charset))) - (delete-region (point-min) (point-max)) - (insert (mm-decode-string text charset)) - (save-window-excursion - (save-restriction - (let ((w3-strict-width width) - ;; Don't let w3 set the global version of - ;; this variable. - (fill-column fill-column)) - (condition-case var - (w3-region (point-min) (point-max)) - (error - (delete-region (point-min) (point-max)) - (let ((b (point)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (if (or (eq charset 'gnus-decoded) - (eq mail-parse-charset 'gnus-decoded)) - (save-restriction - (narrow-to-region (point) (point)) - (mm-insert-part handle) - (goto-char (point-max))) - (insert (mm-decode-string (mm-get-part handle) - charset)))) - (message - "Error while rendering html; showing as text/plain")))))) - (mm-handle-set-undisplayer - handle - `(lambda () - (let (buffer-read-only) - (if (functionp 'remove-specifier) - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) - (current-buffer))) - '(background background-pixmap foreground))) - (delete-region ,(point-min-marker) - ,(point-max-marker))))))))) - ((equal type "x-vcard") - (mm-insert-inline + (let ((w3-strict-width width) + ;; Don't let w3 set the global version of + ;; this variable. + (fill-column fill-column)) + (if (or debug-on-error debug-on-quit) + (w3-region (point-min) (point-max)) + (condition-case () + (w3-region (point-min) (point-max)) + (error + (delete-region (point-min) (point-max)) + (let ((b (point)) + (charset (mail-content-type-get + (mm-handle-type handle) 'charset))) + (if (or (eq charset 'gnus-decoded) + (eq mail-parse-charset 'gnus-decoded)) + (save-restriction + (narrow-to-region (point) (point)) + (mm-insert-part handle) + (goto-char (point-max))) + (insert (mm-decode-string (mm-get-part handle) + charset)))) + (message + "Error while rendering html; showing as text/plain"))))))) + (mm-handle-set-undisplayer + handle + `(lambda () + (let (buffer-read-only) + (if (functionp 'remove-specifier) + (mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) + (current-buffer))) + '(background background-pixmap foreground))) + (delete-region ,(point-min-marker) + ,(point-max-marker))))))))) + +(defvar mm-w3m-setup nil + "Whether gnus-article-mode has been setup to use emacs-w3m.") + +(defun mm-setup-w3m () + "Setup gnus-article-mode to use emacs-w3m." + (unless mm-w3m-setup + (require 'w3m) + (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist) + (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve) + w3m-cid-retrieve-function-alist)) + (setq mm-w3m-setup t)) + (setq w3m-display-inline-images mm-inline-text-html-with-images)) + +(defun mm-w3m-cid-retrieve-1 (url handle) + (dolist (elem handle) + (when (and (listp elem) + (equal url (mm-handle-id elem))) + (mm-insert-part elem) + (throw 'found-handle (mm-handle-media-type elem))))) + +(defun mm-w3m-cid-retrieve (url &rest args) + "Insert a content pointed by URL if it has the cid: scheme." + (when (string-match "\\`cid:" url) + (setq url (concat "<" (substring url (match-end 0)) ">")) + (catch 'found-handle + (let ((handles (with-current-buffer w3m-current-buffer + gnus-article-mime-handles))) + (if (mm-multiple-handles handles) + (dolist (handle handles) + (mm-w3m-cid-retrieve-1 url handle)) + (mm-w3m-cid-retrieve-1 url handles)))))) + +(eval-and-compile + (unless (or (featurep 'xemacs) + (>= emacs-major-version 21)) + (defvar mm-w3m-mode-map nil + "Keymap for text/html parts rendered by emacs-w3m. +This keymap will be bound only when Emacs 20 is running and overwritten +by the value of `w3m-minor-mode-map'. In order to add some commands to +this keymap, add them to `w3m-minor-mode-map' instead of this keymap."))) + +(defun mm-w3m-local-map-property () + (when (and (boundp 'w3m-minor-mode-map) w3m-minor-mode-map) + (if (or (featurep 'xemacs) + (>= emacs-major-version 21)) + (list 'keymap w3m-minor-mode-map) + (list 'local-map + (or mm-w3m-mode-map + (progn + (setq mm-w3m-mode-map (copy-keymap w3m-minor-mode-map)) + (set-keymap-parent mm-w3m-mode-map gnus-article-mode-map) + mm-w3m-mode-map)))))) + +(defun mm-inline-text-html-render-with-w3m (handle) + "Render a text/html part using emacs-w3m." + (mm-setup-w3m) + (let ((text (mm-get-part handle)) + (b (point)) + (charset (mail-content-type-get (mm-handle-type handle) 'charset))) + (save-excursion + (insert text) + (save-restriction + (narrow-to-region b (point)) + (goto-char (point-min)) + (when (re-search-forward w3m-meta-content-type-charset-regexp nil t) + (setq charset (or (w3m-charset-to-coding-system (match-string 2)) + charset))) + (when charset + (delete-region (point-min) (point-max)) + (insert (mm-decode-string text charset))) + (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) + w3m-force-redisplay) + (w3m-region (point-min) (point-max))) + (when mm-inline-text-html-with-w3m-keymap + (add-text-properties + (point-min) (point-max) + (nconc (mm-w3m-local-map-property) + ;; Put the mark meaning this part was rendered by emacs-w3m. + '(mm-inline-text-html-with-w3m t))))) + (mm-handle-set-undisplayer handle - (concat "\n-- \n" - (ignore-errors - (if (fboundp 'vcard-pretty-print) - (vcard-pretty-print (mm-get-part handle)) - (vcard-format-string - (vcard-parse-string (mm-get-part handle) - 'vcard-standard-filter))))))) + `(lambda () + (let (buffer-read-only) + (if (functionp 'remove-specifier) + (mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) + (current-buffer))) + '(background background-pixmap foreground))) + (delete-region ,(point-min-marker) + ,(point-max-marker)))))))) + +(defun mm-links-remove-leading-blank () + ;; Delete the annoying three spaces preceding each line of links + ;; output. + (goto-char (point-min)) + (while (re-search-forward "^ " nil t) + (delete-region (match-beginning 0) (match-end 0)))) + +(defun mm-inline-wash-with-file (post-func cmd &rest args) + (let ((file (mm-make-temp-file + (expand-file-name "mm" mm-tmp-directory)))) + (let ((coding-system-for-write 'binary)) + (write-region (point-min) (point-max) file nil 'silent)) + (delete-region (point-min) (point-max)) + (unwind-protect + (apply 'call-process cmd nil t nil (mapcar 'eval args)) + (delete-file file)) + (and post-func (funcall post-func)))) + +(defun mm-inline-wash-with-stdin (post-func cmd &rest args) + (let ((coding-system-for-write 'binary)) + (apply 'call-process-region (point-min) (point-max) + cmd t t nil args)) + (and post-func (funcall post-func))) + +(defun mm-inline-render-with-file (handle post-func cmd &rest args) + (let ((source (mm-get-part handle))) + (mm-insert-inline + handle + (mm-with-unibyte-buffer + (insert source) + (apply 'mm-inline-wash-with-file post-func cmd args) + (buffer-string))))) + +(defun mm-inline-render-with-stdin (handle post-func cmd &rest args) + (let ((source (mm-get-part handle))) + (mm-insert-inline + handle + (mm-with-unibyte-buffer + (insert source) + (apply 'mm-inline-wash-with-stdin post-func cmd args) + (buffer-string))))) + +(defun mm-inline-render-with-function (handle func &rest args) + (let ((source (mm-get-part handle))) + (mm-insert-inline + handle + (mm-with-unibyte-buffer + (insert source) + (apply func args) + (buffer-string))))) + +(defun mm-inline-text-html (handle) + (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer)) + (entry (assq func mm-text-html-renderer-alist)) + buffer-read-only) + (if entry + (setq func (cdr entry))) + (cond + ((functionp func) + (funcall func handle)) (t - (let ((b (point)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (if (or (eq charset 'gnus-decoded) - ;; This is probably not entirely correct, but - ;; makes rfc822 parts with embedded multiparts work. - (eq mail-parse-charset 'gnus-decoded)) - (save-restriction - (narrow-to-region (point) (point)) - (mm-insert-part handle) - (goto-char (point-max))) - (insert (mm-decode-string (mm-get-part handle) charset))) - (when (and (equal type "plain") - (equal (cdr (assoc 'format (mm-handle-type handle))) - "flowed")) - (save-restriction - (narrow-to-region b (point)) - (goto-char b) - (fill-flowed) - (goto-char (point-max)))) + (apply (car func) handle (cdr func)))))) + +(defun mm-inline-text-vcard (handle) + (let (buffer-read-only) + (mm-insert-inline + handle + (concat "\n-- \n" + (ignore-errors + (if (fboundp 'vcard-pretty-print) + (vcard-pretty-print (mm-get-part handle)) + (vcard-format-string + (vcard-parse-string (mm-get-part handle) + 'vcard-standard-filter)))))))) + +(defun mm-inline-text (handle) + (let ((b (point)) + (type (mm-handle-media-subtype handle)) + (charset (mail-content-type-get + (mm-handle-type handle) 'charset)) + buffer-read-only) + (if (or (eq charset 'gnus-decoded) + ;; This is probably not entirely correct, but + ;; makes rfc822 parts with embedded multiparts work. + (eq mail-parse-charset 'gnus-decoded)) (save-restriction - (narrow-to-region b (point)) - (set-text-properties (point-min) (point-max) nil) - (when (or (equal type "enriched") - (equal type "richtext")) - (enriched-decode (point-min) (point-max))) - (mm-handle-set-undisplayer - handle - `(lambda () - (let (buffer-read-only) - (delete-region ,(point-min-marker) - ,(point-max-marker))))))))))) + (narrow-to-region (point) (point)) + (mm-insert-part handle) + (goto-char (point-max))) + (insert (mm-decode-string (mm-get-part handle) charset))) + (when (and (equal type "plain") + (equal (cdr (assoc 'format (mm-handle-type handle))) + "flowed")) + (save-restriction + (narrow-to-region b (point)) + (goto-char b) + (fill-flowed) + (goto-char (point-max)))) + (save-restriction + (narrow-to-region b (point)) + (set-text-properties (point-min) (point-max) nil) + (when (or (equal type "enriched") + (equal type "richtext")) + (ignore-errors + (enriched-decode (point-min) (point-max)))) + (mm-handle-set-undisplayer + handle + `(lambda () + (let (buffer-read-only) + (delete-region ,(point-min-marker) + ,(point-max-marker)))))))) (defun mm-insert-inline (handle text) "Insert TEXT inline from HANDLE." - (let ((b (point)) - (inhibit-read-only t)) + (let ((b (point))) (insert text) (mm-handle-set-undisplayer handle @@ -216,7 +408,8 @@ (defun mm-w3-prepare-buffer () (require 'w3) (let ((url-standalone-mode t) - (url-gateway-unplugged t)) + (url-gateway-unplugged t) + (w3-honor-stylesheets nil)) (w3-prepare-buffer))) (defun mm-view-message () @@ -229,9 +422,7 @@ (setq handles gnus-article-mime-handles)) (when handles (setq gnus-article-mime-handles - (nconc gnus-article-mime-handles - (if (listp (car handles)) - handles (list handles)))))) + (mm-merge-handles gnus-article-mime-handles handles)))) (fundamental-mode) (goto-char (point-min))) @@ -255,7 +446,8 @@ gnus-article-prepare-hook (gnus-newsgroup-charset (or charset gnus-newsgroup-charset))) - (run-hooks 'gnus-article-decode-hook) + (let ((gnus-original-article-buffer (mm-handle-buffer handle))) + (run-hooks 'gnus-article-decode-hook)) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) (goto-char (point-min)) @@ -267,9 +459,7 @@ (insert "----------\n\n") (when handles (setq gnus-article-mime-handles - (nconc gnus-article-mime-handles - (if (listp (car handles)) - handles (list handles))))) + (mm-merge-handles gnus-article-mime-handles handles))) (mm-handle-set-undisplayer handle `(lambda () @@ -284,24 +474,120 @@ (defun mm-display-inline-fontify (handle mode) (let (text) - (with-temp-buffer - (mm-insert-part handle) - (funcall mode) - (font-lock-fontify-buffer) - (when (fboundp 'extent-list) - (map-extents (lambda (ext ignored) - (set-extent-property ext 'duplicable t) - nil) - nil nil nil nil nil 'text-prop)) - (setq text (buffer-string))) + ;; XEmacs @#$@ version of font-lock refuses to fully turn itself + ;; on for buffers whose name begins with " ". That's why we use + ;; save-current-buffer/get-buffer-create rather than + ;; with-temp-buffer. + (save-current-buffer + (set-buffer (generate-new-buffer "*fontification*")) + (unwind-protect + (progn + (buffer-disable-undo) + (mm-insert-part handle) + (funcall mode) + (require 'font-lock) + (let ((font-lock-verbose nil)) + ;; I find font-lock a bit too verbose. + (font-lock-fontify-buffer)) + ;; By default, XEmacs font-lock uses non-duplicable text + ;; properties. This code forces all the text properties + ;; to be copied along with the text. + (when (fboundp 'extent-list) + (map-extents (lambda (ext ignored) + (set-extent-property ext 'duplicable t) + nil) + nil nil nil nil nil 'text-prop)) + (setq text (buffer-string))) + (kill-buffer (current-buffer)))) (mm-insert-inline handle text))) +;; Shouldn't these functions check whether the user even wants to use +;; font-lock? At least under XEmacs, this fontification is pretty +;; much unconditional. Also, it would be nice to change for the size +;; of the fontified region. + (defun mm-display-patch-inline (handle) (mm-display-inline-fontify handle 'diff-mode)) (defun mm-display-elisp-inline (handle) (mm-display-inline-fontify handle 'emacs-lisp-mode)) +;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) +;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 } +(defvar mm-pkcs7-signed-magic + (mm-string-as-unibyte + (apply 'concat + (mapcar 'char-to-string + (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c + ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e + ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 + ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02))))) + +;; id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) +;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 } +(defvar mm-pkcs7-enveloped-magic + (mm-string-as-unibyte + (apply 'concat + (mapcar 'char-to-string + (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c + ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e + ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 + ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03))))) + +(defun mm-view-pkcs7-get-type (handle) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (cond ((looking-at mm-pkcs7-enveloped-magic) + 'enveloped) + ((looking-at mm-pkcs7-signed-magic) + 'signed) + (t + (error "Could not identify PKCS#7 type"))))) + +(defun mm-view-pkcs7 (handle) + (case (mm-view-pkcs7-get-type handle) + (enveloped (mm-view-pkcs7-decrypt handle)) + (signed (mm-view-pkcs7-verify handle)) + (otherwise (error "Unknown or unimplemented PKCS#7 type")))) + +(defun mm-view-pkcs7-verify (handle) + ;; A bogus implementation of PKCS#7. FIXME:: + (mm-insert-part handle) + (goto-char (point-min)) + (if (search-forward "Content-Type: " nil t) + (delete-region (point-min) (match-beginning 0))) + (goto-char (point-max)) + (if (re-search-backward "--\r?\n?" nil t) + (delete-region (match-end 0) (point-max))) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + (message "Verify signed PKCS#7 message is unimplemented.") + (sit-for 1) + t) + +(autoload 'gnus-completing-read-maybe-default "gnus-util" nil nil 'macro) + +(defun mm-view-pkcs7-decrypt (handle) + (insert-buffer-substring (mm-handle-buffer handle)) + (goto-char (point-min)) + (insert "MIME-Version: 1.0\n") + (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") + (smime-decrypt-region + (point-min) (point-max) + (if (= (length smime-keys) 1) + (cadar smime-keys) + (smime-get-key-by-email + (gnus-completing-read-maybe-default + (concat "Decipher using which key? " + (if smime-keys (concat "(default " (caar smime-keys) ") ") + "")) + smime-keys nil nil nil nil (car-safe (car-safe smime-keys)))))) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + (goto-char (point-min))) + (provide 'mm-view) ;;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/mml-sec.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,293 @@ +;;; mml-sec.el --- A package with security functions for MML documents +;; Copyright (C) 2000, 2001, 2002, 2003, 2004 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.") + +(defcustom mml-default-sign-method "pgpmime" + "Default sign method. +The string must have an entry in `mml-sign-alist'." + :type '(choice (const "smime") + (const "pgp") + (const "pgpauto") + (const "pgpmime") + string) + :group 'message) + +(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.") + +(defcustom mml-default-encrypt-method "pgpmime" + "Default encryption method. +The string must have an entry in `mml-encrypt-alist'." + :type '(choice (const "smime") + (const "pgp") + (const "pgpauto") + (const "pgpmime") + string) + :group 'message) + +(defcustom mml-signencrypt-style-alist + '(("smime" separate) + ("pgp" combined) + ("pgpauto" combined) + ("pgpmime" combined)) + "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 output generated by using a `combined' mode is NOT +understood by all PGP implementations, in particular PGP version +2 does not support it! See Info node `(message)Security' for +details." + :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) + +;;; arch-tag: 111c56e7-df5e-4287-87d7-93ed2911ec6c +;;; mml-sec.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/mml-smime.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,201 @@ +;;; 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) +(autoload 'message-narrow-to-headers "message") + +(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-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" t t)) + (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) + +;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2 +;;; mml-smime.el ends here
--- a/lisp/gnus/mml.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/mml.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ -;;; mml.el --- package for parsing and validating MML documents -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. +;;; mml.el --- A package for parsing and validating MML documents +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; This file is part of GNU Emacs. @@ -27,15 +28,61 @@ (require 'mm-bodies) (require 'mm-encode) (require 'mm-decode) +(require 'mml-sec) (eval-when-compile (require 'cl)) (eval-and-compile (autoload 'message-make-message-id "message") (autoload 'gnus-setup-posting-charset "gnus-msg") (autoload 'gnus-add-minor-mode "gnus-ems") + (autoload 'gnus-make-local-hook "gnus-util") (autoload 'message-fetch-field "message") + (autoload 'fill-flowed-encode "flow-fill") (autoload 'message-posting-charset "message")) +(defcustom mml-content-type-parameters + '(name access-type expiration size permission format) + "*A list of acceptable parameters in MML tag. +These parameters are generated in Content-Type header if exists." + :type '(repeat (symbol :tag "Parameter")) + :group 'message) + +(defcustom mml-content-disposition-parameters + '(filename creation-date modification-date read-date) + "*A list of acceptable parameters in MML tag. +These parameters are generated in Content-Disposition header if exists." + :type '(repeat (symbol :tag "Parameter")) + :group 'message) + +(defcustom mml-insert-mime-headers-always nil + "If non-nil, always put Content-Type: text/plain at top of empty parts. +It is necessary to work against a bug in certain clients." + :type 'boolean + :group 'message) + +(defvar mml-tweak-type-alist nil + "A list of (TYPE . FUNCTION) for tweaking MML parts. +TYPE is a string containing a regexp to match the MIME type. FUNCTION +is a Lisp function which is called with the MML handle to tweak the +part. This variable is used only when no TWEAK parameter exists in +the MML handle.") + +(defvar mml-tweak-function-alist nil + "A list of (NAME . FUNCTION) for tweaking MML parts. +NAME is a string containing the name of the TWEAK parameter in the MML +handle. FUNCTION is a Lisp function which is called with the MML +handle to tweak the part.") + +(defvar mml-tweak-sexp-alist + '((mml-externalize-attachments . mml-tweak-externalize-attachments)) + "A list of (SEXP . FUNCTION) for tweaking MML parts. +SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION +is called. FUNCTION is a Lisp function which is called with the MML +handle to tweak the part.") + +(defvar mml-externalize-attachments nil + "*If non-nil, local-file attachments are generated as external parts.") + (defvar mml-generate-multipart-alist nil "*Alist of multipart generation functions. Each entry has the form (NAME . FUNCTION), where @@ -73,15 +120,6 @@ with unknown encoding; `multipart': always send messages with more than one charsets.") -(defvar mml-generate-mime-preprocess-function nil - "A function called before generating a mime part. -The function is called with one parameter, which is the part to be -generated.") - -(defvar mml-generate-mime-postprocess-function nil - "A function called after generating a mime part. -The function is called with one parameter, which is the generated part.") - (defvar mml-generate-default-type "text/plain") (defvar mml-buffer-list nil) @@ -98,13 +136,14 @@ (defun mml-parse () "Parse the current buffer as an MML document." - (goto-char (point-min)) - (let ((table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table mml-syntax-table) - (mml-parse-1)) - (set-syntax-table table)))) + (save-excursion + (goto-char (point-min)) + (let ((table (syntax-table))) + (unwind-protect + (progn + (set-syntax-table mml-syntax-table) + (mml-parse-1)) + (set-syntax-table table))))) (defun mml-parse-1 () "Parse the current buffer as an MML document." @@ -112,6 +151,43 @@ (while (and (not (eobp)) (not (looking-at "<#/multipart"))) (cond + ((looking-at "<#secure") + ;; The secure part is essentially a meta-meta tag, which + ;; expands to either a part tag if there are no other parts in + ;; the document or a multipart tag if there are other parts + ;; included in the message + (let* (secure-mode + (taginfo (mml-read-tag)) + (recipients (cdr (assq 'recipients taginfo))) + (sender (cdr (assq 'sender taginfo))) + (location (cdr (assq 'tag-location taginfo))) + (mode (cdr (assq 'mode taginfo))) + (method (cdr (assq 'method taginfo))) + tags) + (save-excursion + (if + (re-search-forward + "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) + (setq secure-mode "multipart") + (setq secure-mode "part"))) + (save-excursion + (goto-char location) + (re-search-forward "<#secure[^\n]*>\n")) + (delete-region (match-beginning 0) (match-end 0)) + (cond ((string= mode "sign") + (setq tags (list "sign" method))) + ((string= mode "encrypt") + (setq tags (list "encrypt" method))) + ((string= mode "signencrypt") + (setq tags (list "sign" method "encrypt" method)))) + (eval `(mml-insert-tag ,secure-mode + ,@tags + ,(if recipients "recipients") + ,recipients + ,(if sender "sender") + ,sender)) + ;; restart the parse + (goto-char location))) ((looking-at "<#multipart") (push (nconc (mml-read-tag) (mml-parse-1)) struct)) ((looking-at "<#external") @@ -128,18 +204,25 @@ (setq raw (cdr (assq 'raw tag)) point (point) contents (mml-read-part (eq 'mml (car tag))) - charsets (if raw nil - (mm-find-mime-charset-region point (point)))) + charsets (cond + (raw nil) + ((assq 'charset tag) + (list + (intern (downcase (cdr (assq 'charset tag)))))) + (t + (mm-find-mime-charset-region point (point) + mm-hack-charsets)))) (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) - (prog1 (y-or-n-p - "\ -Message contains characters with unknown encoding. Really send?") - (set (make-local-variable 'mml-confirmation-set) - (push 'unknown-encoding mml-confirmation-set)))) + (message-options-get 'unknown-encoding) + (and (y-or-n-p "\ +Message contains characters with unknown encoding. Really send? ") + (message-options-set 'unknown-encoding t))) (if (setq use-ascii (or (memq 'use-ascii mml-confirmation-set) - (y-or-n-p "Use ASCII as charset?"))) + (message-options-get 'use-ascii) + (and (y-or-n-p "Use ASCII as charset? ") + (message-options-set 'use-ascii t)))) (setq charsets (delq nil charsets)) (setq warn nil)) (error "Edit your message to remove those characters"))) @@ -155,14 +238,11 @@ tag point (point) use-ascii))) (when (and warn (not (memq 'multipart mml-confirmation-set)) - (not - (prog1 (y-or-n-p - (format - "\ + (not (message-options-get 'multipart)) + (not (and (y-or-n-p (format "\ A message part needs to be split into %d charset parts. Really send? " - (length nstruct))) - (set (make-local-variable 'mml-confirmation-set) - (push 'multipart mml-confirmation-set))))) + (length nstruct))) + (message-options-set 'multipart t)))) (error "Edit your message to use only one charset")) (setq struct (nconc nstruct struct))))))) (unless (eobp) @@ -229,12 +309,13 @@ (defun mml-read-tag () "Read a tag and return the contents." - (let (contents name elem val) + (let ((orig-point (point)) + contents name elem val) (forward-char 2) (setq name (buffer-substring-no-properties (point) (progn (forward-sexp 1) (point)))) (skip-chars-forward " \t\n") - (while (not (looking-at ">")) + (while (not (looking-at ">[ \t]*\n?")) (setq elem (buffer-substring-no-properties (point) (progn (forward-sexp 1) (point)))) (skip-chars-forward "= \t\n") @@ -244,15 +325,27 @@ (setq val (match-string 1 val))) (push (cons (intern elem) val) contents) (skip-chars-forward " \t\n")) - (forward-char 1) - (skip-chars-forward " \t\n") + (goto-char (match-end 0)) + ;; Don't skip the leading space. + ;;(skip-chars-forward " \t\n") + ;; Put the tag location into the returned contents + (setq contents (append (list (cons 'tag-location orig-point)) contents)) (cons (intern name) (nreverse contents)))) +(defun mml-buffer-substring-no-properties-except-hard-newlines (start end) + (let ((str (buffer-substring-no-properties start end)) + (bufstart start) tmp) + (while (setq tmp (text-property-any start end 'hard 't)) + (set-text-properties (- tmp bufstart) (- tmp bufstart -1) + '(hard t) str) + (setq start (1+ tmp))) + str)) + (defun mml-read-part (&optional mml) "Return the buffer up till the next part, multipart or closing part or multipart. If MML is non-nil, return the buffer up till the correspondent mml tag." (let ((beg (point)) (count 1)) - ;; If the tag ended at the end of the line, we go to the next line. + ;; If the tag ended at the end of the line, we go to the next line. (when (looking-at "[ \t]*\n") (forward-line 1)) (if mml @@ -261,19 +354,22 @@ (if (re-search-forward "<#\\(/\\)?mml." nil t) (setq count (+ count (if (match-beginning 1) -1 1))) (goto-char (point-max)))) - (buffer-substring-no-properties beg (if (> count 0) - (point) - (match-beginning 0)))) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (if (> count 0) + (point) + (match-beginning 0)))) (if (re-search-forward "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) (prog1 - (buffer-substring-no-properties beg (match-beginning 0)) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (match-beginning 0)) (if (or (not (match-beginning 1)) (equal (match-string 2) "multipart")) (goto-char (match-beginning 0)) (when (looking-at "[ \t]*\n") (forward-line 1)))) - (buffer-substring-no-properties beg (goto-char (point-max))))))) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (goto-char (point-max))))))) (defvar mml-boundary nil) (defvar mml-base-boundary "-=-=") @@ -294,129 +390,183 @@ (buffer-string))))) (defun mml-generate-mime-1 (cont) - (save-restriction - (narrow-to-region (point) (point)) - (if mml-generate-mime-preprocess-function - (funcall mml-generate-mime-preprocess-function cont)) - (cond - ((or (eq (car cont) 'part) (eq (car cont) 'mml)) - (let ((raw (cdr (assq 'raw cont))) - coded encoding charset filename type) - (setq type (or (cdr (assq 'type cont)) "text/plain")) - (if (and (not raw) - (member (car (split-string type "/")) '("text" "message"))) - (progn - (with-temp-buffer - (cond - ((cdr (assq 'buffer cont)) - (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((and (setq filename (cdr (assq 'filename cont))) - (not (equal (cdr (assq 'nofile cont)) "yes"))) - (mm-insert-file-contents filename)) - ((eq 'mml (car cont)) - (insert (cdr (assq 'contents cont)))) - (t - (save-restriction - (narrow-to-region (point) (point)) - (insert (cdr (assq 'contents cont))) - ;; Remove quotes from quoted tags. - (goto-char (point-min)) - (while (re-search-forward - "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t) - (delete-region (+ (match-beginning 0) 2) - (+ (match-beginning 0) 3)))))) - (cond - ((eq (car cont) 'mml) - (let ((mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number))) - (mml-generate-default-type "text/plain")) - (mml-to-mime)) - (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) - ;; ignore 0x1b, it is part of iso-2022-jp - (setq encoding (mm-body-7-or-8)))) - ((string= (car (split-string type "/")) "message") - (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) - ;; ignore 0x1b, it is part of iso-2022-jp - (setq encoding (mm-body-7-or-8)))) - (t - (setq charset (mm-encode-body)) - (setq encoding (mm-body-encoding - charset (cdr (assq 'encoding cont)))))) - (setq coded (buffer-string))) - (mml-insert-mime-headers cont type charset encoding) - (insert "\n") - (insert coded)) - (mm-with-unibyte-buffer - (cond - ((cdr (assq 'buffer cont)) - (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((and (setq filename (cdr (assq 'filename cont))) - (not (equal (cdr (assq 'nofile cont)) "yes"))) - (let ((coding-system-for-read mm-binary-coding-system)) - (mm-insert-file-contents filename nil nil nil nil t))) - (t - (insert (cdr (assq 'contents cont))))) - (setq encoding (mm-encode-buffer type) - coded (buffer-string))) - (mml-insert-mime-headers cont type charset encoding) - (insert "\n") - (mm-with-unibyte-current-buffer - (insert coded))))) - ((eq (car cont) 'external) - (insert "Content-Type: message/external-body") - (let ((parameters (mml-parameter-string - cont '(expiration size permission))) - (name (cdr (assq 'name cont)))) - (when name - (setq name (mml-parse-file-name name)) - (if (stringp name) + (let ((mm-use-ultra-safe-encoding + (or mm-use-ultra-safe-encoding (assq 'sign cont)))) + (save-restriction + (narrow-to-region (point) (point)) + (mml-tweak-part cont) + (cond + ((or (eq (car cont) 'part) (eq (car cont) 'mml)) + (let ((raw (cdr (assq 'raw cont))) + coded encoding charset filename type flowed) + (setq type (or (cdr (assq 'type cont)) "text/plain")) + (if (and (not raw) + (member (car (split-string type "/")) '("text" "message"))) + (progn + (with-temp-buffer + (setq charset (mm-charset-to-coding-system + (cdr (assq 'charset cont)))) + (when (eq charset 'ascii) + (setq charset nil)) + (cond + ((cdr (assq 'buffer cont)) + (insert-buffer-substring (cdr (assq 'buffer cont)))) + ((and (setq filename (cdr (assq 'filename cont))) + (not (equal (cdr (assq 'nofile cont)) "yes"))) + (let ((coding-system-for-read charset)) + (mm-insert-file-contents filename))) + ((eq 'mml (car cont)) + (insert (cdr (assq 'contents cont)))) + (t + (save-restriction + (narrow-to-region (point) (point)) + (insert (cdr (assq 'contents cont))) + ;; Remove quotes from quoted tags. + (goto-char (point-min)) + (while (re-search-forward + "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" + nil t) + (delete-region (+ (match-beginning 0) 2) + (+ (match-beginning 0) 3)))))) + (cond + ((eq (car cont) 'mml) + (let ((mml-boundary (mml-compute-boundary cont)) + (mml-generate-default-type "text/plain")) + (mml-to-mime)) + (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) + ;; ignore 0x1b, it is part of iso-2022-jp + (setq encoding (mm-body-7-or-8)))) + ((string= (car (split-string type "/")) "message") + (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) + ;; ignore 0x1b, it is part of iso-2022-jp + (setq encoding (mm-body-7-or-8)))) + (t + ;; Only perform format=flowed filling on text/plain + ;; parts where there either isn't a format parameter + ;; in the mml tag or it says "flowed" and there + ;; actually are hard newlines in the text. + (let (use-hard-newlines) + (when (and (string= type "text/plain") + (or (null (assq 'format cont)) + (string= (cdr (assq 'format cont)) + "flowed")) + (setq use-hard-newlines + (text-property-any + (point-min) (point-max) 'hard 't))) + (fill-flowed-encode) + ;; Indicate that `mml-insert-mime-headers' should + ;; insert a "; format=flowed" string unless the + ;; user has already specified it. + (setq flowed (null (assq 'format cont))))) + (setq charset (mm-encode-body charset)) + (setq encoding (mm-body-encoding + charset (cdr (assq 'encoding cont)))))) + (setq coded (buffer-string))) + (mml-insert-mime-headers cont type charset encoding flowed) + (insert "\n") + (insert coded)) + (mm-with-unibyte-buffer + (cond + ((cdr (assq 'buffer cont)) + (insert-buffer-substring (cdr (assq 'buffer cont)))) + ((and (setq filename (cdr (assq 'filename cont))) + (not (equal (cdr (assq 'nofile cont)) "yes"))) + (let ((coding-system-for-read mm-binary-coding-system)) + (mm-insert-file-contents filename nil nil nil nil t))) + (t + (insert (cdr (assq 'contents cont))))) + (setq encoding (mm-encode-buffer type) + coded (mm-string-as-multibyte (buffer-string)))) + (mml-insert-mime-headers cont type charset encoding nil) + (insert "\n") + (mm-with-unibyte-current-buffer + (insert coded))))) + ((eq (car cont) 'external) + (insert "Content-Type: message/external-body") + (let ((parameters (mml-parameter-string + cont '(expiration size permission))) + (name (cdr (assq 'name cont))) + (url (cdr (assq 'url cont)))) + (when name + (setq name (mml-parse-file-name name)) + (if (stringp name) + (mml-insert-parameter + (mail-header-encode-parameter "name" name) + "access-type=local-file") (mml-insert-parameter - (mail-header-encode-parameter "name" name) - "access-type=local-file") - (mml-insert-parameter - (mail-header-encode-parameter - "name" (file-name-nondirectory (nth 2 name))) - (mail-header-encode-parameter "site" (nth 1 name)) - (mail-header-encode-parameter - "directory" (file-name-directory (nth 2 name)))) + (mail-header-encode-parameter + "name" (file-name-nondirectory (nth 2 name))) + (mail-header-encode-parameter "site" (nth 1 name)) + (mail-header-encode-parameter + "directory" (file-name-directory (nth 2 name)))) + (mml-insert-parameter + (concat "access-type=" + (if (member (nth 0 name) '("ftp@" "anonymous@")) + "anon-ftp" + "ftp"))))) + (when url (mml-insert-parameter - (concat "access-type=" - (if (member (nth 0 name) '("ftp@" "anonymous@")) - "anon-ftp" - "ftp"))))) - (when parameters - (mml-insert-parameter-string - cont '(expiration size permission)))) - (insert "\n\n") - (insert "Content-Type: " (cdr (assq 'type cont)) "\n") - (insert "Content-ID: " (message-make-message-id) "\n") - (insert "Content-Transfer-Encoding: " - (or (cdr (assq 'encoding cont)) "binary")) - (insert "\n\n") - (insert (or (cdr (assq 'contents cont)))) - (insert "\n")) - ((eq (car cont) 'multipart) - (let* ((type (or (cdr (assq 'type cont)) "mixed")) - (mml-generate-default-type (if (equal type "digest") - "message/rfc822" - "text/plain")) - (handler (assoc type mml-generate-multipart-alist))) - (if handler - (funcall (cdr handler) cont) - ;; No specific handler. Use default one. - (let ((mml-boundary (mml-compute-boundary cont))) - (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n" - type mml-boundary)) - ;; Skip `multipart' and `type' elements. - (setq cont (cddr cont)) - (while cont - (insert "\n--" mml-boundary "\n") - (mml-generate-mime-1 (pop cont))) - (insert "\n--" mml-boundary "--\n"))))) - (t - (error "Invalid element: %S" cont))) - (if mml-generate-mime-postprocess-function - (funcall mml-generate-mime-postprocess-function cont)))) + (mail-header-encode-parameter "url" url) + "access-type=url")) + (when parameters + (mml-insert-parameter-string + cont '(expiration size permission)))) + (insert "\n\n") + (insert "Content-Type: " (cdr (assq 'type cont)) "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: " + (or (cdr (assq 'encoding cont)) "binary")) + (insert "\n\n") + (insert (or (cdr (assq 'contents cont)))) + (insert "\n")) + ((eq (car cont) 'multipart) + (let* ((type (or (cdr (assq 'type cont)) "mixed")) + (mml-generate-default-type (if (equal type "digest") + "message/rfc822" + "text/plain")) + (handler (assoc type mml-generate-multipart-alist))) + (if handler + (funcall (cdr handler) cont) + ;; No specific handler. Use default one. + (let ((mml-boundary (mml-compute-boundary cont))) + (insert (format "Content-Type: multipart/%s; boundary=\"%s\"" + type mml-boundary) + (if (cdr (assq 'start cont)) + (format "; start=\"%s\"\n" (cdr (assq 'start cont))) + "\n")) + (let ((cont cont) part) + (while (setq part (pop cont)) + ;; Skip `multipart' and attributes. + (when (and (consp part) (consp (cdr part))) + (insert "\n--" mml-boundary "\n") + (mml-generate-mime-1 part)))) + (insert "\n--" mml-boundary "--\n"))))) + (t + (error "Invalid element: %S" cont))) + ;; handle sign & encrypt tags in a semi-smart way. + (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist)) + (encrypt-item (assoc (cdr (assq 'encrypt cont)) + mml-encrypt-alist)) + sender recipients) + (when (or sign-item encrypt-item) + (when (setq sender (cdr (assq 'sender cont))) + (message-options-set 'mml-sender sender) + (message-options-set 'message-sender sender)) + (if (setq recipients (cdr (assq 'recipients cont))) + (message-options-set 'message-recipients recipients)) + (let ((style (mml-signencrypt-style (first (or sign-item encrypt-item))))) + ;; check if: we're both signing & encrypting, both methods + ;; are the same (why would they be different?!), and that + ;; the signencrypt style allows for combined operation. + (if (and sign-item encrypt-item (equal (first sign-item) + (first encrypt-item)) + (equal style 'combined)) + (funcall (nth 1 encrypt-item) cont t) + ;; otherwise, revert to the old behavior. + (when sign-item + (funcall (nth 1 sign-item) cont)) + (when encrypt-item + (funcall (nth 1 encrypt-item) cont))))))))) (defun mml-compute-boundary (cont) "Return a unique boundary that does not exist in CONT." @@ -458,34 +608,40 @@ "") mml-base-boundary)) -(defun mml-insert-mime-headers (cont type charset encoding) - (let (parameters disposition description) +(defun mml-insert-mime-headers (cont type charset encoding flowed) + (let (parameters id disposition description) (setq parameters (mml-parameter-string - cont '(name access-type expiration size permission))) + cont mml-content-type-parameters)) (when (or charset parameters - (not (equal type mml-generate-default-type))) + flowed + (not (equal type mml-generate-default-type)) + mml-insert-mime-headers-always) (when (consp charset) (error - "Can't encode a part with several charsets.")) + "Can't encode a part with several charsets")) (insert "Content-Type: " type) (when charset (insert "; " (mail-header-encode-parameter "charset" (symbol-name charset)))) + (when flowed + (insert "; format=flowed")) (when parameters (mml-insert-parameter-string - cont '(name access-type expiration size permission))) + cont mml-content-type-parameters)) (insert "\n")) + (when (setq id (cdr (assq 'id cont))) + (insert "Content-ID: " id "\n")) (setq parameters (mml-parameter-string - cont '(filename creation-date modification-date read-date))) + cont mml-content-disposition-parameters)) (when (or (setq disposition (cdr (assq 'disposition cont))) parameters) (insert "Content-Disposition: " (or disposition "inline")) (when parameters (mml-insert-parameter-string - cont '(filename creation-date modification-date read-date))) + cont mml-content-disposition-parameters)) (insert "\n")) (unless (eq encoding '7bit) (insert (format "Content-Transfer-Encoding: %s\n" encoding))) @@ -542,25 +698,28 @@ ;;; Transforming MIME to MML ;;; -(defun mime-to-mml () - "Translate the current buffer (which should be a message) into MML." +(defun mime-to-mml (&optional handles) + "Translate the current buffer (which should be a message) into MML. +If HANDLES is non-nil, use it instead reparsing the buffer." ;; First decode the head. (save-restriction (message-narrow-to-head) (mail-decode-encoded-word-region (point-min) (point-max))) - (let ((handles (mm-dissect-buffer t))) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (delete-region (point) (point-max)) - (if (stringp (car handles)) - (mml-insert-mime handles) - (mml-insert-mime handles t)) - (mm-destroy-parts handles)) + (unless handles + (setq handles (mm-dissect-buffer t))) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (delete-region (point) (point-max)) + (if (stringp (car handles)) + (mml-insert-mime handles) + (mml-insert-mime handles t)) + (mm-destroy-parts handles) (save-restriction (message-narrow-to-head) ;; Remove them, they are confusing. (message-remove-header "Content-Type") (message-remove-header "MIME-Version") + (message-remove-header "Content-Disposition") (message-remove-header "Content-Transfer-Encoding"))) (defun mml-to-mime () @@ -568,6 +727,9 @@ (message-encode-message-body) (save-restriction (message-narrow-to-headers-or-head) + ;; Skip past any From_ headers. + (while (looking-at "From ") + (forward-line 1)) (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer)))) @@ -589,17 +751,20 @@ (mml-insert-mml-markup handle buffer textp))) (cond (mmlp - (insert-buffer buffer) + (insert-buffer-substring buffer) (goto-char (point-max)) (insert "<#/mml>\n")) ((stringp (car handle)) (mapcar 'mml-insert-mime (cdr handle)) (insert "<#/multipart>\n")) (textp - (let ((text (mm-get-part handle)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (insert (mm-decode-string text charset))) + (let ((charset (mail-content-type-get + (mm-handle-type handle) 'charset)) + (start (point))) + (if (eq charset 'gnus-decoded) + (mm-insert-part handle) + (insert (mm-decode-string (mm-get-part handle) charset))) + (mml-quote-region start (point))) (goto-char (point-max))) (t (insert "<#/part>\n"))))) @@ -607,14 +772,21 @@ (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp) "Take a MIME handle and insert an MML tag." (if (stringp (car handle)) - (insert "<#multipart type=" (mm-handle-media-subtype handle) - ">\n") + (progn + (insert "<#multipart type=" (mm-handle-media-subtype handle)) + (let ((start (mm-handle-multipart-ctl-parameter handle 'start))) + (when start + (insert " start=\"" start "\""))) + (insert ">\n")) (if mmlp (insert "<#mml type=" (mm-handle-media-type handle)) (insert "<#part type=" (mm-handle-media-type handle))) (dolist (elem (append (cdr (mm-handle-type handle)) (cdr (mm-handle-disposition handle)))) - (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")) + (unless (symbolp (cdr elem)) + (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\""))) + (when (mm-handle-id handle) + (insert " id=\"" (mm-handle-id handle) "\"")) (when (mm-handle-disposition handle) (insert " disposition=" (car (mm-handle-disposition handle)))) (when buffer @@ -641,8 +813,25 @@ ;;; (defvar mml-mode-map - (let ((map (make-sparse-keymap)) + (let ((sign (make-sparse-keymap)) + (encrypt (make-sparse-keymap)) + (signpart (make-sparse-keymap)) + (encryptpart (make-sparse-keymap)) + (map (make-sparse-keymap)) (main (make-sparse-keymap))) + (define-key sign "p" 'mml-secure-message-sign-pgpmime) + (define-key sign "o" 'mml-secure-message-sign-pgp) + (define-key sign "s" 'mml-secure-message-sign-smime) + (define-key signpart "p" 'mml-secure-sign-pgpmime) + (define-key signpart "o" 'mml-secure-sign-pgp) + (define-key signpart "s" 'mml-secure-sign-smime) + (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime) + (define-key encrypt "o" 'mml-secure-message-encrypt-pgp) + (define-key encrypt "s" 'mml-secure-message-encrypt-smime) + (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime) + (define-key encryptpart "o" 'mml-secure-encrypt-pgp) + (define-key encryptpart "s" 'mml-secure-encrypt-smime) + (define-key map "\C-n" 'mml-unsecure-message) (define-key map "f" 'mml-attach-file) (define-key map "b" 'mml-attach-buffer) (define-key map "e" 'mml-attach-external) @@ -651,23 +840,43 @@ (define-key map "p" 'mml-insert-part) (define-key map "v" 'mml-validate) (define-key map "P" 'mml-preview) + (define-key map "s" sign) + (define-key map "S" signpart) + (define-key map "c" encrypt) + (define-key map "C" encryptpart) ;;(define-key map "n" 'mml-narrow-to-part) - (define-key main "\M-m" map) + ;; `M-m' conflicts with `back-to-indentation'. + ;; (define-key main "\M-m" map) + (define-key main "\C-c\C-m" map) main)) (easy-menu-define mml-menu mml-mode-map "" - '("MML" - ("Attach" - ["File" mml-attach-file t] - ["Buffer" mml-attach-buffer t] - ["External" mml-attach-external t]) - ("Insert" - ["Multipart" mml-insert-multipart t] - ["Part" mml-insert-part t]) + `("Attachments" + ["Attach File..." mml-attach-file + ,@(if (featurep 'xemacs) '(t) + '(:help "Attach a file at point"))] + ["Attach Buffer..." mml-attach-buffer t] + ["Attach External..." mml-attach-external t] + ["Insert Part..." mml-insert-part t] + ["Insert Multipart..." mml-insert-multipart t] + ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t] + ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t] + ["PGP Sign" mml-secure-message-sign-pgp t] + ["PGP Encrypt" mml-secure-message-encrypt-pgp t] + ["S/MIME Sign" mml-secure-message-sign-smime t] + ["S/MIME Encrypt" mml-secure-message-encrypt-smime t] + ("Secure MIME part" + ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t] + ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t] + ["PGP Sign Part" mml-secure-sign-pgp t] + ["PGP Encrypt Part" mml-secure-encrypt-pgp t] + ["S/MIME Sign Part" mml-secure-sign-smime t] + ["S/MIME Encrypt Part" mml-secure-encrypt-smime t]) + ["Encrypt/Sign off" mml-unsecure-message t] ;;["Narrow" mml-narrow-to-part t] - ["Quote" mml-quote-region t] - ["Validate" mml-validate t] + ["Quote MML" mml-quote-region t] + ["Validate MML" mml-validate t] ["Preview" mml-preview t])) (defvar mml-mode nil @@ -675,20 +884,17 @@ (defun mml-mode (&optional arg) "Minor mode for editing MML. +MML is the MIME Meta Language, a minor mode for composing MIME articles. +See Info node `(emacs-mime)Composing'. \\{mml-mode-map}" (interactive "P") - (if (not (set (make-local-variable 'mml-mode) - (if (null arg) (not mml-mode) - (> (prefix-numeric-value arg) 0)))) - nil - (set (make-local-variable 'mml-mode) t) - (unless (assq 'mml-mode minor-mode-alist) - (push `(mml-mode " MML") minor-mode-alist)) - (unless (assq 'mml-mode minor-mode-map-alist) - (push (cons 'mml-mode mml-mode-map) - minor-mode-map-alist))) - (run-hooks 'mml-mode-hook)) + (when (set (make-local-variable 'mml-mode) + (if (null arg) (not mml-mode) + (> (prefix-numeric-value arg) 0))) + (gnus-add-minor-mode 'mml-mode " MML" mml-mode-map) + (easy-menu-add mml-menu mml-mode-map) + (run-hooks 'mml-mode-hook))) ;;; ;;; Helper functions for reading MIME stuff from the minibuffer and @@ -696,8 +902,9 @@ ;;; (defun mml-minibuffer-read-file (prompt) - (let ((file (read-file-name prompt nil nil t))) - ;; Prevent some common errors. This is inspired by similar code in + (let* ((completion-ignored-extensions nil) + (file (read-file-name prompt nil nil t))) + ;; Prevent some common errors. This is inspired by similar code in ;; VM. (when (file-directory-p file) (error "%s is a directory, cannot attach" file)) @@ -728,6 +935,19 @@ (setq description nil)) description)) +(defun mml-minibuffer-read-disposition (type &optional default) + (let* ((default (or default + (if (string-match "^text/.*" type) + "inline" + "attachment"))) + (disposition (completing-read "Disposition: " + '(("attachment") ("inline") ("")) + nil + nil))) + (if (not (equal disposition "")) + disposition + default))) + (defun mml-quote-region (beg end) "Quote the MML tags in the region." (interactive "r") @@ -755,7 +975,9 @@ (when value ;; Quote VALUE if it contains suspicious characters. (when (string-match "[\"'\\~/*;() \t\n]" value) - (setq value (prin1-to-string value))) + (setq value (with-output-to-string + (let (print-escape-nonascii) + (prin1 value))))) (insert (format " %s=%s" key value))))) (insert ">\n")) @@ -768,7 +990,7 @@ ;;; Attachment functions. -(defun mml-attach-file (file &optional type description) +(defun mml-attach-file (file &optional type description disposition) "Attach a file to the outgoing MIME message. The file is not inserted or encoded until you send the message with `\\[message-send-and-exit]' or `\\[message-send]'. @@ -779,10 +1001,14 @@ (interactive (let* ((file (mml-minibuffer-read-file "Attach file: ")) (type (mml-minibuffer-read-type file)) - (description (mml-minibuffer-read-description))) - (list file type description))) - (mml-insert-empty-tag 'part 'type type 'filename file - 'disposition "attachment" 'description description)) + (description (mml-minibuffer-read-description)) + (disposition (mml-minibuffer-read-disposition type))) + (list file type description disposition))) + (mml-insert-empty-tag 'part + 'type type + 'filename file + 'disposition (or disposition "attachment") + 'description description)) (defun mml-attach-buffer (buffer &optional type description) "Attach a buffer to the outgoing MIME message. @@ -823,48 +1049,126 @@ (mml-insert-tag 'part 'type type 'disposition "inline") (forward-line -1)) +(defun mml-preview-insert-mail-followup-to () + "Insert a Mail-Followup-To header before previewing an article. +Should be adopted if code in `message-send-mail' is changed." + (when (and (message-mail-p) + (message-subscribed-p) + (not (mail-fetch-field "mail-followup-to")) + (message-make-mail-followup-to)) + (message-position-on-field "Mail-Followup-To" "X-Draft-From") + (insert (message-make-mail-followup-to)))) + (defun mml-preview (&optional raw) "Display current buffer with Gnus, in a new buffer. If RAW, don't highlight the article." (interactive "P") - (let ((buf (current-buffer)) - (message-posting-charset (or (gnus-setup-posting-charset - (save-restriction - (message-narrow-to-headers-or-head) - (message-fetch-field "Newsgroups"))) - message-posting-charset))) - (switch-to-buffer (get-buffer-create - (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) - (erase-buffer) - (insert-buffer buf) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t) - (replace-match "\n")) - (let ((mail-header-separator "")) ;; mail-header-separator is removed. - (mml-to-mime)) - (if raw - (when (fboundp 'set-buffer-multibyte) - (let ((s (buffer-string))) - ;; Insert the content into unibyte buffer. - (erase-buffer) - (mm-disable-multibyte) - (insert s))) - (let ((gnus-newsgroup-charset (car message-posting-charset))) - (run-hooks 'gnus-article-decode-hook) - (let ((gnus-newsgroup-name "dummy")) - (gnus-article-prepare-display)))) - ;; Disable article-mode-map. - (use-local-map nil) - (setq buffer-read-only t) - (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) - (goto-char (point-min)))) + (save-excursion + (let* ((buf (current-buffer)) + (message-options message-options) + (message-this-is-mail (message-mail-p)) + (message-this-is-news (message-news-p)) + (message-posting-charset (or (gnus-setup-posting-charset + (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups"))) + message-posting-charset))) + (message-options-set-recipient) + (switch-to-buffer (generate-new-buffer + (concat (if raw "*Raw MIME preview of " + "*MIME preview of ") (buffer-name)))) + (when (boundp 'gnus-buffers) + (push (current-buffer) gnus-buffers)) + (erase-buffer) + (insert-buffer-substring buf) + (mml-preview-insert-mail-followup-to) + (let ((message-deletable-headers (if (message-news-p) + nil + message-deletable-headers))) + (message-generate-headers + (copy-sequence (if (message-news-p) + message-required-news-headers + message-required-mail-headers)))) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t) + (replace-match "\n")) + (let ((mail-header-separator ""));; mail-header-separator is removed. + (mml-to-mime)) + (if raw + (when (fboundp 'set-buffer-multibyte) + (let ((s (buffer-string))) + ;; Insert the content into unibyte buffer. + (erase-buffer) + (mm-disable-multibyte) + (insert s))) + (let ((gnus-newsgroup-charset (car message-posting-charset)) + gnus-article-prepare-hook gnus-original-article-buffer) + (run-hooks 'gnus-article-decode-hook) + (let ((gnus-newsgroup-name "dummy") + (gnus-newsrc-hashtb (or gnus-newsrc-hashtb + (gnus-make-hashtable 5)))) + (gnus-article-prepare-display)))) + ;; Disable article-mode-map. + (use-local-map nil) + (gnus-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook + (lambda () + (mm-destroy-parts gnus-article-mime-handles)) nil t) + (setq buffer-read-only t) + (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) + (local-set-key "=" (lambda () (interactive) (delete-other-windows))) + (local-set-key "\r" + (lambda () + (interactive) + (widget-button-press (point)))) + (local-set-key gnus-mouse-2 + (lambda (event) + (interactive "@e") + (widget-button-press (widget-event-point event) event))) + (goto-char (point-min))))) (defun mml-validate () "Validate the current MML document." (interactive) (mml-parse)) +(defun mml-tweak-part (cont) + "Tweak a MML part." + (let ((tweak (cdr (assq 'tweak cont))) + func) + (cond + (tweak + (setq func + (or (cdr (assoc tweak mml-tweak-function-alist)) + (intern tweak)))) + (mml-tweak-type-alist + (let ((alist mml-tweak-type-alist) + (type (or (cdr (assq 'type cont)) "text/plain"))) + (while alist + (if (string-match (caar alist) type) + (setq func (cdar alist) + alist nil) + (setq alist (cdr alist))))))) + (if func + (funcall func cont) + cont) + (let ((alist mml-tweak-sexp-alist)) + (while alist + (if (eval (caar alist)) + (funcall (cdar alist) cont)) + (setq alist (cdr alist))))) + cont) + +(defun mml-tweak-externalize-attachments (cont) + "Tweak attached files as external parts." + (let (filename-cons) + (when (and (eq (car cont) 'part) + (not (cdr (assq 'buffer cont))) + (and (setq filename-cons (assq 'filename cont)) + (not (equal (cdr (assq 'nofile cont)) "yes")))) + (setcar cont 'external) + (setcar filename-cons 'name)))) + (provide 'mml) ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/mml1991.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,307 @@ +;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML +;; Copyright (C) 1998, 1999, 2000, 2001, 2003 Free Software Foundation, Inc. + +;; Author: Sascha Lüdecke <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 + (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 + (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 cte) + ;; 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))) + (when (string-match "^Content-Transfer-Encoding: \\(.+\\)" headers) + (setq cte (intern (match-string 1 headers)))) + (mm-decode-content-transfer-encoding cte) + (unless (let ((pgg-default-user-id + (or (message-options-get 'mml-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)) + (mm-with-unibyte-current-buffer + (insert-buffer-substring pgg-output-buffer) + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) + (mm-encode-content-transfer-encoding cte) + (goto-char (point-min)) + (when headers + (insert headers)) + (insert "\n")) + t)) + +(defun mml1991-pgg-encrypt (cont &optional sign) + (let (cte) + ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED + (goto-char (point-min)) + (while (looking-at "^Content[^ ]+:") + (when (looking-at "^Content-Transfer-Encoding: \\(.+\\)") + (setq cte (intern (match-string 1)))) + (forward-line)) + (unless (bobp) + (delete-region (point-min) (point))) + (mm-decode-content-transfer-encoding cte) + (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: + +;;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706 +;;; mml1991.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/mml2015.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,918 @@ +;;; 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)) +(require 'mm-decode) +(require 'mm-util) +(require 'mml) + +(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 (mml-compute-boundary cont)) + 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 + (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 (mml-compute-boundary cont))) + (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 (mml-compute-boundary cont)) + (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 (mml-compute-boundary cont)) + (text (current-buffer)) + cipher) + (mm-with-unibyte-current-buffer + (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 (mml-compute-boundary cont)) + (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 (mml-compute-boundary cont))) + (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) + +;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2 +;;; mml2015.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/netrc.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,129 @@ +;;; 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) + +;;; arch-tag: af9929cc-2d12-482f-936e-eb4366f9fa55 +;;; netrc.el ends here
--- a/lisp/gnus/next-ur.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/next-ur.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,66 +1,35 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 36 1", -" c Gray0", -". c Gray6", -"X c Gray9", -"o c Gray12", -"O c #23f323f323f3", -"+ c Gray15", -"@ c #2ff32ff32ff3", -"# c #399939993999", -"$ c #3fff3fff3fff", -"% c #433243324332", -"& c Gray28", -"* c #4ccc4ccc4ccc", -"= c #53ed53ed53ed", -"- c #5ff05ff05ff0", -"; c Gray40", -": c #67e767e767e7", -"> c #6ccc6ccc6ccc", -", c #6fff6fff6fff", -"< c Gray45", -"1 c #77f277f277f2", -"2 c #7bdb7bdb7bdb", -"3 c #7ccc7ccc7ccc", -"4 c Gray50", -"5 c #866586658665", -"6 c Gray56", -"7 c Gray60", -"8 c #9bd39bd39bd3", -"9 c #9fff9fff9fff", -"0 c Gray65", -"q c #a7c7a7c7a7c7", -"w c Gray70", -"e c Gray75", -"r c Gray81", -"t c #dfffdfffdfff", -"y c #efffefffefff", -"u c Gray100", -/* pixels */ -"wqewqewqewqewqewqewqewqe", -"q6eq6eq6eq6eq6eq6eq6eq6e", -"eeeeeeeeeeeeeeeeeeeeeeee", -"wqewqewqewq82$.wqewqewqe", -"q6eq6eq6e6@19u$-6eq6eq6e", -"eeeeeeee==eyr$9@eeeeeeee", -"wqewq82$ruuu or=qewqewqe", -"q6e6@19uuuu94eue-eq6eq6e", -"eeew&euuuuuruuuy18eeeeee", -"wqew-8uuuuuuuuuu92wqewqe", -"q6eq619uut44uuuuu$q6eq6e", -"eeeeee29,-e@uuuuur=eeeee", -"wqeee82$rye-$uuuuu=qewqe", -"q6eq-19uu- e$uuuuue-eq6e", -"ee==eyuuu -y99uuuuy18eee", -"w&euuuuu,uuue4uuuuu92wqe", -"q@euuuuuuuuut4tuuuueoq6e", -"eq=u9$$$ruuuu4@$$r$;6eee", -"wq=8,988%ruu8,98-+6qewqe", -"q6e+wq888$et+wq888X6eq6e", -"eee+88888.4-+88888@eeeee", -"wqeO#6884,uu*5885<&qewqe", -"q6eq@#**<uuut;**+&q6eq6e", -"eeeeqOeeyuuuuteee=eeeeee" -}; +static char * next_ur_xpm[] = { +"24 24 8 1", +". c None", +" c #000000000000", +"X c #A5A5A5A59595", +"o c #C7C7C6C6C6C6", +"O c #FFFF00000000", +"+ c #9A9A6C6C4E4E", +"@ c #E1E1E0E0E0E0", +"# c #FFFFFFFFFFFF", +" .. .. .. .. .. .. .. ..", +"........................", +"............X...........", +" .. .. .. .XXX. .. .. ..", +".........XXooOX.........", +".......XXooo+O@X........", +" .. XXXoooo++@@@X. .. ..", +"....X@Xoooooo@@@X.......", +"....X@@Xooo@@@@@@X......", +" .. X@@XXoo@@@@@@@X.. ..", +"....X@@Xoo@@@@@@@@@X....", +"....X@Xo@@@XX@@@@@@oX...", +" .. oXoo@XXooO@@@@@@X ..", +"....oXoXXooo+OX@@@@Xo...", +"....XXXoooo++@@X@@Xo....", +" .. X@Xoooooo@@@XX .. ..", +"....X@@Xooo@@@@@@X......", +"....X@@XXoo@@@@@@@X.....", +" .. X@@Xoo@@@@@@@@@X. ..", +"....X@Xo@ @@@@@@@ X...", +"... oXoo ## @@ @@ ## ...", +" .. oXo #### @ #### ..", +".....oX #### @@@ #### ..", +".....oX@ ## @@@@X ## ..."};
--- a/lisp/gnus/nnagent.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnagent.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,7 @@ ;;; nnagent.el --- offline backend for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc. + +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail @@ -121,68 +123,108 @@ (deffoo nnagent-request-set-mark (group action server) (with-temp-buffer (insert (format "(%s-request-set-mark \"%s\" '%s \"%s\")\n" - (nth 0 gnus-command-method) group action - (or server (nth 1 gnus-command-method)))) + (nth 0 gnus-command-method) group action + (or server (nth 1 gnus-command-method)))) (append-to-file (point-min) (point-max) (gnus-agent-lib-file "flags"))) nil) +(deffoo nnagent-retrieve-headers (articles &optional group server fetch-old) + (let ((file (gnus-agent-article-name ".overview" group)) + arts n first) + (save-excursion + (gnus-agent-load-alist group) + (setq arts (gnus-sorted-difference + articles (mapcar 'car gnus-agent-article-alist))) + ;; Assume that articles with smaller numbers than the first one + ;; Agent knows are gone. + (setq first (caar gnus-agent-article-alist)) + (when first + (while (and arts (< (car arts) first)) + (pop arts))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (nnheader-insert-nov-file file (car articles)) + (goto-char (point-min)) + (gnus-parse-without-error + (while (and arts (not (eobp))) + (setq n (read (current-buffer))) + (when (> n (car arts)) + (beginning-of-line)) + (while (and arts (> n (car arts))) + (insert (format + "%d\t[Undownloaded article %d]\tGnus Agent\t\t\t\n" + (car arts) (car arts))) + (pop arts)) + (when (and arts (= n (car arts))) + (pop arts)) + (forward-line 1))) + (while arts + (insert (format + "%d\t[Undownloaded article %d]\tGnus Agent\t\t\t\n" + (car arts) (car arts))) + (pop arts)) + (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) + 'nov))) + +(deffoo nnagent-request-expire-articles (articles group &optional server force) + articles) + (deffoo nnagent-request-group (group &optional server dont-check) (nnoo-parent-function 'nnagent 'nnml-request-group - (list group (nnagent-server server) dont-check))) + (list group (nnagent-server server) dont-check))) (deffoo nnagent-close-group (group &optional server) (nnoo-parent-function 'nnagent 'nnml-close-group - (list group (nnagent-server server)))) + (list group (nnagent-server server)))) (deffoo nnagent-request-accept-article (group &optional server last) (nnoo-parent-function 'nnagent 'nnml-request-accept-article - (list group (nnagent-server server) last))) + (list group (nnagent-server server) last))) (deffoo nnagent-request-article (id &optional group server buffer) (nnoo-parent-function 'nnagent 'nnml-request-article - (list id group (nnagent-server server) buffer))) + (list id group (nnagent-server server) buffer))) (deffoo nnagent-request-create-group (group &optional server args) (nnoo-parent-function 'nnagent 'nnml-request-create-group - (list group (nnagent-server server) args))) + (list group (nnagent-server server) args))) (deffoo nnagent-request-delete-group (group &optional force server) (nnoo-parent-function 'nnagent 'nnml-request-delete-group - (list group force (nnagent-server server)))) - -(deffoo nnagent-request-expire-articles (articles group &optional server force) - (nnoo-parent-function 'nnagent 'nnml-request-expire-articles - (list articles group (nnagent-server server) force))) + (list group force (nnagent-server server)))) (deffoo nnagent-request-list (&optional server) (nnoo-parent-function 'nnagent 'nnml-request-list - (list (nnagent-server server)))) + (list (nnagent-server server)))) (deffoo nnagent-request-list-newsgroups (&optional server) (nnoo-parent-function 'nnagent 'nnml-request-list-newsgroups - (list (nnagent-server server)))) + (list (nnagent-server server)))) (deffoo nnagent-request-move-article (article group server accept-form &optional last) (nnoo-parent-function 'nnagent 'nnml-request-move-article - (list article group (nnagent-server server) - accept-form last))) + (list article group (nnagent-server server) + accept-form last))) (deffoo nnagent-request-rename-group (group new-name &optional server) (nnoo-parent-function 'nnagent 'nnml-request-rename-group - (list group new-name (nnagent-server server)))) + (list group new-name (nnagent-server server)))) (deffoo nnagent-request-scan (&optional group server) (nnoo-parent-function 'nnagent 'nnml-request-scan - (list group (nnagent-server server)))) - -(deffoo nnagent-retrieve-headers (sequence &optional group server fetch-old) - (nnoo-parent-function 'nnagent 'nnml-retrieve-headers - (list sequence group (nnagent-server server) fetch-old))) + (list group (nnagent-server server)))) (deffoo nnagent-set-status (article name value &optional group server) (nnoo-parent-function 'nnagent 'nnml-set-status - (list article name value group (nnagent-server server)))) + (list article name value group (nnagent-server server)))) (deffoo nnagent-server-opened (&optional server) (nnoo-parent-function 'nnagent 'nnml-server-opened @@ -192,6 +234,10 @@ (nnoo-parent-function 'nnagent 'nnml-status-message (list (nnagent-server server)))) +(deffoo nnagent-request-regenerate (server) + (nnoo-parent-function 'nnagent 'nnml-request-regenerate + (list (nnagent-server server)))) + ;; Use nnml functions for just about everything. (nnoo-import nnagent (nnml))
--- a/lisp/gnus/nnbabyl.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnbabyl.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,10 +1,10 @@ ;;; nnbabyl.el --- rmail mbox access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1099, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1099, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -51,6 +51,7 @@ (defvoo nnbabyl-get-new-mail t "If non-nil, nnbabyl will check the incoming mail file and split the mail.") + (defvoo nnbabyl-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") @@ -287,7 +288,8 @@ (current-buffer)) (let ((nnml-current-directory nil)) (nnmail-expiry-target-group - nnmail-expiry-target newsgroup)))) + nnmail-expiry-target newsgroup))) + (nnbabyl-possibly-change-newsgroup newsgroup server)) (nnheader-message 5 "Deleting article %d in %s..." (car articles) newsgroup) (nnbabyl-delete-mail)) @@ -347,7 +349,10 @@ (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) (delete-region (point) (progn (forward-line 1) (point))))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) (setq result (if (stringp group) (list (cons group (nnbabyl-active-number group))) @@ -363,7 +368,10 @@ (insert-buffer-substring buf) (when last (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) (save-buffer) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) result))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nndb.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,331 @@ +;;; nndb.el --- nndb access for Gnus + +;; Copyright (C) 1997, 1998, 2000, 2003 Free Software Foundation, Inc. + +;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de> +;; Joe Hildebrand <joe.hildebrand@ilg.com> +;; David Blacka <davidb@rwhois.net> +;; 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: + +;;; This was based upon Kai Grossjohan's shamessly snarfed code and +;;; further modified by Joe Hildebrand. It has been updated for Red +;;; Gnus. + +;; TODO: +;; +;; * Fix bug where server connection can be lost and impossible to regain +;; This hasn't happened to me in a while; think it was fixed in Rgnus +;; +;; * make it handle different nndb servers seemlessly +;; +;; * Optimize expire if FORCE +;; +;; * Optimize move (only expire once) +;; +;; * Deal with add/deletion of groups +;; +;; * make the backend TOUCH an article when marked as expireable (will +;; make article expire 'expiry' days after that moment). + +;;- +;; Register nndb with known select methods. + +(gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address) + +;;; Code: + +(require 'nnmail) +(require 'nnheader) +(require 'nntp) +(eval-when-compile (require 'cl)) + +(eval-and-compile + (unless (fboundp 'open-network-stream) + (require 'tcp))) + +(eval-when-compile (require 'cl)) + +(eval-and-compile + (autoload 'news-setup "rnewspost") + (autoload 'news-reply-mode "rnewspost") + (autoload 'cancel-timer "timer") + (autoload 'telnet "telnet" nil t) + (autoload 'telnet-send-input "telnet" nil t) + (autoload 'gnus-declare-backend "gnus-start")) + +;; Declare nndb as derived from nntp + +(nnoo-declare nndb nntp) + +;; Variables specific to nndb + +;;- currently not used but just in case... +(defvoo nndb-deliver-program "nndel" + "*The program used to put a message in an NNDB group.") + +(defvoo nndb-server-side-expiry nil + "If t, expiry calculation will occur on the server side.") + +(defvoo nndb-set-expire-date-on-mark nil + "If t, the expiry date for a given article will be set to the time +it was marked as expireable; otherwise the date will be the time the +article was posted to nndb") + +;; Variables copied from nntp + +(defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) + "Like nntp-server-opened-hook." + nntp-server-opened-hook) + +(defvoo nndb-address "localhost" + "*The name of the NNDB server." + nntp-address) + +(defvoo nndb-port-number 9000 + "*Port number to connect to." + nntp-port-number) + +;; change to 'news if you are actually using nndb for news +(defvoo nndb-article-type 'mail) + +(defvoo nndb-status-string nil "" nntp-status-string) + + + +(defconst nndb-version "nndb 0.7" + "Version numbers of this version of NNDB.") + + +;;; Interface functions. + +(nnoo-define-basics nndb) + +;;------------------------------------------------------------------ + +;; this function turns the lisp list into a string list. There is +;; probably a more efficient way to do this. +(defun nndb-build-article-string (articles) + (let (art-string art) + (while articles + (setq art (pop articles)) + (setq art-string (concat art-string art " "))) + art-string)) + +(defun nndb-build-expire-rest-list (total expire) + (let (art rest) + (while total + (setq art (pop total)) + (if (memq art expire) + () + (push art rest))) + rest)) + + +;; +(deffoo nndb-request-type (group &optional article) + nndb-article-type) + +;; nndb-request-update-info does not exist and is not needed + +;; nndb-request-update-mark does not exist; it should be used to TOUCH +;; articles as they are marked exipirable +(defun nndb-touch-article (group article) + (nntp-send-command nil "X-TOUCH" article)) + +(deffoo nndb-request-update-mark + (group article mark) + "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" + (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) + (nndb-touch-article group article)) + mark) + +;; nndb-request-create-group -- currently this isn't necessary; nndb +;; creates groups on demand. + +;; todo -- use some other time than the creation time of the article +;; best is time since article has been marked as expirable + +(defun nndb-request-expire-articles-local + (articles &optional group server force) + "Let gnus do the date check and issue the delete commands." + (let (msg art delete-list (num-delete 0) rest) + (nntp-possibly-change-group group server) + (while articles + (setq art (pop articles)) + (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art) + (setq msg (nndb-status-message)) + (if (string-match "^423" msg) + () + (or (string-match "'\\(.+\\)'" msg) + (error "Not a valid response for X-DATE command: %s" + msg)) + (if (nnmail-expired-article-p + group + (date-to-time (substring msg (match-beginning 1) (match-end 1))) + force) + (progn + (setq delete-list (concat delete-list " " (int-to-string art))) + (setq num-delete (1+ num-delete))) + (push art rest)))) + (if (> (length delete-list) 0) + (progn + (nnheader-message 5 "Deleting %s article(s) from %s" + (int-to-string num-delete) group) + (nntp-send-command "^[23].*\n" "X-DELETE" delete-list)) + ) + + (nnheader-message 5 "") + (nconc rest articles))) + +(defun nndb-get-remote-expire-response () + (let (list) + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (if (looking-at "^[34]") + ;; x-expire returned error--presume no articles were expirable) + (setq list nil) + ;; otherwise, pull all of the following numbers into the list + (re-search-forward "follows\r?\n?" nil t) + (while (re-search-forward "^[0-9]+$" nil t) + (push (string-to-int (match-string 0)) list))) + list)) + +(defun nndb-request-expire-articles-remote + (articles &optional group server force) + "Let the nndb backend expire articles" + (let (days art-string delete-list (num-delete 0)) + (nntp-possibly-change-group group server) + + ;; first calculate the wait period in days + (setq days (or (and nnmail-expiry-wait-function + (funcall nnmail-expiry-wait-function group)) + nnmail-expiry-wait)) + ;; now handle the special cases + (cond (force + (setq days 0)) + ((eq days 'never) + ;; This isn't an expirable group. + (setq days -1)) + ((eq days 'immediate) + (setq days 0))) + + + ;; build article string + (setq art-string (concat days " " (nndb-build-article-string articles))) + (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string) + + (setq delete-list (nndb-get-remote-expire-response)) + (setq num-delete (length delete-list)) + (if (> num-delete 0) + (nnheader-message 5 "Deleting %s article(s) from %s" + (int-to-string num-delete) group)) + + (nndb-build-expire-rest-list articles delete-list))) + +(deffoo nndb-request-expire-articles + (articles &optional group server force) + "Expires ARTICLES from GROUP on SERVER. +If FORCE, delete regardless of exiration date, otherwise use normal +expiry mechanism." + (if nndb-server-side-expiry + (nndb-request-expire-articles-remote articles group server force) + (nndb-request-expire-articles-local articles group server force))) + +(deffoo nndb-request-move-article + (article group server accept-form &optional last) + "Move ARTICLE (a number) from GROUP on SERVER. +Evals ACCEPT-FORM in current buffer, where the article is. +Optional LAST is ignored." + ;; we guess that the second arg in accept-form is the new group, + ;; which it will be for nndb, which is all that matters anyway + (let ((new-group (nth 1 accept-form)) result) + (nntp-possibly-change-group group server) + + ;; use the move command for nndb-to-nndb moves + (if (string-match "^nndb" new-group) + (let ((new-group-name (gnus-group-real-name new-group))) + (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name) + (cons new-group article)) + ;; else move normally + (let ((artbuf (get-buffer-create " *nndb move*"))) + (and + (nndb-request-article article group server artbuf) + (save-excursion + (set-buffer artbuf) + (insert-buffer-substring nntp-server-buffer) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (nndb-request-expire-articles (list article) + group + server + t)) + result) + ))) + +(deffoo nndb-request-accept-article (group server &optional last) + "The article in the current buffer is put into GROUP." + (nntp-possibly-change-group group server) + (let (art msg) + (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) + (nnheader-insert "") + (nntp-send-buffer "^[23].*\n")) + + (set-buffer nntp-server-buffer) + (setq msg (buffer-string)) + (or (string-match "^\\([0-9]+\\)" msg) + (error "nndb: %s" msg)) + (setq art (substring msg (match-beginning 1) (match-end 1))) + (nnheader-message 5 "nndb: accepted %s" art) + (list art))) + +(deffoo nndb-request-replace-article (article group buffer) + "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER." + (set-buffer buffer) + (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) + (nnheader-insert "") + (nntp-send-buffer "^[23.*\n") + (list (int-to-string article)))) + + ; nndb-request-delete-group does not exist + ; todo -- maybe later + + ; nndb-request-rename-group does not exist + ; todo -- maybe later + +;; -- standard compatability functions + +(deffoo nndb-status-message (&optional server) + "Return server status as a string." + (set-buffer nntp-server-buffer) + (buffer-string)) + +;; Import stuff from nntp + +(nnoo-import nndb + (nntp)) + +(provide 'nndb) + +;;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a +;;; nndb.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nndiary.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,1712 @@ +;;; 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.") + + + +(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 + (nnmail-fetch-field "subject"))) + (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)))) + + +;;; 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)) + + + +;;; 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) + + +;;; arch-tag: 9c542b95-92e7-4ace-a038-330ab296e203 +;;; nndiary.el ends here
--- a/lisp/gnus/nndoc.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nndoc.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; nndoc.el --- single file access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -58,9 +58,16 @@ `((mmdf (article-begin . "^\^A\^A\^A\^A\n") (body-end . "^\^A\^A\^A\^A\n")) - (exim-bounce - (article-begin . "^------ This is a copy of the message, including all the headers. ------\n\n") - (body-end-function . nndoc-exim-bounce-body-end-function)) + (mime-digest + (article-begin . "") + (head-begin . "^ ?\n") + (head-end . "^ ?$") + (body-end . "") + (file-end . "") + (subtype digest guess)) + (mime-parts + (generate-head-function . nndoc-generate-mime-parts-head) + (article-transform-function . nndoc-transform-mime-parts)) (nsmail (article-begin . "^From - ")) (news @@ -76,6 +83,9 @@ (body-end . "\^_") (body-begin-function . nndoc-babyl-body-begin) (head-begin-function . nndoc-babyl-head-begin)) + (exim-bounce + (article-begin . "^------ This is a copy of the message, including all the headers. ------\n\n") + (body-end-function . nndoc-exim-bounce-body-end-function)) (rfc934 (article-begin . "^--.*\n+") (body-end . "^--.*$") @@ -91,16 +101,7 @@ (head-end . "^\t") (generate-head-function . nndoc-generate-clari-briefs-head) (article-transform-function . nndoc-transform-clari-briefs)) - (mime-digest - (article-begin . "") - (head-begin . "^ ?\n") - (head-end . "^ ?$") - (body-end . "") - (file-end . "") - (subtype digest guess)) - (mime-parts - (generate-head-function . nndoc-generate-mime-parts-head) - (article-transform-function . nndoc-transform-mime-parts)) + (standard-digest (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+")) (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+")) @@ -393,7 +394,7 @@ (error "Document is not of any recognized type")) (if result (car entry) - (cadar (sort results 'car-less-than-car))))) + (cadar (last (sort results 'car-less-than-car)))))) ;;; ;;; Built-in type predicates and functions @@ -771,7 +772,7 @@ "Go through the document and partition it into heads/bodies/articles." (let ((i 0) (first t) - head-begin head-end body-begin body-end) + art-begin head-begin head-end body-begin body-end) (setq nndoc-dissection-alist nil) (save-excursion (set-buffer nndoc-current-buffer) @@ -787,8 +788,11 @@ ;; Go through the file. (while (if (and first nndoc-first-article) (nndoc-search nndoc-first-article) - (nndoc-article-begin)) - (setq first nil) + (if art-begin + (goto-char art-begin) + (nndoc-article-begin))) + (setq first nil + art-begin nil) (cond (nndoc-head-begin-function (funcall nndoc-head-begin-function)) (nndoc-head-begin @@ -808,7 +812,8 @@ (funcall nndoc-body-end-function)) (and nndoc-body-end (nndoc-search nndoc-body-end)) - (nndoc-article-begin) + (and (nndoc-article-begin) + (setq art-begin (point))) (progn (goto-char (point-max)) (when nndoc-file-end @@ -890,7 +895,7 @@ subtype "plain")) ;; Prepare the article and summary inserts. (unless article-insert - (setq article-insert (buffer-substring (point-min) (point-max)) + (setq article-insert (buffer-string) head-end head-begin)) ;; Fix MIME-Version (unless (string-match "MIME-Version:" article-insert)
--- a/lisp/gnus/nndraft.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nndraft.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; nndraft.el --- draft article access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -32,10 +33,7 @@ (require 'nnmh) (require 'nnoo) (require 'mm-util) -(eval-when-compile - (require 'cl) - ;; This is just to shut up the byte-compiler. - (fset 'nndraft-request-group 'ignore)) +(eval-when-compile (require 'cl)) (nnoo-declare nndraft nnmh) @@ -113,7 +111,7 @@ (when (and (file-exists-p newest) (let ((nnmail-file-coding-system (if (file-newer-than-file-p file auto) - (if (equal group "drafts") + (if (member group '("drafts" "delayed")) message-draft-coding-system mm-text-coding-system) mm-auto-save-coding-system))) @@ -124,7 +122,7 @@ ;; If there's a mail header separator in this file, ;; we remove it. (when (re-search-forward - (concat "^" mail-header-separator "$") nil t) + (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t))) t)))) @@ -134,6 +132,9 @@ (when (nndraft-request-article article group server (current-buffer)) (message-remove-header "xref") (message-remove-header "lines") + ;; Articles in nndraft:queue are considered as sent messages. The + ;; Date field should be the time when they are sent. + ;;(message-remove-header "date") t)) (deffoo nndraft-request-update-info (group info &optional server) @@ -151,6 +152,12 @@ nil)))) t) +(defun nndraft-generate-headers () + (save-excursion + (message-generate-headers + (message-headers-to-generate + message-required-headers message-draft-headers nil)))) + (deffoo nndraft-request-associate-buffer (group) "Associate the current buffer with some article in the draft group." (nndraft-open-server "") @@ -167,8 +174,45 @@ (setq buffer-file-name (expand-file-name file) buffer-auto-save-file-name (make-auto-save-file-name)) (clear-visited-file-modtime) + (make-local-variable 'write-contents-hooks) + (push 'nndraft-generate-headers write-contents-hooks) article)) +(deffoo nndraft-request-group (group &optional server dont-check) + (nndraft-possibly-change-group group) + (unless dont-check + (let* ((pathname (nnmail-group-pathname group nndraft-directory)) + (file-name-coding-system nnmail-pathname-coding-system) + dir file) + (nnheader-re-read-dir pathname) + (setq dir (mapcar (lambda (name) (string-to-int (substring name 1))) + (ignore-errors (directory-files + pathname nil "^#[0-9]+#$" t)))) + (dolist (n dir) + (unless (file-exists-p + (setq file (expand-file-name (int-to-string n) pathname))) + (rename-file (nndraft-auto-save-file-name file) file))))) + (nnoo-parent-function 'nndraft + 'nnmh-request-group + (list group server dont-check))) + +(deffoo nndraft-request-move-article (article group server + accept-form &optional last) + (nndraft-possibly-change-group group) + (let ((buf (get-buffer-create " *nndraft move*")) + result) + (and + (nndraft-request-article article group server) + (save-excursion + (set-buffer buf) + (erase-buffer) + (insert-buffer-substring nntp-server-buffer) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (null (nndraft-request-expire-articles (list article) group server 'force)) + result))) + (deffoo nndraft-request-expire-articles (articles group &optional server force) (nndraft-possibly-change-group group) (let* ((nnmh-allow-delete-final t) @@ -201,8 +245,8 @@ (deffoo nndraft-request-replace-article (article group buffer) (nndraft-possibly-change-group group) (let ((nnmail-file-coding-system - (if (equal group "drafts") - mm-auto-save-coding-system + (if (member group '("drafts" "delayed")) + message-draft-coding-system mm-text-coding-system))) (nnoo-parent-function 'nndraft 'nnmh-request-replace-article (list article group buffer)))) @@ -259,8 +303,7 @@ nnmh-request-group nnmh-close-group nnmh-request-list - nnmh-request-newsgroups - nnmh-request-move-article)) + nnmh-request-newsgroups)) (provide 'nndraft)
--- a/lisp/gnus/nneething.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nneething.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,10 +1,10 @@ ;;; nneething.el --- arbitrary file access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -64,7 +64,6 @@ (defvoo nneething-status-string "") -(defvoo nneething-message-id-number 0) (defvoo nneething-work-buffer " *nneething work*") (defvoo nneething-group nil) @@ -122,15 +121,27 @@ (let ((file (unless (stringp id) (nneething-file-name id))) (nntp-server-buffer (or buffer nntp-server-buffer))) - (and (stringp file) ; We did not request by Message-ID. + (and (stringp file) ; We did not request by Message-ID. (file-exists-p file) ; The file exists. (not (file-directory-p file)) ; It's not a dir. (save-excursion - (nnmail-find-file file) ; Insert the file in the nntp buf. + (let ((nnmail-file-coding-system 'binary)) + (nnmail-find-file file)) ; Insert the file in the nntp buf. (unless (nnheader-article-p) ; Either it's a real article... - (goto-char (point-min)) - (nneething-make-head - file (current-buffer)) ; ... or we fake some headers. + (let ((type + (unless (file-directory-p file) + (or (cdr (assoc (concat "." (file-name-extension file)) + mailcap-mime-extensions)) + "text/plain"))) + (charset + (mm-detect-mime-charset-region (point-min) (point-max))) + (encoding)) + (unless (string-match "\\`text/" type) + (base64-encode-region (point-min) (point-max)) + (setq encoding "base64")) + (goto-char (point-min)) + (nneething-make-head file (current-buffer) + nil type charset encoding)) (insert "\n")) t)))) @@ -234,7 +245,7 @@ prev) (while map (if (and (member (cadr (car map)) files) - ;; We also remove files that have changed mod times. + ;; We also remove files that have changed mod times. (equal (nth 5 (file-attributes (nneething-file-name (cadr (car map))))) (cadr (cdar map)))) @@ -272,13 +283,42 @@ (insert-buffer-substring nneething-work-buffer) (goto-char (point-max)))) -(defun nneething-make-head (file &optional buffer) +(defun nneething-encode-file-name (file &optional coding-system) + "Encode the name of the FILE in CODING-SYSTEM." + (let ((pos 0) buf) + (setq file (mm-encode-coding-string + file (or coding-system nnmail-pathname-coding-system))) + (while (string-match "[^-0-9a-zA-Z_:/.]" file pos) + (setq buf (cons (format "%%%02x" (aref file (match-beginning 0))) + (cons (substring file pos (match-beginning 0)) buf)) + pos (match-end 0))) + (apply (function concat) + (nreverse (cons (substring file pos) buf))))) + +(defun nneething-decode-file-name (file &optional coding-system) + "Decode the name of the FILE is encoded in CODING-SYSTEM." + (let ((pos 0) buf) + (while (string-match "%\\([0-9a-fA-F][0-9a-fA-F]\\)" file pos) + (setq buf (cons (string (string-to-number (match-string 1 file) 16)) + (cons (substring file pos (match-beginning 0)) buf)) + pos (match-end 0))) + (decode-coding-string + (apply (function concat) + (nreverse (cons (substring file pos) buf))) + (or coding-system nnmail-pathname-coding-system)))) + +(defun nneething-get-file-name (id) + "Extract the file name from the message ID string." + (when (string-match "\\`<nneething-\\([^@]+\\)@.*>\\'" id) + (nneething-decode-file-name (match-string 1 id)))) + +(defun nneething-make-head (file &optional buffer extra-msg + mime-type mime-charset mime-encoding) "Create a head by looking at the file attributes of FILE." (let ((atts (file-attributes file))) (insert - "Subject: " (file-name-nondirectory file) "\n" - "Message-ID: <nneething-" - (int-to-string (incf nneething-message-id-number)) + "Subject: " (file-name-nondirectory file) (or extra-msg "") "\n" + "Message-ID: <nneething-" (nneething-encode-file-name file) "@" (system-name) ">\n" (if (equal '(0 0) (nth 5 atts)) "" (concat "Date: " (current-time-string (nth 5 atts)) "\n")) @@ -297,6 +337,19 @@ (concat "Lines: " (int-to-string (count-lines (point-min) (point-max))) "\n")) + "") + (if mime-type + (concat "Content-Type: " mime-type + (if mime-charset + (concat "; charset=" + (if (stringp mime-charset) + mime-charset + (symbol-name mime-charset))) + "") + (if mime-encoding + (concat "\nContent-Transfer-Encoding: " mime-encoding) + "") + "\nMIME-Version: 1.0\n") "")))) (defun nneething-from-line (uid &optional file) @@ -344,24 +397,28 @@ (nneething-make-head file) t) (t ;; We examine the file. - (nnheader-insert-head file) - (if (nnheader-article-p) - (delete-region - (progn - (goto-char (point-min)) - (or (and (search-forward "\n\n" nil t) - (1- (point))) - (point-max))) - (point-max)) - (goto-char (point-min)) - (nneething-make-head file (current-buffer)) - (delete-region (point) (point-max))) + (condition-case () + (progn + (nnheader-insert-head file) + (if (nnheader-article-p) + (delete-region + (progn + (goto-char (point-min)) + (or (and (search-forward "\n\n" nil t) + (1- (point))) + (point-max))) + (point-max)) + (goto-char (point-min)) + (nneething-make-head file (current-buffer)) + (delete-region (point) (point-max)))) + (file-error + (nneething-make-head file (current-buffer) " (unreadable)"))) t)))) (defun nneething-file-name (article) "Return the file name of ARTICLE." (let ((dir (file-name-as-directory nneething-address)) - fname) + fname) (if (numberp article) (if (setq fname (cadr (assq article nneething-map))) (expand-file-name fname dir)
--- a/lisp/gnus/nnfolder.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnfolder.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,10 +1,12 @@ ;;; nnfolder.el --- mail folder access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. -;; Author: Scott Byer <byer@mv.us.adobe.com> +;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS) +;; ShengHuo Zhu <zsh@cs.rochester.edu> (adding NOV) +;; Scott Byer <byer@mv.us.adobe.com> ;; Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: mail ;; This file is part of GNU Emacs. @@ -33,14 +35,27 @@ (require 'nnmail) (require 'nnoo) (eval-when-compile (require 'cl)) +(require 'gnus) (require 'gnus-util) (require 'gnus-range) +(eval-and-compile + (autoload 'gnus-article-unpropagatable-p "gnus-sum") + (autoload 'gnus-intersection "gnus-range")) + (nnoo-declare nnfolder) (defvoo nnfolder-directory (expand-file-name message-directory) "The name of the nnfolder directory.") +(defvoo nnfolder-nov-directory nil + "The name of the nnfolder NOV directory. +If nil, `nnfolder-directory' is used.") + +(defvoo nnfolder-marks-directory nil + "The name of the nnfolder MARKS directory. +If nil, `nnfolder-directory' is used.") + (defvoo nnfolder-active-file (nnheader-concat nnfolder-directory "active") "The name of the active file.") @@ -76,12 +91,13 @@ (defvoo nnfolder-save-buffer-hook nil "Hook run before saving the nnfolder mbox buffer.") + (defvoo nnfolder-inhibit-expiry nil "If non-nil, inhibit expiry.") -(defconst nnfolder-version "nnfolder 1.0" +(defconst nnfolder-version "nnfolder 2.0" "nnfolder version.") (defconst nnfolder-article-marker "X-Gnus-Article-Number: " @@ -100,7 +116,37 @@ (defvoo nnfolder-file-coding-system mm-text-coding-system) (defvoo nnfolder-file-coding-system-for-write nnheader-file-coding-system "Coding system for save nnfolder file. -If nil, `nnfolder-file-coding-system' is used.") +if nil, `nnfolder-file-coding-system' is used.") ; FIXME: fill-in the doc-string of this variable + +(defvoo nnfolder-nov-is-evil nil + "If non-nil, Gnus will never generate and use nov databases for mail 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 `nnfolder-generate-active-file' command. The function will go +through all nnfolder directories and generate nov databases for them +all. This may very well take some time.") + +(defvoo nnfolder-nov-file-suffix ".nov") + +(defvoo nnfolder-nov-buffer-alist nil) + +(defvar nnfolder-nov-buffer-file-name nil) + +(defvoo nnfolder-marks-is-evil nil + "If non-nil, Gnus will never generate and use marks file for mail groups. +Using marks files makes it possible to backup and restore mail groups +separately from `.newsrc.eld'. If you have, for some reason, set +this to t, and want to set it to nil again, you should always remove +the corresponding marks file (usually base nnfolder file name +concatenated with `.mrk', but see `nnfolder-marks-file-suffix') for +the group. Then the marks file will be regenerated properly by Gnus.") + +(defvoo nnfolder-marks nil) + +(defvoo nnfolder-marks-file-suffix ".mrk") + +(defvar nnfolder-marks-modtime (gnus-make-hashtable)) @@ -112,34 +158,82 @@ (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) - (let (article start stop) + (let (article start stop num) (nnfolder-possibly-change-group group server) (when nnfolder-current-buffer (set-buffer nnfolder-current-buffer) (goto-char (point-min)) (if (stringp (car articles)) 'headers - (while (setq article (pop articles)) - (set-buffer nnfolder-current-buffer) - (when (nnfolder-goto-article article) - (setq start (point)) - (setq stop (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max))) - (set-buffer nntp-server-buffer) - (insert (format "221 %d Article retrieved.\n" article)) - (insert-buffer-substring nnfolder-current-buffer start stop) - (goto-char (point-max)) - (insert ".\n"))) + (if (nnfolder-retrieve-headers-with-nov articles fetch-old) + 'nov + (setq articles (gnus-sorted-intersection + ;; Is ARTICLES sorted? + (sort articles '<) + (nnfolder-existing-articles))) + (while (setq article (pop articles)) + (set-buffer nnfolder-current-buffer) + (cond ((nnfolder-goto-article article) + (setq start (point)) + (setq stop (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (set-buffer nntp-server-buffer) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring nnfolder-current-buffer + start stop) + (goto-char (point-max)) + (insert ".\n")) - (set-buffer nntp-server-buffer) - (nnheader-fold-continuation-lines) - 'headers))))) + ;; If we couldn't find this article, skip over ranges + ;; of missing articles so we don't search the whole file + ;; for each of them. + ((numberp article) + (setq start (point)) + (and + ;; Check that we are either at BOF or after an + ;; article with a lower number. We do this so we + ;; won't be confused by out-of-order article numbers, + ;; as caused by active file bogosity. + (cond + ((bobp)) + ((search-backward (concat "\n" nnfolder-article-marker) + nil t) + (goto-char (match-end 0)) + (setq num (string-to-int + (buffer-substring + (point) (gnus-point-at-eol)))) + (goto-char start) + (< num article))) + ;; Check that we are before an article with a + ;; higher number. + (search-forward (concat "\n" nnfolder-article-marker) + nil t) + (progn + (setq num (string-to-int + (buffer-substring + (point) (gnus-point-at-eol)))) + (> num article)) + ;; Discard any article numbers before the one we're + ;; now looking at. + (while (and articles + (< (car articles) num)) + (setq articles (cdr articles)))) + (goto-char start)))) + (set-buffer nntp-server-buffer) + (nnheader-fold-continuation-lines) + 'headers)))))) (deffoo nnfolder-open-server (server &optional defs) (nnoo-change-server 'nnfolder server defs) (nnmail-activate 'nnfolder t) (gnus-make-directory nnfolder-directory) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (and nnfolder-nov-directory + (gnus-make-directory nnfolder-nov-directory))) + (unless nnfolder-marks-is-evil + (and nnfolder-marks-directory + (gnus-make-directory nnfolder-marks-directory))) (cond ((not (file-exists-p nnfolder-directory)) (nnfolder-close-server) @@ -191,9 +285,8 @@ (cons nnfolder-current-group (if (search-forward (concat "\n" nnfolder-article-marker) nil t) - (string-to-int - (buffer-substring - (point) (progn (end-of-line) (point)))) + (string-to-int (buffer-substring + (point) (gnus-point-at-eol))) -1)))))))) (deffoo nnfolder-request-group (group &optional server dont-check) @@ -313,13 +406,13 @@ (let ((marker (concat "\n" nnfolder-article-marker)) (number "[0-9]+") numbers) - (while (and (search-forward marker nil t) (re-search-forward number nil t)) (let ((newnum (string-to-number (match-string 0)))) (if (nnmail-within-headers-p) (push newnum numbers)))) - numbers)))) + ;; The article numbers are increasing, so this result is sorted. + (nreverse numbers))))) (deffoo nnfolder-request-expire-articles (articles newsgroup &optional server force) @@ -330,7 +423,7 @@ ;; The articles that really exist and will ;; be expired if they are old enough. (maybe-expirable - (gnus-intersection articles (nnfolder-existing-articles)))) + (gnus-sorted-intersection articles (nnfolder-existing-articles)))) (nnmail-activate 'nnfolder) (save-excursion @@ -354,12 +447,15 @@ (with-temp-buffer (nnfolder-request-article (car maybe-expirable) newsgroup server (current-buffer)) - (let ((nnml-current-directory nil)) + (let ((nnfolder-current-directory nil)) (nnmail-expiry-target-group - nnmail-expiry-target newsgroup)))) + nnmail-expiry-target newsgroup))) + (nnfolder-possibly-change-group newsgroup server)) (nnheader-message 5 "Deleting article %d in %s..." (car maybe-expirable) newsgroup) (nnfolder-delete-mail) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (nnfolder-nov-delete-article newsgroup (car maybe-expirable))) ;; Must remember which articles were actually deleted (push (car maybe-expirable) deleted-articles))) (setq maybe-expirable (cdr maybe-expirable))) @@ -368,7 +464,7 @@ (nnfolder-save-buffer) (nnfolder-adjust-min-active newsgroup) (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) - (gnus-sorted-complement articles (nreverse deleted-articles))))) + (gnus-sorted-difference articles (nreverse deleted-articles))))) (deffoo nnfolder-request-move-article (article group server accept-form &optional last) @@ -386,8 +482,7 @@ (concat "^" nnfolder-article-marker) (save-excursion (and (search-forward "\n\n" nil t) (point))) t) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (gnus-delete-line)) (setq result (eval accept-form)) (kill-buffer buf) result) @@ -397,6 +492,8 @@ (goto-char (point-min)) (when (nnfolder-goto-article article) (nnfolder-delete-mail)) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (nnfolder-nov-delete-article group article)) (when last (nnfolder-save-buffer) (nnfolder-adjust-min-active group) @@ -414,33 +511,38 @@ (replace-match "From ") (while (progn (forward-line) (looking-at "[ \t]")) (delete-char -1))) - (and - (nnfolder-request-list) - (save-excursion - (set-buffer buf) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (forward-line -1) - (goto-char (point-max))) - (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) - (delete-region (point) (progn (forward-line 1) (point)))) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) - (setq result (if (stringp group) - (list (cons group (nnfolder-active-number group))) - (setq art-group - (nnmail-article-group 'nnfolder-active-number)))) - (if (and (null result) - (yes-or-no-p "Moved to `junk' group; delete article? ")) - (setq result 'junk) - (setq result - (car (nnfolder-save-mail result))))) - (when last - (save-excursion - (nnfolder-possibly-change-folder (or (caar art-group) group)) - (nnfolder-save-buffer) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-close))))) + (with-temp-buffer + (let ((nnmail-file-coding-system nnfolder-active-file-coding-system) + (nntp-server-buffer (current-buffer))) + (nnmail-find-file nnfolder-active-file) + (setq nnfolder-group-alist (nnmail-parse-active)))) + (save-excursion + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (forward-line -1) + (goto-char (point-max))) + (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) + (delete-region (point) (progn (forward-line 1) (point)))) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) + (setq result (if (stringp group) + (list (cons group (nnfolder-active-number group))) + (setq art-group + (nnmail-article-group 'nnfolder-active-number)))) + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result + (car (nnfolder-save-mail result))))) + (when last + (save-excursion + (nnfolder-possibly-change-folder (or (caar art-group) group)) + (nnfolder-save-buffer) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-close)))) (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) (unless result (nnheader-report 'nnfolder "Couldn't store article")) @@ -451,15 +553,13 @@ (save-excursion (set-buffer buffer) (goto-char (point-min)) - (let (xfrom) - (while (re-search-forward "^X-From-Line: \\(.*\\)$" nil t) - (setq xfrom (match-string 1)) - (gnus-delete-line)) - (goto-char (point-min)) - (if xfrom - (insert "From " xfrom "\n") - (unless (looking-at "From ") - (insert "From nobody " (current-time-string) "\n")))) + (if (not (looking-at "X-From-Line: ")) + (insert "From nobody " (current-time-string) "\n") + (replace-match "From ") + (forward-line 1) + (while (looking-at "[ \t]") + (delete-char -1) + (forward-line 1))) (nnfolder-normalize-buffer) (set-buffer nnfolder-current-buffer) (goto-char (point-min)) @@ -467,6 +567,15 @@ nil (nnfolder-delete-mail) (insert-buffer-substring buffer) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (save-excursion + (set-buffer buffer) + (let ((headers (nnfolder-parse-head article + (point-min) (point-max)))) + (with-current-buffer (nnfolder-open-nov group) + (if (nnheader-find-nov-line article) + (delete-region (point) (progn (forward-line 1) (point)))) + (nnheader-insert-nov headers))))) (nnfolder-save-buffer) t))) @@ -476,8 +585,12 @@ (if (not force) () ; Don't delete the articles. ;; Delete the file that holds the group. - (ignore-errors - (delete-file (nnfolder-group-pathname group)))) + (let ((data (nnfolder-group-pathname group)) + (nov (nnfolder-group-nov-pathname group)) + (mrk (nnfolder-group-marks-pathname group))) + (ignore-errors (delete-file data)) + (ignore-errors (delete-file nov)) + (ignore-errors (delete-file mrk)))) ;; Remove the group from all structures. (setq nnfolder-group-alist (delq (assoc group nnfolder-group-alist) nnfolder-group-alist) @@ -493,11 +606,17 @@ (set-buffer nnfolder-current-buffer) (and (file-writable-p buffer-file-name) (ignore-errors - (rename-file - buffer-file-name - (let ((new-file (nnfolder-group-pathname new-name))) - (gnus-make-directory (file-name-directory new-file)) - new-file)) + (let ((new-file (nnfolder-group-pathname new-name))) + (gnus-make-directory (file-name-directory new-file)) + (rename-file buffer-file-name new-file) + (when (file-exists-p (nnfolder-group-nov-pathname group)) + (setq new-file (nnfolder-group-nov-pathname new-name)) + (gnus-make-directory (file-name-directory new-file)) + (rename-file (nnfolder-group-nov-pathname group) new-file)) + (when (file-exists-p (nnfolder-group-marks-pathname group)) + (setq new-file (nnfolder-group-marks-pathname new-name)) + (gnus-make-directory (file-name-directory new-file)) + (rename-file (nnfolder-group-marks-pathname group) new-file))) t) ;; That went ok, so we change the internal structures. (let ((entry (assoc group nnfolder-group-alist))) @@ -510,7 +629,7 @@ (kill-buffer (current-buffer)) t)))) -(defun nnfolder-request-regenerate (server) +(deffoo nnfolder-request-regenerate (server) (nnfolder-possibly-change-group nil server) (nnfolder-generate-active-file) t) @@ -592,30 +711,26 @@ (setq nnfolder-current-buffer nil nnfolder-current-group nil)) ;; Change group. - (when (and group - (not (equal group nnfolder-current-group))) - (let ((file-name-coding-system nnmail-pathname-coding-system)) - (nnmail-activate 'nnfolder) - (when (and (not (assoc group nnfolder-group-alist)) - (not (file-exists-p - (nnfolder-group-pathname group)))) - ;; The group doesn't exist, so we create a new entry for it. - (push (list group (cons 1 0)) nnfolder-group-alist) - (nnfolder-save-active nnfolder-group-alist nnfolder-active-file)) - + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (when (and group + (not (equal group nnfolder-current-group)) + (progn + (nnmail-activate 'nnfolder) + (and (assoc group nnfolder-group-alist) + (file-exists-p (nnfolder-group-pathname group))))) (if dont-check (setq nnfolder-current-group group nnfolder-current-buffer nil) (let (inf file) - ;; If we have to change groups, see if we don't already have the - ;; folder in memory. If we do, verify the modtime and destroy - ;; the folder if needed so we can rescan it. + ;; If we have to change groups, see if we don't already have + ;; the folder in memory. If we do, verify the modtime and + ;; destroy the folder if needed so we can rescan it. (setq nnfolder-current-buffer (nth 1 (assoc group nnfolder-buffer-alist))) - ;; If the buffer is not live, make sure it isn't in the alist. If it - ;; is live, verify that nobody else has touched the file since last - ;; time. + ;; If the buffer is not live, make sure it isn't in the + ;; alist. If it is live, verify that nobody else has + ;; touched the file since last time. (when (and nnfolder-current-buffer (not (gnus-buffer-live-p nnfolder-current-buffer))) (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist) @@ -684,7 +799,11 @@ (nnfolder-possibly-change-folder (car group-art)) (let ((buffer-read-only nil)) (nnfolder-normalize-buffer) - (insert-buffer-substring obuf beg end))))) + (insert-buffer-substring obuf beg end)) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (set-buffer obuf) + (nnfolder-add-nov (car group-art) (cdr group-art) + (nnfolder-parse-head nil beg end)))))) ;; Did we save it anywhere? save-list)) @@ -694,7 +813,8 @@ (goto-char (point-max)) (skip-chars-backward "\n") (delete-region (point) (point-max)) - (insert "\n\n")) + (unless (bobp) + (insert "\n\n"))) (defun nnfolder-insert-newsgroup-line (group-art) (save-excursion @@ -730,23 +850,25 @@ (push (list group (nnfolder-read-folder group)) nnfolder-buffer-alist)))) -;; This method has a problem if you've accidentally let the active list get -;; out of sync with the files. This could happen, say, if you've -;; accidentally gotten new mail with something other than Gnus (but why -;; would _that_ ever happen? :-). In that case, we will be in the middle of -;; processing the file, ready to add new X-Gnus article number markers, and -;; we'll run across a message with no ID yet - the active list _may_not_ be -;; ready for us yet. +;; This method has a problem if you've accidentally let the active +;; list get out of sync with the files. This could happen, say, if +;; you've accidentally gotten new mail with something other than Gnus +;; (but why would _that_ ever happen? :-). In that case, we will be +;; in the middle of processing the file, ready to add new X-Gnus +;; article number markers, and we'll run across a message with no ID +;; yet - the active list _may_not_ be ready for us yet. -;; To handle this, I'm modifying this routine to maintain the maximum ID seen -;; so far, and when we hit a message with no ID, we will _manually_ scan the -;; rest of the message looking for any more, possibly higher IDs. We'll -;; assume the maximum that we find is the highest active. Note that this -;; shouldn't cost us much extra time at all, but will be a lot less -;; vulnerable to glitches between the mbox and the active file. +;; To handle this, I'm modifying this routine to maintain the maximum +;; ID seen so far, and when we hit a message with no ID, we will +;; _manually_ scan the rest of the message looking for any more, +;; possibly higher IDs. We'll assume the maximum that we find is the +;; highest active. Note that this shouldn't cost us much extra time +;; at all, but will be a lot less vulnerable to glitches between the +;; mbox and the active file. (defun nnfolder-read-folder (group) (let* ((file (nnfolder-group-pathname group)) + (nov (nnfolder-group-nov-pathname group)) (buffer (set-buffer (let ((nnheader-file-coding-system nnfolder-file-coding-system)) @@ -776,51 +898,81 @@ (scantime (assoc group nnfolder-scantime-alist)) (minid (lsh -1 -1)) maxid start end newscantime + novbuf articles newnum buffer-read-only) (buffer-disable-undo) (setq maxid (cdr active)) + + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil + (and (file-exists-p nov) + (file-newer-than-file-p nov file))) + (unless (file-exists-p nov) + (gnus-make-directory (file-name-directory nov))) + (with-current-buffer + (setq novbuf (nnfolder-open-nov group)) + (goto-char (point-min)) + (while (not (eobp)) + (push (read novbuf) articles) + (forward-line 1)) + (setq articles (nreverse articles)))) (goto-char (point-min)) - ;; Anytime the active number is 1 or 0, it is suspect. In that - ;; case, search the file manually to find the active number. Or, - ;; of course, if we're being paranoid. (This would also be the - ;; place to build other lists from the header markers, such as - ;; expunge lists, etc., if we ever desired to abandon the active - ;; file entirely for mboxes.) + ;; Anytime the active number is 1 or 0, it is suspect. In + ;; that case, search the file manually to find the active + ;; number. Or, of course, if we're being paranoid. (This + ;; would also be the place to build other lists from the + ;; header markers, such as expunge lists, etc., if we ever + ;; desired to abandon the active file entirely for mboxes.) (when (or nnfolder-ignore-active-file + novbuf (< maxid 2)) (while (and (search-forward marker nil t) - (re-search-forward number nil t)) - (let ((newnum (string-to-number (match-string 0)))) - (if (nnmail-within-headers-p) - (setq maxid (max maxid newnum) - minid (min minid newnum))))) + (looking-at number)) + (setq newnum (string-to-number (match-string 0))) + (when (nnmail-within-headers-p) + (setq maxid (max maxid newnum) + minid (min minid newnum)) + (when novbuf + (if (memq newnum articles) + (setq articles (delq newnum articles)) + (let ((headers (nnfolder-parse-head newnum))) + (with-current-buffer novbuf + (nnheader-find-nov-line newnum) + (nnheader-insert-nov headers))))))) + (when (and novbuf articles) + (with-current-buffer novbuf + (dolist (article articles) + (when (nnheader-find-nov-line article) + (delete-region (point) + (progn (forward-line 1) (point))))))) (setcar active (max 1 (min minid maxid))) (setcdr active (max maxid (cdr active))) (goto-char (point-min))) - ;; As long as we trust that the user will only insert unmarked mail - ;; at the end, go to the end and search backwards for the last - ;; marker. Find the start of that message, and begin to search for - ;; unmarked messages from there. + ;; As long as we trust that the user will only insert + ;; unmarked mail at the end, go to the end and search + ;; backwards for the last marker. Find the start of that + ;; message, and begin to search for unmarked messages from + ;; there. (when (not (or nnfolder-distrust-mbox (< maxid 2))) (goto-char (point-max)) (unless (re-search-backward marker nil t) (goto-char (point-min))) - (when (nnmail-search-unix-mail-delim) - (goto-char (point-min)))) + ;;(when (nnmail-search-unix-mail-delim) + ;; (goto-char (point-min))) + ) - ;; Keep track of the active number on our own, and insert it back - ;; into the active list when we're done. Also, prime the pump to - ;; cut down on the number of searches we do. + ;; Keep track of the active number on our own, and insert it + ;; back into the active list when we're done. Also, prime + ;; the pump to cut down on the number of searches we do. (unless (nnmail-search-unix-mail-delim) (goto-char (point-max))) (setq end (point-marker)) (while (not (= end (point-max))) (setq start (marker-position end)) (goto-char end) - ;; There may be more than one "From " line, so we skip past + ;; There may be more than one "From " line, so we skip past ;; them. (while (looking-at delim) (forward-line 1)) @@ -832,18 +984,31 @@ (narrow-to-region start end) (nnmail-insert-lines) (nnfolder-insert-newsgroup-line - (cons nil (nnfolder-active-number nnfolder-current-group))) + (cons nil + (setq newnum + (nnfolder-active-number group)))) + (when novbuf + (let ((headers (nnfolder-parse-head newnum (point-min) + (point-max)))) + (with-current-buffer novbuf + (goto-char (point-max)) + (nnheader-insert-nov headers)))) (widen))) (set-marker end nil) - ;; Make absolutely sure that the active list reflects reality! + ;; Make absolutely sure that the active list reflects + ;; reality! (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) + ;; Set the scantime for this group. (setq newscantime (visited-file-modtime)) (if scantime (setcdr scantime (list newscantime)) - (push (list nnfolder-current-group newscantime) + (push (list group newscantime) nnfolder-scantime-alist)) + ;; Save nov. + (when novbuf + (nnfolder-save-nov)) (current-buffer)))))) ;;;###autoload @@ -852,23 +1017,33 @@ This command does not work if you use short group names." (interactive) (nnmail-activate 'nnfolder) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (dolist (file (directory-files (or nnfolder-nov-directory + nnfolder-directory) + t + (concat + (regexp-quote nnfolder-nov-file-suffix) + "$"))) + (when (not (message-mail-file-mbox-p file)) + (ignore-errors + (delete-file file))))) (let ((files (directory-files nnfolder-directory)) - file) + file) (while (setq file (pop files)) (when (and (not (backup-file-name-p file)) - (message-mail-file-mbox-p + (message-mail-file-mbox-p (nnheader-concat nnfolder-directory file))) - (let ((oldgroup (assoc file nnfolder-group-alist))) - (if oldgroup - (nnheader-message 5 "Refreshing group %s..." file) - (nnheader-message 5 "Adding group %s..." file)) + (let ((oldgroup (assoc file nnfolder-group-alist))) + (if oldgroup + (nnheader-message 5 "Refreshing group %s..." file) + (nnheader-message 5 "Adding group %s..." file)) (if oldgroup (setq nnfolder-group-alist (delq oldgroup (copy-sequence nnfolder-group-alist)))) - (push (list file (cons 1 0)) nnfolder-group-alist) - (nnfolder-possibly-change-folder file) - (nnfolder-possibly-change-group file) - (nnfolder-close-group file)))) + (push (list file (cons 1 0)) nnfolder-group-alist) + (nnfolder-possibly-change-folder file) + (nnfolder-possibly-change-group file) + (nnfolder-close-group file)))) (nnheader-message 5 ""))) (defun nnfolder-group-pathname (group) @@ -883,6 +1058,12 @@ ;; If not, we translate dots into slashes. (concat dir (nnheader-replace-chars-in-string group ?. ?/))))) +(defun nnfolder-group-nov-pathname (group) + "Make pathname for GROUP NOV." + (let ((nnfolder-directory + (or nnfolder-nov-directory nnfolder-directory))) + (concat (nnfolder-group-pathname group) nnfolder-nov-file-suffix))) + (defun nnfolder-save-buffer () "Save the buffer." (when (buffer-modified-p) @@ -891,7 +1072,9 @@ (let ((coding-system-for-write (or nnfolder-file-coding-system-for-write nnfolder-file-coding-system))) - (save-buffer)))) + (save-buffer))) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (nnfolder-save-nov))) (defun nnfolder-save-active (group-alist active-file) (let ((nnmail-active-file-coding-system @@ -899,6 +1082,194 @@ nnfolder-active-file-coding-system))) (nnmail-save-active group-alist active-file))) +(defun nnfolder-open-nov (group) + (or (cdr (assoc group nnfolder-nov-buffer-alist)) + (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) + (save-excursion + (set-buffer buffer) + (set (make-local-variable 'nnfolder-nov-buffer-file-name) + (nnfolder-group-nov-pathname group)) + (erase-buffer) + (when (file-exists-p nnfolder-nov-buffer-file-name) + (nnheader-insert-file-contents nnfolder-nov-buffer-file-name))) + (push (cons group buffer) nnfolder-nov-buffer-alist) + buffer))) + +(defun nnfolder-save-nov () + (save-excursion + (while nnfolder-nov-buffer-alist + (when (buffer-name (cdar nnfolder-nov-buffer-alist)) + (set-buffer (cdar nnfolder-nov-buffer-alist)) + (when (buffer-modified-p) + (gnus-make-directory (file-name-directory + nnfolder-nov-buffer-file-name)) + (nnmail-write-region 1 (point-max) nnfolder-nov-buffer-file-name + nil 'nomesg)) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (setq nnfolder-nov-buffer-alist (cdr nnfolder-nov-buffer-alist))))) + +(defun nnfolder-nov-delete-article (group article) + (save-excursion + (set-buffer (nnfolder-open-nov group)) + (when (nnheader-find-nov-line article) + (delete-region (point) (progn (forward-line 1) (point)))) + t)) + +(defun nnfolder-retrieve-headers-with-nov (articles &optional fetch-old) + (if (or gnus-nov-is-evil nnfolder-nov-is-evil) + nil + (let ((nov (nnfolder-group-nov-pathname nnfolder-current-group))) + (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 nnfolder-parse-head (&optional number b e) + "Parse the head of the current buffer." + (let ((buf (current-buffer)) + chars) + (save-excursion + (unless b + (setq b (if (nnmail-search-unix-mail-delim-backward) + (point) (point-min))) + (forward-line 1) + (setq e (if (nnmail-search-unix-mail-delim) + (point) (point-max)))) + (setq chars (- e b)) + (unless (zerop chars) + (goto-char b) + (if (search-forward "\n\n" e t) (setq e (1- (point))))) + (with-temp-buffer + (insert-buffer-substring buf b e) + (let ((headers (nnheader-parse-naked-head))) + (mail-header-set-chars headers chars) + (mail-header-set-number headers number) + headers))))) + +(defun nnfolder-add-nov (group article headers) + "Add a nov line for the GROUP base." + (save-excursion + (set-buffer (nnfolder-open-nov group)) + (goto-char (point-max)) + (mail-header-set-number headers article) + (nnheader-insert-nov headers))) + +(deffoo nnfolder-request-set-mark (group actions &optional server) + (when (and server + (not (nnfolder-server-opened server))) + (nnfolder-open-server server)) + (unless nnfolder-marks-is-evil + (nnfolder-open-marks group server) + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (assert (or (eq what 'add) (eq what 'del)) t + "Unknown request-set-mark action: %s" what) + (dolist (mark marks) + (setq nnfolder-marks (gnus-update-alist-soft + mark + (funcall (if (eq what 'add) 'gnus-range-add + 'gnus-remove-from-range) + (cdr (assoc mark nnfolder-marks)) range) + nnfolder-marks))))) + (nnfolder-save-marks group server)) + nil) + +(deffoo nnfolder-request-update-info (group info &optional server) + ;; Change servers. + (when (and server + (not (nnfolder-server-opened server))) + (nnfolder-open-server server)) + (when (and (not nnfolder-marks-is-evil) (nnfolder-marks-changed-p group)) + (nnheader-message 8 "Updating marks for %s..." group) + (nnfolder-open-marks group server) + ;; Update info using `nnfolder-marks'. + (mapcar (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nnfolder-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) + (let ((seen (cdr (assq 'read nnfolder-marks)))) + (gnus-info-set-read info + (if (and (integerp (car seen)) + (null (cdr seen))) + (list (cons (car seen) (car seen))) + seen))) + (nnheader-message 8 "Updating marks for %s...done" group)) + info) + +(defun nnfolder-group-marks-pathname (group) + "Make pathname for GROUP NOV." + (let ((nnfolder-directory (or nnfolder-marks-directory nnfolder-directory))) + (concat (nnfolder-group-pathname group) nnfolder-marks-file-suffix))) + +(defun nnfolder-marks-changed-p (group) + (let ((file (nnfolder-group-marks-pathname group))) + (if (null (gnus-gethash file nnfolder-marks-modtime)) + t ;; never looked at marks file, assume it has changed + (not (equal (gnus-gethash file nnfolder-marks-modtime) + (nth 5 (file-attributes file))))))) + +(defun nnfolder-save-marks (group server) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (file (nnfolder-group-marks-pathname group))) + (condition-case err + (progn + (with-temp-file file + (erase-buffer) + (gnus-prin1 nnfolder-marks) + (insert "\n")) + (gnus-sethash file + (nth 5 (file-attributes file)) + nnfolder-marks-modtime)) + (error (or (gnus-yes-or-no-p + (format "Could not write to %s (%s). Continue? " file err)) + (error "Cannot write to %s (%s)" err)))))) + +(defun nnfolder-open-marks (group server) + (let ((file (nnfolder-group-marks-pathname group))) + (if (file-exists-p file) + (condition-case err + (with-temp-buffer + (gnus-sethash file (nth 5 (file-attributes file)) + nnfolder-marks-modtime) + (nnheader-insert-file-contents file) + (setq nnfolder-marks (read (current-buffer))) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nnfolder-marks (gnus-remassoc el nnfolder-marks)))) + (error (or (gnus-yes-or-no-p + (format "Error reading nnfolder marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) + (error "Cannot read nnfolder marks file %s (%s)" file err)))) + ;; User didn't have a .marks file. Probably first time + ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. + (let ((info (gnus-get-info + (gnus-group-prefixed-name + group + (gnus-server-to-method (format "nnfolder:%s" server)))))) + (nnheader-message 7 "Bootstrapping marks for %s..." group) + (setq nnfolder-marks (gnus-info-marks info)) + (push (cons 'read (gnus-info-read info)) nnfolder-marks) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nnfolder-marks (gnus-remassoc el nnfolder-marks))) + (nnfolder-save-marks group server) + (nnheader-message 7 "Bootstrapping marks for %s...done" group))))) + (provide 'nnfolder) ;;; arch-tag: a040d0f4-4f4e-445f-8972-839575c5f7e6
--- a/lisp/gnus/nngateway.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nngateway.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; nngateway.el --- posting news via mail gateways -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -65,7 +65,8 @@ (insert mail-header-separator "\n") (widen) (let (message-required-mail-headers) - (funcall message-send-mail-function)) + (funcall (or message-send-mail-real-function + message-send-mail-function))) t)))) ;;; Internal functions
--- a/lisp/gnus/nnheader.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnheader.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,11 +1,11 @@ ;;; nnheader.el --- header access macros for Gnus and its backends ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000, 2001 +;; 1997, 1998, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -33,28 +33,60 @@ ;; Requiring `gnus-util' at compile time creates a circular ;; dependency between nnheader.el and gnus-util.el. -;(eval-when-compile (require 'gnus-util)) +;;(eval-when-compile (require 'gnus-util)) (require 'mail-utils) (require 'mm-util) +(require 'gnus-util) (eval-and-compile + (autoload 'gnus-sorted-intersection "gnus-range") (autoload 'gnus-intersection "gnus-range") - (autoload 'gnus-sorted-complement "gnus-range")) + (autoload 'gnus-sorted-complement "gnus-range") + (autoload 'gnus-sorted-difference "gnus-range")) + +(defcustom gnus-verbose-backends 7 + "Integer that says how verbose the Gnus backends should be. +The higher the number, the more messages the Gnus backends will flash +to say what it's doing. At zero, the Gnus backends will be totally +mute; at five, they will display most important messages; and at ten, +they will keep on jabbering all the time." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-nov-is-evil nil + "If non-nil, Gnus backends will never output headers in the NOV format." + :group 'gnus-server + :type 'boolean) (defvar nnheader-max-head-length 4096 - "*Max length of the head of articles.") + "*Max length of the head of articles. + +Value is an integer, nil, or t. nil means read in chunks of a file +indefinitely until a complete head is found\; t means always read the +entire file immediately, disregarding `nnheader-head-chop-length'. + +Integer values will in effect be rounded up to the nearest multiple of +`nnheader-head-chop-length'.") (defvar nnheader-head-chop-length 2048 "*Length of each read operation when trying to fetch HEAD headers.") +(defvar nnheader-read-timeout + (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin" + (symbol-name system-type)) + 1.0 ; why? + 0.1) + "How long nntp should wait between checking for the end of output. +Shorter values mean quicker response, but are more CPU intensive.") + (defvar nnheader-file-name-translation-alist (let ((case-fold-search t)) (cond - ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32" + ((string-match "windows-nt\\|os/2\\|emx\\|cygwin" (symbol-name system-type)) (append (mapcar (lambda (c) (cons c ?_)) '(?: ?* ?\" ?< ?> ??)) - (if (string-match "windows-nt\\|cygwin32" + (if (string-match "windows-nt\\|cygwin" (symbol-name system-type)) nil '((?+ . ?-))))) @@ -65,12 +97,15 @@ \(setq nnheader-file-name-translation-alist '((?: . ?_)))") +(defvar nnheader-directory-separator-character + (string-to-char (substring (file-name-as-directory ".") -1)) + "*A character used to a directory separator.") + (eval-and-compile (autoload 'nnmail-message-id "nnmail") (autoload 'mail-position-on-field "sendmail") (autoload 'message-remove-header "message") (autoload 'gnus-point-at-eol "gnus-util") - (autoload 'gnus-delete-line "gnus-util" nil nil 'macro) (autoload 'gnus-buffer-live-p "gnus-util")) ;;; Header access macros. @@ -186,125 +221,140 @@ (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id)))) (defsubst nnheader-fake-message-id-p (id) - (save-match-data ; regular message-id's are <.*> + (save-match-data ; regular message-id's are <.*> (string-match "\\`fake\\+none\\+[0-9]+\\'" id))) ;; Parsing headers and NOV lines. +(defsubst nnheader-remove-cr-followed-by-lf () + (goto-char (point-max)) + (while (search-backward "\r\n" nil t) + (delete-char 1))) + (defsubst nnheader-header-value () - (buffer-substring (match-end 0) (gnus-point-at-eol))) + (skip-chars-forward " \t") + (buffer-substring (point) (gnus-point-at-eol))) + +(defun nnheader-parse-naked-head (&optional number) + ;; This function unfolds continuation lines in this buffer + ;; destructively. When this side effect is unwanted, use + ;; `nnheader-parse-head' instead of this function. + (let ((case-fold-search t) + (buffer-read-only nil) + (cur (current-buffer)) + (p (point-min)) + in-reply-to lines ref) + (nnheader-remove-cr-followed-by-lf) + (ietf-drums-unfold-fws) + (subst-char-in-region (point-min) (point-max) ?\t ? ) + (goto-char p) + (insert "\n") + (prog1 + ;; This implementation of this function, with nine + ;; search-forwards instead of the one re-search-forward and a + ;; case (which basically was the old function) is actually + ;; about twice as fast, even though it looks messier. You + ;; can't have everything, I guess. Speed and elegance don't + ;; always go hand in hand. + (vector + ;; Number. + (or number 0) + ;; Subject. + (progn + (goto-char p) + (if (search-forward "\nsubject:" nil t) + (nnheader-header-value) "(none)")) + ;; From. + (progn + (goto-char p) + (if (search-forward "\nfrom:" nil t) + (nnheader-header-value) "(nobody)")) + ;; Date. + (progn + (goto-char p) + (if (search-forward "\ndate:" nil t) + (nnheader-header-value) "")) + ;; Message-ID. + (progn + (goto-char p) + (if (search-forward "\nmessage-id:" nil t) + (buffer-substring + (1- (or (search-forward "<" (gnus-point-at-eol) t) + (point))) + (or (search-forward ">" (gnus-point-at-eol) t) (point))) + ;; If there was no message-id, we just fake one to make + ;; subsequent routines simpler. + (nnheader-generate-fake-message-id))) + ;; References. + (progn + (goto-char p) + (if (search-forward "\nreferences:" nil t) + (nnheader-header-value) + ;; Get the references from the in-reply-to header if + ;; there were no references and the in-reply-to header + ;; looks promising. + (if (and (search-forward "\nin-reply-to:" nil t) + (setq in-reply-to (nnheader-header-value)) + (string-match "<[^\n>]+>" in-reply-to)) + (let (ref2) + (setq ref (substring in-reply-to (match-beginning 0) + (match-end 0))) + (while (string-match "<[^\n>]+>" + in-reply-to (match-end 0)) + (setq ref2 (substring in-reply-to (match-beginning 0) + (match-end 0))) + (when (> (length ref2) (length ref)) + (setq ref ref2))) + ref) + nil))) + ;; Chars. + 0 + ;; Lines. + (progn + (goto-char p) + (if (search-forward "\nlines: " nil t) + (if (numberp (setq lines (read cur))) + lines 0) + 0)) + ;; Xref. + (progn + (goto-char p) + (and (search-forward "\nxref:" nil t) + (nnheader-header-value))) + ;; Extra. + (when nnmail-extra-headers + (let ((extra nnmail-extra-headers) + out) + (while extra + (goto-char p) + (when (search-forward + (concat "\n" (symbol-name (car extra)) ":") nil t) + (push (cons (car extra) (nnheader-header-value)) + out)) + (pop extra)) + out))) + (goto-char p) + (delete-char 1)))) (defun nnheader-parse-head (&optional naked) - (let ((case-fold-search t) - (cur (current-buffer)) - (buffer-read-only nil) - in-reply-to lines p ref) - (goto-char (point-min)) - (when naked - (insert "\n")) - ;; Search to the beginning of the next header. Error messages - ;; do not begin with 2 or 3. - (prog1 - (when (or naked (re-search-forward "^[23][0-9]+ " nil t)) - ;; This implementation of this function, with nine - ;; search-forwards instead of the one re-search-forward and - ;; a case (which basically was the old function) is actually - ;; about twice as fast, even though it looks messier. You - ;; can't have everything, I guess. Speed and elegance - ;; don't always go hand in hand. - (vector - ;; Number. - (if naked - (progn - (setq p (point-min)) - 0) - (prog1 - (read cur) - (end-of-line) - (setq p (point)) - (narrow-to-region (point) - (or (and (search-forward "\n.\n" nil t) - (- (point) 2)) - (point))))) - ;; Subject. - (progn - (goto-char p) - (if (search-forward "\nsubject: " nil t) - (nnheader-header-value) "(none)")) - ;; From. - (progn - (goto-char p) - (if (or (search-forward "\nfrom: " nil t) - (search-forward "\nfrom:" nil t)) - (nnheader-header-value) "(nobody)")) - ;; Date. - (progn - (goto-char p) - (if (search-forward "\ndate: " nil t) - (nnheader-header-value) "")) - ;; Message-ID. - (progn - (goto-char p) - (if (search-forward "\nmessage-id:" nil t) - (buffer-substring - (1- (or (search-forward "<" (gnus-point-at-eol) t) - (point))) - (or (search-forward ">" (gnus-point-at-eol) t) (point))) - ;; If there was no message-id, we just fake one to make - ;; subsequent routines simpler. - (nnheader-generate-fake-message-id))) - ;; References. - (progn - (goto-char p) - (if (search-forward "\nreferences: " nil t) - (nnheader-header-value) - ;; Get the references from the in-reply-to header if there - ;; were no references and the in-reply-to header looks - ;; promising. - (if (and (search-forward "\nin-reply-to: " nil t) - (setq in-reply-to (nnheader-header-value)) - (string-match "<[^\n>]+>" in-reply-to)) - (let (ref2) - (setq ref (substring in-reply-to (match-beginning 0) - (match-end 0))) - (while (string-match "<[^\n>]+>" - in-reply-to (match-end 0)) - (setq ref2 (substring in-reply-to (match-beginning 0) - (match-end 0))) - (when (> (length ref2) (length ref)) - (setq ref ref2))) - ref) - nil))) - ;; Chars. - 0 - ;; Lines. - (progn - (goto-char p) - (if (search-forward "\nlines: " nil t) - (if (numberp (setq lines (read cur))) - lines 0) - 0)) - ;; Xref. - (progn - (goto-char p) - (and (search-forward "\nxref: " nil t) - (nnheader-header-value))) - - ;; Extra. - (when nnmail-extra-headers - (let ((extra nnmail-extra-headers) - out) - (while extra - (goto-char p) - (when (search-forward - (concat "\n" (symbol-name (car extra)) ": ") nil t) - (push (cons (car extra) (nnheader-header-value)) - out)) - (pop extra)) - out)))) - (when naked - (goto-char (point-min)) - (delete-char 1))))) + (let ((cur (current-buffer)) num beg end) + (when (if naked + (setq num 0 + beg (point-min) + end (point-max)) + (goto-char (point-min)) + ;; Search to the beginning of the next header. Error + ;; messages do not begin with 2 or 3. + (when (re-search-forward "^[23][0-9]+ " nil t) + (end-of-line) + (setq num (read cur) + beg (point) + end (if (search-forward "\n.\n" nil t) + (- (point) 2) + (point))))) + (with-temp-buffer + (insert-buffer-substring cur beg end) + (nnheader-parse-naked-head num))))) (defmacro nnheader-nov-skip-field () '(search-forward "\t" eol 'move)) @@ -389,6 +439,22 @@ (delete-char 1)) (forward-line 1))) +(defun nnheader-parse-overview-file (file) + "Parse FILE and return a list of headers." + (mm-with-unibyte-buffer + (nnheader-insert-file-contents file) + (goto-char (point-min)) + (let (headers) + (while (not (eobp)) + (push (nnheader-parse-nov) headers) + (forward-line 1)) + (nreverse headers)))) + +(defun nnheader-write-overview-file (file headers) + "Write HEADERS to FILE." + (with-temp-file file + (mapcar 'nnheader-insert-nov headers))) + (defun nnheader-insert-header (header) (insert "Subject: " (or (mail-header-subject header) "(none)") "\n" @@ -432,7 +498,7 @@ (prev (point-min)) num found) (while (not found) - (goto-char (/ (+ max min) 2)) + (goto-char (+ min (/ (- max min) 2))) (beginning-of-line) (if (or (= (point) prev) (eobp)) @@ -471,10 +537,7 @@ ;; Various cruft the backends and Gnus need to communicate. (defvar nntp-server-buffer nil) -(defvar gnus-verbose-backends 7 - "*A number that says how talkative the Gnus backends should be.") -(defvar gnus-nov-is-evil nil - "If non-nil, Gnus backends will never output headers in the NOV format.") +(defvar nntp-process-response nil) (defvar news-reply-yank-from nil) (defvar news-reply-yank-message-id nil) @@ -490,6 +553,7 @@ (erase-buffer) (kill-all-local-variables) (setq case-fold-search t) ;Should ignore case. + (set (make-local-variable 'nntp-process-response) nil) t)) ;;; Various functions the backends use. @@ -544,7 +608,7 @@ ;; This is invalid, but not all articles have Message-IDs. () (mail-position-on-field "References") - (let ((begin (save-excursion (beginning-of-line) (point))) + (let ((begin (gnus-point-at-bol)) (fill-column 78) (fill-prefix "\t")) (when references @@ -578,6 +642,12 @@ (point-max))) (goto-char (point-min))) +(defun nnheader-remove-body () + "Remove the body from an article in this current buffer." + (goto-char (point-min)) + (when (re-search-forward "\n\r?\n" nil t) + (delete-region (point) (point-max)))) + (defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." (set-buffer (get-buffer-create name)) @@ -609,11 +679,17 @@ (string-match nnheader-numerical-short-files file) (string-to-int (match-string 0 file)))) +(defvar nnheader-directory-files-is-safe + (or (eq system-type 'windows-nt) + (and (not (featurep 'xemacs)) + (> emacs-major-version 20))) + "If non-nil, Gnus believes `directory-files' is safe. +It has been reported numerous times that `directory-files' fails with +an alarming frequency on NFS mounted file systems. If it is nil, +`nnheader-directory-files-safe' is used.") + (defun nnheader-directory-files-safe (&rest args) - ;; It has been reported numerous times that `directory-files' - ;; fails with an alarming frequency on NFS mounted file systems. - ;; This function executes that function twice and returns - ;; the longest result. + "Execute `directory-files' twice and returns the longer result." (let ((first (apply 'directory-files args)) (second (apply 'directory-files args))) (if (> (length first) (length second)) @@ -623,14 +699,20 @@ (defun nnheader-directory-articles (dir) "Return a list of all article files in directory DIR." (mapcar 'nnheader-file-to-number - (nnheader-directory-files-safe - dir nil nnheader-numerical-short-files t))) + (if nnheader-directory-files-is-safe + (directory-files + dir nil nnheader-numerical-short-files t) + (nnheader-directory-files-safe + dir nil nnheader-numerical-short-files t)))) (defun nnheader-article-to-file-alist (dir) "Return an alist of article/file pairs in DIR." (mapcar (lambda (file) (cons (nnheader-file-to-number file) file)) - (nnheader-directory-files-safe - dir nil nnheader-numerical-short-files t))) + (if nnheader-directory-files-is-safe + (directory-files + dir nil nnheader-numerical-short-files t) + (nnheader-directory-files-safe + dir nil nnheader-numerical-short-files t)))) (defun nnheader-fold-continuation-lines () "Fold continuation lines in the current buffer." @@ -653,7 +735,8 @@ ;; We translate -- but only the file name. We leave the directory ;; alone. (if (and (featurep 'xemacs) - (memq system-type '(win32 w32 mswindows windows-nt cygwin))) + (memq system-type '(cygwin32 win32 w32 mswindows windows-nt + cygwin))) ;; This is needed on NT and stuff, because ;; file-name-nondirectory is not enough to split ;; file names, containing ':', e.g. @@ -710,21 +793,8 @@ (apply 'insert format args)) t)) -(eval-and-compile - (if (fboundp 'subst-char-in-string) - (defsubst nnheader-replace-chars-in-string (string from to) - (subst-char-in-string from to string)) - (defun nnheader-replace-chars-in-string (string from to) - "Replace characters in STRING from FROM to TO." - (let ((string (substring string 0)) ;Copy string. - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (when (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string)))) +(defsubst nnheader-replace-chars-in-string (string from to) + (mm-subst-char-in-string from to string)) (defun nnheader-replace-duplicate-chars-in-string (string from to) "Replace characters in STRING from FROM to TO." @@ -752,7 +822,7 @@ (expand-file-name (file-name-as-directory top)))) (error ""))) - ?/ ?.)) + nnheader-directory-separator-character ?.)) (defun nnheader-message (level &rest args) "Message if the Gnus backends are talkative." @@ -766,8 +836,8 @@ (or (not (numberp gnus-verbose-backends)) (<= level gnus-verbose-backends))) -(defvar nnheader-pathname-coding-system 'binary - "*Coding system for file names.") +(defvar nnheader-pathname-coding-system 'iso-8859-1 + "*Coding system for file name.") (defun nnheader-group-pathname (group dir &optional file) "Make file name for GROUP." @@ -780,17 +850,12 @@ ;; If not, we translate dots into slashes. (expand-file-name (mm-encode-coding-string (nnheader-replace-chars-in-string group ?. ?/) - nnheader-pathname-coding-system) + nnheader-pathname-coding-system) dir)))) (cond ((null file) "") ((numberp file) (int-to-string file)) (t file)))) -(defun nnheader-functionp (form) - "Return non-nil if FORM is funcallable." - (or (and (symbolp form) (fboundp form)) - (and (listp form) (eq (car form) 'lambda)))) - (defun nnheader-concat (dir &rest files) "Concat DIR as directory to FILES." (apply 'concat (file-name-as-directory dir) files)) @@ -798,19 +863,21 @@ (defun nnheader-ms-strip-cr () "Strip ^M from the end of all lines." (save-excursion - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (delete-backward-char 1)))) + (nnheader-remove-cr-followed-by-lf))) (defun nnheader-file-size (file) "Return the file size of FILE or 0." (or (nth 7 (file-attributes file)) 0)) -(defun nnheader-find-etc-directory (package &optional file) - "Go through the path and find the \".../etc/PACKAGE\" directory. -If FILE, find the \".../etc/PACKAGE\" file instead." +(defun nnheader-find-etc-directory (package &optional file first) + "Go through `load-path' and find the \"../etc/PACKAGE\" directory. +This function will look in the parent directory of each `load-path' +entry, and look for the \"etc\" directory there. +If FILE, find the \".../etc/PACKAGE\" file instead. +If FIRST is non-nil, return the directory or the file found at the +first. Otherwise, find the newest one, though it may take a time." (let ((path load-path) - dir result) + dir results) ;; We try to find the dir by looking at the load path, ;; stripping away the last component and adding "etc/". (while path @@ -822,10 +889,14 @@ "etc/" package (if file "" "/")))) (or file (file-directory-p dir))) - (setq result dir - path nil) + (progn + (or (member dir results) + (push dir results)) + (setq path (if first nil (cdr path)))) (setq path (cdr path)))) - result)) + (if (or first (not (cdr results))) + (car results) + (car (sort results 'file-newer-than-file-p))))) (eval-when-compile (defvar ange-ftp-path-format) @@ -851,12 +922,32 @@ (let ((coding-system-for-read nnheader-file-coding-system)) (mm-insert-file-contents filename visit beg end replace))) +(defun nnheader-insert-nov-file (file first) + (let ((size (nth 7 (file-attributes file))) + (cutoff (* 32 1024))) + (when size + (if (< size cutoff) + ;; If the file is small, we just load it. + (nnheader-insert-file-contents file) + ;; We start on the assumption that FIRST is pretty recent. If + ;; not, we just insert the rest of the file as well. + (let (current) + (nnheader-insert-file-contents file nil (- size cutoff) size) + (goto-char (point-min)) + (delete-region (point) (or (search-forward "\n" nil 'move) (point))) + (setq current (ignore-errors (read (current-buffer)))) + (if (and (numberp current) + (< current first)) + t + (delete-region (point-min) (point-max)) + (nnheader-insert-file-contents file))))))) + (defun nnheader-find-file-noselect (&rest args) (let ((format-alist nil) (auto-mode-alist (mm-auto-mode-alist)) (default-major-mode 'fundamental-mode) (enable-local-variables nil) - (after-insert-file-functions nil) + (after-insert-file-functions nil) (enable-local-eval nil) (find-file-hooks nil) (coding-system-for-read nnheader-file-coding-system)) @@ -917,6 +1008,15 @@ (defalias 'nnheader-run-at-time 'run-at-time) (defalias 'nnheader-cancel-timer 'cancel-timer) (defalias 'nnheader-cancel-function-timers 'cancel-function-timers) +(defalias 'nnheader-string-as-multibyte 'string-as-multibyte) + +(defun nnheader-accept-process-output (process) + (accept-process-output + process + (truncate nnheader-read-timeout) + (truncate (* (- nnheader-read-timeout + (truncate nnheader-read-timeout)) + 1000)))) (when (featurep 'xemacs) (require 'nnheaderxm))
--- a/lisp/gnus/nnimap.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnimap.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; nnimap.el --- imap backend for Gnus - -;; Copyright (C) 1998,1999,2000,01,02,2004 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Simon Josefsson <jas@pdc.kth.se> ;; Jim Radford <radford@robby.caltech.edu> @@ -56,13 +56,11 @@ ;; o What about Gnus's article editing, can we support it? NO! ;; o Use \Draft to support the draft group?? ;; o Duplicate suppression +;; o Rewrite UID SEARCH UID X as UID FETCH X (UID) for those with slow servers ;;; Code: -(eval-and-compile - (require 'cl) - (require 'imap)) - +(require 'imap) (require 'nnoo) (require 'nnmail) (require 'nnheader) @@ -72,33 +70,55 @@ (require 'gnus-start) (require 'gnus-int) +(eval-when-compile (require 'cl)) + (nnoo-declare nnimap) -(defconst nnimap-version "nnimap 0.131") +(defconst nnimap-version "nnimap 1.0") + +(defgroup nnimap nil + "Reading IMAP mail with Gnus." + :group 'gnus) (defvoo nnimap-address nil "Address of physical IMAP server. If nil, use the virtual server's name.") (defvoo nnimap-server-port nil "Port number on physical IMAP server. -If nil, defaults to 993 for SSL connections and 143 otherwise.") +If nil, defaults to 993 for TLS/SSL connections and 143 otherwise.") ;; Splitting variables -(defvar nnimap-split-crosspost t +(defcustom nnimap-split-crosspost t "If non-nil, do crossposting if several split methods match the mail. -If nil, the first match found will be used.") +If nil, the first match found will be used." + :group 'nnimap + :type 'boolean) -(defvar nnimap-split-inbox nil - "*Name of mailbox to split mail from. +(defcustom nnimap-split-inbox nil + "Name of mailbox to split mail from. Mail is read from this mailbox and split according to rules in -`nnimap-split-rules'. +`nnimap-split-rule'. + +This can be a string or a list of strings." + :group 'nnimap + :type '(choice (string) + (repeat string))) + +(define-widget 'nnimap-strict-function 'function + "This widget only matches values that are functionp. -This can be a string or a list of strings.") +Warning: This means that a value that is the symbol of a not yet +loaded function will not match. Use with care." + :match 'nnimap-strict-function-match) -(defvar nnimap-split-rule nil - "*Mail will be split according to these rules. +(defun nnimap-strict-function-match (widget value) + "Ignoring WIDGET, match if VALUE is a function." + (functionp value)) + +(defcustom nnimap-split-rule nil + "Mail will be split according to these rules. Mail is read from mailbox(es) specified in `nnimap-split-inbox'. @@ -110,10 +130,10 @@ \(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\") (\"INBOX.junk\" \"Subject:.*buy\"))) -As you can see, `nnimap-split-rule' is a list of lists, where the first -element in each \"rule\" is the name of the IMAP mailbox, and the -second is a regexp that nnimap will try to match on the header to find -a fit. +As you can see, `nnimap-split-rule' is a list of lists, where the +first element in each \"rule\" is the name of the IMAP mailbox (or the +symbol `junk' if you want to remove the mail), and the second is a +regexp that nnimap will try to match on the header to find a fit. The second element can also be a function. In that case, it will be called narrowed to the headers with the first element of the rule as @@ -130,27 +150,104 @@ \(setq nnimap-split-rule '((\"my1server\" (\".*\" ((\"ding\" \"ding@gnus.org\") - (\"junk\" \"From:.*Simon\"))) - (\"my2server\" (\"INBOX\" nnimap-split-fancy)) - (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\") - (\"junk\" my-junk-func))))) + (\"junk\" \"From:.*Simon\"))) + (\"my2server\" (\"INBOX\" nnimap-split-fancy)) + (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\") + (\"junk\" my-junk-func))))) The virtual server name is in fact a regexp, so that the same rules may apply to several servers. In the example, the servers \"my3server\" and \"my4server\" both use the same rules. Similarly, the inbox string is also a regexp. The actual splitting rules are as before, either a function, or a list with group/regexp or -group/function elements.") +group/function elements." + :group 'nnimap + :type '(choice :tag "Rule type" + (repeat :menu-tag "Single-server" + :tag "Single-server list" + (list (string :tag "Mailbox") + (choice :tag "Predicate" + (regexp :tag "A regexp") + (nnimap-strict-function :tag "A function")))) + (choice :menu-tag "A function" + :tag "A function" + (function-item nnimap-split-fancy) + (function-item nnmail-split-fancy) + (nnimap-strict-function :tag "User-defined function")) + (repeat :menu-tag "Multi-server (extended)" + :tag "Multi-server list" + (list (regexp :tag "Server regexp") + (list (regexp :tag "Incoming Mailbox regexp") + (repeat :tag "Rules for matching server(s) and mailbox(es)" + (list (string :tag "Destination mailbox") + (choice :tag "Predicate" + (regexp :tag "A Regexp") + (nnimap-strict-function :tag "A Function"))))))))) -(defvar nnimap-split-predicate "UNSEEN UNDELETED" +(defcustom nnimap-split-predicate "UNSEEN UNDELETED" "The predicate used to find articles to split. If you use another IMAP client to peek on articles but always would like nnimap to split them once it's started, you could change this to \"UNDELETED\". Other available predicates are available in -RFC2060 section 6.4.4.") +RFC2060 section 6.4.4." + :group 'nnimap + :type 'string) + +(defcustom nnimap-split-fancy nil + "Like the variable `nnmail-split-fancy'." + :group 'nnimap + :type 'sexp) + +(defvar nnimap-split-download-body-default nil + "Internal variable with default value for `nnimap-split-download-body'.") + +(defcustom nnimap-split-download-body 'default + "Whether to download entire articles during splitting. +This is generally not required, and will slow things down considerably. +You may need it if you want to use an advanced splitting function that +analyses the body before splitting the article. +If this variable is nil, bodies will not be downloaded; if this +variable is the symbol `default' the default behaviour is +used (which currently is nil, unless you use a statistical +spam.el test); if this variable is another non-nil value bodies +will be downloaded." + :group 'nnimap + :type '(choice (const :tag "Let system decide" deault) + boolean)) + +;; Performance / bug workaround variables -(defvar nnimap-split-fancy nil - "Like `nnmail-split-fancy', which see.") +(defcustom nnimap-close-asynchronous t + "Close mailboxes asynchronously in `nnimap-close-group'. +This means that errors cought by nnimap when closing the mailbox will +not prevent Gnus from updating the group status, which may be harmful. +However, it increases speed." + :type 'boolean + :group 'nnimap) + +(defcustom nnimap-dont-close t + "Never close mailboxes. +This increases the speed of closing mailboxes (quiting group) but may +decrease the speed of selecting another mailbox later. Re-selecting +the same mailbox will be faster though." + :type 'boolean + :group 'nnimap) + +(defcustom nnimap-retrieve-groups-asynchronous t + "Send asynchronous STATUS commands for each mailbox before checking mail. +If you have mailboxes that rarely receives mail, this speeds up new +mail checking. It works by first sending STATUS commands for each +mailbox, and then only checking groups which has a modified UIDNEXT +more carefully for new mail. + +In summary, the default is O((1-p)*k+p*n) and changing it to nil makes +it O(n). If p is small, then the default is probably faster." + :type 'boolean + :group 'nnimap) + +(defvoo nnimap-need-unselect-to-notice-new-mail nil + "Unselect mailboxes before looking for new mail in them. +Some servers seem to need this under some circumstances.") ;; Authorization / Privacy variables @@ -165,14 +262,16 @@ Change this if -1) you want to connect with SSL. The SSL integration with IMAP is - brain-dead so you'll have to tell it specifically. +1) you want to connect with TLS/SSL. The TLS/SSL integration + with IMAP is suboptimal so you'll have to tell it + specifically. 2) your server is more capable than your environment -- i.e. your server accept Kerberos login's but you haven't installed the `imtest' program or your machine isn't configured for Kerberos. -Possible choices: kerberos4, ssl, network") +Possible choices: gssapi, kerberos4, starttls, tls, ssl, network, shell. +See also `imap-streams' and `imap-stream-alist'.") (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. @@ -186,7 +285,8 @@ installed the `imtest' program or your machine isn't configured for Kerberos. -Possible choices: kerberos4, cram-md5, login, anonymous.") +Possible choices: gssapi, kerberos4, digest-md5, cram-md5, login, anonymous. +See also `imap-authenticators' and `imap-authenticator-alist'") (defvoo nnimap-directory (nnheader-concat gnus-directory "overview/") "Directory to keep NOV cache files for nnimap groups. @@ -203,9 +303,12 @@ (defvoo nnimap-nov-file-name-suffix ".novcache" "Suffix for NOV cache base filename.") -(defvoo nnimap-nov-is-evil nil - "If non-nil, nnimap will never generate or use a local nov database for this backend. -Using nov databases will speed up header fetching considerably. +(defvoo nnimap-nov-is-evil gnus-agent + "If non-nil, never generate or use a local nov database for this backend. +Using nov databases should speed up header fetching considerably. +However, it will invoke a UID SEARCH UID command on the server, and +some servers implement this command inefficiently by opening each and +every message in the group, thus making it quite slow. Unlike other backends, you do not need to take special care if you flip this variable.") @@ -238,7 +341,8 @@ everything in the current hierarchy.") (defvoo nnimap-news-groups nil - "IMAP support a news-like mode, also known as bulletin board mode, where replies is sent via IMAP instead of SMTP. + "IMAP support a news-like mode, also known as bulletin board mode, +where replies is sent via IMAP instead of SMTP. This variable should contain a regexp matching groups where you wish replies to be stored to the mailbox directly. @@ -253,6 +357,22 @@ similar which you wouldn't want to set up a mailing list for, you can use this to make replies go directly to the group.") +(defvoo nnimap-expunge-search-string "UID %s NOT SINCE %s" + "IMAP search command to use for articles that are to be expired. +The first %s is replaced by a UID set of articles to search on, +and the second %s is replaced by a date criterium. + +One useful (and perhaps the only useful) value to change this to would +be `UID %s NOT SENTSINCE %s' to make nnimap use the Date: header +instead of the internal date of messages. See section 6.4.4 of RFC +2060 for more information on valid strings.") + +(defvoo nnimap-importantize-dormant t + "If non-nil, mark \"dormant\" articles as \"ticked\" for other IMAP clients. +Note that within Gnus, dormant articles will still (only) be +marked as ticked. This is to make \"dormant\" articles stand out, +just like \"ticked\" articles, in other IMAP clients.") + (defvoo nnimap-server-address nil "Obsolete. Use `nnimap-address'.") @@ -271,24 +391,26 @@ (string :format "Login: %v")) (cons :format "%v" (const :format "" "password") - (string :format "Password: %v")))))) - :group 'nnimap) + (string :format "Password: %v"))))))) (defcustom nnimap-prune-cache t "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache." - :type 'boolean - :group 'nnimap) + :type 'boolean) (defvar nnimap-request-list-method 'imap-mailbox-list "Method to use to request a list of all folders from the server. If this is 'imap-mailbox-lsub, then use a server-side subscription list to restrict visible folders.") +(defcustom nnimap-debug nil + "If non-nil, random debug spews are placed in *nnimap-debug* buffer." + :group 'nnimap + :type 'boolean) + ;; Internal variables: -(defvar nnimap-debug nil - "Name of buffer to record debugging info. -For example: (setq nnimap-debug \"*nnimap-debug*\")") +(defvar nnimap-debug-buffer "*nnimap-debug*") +(defvar nnimap-mailbox-info (gnus-make-hashtable 997)) (defvar nnimap-current-move-server nil) (defvar nnimap-current-move-group nil) (defvar nnimap-current-move-article nil) @@ -296,13 +418,9 @@ (defvar nnimap-progress-chars '(?| ?/ ?- ?\\)) (defvar nnimap-progress-how-often 20) (defvar nnimap-counter) -(defvar nnimap-callback-callback-function nil - "Gnus callback the nnimap asynchronous callback should call.") -(defvar nnimap-callback-buffer nil - "Which buffer the asynchronous article prefetch callback should work in.") (defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers. -(defvar nnimap-current-server nil) ;; Current server -(defvar nnimap-server-buffer nil) ;; Current servers' buffer +(defvar nnimap-current-server nil) ;; Current server +(defvar nnimap-server-buffer nil) ;; Current servers' buffer @@ -328,13 +446,13 @@ (new-uidvalidity (imap-mailbox-get 'uidvalidity)) (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)) (dir (file-name-as-directory (expand-file-name nnimap-directory))) - (nameuid (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group "." old-uidvalidity - nnimap-nov-file-name-suffix) t)) - (file (if (or nnmail-use-long-file-names + (nameuid (nnheader-translate-file-chars + (concat nnimap-nov-file-name + (if (equal server "") + "unnamed" + server) "." group "." old-uidvalidity + nnimap-nov-file-name-suffix) t)) + (file (if (or nnmail-use-long-file-names (file-exists-p (expand-file-name nameuid dir))) (expand-file-name nameuid dir) (expand-file-name @@ -354,16 +472,18 @@ (defun nnimap-before-find-minmax-bugworkaround () "Function called before iterating through mailboxes with `nnimap-find-minmax-uid'." - ;; XXX this is for UoW imapd problem, it doesn't notice new mail in - ;; currently selected mailbox without a re-select/examine. - (or (null (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer))) + (when nnimap-need-unselect-to-notice-new-mail + ;; XXX this is for UoW imapd problem, it doesn't notice new mail in + ;; currently selected mailbox without a re-select/examine. + (or (null (imap-current-mailbox nnimap-server-buffer)) + (imap-mailbox-unselect nnimap-server-buffer)))) (defun nnimap-find-minmax-uid (group &optional examine) "Find lowest and highest active article number in GROUP. If EXAMINE is non-nil the group is selected read-only." (with-current-buffer nnimap-server-buffer - (when (imap-mailbox-select group examine) + (when (or (string= group (imap-current-mailbox)) + (imap-mailbox-select group examine)) (let (minuid maxuid) (when (> (imap-mailbox-get 'exists) 0) (imap-fetch "1,*" "UID" nil 'nouidfetch) @@ -383,6 +503,8 @@ (if (or (nnimap-verify-uidvalidity group (or server nnimap-current-server)) (zerop (imap-mailbox-get 'exists group)) + t ;; for OGnus to see if ignoring uidvalidity + ;; changes has any bad effects. (yes-or-no-p (format "nnimap: Group %s is not uidvalid. Continue? " group))) @@ -428,10 +550,7 @@ (with-temp-buffer (buffer-disable-undo) (insert headers) - (nnheader-ms-strip-cr) - (nnheader-fold-continuation-lines) - (subst-char-in-region (point-min) (point-max) ?\t ? ) - (let ((head (nnheader-parse-head 'naked))) + (let ((head (nnheader-parse-naked-head))) (mail-header-set-number head uid) (mail-header-set-chars head chars) (mail-header-set-lines head lines) @@ -456,44 +575,44 @@ articles))))) (mapcar (lambda (msgid) (imap-search - (format "HEADER Message-Id %s" msgid))) + (format "HEADER Message-Id \"%s\"" msgid))) articles)))) (defun nnimap-group-overview-filename (group server) "Make file name for GROUP on SERVER." (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory))) - (uidvalidity (gnus-group-get-parameter - (gnus-group-prefixed-name - group (gnus-server-to-method - (format "nnimap:%s" server))) - 'uidvalidity)) - (name (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group nnimap-nov-file-name-suffix) t)) - (nameuid (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group "." uidvalidity - nnimap-nov-file-name-suffix) t)) - (oldfile (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name name dir))) - (expand-file-name name dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string name ?. ?/) - nnmail-pathname-coding-system) - dir))) - (newfile (if (or nnmail-use-long-file-names - (file-exists-p (expand-file-name nameuid dir))) - (expand-file-name nameuid dir) - (expand-file-name - (mm-encode-coding-string - (nnheader-replace-chars-in-string nameuid ?. ?/) - nnmail-pathname-coding-system) - dir)))) + (uidvalidity (gnus-group-get-parameter + (gnus-group-prefixed-name + group (gnus-server-to-method + (format "nnimap:%s" server))) + 'uidvalidity)) + (name (nnheader-translate-file-chars + (concat nnimap-nov-file-name + (if (equal server "") + "unnamed" + server) "." group nnimap-nov-file-name-suffix) t)) + (nameuid (nnheader-translate-file-chars + (concat nnimap-nov-file-name + (if (equal server "") + "unnamed" + server) "." group "." uidvalidity + nnimap-nov-file-name-suffix) t)) + (oldfile (if (or nnmail-use-long-file-names + (file-exists-p (expand-file-name name dir))) + (expand-file-name name dir) + (expand-file-name + (mm-encode-coding-string + (nnheader-replace-chars-in-string name ?. ?/) + nnmail-pathname-coding-system) + dir))) + (newfile (if (or nnmail-use-long-file-names + (file-exists-p (expand-file-name nameuid dir))) + (expand-file-name nameuid dir) + (expand-file-name + (mm-encode-coding-string + (nnheader-replace-chars-in-string nameuid ?. ?/) + nnmail-pathname-coding-system) + dir)))) (when (and (file-exists-p oldfile) (not (file-exists-p newfile))) (message "nnimap: Upgrading novcache filename...") (sit-for 1) @@ -540,7 +659,7 @@ (> nnimap-length nnmail-large-newsgroup) (nnheader-message 6 "nnimap: Retrieving headers...done"))))) -(defun nnimap-use-nov-p (group server) +(defun nnimap-dont-use-nov-p (group server) (or gnus-nov-is-evil nnimap-nov-is-evil (unless (and (gnus-make-directory (file-name-directory @@ -554,7 +673,7 @@ (when (nnimap-possibly-change-group group server) (with-current-buffer nntp-server-buffer (erase-buffer) - (if (nnimap-use-nov-p group server) + (if (nnimap-dont-use-nov-p group server) (nnimap-retrieve-headers-from-server (gnus-compress-sequence articles) group server) (let (uids cached low high) @@ -577,8 +696,8 @@ ;; remove nov's for articles which has expired on server (goto-char (point-min)) (dolist (uid (gnus-set-difference articles uids)) - (when (re-search-forward (format "^%d\t" uid) nil t) - (gnus-delete-line))))) + (when (re-search-forward (format "^%d\t" uid) nil t) + (gnus-delete-line))))) ;; nothing cached, fetch whole range from server (nnimap-retrieve-headers-from-server (cons low high) group server)) @@ -601,9 +720,11 @@ (port (if nnimap-server-port (int-to-string nnimap-server-port) "imap")) - (alist (gnus-netrc-machine list (or nnimap-server-address - nnimap-address server) - port "imap")) + (alist (or (gnus-netrc-machine list server port "imap") + (gnus-netrc-machine list + (or nnimap-server-address + nnimap-address) + port "imap"))) (user (gnus-netrc-get alist "login")) (passwd (gnus-netrc-get alist "password"))) (if (imap-authenticate user passwd nnimap-server-buffer) @@ -629,10 +750,17 @@ (cadr (assq 'nnimap-server-address defs))) defs) (push (list 'nnimap-address server) defs))) (nnoo-change-server 'nnimap server defs) + (or nnimap-server-buffer + (setq nnimap-server-buffer (cadr (assq 'nnimap-server-buffer defs)))) (with-current-buffer (get-buffer-create nnimap-server-buffer) (nnoo-change-server 'nnimap server defs)) (or (and nnimap-server-buffer - (imap-opened nnimap-server-buffer)) + (imap-opened nnimap-server-buffer) + (if (with-current-buffer nnimap-server-buffer + (memq imap-state '(auth select examine))) + t + (imap-close nnimap-server-buffer) + (nnimap-open-connection server))) (nnimap-open-connection server)))) (deffoo nnimap-server-opened (&optional server) @@ -674,57 +802,67 @@ (nnoo-status-message 'nnimap server))) (defun nnimap-demule (string) - ;; BEWARE: we used to use string-as-multibyte here which is braindead - ;; because it will turn accidental emacs-mule-valid byte sequences - ;; into multibyte chars. --Stef - (funcall (if (and (fboundp 'string-to-multibyte) - (subrp (symbol-function 'string-to-multibyte))) - 'string-to-multibyte + (funcall (if (and (fboundp 'string-as-multibyte) + (subrp (symbol-function 'string-as-multibyte))) + 'string-as-multibyte 'identity) (or string ""))) -(defun nnimap-callback () - (remove-hook 'imap-fetch-data-hook 'nnimap-callback) - (with-current-buffer nnimap-callback-buffer - (insert - (with-current-buffer nnimap-server-buffer - (nnimap-demule - (if (imap-capability 'IMAP4rev1) - ;; xxx don't just use car? alist doesn't contain - ;; anything else now, but it might... - (nth 2 (car (imap-message-get (imap-current-message) 'BODYDETAIL))) - (imap-message-get (imap-current-message) 'RFC822))))) - (nnheader-ms-strip-cr) - (funcall nnimap-callback-callback-function t))) +(defun nnimap-make-callback (article gnus-callback buffer) + "Return a callback function." + `(lambda () + (nnimap-callback ,article ,gnus-callback ,buffer))) + +(defun nnimap-callback (article gnus-callback buffer) + (when (eq article (imap-current-message)) + (remove-hook 'imap-fetch-data-hook + (nnimap-make-callback article gnus-callback buffer)) + (with-current-buffer buffer + (insert + (with-current-buffer nnimap-server-buffer + (nnimap-demule + (if (imap-capability 'IMAP4rev1) + ;; xxx don't just use car? alist doesn't contain + ;; anything else now, but it might... + (nth 2 (car (imap-message-get article 'BODYDETAIL))) + (imap-message-get article 'RFC822))))) + (nnheader-ms-strip-cr) + (funcall gnus-callback t)))) (defun nnimap-request-article-part (article part prop &optional - group server to-buffer detail) + group server to-buffer detail) (when (nnimap-possibly-change-group group server) (let ((article (if (stringp article) (car-safe (imap-search - (format "HEADER Message-Id %s" article) + (format "HEADER Message-Id \"%s\"" article) nnimap-server-buffer)) article))) (when article - (gnus-message 10 "nnimap: Fetching (part of) article %d..." article) + (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..." + article (or group imap-current-mailbox + gnus-newsgroup-name)) (if (not nnheader-callback-function) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) - (let ((data (imap-fetch article part prop nil - nnimap-server-buffer))) - (insert (nnimap-demule (if detail - (nth 2 (car data)) - data)))) - (nnheader-ms-strip-cr) - (gnus-message 10 "nnimap: Fetching (part of) article %d...done" - article) + (let ((data (imap-fetch article part prop nil + nnimap-server-buffer))) + (insert (nnimap-demule (if detail + (nth 2 (car data)) + data)))) + (nnheader-ms-strip-cr) + (gnus-message + 10 "nnimap: Fetching (part of) article %d from %s...done" + article (or group imap-current-mailbox gnus-newsgroup-name)) (if (bobp) - (nnheader-report 'nnimap "No such article: %s" + (nnheader-report 'nnimap "No such article %d in %s: %s" + article (or group imap-current-mailbox + gnus-newsgroup-name) (imap-error-text nnimap-server-buffer)) (cons group article))) - (add-hook 'imap-fetch-data-hook 'nnimap-callback) - (setq nnimap-callback-callback-function nnheader-callback-function - nnimap-callback-buffer nntp-server-buffer) + (add-hook 'imap-fetch-data-hook + (nnimap-make-callback article + nnheader-callback-function + nntp-server-buffer)) (imap-fetch-asynch article part nil nnimap-server-buffer) (cons group article)))))) @@ -772,20 +910,35 @@ (nnheader-report 'nnimap "Group %s selected" group) t))))) +(defun nnimap-update-unseen (group &optional server) + "Update the unseen count in `nnimap-mailbox-info'." + (gnus-sethash + (gnus-group-prefixed-name group server) + (let ((old (gnus-gethash-safe (gnus-group-prefixed-name group server) + nnimap-mailbox-info))) + (list (nth 0 old) (nth 1 old) + (imap-mailbox-status group 'unseen nnimap-server-buffer) + (nth 3 old))) + nnimap-mailbox-info)) + (defun nnimap-close-group (group &optional server) (with-current-buffer nnimap-server-buffer (when (and (imap-opened) (nnimap-possibly-change-group group server)) + (nnimap-update-unseen group server) (case nnimap-expunge-on-close - ('always (imap-mailbox-expunge) - (imap-mailbox-close)) - ('ask (if (and (imap-search "DELETED") - (gnus-y-or-n-p (format - "Expunge articles in group `%s'? " - imap-current-mailbox))) - (progn (imap-mailbox-expunge) - (imap-mailbox-close)) - (imap-mailbox-unselect))) + (always (progn + (imap-mailbox-expunge nnimap-close-asynchronous) + (unless nnimap-dont-close + (imap-mailbox-close nnimap-close-asynchronous)))) + (ask (if (and (imap-search "DELETED") + (gnus-y-or-n-p (format "Expunge articles in group `%s'? " + imap-current-mailbox))) + (progn + (imap-mailbox-expunge nnimap-close-asynchronous) + (unless nnimap-dont-close + (imap-mailbox-close nnimap-close-asynchronous))) + (imap-mailbox-unselect))) (t (imap-mailbox-unselect))) (not imap-current-mailbox)))) @@ -812,9 +965,9 @@ (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info (with-current-buffer nntp-server-buffer - (insert (format "\"%s\" %d %d y\n" - mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))))) + (insert (format "\"%s\" %d %d y\n" + mbx (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))))))))) (gnus-message 5 "nnimap: Generating active list%s...done" (if (> (length server) 0) (concat " for " server) "")) t)) @@ -822,8 +975,8 @@ (deffoo nnimap-request-post (&optional server) (let ((success t)) (dolist (mbx (message-unquote-tokens - (message-tokenize-header - (message-fetch-field "Newsgroups") ", ")) success) + (message-tokenize-header + (message-fetch-field "Newsgroups") ", ")) success) (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) (or (gnus-active to-newsgroup) (gnus-activate-group to-newsgroup) @@ -840,26 +993,102 @@ ;; Optional backend functions +(defun nnimap-string-lessp-numerical (s1 s2) + "Return t if first arg string is less than second in numerical order." + (cond ((string= s1 s2) + nil) + ((> (length s1) (length s2)) + nil) + ((< (length s1) (length s2)) + t) + ((< (string-to-number (substring s1 0 1)) + (string-to-number (substring s2 0 1))) + t) + ((> (string-to-number (substring s1 0 1)) + (string-to-number (substring s2 0 1))) + nil) + (t + (nnimap-string-lessp-numerical (substring s1 1) (substring s2 1))))) + (deffoo nnimap-retrieve-groups (groups &optional server) (when (nnimap-possibly-change-server server) (gnus-message 5 "nnimap: Checking mailboxes...") (with-current-buffer nntp-server-buffer (erase-buffer) (nnimap-before-find-minmax-bugworkaround) - (dolist (group groups) - (gnus-message 7 "nnimap: Checking mailbox %s" group) - (or (member "\\NoSelect" - (imap-mailbox-get 'list-flags group nnimap-server-buffer)) - (let ((info (nnimap-find-minmax-uid group 'examine))) - (insert (format "\"%s\" %d %d y\n" group - (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1)))))))) + (let (asyncgroups slowgroups) + (if (null nnimap-retrieve-groups-asynchronous) + (setq slowgroups groups) + (dolist (group groups) + (gnus-message 9 "nnimap: Quickly checking mailbox %s" group) + (add-to-list (if (gnus-gethash-safe + (gnus-group-prefixed-name group server) + nnimap-mailbox-info) + 'asyncgroups + 'slowgroups) + (list group (imap-mailbox-status-asynch + group '(uidvalidity uidnext unseen) + nnimap-server-buffer)))) + (dolist (asyncgroup asyncgroups) + (let ((group (nth 0 asyncgroup)) + (tag (nth 1 asyncgroup)) + new old) + (when (imap-ok-p (imap-wait-for-tag tag nnimap-server-buffer)) + (if (or (not (string= + (nth 0 (gnus-gethash (gnus-group-prefixed-name + group server) + nnimap-mailbox-info)) + (imap-mailbox-get 'uidvalidity group + nnimap-server-buffer))) + (not (string= + (nth 1 (gnus-gethash (gnus-group-prefixed-name + group server) + nnimap-mailbox-info)) + (imap-mailbox-get 'uidnext group + nnimap-server-buffer)))) + (push (list group) slowgroups) + (insert (nth 3 (gnus-gethash (gnus-group-prefixed-name + group server) + nnimap-mailbox-info)))))))) + (dolist (group slowgroups) + (if nnimap-retrieve-groups-asynchronous + (setq group (car group))) + (gnus-message 7 "nnimap: Mailbox %s modified" group) + (imap-mailbox-put 'uidnext nil group nnimap-server-buffer) + (or (member "\\NoSelect" (imap-mailbox-get 'list-flags group + nnimap-server-buffer)) + (let* ((info (nnimap-find-minmax-uid group 'examine)) + (str (format "\"%s\" %d %d y\n" group + (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))) + (when (> (or (imap-mailbox-get 'recent group + nnimap-server-buffer) 0) + 0) + (push (list (cons group 0)) nnmail-split-history)) + (insert str) + (when nnimap-retrieve-groups-asynchronous + (gnus-sethash + (gnus-group-prefixed-name group server) + (list (or (imap-mailbox-get + 'uidvalidity group nnimap-server-buffer) + (imap-mailbox-status + group 'uidvalidity nnimap-server-buffer)) + (or (imap-mailbox-get + 'uidnext group nnimap-server-buffer) + (imap-mailbox-status + group 'uidnext nnimap-server-buffer)) + (or (imap-mailbox-get + 'unseen group nnimap-server-buffer) + (imap-mailbox-status + group 'unseen nnimap-server-buffer)) + str) + nnimap-mailbox-info))))))) (gnus-message 5 "nnimap: Checking mailboxes...done") 'active)) (deffoo nnimap-request-update-info-internal (group info &optional server) (when (nnimap-possibly-change-group group server) - (when info;; xxx what does this mean? should we create a info? + (when info ;; xxx what does this mean? should we create a info? (with-current-buffer nnimap-server-buffer (gnus-message 5 "nnimap: Updating info for %s..." (gnus-info-group info)) @@ -887,12 +1116,13 @@ (gnus-info-set-read info seen))) (mapcar (lambda (pred) - (when (and (nnimap-mark-permanent-p (cdr pred)) - (member (nnimap-mark-to-flag (cdr pred)) - (imap-mailbox-get 'flags))) + (when (or (eq (cdr pred) 'recent) + (and (nnimap-mark-permanent-p (cdr pred)) + (member (nnimap-mark-to-flag (cdr pred)) + (imap-mailbox-get 'flags)))) (gnus-info-set-marks info - (nnimap-update-alist-soft + (gnus-update-alist-soft (cdr pred) (gnus-compress-sequence (imap-search (nnimap-mark-to-predicate (cdr pred)))) @@ -900,17 +1130,18 @@ t))) gnus-article-mark-lists) - ;; nnimap mark dormant article as ticked too (for other clients) - ;; so we remove that mark for gnus since we support dormant - (gnus-info-set-marks - info - (nnimap-update-alist-soft - 'tick - (gnus-remove-from-range - (cdr-safe (assoc 'tick (gnus-info-marks info))) - (cdr-safe (assoc 'dormant (gnus-info-marks info)))) - (gnus-info-marks info)) - t) + (when nnimap-importantize-dormant + ;; nnimap mark dormant article as ticked too (for other clients) + ;; so we remove that mark for gnus since we support dormant + (gnus-info-set-marks + info + (gnus-update-alist-soft + 'tick + (gnus-remove-from-range + (cdr-safe (assoc 'tick (gnus-info-marks info))) + (cdr-safe (assoc 'dormant (gnus-info-marks info)))) + (gnus-info-marks info)) + t)) (gnus-message 5 "nnimap: Updating info for %s...done" (gnus-info-group info)) @@ -932,11 +1163,22 @@ (what (nth 1 action)) (cmdmarks (nth 2 action)) marks) + ;; bookmark can't be stored (not list/range + (setq cmdmarks (delq 'bookmark cmdmarks)) + ;; killed can't be stored (not list/range + (setq cmdmarks (delq 'killed cmdmarks)) + ;; unsent are for nndraft groups only + (setq cmdmarks (delq 'unsent cmdmarks)) ;; cache flags are pointless on the server (setq cmdmarks (delq 'cache cmdmarks)) - ;; flag dormant articles as ticked - (if (memq 'dormant cmdmarks) - (setq cmdmarks (cons 'tick cmdmarks))) + ;; seen flags are local to each gnus + (setq cmdmarks (delq 'seen cmdmarks)) + ;; recent marks can't be set + (setq cmdmarks (delq 'recent cmdmarks)) + (when nnimap-importantize-dormant + ;; flag dormant articles as ticked + (if (memq 'dormant cmdmarks) + (setq cmdmarks (cons 'tick cmdmarks)))) ;; remove stuff we are forbidden to store (mapcar (lambda (mark) (if (imap-message-flag-permanent-p @@ -960,7 +1202,7 @@ nil) (defun nnimap-split-fancy () - "Like nnmail-split-fancy, but uses nnimap-split-fancy." + "Like the function `nnmail-split-fancy', but uses `nnimap-split-fancy'." (let ((nnmail-split-fancy nnimap-split-fancy)) (nnmail-split-fancy))) @@ -982,7 +1224,10 @@ (goto-char (point-min)) (when (and (if (stringp regexp) (progn - (setq regrepp (string-match "\\\\[0-9&]" group)) + (if (not (stringp group)) + (setq group (eval group)) + (setq regrepp + (string-match "\\\\[0-9&]" group))) (re-search-forward regexp nil t)) (funcall regexp group)) ;; Don't enter the article into the same group twice. @@ -1004,7 +1249,7 @@ (defun nnimap-split-find-rule (server inbox) (if (and (listp nnimap-split-rule) (listp (car nnimap-split-rule)) - (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule))) + (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule))) ;; extended format (cadr (nnimap-assoc-match inbox (cdr (nnimap-assoc-match server nnimap-split-rule)))) @@ -1021,33 +1266,56 @@ (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server))) ;; iterate over inboxes (while (and (setq inbox (pop inboxes)) - (nnimap-possibly-change-group inbox));; SELECT + (nnimap-possibly-change-group inbox)) ;; SELECT ;; find split rule for this server / inbox (when (setq rule (nnimap-split-find-rule server inbox)) ;; iterate over articles (dolist (article (imap-search nnimap-split-predicate)) - (when (nnimap-request-head article) + (when (if (if (eq nnimap-split-download-body 'default) + nnimap-split-download-body-default + nnimap-split-download-body) + (and (nnimap-request-article article) + (with-current-buffer nntp-server-buffer (mail-narrow-to-head))) + (nnimap-request-head article)) ;; copy article to right group(s) (setq removeorig nil) (dolist (to-group (nnimap-split-to-groups rule)) - (if (imap-message-copy (number-to-string article) - to-group nil 'nocopyuid) - (progn - (message "IMAP split moved %s:%s:%d to %s" server inbox - article to-group) - (setq removeorig t) - ;; Add the group-art list to the history list. - (push (list (cons to-group 0)) nnmail-split-history)) - (message "IMAP split failed to move %s:%s:%d to %s" server - inbox article to-group))) + (cond ((eq to-group 'junk) + (message "IMAP split removed %s:%s:%d" server inbox + article) + (setq removeorig t)) + ((imap-message-copy (number-to-string article) + to-group nil 'nocopyuid) + (message "IMAP split moved %s:%s:%d to %s" server + inbox article to-group) + (setq removeorig t) + (when nnmail-cache-accepted-message-ids + (with-current-buffer nntp-server-buffer + (let (msgid) + (and (setq msgid + (nnmail-fetch-field "message-id")) + (nnmail-cache-insert msgid + to-group + (nnmail-fetch-field "subject")))))) + ;; Add the group-art list to the history list. + (push (list (cons to-group 0)) nnmail-split-history)) + (t + (message "IMAP split failed to move %s:%s:%d to %s" + server inbox article to-group)))) + (if (if (eq nnimap-split-download-body 'default) + nnimap-split-download-body-default + nnimap-split-download-body) + (widen)) ;; remove article if it was successfully copied somewhere (and removeorig (imap-message-flags-add (format "%d" article) "\\Seen \\Deleted"))))) - (when (imap-mailbox-select inbox);; just in case + (when (imap-mailbox-select inbox) ;; just in case ;; todo: UID EXPUNGE (if available) to remove splitted articles (imap-mailbox-expunge) (imap-mailbox-close))) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-close)) t)))) (deffoo nnimap-request-scan (&optional group server) @@ -1062,7 +1330,7 @@ (nnimap-before-find-minmax-bugworkaround) (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) - (dolist (mbx (imap-mailbox-lsub "*" (car pattern) nil + (dolist (mbx (imap-mailbox-lsub (cdr pattern) (car pattern) nil nnimap-server-buffer)) (or (catch 'found (dolist (mailbox (imap-mailbox-get 'list-flags mbx @@ -1072,9 +1340,9 @@ nil) (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info - (insert (format "\"%s\" %d %d y\n" - mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))) + (insert (format "\"%s\" %d %d y\n" + mbx (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))))))) (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done" (if (> (length server) 0) " on " "") server)) t)) @@ -1082,7 +1350,9 @@ (deffoo nnimap-request-create-group (group &optional server args) (when (nnimap-possibly-change-server server) (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer) - (imap-mailbox-create group nnimap-server-buffer)))) + (imap-mailbox-create group nnimap-server-buffer) + (nnheader-report 'nnimap "%S" + (imap-error-text nnimap-server-buffer))))) (defun nnimap-time-substract (time1 time2) "Return TIME for TIME1 - TIME2." @@ -1108,36 +1378,53 @@ (gnus-message 5 "nnimap: Marking article %d for deletion..." imap-current-message)) +(defun nnimap-expiry-target (arts group server) + (unless (eq nnmail-expiry-target 'delete) + (with-temp-buffer + (dolist (art arts) + (nnimap-request-article art group server (current-buffer)) + ;; hints for optimization in `nnimap-request-accept-article' + (let ((nnimap-current-move-article art) + (nnimap-current-move-group group) + (nnimap-current-move-server server)) + (nnmail-expiry-target-group nnmail-expiry-target group)))) + ;; It is not clear if `nnmail-expiry-target' somehow cause the + ;; current group to be changed or not, so we make sure here. + (nnimap-possibly-change-group group server))) + ;; Notice that we don't actually delete anything, we just mark them deleted. (deffoo nnimap-request-expire-articles (articles group &optional server force) (let ((artseq (gnus-compress-sequence articles))) (when (and artseq (nnimap-possibly-change-group group server)) (with-current-buffer nnimap-server-buffer - (if force - (and (imap-message-flags-add - (imap-range-to-message-set artseq) "\\Deleted") - (setq articles nil)) - (let ((days (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function group)) - nnmail-expiry-wait))) - (cond ((eq days 'immediate) - (and (imap-message-flags-add - (imap-range-to-message-set artseq) "\\Deleted") - (setq articles nil))) - ((numberp days) - (let ((oldarts (imap-search - (format "UID %s NOT SINCE %s" - (imap-range-to-message-set artseq) - (nnimap-date-days-ago days)))) - (imap-fetch-data-hook - '(nnimap-request-expire-articles-progress))) - (and oldarts - (imap-message-flags-add - (imap-range-to-message-set - (gnus-compress-sequence oldarts)) - "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts))))))))))) + (let ((days (or (and nnmail-expiry-wait-function + (funcall nnmail-expiry-wait-function group)) + nnmail-expiry-wait))) + (cond ((or force (eq days 'immediate)) + (let ((oldarts (imap-search + (concat "UID " + (imap-range-to-message-set artseq))))) + (when oldarts + (nnimap-expiry-target oldarts group server) + (when (imap-message-flags-add + (imap-range-to-message-set + (gnus-compress-sequence oldarts)) "\\Deleted") + (setq articles (gnus-set-difference + articles oldarts)))))) + ((numberp days) + (let ((oldarts (imap-search + (format nnimap-expunge-search-string + (imap-range-to-message-set artseq) + (nnimap-date-days-ago days)))) + (imap-fetch-data-hook + '(nnimap-request-expire-articles-progress))) + (when oldarts + (nnimap-expiry-target oldarts group server) + (when (imap-message-flags-add + (imap-range-to-message-set + (gnus-compress-sequence oldarts)) "\\Deleted") + (setq articles (gnus-set-difference + articles oldarts))))))))))) ;; return articles not deleted articles) @@ -1158,7 +1445,9 @@ (setq result (eval accept-form)) (kill-buffer buf) result) - (nnimap-request-expire-articles (list article) group server t)) + (imap-message-flags-add + (imap-range-to-message-set (list article)) + "\\Deleted" 'silent nnimap-server-buffer)) result)))) (deffoo nnimap-request-accept-article (group &optional server last) @@ -1178,13 +1467,19 @@ ;; remove any 'From blabla' lines, some IMAP servers ;; reject the entire message otherwise. (when (looking-at "^From[^:]") - (kill-region (point) (progn (forward-line) (point)))) + (delete-region (point) (progn (forward-line) (point)))) ;; turn into rfc822 format (\r\n eol's) (while (search-forward "\n" nil t) - (replace-match "\r\n"))) - ;; this 'or' is for Cyrus server bug - (or (null (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)) + (replace-match "\r\n")) + (when nnmail-cache-accepted-message-ids + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject")))) + (when (and last nnmail-cache-accepted-message-ids) + (nnmail-cache-close)) + ;; this 'or' is for Cyrus server bug + (or (null (imap-current-mailbox nnimap-server-buffer)) + (imap-mailbox-unselect nnimap-server-buffer)) (imap-message-append group (current-buffer) nil nil nnimap-server-buffer))) (cons group (nth 1 uid)) @@ -1205,7 +1500,7 @@ (defun nnimap-expunge (mailbox server) (when (nnimap-possibly-change-group mailbox server) - (imap-mailbox-expunge nnimap-server-buffer))) + (imap-mailbox-expunge nil nnimap-server-buffer))) (defun nnimap-acl-get (mailbox server) (when (nnimap-possibly-change-server server) @@ -1253,12 +1548,13 @@ (mapcar (lambda (pair) ; cdr is the mark (or (assoc (cdr pair) - '((read . "SEEN") - (tick . "FLAGGED") - (draft . "DRAFT") - (reply . "ANSWERED"))) - (cons (cdr pair) - (format "KEYWORD gnus-%s" (symbol-name (cdr pair)))))) + '((read . "SEEN") + (tick . "FLAGGED") + (draft . "DRAFT") + (recent . "RECENT") + (reply . "ANSWERED"))) + (cons (cdr pair) + (format "KEYWORD gnus-%s" (symbol-name (cdr pair)))))) (cons '(read . read) gnus-article-mark-lists))) (defun nnimap-mark-to-predicate (pred) @@ -1271,12 +1567,13 @@ (mapcar (lambda (pair) (or (assoc (cdr pair) - '((read . "\\Seen") - (tick . "\\Flagged") - (draft . "\\Draft") - (reply . "\\Answered"))) - (cons (cdr pair) - (format "gnus-%s" (symbol-name (cdr pair)))))) + '((read . "\\Seen") + (tick . "\\Flagged") + (draft . "\\Draft") + (recent . "\\Recent") + (reply . "\\Answered"))) + (cons (cdr pair) + (format "gnus-%s" (symbol-name (cdr pair)))))) (cons '(read . read) gnus-article-mark-lists))) (defun nnimap-mark-to-flag-1 (preds) @@ -1306,86 +1603,67 @@ "Return t iff MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) -(defun nnimap-remassoc (key alist) - "Delete by side effect any elements of LIST whose car is `equal' to KEY. -The modified LIST is returned. If the first member -of LIST has a car that is `equal' to KEY, there is no way to remove it -by side effect; therefore, write `(setq foo (remassoc key foo))' to be -sure of changing the value of `foo'." - (when alist - (if (equal key (caar alist)) - (cdr alist) - (setcdr alist (nnimap-remassoc key (cdr alist))) - alist))) - -(defun nnimap-update-alist-soft (key value alist) - (if value - (cons (cons key value) (nnimap-remassoc key alist)) - (nnimap-remassoc key alist))) - (when nnimap-debug (require 'trace) - (buffer-disable-undo (get-buffer-create nnimap-debug)) - (mapcar (lambda (f) (trace-function-background f nnimap-debug)) - '( - nnimap-possibly-change-server - nnimap-verify-uidvalidity - nnimap-find-minmax-uid - nnimap-before-find-minmax-bugworkaround - nnimap-possibly-change-group - ;;nnimap-replace-whitespace - nnimap-retrieve-headers-progress - nnimap-retrieve-which-headers - nnimap-group-overview-filename - nnimap-retrieve-headers-from-file - nnimap-retrieve-headers-from-server - nnimap-retrieve-headers - nnimap-open-connection - nnimap-open-server - nnimap-server-opened - nnimap-close-server - nnimap-request-close - nnimap-status-message - ;;nnimap-demule - nnimap-request-article-part - nnimap-request-article - nnimap-request-head - nnimap-request-body - nnimap-request-group - nnimap-close-group - nnimap-pattern-to-list-arguments - nnimap-request-list - nnimap-request-post - nnimap-retrieve-groups - nnimap-request-update-info-internal - nnimap-request-type - nnimap-request-set-mark - nnimap-split-to-groups - nnimap-split-find-rule - nnimap-split-find-inbox - nnimap-split-articles - nnimap-request-scan - nnimap-request-newgroups - nnimap-request-create-group - nnimap-time-substract - nnimap-date-days-ago - nnimap-request-expire-articles-progress - nnimap-request-expire-articles - nnimap-request-move-article - nnimap-request-accept-article - nnimap-request-delete-group - nnimap-request-rename-group - gnus-group-nnimap-expunge - gnus-group-nnimap-edit-acl - gnus-group-nnimap-edit-acl-done - nnimap-group-mode-hook - nnimap-mark-to-predicate - nnimap-mark-to-flag-1 - nnimap-mark-to-flag - nnimap-mark-permanent-p - nnimap-remassoc - nnimap-update-alist-soft - ))) + (buffer-disable-undo (get-buffer-create nnimap-debug-buffer)) + (mapcar (lambda (f) (trace-function-background f nnimap-debug-buffer)) + '( + nnimap-possibly-change-server + nnimap-verify-uidvalidity + nnimap-find-minmax-uid + nnimap-before-find-minmax-bugworkaround + nnimap-possibly-change-group + ;;nnimap-replace-whitespace + nnimap-retrieve-headers-progress + nnimap-retrieve-which-headers + nnimap-group-overview-filename + nnimap-retrieve-headers-from-file + nnimap-retrieve-headers-from-server + nnimap-retrieve-headers + nnimap-open-connection + nnimap-open-server + nnimap-server-opened + nnimap-close-server + nnimap-request-close + nnimap-status-message + ;;nnimap-demule + nnimap-request-article-part + nnimap-request-article + nnimap-request-head + nnimap-request-body + nnimap-request-group + nnimap-close-group + nnimap-pattern-to-list-arguments + nnimap-request-list + nnimap-request-post + nnimap-retrieve-groups + nnimap-request-update-info-internal + nnimap-request-type + nnimap-request-set-mark + nnimap-split-to-groups + nnimap-split-find-rule + nnimap-split-find-inbox + nnimap-split-articles + nnimap-request-scan + nnimap-request-newgroups + nnimap-request-create-group + nnimap-time-substract + nnimap-date-days-ago + nnimap-request-expire-articles-progress + nnimap-request-expire-articles + nnimap-request-move-article + nnimap-request-accept-article + nnimap-request-delete-group + nnimap-request-rename-group + gnus-group-nnimap-expunge + gnus-group-nnimap-edit-acl + gnus-group-nnimap-edit-acl-done + nnimap-group-mode-hook + nnimap-mark-to-predicate + nnimap-mark-to-flag-1 + nnimap-mark-to-flag + nnimap-mark-permanent-p + ))) (provide 'nnimap)
--- a/lisp/gnus/nnkiboze.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnkiboze.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; nnkiboze.el --- select virtual news access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -109,10 +109,12 @@ (setq num (string-to-int (match-string 2 xref)) group (match-string 1 xref)) (or (with-current-buffer buffer - (gnus-cache-request-article num group)) + (or (and gnus-use-cache (gnus-cache-request-article num group)) + (gnus-agent-request-article num group))) (gnus-request-article num group buffer))))) (deffoo nnkiboze-request-scan (&optional group server) + (nnkiboze-possibly-change-group group) (nnkiboze-generate-group (concat "nnkiboze:" group))) (deffoo nnkiboze-request-group (group &optional server dont-check) @@ -227,11 +229,11 @@ (defun nnkiboze-generate-group (group &optional inhibit-list-groups) (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) (newsrc-file (concat nnkiboze-directory - (nnheader-translate-file-chars - (concat group ".newsrc")))) + (nnheader-translate-file-chars + (concat group ".newsrc")))) (nov-file (concat nnkiboze-directory - (nnheader-translate-file-chars - (concat group ".nov")))) + (nnheader-translate-file-chars + (concat group ".nov")))) method nnkiboze-newsrc gname newsrc active ginfo lowest glevel orig-info nov-buffer ;; Bind various things to nil to make group entry faster. @@ -242,112 +244,116 @@ (gnus-score-use-all-scores nil) (gnus-use-scoring t) (gnus-verbose (min gnus-verbose 3)) - gnus-select-group-hook gnus-summary-prepare-hook + gnus-select-group-hook gnus-summary-prepare-hook gnus-thread-sort-functions gnus-show-threads gnus-visual gnus-suppress-duplicates num-unread) (unless info (error "No such group: %s" group)) ;; Load the kiboze newsrc file for this group. - (when (file-exists-p newsrc-file) - (load newsrc-file)) - (let ((coding-system-for-write nnkiboze-file-coding-system)) - (with-temp-file nov-file - (when (file-exists-p nov-file) - (insert-file-contents nov-file)) - (setq nov-buffer (current-buffer)) - ;; Go through the active hashtb and add new all groups that match the - ;; kiboze regexp. - (mapatoms - (lambda (group) - (and (string-match nnkiboze-regexp - (setq gname (symbol-name group))) ; Match - (not (assoc gname nnkiboze-newsrc)) ; It isn't registered - (numberp (car (symbol-value group))) ; It is active - (or (> nnkiboze-level 7) - (and (setq glevel (nth 1 (nth 2 (gnus-gethash - gname gnus-newsrc-hashtb)))) - (>= nnkiboze-level glevel))) - (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes - (push (cons gname (1- (car (symbol-value group)))) - nnkiboze-newsrc))) - gnus-active-hashtb) - ;; `newsrc' is set to the list of groups that possibly are - ;; component groups to this kiboze group. This list has elements - ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest - ;; number that has been kibozed in GROUP in this kiboze group. - (setq newsrc nnkiboze-newsrc) - (while newsrc - (if (not (setq active (gnus-gethash - (caar newsrc) gnus-active-hashtb))) - ;; This group isn't active after all, so we remove it from - ;; the list of component groups. - (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) - (setq lowest (cdar newsrc)) - ;; Ok, we have a valid component group, so we jump to it. - (switch-to-buffer gnus-group-buffer) - (gnus-group-jump-to-group (caar newsrc)) - (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) - (setq ginfo (gnus-get-info (gnus-group-group-name)) - orig-info (gnus-copy-sequence ginfo) - num-unread (car (gnus-gethash (caar newsrc) - gnus-newsrc-hashtb))) - (unwind-protect - (progn - ;; We set all list of article marks to nil. Since we operate - ;; on copies of the real lists, we can destroy anything we - ;; want here. - (when (nth 3 ginfo) - (setcar (nthcdr 3 ginfo) nil)) - ;; We set the list of read articles to be what we expect for - ;; this kiboze group -- either nil or `(1 . LOWEST)'. - (when ginfo - (setcar (nthcdr 2 ginfo) - (and (not (= lowest 1)) (cons 1 lowest)))) - (when (and (or (not ginfo) - (> (length (gnus-list-of-unread-articles - (car ginfo))) - 0)) - (progn - (ignore-errors - (gnus-group-select-group nil)) - (eq major-mode 'gnus-summary-mode))) - ;; We are now in the group where we want to be. - (setq method (gnus-find-method-for-group - gnus-newsgroup-name)) - (when (eq method gnus-select-method) - (setq method nil)) - ;; We go through the list of scored articles. - (while gnus-newsgroup-scored - (when (> (caar gnus-newsgroup-scored) lowest) - ;; If it has a good score, then we enter this article - ;; into the kiboze group. - (nnkiboze-enter-nov - nov-buffer - (gnus-summary-article-header - (caar gnus-newsgroup-scored)) - gnus-newsgroup-name)) - (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) - ;; That's it. We exit this group. - (when (eq major-mode 'gnus-summary-mode) - (kill-buffer (current-buffer))))) - ;; Restore the proper info. - (when ginfo - (setcdr ginfo (cdr orig-info))) - (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb) - num-unread))) - (setcdr (car newsrc) (car active)) - (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) - (setq newsrc (cdr newsrc))))) - ;; We save the kiboze newsrc for this group. - (with-temp-file newsrc-file - (insert "(setq nnkiboze-newsrc '") - (gnus-prin1 nnkiboze-newsrc) - (insert ")\n"))) + (mm-with-unibyte + (when (file-exists-p newsrc-file) + (load newsrc-file)) + (let ((coding-system-for-write nnkiboze-file-coding-system)) + (gnus-make-directory (file-name-directory nov-file)) + (with-temp-file nov-file + (when (file-exists-p nov-file) + (insert-file-contents nov-file)) + (setq nov-buffer (current-buffer)) + ;; Go through the active hashtb and add new all groups that match the + ;; kiboze regexp. + (mapatoms + (lambda (group) + (and (string-match nnkiboze-regexp + (setq gname (symbol-name group))) ; Match + (not (assoc gname nnkiboze-newsrc)) ; It isn't registered + (numberp (car (symbol-value group))) ; It is active + (or (> nnkiboze-level 7) + (and (setq glevel + (nth 1 (nth 2 (gnus-gethash + gname gnus-newsrc-hashtb)))) + (>= nnkiboze-level glevel))) + (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes + (push (cons gname (1- (car (symbol-value group)))) + nnkiboze-newsrc))) + gnus-active-hashtb) + ;; `newsrc' is set to the list of groups that possibly are + ;; component groups to this kiboze group. This list has elements + ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest + ;; number that has been kibozed in GROUP in this kiboze group. + (setq newsrc nnkiboze-newsrc) + (while newsrc + (if (not (setq active (gnus-gethash + (caar newsrc) gnus-active-hashtb))) + ;; This group isn't active after all, so we remove it from + ;; the list of component groups. + (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) + (setq lowest (cdar newsrc)) + ;; Ok, we have a valid component group, so we jump to it. + (switch-to-buffer gnus-group-buffer) + (gnus-group-jump-to-group (caar newsrc)) + (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) + (setq ginfo (gnus-get-info (gnus-group-group-name)) + orig-info (gnus-copy-sequence ginfo) + num-unread (car (gnus-gethash (caar newsrc) + gnus-newsrc-hashtb))) + (unwind-protect + (progn + ;; We set all list of article marks to nil. Since we operate + ;; on copies of the real lists, we can destroy anything we + ;; want here. + (when (nth 3 ginfo) + (setcar (nthcdr 3 ginfo) nil)) + ;; We set the list of read articles to be what we expect for + ;; this kiboze group -- either nil or `(1 . LOWEST)'. + (when ginfo + (setcar (nthcdr 2 ginfo) + (and (not (= lowest 1)) (cons 1 lowest)))) + (when (and (or (not ginfo) + (> (length (gnus-list-of-unread-articles + (car ginfo))) + 0)) + (progn + (ignore-errors + (gnus-group-select-group nil)) + (eq major-mode 'gnus-summary-mode))) + ;; We are now in the group where we want to be. + (setq method (gnus-find-method-for-group + gnus-newsgroup-name)) + (when (eq method gnus-select-method) + (setq method nil)) + ;; We go through the list of scored articles. + (while gnus-newsgroup-scored + (when (> (caar gnus-newsgroup-scored) lowest) + ;; If it has a good score, then we enter this article + ;; into the kiboze group. + (nnkiboze-enter-nov + nov-buffer + (gnus-summary-article-header + (caar gnus-newsgroup-scored)) + gnus-newsgroup-name)) + (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) + ;; That's it. We exit this group. + (when (eq major-mode 'gnus-summary-mode) + (kill-buffer (current-buffer))))) + ;; Restore the proper info. + (when ginfo + (setcdr ginfo (cdr orig-info))) + (setcar (gnus-gethash (caar newsrc) gnus-newsrc-hashtb) + num-unread))) + (setcdr (car newsrc) (cdr active)) + (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) + (setq newsrc (cdr newsrc))))) + ;; We save the kiboze newsrc for this group. + (gnus-make-directory (file-name-directory newsrc-file)) + (with-temp-file newsrc-file + (insert "(setq nnkiboze-newsrc '") + (gnus-prin1 nnkiboze-newsrc) + (insert ")\n"))) (unless inhibit-list-groups (save-excursion (set-buffer gnus-group-buffer) (gnus-group-list-groups))) - t) + t)) (defun nnkiboze-enter-nov (buffer header group) (save-excursion
--- a/lisp/gnus/nnlistserv.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnlistserv.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; nnlistserv.el --- retrieving articles via web mailing list archives -;; Copyright (C) 1997, 1998, 1999, 2000, 2004 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 1999, 2000 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail @@ -24,18 +24,13 @@ ;;; Commentary: -;; Note: You need to have `url' and `w3' installed for this -;; backend to work. - ;;; Code: (eval-when-compile (require 'cl)) (require 'nnoo) -(eval-when-compile - (ignore-errors - (require 'nnweb)) ; requires W3 - (autoload 'url-insert-file-contents "nnweb")) +(require 'mm-url) +(require 'nnweb) (nnoo-declare nnlistserv nnweb) @@ -98,7 +93,7 @@ (when (funcall (nnweb-definition 'search) page) ;; Go through all the article hits on this page. (goto-char (point-min)) - (nnweb-decode-entities) + (mm-url-decode-entities) (goto-char (point-min)) (while (re-search-forward "^<li> *<a href=\"\\([^\"]+\\)\"><b>\\([^\\>]+\\)</b></a> *<[^>]+><i>\\([^>]+\\)<" nil t) (setq url (match-string 1) @@ -124,10 +119,10 @@ (let ((case-fold-search t) (headers '(sent name email subject id)) sent name email subject id) - (nnweb-decode-entities) + (mm-url-decode-entities) (while headers (goto-char (point-min)) - (re-search-forward (format "<!-- %s=\"\\([^\"]+\\)" (car headers)) nil t) + (re-search-forward (format "<!-- %s=\"\\([^\"]+\\)" (car headers) nil t)) (set (pop headers) (match-string 1))) (goto-char (point-min)) (search-forward "<!-- body" nil t) @@ -135,7 +130,7 @@ (goto-char (point-max)) (search-backward "<!-- body" nil t) (delete-region (point-max) (progn (beginning-of-line) (point))) - (nnweb-remove-markup) + (mm-url-remove-markup) (goto-char (point-min)) (insert (format "From: %s <%s>\n" name email) (format "Subject: %s\n" subject) @@ -143,7 +138,7 @@ (format "Date: %s\n\n" sent)))) (defun nnlistserv-kk-search (search) - (url-insert-file-contents + (mm-url-insert (concat (format (nnweb-definition 'address) search) (nnweb-definition 'index))) t)
--- a/lisp/gnus/nnmail.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnmail.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; nnmail.el --- mail support functions for the Gnus mail backends -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -28,6 +28,7 @@ (eval-when-compile (require 'cl)) +(require 'gnus) ; for macro gnus-kill-buffer, at least (require 'nnheader) (require 'message) (require 'custom) @@ -36,8 +37,8 @@ (require 'mm-util) (eval-and-compile - (autoload 'gnus-error "gnus-util") - (autoload 'gnus-buffer-live-p "gnus-util")) + (autoload 'gnus-add-buffer "gnus") + (autoload 'gnus-kill-buffer "gnus")) (defgroup nnmail nil "Reading mail with Gnus." @@ -76,8 +77,7 @@ "Various mail options." :group 'nnmail) -(defcustom nnmail-split-methods - '(("mail.misc" "")) +(defcustom nnmail-split-methods '(("mail.misc" "")) "*Incoming mail will be split according to this variable. If you'd like, for instance, one mail group for mail from the @@ -86,8 +86,8 @@ (setq nnmail-split-methods '((\"mail.4ad\" \"From:.*4ad\") - (\"mail.junk\" \"From:.*Lars\\\\|Subject:.*buy\") - (\"mail.misc\" \"\"))) + (\"mail.junk\" \"From:.*Lars\\\\|Subject:.*buy\") + (\"mail.misc\" \"\"))) As you can see, this variable is a list of lists, where the first element in each \"rule\" is the name of the group (which, by the way, @@ -104,7 +104,8 @@ This variable can also have a function as its value." :group 'nnmail-split - :type '(choice (repeat :tag "Alist" (group (string :tag "Name") regexp)) + :type '(choice (repeat :tag "Alist" (group (string :tag "Name") + (choice regexp function))) (function-item nnmail-split-fancy) (function :tag "Other"))) @@ -115,6 +116,22 @@ :group 'nnmail-split :type 'boolean) +(defcustom nnmail-split-fancy-with-parent-ignore-groups nil + "Regexp that matches group names to be ignored when applying `nnmail-split-fancy-with-parent'. +This can also be a list of regexps." + :group 'nnmail-split + :type '(choice (const :tag "none" nil) + (regexp :value ".*") + (repeat :value (".*") regexp))) + +(defcustom nnmail-cache-ignore-groups nil + "Regexp that matches group names to be ignored when inserting message ids into the cache (`nnmail-cache-insert'). +This can also be a list of regexps." + :group 'nnmail-split + :type '(choice (const :tag "none" nil) + (regexp :value ".*") + (repeat :value (".*") regexp))) + ;; Added by gord@enci.ucalgary.ca (Gordon Matzigkeit). (defcustom nnmail-keep-last-article nil "If non-nil, nnmail will never delete/move a group's last article. @@ -145,22 +162,22 @@ can also be `immediate' and `never'." :group 'nnmail-expire :type '(choice (const immediate) - (integer :tag "days") + (number :tag "days") (const never))) (defcustom nnmail-expiry-wait-function nil "Variable that holds function to specify how old articles should be before they are expired. - The function will be called with the name of the group that the -expiry is to be performed in, and it should return an integer that -says how many days an article can be stored before it is considered -\"old\". It can also return the values `never' and `immediate'. +The function will be called with the name of the group that the expiry +is to be performed in, and it should return an integer that says how +many days an article can be stored before it is considered \"old\". +It can also return the values `never' and `immediate'. Eg.: \(setq nnmail-expiry-wait-function (lambda (newsgroup) - (cond ((string-match \"private\" newsgroup) 31) - ((string-match \"junk\" newsgroup) 1) + (cond ((string-match \"private\" newsgroup) 31) + ((string-match \"junk\" newsgroup) 1) ((string-match \"important\" newsgroup) 'never) (t 7))))" :group 'nnmail-expire @@ -176,13 +193,47 @@ receives one argument, the name of the group the message comes from. The return value should be `delete' or a group name (a string)." :version "21.1" - :group 'nnmail-expire - :type '(choice (const delete) - (function :format "%v" nnmail-) - string)) + :group 'nnmail-expire + :type '(choice (const delete) + (function :format "%v" nnmail-) + string)) + +(defcustom nnmail-fancy-expiry-targets nil + "Determine expiry target based on articles using fancy techniques. + +This is a list of (\"HEADER\" \"REGEXP\" \"TARGET\") entries. If +`nnmail-expiry-target' is set to the function +`nnmail-fancy-expiry-target' and HEADER of the article matches REGEXP, +the message will be expired to a group determined by invoking +`format-time-string' with TARGET used as the format string and the +time extracted from the articles' Date header (if missing the current +time is used). + +In the special cases that HEADER is the symbol `to-from', the regexp +will try to match against both the From and the To header. + +Example: + +\(setq nnmail-fancy-expiry-targets + '((to-from \"boss\" \"nnfolder:Work\") + (\"Subject\" \"IMPORTANT\" \"nnfolder:IMPORTANT.%Y.%b\") + (\"from\" \".*\" \"nnfolder:Archive-%Y\"))) + +In this case, articles containing the string \"boss\" in the To or the +From header will be expired to the group \"nnfolder:Work\"; +articles containing the sting \"IMPORTANT\" in the Subject header will +be expired to the group \"nnfolder:IMPORTANT.YYYY.MMM\"; and +everything else will be expired to \"nnfolder:Archive-YYYY\"." + :group 'nnmail-expire + :type '(repeat (list (choice :tag "Match against" + (string :tag "Header") + (const to-from)) + regexp + (string :tag "Target group format string")))) (defcustom nnmail-cache-accepted-message-ids nil - "If non-nil, put Message-IDs of Gcc'd articles into the duplicate cache." + "If non-nil, put Message-IDs of Gcc'd articles into the duplicate cache. +If non-nil, also update the cache when copy or move articles." :group 'nnmail :type 'boolean) @@ -237,9 +288,9 @@ Eg. \(add-hook 'nnmail-read-incoming-hook - (lambda () - (call-process \"/local/bin/mailsend\" nil nil nil - \"read\" nnmail-spool-file))) + (lambda () + (call-process \"/local/bin/mailsend\" nil nil nil + \"read\" nnmail-spool-file))) If you have xwatch running, this will alert it that mail has been read. @@ -299,12 +350,82 @@ :group 'nnmail-split :type 'hook) +(defcustom nnmail-spool-hook nil + "*A hook called when a new article is spooled." + :group 'nnmail + :type 'hook) + (defcustom nnmail-large-newsgroup 50 - "*The number of the articles which indicates a large newsgroup. -If the number of the articles is greater than the value, verbose + "*The number of articles which indicates a large newsgroup or nil. +If the number of articles is greater than the value, verbose messages will be shown to indicate the current status." :group 'nnmail-various - :type 'integer) + :type '(choice (const :tag "infinite" nil) + (number :tag "count"))) + +(define-widget 'nnmail-lazy 'default + "Base widget for recursive datastructures. + +This is copy of the `lazy' widget in Emacs 21.4 provided for compatibility." + :format "%{%t%}: %v" + :convert-widget 'widget-value-convert-widget + :value-create (lambda (widget) + (let ((value (widget-get widget :value)) + (type (widget-get widget :type))) + (widget-put widget :children + (list (widget-create-child-value + widget (widget-convert type) value))))) + :value-delete 'widget-children-value-delete + :value-get (lambda (widget) + (widget-value (car (widget-get widget :children)))) + :value-inline (lambda (widget) + (widget-apply (car (widget-get widget :children)) + :value-inline)) + :default-get (lambda (widget) + (widget-default-get + (widget-convert (widget-get widget :type)))) + :match (lambda (widget value) + (widget-apply (widget-convert (widget-get widget :type)) + :match value)) + :validate (lambda (widget) + (widget-apply (car (widget-get widget :children)) :validate))) + +(define-widget 'nnmail-split-fancy 'nnmail-lazy + "Widget for customizing splits in the variable of the same name." + :tag "Split" + :type '(menu-choice :value (any ".*value.*" "misc") + :tag "Type" + (string :tag "Destination") + (list :tag "Use first match (|)" :value (|) + (const :format "" |) + (editable-list :inline t nnmail-split-fancy)) + (list :tag "Use all matches (&)" :value (&) + (const :format "" &) + (editable-list :inline t nnmail-split-fancy)) + (list :tag "Function with fixed arguments (:)" + :value (: nil) + (const :format "" :value :) + function + (editable-list :inline t (sexp :tag "Arg")) + ) + (list :tag "Function with split arguments (!)" + :value (! nil) + (const :format "" !) + function + (editable-list :inline t nnmail-split-fancy)) + (list :tag "Field match" + (choice :tag "Field" + regexp symbol) + (choice :tag "Match" + regexp + (symbol :value mail)) + (repeat :inline t + :tag "Restrictions" + (group :inline t + (const :format "" -) + regexp)) + nnmail-split-fancy) + (const :tag "Junk (delete mail)" junk))) (defcustom nnmail-split-fancy "mail.misc" "Incoming mail can be split according to this fancy variable. @@ -336,6 +457,12 @@ return value FUNCTION should be a split, which is then recursively processed. +junk: Mail will be deleted. Use with care! Do not submerge in water! + Example: + (setq nnmail-split-fancy + '(| (\"Subject\" \"MAKE MONEY FAST\" junk) + ...other.rules.omitted...)) + FIELD must match a complete field name. VALUE must match a complete word according to the `nnmail-split-fancy-syntax-table' syntax table. You can use \".*\" in the regexps to match partial field names or words. @@ -363,20 +490,19 @@ ;; Other mailing lists... (any \"procmail@informatik\\\\.rwth-aachen\\\\.de\" \"procmail.list\") (any \"SmartList@informatik\\\\.rwth-aachen\\\\.de\" \"SmartList.list\") - ;; Both lists below have the same suffix, so prevent - ;; cross-posting to mkpkg.list of messages posted only to - ;; the bugs- list, but allow cross-posting when the - ;; message was really cross-posted. - (any \"bugs-mypackage@somewhere\" \"mypkg.bugs\") - (any \"mypackage@somewhere\" - \"bugs-mypackage\" \"mypkg.list\") - ;; + ;; Both lists below have the same suffix, so prevent + ;; cross-posting to mkpkg.list of messages posted only to + ;; the bugs- list, but allow cross-posting when the + ;; message was really cross-posted. + (any \"bugs-mypackage@somewhere\" \"mypkg.bugs\") + (any \"mypackage@somewhere\" - \"bugs-mypackage\" \"mypkg.list\") + ;; ;; People... (any \"larsi@ifi\\\\.uio\\\\.no\" \"people.Lars Magne Ingebrigtsen\")) ;; Unmatched mail goes to the catch all group. \"misc.misc\"))" :group 'nnmail-split - ;; Sigh! - :type 'sexp) + :type 'nnmail-split-fancy) (defcustom nnmail-split-abbrev-alist '((any . "from\\|to\\|cc\\|sender\\|apparently-to\\|resent-from\\|resent-to\\|resent-cc") @@ -418,7 +544,7 @@ (const warn) (const delete))) -(defcustom nnmail-extra-headers nil +(defcustom nnmail-extra-headers '(To Newsgroups) "*Extra headers to parse." :version "21.1" :group 'nnmail @@ -430,18 +556,39 @@ :group 'nnmail :type 'integer) +(defcustom nnmail-mail-splitting-charset nil + "Default charset to be used when splitting incoming mail." + :group 'nnmail + :type 'symbol) + +(defcustom nnmail-mail-splitting-decodes nil + "Whether the nnmail splitting functionality should MIME decode headers." + :group 'nnmail + :type 'boolean) + +(defcustom nnmail-split-fancy-match-partial-words nil + "Whether to match partial words when fancy splitting. +Normally, regexes given in `nnmail-split-fancy' are implicitly surrounded +by \"\\=\\<...\\>\". If this variable is true, they are not implicitly\ + surrounded +by anything." + :group 'nnmail + :type 'boolean) + ;;; Internal variables. +(defvar nnmail-article-buffer " *nnmail incoming*" + "The buffer used for splitting incoming mails.") + (defvar nnmail-split-history nil "List of group/article elements that say where the previous split put messages.") -(defvar nnmail-split-fancy-syntax-table nil +(defvar nnmail-split-fancy-syntax-table + (let ((table (make-syntax-table))) + ;; support the %-hack + (modify-syntax-entry ?\% "." table) + table) "Syntax table used by `nnmail-split-fancy'.") -(unless (syntax-table-p nnmail-split-fancy-syntax-table) - (setq nnmail-split-fancy-syntax-table - (copy-syntax-table (standard-syntax-table))) - ;; support the %-hack - (modify-syntax-entry ?\% "." nnmail-split-fancy-syntax-table)) (defvar nnmail-prepare-save-mail-hook nil "Hook called before saving mail.") @@ -451,11 +598,6 @@ -(defconst nnmail-version "nnmail 1.0" - "nnmail version.") - - - (defun nnmail-request-post (&optional server) (mail-send-and-exit nil)) @@ -474,7 +616,7 @@ (set-buffer nntp-server-buffer) (delete-region (point-min) (point-max)) (let ((format-alist nil) - (after-insert-file-functions nil)) + (after-insert-file-functions nil)) (condition-case () (let ((coding-system-for-read nnmail-file-coding-system) (auto-mode-alist (mm-auto-mode-alist)) @@ -529,8 +671,8 @@ (setq group (read buffer)) (unless (stringp group) (setq group (symbol-name group))) - (if (and (numberp (setq max (read nntp-server-buffer))) - (numberp (setq min (read nntp-server-buffer)))) + (if (and (numberp (setq max (read buffer))) + (numberp (setq min (read buffer)))) (push (list group (cons min max)) group-assoc))) (error nil)) @@ -715,7 +857,9 @@ (if (not (and (re-search-forward "^From " nil t) (goto-char (match-beginning 0)))) ;; Possibly wrong format? - (error "Error, unknown mail format! (Possibly corrupted.)") + (error "Error, unknown mail format! (Possibly corrupted %s `%s'.)" + (if (buffer-file-name) "file" "buffer") + (or (buffer-file-name) (buffer-name))) ;; Carry on until the bitter end. (while (not (eobp)) (setq start (point) @@ -887,7 +1031,7 @@ group artnum-func) "Go through the entire INCOMING file and pick out each individual mail. FUNC will be called with the buffer narrowed to each mail." - (let (;; If this is a group-specific split, we bind the split + (let ( ;; If this is a group-specific split, we bind the split ;; methods to just this group. (nnmail-split-methods (if (and group (not nnmail-resplit-incoming)) @@ -895,7 +1039,7 @@ nnmail-split-methods))) (save-excursion ;; Insert the incoming file. - (set-buffer (get-buffer-create " *nnmail incoming*")) + (set-buffer (get-buffer-create nnmail-article-buffer)) (erase-buffer) (let ((coding-system-for-read nnmail-incoming-coding-system)) (mm-insert-file-contents incoming)) @@ -923,10 +1067,9 @@ (defun nnmail-article-group (func &optional trace) "Look at the headers and return an alist of groups that match. FUNC will be called with the group name to determine the article number." - (let ((methods nnmail-split-methods) + (let ((methods (or nnmail-split-methods '(("bogus" "")))) (obuf (current-buffer)) - (beg (point-min)) - end group-art method grp) + group-art method grp) (if (and (sequencep methods) (= (length methods) 1)) ;; If there is only just one group to put everything in, we @@ -935,13 +1078,21 @@ (list (cons (caar methods) (funcall func (caar methods))))) ;; We do actual comparison. (save-excursion - ;; Find headers. - (goto-char beg) - (setq end (if (search-forward "\n\n" nil t) (point) (point-max))) + ;; Copy the article into the work buffer. (set-buffer nntp-server-buffer) (erase-buffer) - ;; Copy the headers into the work buffer. - (insert-buffer-substring obuf beg end) + (insert-buffer-substring obuf) + ;; Narrow to headers. + (narrow-to-region + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (point) + (point-max))) + (goto-char (point-min)) + ;; Decode MIME headers and charsets. + (when nnmail-mail-splitting-decodes + (let ((mail-parse-charset nnmail-mail-splitting-charset)) + (mail-decode-encoded-word-region (point-min) (point-max)))) ;; Fold continuation lines. (goto-char (point-min)) (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) @@ -954,7 +1105,7 @@ (while (not (eobp)) (unless (< (move-to-column nnmail-split-header-length-limit) nnmail-split-header-length-limit) - (delete-region (point) (progn (end-of-line) (point)))) + (delete-region (point) (gnus-point-at-eol))) (forward-line 1)) ;; Allow washing. (goto-char (point-min)) @@ -971,8 +1122,8 @@ (or (funcall nnmail-split-methods) '("bogus")) (error - (nnheader-message 5 - "Error in `nnmail-split-methods'; using `bogus' mail group") + (nnheader-message + 5 "Error in `nnmail-split-methods'; using `bogus' mail group") (sit-for 1) '("bogus"))))) (setq split (gnus-remove-duplicates split)) @@ -1017,19 +1168,22 @@ (unless group-art (setq group-art (list (cons (car method) - (funcall func (car method))))))))) + (funcall func (car method)))))))) + ;; Fall back on "bogus" if all else fails. + (unless group-art + (setq group-art (list (cons "bogus" (funcall func "bogus")))))) ;; Produce a trace if non-empty. (when (and trace nnmail-split-trace) - (let ((trace (nreverse nnmail-split-trace)) - (restore (current-buffer))) + (let ((restore (current-buffer))) (nnheader-set-temp-buffer "*Split Trace*") (gnus-add-buffer) - (while trace - (insert (car trace) "\n") - (setq trace (cdr trace))) + (dolist (trace (nreverse nnmail-split-trace)) + (prin1 trace (current-buffer)) + (insert "\n")) (goto-char (point-min)) (gnus-configure-windows 'split-trace) (set-buffer restore))) + (widen) ;; See whether the split methods returned `junk'. (if (equal group-art '(junk)) nil @@ -1091,14 +1245,21 @@ (defun nnmail-remove-list-identifiers () "Remove list identifiers from Subject headers." - (let ((regexp (if (stringp nnmail-list-identifiers) nnmail-list-identifiers - (mapconcat 'identity nnmail-list-identifiers " *\\|")))) + (let ((regexp + (if (consp nnmail-list-identifiers) + (mapconcat 'identity nnmail-list-identifiers " *\\|") + nnmail-list-identifiers))) (when regexp (goto-char (point-min)) - (when (re-search-forward - (concat "^Subject: +\\(Re: +\\)?\\(" regexp " *\\)") - nil t) - (delete-region (match-beginning 2) (match-end 0)))))) + (while (re-search-forward + (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") + nil t) + (delete-region (match-beginning 2) (match-end 0)) + (beginning-of-line)) + (when (re-search-forward "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" + nil t) + (delete-region (match-beginning 1) (match-end 1)) + (beginning-of-line))))) (defun nnmail-remove-tabs () "Translate TAB characters into SPACE characters." @@ -1113,17 +1274,39 @@ (beginning-of-line) (insert "X-Gnus-Broken-Eudora-")) (goto-char (point-min)) - (when (re-search-forward "^In-Reply-To:[^\n]+\\(\n[ \t]+\\)" nil t) - (replace-match "" t t nil 1)))) + (when (re-search-forward "^\\(In-Reply-To:[^\n]+\\)\n[ \t]+" nil t) + (replace-match "\\1" t)))) (custom-add-option 'nnmail-prepare-incoming-header-hook 'nnmail-fix-eudora-headers) ;;; Utility functions +(defun nnmail-do-request-post (accept-func &optional server) + "Utility function to directly post a message to an nnmail-derived group. +Calls ACCEPT-FUNC (which should be `nnchoke-request-accept-article') +to actually put the message in the right group." + (let ((success t)) + (dolist (mbx (message-unquote-tokens + (message-tokenize-header + (message-fetch-field "Newsgroups") ", ")) success) + (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) + (or (gnus-active to-newsgroup) + (gnus-activate-group to-newsgroup) + (if (gnus-y-or-n-p (format "No such group: %s. Create it? " + to-newsgroup)) + (or (and (gnus-request-create-group + to-newsgroup gnus-command-method) + (gnus-activate-group to-newsgroup nil nil + gnus-command-method)) + (error "Couldn't create group %s" to-newsgroup))) + (error "No such group: %s" to-newsgroup)) + (unless (funcall accept-func mbx (nth 1 gnus-command-method)) + (setq success nil)))))) + (defun nnmail-split-fancy () "Fancy splitting method. -See the documentation for the variable `nnmail-split-fancy' for documentation." +See the documentation for the variable `nnmail-split-fancy' for details." (let ((syntab (syntax-table))) (unwind-protect (progn @@ -1145,7 +1328,7 @@ ;; A group name. Do the \& and \N subs into the string. ((stringp split) (when nnmail-split-tracing - (push (format "\"%s\"" split) nnmail-split-trace)) + (push split nnmail-split-trace)) (list (nnmail-expand-newtext split))) ;; Junk the message. @@ -1168,6 +1351,8 @@ ;; Builtin : operation. ((eq (car split) ':) + (when nnmail-split-tracing + (push split nnmail-split-trace)) (nnmail-split-it (save-excursion (eval (cdr split))))) ;; Builtin ! operation. @@ -1184,13 +1369,13 @@ (while (and (goto-char end-point) (re-search-backward (cdr cached-pair) nil t)) (when nnmail-split-tracing - (push (cdr cached-pair) nnmail-split-trace)) + (push split nnmail-split-trace)) (let ((split-rest (cddr split)) (end (match-end 0)) - ;; The searched regexp is \(\(FIELD\).*\)\(VALUE\). So, - ;; start-of-value is the point just before the - ;; beginning of the value, whereas after-header-name is - ;; the point just after the field name. + ;; The searched regexp is \(\(FIELD\).*\)\(VALUE\). + ;; So, start-of-value is the point just before the + ;; beginning of the value, whereas after-header-name + ;; is the point just after the field name. (start-of-value (match-end 1)) (after-header-name (match-end 2))) ;; Start the next search just before the beginning of the @@ -1218,7 +1403,7 @@ ;; correct match positions. (re-search-backward value start-of-value)) (dolist (sp (nnmail-split-it (car split-rest))) - (unless (memq sp split-result) + (unless (member sp split-result) (push sp split-result)))))) split-result)) @@ -1226,25 +1411,36 @@ (t (let* ((field (nth 0 split)) (value (nth 1 split)) - partial regexp) + partial-front + partial-rear + regexp) (if (symbolp value) (setq value (cdr (assq value nnmail-split-abbrev-alist)))) (if (and (>= (length value) 2) (string= ".*" (substring value 0 2))) (setq value (substring value 2) - partial "")) + partial-front "")) + ;; Same trick for the rear of the regexp + (if (and (>= (length value) 2) + (string= ".*" (substring value -2))) + (setq value (substring value 0 -2) + partial-rear "")) + (when nnmail-split-fancy-match-partial-words + (setq partial-front "" + partial-rear "")) (setq regexp (concat "^\\(\\(" (if (symbolp field) (cdr (assq field nnmail-split-abbrev-alist)) field) "\\):.*\\)" - (or partial "\\<") + (or partial-front "\\<") "\\(" value - "\\)\\>")) + "\\)" + (or partial-rear "\\>"))) (push (cons split regexp) nnmail-split-cache) ;; Now that it's in the cache, just call nnmail-split-it again - ;; on the same split, which will find it immediately in the cache. + ;; on the same split, which will find it immediately in the cache. (nnmail-split-it split)))))) (defun nnmail-expand-newtext (newtext) @@ -1329,6 +1525,7 @@ (set-buffer (setq nnmail-cache-buffer (get-buffer-create " *nnmail message-id cache*"))) + (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) (set-buffer-modified-p nil) @@ -1355,52 +1552,54 @@ nnmail-message-id-cache-file nil 'silent) (set-buffer-modified-p nil) (setq nnmail-cache-buffer nil) - (kill-buffer (current-buffer))))) + (gnus-kill-buffer (current-buffer))))) ;; Compiler directives. (defvar group) (defvar group-art-list) (defvar group-art) -(defun nnmail-cache-insert (id) - (when nnmail-treat-duplicates - ;; Store some information about the group this message is written - ;; to. This function might have been called from various places. - ;; Sometimes, a function up in the calling sequence has an - ;; argument GROUP which is bound to a string, the group name. At - ;; other times, there is a function up in the calling sequence - ;; which has an argument GROUP-ART which is a list of pairs, and - ;; the car of a pair is a group name. Should we check that the - ;; length of the list is equal to 1? -- kai - (let ((g nil)) - (cond ((and (boundp 'group) group) - (setq g group)) - ((and (boundp 'group-art-list) group-art-list - (listp group-art-list)) - (setq g (caar group-art-list))) - ((and (boundp 'group-art) group-art (listp group-art)) - (setq g (caar group-art))) - (t (setq g ""))) +(defun nnmail-cache-insert (id grp &optional subject sender) + (when (stringp id) + ;; this will handle cases like `B r' where the group is nil + (let ((grp (or grp gnus-newsgroup-name "UNKNOWN"))) + (run-hook-with-args 'nnmail-spool-hook + id grp subject sender)) + (when nnmail-treat-duplicates + ;; Store some information about the group this message is written + ;; to. This is passed in as the grp argument -- all locations this + ;; has been called from have been checked and the group is available. + ;; The only ambiguous case is nnmail-check-duplication which will only + ;; pass the first (of possibly >1) group which matches. -Josh (unless (gnus-buffer-live-p nnmail-cache-buffer) - (nnmail-cache-open)) + (nnmail-cache-open)) (save-excursion - (set-buffer nnmail-cache-buffer) - (goto-char (point-max)) - (if (and g (not (string= "" g)) - (gnus-methods-equal-p gnus-command-method - (nnmail-cache-primary-mail-backend))) - (insert id "\t" g "\n") - (insert id "\n")))))) - + (set-buffer nnmail-cache-buffer) + (goto-char (point-max)) + (if (and grp (not (string= "" grp)) + (gnus-methods-equal-p gnus-command-method + (nnmail-cache-primary-mail-backend))) + (let ((regexp (if (consp nnmail-cache-ignore-groups) + (mapconcat 'identity nnmail-cache-ignore-groups + "\\|") + nnmail-cache-ignore-groups))) + (unless (and regexp (string-match regexp grp)) + (insert id "\t" grp "\n"))) + (insert id "\n")))))) + (defun nnmail-cache-primary-mail-backend () (let ((be-list (cons gnus-select-method gnus-secondary-select-methods)) - (be nil) - (res nil)) + (be nil) + (res nil) + (get-new-mail nil)) (while (and (null res) be-list) (setq be (car be-list)) (setq be-list (cdr be-list)) (when (and (gnus-method-option-p be 'respool) - (eval (intern (format "%s-get-new-mail" (car be))))) - (setq res be))) + (setq get-new-mail + (intern (format "%s-get-new-mail" (car be)))) + (boundp get-new-mail) + (symbol-value get-new-mail)) + (setq res be))) res)) ;; Fetch the group name corresponding to the message id stored in the @@ -1411,29 +1610,44 @@ (set-buffer nnmail-cache-buffer) (goto-char (point-max)) (when (search-backward id nil t) - (beginning-of-line) - (skip-chars-forward "^\n\r\t") - (unless (eolp) - (forward-char 1) - (buffer-substring (point) - (progn (end-of-line) (point)))))))) + (beginning-of-line) + (skip-chars-forward "^\n\r\t") + (unless (looking-at "[\r\n]") + (forward-char 1) + (buffer-substring (point) (gnus-point-at-eol))))))) ;; Function for nnmail-split-fancy: look up all references in the ;; cache and if a match is found, return that group. (defun nnmail-split-fancy-with-parent () + "Split this message into the same group as its parent. +This function can be used as an entry in `nnmail-split-fancy', for +example like this: (: nnmail-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 message id +cache file (given by the variable `nnmail-message-id-cache-file') 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)) + (message-fetch-field "in-reply-to"))) + (references nil) + (res nil) + (regexp (if (consp nnmail-split-fancy-with-parent-ignore-groups) + (mapconcat + (lambda (x) (format "\\(%s\\)" x)) + nnmail-split-fancy-with-parent-ignore-groups + "\\|") + nnmail-split-fancy-with-parent-ignore-groups))) (when refstr (setq references (nreverse (gnus-split-references refstr))) (unless (gnus-buffer-live-p nnmail-cache-buffer) - (nnmail-cache-open)) + (nnmail-cache-open)) (mapcar (lambda (x) - (setq res (or (nnmail-cache-fetch-group x) res)) - (when (string= "drafts" res) - (setq res nil))) - references) + (setq res (or (nnmail-cache-fetch-group x) res)) + (when (or (member res '("delayed" "drafts" "queue")) + (and regexp res (string-match regexp res))) + (setq res nil))) + references) res))) (defun nnmail-cache-id-exists-p (id) @@ -1458,7 +1672,7 @@ (cond ((memq nnmail-treat-duplicates '(warn delete)) nnmail-treat-duplicates) - ((nnheader-functionp nnmail-treat-duplicates) + ((functionp nnmail-treat-duplicates) (funcall nnmail-treat-duplicates message-id)) (t nnmail-treat-duplicates)))) @@ -1475,7 +1689,7 @@ ((not duplication) (funcall func (setq group-art (nreverse (nnmail-article-group artnum-func)))) - (nnmail-cache-insert message-id)) + (nnmail-cache-insert message-id (caar group-art))) ((eq action 'delete) (setq group-art nil)) ((eq action 'warn) @@ -1542,12 +1756,11 @@ (setq source (append source (list :predicate - `(lambda (file) - (string-match - ,(concat - (regexp-quote (concat group suffix)) - "$") - file))))))) + (gnus-byte-compile + `(lambda (file) + (string-equal + ,(concat group suffix) + (file-name-nondirectory file))))))))) (when nnmail-fetched-sources (if (member source nnmail-fetched-sources) (setq source nil) @@ -1568,14 +1781,15 @@ (when (setq new (mail-source-fetch source - `(lambda (file orig-file) - (nnmail-split-incoming - file ',(intern (format "%s-save-mail" method)) - ',spool-func - (if (equal file orig-file) - nil - (nnmail-get-split-group orig-file ',source)) - ',(intern (format "%s-active-number" method)))))) + (gnus-byte-compile + `(lambda (file orig-file) + (nnmail-split-incoming + file ',(intern (format "%s-save-mail" method)) + ',spool-func + (if (equal file orig-file) + nil + (nnmail-get-split-group orig-file ',source)) + ',(intern (format "%s-active-number" method))))))) (incf total new) (incf i))) ;; If we did indeed read any incoming spools, we save all info. @@ -1611,7 +1825,7 @@ ;; We expire all articles on sight. t) ((equal time '(0 0)) - ;; This is an ange-ftp group, and we don't have any dates. + ;; This is an ange-ftp group, and we don't have any dates. nil) ((numberp days) (setq days (days-to-time days)) @@ -1619,10 +1833,46 @@ (ignore-errors (time-less-p days (time-since time)))))))) (defun nnmail-expiry-target-group (target group) - (when (nnheader-functionp target) - (setq target (funcall target group))) - (unless (eq target 'delete) - (gnus-request-accept-article target nil nil t))) + ;; Do not invoke this from nntp-server-buffer! At least nnfolder clears + ;; that buffer if the nnfolder group isn't selected. + (let (nnmail-cache-accepted-message-ids) + ;; Don't enter Message-IDs into cache. + ;; Let users hack it in TARGET function. + (when (functionp target) + (setq target (funcall target group))) + (unless (eq target 'delete) + (when (or (gnus-request-group target) + (gnus-request-create-group target)) + (let ((group-art (gnus-request-accept-article target nil nil t))) + (when (consp group-art) + (gnus-group-mark-article-read target (cdr group-art)))))))) + +(defun nnmail-fancy-expiry-target (group) + "Returns a target expiry group determined by `nnmail-fancy-expiry-targets'." + (let* (header + (case-fold-search nil) + (from (or (message-fetch-field "from") "")) + (to (or (message-fetch-field "to") "")) + (date (date-to-time + (or (message-fetch-field "date") (current-time-string)))) + (target 'delete)) + (dolist (regexp-target-pair (reverse nnmail-fancy-expiry-targets) target) + (setq header (car regexp-target-pair)) + (cond + ;; If the header is to-from then match against the + ;; To or From header + ((and (equal header 'to-from) + (or (string-match (cadr regexp-target-pair) from) + (and (string-match message-dont-reply-to-names from) + (string-match (cadr regexp-target-pair) to)))) + (setq target (format-time-string (caddr regexp-target-pair) date))) + ((and (not (equal header 'to-from)) + (string-match (cadr regexp-target-pair) + (or + (message-fetch-field header) + ""))) + (setq target + (format-time-string (caddr regexp-target-pair) date))))))) (defun nnmail-check-syntax () "Check (and modify) the syntax of the message in the current buffer." @@ -1719,7 +1969,7 @@ "Remove all instances of GROUP from `nnmail-split-history'." (let ((history nnmail-split-history)) (while history - (setcar history (gnus-delete-if (lambda (e) (string= (car e) group)) + (setcar history (gnus-remove-if (lambda (e) (string= (car e) group)) (car history))) (pop history)) (setq nnmail-split-history (delq nil nnmail-split-history))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nnmaildir.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,1627 @@ +;;; 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) + (buffer-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) + (buffer-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) + (buffer-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) + (buffer-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) + (buffer-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: + +;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849 +;;; nnmaildir.el ends here
--- a/lisp/gnus/nnmbox.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnmbox.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,10 +1,10 @@ ;;; nnmbox.el --- mail mbox access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -30,6 +30,7 @@ (require 'message) (require 'nnmail) (require 'nnoo) +(require 'gnus-range) (eval-when-compile (require 'cl)) (nnoo-declare nnmbox) @@ -54,7 +55,7 @@ (defvoo nnmbox-current-group nil "Current nnmbox news group directory.") -(defconst nnmbox-mbox-buffer nil) +(defvar nnmbox-mbox-buffer nil) (defvoo nnmbox-status-string "") @@ -66,6 +67,8 @@ (defvoo nnmbox-active-file-coding-system mm-binary-coding-system) (defvoo nnmbox-active-file-coding-system-for-write nil) +(defvar nnmbox-group-building-active-articles nil) +(defvar nnmbox-group-active-articles nil) ;;; Interface functions @@ -78,15 +81,12 @@ (erase-buffer) (let ((number (length sequence)) (count 0) - article art-string start stop) + article start stop) (nnmbox-possibly-change-newsgroup newsgroup server) (while sequence (setq article (car sequence)) - (setq art-string (nnmbox-article-string article)) (set-buffer nnmbox-mbox-buffer) - (when (or (search-forward art-string nil t) - (progn (goto-char (point-min)) - (search-forward art-string nil t))) + (when (nnmbox-find-article article) (setq start (save-excursion (re-search-backward @@ -148,8 +148,7 @@ (nnmbox-possibly-change-newsgroup newsgroup server) (save-excursion (set-buffer nnmbox-mbox-buffer) - (goto-char (point-min)) - (when (search-forward (nnmbox-article-string article) nil t) + (when (nnmbox-find-article article) (let (start stop) (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) (setq start (point)) @@ -170,7 +169,7 @@ (forward-line 1)) (if (numberp article) (cons nnmbox-current-group article) - (nnmbox-article-group-number))))))) + (nnmbox-article-group-number nil))))))) (deffoo nnmbox-request-group (group &optional server dont-check) (nnmbox-possibly-change-newsgroup nil server) @@ -254,8 +253,7 @@ (save-excursion (set-buffer nnmbox-mbox-buffer) (while (and articles is-old) - (goto-char (point-min)) - (when (search-forward (nnmbox-article-string (car articles)) nil t) + (when (nnmbox-find-article (car articles)) (if (setq is-old (nnmail-expired-article-p newsgroup @@ -269,7 +267,8 @@ (current-buffer)) (let ((nnml-current-directory nil)) (nnmail-expiry-target-group - nnmail-expiry-target newsgroup)))) + nnmail-expiry-target newsgroup))) + (nnmbox-possibly-change-newsgroup newsgroup server)) (nnheader-message 5 "Deleting article %d in %s..." (car articles) newsgroup) (nnmbox-delete-mail)) @@ -278,12 +277,9 @@ (nnmbox-save-buffer) ;; Find the lowest active article in this group. (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist)))) - (goto-char (point-min)) - (while (and (not (search-forward - (nnmbox-article-string (car active)) nil t)) + (while (and (not (nnmbox-find-article (car active))) (<= (car active) (cdr active))) - (setcar active (1+ (car active))) - (goto-char (point-min)))) + (setcar active (1+ (car active))))) (nnmbox-save-active nnmbox-group-alist nnmbox-active-file) (nconc rest articles)))) @@ -301,16 +297,14 @@ (while (re-search-forward "^X-Gnus-Newsgroup:" (save-excursion (search-forward "\n\n" nil t) (point)) t) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (gnus-delete-line)) (setq result (eval accept-form)) (kill-buffer buf) result) (save-excursion (nnmbox-possibly-change-newsgroup group server) (set-buffer nnmbox-mbox-buffer) - (goto-char (point-min)) - (when (search-forward (nnmbox-article-string article) nil t) + (when (nnmbox-find-article article) (nnmbox-delete-mail)) (and last (nnmbox-save-buffer)))) result)) @@ -337,7 +331,10 @@ (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) (delete-region (point) (progn (forward-line 1) (point)))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) (setq result (if (stringp group) (list (cons group (nnmbox-active-number group))) (nnmail-article-group 'nnmbox-active-number))) @@ -360,8 +357,7 @@ (nnmbox-possibly-change-newsgroup group) (save-excursion (set-buffer nnmbox-mbox-buffer) - (goto-char (point-min)) - (if (not (search-forward (nnmbox-article-string article) nil t)) + (if (not (nnmbox-find-article article)) nil (nnmbox-delete-mail t t) (insert-buffer-substring buffer) @@ -405,6 +401,9 @@ (setq found t)) (when found (nnmbox-save-buffer)))) + (let ((entry (assoc group nnmbox-group-active-articles))) + (when entry + (setcar entry new-name))) (let ((entry (assoc group nnmbox-group-alist))) (when entry (setcar entry new-name)) @@ -421,10 +420,12 @@ ;; delimiter line. (defun nnmbox-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. + ;; First delete record of active article, unless the article is being + ;; replaced, indicated by FORCE being non-nil. + (if (not force) + (nnmbox-record-deleted-article (nnmbox-article-group-number t))) (or force - (delete-region - (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (gnus-delete-line)) ;; Beginning of the article. (save-excursion (save-restriction @@ -442,7 +443,7 @@ (match-beginning 0))) (point-max)))) (goto-char (point-min)) - ;; Only delete the article if no other groups owns it as well. + ;; Only delete the article if no other group owns it as well. (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) (delete-region (point-min) (point-max)))))) @@ -452,14 +453,7 @@ (nnmbox-open-server server)) (when (or (not nnmbox-mbox-buffer) (not (buffer-name nnmbox-mbox-buffer))) - (save-excursion - (set-buffer (setq nnmbox-mbox-buffer - (let ((nnheader-file-coding-system - nnmbox-file-coding-system)) - (nnheader-find-file-noselect - nnmbox-mbox-file nil t)))) - (mm-enable-multibyte) - (buffer-disable-undo))) + (nnmbox-read-mbox)) (when (not nnmbox-group-alist) (nnmail-activate 'nnmbox)) (if newsgroup @@ -473,15 +467,86 @@ (int-to-string article) " ") (concat "\nMessage-ID: " article))) -(defun nnmbox-article-group-number () +(defun nnmbox-article-group-number (this-line) (save-excursion - (goto-char (point-min)) + (if this-line + (beginning-of-line) + (goto-char (point-min))) (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " nil t) (cons (buffer-substring (match-beginning 1) (match-end 1)) (string-to-int (buffer-substring (match-beginning 2) (match-end 2))))))) +(defun nnmbox-in-header-p (pos) + "Return non-nil if POS is in the header of an article." + (save-excursion + (goto-char pos) + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (search-forward "\n\n" nil t) + (< pos (point)))) + +(defun nnmbox-find-article (article) + "Leaves point on the relevant X-Gnus-Newsgroup line if found." + ;; Check that article is in the active range first, to avoid an + ;; expensive exhaustive search if it isn't. + (if (and (numberp article) + (not (nnmbox-is-article-active-p article))) + nil + (let ((art-string (nnmbox-article-string article)) + (found nil)) + ;; There is the possibility that the X-Gnus-Newsgroup line appears + ;; in the body of an article (for instance, if an article has been + ;; forwarded from someone using Gnus as their mailer), so check + ;; that the line is actually part of the article header. + (or (and (search-forward art-string nil t) + (nnmbox-in-header-p (point))) + (progn + (goto-char (point-min)) + (while (and (not found) + (search-forward art-string nil t)) + (setq found (nnmbox-in-header-p (point)))) + found))))) + +(defun nnmbox-record-active-article (group-art) + (let* ((group (car group-art)) + (article (cdr group-art)) + (entry + (or (assoc group nnmbox-group-active-articles) + (progn + (push (list group) + nnmbox-group-active-articles) + (car nnmbox-group-active-articles))))) + ;; add article to index, either by building complete list + ;; in reverse order, or as a list of ranges. + (if (not nnmbox-group-building-active-articles) + (setcdr entry (gnus-add-to-range (cdr entry) (list article))) + (when (memq article (cdr entry)) + (switch-to-buffer nnmbox-mbox-buffer) + (error "Article %s:%d already exists!" group article)) + (when (and (cadr entry) (< article (cadr entry))) + (switch-to-buffer nnmbox-mbox-buffer) + (error "Article %s:%d out of order" group article)) + (setcdr entry (cons article (cdr entry)))))) + +(defun nnmbox-record-deleted-article (group-art) + (let* ((group (car group-art)) + (article (cdr group-art)) + (entry + (or (assoc group nnmbox-group-active-articles) + (progn + (push (list group) + nnmbox-group-active-articles) + (car nnmbox-group-active-articles))))) + ;; remove article from index + (setcdr entry (gnus-remove-from-range (cdr entry) (list article))))) + +(defun nnmbox-is-article-active-p (article) + (gnus-member-of-range + article + (cdr (assoc nnmbox-current-group + nnmbox-group-active-articles)))) + (defun nnmbox-save-mail (group-art) "Called narrowed to an article." (let ((delim (concat "^" message-unix-mail-delimiter))) @@ -498,6 +563,10 @@ (nnmail-insert-lines) (nnmail-insert-xref group-art) (nnmbox-insert-newsgroup-line group-art) + (let ((alist group-art)) + (while alist + (nnmbox-record-active-article (car alist)) + (setq alist (cdr alist)))) (run-hooks 'nnmail-prepare-save-mail-hook) (run-hooks 'nnmbox-prepare-save-mail-hook) group-art)) @@ -530,7 +599,9 @@ (when (not (file-exists-p nnmbox-mbox-file)) (let ((nnmail-file-coding-system (or nnmbox-file-coding-system-for-write - nnmbox-file-coding-system))) + nnmbox-file-coding-system)) + (dir (file-name-directory nnmbox-mbox-file))) + (and dir (gnus-make-directory dir)) (nnmail-write-region (point-min) (point-min) nnmbox-mbox-file t 'nomesg)))) @@ -546,17 +617,17 @@ (save-excursion (let ((delim (concat "^" message-unix-mail-delimiter)) (alist nnmbox-group-alist) - start end number) + (nnmbox-group-building-active-articles t) + start end end-header number) (set-buffer (setq nnmbox-mbox-buffer (let ((nnheader-file-coding-system nnmbox-file-coding-system)) (nnheader-find-file-noselect - nnmbox-mbox-file nil t)))) + nnmbox-mbox-file t t)))) (mm-enable-multibyte) (buffer-disable-undo) - ;; Go through the group alist and compare against - ;; the mbox file. + ;; Go through the group alist and compare against the mbox file. (while alist (goto-char (point-max)) (when (and (re-search-backward @@ -570,29 +641,57 @@ (setcdr (cadar alist) number)) (setq alist (cdr alist))) + ;; Examine all articles for our private X-Gnus-Newsgroup + ;; headers. This is done primarily as a consistency check, but + ;; it is convenient for building an index of the articles + ;; present, to avoid costly searches for missing articles + ;; (eg. when expiring articles). (goto-char (point-min)) + (setq nnmbox-group-active-articles nil) (while (re-search-forward delim nil t) (setq start (match-beginning 0)) - (unless (search-forward - "\nX-Gnus-Newsgroup: " - (save-excursion - (setq end - (or - (and - ;; skip to end of headers first, since mail - ;; which has been respooled has additional - ;; "From nobody" lines. - (search-forward "\n\n" nil t) - (re-search-forward delim nil t) - (match-beginning 0)) - (point-max)))) - t) + (save-excursion + (search-forward "\n\n" nil t) + (setq end-header (point)) + (setq end (or (and + (re-search-forward delim nil t) + (match-beginning 0)) + (point-max)))) + (if (search-forward "\nX-Gnus-Newsgroup: " end-header t) + ;; Build a list of articles in each group, remembering + ;; that each article may be in more than one group. + (progn + (nnmbox-record-active-article (nnmbox-article-group-number t)) + (while (search-forward "\nX-Gnus-Newsgroup: " end-header t) + (nnmbox-record-active-article (nnmbox-article-group-number t)))) + ;; The article is either new, or for some other reason + ;; hasn't got our private headers, so add them now. The + ;; only situation I've encountered when the X-Gnus-Newsgroup + ;; header is missing is if the article contains a forwarded + ;; message which does contain that header line (earlier + ;; versions of Gnus didn't restrict their search to the + ;; headers). In this case, there is an Xref line which + ;; provides the relevant information to construct the + ;; missing header(s). (save-excursion (save-restriction (narrow-to-region start end) - (nnmbox-save-mail - (nnmail-article-group 'nnmbox-active-number))))) - (goto-char end)))))) + (if (re-search-forward "\nXref: [^ ]+" end-header t) + ;; generate headers from Xref: + (let (alist) + (while (re-search-forward " \\([^:]+\\):\\([0-9]+\\)" end-header t) + (push (cons (match-string 1) + (string-to-int (match-string 2))) alist)) + (nnmbox-insert-newsgroup-line alist)) + ;; this is really a new article + (nnmbox-save-mail + (nnmail-article-group 'nnmbox-active-number)))))) + (goto-char end)) + ;; put article lists in order + (setq alist nnmbox-group-active-articles) + (while alist + (setcdr (car alist) (gnus-compress-sequence (nreverse (cdar alist)))) + (setq alist (cdr alist))))))) (provide 'nnmbox)
--- a/lisp/gnus/nnmh.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnmh.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,10 +1,10 @@ ;;; nnmh.el --- mhspool access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -41,16 +41,16 @@ (nnoo-declare nnmh) (defvoo nnmh-directory message-directory - "*Mail spool directory.") + "Mail spool directory.") (defvoo nnmh-get-new-mail t - "*If non-nil, nnmh will check the incoming mail file and split the mail.") + "If non-nil, nnmh will check the incoming mail file and split the mail.") (defvoo nnmh-prepare-save-mail-hook nil - "*Hook run narrowed to an article before saving.") + "Hook run narrowed to an article before saving.") (defvoo nnmh-be-safe nil - "*If non-nil, nnmh will check all articles to make sure whether they are new or not. + "If non-nil, nnmh will check all articles to make sure whether they are new or not. Go through the .nnmh-articles file and compare with the actual articles in this folder. The articles that are \"new\" will be marked as unread by Gnus.") @@ -239,10 +239,12 @@ (file-truename (file-name-as-directory (expand-file-name nnmh-toplev)))) dir) - (nnheader-replace-chars-in-string - (mm-decode-coding-string (substring dir (match-end 0)) - nnmail-pathname-coding-system) - ?/ ?.)) + (mm-string-as-multibyte + (mm-encode-coding-string + (nnheader-replace-chars-in-string + (substring dir (match-end 0)) + ?/ ?.) + nnmail-pathname-coding-system))) (apply 'max files) (apply 'min files))))))) t) @@ -288,8 +290,8 @@ (deffoo nnmh-close-group (group &optional server) t) -(deffoo nnmh-request-move-article - (article group server accept-form &optional last) +(deffoo nnmh-request-move-article (article group server + accept-form &optional last) (let ((buf (get-buffer-create " *nnmh move*")) result) (and @@ -314,7 +316,10 @@ (nnmh-possibly-change-directory group server) (nnmail-check-syntax) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) (nnheader-init-server-buffer) (prog1 (if (stringp group) @@ -422,7 +427,7 @@ (file-name-coding-system nnmail-pathname-coding-system)) (if (file-directory-p pathname) (setq nnmh-current-directory pathname) - (error "No such newsgroup: %s" newsgroup))))) + (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))))) (defun nnmh-possibly-create-directory (group) (let (dir dirs)
--- a/lisp/gnus/nnml.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnml.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,9 +1,10 @@ ;;; nnml.el --- mail spool access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003 ;; Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS) +;; Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -31,12 +32,14 @@ ;;; Code: +(require 'gnus) (require 'nnheader) (require 'nnmail) (require 'nnoo) (eval-when-compile (require 'cl)) + (eval-and-compile - (autoload 'gnus-sorted-intersection "gnus-range")) + (autoload 'gnus-article-unpropagatable-p "gnus-sum")) (nnoo-declare nnml) @@ -55,7 +58,7 @@ "If non-nil, nnml will check the incoming mail file and split the mail.") (defvoo nnml-nov-is-evil nil - "If non-nil, Gnus will never generate and use nov databases for mail groups. + "If non-nil, Gnus will never generate and use nov databases for mail spools. 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 @@ -63,12 +66,23 @@ through all nnml directories and generate nov databases for them all. This may very well take some time.") +(defvoo nnml-marks-is-evil nil + "If non-nil, Gnus will never generate and use marks file for mail spools. +Using marks files makes it possible to backup and restore mail groups +separately from `.newsrc.eld'. If you have, for some reason, set this +to t, and want to set it to nil again, you should always remove the +corresponding marks file (usually named `.marks' in the nnml group +directory, but see `nnml-marks-file-name') for the group. Then the +marks file will be regenerated properly by Gnus.") + (defvoo nnml-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") (defvoo nnml-inhibit-expiry nil "If non-nil, inhibit expiry.") +(defvoo nnml-use-compressed-files nil + "If non-nil, allow using compressed message files.") @@ -76,6 +90,7 @@ "nnml version.") (defvoo nnml-nov-file-name ".overview") +(defvoo nnml-marks-file-name ".marks") (defvoo nnml-current-directory nil) (defvoo nnml-current-group nil) @@ -91,8 +106,11 @@ (defvoo nnml-file-coding-system nnmail-file-coding-system) +(defvoo nnml-marks nil) + +(defvar nnml-marks-modtime (gnus-make-hashtable)) + - ;;; Interface functions. (nnoo-define-basics nnml) @@ -102,11 +120,11 @@ (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) + (let* ((file nil) + (number (length sequence)) + (count 0) + (file-name-coding-system nnmail-pathname-coding-system) + beg article) (if (stringp (car sequence)) 'headers (if (nnml-retrieve-headers-with-nov sequence fetch-old) @@ -121,7 +139,7 @@ (setq beg (point)) (nnheader-insert-head file) (goto-char beg) - (if (search-forward "\n\n" nil t) + (if (re-search-forward "\n\r?\n" nil t) (forward-char -1) (goto-char (point-max)) (insert "\n\n")) @@ -158,9 +176,9 @@ server nnml-directory) t))) -(defun nnml-request-regenerate (server) +(deffoo nnml-request-regenerate (server) (nnml-possibly-change-directory nil server) - (nnml-generate-nov-databases) + (nnml-generate-nov-databases server) t) (deffoo nnml-request-article (id &optional group server buffer) @@ -245,7 +263,7 @@ nnml-group-alist) (nnml-possibly-create-directory group) (nnml-possibly-change-directory group server) - (let ((articles (nnheader-directory-articles nnml-current-directory))) + (let ((articles (nnml-directory-articles nnml-current-directory))) (when articles (setcar active (apply 'min articles)) (setcdr active (apply 'max articles)))) @@ -270,7 +288,7 @@ (deffoo nnml-request-expire-articles (articles group &optional server force) (nnml-possibly-change-directory group server) (let ((active-articles - (nnheader-directory-articles nnml-current-directory)) + (nnml-directory-articles nnml-current-directory)) (is-old t) article rest mod-time number) (nnmail-activate 'nnml) @@ -281,30 +299,32 @@ (setq articles (gnus-sorted-intersection articles active-articles)) (while (and articles is-old) - (when (setq article (nnml-article-to-file (setq number (pop articles)))) - (when (setq mod-time (nth 5 (file-attributes article))) - (if (and (nnml-deletable-article-p group number) - (setq is-old - (nnmail-expired-article-p group mod-time force - nnml-inhibit-expiry))) - (progn - ;; Allow a special target group. - (unless (eq nnmail-expiry-target 'delete) - (with-temp-buffer - (nnml-request-article number group server - (current-buffer)) - (let ((nnml-current-directory nil)) - (nnmail-expiry-target-group - nnmail-expiry-target group)))) - (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)) - (nnml-nov-delete-article group number)) - (push number rest))))) + (if (and (setq article (nnml-article-to-file + (setq number (pop articles)))) + (setq mod-time (nth 5 (file-attributes article))) + (nnml-deletable-article-p group number) + (setq is-old (nnmail-expired-article-p group mod-time force + nnml-inhibit-expiry))) + (progn + ;; Allow a special target group. + (unless (eq nnmail-expiry-target 'delete) + (with-temp-buffer + (nnml-request-article number group server (current-buffer)) + (let (nnml-current-directory + nnml-current-group + nnml-article-file-alist) + (nnmail-expiry-target-group nnmail-expiry-target group))) + ;; Maybe directory is changed during nnmail-expiry-target-group. + (nnml-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)) + (nnml-nov-delete-article group number)) + (push number rest))) (let ((active (nth 1 (assoc group nnml-group-alist)))) (when active (setcar active (or (and active-articles @@ -349,7 +369,10 @@ (nnmail-check-syntax) (let (result) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) (if (stringp group) (and (nnmail-activate 'nnml) @@ -371,6 +394,9 @@ (nnml-save-nov)))) result)) +(deffoo nnml-request-post (&optional server) + (nnmail-do-request-post 'nnml-request-accept-article server)) + (deffoo nnml-request-replace-article (article group buffer) (nnml-possibly-change-directory group) (save-excursion @@ -395,8 +421,7 @@ (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))) + (gnus-delete-line) ;; 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...) @@ -419,7 +444,8 @@ (directory-files nnml-current-directory t (concat nnheader-numerical-short-files - "\\|" (regexp-quote nnml-nov-file-name) "$"))) + "\\|" (regexp-quote nnml-nov-file-name) "$" + "\\|" (regexp-quote nnml-marks-file-name) "$"))) article) (while articles (setq article (pop articles)) @@ -457,6 +483,10 @@ (let ((overview (concat old-dir nnml-nov-file-name))) (when (file-exists-p overview) (rename-file overview (concat new-dir nnml-nov-file-name)))) + ;; Move .marks file. + (let ((marks (concat old-dir nnml-marks-file-name))) + (when (file-exists-p marks) + (rename-file marks (concat new-dir nnml-marks-file-name)))) (when (<= (length (directory-files old-dir)) 2) (ignore-errors (delete-directory old-dir))) ;; That went ok, so we change the internal structures. @@ -487,15 +517,19 @@ (defun nnml-article-to-file (article) (nnml-update-file-alist) (let (file) - (if (setq file (cdr (assq article nnml-article-file-alist))) + (if (setq file + (if nnml-use-compressed-files + (cdr (assq article nnml-article-file-alist)) + (number-to-string article))) (expand-file-name file nnml-current-directory) - ;; Just to make sure nothing went wrong when reading over NFS -- - ;; check once more. - (when (file-exists-p - (setq file (expand-file-name (number-to-string article) - nnml-current-directory))) - (nnml-update-file-alist t) - file)))) + (when (not nnheader-directory-files-is-safe) + ;; Just to make sure nothing went wrong when reading over NFS -- + ;; check once more. + (when (file-exists-p + (setq file (expand-file-name (number-to-string article) + nnml-current-directory))) + (nnml-update-file-alist t) + file))))) (defun nnml-deletable-article-p (group article) "Say whether ARTICLE in GROUP can be deleted." @@ -517,7 +551,7 @@ ;; likely that the article we are looking for is in that group. (if (setq number (nnml-find-id nnml-current-group id)) (cons nnml-current-group number) - ;; It wasn't there, so we look through the other groups as well. + ;; It wasn't there, so we look through the other groups as well. (while (and (not number) alist) (or (string= (caar alist) nnml-current-group) @@ -587,8 +621,12 @@ (defun nnml-save-mail (group-art) "Called narrowed to an article." - (let (chars headers) + (let (chars headers extension) (setq chars (nnmail-insert-lines)) + (setq extension + (and nnml-use-compressed-files + (> chars 1000) + ".gz")) (nnmail-insert-xref group-art) (run-hooks 'nnmail-prepare-save-mail-hook) (run-hooks 'nnml-prepare-save-mail-hook) @@ -603,7 +641,8 @@ (nnml-possibly-create-directory (caar ga)) (let ((file (concat (nnmail-group-pathname (caar ga) nnml-directory) - (int-to-string (cdar ga))))) + (int-to-string (cdar ga)) + extension))) (if first ;; It was already saved, so we just make a hard link. (funcall nnmail-crosspost-link-function first file t) @@ -636,7 +675,7 @@ (unless nnml-article-file-alist (setq nnml-article-file-alist (sort - (nnheader-article-to-file-alist nnml-current-directory) + (nnml-current-group-article-to-file-alist) 'car-less-than-car))) (setq active (if nnml-article-file-alist @@ -660,7 +699,7 @@ (nnheader-insert-nov headers))) (defsubst nnml-header-value () - (buffer-substring (match-end 0) (progn (end-of-line) (point)))) + (buffer-substring (match-end 0) (gnus-point-at-eol))) (defun nnml-parse-head (chars &optional number) "Parse the head of the current buffer." @@ -669,30 +708,30 @@ (unless (zerop (buffer-size)) (narrow-to-region (goto-char (point-min)) - (if (search-forward "\n\n" nil t) (1- (point)) (point-max)))) - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - ;; Remove any tabs; they are too confusing. - (subst-char-in-region (point-min) (point-max) ?\t ? ) - (let ((headers (nnheader-parse-head t))) + (if (re-search-forward "\n\r?\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 nnml-get-nov-buffer (group) + (let ((buffer (get-buffer-create (format " *nnml overview %s*" group)))) + (save-excursion + (set-buffer buffer) + (set (make-local-variable 'nnml-nov-buffer-file-name) + (expand-file-name + nnml-nov-file-name + (nnmail-group-pathname group nnml-directory))) + (erase-buffer) + (when (file-exists-p nnml-nov-buffer-file-name) + (nnheader-insert-file-contents nnml-nov-buffer-file-name))) + buffer)) + (defun nnml-open-nov (group) (or (cdr (assoc group nnml-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nnml overview %s*" group)))) - (save-excursion - (set-buffer buffer) - (set (make-local-variable 'nnml-nov-buffer-file-name) - (expand-file-name - nnml-nov-file-name - (nnmail-group-pathname group nnml-directory))) - (erase-buffer) - (when (file-exists-p nnml-nov-buffer-file-name) - (nnheader-insert-file-contents nnml-nov-buffer-file-name))) + (let ((buffer (nnml-get-nov-buffer group))) (push (cons group buffer) nnml-nov-buffer-alist) buffer))) @@ -709,13 +748,14 @@ (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist))))) ;;;###autoload -(defun nnml-generate-nov-databases () +(defun nnml-generate-nov-databases (&optional server) "Generate NOV databases in all nnml directories." - (interactive) + (interactive (list (or (nnoo-current-server 'nnml) ""))) ;; Read the active file to make sure we don't re-use articles ;; numbers in empty groups. (nnmail-activate 'nnml) - (nnml-open-server (or (nnoo-current-server 'nnml) "")) + (unless (nnml-server-opened server) + (nnml-open-server server)) (setq nnml-directory (expand-file-name nnml-directory)) ;; Recurse down the directories. (nnml-generate-nov-databases-1 nnml-directory nil t) @@ -754,15 +794,18 @@ (eval-when-compile (defvar files)) (defun nnml-generate-active-info (dir) ;; Update the active info for this group. - (let ((group (nnheader-file-to-group - (directory-file-name dir) nnml-directory))) - (setq nnml-group-alist - (delq (assoc group nnml-group-alist) nnml-group-alist)) + (let* ((group (nnheader-file-to-group + (directory-file-name dir) nnml-directory)) + (entry (assoc group nnml-group-alist)) + (last (or (caadr entry) 0))) + (setq nnml-group-alist (delq entry nnml-group-alist)) (push (list group - (cons (caar files) - (let ((f files)) - (while (cdr f) (setq f (cdr f))) - (caar f)))) + (cons (or (caar files) (1+ last)) + (max last + (or (let ((f files)) + (while (cdr f) (setq f (cdr f))) + (caar f)) + 0)))) nnml-group-alist))) (defun nnml-generate-nov-file (dir files) @@ -786,7 +829,7 @@ (narrow-to-region (goto-char (point-min)) (progn - (search-forward "\n\n" nil t) + (re-search-forward "\n\r?\n" nil t) (setq chars (- (point-max) (point))) (max (point-min) (1- (point))))) (unless (zerop (buffer-size)) @@ -820,10 +863,158 @@ t)) (defun nnml-update-file-alist (&optional force) - (when (or (not nnml-article-file-alist) - force) - (setq nnml-article-file-alist - (nnheader-article-to-file-alist nnml-current-directory)))) + (when nnml-use-compressed-files + (when (or (not nnml-article-file-alist) + force) + (setq nnml-article-file-alist + (nnml-current-group-article-to-file-alist))))) + +(defun nnml-directory-articles (dir) + "Return a list of all article files in a directory. +Use the nov database for that directory if available." + (if (or gnus-nov-is-evil nnml-nov-is-evil + (not (file-exists-p + (expand-file-name nnml-nov-file-name dir)))) + (nnheader-directory-articles dir) + ;; build list from .overview if available + ;; We would use nnml-open-nov, except that nnml-nov-buffer-alist is + ;; defvoo'd, and we might get called when it hasn't been swapped in. + (save-excursion + (let ((list nil) + art + (buffer (nnml-get-nov-buffer nnml-current-group))) + (set-buffer buffer) + (goto-char (point-min)) + (while (not (eobp)) + (setq art (read (current-buffer))) + (push art list) + (forward-line 1)) + list)))) + +(defun nnml-current-group-article-to-file-alist () + "Return an alist of article/file pairs in the current group. +Use the nov database for the current group if available." + (if (or nnml-use-compressed-files + gnus-nov-is-evil + nnml-nov-is-evil + (not (file-exists-p + (expand-file-name nnml-nov-file-name + nnml-current-directory)))) + (nnheader-article-to-file-alist nnml-current-directory) + ;; build list from .overview if available + (save-excursion + (let ((alist nil) + (buffer (nnml-get-nov-buffer nnml-current-group)) + art) + (set-buffer buffer) + (goto-char (point-min)) + (while (not (eobp)) + (setq art (read (current-buffer))) + ;; assume file name is unadorned (ie. not compressed etc) + (push (cons art (int-to-string art)) alist) + (forward-line 1)) + alist)))) + +(deffoo nnml-request-set-mark (group actions &optional server) + (nnml-possibly-change-directory group server) + (unless nnml-marks-is-evil + (nnml-open-marks group server) + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (assert (or (eq what 'add) (eq what 'del)) t + "Unknown request-set-mark action: %s" what) + (dolist (mark marks) + (setq nnml-marks (gnus-update-alist-soft + mark + (funcall (if (eq what 'add) 'gnus-range-add + 'gnus-remove-from-range) + (cdr (assoc mark nnml-marks)) range) + nnml-marks))))) + (nnml-save-marks group server)) + nil) + +(deffoo nnml-request-update-info (group info &optional server) + (nnml-possibly-change-directory group server) + (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group)) + (nnheader-message 8 "Updating marks for %s..." group) + (nnml-open-marks group server) + ;; Update info using `nnml-marks'. + (mapcar (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nnml-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) + (let ((seen (cdr (assq 'read nnml-marks)))) + (gnus-info-set-read info + (if (and (integerp (car seen)) + (null (cdr seen))) + (list (cons (car seen) (car seen))) + seen))) + (nnheader-message 8 "Updating marks for %s...done" group)) + info) + +(defun nnml-marks-changed-p (group) + (let ((file (expand-file-name nnml-marks-file-name + (nnmail-group-pathname group nnml-directory)))) + (if (null (gnus-gethash file nnml-marks-modtime)) + t ;; never looked at marks file, assume it has changed + (not (equal (gnus-gethash file nnml-marks-modtime) + (nth 5 (file-attributes file))))))) + +(defun nnml-save-marks (group server) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (file (expand-file-name nnml-marks-file-name + (nnmail-group-pathname group nnml-directory)))) + (condition-case err + (progn + (nnml-possibly-create-directory group) + (with-temp-file file + (erase-buffer) + (gnus-prin1 nnml-marks) + (insert "\n")) + (gnus-sethash file + (nth 5 (file-attributes file)) + nnml-marks-modtime)) + (error (or (gnus-yes-or-no-p + (format "Could not write to %s (%s). Continue? " file err)) + (error "Cannot write to %s (%s)" err)))))) + +(defun nnml-open-marks (group server) + (let ((file (expand-file-name + nnml-marks-file-name + (nnmail-group-pathname group nnml-directory)))) + (if (file-exists-p file) + (condition-case err + (with-temp-buffer + (gnus-sethash file (nth 5 (file-attributes file)) + nnml-marks-modtime) + (nnheader-insert-file-contents file) + (setq nnml-marks (read (current-buffer))) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nnml-marks (gnus-remassoc el nnml-marks)))) + (error (or (gnus-yes-or-no-p + (format "Error reading nnml marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) + (error "Cannot read nnml marks file %s (%s)" file err)))) + ;; User didn't have a .marks file. Probably first time + ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. + (let ((info (gnus-get-info + (gnus-group-prefixed-name + group + (gnus-server-to-method (format "nnml:%s" server)))))) + (nnheader-message 7 "Bootstrapping marks for %s..." group) + (setq nnml-marks (gnus-info-marks info)) + (push (cons 'read (gnus-info-read info)) nnml-marks) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nnml-marks (gnus-remassoc el nnml-marks))) + (nnml-save-marks group server) + (nnheader-message 7 "Bootstrapping marks for %s...done" group))))) (provide 'nnml)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nnnil.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,83 @@ +;;; 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) + +;;; arch-tag: a982a1a3-bc5e-4fb1-a233-d7657a3e3257
--- a/lisp/gnus/nnoo.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnoo.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; nnoo.el --- OO Gnus Backends -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -38,7 +38,7 @@ "The same as `defvar', only takes list of variables to MAP to." `(prog1 ,(if doc - `(defvar ,var ,init ,doc) + `(defvar ,var ,init ,(concat doc "\n\nThis is a Gnus server variable. See Info node `(gnus)Select Methods'.")) `(defvar ,var ,init)) (nnoo-define ',var ',map))) (put 'defvoo 'lisp-indent-function 2) @@ -201,8 +201,8 @@ (while (setq def (pop defs)) (unless (assq (car def) bvariables) (nconc bvariables - (list (cons (car def) (and (boundp (car def)) - (symbol-value (car def))))))) + (list (cons (car def) (and (boundp (car def)) + (symbol-value (car def))))))) (if (equal server "*internal-non-initialized-backend*") (set (car def) (symbol-value (cadr def))) (set (car def) (cadr def))))) @@ -254,7 +254,7 @@ (setcdr bstate (delq defs (cdr bstate))) (pop defs) (while defs - (set (car (pop defs)) nil))))) + (set (car (pop defs)) nil))))) t) (defun nnoo-close (backend) @@ -304,6 +304,20 @@ (&rest args) (nnheader-report ',backend ,(format "%s-%s not implemented" backend function)))))))) + +(defun nnoo-set (server &rest args) + (let ((parents (nnoo-parents (car server))) + (nnoo-parent-backend (car server))) + (while parents + (nnoo-change-server (caar parents) + (cadr server) + (cdar parents)) + (pop parents))) + (nnoo-change-server (car server) + (cadr server) (cddr server)) + (while args + (set (pop args) (pop args)))) + (provide 'nnoo) ;;; arch-tag: 0196b5ed-6f34-4778-a455-73a971f837e7
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nnrss.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,771 @@ +;;; 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) + 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) + 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) + 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) + 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)))) + (setq xml (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) + (nnrss-node-text dc-ns 'contributor 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 (not (locate-library "xml-rpc")) + (progn + (message "XML-RPC is not available... not checking Syndic8.") + nil) + (require 'xml-rpc) + (let ((feedid (xml-rpc-method-call + "http://www.syndic8.com/xmlrpc.php" + 'syndic8.FindSites + url))) + (when 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 (not (> (length urllist) 1)) + (cdar urllist) + (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))))))))) + +(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 + +;;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267
--- a/lisp/gnus/nnslashdot.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnslashdot.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; nnslashdot.el --- interfacing with Slashdot -;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -23,9 +23,6 @@ ;;; Commentary: -;; Note: You need to have `url' and `w3' installed for this -;; backend to work. - ;;; Code: (eval-when-compile (require 'cl)) @@ -36,11 +33,7 @@ (require 'gnus) (require 'nnmail) (require 'mm-util) -(eval-when-compile - (ignore-errors - (require 'nnweb))) -;; Report failure to find w3 at load time if appropriate. -(eval '(require 'nnweb)) +(require 'mm-url) (nnoo-declare nnslashdot) @@ -60,6 +53,9 @@ (defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml" "Where nnslashdot will fetch the stories from.") +(defvoo nnslashdot-use-front-page nil + "Use the front page in addition to the backslash page.") + (defvoo nnslashdot-threshold -1 "The article threshold.") @@ -105,12 +101,13 @@ (let ((case-fold-search t)) (erase-buffer) (when (= start 1) - (nnweb-insert (format nnslashdot-article-url - (nnslashdot-sid-strip sid)) t) + (mm-url-insert (format nnslashdot-article-url sid) t) (goto-char (point-min)) + (if (eobp) + (error "Couldn't open connection to slashdot")) (re-search-forward "Posted by[ \t\r\n]+") (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)") - (setq from (nnweb-decode-entities-string (match-string 2)))) + (setq from (mm-url-decode-entities-string (match-string 2)))) (search-forward "on ") (setq date (nnslashdot-date-to-date (buffer-substring (point) (1- (search-forward "<"))))) @@ -122,15 +119,14 @@ 1 (make-full-mail-header 1 group from date - (concat "<" (nnslashdot-sid-strip sid) "%1@slashdot>") + (concat "<" sid "%1@slashdot>") "" 0 lines nil nil)) headers) (setq start (if nnslashdot-threaded 2 (pop articles)))) (while (and start (<= start last)) (setq point (goto-char (point-max))) - (nnweb-insert - (format nnslashdot-comments-url - (nnslashdot-sid-strip sid) + (mm-url-insert + (format nnslashdot-comments-url sid nnslashdot-threshold 0 (- start 2)) t) (when (and nnslashdot-threaded first-comments) @@ -154,20 +150,26 @@ (setq changed t)) (when (string-match "^Re: *" subject) (setq subject (concat "Re: " (substring subject (match-end 0))))) - (setq subject (nnweb-decode-entities-string subject)) + (setq subject (mm-url-decode-entities-string subject)) (search-forward "<BR>") - (if (looking-at - "by[ \t\n]+<a[^>]+>\\([^<]+\\)</a>[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))") - (progn - (goto-char (- (match-end 0) 5)) - (setq from (concat - (nnweb-decode-entities-string (match-string 1)) - " <" (match-string 3) ">"))) - (setq from "") - (when (looking-at "by \\([^<>]*\\) on ") - (goto-char (- (match-end 0) 5)) - (setq from (nnweb-decode-entities-string (match-string 1))))) - (search-forward " on ") + (cond + ((looking-at + "by[ \t\n]+<a[^>]+>\\([^<]+\\)</a>[ \t\n]*(\\(<[^>]+>\\)*\\([^<>)]+\\))") + (goto-char (- (match-end 0) 5)) + (setq from (concat + (mm-url-decode-entities-string (match-string 1)) + " <" (match-string 3) ">"))) + ((looking-at "by[ \t\n]+<a[^>]+>\\([^<(]+\\) (\\([0-9]+\\))</a>") + (goto-char (- (match-end 0) 5)) + (setq from (concat + (mm-url-decode-entities-string (match-string 1)) + " <" (match-string 2) ">"))) + ((looking-at "by \\([^<>]*\\)[\t\n\r ]+on ") + (goto-char (- (match-end 0) 5)) + (setq from (mm-url-decode-entities-string (match-string 1)))) + (t + (setq from ""))) + (search-forward "on ") (setq date (nnslashdot-date-to-date (buffer-substring (point) (progn (skip-chars-forward "^()<>\n\r") (point))))) @@ -187,10 +189,9 @@ article (concat subject " (" score ")") from date - (concat "<" (nnslashdot-sid-strip sid) "%" cid "@slashdot>") + (concat "<" sid "%" cid "@slashdot>") (if parent - (concat "<" (nnslashdot-sid-strip sid) "%" - parent "@slashdot>") + (concat "<" sid "%" parent "@slashdot>") "") 0 lines nil nil)) headers) @@ -260,7 +261,7 @@ (point) (progn (re-search-forward - "< [ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article") + "<IFRAME\\|<SCRIPT LANGUAGE=\"JAVASCRIPT\">\\|<!-- no ad 6 -->\\|< [ \t\r\n]*<A HREF=\"\\(\\(http:\\)?//slashdot\\.org\\)?/article") (match-beginning 0))))) (setq cid (cdr (assq article (nth 4 (assoc group nnslashdot-groups))))) @@ -300,19 +301,22 @@ (deffoo nnslashdot-request-list (&optional server) (nnslashdot-possibly-change-server nil server) (let ((number 0) + (first nnslashdot-use-front-page) sid elem description articles gname) (condition-case why ;; First we do the Ultramode to get info on all the latest groups. (progn (mm-with-unibyte-buffer - (nnweb-insert nnslashdot-backslash-url t) + (mm-url-insert nnslashdot-backslash-url t) (goto-char (point-min)) + (if (eobp) + (error "Couldn't open connection to slashdot")) (while (search-forward "<story>" nil t) (narrow-to-region (point) (search-forward "</story>")) (goto-char (point-min)) (re-search-forward "<title>\\([^<]+\\)</title>") (setq description - (nnweb-decode-entities-string (match-string 1))) + (mm-url-decode-entities-string (match-string 1))) (re-search-forward "<url>\\([^<]+\\)</url>") (setq sid (match-string 1)) (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid) @@ -327,20 +331,22 @@ (goto-char (point-max)) (widen))) ;; Then do the older groups. - (while (> (- nnslashdot-group-number number) 0) + (while (or first + (> (- nnslashdot-group-number number) 0)) + (setq first nil) (mm-with-unibyte-buffer (let ((case-fold-search t)) - (nnweb-insert (format nnslashdot-active-url number) t) + (mm-url-insert (format nnslashdot-active-url number) t) (goto-char (point-min)) (while (re-search-forward - "article.pl\\?sid=\\([^&]+\\).*<b>\\([^<]+\\)</b>" + "article.pl\\?sid=\\([^&]+\\).*>\\([^<]+\\)</a>" nil t) (setq sid (match-string 1) description - (nnweb-decode-entities-string (match-string 2))) + (mm-url-decode-entities-string (match-string 2))) (forward-line 1) - (when (re-search-forward "<b>\\([0-9]+\\)</b>" nil t) - (setq articles (string-to-number (match-string 1)))) + (when (re-search-forward "with \\([0-9]+\\) comment" nil t) + (setq articles (1+ (string-to-number (match-string 1))))) (setq gname (concat description " (" sid ")")) (if (setq elem (assoc gname nnslashdot-groups)) (setcar (cdr elem) articles) @@ -359,7 +365,7 @@ (deffoo nnslashdot-request-post (&optional server) (nnslashdot-possibly-change-server nil server) - (let ((sid (nnslashdot-sid-strip (message-fetch-field "newsgroups"))) + (let ((sid (message-fetch-field "newsgroups")) (subject (message-fetch-field "subject")) (references (car (last (split-string (message-fetch-field "references"))))) @@ -394,7 +400,7 @@ (message-goto-body) (setq body (buffer-substring (point) (point-max))) (erase-buffer) - (nnweb-fetch-form + (mm-url-fetch-form "http://slashdot.org/comments.pl" `(("sid" . ,sid) ("pid" . ,pid) @@ -499,14 +505,13 @@ (set-buffer nntp-server-buffer) (erase-buffer) (dolist (elem nnslashdot-groups) - (insert (prin1-to-string (car elem)) - " " (number-to-string (cadr elem)) " 1 y\n")))) + (when (numberp (cadr elem)) + (insert (prin1-to-string (car elem)) + " " (number-to-string (cadr elem)) " 1 y\n"))))) (defun nnslashdot-lose (why) (error "Slashdot HTML has changed; please get a new version of nnslashdot")) -(defalias 'nnslashdot-sid-strip 'identity) - (provide 'nnslashdot) ;;; arch-tag: aa73df7a-f7e6-4eef-bdea-5ce2f8c691b3
--- a/lisp/gnus/nnsoup.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnsoup.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,10 +1,10 @@ ;;; nnsoup.el --- SOUP access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -337,7 +337,7 @@ (delete-file (nnsoup-file prefix t))) t) (setcdr (cdr total-infolist) (delq info (cddr total-infolist))) - (setq articles (gnus-sorted-complement articles range-list)))) + (setq articles (gnus-sorted-difference articles range-list)))) (when (not mod-time) (setcdr (cdr total-infolist) (delq info (cddr total-infolist))))) (if (cddr total-infolist) @@ -656,20 +656,20 @@ (and areas (car areas)))) (defvar nnsoup-old-functions - (list message-send-mail-function message-send-news-function)) + (list message-send-mail-real-function message-send-news-function)) ;;;###autoload (defun nnsoup-set-variables () "Use the SOUP methods for posting news and mailing mail." (interactive) (setq message-send-news-function 'nnsoup-request-post) - (setq message-send-mail-function 'nnsoup-request-mail)) + (setq message-send-mail-real-function 'nnsoup-request-mail)) ;;;###autoload (defun nnsoup-revert-variables () "Revert posting and mailing methods to the standard Emacs methods." (interactive) - (setq message-send-mail-function (car nnsoup-old-functions)) + (setq message-send-mail-real-function (car nnsoup-old-functions)) (setq message-send-news-function (cadr nnsoup-old-functions))) (defun nnsoup-store-reply (kind)
--- a/lisp/gnus/nnspool.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnspool.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,11 +1,11 @@ ;;; nnspool.el --- spool access for GNU Emacs ;; Copyright (C) 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, 1998, -;; 2000, 2002 +;; 2000, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -50,7 +50,10 @@ (defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/") "Local news nov directory.") -(defvoo nnspool-lib-dir "/usr/lib/news/" +(defvoo nnspool-lib-dir + (if (file-exists-p "/usr/lib/news/active") + "/usr/lib/news/" + "/var/lib/news/") "Where the local news library files are stored.") (defvoo nnspool-active-file (concat nnspool-lib-dir "active") @@ -69,8 +72,8 @@ "Local news active date file.") (defvoo nnspool-large-newsgroup 50 - "The number of the articles which indicates a large newsgroup. -If the number of the articles is greater than the value, verbose + "The number of articles which indicates a large newsgroup. +If the number of articles is greater than the value, verbose messages will be shown to indicate the current status.") (defvoo nnspool-nov-is-evil nil @@ -361,7 +364,7 @@ (let ((nov (nnheader-group-pathname nnspool-current-group nnspool-nov-directory ".overview")) (arts articles) - (nnheader-file-coding-system nnspool-file-coding-system) + (nnheader-file-coding-system nnspool-file-coding-system) last) (if (not (file-exists-p nov)) ()
--- a/lisp/gnus/nntp.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nntp.el Thu Jul 22 16:45:51 2004 +0000 @@ -9,18 +9,18 @@ ;; 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. +;; 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. +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: @@ -65,61 +65,82 @@ (defvoo nntp-open-connection-function 'nntp-open-network-stream "*Function used for connecting to a remote system. -It will be called with the buffer to output in. +It will be called with the buffer to output in as argument. + +Currently, five such functions are provided (please refer to their +respective doc string for more information), three of them establishing +direct connections to the nntp server, and two of them using an indirect +host. + +Direct connections: +- `nntp-open-network-stream' (the default), +- `nntp-open-ssl-stream', +- `nntp-open-tls-stream', +- `nntp-open-telnet-stream'. + +Indirect connections: +- `nntp-open-via-rlogin-and-telnet', +- `nntp-open-via-telnet-and-telnet'.") -Two pre-made functions are `nntp-open-network-stream', which is the -default, and simply connects to some port or other on the remote -system (see nntp-port-number). The other are `nntp-open-rlogin', -which does an rlogin on the remote system, and then does a telnet to -the NNTP server available there (see nntp-rlogin-parameters) and -`nntp-open-telnet' which telnets to a remote system, logs in and does -the same.") +(defvoo nntp-pre-command nil + "*Pre-command to use with the various nntp-open-via-* methods. +This is where you would put \"runsocks\" or stuff like that.") + +(defvoo nntp-telnet-command "telnet" + "*Telnet command used to connect to the nntp server. +This command is used by the various nntp-open-via-* methods.") -(defvoo nntp-rlogin-program "rsh" - "*Program used to log in on remote machines. +(defvoo nntp-telnet-switches '("-8") + "*Switches given to the telnet command `nntp-telnet-command'.") + +(defvoo nntp-end-of-line "\r\n" + "*String to use on the end of lines when talking to the NNTP server. +This is \"\\r\\n\" by default, but should be \"\\n\" when +using and indirect connection method (nntp-open-via-*).") + +(defvoo nntp-via-rlogin-command "rsh" + "*Rlogin command used to connect to an intermediate host. +This command is used by the `nntp-open-via-rlogin-and-telnet' method. The default is \"rsh\", but \"ssh\" is a popular alternative.") -(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-rlogin'. -That function may be used as `nntp-open-connection-function'. In that -case, this list will be used as the parameter list given to rsh.") - -(defvoo nntp-rlogin-user-name nil - "*User name on remote system when using the rlogin connect method.") +(defvoo nntp-via-rlogin-command-switches nil + "*Switches given to the rlogin command `nntp-via-rlogin-command'. +If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to +\(\"-C\") in order to compress all data connections, otherwise set this +to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet +command requires a pseudo-tty allocation on an intermediate host.") -(defvoo nntp-telnet-parameters - '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-telnet'. -That function may be used as `nntp-open-connection-function'. In that -case, this list will be executed as a command after logging in -via telnet.") +(defvoo nntp-via-telnet-command "telnet" + "*Telnet command used to connect to an intermediate host. +This command is used by the `nntp-open-via-telnet-and-telnet' method.") -(defvoo nntp-telnet-user-name nil - "User name to log in via telnet with.") +(defvoo nntp-via-telnet-switches '("-8") + "*Switches given to the telnet command `nntp-via-telnet-command'.") -(defvoo nntp-telnet-passwd nil - "Password to use to log in via telnet with.") +(defvoo nntp-via-user-name nil + "*User name to log in on an intermediate host with. +This variable is used by the `nntp-open-via-telnet-and-telnet' method.") -(defvoo nntp-open-telnet-envuser nil - "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") - -(defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" - "*Regular expression to match the shell prompt on the remote machine.") +(defvoo nntp-via-user-password nil + "*Password to use to log in on an intermediate host with. +This variable is used by the `nntp-open-via-telnet-and-telnet' method.") -(defvoo nntp-telnet-command "telnet" - "Command used to start telnet.") +(defvoo nntp-via-address nil + "*Address of an intermediate host to connect to. +This variable is used by the `nntp-open-via-rlogin-and-telnet' and +`nntp-open-via-telnet-and-telnet' methods.") -(defvoo nntp-telnet-switches '("-8") - "Switches given to the telnet command.") +(defvoo nntp-via-envuser nil + "*Whether both telnet client and server support the ENVIRON option. +If non-nil, there will be no prompt for a login name.") -(defvoo nntp-end-of-line "\r\n" - "String to use on the end of lines when talking to the NNTP server. -This is \"\\r\\n\" by default, but should be \"\\n\" when -using rlogin or telnet to communicate with the server.") +(defvoo nntp-via-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" + "*Regular expression to match the shell prompt on an intermediate host. +This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-large-newsgroup 50 - "*The number of the articles which indicates a large newsgroup. -If the number of the articles is greater than the value, verbose + "*The number of articles which indicates a large newsgroup. +If the number of articles is greater than the value, verbose messages will be shown to indicate the current status.") (defvoo nntp-maximum-request 400 @@ -174,8 +195,7 @@ (string :format "Login: %v")) (cons :format "%v" (const :format "" "password") - (string :format "Password: %v")))))) - :group 'nntp) + (string :format "Password: %v"))))))) @@ -184,6 +204,10 @@ If this variable is nil, which is the default, no timers are set. NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.") +(defvoo nntp-prepare-post-hook nil + "*Hook run just before posting an article. It is supposed to be used +to insert Cancel-Lock headers.") + ;;; Internal variables. (defvar nntp-record-commands nil @@ -224,16 +248,13 @@ (defvar nntp-async-timer nil) (defvar nntp-async-process-list nil) -(defvar nntp-ssl-program +(defvar nntp-ssl-program "openssl s_client -quiet -ssl3 -connect %s:%p" "A string containing commands for SSL connections. Within a string, %s is replaced with the server address and %p with port number on server. The program should accept IMAP commands on stdin and return responses to stdout.") -(eval-and-compile - (autoload 'mail-source-read-passwd "mail-source")) - ;;; Internal functions. @@ -247,7 +268,9 @@ nntp-last-command string) (when nntp-record-commands (nntp-record-command string)) - (process-send-string process (concat string nntp-end-of-line))) + (process-send-string process (concat string nntp-end-of-line)) + (or (memq (process-status process) '(open run)) + (nntp-report "Server closed connection"))) (defun nntp-record-command (string) "Record the command STRING." @@ -259,6 +282,27 @@ "." (format "%03d" (/ (nth 2 time) 1000)) " " nntp-address " " string "\n")))) +(defun nntp-report (&rest args) + "Report an error from the nntp backend. The first string in ARGS +can be a format string. For some commands, the failed command may be +retried once before actually displaying the error report." + + (when nntp-record-commands + (nntp-record-command "*** CALLED nntp-report ***")) + + (nnheader-report 'nntp args) + + (apply 'error args)) + +(defun nntp-report-1 (&rest args) + "Throws out to nntp-with-open-group-error so that the connection may +be restored and the command retried." + + (when nntp-record-commands + (nntp-record-command "*** CONNECTION LOST ***")) + + (throw 'nntp-with-open-group-error t)) + (defsubst nntp-wait-for (process wait-for buffer &optional decode discard) "Wait for WAIT-FOR to arrive from PROCESS." (save-excursion @@ -269,6 +313,8 @@ (memq (process-status process) '(open run))) (when (looking-at "480") (nntp-handle-authinfo process)) + (when (looking-at "^.*\n") + (delete-region (point) (progn (forward-line 1) (point)))) (nntp-accept-process-output process) (goto-char (point-min))) (prog1 @@ -278,27 +324,31 @@ (nntp-snarf-error-message) nil)) ((not (memq (process-status process) '(open run))) - (nnheader-report 'nntp "Server closed connection")) + (nntp-report "Server closed connection")) (t (goto-char (point-max)) - (let ((limit (point-min))) + (let ((limit (point-min)) + response) (while (not (re-search-backward wait-for limit t)) (nntp-accept-process-output process) ;; We assume that whatever we wait for is less than 1000 ;; characters long. (setq limit (max (- (point-max) 1000) (point-min))) - (goto-char (point-max)))) + (goto-char (point-max))) + (setq response (match-string 0)) + (with-current-buffer nntp-server-buffer + (setq nntp-process-response response))) (nntp-decode-text (not decode)) (unless discard (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (insert-buffer-substring (process-buffer process)) + (set-buffer buffer) + (goto-char (point-max)) + (insert-buffer-substring (process-buffer process)) ;; Nix out "nntp reading...." message. (when nntp-have-messaged (setq nntp-have-messaged nil) - (nnheader-message 5 "")) - t)))) + (nnheader-message 5 "")))) + t)) (unless discard (erase-buffer))))) @@ -312,7 +362,7 @@ (let ((alist nntp-connection-alist) (buffer (if (stringp buffer) (get-buffer buffer) buffer)) process entry) - (while (setq entry (pop alist)) + (while (and alist (setq entry (pop alist))) (when (eq buffer (cadr entry)) (setq process (car entry) alist nil))) @@ -338,32 +388,33 @@ "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." (let ((process (or (nntp-find-connection buffer) (nntp-open-connection buffer)))) - (if (not process) - (nnheader-report 'nntp "Couldn't open connection to %s" address) - (unless (or nntp-inhibit-erase nnheader-callback-function) - (save-excursion - (set-buffer (process-buffer process)) - (erase-buffer))) - (condition-case err - (progn - (when command - (nntp-send-string process command)) - (cond - ((eq callback 'ignore) - t) - ((and callback wait-for) - (nntp-async-wait process wait-for buffer decode callback) - t) - (wait-for - (nntp-wait-for process wait-for buffer decode)) - (t t))) - (error - (nnheader-report 'nntp "Couldn't open connection to %s: %s" - address err)) - (quit - (message "Quit retrieving data from nntp") - (signal 'quit nil) - nil))))) + (if process + (progn + (unless (or nntp-inhibit-erase nnheader-callback-function) + (save-excursion + (set-buffer (process-buffer process)) + (erase-buffer))) + (condition-case err + (progn + (when command + (nntp-send-string process command)) + (cond + ((eq callback 'ignore) + t) + ((and callback wait-for) + (nntp-async-wait process wait-for buffer decode callback) + t) + (wait-for + (nntp-wait-for process wait-for buffer decode)) + (t t))) + (error + (nnheader-report 'nntp "Couldn't open connection to %s: %s" + address err)) + (quit + (message "Quit retrieving data from nntp") + (signal 'quit nil) + nil))) + (nnheader-report 'nntp "Couldn't open connection to %s" address)))) (defsubst nntp-send-command (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." @@ -372,17 +423,56 @@ (save-excursion (set-buffer nntp-server-buffer) (erase-buffer))) - (nntp-retrieve-data - (mapconcat 'identity strings " ") - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function)) + (let* ((command (mapconcat 'identity strings " ")) + (process (nntp-find-connection nntp-server-buffer)) + (buffer (and process (process-buffer process))) + (pos (and buffer (with-current-buffer buffer (point))))) + (if process + (prog1 + (nntp-retrieve-data command + nntp-address nntp-port-number + nntp-server-buffer + wait-for nnheader-callback-function) + ;; If nothing to wait for, still remove possibly echo'ed commands. + ;; We don't have echos if nntp-open-connection-function + ;; is `nntp-open-network-stream', so we skip this in that case. + (unless (or wait-for + (equal nntp-open-connection-function + 'nntp-open-network-stream)) + (nntp-accept-response) + (save-excursion + (set-buffer buffer) + (goto-char pos) + (if (looking-at (regexp-quote command)) + (delete-region pos (progn (forward-line 1) + (gnus-point-at-bol)))) + ))) + (nnheader-report 'nntp "Couldn't open connection to %s." + nntp-address)))) (defun nntp-send-command-nodelete (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." - (nntp-retrieve-data - (mapconcat 'identity strings " ") - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function)) + (let* ((command (mapconcat 'identity strings " ")) + (process (nntp-find-connection nntp-server-buffer)) + (buffer (and process (process-buffer process))) + (pos (and buffer (with-current-buffer buffer (point))))) + (if process + (prog1 + (nntp-retrieve-data command + nntp-address nntp-port-number + nntp-server-buffer + wait-for nnheader-callback-function) + ;; If nothing to wait for, still remove possibly echo'ed commands + (unless wait-for + (nntp-accept-response) + (save-excursion + (set-buffer buffer) + (goto-char pos) + (if (looking-at (regexp-quote command)) + (delete-region pos (progn (forward-line 1) + (gnus-point-at-bol))))))) + (nnheader-report 'nntp "Couldn't open connection to %s." + nntp-address)))) (defun nntp-send-command-and-decode (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." @@ -391,10 +481,28 @@ (save-excursion (set-buffer nntp-server-buffer) (erase-buffer))) - (nntp-retrieve-data - (mapconcat 'identity strings " ") - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function t)) + (let* ((command (mapconcat 'identity strings " ")) + (process (nntp-find-connection nntp-server-buffer)) + (buffer (and process (process-buffer process))) + (pos (and buffer (with-current-buffer buffer (point))))) + (if process + (prog1 + (nntp-retrieve-data command + nntp-address nntp-port-number + nntp-server-buffer + wait-for nnheader-callback-function t) + ;; If nothing to wait for, still remove possibly echo'ed commands + (unless wait-for + (nntp-accept-response) + (save-excursion + (set-buffer buffer) + (goto-char pos) + (if (looking-at (regexp-quote command)) + (delete-region pos (progn (forward-line 1) (gnus-point-at-bol)))) + ))) + (nnheader-report 'nntp "Couldn't open connection to %s." + nntp-address)))) + (defun nntp-send-buffer (wait-for) "Send the current buffer to server and wait until WAIT-FOR returns." @@ -436,208 +544,288 @@ (t nil))) +(eval-when-compile + (defvar nntp-with-open-group-internal nil) + (defvar nntp-report-n nil)) + +(defmacro nntp-with-open-group (group server &optional connectionless &rest forms) + "Protect against servers that don't like clients that keep idle connections opens. +The problem being that these servers may either close a connection or +simply ignore any further requests on a connection. Closed +connections are not detected until accept-process-output has updated +the process-status. Dropped connections are not detected until the +connection timeouts (which may be several minutes) or +nntp-connection-timeout has expired. When these occur +nntp-with-open-group, opens a new connection then re-issues the NNTP +command whose response triggered the error." + (when (and (listp connectionless) + (not (eq connectionless nil))) + (setq forms (cons connectionless forms) + connectionless nil)) + `(letf ((nntp-report-n (symbol-function 'nntp-report)) + ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1)) + (nntp-with-open-group-internal nil)) + (while (catch 'nntp-with-open-group-error + ;; Open the connection to the server + ;; NOTE: Existing connections are NOT tested. + (nntp-possibly-change-group ,group ,server ,connectionless) + + (let ((timer + (and nntp-connection-timeout + (nnheader-run-at-time + nntp-connection-timeout nil + '(lambda () + (let ((process (nntp-find-connection + nntp-server-buffer)) + (buffer (and process + (process-buffer process)))) + ;; When I an able to identify the + ;; connection to the server AND I've + ;; received NO reponse for + ;; nntp-connection-timeout seconds. + (when (and buffer (eq 0 (buffer-size buffer))) + ;; Close the connection. Take no + ;; other action as the accept input + ;; code will handle the closed + ;; connection. + (nntp-kill-buffer buffer)))))))) + (unwind-protect + (setq nntp-with-open-group-internal + (condition-case nil + (progn ,@forms) + (quit + (nntp-close-server) + (signal 'quit nil)))) + (when timer + (nnheader-cancel-timer timer))) + nil)) + (setf (symbol-function 'nntp-report) nntp-report-n)) + nntp-with-open-group-internal)) + (deffoo nntp-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." - (nntp-possibly-change-group group server) - (save-excursion - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - (erase-buffer) - (if (and (not gnus-nov-is-evil) - (not nntp-nov-is-evil) - (nntp-retrieve-headers-with-xover articles fetch-old)) - ;; We successfully retrieved the headers via XOVER. - 'nov - ;; XOVER didn't work, so we do it the hard, slow and inefficient - ;; way. - (let ((number (length articles)) - (count 0) - (received 0) - (last-point (point-min)) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (nntp-inhibit-erase t) - article) - ;; Send HEAD commands. - (while (setq article (pop articles)) - (nntp-send-command - nil - "HEAD" (if (numberp article) - (int-to-string article) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - article)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (nntp-next-result-arrived-p) - (setq last-point (point)) - (incf received)) - (< received count)) - ;; If number of headers is greater than 100, give - ;; informative messages. - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (nnheader-message 6 "NNTP: Receiving headers... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (nnheader-message 6 "NNTP: Receiving headers...done")) + (nntp-with-open-group + group server + (save-excursion + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) + (erase-buffer) + (if (and (not gnus-nov-is-evil) + (not nntp-nov-is-evil) + (nntp-retrieve-headers-with-xover articles fetch-old)) + ;; We successfully retrieved the headers via XOVER. + 'nov + ;; XOVER didn't work, so we do it the hard, slow and inefficient + ;; way. + (let ((number (length articles)) + (articles articles) + (count 0) + (received 0) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t) + article) + ;; Send HEAD commands. + (while (setq article (pop articles)) + (nntp-send-command + nil + "HEAD" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (setq last-point (point)) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving headers... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (nnheader-message 6 "NNTP: Receiving headers...done")) - ;; Now all of replies are received. Fold continuation lines. - (nnheader-fold-continuation-lines) - ;; Remove all "\r"'s. - (nnheader-strip-cr) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'headers)))) + ;; Now all of replies are received. Fold continuation lines. + (nnheader-fold-continuation-lines) + ;; Remove all "\r"'s. + (nnheader-strip-cr) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'headers))))) (deffoo nntp-retrieve-groups (groups &optional server) "Retrieve group info on GROUPS." - (nntp-possibly-change-group nil server) - (when (nntp-find-connection-buffer nntp-server-buffer) - (save-excursion - ;; Erase nntp-server-buffer before nntp-inhibit-erase. - (set-buffer nntp-server-buffer) - (erase-buffer) - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - ;; The first time this is run, this variable is `try'. So we - ;; try. - (when (eq nntp-server-list-active-group 'try) - (nntp-try-list-active (car groups))) - (erase-buffer) - (let ((count 0) - (received 0) - (last-point (point-min)) - (nntp-inhibit-erase t) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP"))) - (while groups - ;; Send the command to the server. - (nntp-send-command nil command (pop groups)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null groups) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - ;; Search `blue moon' in this file for the - ;; reason why set-buffer here. - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (re-search-forward "^[0-9]" nil t) - (incf received)) - (setq last-point (point)) - (< received count)) - (nntp-accept-response)))) + (nntp-with-open-group + nil server + (when (nntp-find-connection-buffer nntp-server-buffer) + (catch 'done + (save-excursion + ;; Erase nntp-server-buffer before nntp-inhibit-erase. + (set-buffer nntp-server-buffer) + (erase-buffer) + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) + ;; The first time this is run, this variable is `try'. So we + ;; try. + (when (eq nntp-server-list-active-group 'try) + (nntp-try-list-active (car groups))) + (erase-buffer) + (let ((count 0) + (groups groups) + (received 0) + (last-point (point-min)) + (nntp-inhibit-erase t) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (command (if nntp-server-list-active-group + "LIST ACTIVE" "GROUP"))) + (while groups + ;; Timeout may have killed the buffer. + (unless (gnus-buffer-live-p buf) + (nnheader-report 'nntp "Connection to %s is closed." server) + (throw 'done nil)) + ;; Send the command to the server. + (nntp-send-command nil command (pop groups)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null groups) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (and (gnus-buffer-live-p buf) + (progn + ;; Search `blue moon' in this file for the + ;; reason why set-buffer here. + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (re-search-forward "^[0-9]" nil t) + (incf received)) + (setq last-point (point)) + (< received count))) + (nntp-accept-response)))) - ;; Wait for the reply from the final command. - (set-buffer buf) - (goto-char (point-max)) - (re-search-backward "^[0-9]" nil t) - (when (looking-at "^[23]") - (while (progn - (set-buffer buf) - (goto-char (point-max)) - (if (not nntp-server-list-active-group) - (not (re-search-backward "\r?\n" (- (point) 3) t)) - (not (re-search-backward "^\\.\r?\n" (- (point) 4) t)))) - (nntp-accept-response))) + ;; Wait for the reply from the final command. + (unless (gnus-buffer-live-p buf) + (nnheader-report 'nntp "Connection to %s is closed." server) + (throw 'done nil)) + (set-buffer buf) + (goto-char (point-max)) + (re-search-backward "^[0-9]" nil t) + (when (looking-at "^[23]") + (while (and (gnus-buffer-live-p buf) + (progn + (set-buffer buf) + (goto-char (point-max)) + (if (not nntp-server-list-active-group) + (not (re-search-backward "\r?\n" + (- (point) 3) t)) + (not (re-search-backward "^\\.\r?\n" + (- (point) 4) t))))) + (nntp-accept-response))) - ;; Now all replies are received. We remove CRs. - (set-buffer buf) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (replace-match "" t t)) + ;; Now all replies are received. We remove CRs. + (unless (gnus-buffer-live-p buf) + (nnheader-report 'nntp "Connection to %s is closed." server) + (throw 'done nil)) + (set-buffer buf) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (replace-match "" t t)) - (if (not nntp-server-list-active-group) - (progn - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'group) - ;; We have read active entries, so we just delete the - ;; superfluous gunk. - (goto-char (point-min)) - (while (re-search-forward "^[.2-5]" nil t) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point)))) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'active))))) + (if (not nntp-server-list-active-group) + (progn + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'group) + ;; We have read active entries, so we just delete the + ;; superfluous gunk. + (goto-char (point-min)) + (while (re-search-forward "^[.2-5]" nil t) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point)))) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'active))))))) (deffoo nntp-retrieve-articles (articles &optional group server) - (nntp-possibly-change-group group server) - (save-excursion - (let ((number (length articles)) - (count 0) - (received 0) - (last-point (point-min)) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (nntp-inhibit-erase t) - (map (apply 'vector articles)) - (point 1) - article) - (set-buffer buf) - (erase-buffer) - ;; Send ARTICLE command. - (while (setq article (pop articles)) - (nntp-send-command - nil - "ARTICLE" (if (numberp article) - (int-to-string article) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - article)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (nntp-next-result-arrived-p) - (aset map received (cons (aref map received) (point))) - (setq last-point (point)) - (incf received)) - (< received count)) - ;; If number of headers is greater than 100, give - ;; informative messages. - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (nnheader-message 6 "NNTP: Receiving articles... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (nnheader-message 6 "NNTP: Receiving articles...done")) + (nntp-with-open-group + group server + (save-excursion + (let ((number (length articles)) + (articles articles) + (count 0) + (received 0) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t) + (map (apply 'vector articles)) + (point 1) + article) + (set-buffer buf) + (erase-buffer) + ;; Send ARTICLE command. + (while (setq article (pop articles)) + (nntp-send-command + nil + "ARTICLE" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (aset map received (cons (aref map received) (point))) + (setq last-point (point)) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving articles... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (nnheader-message 6 "NNTP: Receiving articles...done")) - ;; Now we have all the responses. We go through the results, - ;; wash it and copy it over to the server buffer. - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq last-point (point-min)) - (mapcar - (lambda (entry) - (narrow-to-region - (setq point (goto-char (point-max))) - (progn - (insert-buffer-substring buf last-point (cdr entry)) - (point-max))) - (setq last-point (cdr entry)) - (nntp-decode-text) - (widen) - (cons (car entry) point)) - map)))) + ;; Now we have all the responses. We go through the results, + ;; wash it and copy it over to the server buffer. + (set-buffer nntp-server-buffer) + (erase-buffer) + (setq last-point (point-min)) + (mapcar + (lambda (entry) + (narrow-to-region + (setq point (goto-char (point-max))) + (progn + (insert-buffer-substring buf last-point (cdr entry)) + (point-max))) + (setq last-point (cdr entry)) + (nntp-decode-text) + (widen) + (cons (car entry) point)) + map))))) (defun nntp-try-list-active (group) (nntp-list-active-group group) @@ -652,47 +840,53 @@ (deffoo nntp-list-active-group (group &optional server) "Return the active info on GROUP (which can be a regexp)." - (nntp-possibly-change-group nil server) - (nntp-send-command "^\\.*\r?\n" "LIST ACTIVE" group)) + (nntp-with-open-group + nil server + (nntp-send-command "^\\.*\r?\n" "LIST ACTIVE" group))) (deffoo nntp-request-group-articles (group &optional server) "Return the list of existing articles in GROUP." - (nntp-possibly-change-group nil server) - (nntp-send-command "^\\.*\r?\n" "LISTGROUP" group)) + (nntp-with-open-group + nil server + (nntp-send-command "^\\.*\r?\n" "LISTGROUP" group))) (deffoo nntp-request-article (article &optional group server buffer command) - (nntp-possibly-change-group group server) - (when (nntp-send-command-and-decode - "\r?\n\\.\r?\n" "ARTICLE" - (if (numberp article) (int-to-string article) article)) - (if (and buffer - (not (equal buffer nntp-server-buffer))) - (save-excursion - (set-buffer nntp-server-buffer) - (copy-to-buffer buffer (point-min) (point-max)) - (nntp-find-group-and-number)) - (nntp-find-group-and-number)))) + (nntp-with-open-group + group server + (when (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "ARTICLE" + (if (numberp article) (int-to-string article) article)) + (if (and buffer + (not (equal buffer nntp-server-buffer))) + (save-excursion + (set-buffer nntp-server-buffer) + (copy-to-buffer buffer (point-min) (point-max)) + (nntp-find-group-and-number group)) + (nntp-find-group-and-number group))))) (deffoo nntp-request-head (article &optional group server) - (nntp-possibly-change-group group server) - (when (nntp-send-command - "\r?\n\\.\r?\n" "HEAD" - (if (numberp article) (int-to-string article) article)) - (prog1 - (nntp-find-group-and-number) - (nntp-decode-text)))) + (nntp-with-open-group + group server + (when (nntp-send-command + "\r?\n\\.\r?\n" "HEAD" + (if (numberp article) (int-to-string article) article)) + (prog1 + (nntp-find-group-and-number group) + (nntp-decode-text))))) (deffoo nntp-request-body (article &optional group server) - (nntp-possibly-change-group group server) - (nntp-send-command-and-decode - "\r?\n\\.\r?\n" "BODY" - (if (numberp article) (int-to-string article) article))) + (nntp-with-open-group + group server + (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "BODY" + (if (numberp article) (int-to-string article) article)))) (deffoo nntp-request-group (group &optional server dont-check) - (nntp-possibly-change-group nil server) - (when (nntp-send-command "^[245].*\n" "GROUP" group) - (let ((entry (nntp-find-connection-entry nntp-server-buffer))) - (setcar (cddr entry) group)))) + (nntp-with-open-group + nil server + (when (nntp-send-command "^[245].*\n" "GROUP" group) + (let ((entry (nntp-find-connection-entry nntp-server-buffer))) + (setcar (cddr entry) group))))) (deffoo nntp-close-group (group &optional server) t) @@ -750,38 +944,58 @@ (nntp-kill-buffer (process-buffer process))))) (deffoo nntp-request-list (&optional server) - (nntp-possibly-change-group nil server) - (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST")) + (nntp-with-open-group + nil server + (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST"))) (deffoo nntp-request-list-newsgroups (&optional server) - (nntp-possibly-change-group nil server) - (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS")) + (nntp-with-open-group + nil server + (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS"))) (deffoo nntp-request-newgroups (date &optional server) - (nntp-possibly-change-group nil server) - (save-excursion - (set-buffer nntp-server-buffer) - (let* ((time (date-to-time date)) - (ls (- (cadr time) (nth 8 (decode-time time))))) - (cond ((< ls 0) - (setcar time (1- (car time))) - (setcar (cdr time) (+ ls 65536))) - ((>= ls 65536) - (setcar time (1+ (car time))) - (setcar (cdr time) (- ls 65536))) - (t - (setcar (cdr time) ls))) - (prog1 - (nntp-send-command - "^\\.\r?\n" "NEWGROUPS" - (format-time-string "%y%m%d %H%M%S" time) - "GMT") - (nntp-decode-text))))) + (nntp-with-open-group + nil server + (save-excursion + (set-buffer nntp-server-buffer) + (let* ((time (date-to-time date)) + (ls (- (cadr time) (nth 8 (decode-time time))))) + (cond ((< ls 0) + (setcar time (1- (car time))) + (setcar (cdr time) (+ ls 65536))) + ((>= ls 65536) + (setcar time (1+ (car time))) + (setcar (cdr time) (- ls 65536))) + (t + (setcar (cdr time) ls))) + (prog1 + (nntp-send-command + "^\\.\r?\n" "NEWGROUPS" + (format-time-string "%y%m%d %H%M%S" time) + "GMT") + (nntp-decode-text)))))) (deffoo nntp-request-post (&optional server) - (nntp-possibly-change-group nil server) - (when (nntp-send-command "^[23].*\r?\n" "POST") - (nntp-send-buffer "^[23].*\n"))) + (nntp-with-open-group + nil server + (when (nntp-send-command "^[23].*\r?\n" "POST") + (let ((response (with-current-buffer nntp-server-buffer + nntp-process-response)) + server-id) + (when (and response + (string-match "^[23].*\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" + response)) + (setq server-id (match-string 1 response)) + (narrow-to-region (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (unless (mail-fetch-field "Message-ID") + (goto-char (point-min)) + (insert "Message-ID: " server-id "\n")) + (widen)) + (run-hooks 'nntp-prepare-post-hook) + (nntp-send-buffer "^[23].*\n"))))) (deffoo nntp-request-type (group article) 'news) @@ -824,9 +1038,8 @@ (or passwd nntp-authinfo-password (setq nntp-authinfo-password - (mail-source-read-passwd - (format "NNTP (%s@%s) password: " - user nntp-address)))))))))) + (read-passwd (format "NNTP (%s@%s) password: " + user nntp-address)))))))))) (defun nntp-send-nosy-authinfo () "Send the AUTHINFO to the nntp server." @@ -835,8 +1048,8 @@ (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) (when t ;???Should check if AUTHINFO succeeded (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" - (mail-source-read-passwd "NNTP (%s@%s) password: " - user nntp-address)))))) + (read-passwd (format "NNTP (%s@%s) password: " + user nntp-address))))))) (defun nntp-send-authinfo-from-file () "Send the AUTHINFO to the nntp server. @@ -850,7 +1063,7 @@ (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name)) (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" - (buffer-substring (point) (progn (end-of-line) (point))))))) + (buffer-substring (point) (gnus-point-at-eol)))))) ;;; Internal functions. @@ -895,7 +1108,7 @@ (process (condition-case () (let ((coding-system-for-read nntp-coding-system-for-read) - (coding-system-for-write nntp-coding-system-for-write)) + (coding-system-for-write nntp-coding-system-for-write)) (funcall nntp-open-connection-function pbuffer)) (error nil) (quit @@ -905,11 +1118,13 @@ nil)))) (when timer (nnheader-cancel-timer timer)) + (unless process + (nntp-kill-buffer pbuffer)) (when (and (buffer-name pbuffer) process) (process-kill-without-query process) - (nntp-wait-for process "^.*\n" buffer nil t) - (if (memq (process-status process) '(open run)) + (if (and (nntp-wait-for process "^2.*\n" buffer nil t) + (memq (process-status process) '(open run))) (prog1 (caar (push (list process buffer nil) nntp-connection-alist)) (push process nntp-connection-list) @@ -927,19 +1142,35 @@ (defun nntp-open-network-stream (buffer) (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) +(autoload 'format-spec "format") +(autoload 'format-spec-make "format") +(autoload 'open-tls-stream "tls") + (defun nntp-open-ssl-stream (buffer) (let* ((process-connection-type nil) - (proc (start-process "nntpd" buffer + (proc (start-process "nntpd" buffer shell-file-name shell-command-switch - (format-spec nntp-ssl-program + (format-spec nntp-ssl-program (format-spec-make ?s nntp-address ?p nntp-port-number))))) (process-kill-without-query proc) (save-excursion (set-buffer buffer) - (nntp-wait-for-string "^\r*20[01]") + (let ((nntp-connection-alist (list proc buffer nil))) + (nntp-wait-for-string "^\r*20[01]")) + (beginning-of-line) + (delete-region (point-min) (point)) + proc))) + +(defun nntp-open-tls-stream (buffer) + (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number))) + (process-kill-without-query proc) + (save-excursion + (set-buffer buffer) + (let ((nntp-connection-alist (list proc buffer nil))) + (nntp-wait-for-string "^\r*20[01]")) (beginning-of-line) (delete-region (point-min) (point)) proc))) @@ -1027,6 +1258,9 @@ (goto-char (point-max)) (when (re-search-backward nntp-process-wait-for nntp-process-start-point t) + (let ((response (match-string 0))) + (with-current-buffer nntp-server-buffer + (setq nntp-process-response response))) (nntp-async-stop process) ;; convert it. (when (gnus-buffer-exists-p nntp-process-to-buffer) @@ -1060,7 +1294,7 @@ (nnheader-report 'nntp message) message)) -(defun nntp-accept-process-output (process &optional timeout) +(defun nntp-accept-process-output (process) "Wait for output from PROCESS and message some dots." (save-excursion (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer) @@ -1070,7 +1304,14 @@ (unless (< len 10) (setq nntp-have-messaged t) (nnheader-message 7 "nntp read: %dk" len))) - (accept-process-output process (or timeout 1)))) + (nnheader-accept-process-output process) + ;; accept-process-output may update status of process to indicate + ;; that the server has closed the connection. This MUST be + ;; handled here as the buffer restored by the save-excursion may + ;; be the process's former output buffer (i.e. now killed) + (or (and process + (memq (process-status process) '(open run))) + (nntp-report "Server closed connection")))) (defun nntp-accept-response () "Wait for output from the process that outputs to BUFFER." @@ -1088,13 +1329,18 @@ (when group (let ((entry (nntp-find-connection-entry nntp-server-buffer))) - (when (not (equal group (caddr entry))) - (save-excursion - (set-buffer (process-buffer (car entry))) - (erase-buffer) - (nntp-send-command "^[245].*\n" "GROUP" group) - (setcar (cddr entry) group) - (erase-buffer)))))) + (cond ((not entry) + (nntp-report "Server closed connection")) + ((not (equal group (caddr entry))) + (save-excursion + (set-buffer (process-buffer (car entry))) + (erase-buffer) + (nntp-send-command "^[245].*\n" "GROUP" group) + (setcar (cddr entry) group) + (erase-buffer) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer)))))))) (defun nntp-decode-text (&optional cr-only) "Decode the text in the current buffer." @@ -1178,7 +1424,7 @@ in-process-buffer-p (buf nntp-server-buffer) (process-buffer (nntp-find-connection-buffer nntp-server-buffer)) - first) + first last status) ;; We have to check `nntp-server-xover'. If it gets set to nil, ;; that means that the server does not understand XOVER, but we ;; won't know that until we try. @@ -1191,8 +1437,8 @@ (setq articles (cdr articles))) (setq in-process-buffer-p (stringp nntp-server-xover)) - (nntp-send-xover-command first (car articles)) - (setq articles (cdr articles)) + (nntp-send-xover-command first (setq last (car articles))) + (setq articles (cdr articles)) (when (and nntp-server-xover in-process-buffer-p) ;; Don't count tried request. @@ -1201,7 +1447,7 @@ ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) + (= 1 (% count nntp-maximum-request))) (nntp-accept-response) ;; On some Emacs versions the preceding function has a @@ -1212,30 +1458,49 @@ (while (progn (goto-char (or last-point (point-min))) ;; Count replies. - (while (re-search-forward "^[0-9][0-9][0-9] .*\n" nil t) - (incf received)) + (while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n" + nil t) + (incf received) + (setq status (match-string 1)) + (if (string-match "^[45]" status) + (setq status 'error) + (setq status 'ok))) (setq last-point (point)) - (< received count)) + (or (< received count) + (if (eq status 'error) + nil + ;; I haven't started reading the final response + (progn + (goto-char (point-max)) + (forward-line -1) + (not (looking-at "^\\.\r?\n")))))) + ;; I haven't read the end of the final response (nntp-accept-response) - (set-buffer process-buffer)) - (set-buffer buf)))) + (set-buffer process-buffer)))) + + ;; Some nntp servers seem to have an extension to the XOVER + ;; extension. On these servers, requesting an article range + ;; preceeding the active range does not return an error as + ;; specified in the RFC. What we instead get is the NOV entry + ;; for the first available article. Obviously, a client can + ;; use that entry to avoid making unnecessary requests. The + ;; only problem is for a client that assumes that the response + ;; will always be within the requested ranage. For such a + ;; client, we can get N copies of the same entry (one for each + ;; XOVER command sent to the server). + + (when (<= count 1) + (goto-char (point-min)) + (when (re-search-forward "^[0-9][0-9][0-9] .*\n\\([0-9]+\\)" nil t) + (let ((low-limit (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1))))) + (while (and articles (<= (car articles) low-limit)) + (setq articles (cdr articles)))))) + (set-buffer buf)) (when nntp-server-xover (when in-process-buffer-p - (set-buffer process-buffer) - ;; Wait for the reply from the final command. - (goto-char (point-max)) - (while (not (re-search-backward "^[0-9][0-9][0-9] " nil t)) - (nntp-accept-response) - (set-buffer process-buffer) - (goto-char (point-max))) - (when (looking-at "^[23]") - (while (progn - (goto-char (point-max)) - (forward-line -1) - (not (looking-at "^\\.\r?\n"))) - (nntp-accept-response) - (set-buffer process-buffer))) (set-buffer buf) (goto-char (point-max)) (insert-buffer-substring process-buffer) @@ -1288,19 +1553,114 @@ (set-buffer nntp-server-buffer) (erase-buffer) (setq nntp-server-xover nil))) - nntp-server-xover)))) + nntp-server-xover)))) -;;; Alternative connection methods. +(defun nntp-find-group-and-number (&optional group) + (save-excursion + (save-restriction + (set-buffer nntp-server-buffer) + (narrow-to-region (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point-max))) + (goto-char (point-min)) + ;; We first find the number by looking at the status line. + (let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ") + (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1))))) + newsgroups xref) + (and number (zerop number) (setq number nil)) + (if number + ;; Then we find the group name. + (setq group + (cond + ;; If there is only one group in the Newsgroups + ;; header, then it seems quite likely that this + ;; article comes from that group, I'd say. + ((and (setq newsgroups + (mail-fetch-field "newsgroups")) + (not (string-match "," newsgroups))) + newsgroups) + ;; If there is more than one group in the + ;; Newsgroups header, then the Xref header should + ;; be filled out. We hazard a guess that the group + ;; that has this article number in the Xref header + ;; is the one we are looking for. This might very + ;; well be wrong if this article happens to have + ;; the same number in several groups, but that's + ;; life. + ((and (setq xref (mail-fetch-field "xref")) + number + (string-match + (format "\\([^ :]+\\):%d" number) xref)) + (match-string 1 xref)) + (t ""))) + (cond + ((and (setq xref (mail-fetch-field "xref")) + (string-match + (if group + (concat "\\(" (regexp-quote group) "\\):\\([0-9]+\\)") + "\\([^ :]+\\):\\([0-9]+\\)") + xref)) + (setq group (match-string 1 xref) + number (string-to-int (match-string 2 xref)))) + ((and (setq newsgroups + (mail-fetch-field "newsgroups")) + (not (string-match "," newsgroups))) + (setq group newsgroups)) + (group) + (t (setq group "")))) + (when (string-match "\r" group) + (setq group (substring group 0 (match-beginning 0)))) + (cons group number))))) (defun nntp-wait-for-string (regexp) "Wait until string arrives in the buffer." - (let ((buf (current-buffer))) + (let ((buf (current-buffer)) + proc) (goto-char (point-min)) - (while (not (re-search-forward regexp nil t)) - (accept-process-output (nntp-find-connection nntp-server-buffer)) + (while (and (setq proc (get-buffer-process buf)) + (memq (process-status proc) '(open run)) + (not (re-search-forward regexp nil t))) + (accept-process-output proc) (set-buffer buf) (goto-char (point-min))))) + +;; ========================================================================== +;; Obsolete nntp-open-* connection methods -- drv +;; ========================================================================== + +(defvoo nntp-open-telnet-envuser nil + "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") + +(defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" + "*Regular expression to match the shell prompt on the remote machine.") + +(defvoo nntp-rlogin-program "rsh" + "*Program used to log in on remote machines. +The default is \"rsh\", but \"ssh\" is a popular alternative.") + +(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") + "*Parameters to `nntp-open-rlogin'. +That function may be used as `nntp-open-connection-function'. In that +case, this list will be used as the parameter list given to rsh.") + +(defvoo nntp-rlogin-user-name nil + "*User name on remote system when using the rlogin connect method.") + +(defvoo nntp-telnet-parameters + '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") + "*Parameters to `nntp-open-telnet'. +That function may be used as `nntp-open-connection-function'. In that +case, this list will be executed as a command after logging in +via telnet.") + +(defvoo nntp-telnet-user-name nil + "User name to log in via telnet with.") + +(defvoo nntp-telnet-passwd nil + "Password to use to log in via telnet with.") + (defun nntp-open-telnet (buffer) (save-excursion (set-buffer buffer) @@ -1331,7 +1691,7 @@ proc (concat (or nntp-telnet-passwd (setq nntp-telnet-passwd - (mail-source-read-passwd "Password: "))) + (read-passwd "Password: "))) "\n")) (nntp-wait-for-string nntp-telnet-shell-prompt) (process-send-string @@ -1366,44 +1726,155 @@ (delete-region (point-min) (point)) proc))) -(defun nntp-find-group-and-number () - (save-excursion - (save-restriction - (set-buffer nntp-server-buffer) - (narrow-to-region (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) + +;; ========================================================================== +;; Replacements for the nntp-open-* functions -- drv +;; ========================================================================== + +(defun nntp-open-telnet-stream (buffer) + "Open a nntp connection by telnet'ing the news server. + +Please refer to the following variables to customize the connection: +- `nntp-pre-command', +- `nntp-telnet-command', +- `nntp-telnet-switches', +- `nntp-address', +- `nntp-port-number', +- `nntp-end-of-line'." + (let ((command `(,nntp-telnet-command + ,@nntp-telnet-switches + ,nntp-address ,nntp-port-number)) + proc) + (and nntp-pre-command + (push nntp-pre-command command)) + (setq proc (apply 'start-process "nntpd" buffer command)) + (save-excursion + (set-buffer buffer) + (nntp-wait-for-string "^\r*20[01]") + (beginning-of-line) + (delete-region (point-min) (point)) + proc))) + +(defun nntp-open-via-rlogin-and-telnet (buffer) + "Open a connection to an nntp server through an intermediate host. +First rlogin to the remote host, and then telnet the real news server +from there. + +Please refer to the following variables to customize the connection: +- `nntp-pre-command', +- `nntp-via-rlogin-command', +- `nntp-via-rlogin-command-switches', +- `nntp-via-user-name', +- `nntp-via-address', +- `nntp-telnet-command', +- `nntp-telnet-switches', +- `nntp-address', +- `nntp-port-number', +- `nntp-end-of-line'." + (let ((command `(,nntp-via-address + ,nntp-telnet-command + ,@nntp-telnet-switches)) + proc) + (when nntp-via-user-name + (setq command `("-l" ,nntp-via-user-name ,@command))) + (when nntp-via-rlogin-command-switches + (setq command (append nntp-via-rlogin-command-switches command))) + (push nntp-via-rlogin-command command) + (and nntp-pre-command + (push nntp-pre-command command)) + (setq proc (apply 'start-process "nntpd" buffer command)) + (save-excursion + (set-buffer buffer) + (nntp-wait-for-string "^r?telnet") + (process-send-string proc (concat "open " nntp-address + " " nntp-port-number "\n")) + (nntp-wait-for-string "^\r*20[01]") + (beginning-of-line) + (delete-region (point-min) (point)) + (process-send-string proc "\^]") + (nntp-wait-for-string "^r?telnet") + (process-send-string proc "mode character\n") + (accept-process-output proc 1) + (sit-for 1) (goto-char (point-min)) - ;; We first find the number by looking at the status line. - (let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ") - (string-to-int - (buffer-substring (match-beginning 1) - (match-end 1))))) - group newsgroups xref) - (and number (zerop number) (setq number nil)) - ;; Then we find the group name. - (setq group - (cond - ;; If there is only one group in the Newsgroups header, - ;; then it seems quite likely that this article comes - ;; from that group, I'd say. - ((and (setq newsgroups (mail-fetch-field "newsgroups")) - (not (string-match "," newsgroups))) - newsgroups) - ;; If there is more than one group in the Newsgroups - ;; header, then the Xref header should be filled out. - ;; We hazard a guess that the group that has this - ;; article number in the Xref header is the one we are - ;; looking for. This might very well be wrong if this - ;; article happens to have the same number in several - ;; groups, but that's life. - ((and (setq xref (mail-fetch-field "xref")) - number - (string-match (format "\\([^ :]+\\):%d" number) xref)) - (substring xref (match-beginning 1) (match-end 1))) - (t ""))) - (when (string-match "\r" group) - (setq group (substring group 0 (match-beginning 0)))) - (cons group number))))) + (forward-line 1) + (delete-region (point) (point-max))) + proc)) + +(defun nntp-open-via-telnet-and-telnet (buffer) + "Open a connection to an nntp server through an intermediate host. +First telnet the remote host, and then telnet the real news server +from there. + +Please refer to the following variables to customize the connection: +- `nntp-pre-command', +- `nntp-via-telnet-command', +- `nntp-via-telnet-switches', +- `nntp-via-address', +- `nntp-via-envuser', +- `nntp-via-user-name', +- `nntp-via-user-password', +- `nntp-via-shell-prompt', +- `nntp-telnet-command', +- `nntp-telnet-switches', +- `nntp-address', +- `nntp-port-number', +- `nntp-end-of-line'." + (save-excursion + (set-buffer buffer) + (erase-buffer) + (let ((command `(,nntp-via-telnet-command ,@nntp-via-telnet-switches)) + (case-fold-search t) + proc) + (and nntp-pre-command (push nntp-pre-command command)) + (setq proc (apply 'start-process "nntpd" buffer command)) + (when (memq (process-status proc) '(open run)) + (nntp-wait-for-string "^r?telnet") + (process-send-string proc "set escape \^X\n") + (cond + ((and nntp-via-envuser nntp-via-user-name) + (process-send-string proc (concat "open " "-l" nntp-via-user-name + nntp-via-address "\n"))) + (t + (process-send-string proc (concat "open " nntp-via-address + "\n")))) + (when (not nntp-via-envuser) + (nntp-wait-for-string "^\r*.?login:") + (process-send-string proc + (concat + (or nntp-via-user-name + (setq nntp-via-user-name + (read-string "login: "))) + "\n"))) + (nntp-wait-for-string "^\r*.?password:") + (process-send-string proc + (concat + (or nntp-via-user-password + (setq nntp-via-user-password + (read-passwd "Password: "))) + "\n")) + (nntp-wait-for-string nntp-via-shell-prompt) + (let ((real-telnet-command `("exec" + ,nntp-telnet-command + ,@nntp-telnet-switches + ,nntp-address + ,nntp-port-number))) + (process-send-string proc + (concat (mapconcat 'identity + real-telnet-command " ") + "\n"))) + (nntp-wait-for-string "^\r*20[01]") + (beginning-of-line) + (delete-region (point-min) (point)) + (process-send-string proc "\^]") + (nntp-wait-for-string "^r?telnet") + (process-send-string proc "mode character\n") + (accept-process-output proc 1) + (sit-for 1) + (goto-char (point-min)) + (forward-line 1) + (delete-region (point) (point-max))) + proc))) (provide 'nntp)
--- a/lisp/gnus/nnultimate.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnultimate.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ -;;; nnultimate.el --- interfacing with the Ultimate Bulletin Board system -*- coding: iso-latin-1 -*- -;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;;; nnultimate.el --- interfacing with the Ultimate Bulletin Board system + +;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -36,11 +37,9 @@ (require 'gnus) (require 'nnmail) (require 'mm-util) -(eval-when-compile - (ignore-errors - (require 'nnweb))) -;; Report failure to find w3 at load time if appropriate. -(eval '(require 'nnweb)) +(require 'mm-url) +(require 'nnweb) +(autoload 'w3-parse-buffer "w3-parse") (nnoo-declare nnultimate) @@ -107,7 +106,7 @@ fetchers)) (pop articles) (setq article (car articles))))) - ;; Now we have the mapping from/to Gnus/nnultimate article numbers, + ;; Now we have the mapping from/to Gnus/nnultimate article numbers, ;; so we start fetching the topics that we need to satisfy the ;; request. (if (not fetchers) @@ -125,9 +124,9 @@ (setq subject (nth 2 (assq (car elem) topics))) (setq href (nth 3 (assq (car elem) topics))) (if (= current-page 1) - (nnweb-insert href) + (mm-url-insert href) (string-match "\\.html$" href) - (nnweb-insert (concat (substring href 0 (match-beginning 0)) + (mm-url-insert (concat (substring href 0 (match-beginning 0)) "-" (number-to-string current-page) (match-string 0 href)))) (goto-char (point-min)) @@ -173,25 +172,25 @@ datel nil)) (pop datel)) (when date - (setq date (delete "" (split-string - date "[-, \n\t\r ]"))) - (if (or (member "AM" date) - (member "PM" date)) - (setq date (format - "%s %s %s %s" - (nth 1 date) - (if (and (>= (length (nth 0 date)) 3) - (assoc (downcase - (substring (nth 0 date) 0 3)) - parse-time-months)) - (substring (nth 0 date) 0 3) - (car (rassq (string-to-number (nth 0 date)) - parse-time-months))) - (nth 2 date) (nth 3 date))) - (setq date (format "%s %s %s %s" - (car (rassq (string-to-number (nth 1 date)) - parse-time-months)) - (nth 0 date) (nth 2 date) (nth 3 date))))) + (setq date (delete "" (split-string date "[-, \n\t\r ]"))) + (setq date + (if (or (member "AM" date) + (member "PM" date)) + (format + "%s %s %s %s" + (nth 1 date) + (if (and (>= (length (nth 0 date)) 3) + (assoc (downcase + (substring (nth 0 date) 0 3)) + parse-time-months)) + (substring (nth 0 date) 0 3) + (car (rassq (string-to-number (nth 0 date)) + parse-time-months))) + (nth 2 date) (nth 3 date)) + (format "%s %s %s %s" + (car (rassq (string-to-number (nth 1 date)) + parse-time-months)) + (nth 0 date) (nth 2 date) (nth 3 date))))) (push (cons article @@ -269,7 +268,7 @@ (deffoo nnultimate-request-list (&optional server) (nnultimate-possibly-change-server nil server) (mm-with-unibyte-buffer - (nnweb-insert + (mm-url-insert (if (string-match "/$" nnultimate-address) (concat nnultimate-address "Ultimate.cgi") nnultimate-address)) @@ -334,7 +333,7 @@ (mm-with-unibyte-buffer (while furls (erase-buffer) - (nnweb-insert (pop furls)) + (mm-url-insert (pop furls)) (goto-char (point-min)) (setq parse (w3-parse-buffer (current-buffer))) (setq contents
--- a/lisp/gnus/nnvirtual.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnvirtual.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,10 +1,10 @@ ;;; nnvirtual.el --- virtual newsgroups access for Gnus -;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2002 +;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: David Moore <dmoore@ucsd.edu> ;; Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> ;; Keywords: news ;; This file is part of GNU Emacs. @@ -45,13 +45,13 @@ (nnoo-declare nnvirtual) (defvoo nnvirtual-always-rescan t - "*If non-nil, always scan groups for unread articles when entering a group. + "If non-nil, always scan groups for unread articles when entering a group. If this variable is nil and you read articles in a component group after the virtual group has been activated, the read articles from the component group will show up when you enter the virtual group.") (defvoo nnvirtual-component-regexp nil - "*Regexp to match component groups.") + "Regexp to match component groups.") (defvoo nnvirtual-component-groups nil "Component group in this nnvirtual group.") @@ -374,8 +374,9 @@ #'(lambda (article) (nnvirtual-reverse-map-article group article)) - (gnus-group-expire-articles-1 group))))) - (sort unexpired '<))) + (gnus-uncompress-range + (gnus-group-expire-articles-1 group)))))) + (sort (delq nil unexpired) '<))) ;;; Internal functions. @@ -425,7 +426,7 @@ (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+") nil t) (replace-match "" t t)) - (unless (= (point) (point-max)) + (unless (eobp) (insert " ") (when (not (string= "" prefix)) (while (re-search-forward "[^ ]+:[0-9]+" nil t) @@ -520,14 +521,15 @@ ;;; We map between virtual articles and real articles in a manner -;;; which keeps the size of the virtual active list the same as -;;; the sum of the component active lists. -;;; To achieve fair mixing of the groups, the last article in -;;; each of N component groups will be in the last N articles -;;; in the virtual group. +;;; which keeps the size of the virtual active list the same as the +;;; sum of the component active lists. -;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and 6-7 -;;; respectively, then the virtual article numbers look like: +;;; To achieve fair mixing of the groups, the last article in each of +;;; N component groups will be in the last N articles in the virtual +;;; group. + +;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and +;;; 6-7 respectively, then the virtual article numbers look like: ;;; ;;; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ;;; A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7
--- a/lisp/gnus/nnwarchive.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnwarchive.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; nnwarchive.el --- interfacing with web archives -;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> ;; Keywords: news egroups mail-archive @@ -24,7 +24,7 @@ ;;; Commentary: ;; Note: You need to have `url' (w3 0.46) or greater version -;; installed for this backend to work. +;; installed for some functions of this backend to work. ;; Todo: ;; 1. To support more web archives. @@ -41,19 +41,7 @@ (require 'gnus-bcklg) (require 'nnmail) (require 'mm-util) -(require 'mail-source) -(eval-when-compile - (ignore-errors - (require 'w3) - (require 'url) - (require 'w3-forms) - (require 'nnweb))) -;; Report failure to find w3 at load time if appropriate. -(eval '(progn - (require 'w3) - (require 'url) - (require 'w3-forms) - (require 'nnweb))) +(require 'mm-url) (nnoo-declare nnwarchive) @@ -297,7 +285,7 @@ user-mail-address))) (setq nnwarchive-passwd (or nnwarchive-passwd - (mail-source-read-passwd + (read-passwd (format "Password for %s at %s: " nnwarchive-login server))))) (unless nnwarchive-groups @@ -360,23 +348,6 @@ (format " *nnwarchive %s %s*" nnwarchive-type server))))) (nnwarchive-set-default nnwarchive-type)) -(defun nnwarchive-encode-www-form-urlencoded (pairs) - "Return PAIRS encoded for forms." - (mapconcat - (function - (lambda (data) - (concat (w3-form-encode-xwfu (car data)) "=" - (w3-form-encode-xwfu (cdr data))))) - pairs "&")) - -(defun nnwarchive-fetch-form (url pairs) - (let ((url-request-data (nnwarchive-encode-www-form-urlencoded pairs)) - (url-request-method "POST") - (url-request-extra-headers - '(("Content-type" . "application/x-www-form-urlencoded")))) - (nnweb-insert url)) - t) - (defun nnwarchive-eval (expr) (cond ((consp expr) @@ -388,14 +359,14 @@ (defun nnwarchive-url (xurl) (mm-with-unibyte-current-buffer - (let ((url-confirmation-func 'identity) + (let ((url-confirmation-func 'identity) ;; Some hacks. (url-cookie-multiple-line nil)) (cond ((eq (car xurl) 'post) (pop xurl) - (nnwarchive-fetch-form (car xurl) (nnwarchive-eval (cdr xurl)))) + (mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl)))) (t - (nnweb-insert (apply 'format (nnwarchive-eval xurl)))))))) + (mm-url-insert (apply 'format (nnwarchive-eval xurl)))))))) (defun nnwarchive-generate-active () (save-excursion @@ -470,8 +441,8 @@ article (make-full-mail-header article - (nnweb-decode-entities-string subject) - (nnweb-decode-entities-string from) + (mm-url-decode-entities-string subject) + (mm-url-decode-entities-string from) date (concat "<" group "%" (number-to-string article) @@ -490,7 +461,7 @@ (goto-char (point-min)) (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t) (replace-match "\\1")) - (nnweb-decode-entities) + (mm-url-decode-entities) (buffer-string)) (defun nnwarchive-egroups-xover-files (group articles) @@ -550,7 +521,7 @@ subject (match-string 2)) (forward-line 1) (unless (assq article nnwarchive-headers) - (if (looking-at "<UL><LI><EM>From</EM>:\\([^&]+\\)<\\([^&]+\\)>") + (if (looking-at "<UL><LI><EM>From</EM>: *\\([^<]*[^< ]\\) *<\\([^&]+\\)>") (progn (setq from (match-string 1) date (identity (match-string 2)))) @@ -559,8 +530,8 @@ article (make-full-mail-header article - (nnweb-decode-entities-string subject) - (nnweb-decode-entities-string from) + (mm-url-decode-entities-string subject) + (mm-url-decode-entities-string from) date (format "<%05d%%%s>\n" (1- article) group) "" @@ -623,7 +594,7 @@ (when (search-forward "X-Head-End" nil t) (beginning-of-line) (narrow-to-region (point-min) (point)) - (nnweb-decode-entities) + (mm-url-decode-entities) (goto-char (point-min)) (while (search-forward "<!--X-" nil t) (replace-match "")) @@ -645,8 +616,8 @@ (search-forward "</ul>" nil t) (end-of-line) (narrow-to-region (point-min) (point)) - (nnweb-remove-markup) - (nnweb-decode-entities) + (mm-url-remove-markup) + (mm-url-decode-entities) (goto-char (point-min)) (delete-blank-lines) (when from @@ -687,8 +658,8 @@ (delete-region (match-beginning 0) (match-end 0)) (save-restriction (narrow-to-region p (point)) - (nnweb-remove-markup) - (nnweb-decode-entities) + (mm-url-remove-markup) + (mm-url-decode-entities) (goto-char (point-max))))) ((looking-at "<P><A HREF=\"\\([^\"]+\\)") (setq url (match-string 1)) @@ -696,14 +667,17 @@ (progn (forward-line) (point))) ;; I hate to download the url encode it, then immediately ;; decode it. - ;; FixMe: Find a better solution to attach the URL. - ;; Maybe do some hack in external part of mml-generate-mim-1. - (insert "<#part>" - "\n--\nExternal: \n" - (format "<URL:http://www.mail-archive.com/%s/%s>" + (insert "<#external" + " type=" + (or (and url + (string-match "\\.[^\\.]+$" url) + (mailcap-extension-to-mime + (match-string 0 url))) + "application/octet-stream") + (format " url=\"http://www.mail-archive.com/%s/%s\"" group url) - "\n--\n" - "<#/part>") + ">\n" + "<#/external>") (setq mime t)) (t (setq p (point))
--- a/lisp/gnus/nnweb.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/nnweb.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; nnweb.el --- retrieving articles via web search engines -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> @@ -24,8 +24,7 @@ ;;; Commentary: -;; Note: You need to have `url' and `w3' installed for this -;; backend to work. +;; Note: You need to have `w3' installed for some functions to work. ;;; Code: @@ -37,18 +36,11 @@ (require 'gnus) (require 'nnmail) (require 'mm-util) -(eval-when-compile +(require 'mm-url) +(eval-and-compile (ignore-errors - (require 'w3) - (require 'url) - (require 'w3-forms))) - -;; Report failure to find w3 at load time if appropriate. -(unless noninteractive - (eval '(progn - (require 'w3) - (require 'url) - (require 'w3-forms)))) + (require 'url))) +(autoload 'w3-parse-buffer "w3-parse") (nnoo-declare nnweb) @@ -57,63 +49,37 @@ (defvoo nnweb-type 'google "What search engine type is being used. -Valid types include `google', `dejanews', `dejanewsold', `reference', -and `altavista'.") +Valid types include `google', `dejanews', and `gmane'.") (defvar nnweb-type-definition - '( - (google - ;;(article . nnweb-google-wash-article) - ;;(id . "http://groups.google.com/groups?as_umsgid=%s") + '((google (article . ignore) (id . "http://groups.google.com/groups?selm=%s&output=gplain") - ;;(reference . nnweb-google-reference) (reference . identity) (map . nnweb-google-create-mapping) (search . nnweb-google-search) (address . "http://groups.google.com/groups") (identifier . nnweb-google-identity)) (dejanews ;; alias of google - ;;(article . nnweb-google-wash-article) - ;;(id . "http://groups.google.com/groups?as_umsgid=%s") (article . ignore) (id . "http://groups.google.com/groups?selm=%s&output=gplain") - ;;(reference . nnweb-google-reference) (reference . identity) (map . nnweb-google-create-mapping) (search . nnweb-google-search) (address . "http://groups.google.com/groups") (identifier . nnweb-google-identity)) -;;; (dejanews -;;; (article . ignore) -;;; (id . "http://search.dejanews.com/msgid.xp?MID=%s&fmt=text") -;;; (map . nnweb-dejanews-create-mapping) -;;; (search . nnweb-dejanews-search) -;;; (address . "http://www.deja.com/=dnc/qs.xp") -;;; (identifier . nnweb-dejanews-identity)) -;;; (dejanewsold -;;; (article . ignore) -;;; (map . nnweb-dejanews-create-mapping) -;;; (search . nnweb-dejanewsold-search) -;;; (address . "http://www.deja.com/dnquery.xp") -;;; (identifier . nnweb-dejanews-identity)) - (reference - (article . nnweb-reference-wash-article) - (map . nnweb-reference-create-mapping) - (search . nnweb-reference-search) - (address . "http://www.reference.com/cgi-bin/pn/go") - (identifier . identity)) - (altavista - (article . nnweb-altavista-wash-article) - (map . nnweb-altavista-create-mapping) - (search . nnweb-altavista-search) - (address . "http://www.altavista.digital.com/cgi-bin/query") - (id . "/cgi-bin/news?id@%s") - (identifier . identity))) + (gmane + (article . nnweb-gmane-wash-article) + (id . "http://gmane.org/view.php?group=%s") + (reference . identity) + (map . nnweb-gmane-create-mapping) + (search . nnweb-gmane-search) + (address . "http://gmane.org/") + (identifier . nnweb-gmane-identity))) "Type-definition alist.") (defvoo nnweb-search nil - "Search string to feed to DejaNews.") + "Search string to feed to Google.") (defvoo nnweb-max-hits 999 "Maximum number of hits to display.") @@ -197,7 +163,7 @@ (url (and header (mail-header-xref header)))) (when (or (and url (mm-with-unibyte-current-buffer - (nnweb-fetch-url url))) + (mm-url-insert url))) (and (stringp article) (nnweb-definition 'id t) (let ((fetch (nnweb-definition 'id)) @@ -207,7 +173,7 @@ (when (and fetch art) (setq url (format fetch art)) (mm-with-unibyte-current-buffer - (nnweb-fetch-url url)) + (mm-url-insert url)) (if (nnweb-definition 'reference t) (setq article (funcall (nnweb-definition @@ -237,7 +203,7 @@ (nnweb-possibly-change-server group server)) (deffoo nnweb-asynchronous-p () - t) + nil) (deffoo nnweb-request-create-group (group &optional server args) (nnweb-possibly-change-server nil server) @@ -336,383 +302,6 @@ nnweb-type nnweb-search server)) (current-buffer)))))) -(defun nnweb-fetch-url (url) - (let (buf) - (save-excursion - (if (not nnheader-callback-function) - (progn - (with-temp-buffer - (mm-enable-multibyte) - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (default-process-coding-system 'binary)) - (nnweb-insert url)) - (setq buf (buffer-string))) - (erase-buffer) - (insert buf) - t) - (nnweb-url-retrieve-asynch - url 'nnweb-callback (current-buffer) nnheader-callback-function) - t)))) - -(defun nnweb-callback (buffer callback) - (when (gnus-buffer-live-p url-working-buffer) - (save-excursion - (set-buffer url-working-buffer) - (funcall (nnweb-definition 'article)) - (nnweb-decode-entities) - (set-buffer buffer) - (goto-char (point-max)) - (insert-buffer-substring url-working-buffer)) - (funcall callback t) - (gnus-kill-buffer url-working-buffer))) - -(defun nnweb-url-retrieve-asynch (url callback &rest data) - (let ((url-request-method "GET") - (old-asynch url-be-asynchronous) - (url-request-data nil) - (url-request-extra-headers nil) - (url-working-buffer (generate-new-buffer-name " *nnweb*"))) - (setq-default url-be-asynchronous t) - (save-excursion - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-callback-data data - url-be-asynchronous t - url-current-callback-func callback) - (url-retrieve url nil)) - (setq-default url-be-asynchronous old-asynch))) - -(if (fboundp 'url-retrieve-synchronously) - (defun nnweb-url-retrieve-asynch (url callback &rest data) - (url-retrieve url callback data))) - -;;; -;;; DejaNews functions. -;;; - -(defun nnweb-dejanews-create-mapping () - "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) - (erase-buffer) - (when (funcall (nnweb-definition 'search) nnweb-search) - (let ((i 0) - (more t) - (case-fold-search t) - (active (or (cadr (assoc nnweb-group nnweb-group-alist)) - (cons 1 0))) - subject date from - map url parse a table group text) - (while more - ;; Go through all the article hits on this page. - (goto-char (point-min)) - (setq parse (w3-parse-buffer (current-buffer)) - table (nth 1 (nnweb-parse-find-all 'table parse))) - (dolist (row (nth 2 (car (nth 2 table)))) - (setq a (nnweb-parse-find 'a row) - url (cdr (assq 'href (nth 1 a))) - text (nreverse (nnweb-text row))) - (when a - (setq subject (nth 4 text) - group (nth 2 text) - date (nth 1 text) - from (nth 0 text)) - (if (string-match "\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)" date) - (setq date (format "%s %s 00:00:00 %s" - (car (rassq (string-to-number - (match-string 2 date)) - parse-time-months)) - (match-string 3 date) - (match-string 1 date))) - (setq date "Jan 1 00:00:00 0000")) - (incf i) - (setq url (concat url "&fmt=text")) - (when (string-match "&context=[^&]+" url) - (setq url (replace-match "" t t url))) - (unless (nnweb-get-hashtb url) - (push - (list - (incf (cdr active)) - (make-full-mail-header - (cdr active) (concat subject " (" group ")") from date - (concat "<" (nnweb-identifier url) "@dejanews>") - nil 0 0 url)) - map) - (nnweb-set-hashtb (cadar map) (car map))))) - ;; See whether there is a "Get next 20 hits" button here. - (goto-char (point-min)) - (if (or (not (re-search-forward - "HREF=\"\\([^\"]+\\)\"[<>b]+Next result" nil t)) - (>= i nnweb-max-hits)) - (setq more nil) - ;; Yup -- fetch it. - (setq more (match-string 1)) - (erase-buffer) - (url-insert-file-contents more))) - ;; Return the articles in the right order. - (setq nnweb-articles - (sort (nconc nnweb-articles map) 'car-less-than-car)))))) - -(defun nnweb-dejanews-search (search) - (nnweb-insert - (concat - (nnweb-definition 'address) - "?" - (nnweb-encode-www-form-urlencoded - `(("ST" . "PS") - ("svcclass" . "dnyr") - ("QRY" . ,search) - ("defaultOp" . "AND") - ("DBS" . "1") - ("OP" . "dnquery.xp") - ("LNG" . "ALL") - ("maxhits" . "100") - ("threaded" . "0") - ("format" . "verbose2") - ("showsort" . "date") - ("agesign" . "1") - ("ageweight" . "1"))))) - t) - -(defun nnweb-dejanewsold-search (search) - (nnweb-fetch-form - (nnweb-definition 'address) - `(("query" . ,search) - ("defaultOp" . "AND") - ("svcclass" . "dnold") - ("maxhits" . "100") - ("format" . "verbose2") - ("threaded" . "0") - ("showsort" . "date") - ("agesign" . "1") - ("ageweight" . "1"))) - t) - -(defun nnweb-dejanews-identity (url) - "Return an unique identifier based on URL." - (if (string-match "AN=\\([0-9]+\\)" url) - (match-string 1 url) - url)) - -;;; -;;; InReference -;;; - -(defun nnweb-reference-create-mapping () - "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) - (erase-buffer) - (when (funcall (nnweb-definition 'search) nnweb-search) - (let ((i 0) - (more t) - (case-fold-search t) - (active (or (cadr (assoc nnweb-group nnweb-group-alist)) - (cons 1 0))) - Subject Score Date Newsgroups From Message-ID - map url) - (while more - ;; Go through all the article hits on this page. - (goto-char (point-min)) - (search-forward "</pre><hr>" nil t) - (delete-region (point-min) (point)) - (goto-char (point-min)) - (while (re-search-forward "^ +[0-9]+\\." nil t) - (narrow-to-region - (point) - (if (re-search-forward "^$" nil t) - (match-beginning 0) - (point-max))) - (goto-char (point-min)) - (when (looking-at ".*href=\"\\([^\"]+\\)\"") - (setq url (match-string 1))) - (nnweb-remove-markup) - (goto-char (point-min)) - (while (search-forward "\t" nil t) - (replace-match " ")) - (goto-char (point-min)) - (while (re-search-forward "^\\([^:]+\\): \\(.*\\)$" nil t) - (set (intern (match-string 1)) (match-string 2))) - (widen) - (search-forward "</pre>" nil t) - (incf i) - (unless (nnweb-get-hashtb url) - (push - (list - (incf (cdr active)) - (make-full-mail-header - (cdr active) (concat "(" Newsgroups ") " Subject) From Date - Message-ID - nil 0 (string-to-int Score) url)) - map) - (nnweb-set-hashtb (cadar map) (car map)))) - (setq more nil)) - ;; Return the articles in the right order. - (setq nnweb-articles - (sort (nconc nnweb-articles map) 'car-less-than-car)))))) - -(defun nnweb-reference-wash-article () - (let ((case-fold-search t)) - (goto-char (point-min)) - (re-search-forward "^</center><hr>" nil t) - (delete-region (point-min) (point)) - (search-forward "<pre>" nil t) - (forward-line -1) - (let ((body (point-marker))) - (search-forward "</pre>" nil t) - (delete-region (point) (point-max)) - (nnweb-remove-markup) - (goto-char (point-min)) - (while (looking-at " *$") - (gnus-delete-line)) - (narrow-to-region (point-min) body) - (while (and (re-search-forward "^$" nil t) - (not (eobp))) - (gnus-delete-line)) - (goto-char (point-min)) - (while (looking-at "\\(^[^ ]+:\\) *") - (replace-match "\\1 " t) - (forward-line 1)) - (goto-char (point-min)) - (when (re-search-forward "^References:" nil t) - (narrow-to-region - (point) (if (re-search-forward "^$\\|^[^:]+:" nil t) - (match-beginning 0) - (point-max))) - (goto-char (point-min)) - (while (not (eobp)) - (unless (looking-at "References") - (insert "\t") - (forward-line 1))) - (goto-char (point-min)) - (while (search-forward "," nil t) - (replace-match " " t t))) - (widen) - (nnweb-decode-entities) - (set-marker body nil)))) - -(defun nnweb-reference-search (search) - (url-insert-file-contents - (concat - (nnweb-definition 'address) - "?" - (nnweb-encode-www-form-urlencoded - `(("search" . "advanced") - ("querytext" . ,search) - ("subj" . "") - ("name" . "") - ("login" . "") - ("host" . "") - ("organization" . "") - ("groups" . "") - ("keywords" . "") - ("choice" . "Search") - ("startmonth" . "Jul") - ("startday" . "25") - ("startyear" . "1996") - ("endmonth" . "Aug") - ("endday" . "24") - ("endyear" . "1996") - ("mode" . "Quick") - ("verbosity" . "Verbose") - ("ranking" . "Relevance") - ("first" . "1") - ("last" . "25") - ("score" . "50"))))) - (setq buffer-file-name nil) - t) - -;;; -;;; Alta Vista -;;; - -(defun nnweb-altavista-create-mapping () - "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) - (erase-buffer) - (let ((part 0)) - (when (funcall (nnweb-definition 'search) nnweb-search part) - (let ((i 0) - (more t) - (case-fold-search t) - (active (or (cadr (assoc nnweb-group nnweb-group-alist)) - (cons 1 0))) - subject date from id group - map url) - (while more - ;; Go through all the article hits on this page. - (goto-char (point-min)) - (search-forward "<dt>" nil t) - (delete-region (point-min) (match-beginning 0)) - (goto-char (point-min)) - (while (search-forward "<dt>" nil t) - (replace-match "\n<blubb>")) - (nnweb-decode-entities) - (goto-char (point-min)) - (while (re-search-forward "<blubb>.*href=\"\\([^\"]+\\)\"><strong>\\([^>]*\\)</strong></a><dd>\\([^-]+\\)- <b>\\([^<]+\\)<.*href=\"news:\\([^\"]+\\)\">.*\">\\(.+\\)</a><P>" - nil t) - (setq url (match-string 1) - subject (match-string 2) - date (match-string 3) - group (match-string 4) - id (concat "<" (match-string 5) ">") - from (match-string 6)) - (incf i) - (unless (nnweb-get-hashtb url) - (push - (list - (incf (cdr active)) - (make-full-mail-header - (cdr active) (concat "(" group ") " subject) from date - id nil 0 0 url)) - map) - (nnweb-set-hashtb (cadar map) (car map)))) - ;; See if we want more. - (when (or (not nnweb-articles) - (>= i nnweb-max-hits) - (not (funcall (nnweb-definition 'search) - nnweb-search (incf part)))) - (setq more nil))) - ;; Return the articles in the right order. - (setq nnweb-articles - (sort (nconc nnweb-articles map) 'car-less-than-car))))))) - -(defun nnweb-altavista-wash-article () - (goto-char (point-min)) - (let ((case-fold-search t)) - (when (re-search-forward "^<strong>" nil t) - (delete-region (point-min) (match-beginning 0))) - (goto-char (point-min)) - (while (looking-at "<strong>\\([^ ]+\\) +</strong> +\\(.*\\)$") - (replace-match "\\1: \\2" t) - (forward-line 1)) - (when (re-search-backward "^References:" nil t) - (narrow-to-region (point) (progn (forward-line 1) (point))) - (goto-char (point-min)) - (while (re-search-forward "<A.*\\?id@\\([^\"]+\\)\">[0-9]+</A>" nil t) - (replace-match "<\\1> " t))) - (widen) - (nnweb-remove-markup) - (nnweb-decode-entities))) - -(defun nnweb-altavista-search (search &optional part) - (url-insert-file-contents - (concat - (nnweb-definition 'address) - "?" - (nnweb-encode-www-form-urlencoded - `(("pg" . "aq") - ("what" . "news") - ,@(when part `(("stq" . ,(int-to-string (* part 30))))) - ("fmt" . "d") - ("q" . ,search) - ("r" . "") - ("d0" . "") - ("d1" . ""))))) - (setq buffer-file-name nil) - t) - ;;; ;;; Deja bought by google.com ;;; @@ -731,7 +320,7 @@ (goto-char (point-min)) (while (search-forward "<br>" nil t) (replace-match "\n")) - (nnweb-remove-markup) + (mm-url-remove-markup) (goto-char (point-min)) (while (re-search-forward "^[ \t]*\n" nil t) (replace-match "")) @@ -741,7 +330,7 @@ (narrow-to-region (point) (point-max)) (search-forward "</pre>" nil t) (delete-region (point) (point-max)) - (nnweb-remove-markup) + (mm-url-remove-markup) (widen))) (defun nnweb-google-parse-1 (&optional Message-ID) @@ -763,28 +352,30 @@ "http://groups.google.com/groups?selm=%s&output=gplain" mid)) (narrow-to-region (search-forward ">" nil t) (search-forward "</a>" nil t)) - (nnweb-remove-markup) - (nnweb-decode-entities) + (mm-url-remove-markup) + (mm-url-decode-entities) (setq Subject (buffer-string)) (goto-char (point-max)) (widen) - (forward-line 1) + (forward-line 2) (when (looking-at "<br><font[^>]+>") (goto-char (match-end 0))) (if (not (looking-at "<a[^>]+>")) (skip-chars-forward " \t") (narrow-to-region (point) (search-forward "</a>" nil t)) - (nnweb-remove-markup) - (nnweb-decode-entities) + (mm-url-remove-markup) + (mm-url-decode-entities) (setq Newsgroups (buffer-string)) (goto-char (point-max)) (widen) (skip-chars-forward "- \t")) (when (looking-at - "\\([0-9]+[/ ][A-Za-z]+[/ ][0-9]+\\)[ \t]*by[ \t]*\\([^<]*\\) - <a") - (setq From (match-string 2) - Date (match-string 1))) + "\\([0-9]+\\)[/ ]\\([A-Za-z]+\\)[/ ]\\([0-9]+\\)[ \t]*by[ \t]*\\([^<]*\\) - <a") + (setq From (match-string 4) + Date (format "%s %s 00:00:00 %s" + (match-string 2) (match-string 1) + (match-string 3)))) (forward-line 1) (incf i) (unless (nnweb-get-hashtb url) @@ -807,7 +398,7 @@ (nconc nnweb-articles map)) (when (setq header (cadar map)) (mm-with-unibyte-current-buffer - (nnweb-fetch-url (mail-header-xref header))) + (mm-url-insert (mail-header-xref header))) (caar map)))) (defun nnweb-google-create-mapping () @@ -816,22 +407,33 @@ (set-buffer nnweb-buffer) (erase-buffer) (when (funcall (nnweb-definition 'search) nnweb-search) - (let ((more t)) + (let ((more t) + (i 0)) (while more (setq nnweb-articles (nconc nnweb-articles (nnweb-google-parse-1))) - ;; FIXME: There is more. - (setq more nil)) + ;; Check if there are more articles to fetch + (goto-char (point-min)) + (incf i 100) + (if (or (not (re-search-forward + "<td nowrap><a href=\\([^>]+\\).*<span class=b>Next</span>" nil t)) + (>= i nnweb-max-hits)) + (setq more nil) + ;; Yup, there are more articles + (setq more (concat "http://groups.google.com" (match-string 1))) + (when more + (erase-buffer) + (mm-url-insert more)))) ;; Return the articles in the right order. (setq nnweb-articles (sort nnweb-articles 'car-less-than-car)))))) (defun nnweb-google-search (search) - (nnweb-insert + (mm-url-insert (concat (nnweb-definition 'address) "?" - (nnweb-encode-www-form-urlencoded + (mm-url-encode-www-form-urlencoded `(("q" . ,search) ("num". "100") ("hq" . "") @@ -848,6 +450,71 @@ url)) ;;; +;;; gmane.org +;;; +(defun nnweb-gmane-create-mapping () + "Perform the search and create a number-to-url alist." + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (when (funcall (nnweb-definition 'search) nnweb-search) + (let ((more t) + (case-fold-search t) + (active (or (cadr (assoc nnweb-group nnweb-group-alist)) + (cons 1 0))) + subject group url + map) + ;; Remove stuff from the beginning of results + (goto-char (point-min)) + (search-forward "Search Results</h1><ul>" nil t) + (delete-region (point-min) (point)) + (goto-char (point-min)) + ;; Iterate over the actual hits + (while (re-search-forward ".*href=\"\\([^\"]+\\)\">\\(.*\\)" nil t) + (setq url (concat "http://gmane.org/" (match-string 1))) + (setq subject (match-string 2)) + (unless (nnweb-get-hashtb url) + (push + (list + (incf (cdr active)) + (make-full-mail-header + (cdr active) (concat "(" group ") " subject) nil nil + nil nil 0 0 url)) + map) + (nnweb-set-hashtb (cadar map) (car map)))) + ;; Return the articles in the right order. + (setq nnweb-articles + (sort (nconc nnweb-articles map) 'car-less-than-car)))))) + +(defun nnweb-gmane-wash-article () + (let ((case-fold-search t)) + (goto-char (point-min)) + (re-search-forward "<!--X-Head-of-Message-->" nil t) + (delete-region (point-min) (point)) + (goto-char (point-min)) + (while (looking-at "^<li><em>\\([^ ]+\\)</em>.*</li>") + (replace-match "\\1\\2" t) + (forward-line 1)) + (mm-url-remove-markup))) + +(defun nnweb-gmane-search (search) + (mm-url-insert + (concat + (nnweb-definition 'address) + "?" + (mm-url-encode-www-form-urlencoded + `(("query" . ,search))))) + (setq buffer-file-name nil) + t) + + +(defun nnweb-gmane-identity (url) + "Return a unique identifier based on URL." + (if (string-match "group=\\(.+\\)" url) + (match-string 1 url) + url)) + +;;; ;;; General web/w3 interface utility functions ;;; @@ -869,75 +536,6 @@ (mapcar 'nnweb-insert-html (nth 2 parse)) (insert "</" (symbol-name (car parse)) ">\n"))) -(defun nnweb-encode-www-form-urlencoded (pairs) - "Return PAIRS encoded for forms." - (mapconcat - (function - (lambda (data) - (concat (w3-form-encode-xwfu (car data)) "=" - (w3-form-encode-xwfu (cdr data))))) - pairs "&")) - -(defun nnweb-fetch-form (url pairs) - "Fetch a form from URL with PAIRS as the data using the POST method." - (let ((url-request-data (nnweb-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 nnweb-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)) - w3-html-entities)) - ?#)))) - (unless (stringp elem) - (setq elem (char-to-string elem))) - (replace-match elem t t)))) - -(defun nnweb-decode-entities-string (string) - (with-temp-buffer - (insert string) - (nnweb-decode-entities) - (buffer-substring (point-min) (point-max)))) - -(defun nnweb-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))) - -(defun nnweb-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 ((name buffer-file-name)) - (if follow-refresh - (save-restriction - (narrow-to-region (point) (point)) - (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)) - (nnweb-insert url t)))) - (url-insert-file-contents url)) - (setq buffer-file-name name))) - (defun nnweb-parse-find (type parse &optional maxdepth) "Find the element of TYPE in PARSE." (catch 'found @@ -987,11 +585,6 @@ (listp (cdr element))) (nnweb-text-1 element))))) -(defun nnweb-replace-in-string (string match newtext) - (while (string-match match string) - (setq string (replace-match newtext t t string))) - string) - (provide 'nnweb) ;;; arch-tag: f59307eb-c90f-479f-b7d2-dbd8bf51b697
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nnwfm.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,432 @@ +;;; nnwfm.el --- interfacing with a web forum +;; Copyright (C) 2000 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: + +;; Note: You need to have `url' and `w3' installed for this +;; backend to work. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'nnoo) +(require 'message) +(require 'gnus-util) +(require 'gnus) +(require 'nnmail) +(require 'mm-util) +(require 'mm-url) +(require 'nnweb) +(autoload 'w3-parse-buffer "w3-parse") + +(nnoo-declare nnwfm) + +(defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/") + "Where nnwfm will save its files.") + +(defvoo nnwfm-address "" + "The address of the Ultimate bulletin board.") + +;;; Internal variables + +(defvar nnwfm-groups-alist nil) +(defvoo nnwfm-groups nil) +(defvoo nnwfm-headers nil) +(defvoo nnwfm-articles nil) +(defvar nnwfm-table-regexp + "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") + +;;; Interface functions + +(nnoo-define-basics nnwfm) + +(deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old) + (nnwfm-possibly-change-server group server) + (unless gnus-nov-is-evil + (let* ((last (car (last articles))) + (did nil) + (start 1) + (entry (assoc group nnwfm-groups)) + (sid (nth 2 entry)) + (topics (nth 4 entry)) + (mapping (nth 5 entry)) + (old-total (or (nth 6 entry) 1)) + (nnwfm-table-regexp "Thread.asp") + headers article subject score from date lines parent point + contents tinfo fetchers map elem a href garticles topic old-max + inc datel table string current-page total-contents pages + farticles forum-contents parse furl-fetched mmap farticle + thread-id tables hstuff bstuff time) + (setq map mapping) + (while (and (setq article (car articles)) + map) + (while (and map + (or (> article (caar map)) + (< (cadar map) (caar map)))) + (pop map)) + (when (setq mmap (car map)) + (setq farticle -1) + (while (and article + (<= article (nth 1 mmap))) + ;; Do we already have a fetcher for this topic? + (if (setq elem (assq (nth 2 mmap) fetchers)) + ;; Yes, so we just add the spec to the end. + (nconc elem (list (cons article + (+ (nth 3 mmap) (incf farticle))))) + ;; No, so we add a new one. + (push (list (nth 2 mmap) + (cons article + (+ (nth 3 mmap) (incf farticle)))) + fetchers)) + (pop articles) + (setq article (car articles))))) + ;; Now we have the mapping from/to Gnus/nnwfm article numbers, + ;; so we start fetching the topics that we need to satisfy the + ;; request. + (if (not fetchers) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer)) + (setq nnwfm-articles nil) + (mm-with-unibyte-buffer + (dolist (elem fetchers) + (erase-buffer) + (setq subject (nth 2 (assq (car elem) topics)) + thread-id (nth 0 (assq (car elem) topics))) + (mm-url-insert + (concat nnwfm-address + (format "Item.asp?GroupID=%d&ThreadID=%d" sid + thread-id))) + (goto-char (point-min)) + (setq tables (caddar + (caddar + (cdr (caddar + (caddar + (ignore-errors + (w3-parse-buffer (current-buffer))))))))) + (setq tables (cdr (caddar (memq (assq 'div tables) tables)))) + (setq contents nil) + (dolist (table tables) + (when (eq (car table) 'table) + (setq table (caddar (caddar (caddr table))) + hstuff (delete ":link" (nnweb-text (car table))) + bstuff (car (caddar (cdr table))) + from (car hstuff)) + (when (nth 2 hstuff) + (setq time (nnwfm-date-to-time (nth 2 hstuff))) + (push (list from time bstuff) contents)))) + (setq contents (nreverse contents)) + (dolist (art (cdr elem)) + (push (list (car art) + (nth (1- (cdr art)) contents) + subject) + nnwfm-articles)))) + (setq nnwfm-articles + (sort nnwfm-articles 'car-less-than-car)) + ;; Now we have all the articles, conveniently in an alist + ;; where the key is the Gnus article number. + (dolist (articlef nnwfm-articles) + (setq article (nth 0 articlef) + contents (nth 1 articlef) + subject (nth 2 articlef)) + (setq from (nth 0 contents) + date (message-make-date (nth 1 contents))) + (push + (cons + article + (make-full-mail-header + article subject + from (or date "") + (concat "<" (number-to-string sid) "%" + (number-to-string article) + "@wfm>") + "" 0 + (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) "")) + 70) + nil nil)) + headers)) + (setq nnwfm-headers (sort headers 'car-less-than-car)) + (save-excursion + (set-buffer nntp-server-buffer) + (mm-with-unibyte-current-buffer + (erase-buffer) + (dolist (header nnwfm-headers) + (nnheader-insert-nov (cdr header)))))) + 'nov))) + +(deffoo nnwfm-request-group (group &optional server dont-check) + (nnwfm-possibly-change-server nil server) + (when (not nnwfm-groups) + (nnwfm-request-list)) + (unless dont-check + (nnwfm-create-mapping group)) + (let ((elem (assoc group nnwfm-groups))) + (cond + ((not elem) + (nnheader-report 'nnwfm "Group does not exist")) + (t + (nnheader-report 'nnwfm "Opened group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) + (prin1-to-string group)))))) + +(deffoo nnwfm-request-close () + (setq nnwfm-groups-alist nil + nnwfm-groups nil)) + +(deffoo nnwfm-request-article (article &optional group server buffer) + (nnwfm-possibly-change-server group server) + (let ((contents (cdr (assq article nnwfm-articles)))) + (when (setq contents (nth 2 (car contents))) + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (erase-buffer) + (nnweb-insert-html contents) + (goto-char (point-min)) + (insert "Content-Type: text/html\nMIME-Version: 1.0\n") + (let ((header (cdr (assq article nnwfm-headers)))) + (mm-with-unibyte-current-buffer + (nnheader-insert-header header))) + (nnheader-report 'nnwfm "Fetched article %s" article) + (cons group article))))) + +(deffoo nnwfm-request-list (&optional server) + (nnwfm-possibly-change-server nil server) + (mm-with-unibyte-buffer + (mm-url-insert + (if (string-match "/$" nnwfm-address) + (concat nnwfm-address "Group.asp") + nnwfm-address)) + (let* ((nnwfm-table-regexp "Thread.asp") + (contents (w3-parse-buffer (current-buffer))) + sid elem description articles a href group forum + a1 a2) + (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table + contents)))))) + (setq row (nth 2 row)) + (when (setq a (nnweb-parse-find 'a row)) + (setq group (car (last (nnweb-text a))) + href (cdr (assq 'href (nth 1 a)))) + (setq description (car (last (nnweb-text (nth 1 row))))) + (setq articles + (string-to-number + (gnus-replace-in-string + (car (last (nnweb-text (nth 3 row)))) "," ""))) + (when (and href + (string-match "GroupId=\\([0-9]+\\)" href)) + (setq forum (string-to-number (match-string 1 href))) + (if (setq elem (assoc group nnwfm-groups)) + (setcar (cdr elem) articles) + (push (list group articles forum description nil nil nil nil) + nnwfm-groups)))))) + (nnwfm-write-groups) + (nnwfm-generate-active) + t)) + +(deffoo nnwfm-request-newgroups (date &optional server) + (nnwfm-possibly-change-server nil server) + (nnwfm-generate-active) + t) + +(nnoo-define-skeleton nnwfm) + +;;; Internal functions + +(defun nnwfm-new-threads-p (group time) + "See whether we want to fetch the threads for GROUP written before TIME." + (let ((old-time (nth 7 (assoc group nnwfm-groups)))) + (or (null old-time) + (time-less-p old-time time)))) + +(defun nnwfm-create-mapping (group) + (let* ((entry (assoc group nnwfm-groups)) + (sid (nth 2 entry)) + (topics (nth 4 entry)) + (mapping (nth 5 entry)) + (old-total (or (nth 6 entry) 1)) + (current-time (current-time)) + (nnwfm-table-regexp "Thread.asp") + (furls (list (concat nnwfm-address + (format "Thread.asp?GroupId=%d" sid)))) + fetched-urls + contents forum-contents a subject href + garticles topic tinfo old-max inc parse elem date + url time) + (mm-with-unibyte-buffer + (while furls + (erase-buffer) + (push (car furls) fetched-urls) + (mm-url-insert (pop furls)) + (goto-char (point-min)) + (while (re-search-forward " wr(" nil t) + (forward-char -1) + (setq elem (message-tokenize-header + (gnus-replace-in-string + (buffer-substring + (1+ (point)) + (progn + (forward-sexp 1) + (1- (point)))) + "\\\\[\"\\\\]" ""))) + (push (list + (string-to-number (nth 1 elem)) + (gnus-replace-in-string (nth 2 elem) "\"" "") + (string-to-number (nth 5 elem))) + forum-contents)) + (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)" + nil t) + (setq url (match-string 1) + time (nnwfm-date-to-time (gnus-url-unhex-string + (match-string 2)))) + (when (and (nnwfm-new-threads-p group time) + (not (member + (setq url (concat + nnwfm-address + (mm-url-decode-entities-string url))) + fetched-urls))) + (push url furls)))) + ;; The main idea here is to map Gnus article numbers to + ;; nnwfm article numbers. Say there are three topics in + ;; this forum, the first with 4 articles, the seconds with 2, + ;; and the third with 1. Then this will translate into 7 Gnus + ;; article numbers, where 1-4 comes from the first topic, 5-6 + ;; from the second and 7 from the third. Now, then next time + ;; the group is entered, there's 2 new articles in topic one + ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 + ;; in topic one and 10 will be the 2 in topic three. + (dolist (elem (nreverse forum-contents)) + (setq subject (nth 1 elem) + topic (nth 0 elem) + garticles (nth 2 elem)) + (if (setq tinfo (assq topic topics)) + (progn + (setq old-max (cadr tinfo)) + (setcar (cdr tinfo) garticles)) + (setq old-max 0) + (push (list topic garticles subject) topics) + (setcar (nthcdr 4 entry) topics)) + (when (not (= old-max garticles)) + (setq inc (- garticles old-max)) + (setq mapping (nconc mapping + (list + (list + old-total (1- (incf old-total inc)) + topic (1+ old-max))))) + (incf old-max inc) + (setcar (nthcdr 5 entry) mapping) + (setcar (nthcdr 6 entry) old-total)))) + (setcar (nthcdr 7 entry) current-time) + (setcar (nthcdr 1 entry) (1- old-total)) + (nnwfm-write-groups) + mapping)) + +(defun nnwfm-possibly-change-server (&optional group server) + (nnwfm-init server) + (when (and server + (not (nnwfm-server-opened server))) + (nnwfm-open-server server)) + (unless nnwfm-groups-alist + (nnwfm-read-groups) + (setq nnwfm-groups (cdr (assoc nnwfm-address + nnwfm-groups-alist))))) + +(deffoo nnwfm-open-server (server &optional defs connectionless) + (nnheader-init-server-buffer) + (if (nnwfm-server-opened server) + t + (unless (assq 'nnwfm-address defs) + (setq defs (append defs (list (list 'nnwfm-address server))))) + (nnoo-change-server 'nnwfm server defs))) + +(defun nnwfm-read-groups () + (setq nnwfm-groups-alist nil) + (let ((file (expand-file-name "groups" nnwfm-directory))) + (when (file-exists-p file) + (mm-with-unibyte-buffer + (insert-file-contents file) + (goto-char (point-min)) + (setq nnwfm-groups-alist (read (current-buffer))))))) + +(defun nnwfm-write-groups () + (setq nnwfm-groups-alist + (delq (assoc nnwfm-address nnwfm-groups-alist) + nnwfm-groups-alist)) + (push (cons nnwfm-address nnwfm-groups) + nnwfm-groups-alist) + (with-temp-file (expand-file-name "groups" nnwfm-directory) + (prin1 nnwfm-groups-alist (current-buffer)))) + +(defun nnwfm-init (server) + "Initialize buffers and such." + (unless (file-exists-p nnwfm-directory) + (gnus-make-directory nnwfm-directory))) + +(defun nnwfm-generate-active () + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (dolist (elem nnwfm-groups) + (insert (prin1-to-string (car elem)) + " " (number-to-string (cadr elem)) " 1 y\n")))) + +(defun nnwfm-find-forum-table (contents) + (catch 'found + (nnwfm-find-forum-table-1 contents))) + +(defun nnwfm-find-forum-table-1 (contents) + (dolist (element contents) + (unless (stringp element) + (when (and (eq (car element) 'table) + (nnwfm-forum-table-p element)) + (throw 'found element)) + (when (nth 2 element) + (nnwfm-find-forum-table-1 (nth 2 element)))))) + +(defun nnwfm-forum-table-p (parse) + (when (not (apply 'gnus-or + (mapcar + (lambda (p) + (nnweb-parse-find 'table p)) + (nth 2 parse)))) + (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) + case-fold-search) + (when (and href (string-match nnwfm-table-regexp href)) + t)))) + +(defun nnwfm-date-to-time (date) + (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]")))) + (encode-time 0 (nth 4 time) (nth 3 time) + (nth 0 time) (nth 1 time) + (if (< (nth 2 time) 70) + (+ 2000 (nth 2 time)) + (+ 1900 (nth 2 time)))))) + +(provide 'nnwfm) + +;; Local Variables: +;; coding: iso-8859-1 +;; End: + +;;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536 +;;; nnwfm.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pgg-def.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,91 @@ +;;; pgg-def.el --- functions/macros for defining PGG functions + +;; Copyright (C) 1999, 2003 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP, GnuPG + +;; 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. + +;;; Code: + +(require 'custom) + +(defgroup pgg () + "Glue for the various PGP implementations." + :group 'mime) + +(defcustom pgg-default-scheme 'gpg + "Default PGP scheme." + :group 'pgg + :type '(choice (const :tag "GnuPG" gpg) + (const :tag "PGP 5" pgp5) + (const :tag "PGP" pgp))) + +(defcustom pgg-default-user-id (user-login-name) + "User ID of your default identity." + :group 'pgg + :type 'string) + +(defcustom pgg-default-keyserver-address "subkeys.pgp.net" + "Host name of keyserver." + :group 'pgg + :type 'string) + +(defcustom pgg-query-keyserver nil + "Whether PGG queries keyservers for missing keys when verifying messages." + :group 'pgg + :type 'boolean) + +(defcustom pgg-encrypt-for-me t + "If t, encrypt all outgoing messages with user's public key." + :group 'pgg + :type 'boolean) + +(defcustom pgg-cache-passphrase t + "If t, cache passphrase." + :group 'pgg + :type 'boolean) + +(defcustom pgg-passphrase-cache-expiry 16 + "How many seconds the passphrase is cached. +Whether the passphrase is cached at all is controlled by +`pgg-cache-passphrase'." + :group 'pgg + :type 'integer) + +(defvar pgg-messages-coding-system nil + "Coding system used when reading from a PGP external process.") + +(defvar pgg-status-buffer " *PGG status*") +(defvar pgg-errors-buffer " *PGG errors*") +(defvar pgg-output-buffer " *PGG output*") + +(defvar pgg-echo-buffer "*PGG-echo*") + +(defvar pgg-scheme nil + "Current scheme of PGP implementation.") + +(defmacro pgg-truncate-key-identifier (key) + `(if (> (length ,key) 8) (substring ,key 8) ,key)) + +(provide 'pgg-def) + +;;; arch-tag: c425f3ab-ed75-4055-bb46-431a418c94b7 +;;; pgg-def.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pgg-gpg.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,280 @@ +;;; pgg-gpg.el --- GnuPG support for PGG. + +;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; 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. + +;;; Code: + +(eval-when-compile + (require 'cl) ; for gpg macros + (require 'pgg)) + +(defgroup pgg-gpg () + "GnuPG interface" + :group 'pgg) + +(defcustom pgg-gpg-program "gpg" + "The GnuPG executable." + :group 'pgg-gpg + :type 'string) + +(defcustom pgg-gpg-extra-args nil + "Extra arguments for every GnuPG invocation." + :group 'pgg-gpg + :type '(repeat (string :tag "Argument"))) + +(defcustom pgg-gpg-recipient-argument "--recipient" + "GnuPG option to specify recipient." + :group 'pgg-gpg + :type '(choice (const :tag "New `--recipient' option" "--recipient") + (const :tag "Old `--remote-user' option" "--remote-user"))) + +(defvar pgg-gpg-user-id nil + "GnuPG ID of your default identity.") + +(defun pgg-gpg-process-region (start end passphrase program args) + (let* ((output-file-name (pgg-make-temp-file "pgg-output")) + (args + `("--status-fd" "2" + ,@(if passphrase '("--passphrase-fd" "0")) + "--yes" ; overwrite + "--output" ,output-file-name + ,@pgg-gpg-extra-args ,@args)) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (orig-mode (default-file-modes)) + (process-connection-type nil) + exit-status) + (with-current-buffer (get-buffer-create errors-buffer) + (buffer-disable-undo) + (erase-buffer)) + (unwind-protect + (progn + (set-default-file-modes 448) + (let ((coding-system-for-write 'binary) + (input (buffer-substring-no-properties start end)) + (default-enable-multibyte-characters nil)) + (with-temp-buffer + (when passphrase + (insert passphrase "\n")) + (insert input) + (setq exit-status + (apply #'call-process-region (point-min) (point-max) program + nil errors-buffer nil args)))) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer) + (if (file-exists-p output-file-name) + (let ((coding-system-for-read 'raw-text-dos)) + (insert-file-contents output-file-name))) + (set-buffer errors-buffer) + (if (not (equal exit-status 0)) + (insert (format "\n%s exited abnormally: '%s'\n" + program exit-status))))) + (if (file-exists-p output-file-name) + (delete-file output-file-name)) + (set-default-file-modes orig-mode)))) + +(defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key) + (if (and pgg-cache-passphrase + (progn + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] GOOD_PASSPHRASE\\>" nil t))) + (pgg-add-passphrase-cache + (or key + (progn + (goto-char (point-min)) + (if (re-search-forward + "^\\[GNUPG:] NEED_PASSPHRASE \\w+ ?\\w*" nil t) + (substring (match-string 0) -8)))) + passphrase))) + +(defvar pgg-gpg-all-secret-keys 'unknown) + +(defun pgg-gpg-lookup-all-secret-keys () + "Return all secret keys present in secret key ring." + (when (eq pgg-gpg-all-secret-keys 'unknown) + (setq pgg-gpg-all-secret-keys '()) + (let ((args (list "--with-colons" "--no-greeting" "--batch" + "--list-secret-keys"))) + (with-temp-buffer + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (while (re-search-forward "^\\(sec\\|pub\\):" nil t) + (push (substring + (nth 3 (split-string + (buffer-substring (match-end 0) + (progn (end-of-line) (point))) + ":")) 8) + pgg-gpg-all-secret-keys))))) + pgg-gpg-all-secret-keys) + +(defun pgg-gpg-lookup-key (string &optional type) + "Search keys associated with STRING." + (let ((args (list "--with-colons" "--no-greeting" "--batch" + (if type "--list-secret-keys" "--list-keys") + string))) + (with-temp-buffer + (apply #'call-process pgg-gpg-program nil t nil args) + (goto-char (point-min)) + (if (re-search-forward "^\\(sec\\|pub\\):" nil t) + (substring + (nth 3 (split-string + (buffer-substring (match-end 0) + (progn (end-of-line)(point))) + ":")) 8))))) + +(defun pgg-gpg-encrypt-region (start end recipients &optional sign) + "Encrypt the current region between START and END. +If optional argument SIGN is non-nil, do a combined sign and encrypt." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (when sign + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + pgg-gpg-user-id))) + (args + (append + (list "--batch" "--armor" "--always-trust" "--encrypt") + (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) + (if recipients + (apply #'nconc + (mapcar (lambda (rcpt) + (list pgg-gpg-recipient-argument rcpt)) + (append recipients + (if pgg-encrypt-for-me + (list pgg-gpg-user-id))))))))) + (pgg-as-lbt start end 'CRLF + (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) + (when sign + (with-current-buffer pgg-errors-buffer + ;; Possibly cache passphrase under, e.g. "jas", for future sign. + (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) + ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. + (pgg-gpg-possibly-cache-passphrase passphrase))) + (pgg-process-when-success))) + +(defun pgg-gpg-decrypt-region (start end) + "Decrypt the current region between START and END." + (let* ((current-buffer (current-buffer)) + (message-keys (with-temp-buffer + (insert-buffer-substring current-buffer) + (pgg-decode-armor-region (point-min) (point-max)))) + (secret-keys (pgg-gpg-lookup-all-secret-keys)) + (key (pgg-gpg-select-matching-key message-keys secret-keys)) + (pgg-gpg-user-id (or key pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + pgg-gpg-user-id)) + (args '("--batch" "--decrypt"))) + (pgg-gpg-process-region start end passphrase pgg-gpg-program args) + (with-current-buffer pgg-errors-buffer + (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) + +(defun pgg-gpg-select-matching-key (message-keys secret-keys) + "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." + (loop for message-key in message-keys + for message-key-id = (and (equal (car message-key) 1) + (cdr (assq 'key-identifier message-key))) + for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt)) + when (and key (member key secret-keys)) return key)) + +(defun pgg-gpg-sign-region (start end &optional cleartext) + "Make detached signature from text between START and END." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "GnuPG passphrase for %s: " pgg-gpg-user-id) + pgg-gpg-user-id)) + (args + (list (if cleartext "--clearsign" "--detach-sign") + "--armor" "--batch" "--verbose" + "--local-user" pgg-gpg-user-id)) + (inhibit-read-only t) + buffer-read-only) + (pgg-as-lbt start end 'CRLF + (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) + (with-current-buffer pgg-errors-buffer + ;; Possibly cache passphrase under, e.g. "jas", for future sign. + (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) + ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. + (pgg-gpg-possibly-cache-passphrase passphrase)) + (pgg-process-when-success))) + +(defun pgg-gpg-verify-region (start end &optional signature) + "Verify region between START and END as the detached signature SIGNATURE." + (let ((args '("--batch" "--verify"))) + (when (stringp signature) + (setq args (append args (list signature)))) + (setq args (append args '("-"))) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (with-current-buffer pgg-errors-buffer + (goto-char (point-min)) + (while (re-search-forward "^gpg: \\(.*\\)\n" nil t) + (with-current-buffer pgg-output-buffer + (insert-buffer-substring pgg-errors-buffer + (match-beginning 1) (match-end 0))) + (delete-region (match-beginning 0) (match-end 0))) + (goto-char (point-min)) + (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)))) + +(defun pgg-gpg-insert-key () + "Insert public key at point." + (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) + (args (list "--batch" "--export" "--armor" + pgg-gpg-user-id))) + (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) + (insert-buffer-substring pgg-output-buffer))) + +(defun pgg-gpg-snarf-keys-region (start end) + "Add all public keys in region between START and END to the keyring." + (let ((args '("--import" "--batch" "-")) status) + (pgg-gpg-process-region start end nil pgg-gpg-program args) + (set-buffer pgg-errors-buffer) + (goto-char (point-min)) + (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t) + (setq status (buffer-substring (match-end 0) + (progn (end-of-line)(point))) + status (vconcat (mapcar #'string-to-int (split-string status)))) + (erase-buffer) + (insert (format "Imported %d key(s). +\tArmor contains %d key(s) [%d bad, %d old].\n" + (+ (aref status 2) + (aref status 10)) + (aref status 0) + (aref status 1) + (+ (aref status 4) + (aref status 11))) + (if (zerop (aref status 9)) + "" + "\tSecret keys are imported.\n"))) + (append-to-buffer pgg-output-buffer (point-min)(point-max)) + (pgg-process-when-success))) + +(provide 'pgg-gpg) + +;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 +;;; pgg-gpg.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pgg-parse.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,516 @@ +;;; pgg-parse.el --- OpenPGP packet parsing + +;; Copyright (C) 1999, 2003 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/10/28 +;; Keywords: PGP, OpenPGP, GnuPG + +;; 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 is based on + +;; [OpenPGP] RFC 2440: "OpenPGP Message Format" +;; by John W. Noerenberg, II <jwn2@qualcomm.com>, +;; Jon Callas <jon@pgp.com>, Lutz Donnerhacke <lutz@iks-jena.de>, +;; Hal Finney <hal@pgp.com> and Rodney Thayer <rodney@unitran.com> +;; (1998/11) + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'custom) + +(defgroup pgg-parse () + "OpenPGP packet parsing" + :group 'pgg) + +(defcustom pgg-parse-public-key-algorithm-alist + '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG)) + "Alist of the assigned number to the public key algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-symmetric-key-algorithm-alist + '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128)) + "Alist of the assigned number to the simmetric key algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-hash-algorithm-alist + '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2)) + "Alist of the assigned number to the cryptographic hash algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-compression-algorithm-alist + '((0 . nil); Uncompressed + (1 . ZIP) + (2 . ZLIB)) + "Alist of the assigned number to the compression algorithm." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-parse-signature-type-alist + '((0 . "Signature of a binary document") + (1 . "Signature of a canonical text document") + (2 . "Standalone signature") + (16 . "Generic certification of a User ID and Public Key packet") + (17 . "Persona certification of a User ID and Public Key packet") + (18 . "Casual certification of a User ID and Public Key packet") + (19 . "Positive certification of a User ID and Public Key packet") + (24 . "Subkey Binding Signature") + (31 . "Signature directly on a key") + (32 . "Key revocation signature") + (40 . "Subkey revocation signature") + (48 . "Certification revocation signature") + (64 . "Timestamp signature.")) + "Alist of the assigned number to the signature type." + :group 'pgg-parse + :type '(repeat + (cons (sexp :tag "Number") (sexp :tag "Type")))) + +(defcustom pgg-ignore-packet-checksum t; XXX + "If non-nil checksum of each ascii armored packet will be ignored." + :group 'pgg-parse + :type 'boolean) + +(defvar pgg-armor-header-lines + '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$" + "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" + "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$" + "^-----BEGIN PGP SIGNATURE-----\r?$") + "Armor headers.") + +(eval-and-compile + (defalias 'pgg-char-int (if (fboundp 'char-int) + 'char-int + 'identity))) + +(defmacro pgg-format-key-identifier (string) + `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c))) + ,string "") + ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x" + ;; (string-to-int-list ,string))) + ) + +(defmacro pgg-parse-time-field (bytes) + `(list (logior (lsh (car ,bytes) 8) + (nth 1 ,bytes)) + (logior (lsh (nth 2 ,bytes) 8) + (nth 3 ,bytes)) + 0)) + +(defmacro pgg-byte-after (&optional pos) + `(pgg-char-int (char-after ,(or pos `(point))))) + +(defmacro pgg-read-byte () + `(pgg-char-int (char-after (prog1 (point) (forward-char))))) + +(defmacro pgg-read-bytes-string (nbytes) + `(buffer-substring + (point) (prog1 (+ ,nbytes (point)) + (forward-char ,nbytes)))) + +(defmacro pgg-read-bytes (nbytes) + `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes)) + ;; `(string-to-int-list (pgg-read-bytes-string ,nbytes)) + ) + +(defmacro pgg-read-body-string (ptag) + `(if (nth 1 ,ptag) + (pgg-read-bytes-string (nth 1 ,ptag)) + (pgg-read-bytes-string (- (point-max) (point))))) + +(defmacro pgg-read-body (ptag) + `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag)) + ;; `(string-to-int-list (pgg-read-body-string ,ptag)) + ) + +(defalias 'pgg-skip-bytes 'forward-char) + +(defmacro pgg-skip-header (ptag) + `(pgg-skip-bytes (nth 2 ,ptag))) + +(defmacro pgg-skip-body (ptag) + `(pgg-skip-bytes (nth 1 ,ptag))) + +(defmacro pgg-set-alist (alist key value) + `(setq ,alist (nconc ,alist (list (cons ,key ,value))))) + +(when (fboundp 'define-ccl-program) + + (define-ccl-program pgg-parse-crc24 + '(1 + ((loop + (read r0) (r1 ^= r0) (r2 ^= 0) + (r5 = 0) + (loop + (r1 <<= 1) + (r1 += ((r2 >> 15) & 1)) + (r2 <<= 1) + (if (r1 & 256) + ((r1 ^= 390) (r2 ^= 19707))) + (if (r5 < 7) + ((r5 += 1) + (repeat)))) + (repeat))))) + + (defun pgg-parse-crc24-string (string) + (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) + (ccl-execute-on-string pgg-parse-crc24 h string) + (format "%c%c%c" + (logand (aref h 1) 255) + (logand (lsh (aref h 2) -8) 255) + (logand (aref h 2) 255))))) + +(defmacro pgg-parse-length-type (c) + `(cond + ((< ,c 192) (cons ,c 1)) + ((< ,c 224) + (cons (+ (lsh (- ,c 192) 8) + (pgg-byte-after (+ 2 (point))) + 192) + 2)) + ((= ,c 255) + (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) + (pgg-byte-after (+ 3 (point)))) + (logior (lsh (pgg-byte-after (+ 4 (point))) 8) + (pgg-byte-after (+ 5 (point))))) + 5)) + (t;partial body length + '(0 . 0)))) + +(defun pgg-parse-packet-header () + (let ((ptag (pgg-byte-after)) + length-type content-tag packet-bytes header-bytes) + (if (zerop (logand 64 ptag));Old format + (progn + (setq length-type (logand ptag 3) + length-type (if (= 3 length-type) 0 (lsh 1 length-type)) + content-tag (logand 15 (lsh ptag -2)) + packet-bytes 0 + header-bytes (1+ length-type)) + (dotimes (i length-type) + (setq packet-bytes + (logior (lsh packet-bytes 8) + (pgg-byte-after (+ 1 i (point))))))) + (setq content-tag (logand 63 ptag) + length-type (pgg-parse-length-type + (pgg-byte-after (1+ (point)))) + packet-bytes (car length-type) + header-bytes (1+ (cdr length-type)))) + (list content-tag packet-bytes header-bytes))) + +(defun pgg-parse-packet (ptag) + (case (car ptag) + (1 ;Public-Key Encrypted Session Key Packet + (pgg-parse-public-key-encrypted-session-key-packet ptag)) + (2 ;Signature Packet + (pgg-parse-signature-packet ptag)) + (3 ;Symmetric-Key Encrypted Session Key Packet + (pgg-parse-symmetric-key-encrypted-session-key-packet ptag)) + ;; 4 -- One-Pass Signature Packet + ;; 5 -- Secret Key Packet + (6 ;Public Key Packet + (pgg-parse-public-key-packet ptag)) + ;; 7 -- Secret Subkey Packet + ;; 8 -- Compressed Data Packet + (9 ;Symmetrically Encrypted Data Packet + (pgg-read-body-string ptag)) + (10 ;Marker Packet + (pgg-read-body-string ptag)) + (11 ;Literal Data Packet + (pgg-read-body-string ptag)) + ;; 12 -- Trust Packet + (13 ;User ID Packet + (pgg-read-body-string ptag)) + ;; 14 -- Public Subkey Packet + ;; 60 .. 63 -- Private or Experimental Values + )) + +(defun pgg-parse-packets (&optional header-parser body-parser) + (let ((header-parser + (or header-parser + (function pgg-parse-packet-header))) + (body-parser + (or body-parser + (function pgg-parse-packet))) + result ptag) + (while (> (point-max) (1+ (point))) + (setq ptag (funcall header-parser)) + (pgg-skip-header ptag) + (push (cons (car ptag) + (save-excursion + (funcall body-parser ptag))) + result) + (if (zerop (nth 1 ptag)) + (goto-char (point-max)) + (forward-char (nth 1 ptag)))) + result)) + +(defun pgg-parse-signature-subpacket-header () + (let ((length-type (pgg-parse-length-type (pgg-byte-after)))) + (list (pgg-byte-after (+ (cdr length-type) (point))) + (1- (car length-type)) + (1+ (cdr length-type))))) + +(defun pgg-parse-signature-subpacket (ptag) + (case (car ptag) + (2 ;signature creation time + (cons 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (3 ;signature expiration time + (cons 'signature-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + (4 ;exportable certification + (cons 'exportability (pgg-read-byte))) + (5 ;trust signature + (cons 'trust-level (pgg-read-byte))) + (6 ;regular expression + (cons 'regular-expression + (pgg-read-body-string ptag))) + (7 ;revocable + (cons 'revocability (pgg-read-byte))) + (9 ;key expiration time + (cons 'key-expiry + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes)))) + ;; 10 = placeholder for backward compatibility + (11 ;preferred symmetric algorithms + (cons 'preferred-symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist)))) + (12 ;revocation key + ) + (16 ;issuer key ID + (cons 'key-identifier + (pgg-format-key-identifier (pgg-read-body-string ptag)))) + (20 ;notation data + (pgg-skip-bytes 4) + (cons 'notation + (let ((name-bytes (pgg-read-bytes 2)) + (value-bytes (pgg-read-bytes 2))) + (cons (pgg-read-bytes-string + (logior (lsh (car name-bytes) 8) + (nth 1 name-bytes))) + (pgg-read-bytes-string + (logior (lsh (car value-bytes) 8) + (nth 1 value-bytes))))))) + (21 ;preferred hash algorithms + (cons 'preferred-hash-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-hash-algorithm-alist)))) + (22 ;preferred compression algorithms + (cons 'preferred-compression-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-compression-algorithm-alist)))) + (23 ;key server preferences + (cons 'key-server-preferences + (pgg-read-body ptag))) + (24 ;preferred key server + (cons 'preferred-key-server + (pgg-read-body-string ptag))) + ;; 25 = primary user id + (26 ;policy URL + (cons 'policy-url (pgg-read-body-string ptag))) + ;; 27 = key flags + ;; 28 = signer's user id + ;; 29 = reason for revocation + ;; 100 to 110 = internal or user-defined + )) + +(defun pgg-parse-signature-packet (ptag) + (let* ((signature-version (pgg-byte-after)) + (result (list (cons 'version signature-version))) + hashed-material field n) + (cond + ((= signature-version 3) + (pgg-skip-bytes 2) + (setq hashed-material (pgg-read-bytes 5)) + (pgg-set-alist result + 'signature-type + (cdr (assq (pop hashed-material) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'creation-time + (pgg-parse-time-field hashed-material)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte))) + ((= signature-version 4) + (pgg-skip-bytes 1) + (pgg-set-alist result + 'signature-type + (cdr (assq (pgg-read-byte) + pgg-parse-signature-type-alist))) + (pgg-set-alist result + 'public-key-algorithm + (pgg-read-byte)) + (pgg-set-alist result + 'hash-algorithm (pgg-read-byte)) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))) + (goto-char (point-max)))) + (when (>= 10000 (setq n (pgg-read-bytes 2) + n (logior (lsh (car n) 8) + (nth 1 n)))) + (save-restriction + (narrow-to-region (point)(+ n (point))) + (nconc result + (mapcar (function cdr) ;remove packet types + (pgg-parse-packets + #'pgg-parse-signature-subpacket-header + #'pgg-parse-signature-subpacket))))))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + (setcdr (setq field (assq 'hash-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-hash-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version (pgg-read-byte)) + (pgg-set-alist result + 'key-identifier + (pgg-format-key-identifier + (pgg-read-bytes-string 8))) + (pgg-set-alist result + 'public-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-public-key-algorithm-alist))) + result)) + +(defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag) + (let (result) + (pgg-set-alist result + 'version + (pgg-read-byte)) + (pgg-set-alist result + 'symmetric-key-algorithm + (cdr (assq (pgg-read-byte) + pgg-parse-symmetric-key-algorithm-alist))) + result)) + +(defun pgg-parse-public-key-packet (ptag) + (let* ((key-version (pgg-read-byte)) + (result (list (cons 'version key-version))) + field) + (cond + ((= 3 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'key-expiry (pgg-read-bytes 2)) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte))) + ((= 4 key-version) + (pgg-set-alist result + 'creation-time + (let ((bytes (pgg-read-bytes 4))) + (pgg-parse-time-field bytes))) + (pgg-set-alist result + 'public-key-algorithm (pgg-read-byte)))) + + (setcdr (setq field (assq 'public-key-algorithm + result)) + (cdr (assq (cdr field) + pgg-parse-public-key-algorithm-alist))) + result)) + +(defun pgg-decode-packets () + (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t) + (let ((p (match-beginning 0)) + (checksum (match-string 1))) + (delete-region p (point-max)) + (if (ignore-errors (base64-decode-region (point-min) p)) + (or (not (fboundp 'pgg-parse-crc24-string)) + pgg-ignore-packet-checksum + (string-equal (base64-encode-string (pgg-parse-crc24-string + (buffer-string))) + checksum) + (progn + (message "PGP packet checksum does not match") + nil)) + (message "PGP packet contain invalid base64") + nil)) + (message "PGP packet checksum not found") + nil)) + +(defun pgg-decode-armor-region (start end) + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (re-search-forward "^-+BEGIN PGP" nil t) + (delete-region (point-min) + (and (search-forward "\n\n") + (match-end 0))) + (when (pgg-decode-packets) + (goto-char (point-min)) + (pgg-parse-packets)))) + +(defun pgg-parse-armor (string) + (with-temp-buffer + (buffer-disable-undo) + (if (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte nil)) + (insert string) + (pgg-decode-armor-region (point-min)(point)))) + +(eval-and-compile + (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte) + 'string-as-unibyte + 'identity))) + +(defun pgg-parse-armor-region (start end) + (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end)))) + +(provide 'pgg-parse) + +;;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e +;;; pgg-parse.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pgg-pgp.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,240 @@ +;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG. + +;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; 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. + +;;; Code: + +(eval-when-compile + (require 'cl) ; for pgg macros + (require 'pgg)) + +(defgroup pgg-pgp () + "PGP 2.* and 6.* interface" + :group 'pgg) + +(defcustom pgg-pgp-program "pgp" + "PGP 2.* and 6.* executable." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-shell-file-name "/bin/sh" + "File name to load inferior shells from. +Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp + :type 'string) + +(defcustom pgg-pgp-extra-args nil + "Extra arguments for every PGP invocation." + :group 'pgg-pgp + :type '(choice + (const :tag "None" nil) + (string :tag "Arguments"))) + +(defvar pgg-pgp-user-id nil + "PGP ID of your default identity.") + +(defun pgg-pgp-process-region (start end passphrase program args) + (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) + (args + (append args + pgg-pgp-extra-args + (list (concat "2>" errors-file-name)))) + (shell-file-name pgg-pgp-shell-file-name) + (shell-command-switch pgg-pgp-shell-command-switch) + (process-environment process-environment) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (unwind-protect + (progn + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (setq process + (apply #'funcall + #'start-process-shell-command "*PGP*" output-buffer + program args))) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer output-buffer + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (condition-case nil + (delete-file errors-file-name) + (file-error nil))))) + +(defun pgg-pgp-lookup-key (string &optional type) + "Search keys associated with STRING." + (let ((args (list "+batchmode" "+language=en" "-kv" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp-program nil t nil args) + (goto-char (point-min)) + (cond + ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.* + (buffer-substring (point)(+ 8 (point)))) + ((re-search-forward "^Type" nil t);PGP 6.* + (beginning-of-line 2) + (substring + (nth 2 (split-string + (buffer-substring (point)(progn (end-of-line) (point))))) + 2)))))) + +(defun pgg-pgp-encrypt-region (start end recipients) + "Encrypt the current region between START and END." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + `("+encrypttoself=off +verbose=1" "+batchmode" + "+language=us" "-fate" + ,@(if recipients + (mapcar (lambda (rcpt) (concat "\"" rcpt "\"")) + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp-user-id)))))))) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (pgg-process-when-success nil))) + +(defun pgg-pgp-decrypt-region (start end) + "Decrypt the current region between START and END." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt))) + (args + '("+verbose=1" "+batchmode" "+language=us" "-f"))) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success nil))) + +(defun pgg-pgp-sign-region (start end &optional clearsign) + "Make detached signature from text between START and END." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp-user-id) + (pgg-pgp-lookup-key pgg-pgp-user-id 'sign))) + (args + (list (if clearsign "-fast" "-fbast") + "+verbose=1" "+language=us" "+batchmode" + "-u" pgg-pgp-user-id))) + (pgg-pgp-process-region start end passphrase pgg-pgp-program args) + (pgg-process-when-success + (goto-char (point-min)) + (when (re-search-forward "^-+BEGIN PGP" nil t);XXX + (let ((packet + (cdr (assq 2 (pgg-parse-armor-region + (progn (beginning-of-line 2) + (point)) + (point-max)))))) + (if pgg-cache-passphrase + (pgg-add-passphrase-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(defun pgg-pgp-verify-region (start end &optional signature) + "Verify region between START and END as the detached signature SIGNATURE." + (let* ((orig-file (pgg-make-temp-file "pgg")) + (args '("+verbose=1" "+batchmode" "+language=us")) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (let ((coding-system-for-write 'binary) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end orig-file))) + (set-default-file-modes orig-mode)) + (when (stringp signature) + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (append args (list signature orig-file)))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (pgg-process-when-success + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (re-search-forward "^warning: " nil t) + (delete-region (match-beginning 0) + (progn (beginning-of-line 2) (point))))) + (goto-char (point-min)) + (when (re-search-forward "^\\.$" nil t) + (delete-region (point-min) + (progn (beginning-of-line 2) + (point))))))) + +(defun pgg-pgp-insert-key () + "Insert public key at point." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (args + (list "+verbose=1" "+batchmode" "+language=us" "-kxaf" + (concat "\"" pgg-pgp-user-id "\"")))) + (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args) + (insert-buffer-substring pgg-output-buffer))) + +(defun pgg-pgp-snarf-keys-region (start end) + "Add all public keys in region between START and END to the keyring." + (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id)) + (key-file (pgg-make-temp-file "pgg")) + (args + (list "+verbose=1" "+batchmode" "+language=us" "-kaf" + key-file))) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region start end key-file)) + (pgg-pgp-process-region start end nil pgg-pgp-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp) + +;;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c +;;; pgg-pgp.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pgg-pgp5.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,249 @@ +;;; pgg-pgp5.el --- PGP 5.* support for PGG. + +;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/11/02 +;; Keywords: PGP, OpenPGP + +;; 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. + +;;; Code: + +(eval-when-compile + (require 'cl) ; for pgg macros + (require 'pgg)) + +(defgroup pgg-pgp5 () + "PGP 5.* interface" + :group 'pgg) + +(defcustom pgg-pgp5-pgpe-program "pgpe" + "PGP 5.* 'pgpe' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgps-program "pgps" + "PGP 5.* 'pgps' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpk-program "pgpk" + "PGP 5.* 'pgpk' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-pgpv-program "pgpv" + "PGP 5.* 'pgpv' executable." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-shell-file-name "/bin/sh" + "File name to load inferior shells from. +Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-shell-command-switch "-c" + "Switch used to have the shell execute its command line argument." + :group 'pgg-pgp5 + :type 'string) + +(defcustom pgg-pgp5-extra-args nil + "Extra arguments for every PGP 5.* invocation." + :group 'pgg-pgp5 + :type '(choice + (const :tag "None" nil) + (string :tag "Arguments"))) + +(defvar pgg-pgp5-user-id nil + "PGP 5.* ID of your default identity.") + +(defun pgg-pgp5-process-region (start end passphrase program args) + (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) + (args + (append args + pgg-pgp5-extra-args + (list (concat "2>" errors-file-name)))) + (shell-file-name pgg-pgp5-shell-file-name) + (shell-command-switch pgg-pgp5-shell-command-switch) + (process-environment process-environment) + (output-buffer pgg-output-buffer) + (errors-buffer pgg-errors-buffer) + (process-connection-type nil) + process status exit-status) + (with-current-buffer (get-buffer-create output-buffer) + (buffer-disable-undo) + (erase-buffer)) + (when passphrase + (setenv "PGPPASSFD" "0")) + (unwind-protect + (progn + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (setq process + (apply #'funcall + #'start-process-shell-command "*PGP*" output-buffer + program args))) + (set-process-sentinel process #'ignore) + (when passphrase + (process-send-string process (concat passphrase "\n"))) + (process-send-region process start end) + (process-send-eof process) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (setq status (process-status process) + exit-status (process-exit-status process)) + (delete-process process) + (with-current-buffer output-buffer + (pgg-convert-lbt-region (point-min)(point-max) 'LF) + + (if (memq status '(stop signal)) + (error "%s exited abnormally: '%s'" program exit-status)) + (if (= 127 exit-status) + (error "%s could not be found" program)) + + (set-buffer (get-buffer-create errors-buffer)) + (buffer-disable-undo) + (erase-buffer) + (insert-file-contents errors-file-name))) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (condition-case nil + (delete-file errors-file-name) + (file-error nil))))) + +(defun pgg-pgp5-lookup-key (string &optional type) + "Search keys associated with STRING." + (let ((args (list "+language=en" "-l" string))) + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (apply #'call-process pgg-pgp5-pgpk-program nil t nil args) + (goto-char (point-min)) + (when (re-search-forward "^sec" nil t) + (substring + (nth 2 (split-string + (buffer-substring (match-end 0)(progn (end-of-line)(point))))) + 2))))) + +(defun pgg-pgp5-encrypt-region (start end recipients) + "Encrypt the current region between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" + ,@(if recipients + (apply #'append + (mapcar (lambda (rcpt) + (list "-r" + (concat "\"" rcpt "\""))) + (append recipients + (if pgg-encrypt-for-me + (list pgg-pgp5-user-id))))))))) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args) + (pgg-process-when-success nil))) + +(defun pgg-pgp5-decrypt-region (start end) + "Decrypt the current region between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-pgp5-lookup-key pgg-pgp5-user-id 'encrypt))) + (args + '("+verbose=1" "+batchmode=1" "+language=us" "-f"))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args) + (pgg-process-when-success nil))) + +(defun pgg-pgp5-sign-region (start end &optional clearsign) + "Make detached signature from text between START and END." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (passphrase + (pgg-read-passphrase + (format "PGP passphrase for %s: " pgg-pgp5-user-id) + (pgg-pgp5-lookup-key pgg-pgp5-user-id 'sign))) + (args + (list (if clearsign "-fat" "-fbat") + "+verbose=1" "+language=us" "+batchmode=1" + "-u" pgg-pgp5-user-id))) + (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args) + (pgg-process-when-success + (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX + (let ((packet + (cdr (assq 2 (pgg-parse-armor-region + (progn (beginning-of-line 2) + (point)) + (point-max)))))) + (if pgg-cache-passphrase + (pgg-add-passphrase-cache + (cdr (assq 'key-identifier packet)) + passphrase))))))) + +(defun pgg-pgp5-verify-region (start end &optional signature) + "Verify region between START and END as the detached signature SIGNATURE." + (let ((orig-file (pgg-make-temp-file "pgg")) + (args '("+verbose=1" "+batchmode=1" "+language=us")) + (orig-mode (default-file-modes))) + (unwind-protect + (progn + (set-default-file-modes 448) + (let ((coding-system-for-write 'binary) + jka-compr-compression-info-list jam-zcat-filename-list) + (write-region start end orig-file))) + (set-default-file-modes orig-mode)) + (when (stringp signature) + (copy-file signature (setq signature (concat orig-file ".asc"))) + (setq args (append args (list signature)))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args) + (delete-file orig-file) + (if signature (delete-file signature)) + (with-current-buffer pgg-errors-buffer + (goto-char (point-min)) + (if (re-search-forward "^Good signature" nil t) + (progn + (set-buffer pgg-output-buffer) + (insert-buffer-substring pgg-errors-buffer) + t) + nil)))) + +(defun pgg-pgp5-insert-key () + "Insert public key at point." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-x" + (concat "\"" pgg-pgp5-user-id "\"")))) + (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args) + (insert-buffer-substring pgg-output-buffer))) + +(defun pgg-pgp5-snarf-keys-region (start end) + "Add all public keys in region between START and END to the keyring." + (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) + (key-file (pgg-make-temp-file "pgg")) + (args + (list "+verbose=1" "+batchmode=1" "+language=us" "-a" + key-file))) + (let ((coding-system-for-write 'raw-text-dos)) + (write-region start end key-file)) + (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args) + (delete-file key-file) + (pgg-process-when-success nil))) + +(provide 'pgg-pgp5) + +;;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b +;;; pgg-pgp5.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pgg.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,468 @@ +;;; pgg.el --- glue for the various PGP implementations. + +;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Created: 1999/10/28 +;; 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: + +(require 'pgg-def) +(require 'pgg-parse) +(autoload 'run-at-time "timer") + +;; Don't merge these two `eval-when-compile's. +(eval-when-compile + (require 'cl)) +;; Fixme: This would be better done with an autoload for +;; `url-insert-file-contents', and the url stuff rationalized. +;; (`locate-library' can say whether the url code is available.) +(eval-when-compile + (ignore-errors + (require 'w3) + (require 'url))) + +;;; @ utility functions +;;; + +(defvar pgg-fetch-key-function (if (fboundp 'url-insert-file-contents) + (function pgg-fetch-key-with-w3))) + +(defun pgg-invoke (func scheme &rest args) + (progn + (require (intern (format "pgg-%s" scheme))) + (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args))) + +(put 'pgg-save-coding-system 'lisp-indent-function 2) + +(defmacro pgg-save-coding-system (start end &rest body) + `(if (interactive-p) + (let ((buffer (current-buffer))) + (with-temp-buffer + (let (buffer-undo-list) + (insert-buffer-substring buffer ,start ,end) + (encode-coding-region (point-min)(point-max) + buffer-file-coding-system) + (prog1 (save-excursion ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))))) + (save-restriction + (narrow-to-region ,start ,end) + ,@body))) + +(defun pgg-temp-buffer-show-function (buffer) + (let ((window (or (get-buffer-window buffer 'visible) + (split-window-vertically)))) + (set-window-buffer window buffer) + (shrink-window-if-larger-than-buffer window))) + +(defun pgg-display-output-buffer (start end status) + (if status + (progn + (delete-region start end) + (insert-buffer-substring pgg-output-buffer) + (decode-coding-region start (point) buffer-file-coding-system)) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring pgg-errors-buffer))))) + +(defvar pgg-passphrase-cache (make-vector 7 0)) + +(defun pgg-read-passphrase (prompt &optional key) + (or (and pgg-cache-passphrase + key (setq key (pgg-truncate-key-identifier key)) + (symbol-value (intern-soft key pgg-passphrase-cache))) + (read-passwd prompt))) + +(eval-when-compile + (defvar itimer-process) + (defvar itimer-timer) + (autoload 'delete-itimer "itimer") + (autoload 'itimer-driver-start "itimer") + (autoload 'itimer-value "itimer") + (autoload 'set-itimer-function "itimer") + (autoload 'set-itimer-function-arguments "itimer") + (autoload 'set-itimer-restart "itimer") + (autoload 'start-itimer "itimer")) + +(eval-and-compile + (defalias + 'pgg-run-at-time + (if (featurep 'xemacs) + (if (condition-case nil + (progn + (unless (or itimer-process itimer-timer) + (itimer-driver-start)) + ;; Check whether there is a bug to which the difference of + ;; the present time and the time when the itimer driver was + ;; woken up is subtracted from the initial itimer value. + (let* ((inhibit-quit t) + (ctime (current-time)) + (itimer-timer-last-wakeup + (prog1 + ctime + (setcar ctime (1- (car ctime))))) + (itimer-list nil) + (itimer (start-itimer "pgg-run-at-time" 'ignore 5))) + (sleep-for 0.1) ;; Accept the timeout interrupt. + (prog1 + (> (itimer-value itimer) 0) + (delete-itimer itimer)))) + (error nil)) + (lambda (time repeat function &rest args) + "Emulating function run as `run-at-time'. +TIME should be nil meaning now, or a number of seconds from now. +Return an itimer object which can be used in either `delete-itimer' +or `cancel-timer'." + (apply #'start-itimer "pgg-run-at-time" + function (if time (max time 1e-9) 1e-9) + repeat nil t args)) + (lambda (time repeat function &rest args) + "Emulating function run as `run-at-time' in the right way. +TIME should be nil meaning now, or a number of seconds from now. +Return an itimer object which can be used in either `delete-itimer' +or `cancel-timer'." + (let ((itimers (list nil))) + (setcar + itimers + (apply #'start-itimer "pgg-run-at-time" + (lambda (itimers repeat function &rest args) + (let ((itimer (car itimers))) + (if repeat + (progn + (set-itimer-function + itimer + (lambda (itimer repeat function &rest args) + (set-itimer-restart itimer repeat) + (set-itimer-function itimer function) + (set-itimer-function-arguments itimer args) + (apply function args))) + (set-itimer-function-arguments + itimer + (append (list itimer repeat function) args))) + (set-itimer-function + itimer + (lambda (itimer function &rest args) + (delete-itimer itimer) + (apply function args))) + (set-itimer-function-arguments + itimer + (append (list itimer function) args))))) + 1e-9 (if time (max time 1e-9) 1e-9) + nil t itimers repeat function args))))) + 'run-at-time))) + +(defun pgg-add-passphrase-cache (key passphrase) + (setq key (pgg-truncate-key-identifier key)) + (set (intern key pgg-passphrase-cache) + passphrase) + (pgg-run-at-time pgg-passphrase-cache-expiry nil + #'pgg-remove-passphrase-cache + key)) + +(defun pgg-remove-passphrase-cache (key) + (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache)))) + (when passphrase + (fillarray passphrase ?_) + (unintern key pgg-passphrase-cache)))) + +(defmacro pgg-convert-lbt-region (start end lbt) + `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) + (goto-char ,start) + (case ,lbt + (CRLF + (while (progn + (end-of-line) + (> (marker-position pgg-conversion-end) (point))) + (insert "\r") + (forward-line 1))) + (LF + (while (re-search-forward "\r$" pgg-conversion-end t) + (replace-match "")))))) + +(put 'pgg-as-lbt 'lisp-indent-function 3) + +(defmacro pgg-as-lbt (start end lbt &rest body) + `(let ((inhibit-read-only t) + buffer-read-only + buffer-undo-list) + (pgg-convert-lbt-region ,start ,end ,lbt) + (let ((,end (point))) + ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))) + +(put 'pgg-process-when-success 'lisp-indent-function 0) + +(defmacro pgg-process-when-success (&rest body) + `(with-current-buffer pgg-output-buffer + (if (zerop (buffer-size)) nil ,@body t))) + +(defalias 'pgg-make-temp-file + (if (fboundp 'make-temp-file) + 'make-temp-file + (lambda (prefix &optional dir-flag) + (let ((file (expand-file-name + (make-temp-name prefix) + (if (fboundp 'temp-directory) + (temp-directory) + temporary-file-directory)))) + (if dir-flag + (make-directory file)) + file)))) + +;;; @ interface functions +;;; + +;;;###autoload +(defun pgg-encrypt-region (start end rcpts &optional sign) + "Encrypt the current region between START and END for RCPTS. +If optional argument SIGN is non-nil, do a combined sign and encrypt." + (interactive + (list (region-beginning)(region-end) + (split-string (read-string "Recipients: ") "[ \t,]+"))) + (let ((status + (pgg-save-coding-system start end + (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) rcpts sign)))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-encrypt (rcpts &optional sign start end) + "Encrypt the current buffer for RCPTS. +If optional argument SIGN is non-nil, do a combined sign and encrypt. +If optional arguments START and END are specified, only encrypt within +the region." + (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+"))) + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-encrypt-region start end rcpts sign))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt-region (start end) + "Decrypt the current region between START and END." + (interactive "r") + (let* ((buf (current-buffer)) + (status + (pgg-save-coding-system start end + (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-decrypt (&optional start end) + "Decrypt the current buffer. +If optional arguments START and END are specified, only decrypt within +the region." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-decrypt-region start end))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign-region (start end &optional cleartext) + "Make the signature from text between START and END. +If the optional 3rd argument CLEARTEXT is non-nil, it does not create +a detached signature. +If this function is called interactively, CLEARTEXT is enabled +and the the output is displayed." + (interactive "r") + (let ((status (pgg-save-coding-system start end + (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) + (or (interactive-p) cleartext))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign (&optional cleartext start end) + "Sign the current buffer. +If the optional argument CLEARTEXT is non-nil, it does not create a +detached signature. +If optional arguments START and END are specified, only sign data +within the region. +If this function is called interactively, CLEARTEXT is enabled +and the the output is displayed." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-sign-region start end (or (interactive-p) cleartext)))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-verify-region (start end &optional signature fetch) + "Verify the current region between START and END. +If the optional 3rd argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region. + +If the optional 4th argument FETCH is non-nil, we attempt to fetch the +signer's public key from `pgg-default-keyserver-address'." + (interactive "r") + (let* ((packet + (if (null signature) nil + (with-temp-buffer + (buffer-disable-undo) + (if (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte nil)) + (insert-file-contents signature) + (cdr (assq 2 (pgg-decode-armor-region + (point-min)(point-max))))))) + (key (cdr (assq 'key-identifier packet))) + status keyserver) + (and (stringp key) + pgg-query-keyserver + (setq key (concat "0x" (pgg-truncate-key-identifier key))) + (null (pgg-lookup-key key)) + (or fetch (interactive-p)) + (y-or-n-p (format "Key %s not found; attempt to fetch? " key)) + (setq keyserver + (or (cdr (assq 'preferred-key-server packet)) + pgg-default-keyserver-address)) + (pgg-fetch-key keyserver key)) + (setq status + (pgg-save-coding-system start end + (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme) + (point-min) (point-max) signature))) + (when (interactive-p) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer))))) + status)) + +;;;###autoload +(defun pgg-verify (&optional signature fetch start end) + "Verify the current buffer. +If the optional argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region. +If the optional argument FETCH is non-nil, we attempt to fetch the +signer's public key from `pgg-default-keyserver-address'. +If optional arguments START and END are specified, only verify data +within the region." + (interactive "") + (let* ((start (or start (point-min))) + (end (or end (point-max))) + (status (pgg-verify-region start end signature fetch))) + (when (interactive-p) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer))))))) + +;;;###autoload +(defun pgg-insert-key () + "Insert the ASCII armored public key." + (interactive) + (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme))) + +;;;###autoload +(defun pgg-snarf-keys-region (start end) + "Import public keys in the current region between START and END." + (interactive "r") + (pgg-save-coding-system start end + (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme) + start end))) + +;;;###autoload +(defun pgg-snarf-keys () + "Import public keys in the current buffer." + (interactive "") + (pgg-snarf-keys-region (point-min) (point-max))) + +(defun pgg-lookup-key (string &optional type) + (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type)) + +(defvar pgg-insert-url-function (function pgg-insert-url-with-w3)) + +(defun pgg-insert-url-with-w3 (url) + (ignore-errors + (require 'w3) + (require 'url) + (let (buffer-file-name) + (url-insert-file-contents url)))) + +(defvar pgg-insert-url-extra-arguments nil) +(defvar pgg-insert-url-program nil) + +(defun pgg-insert-url-with-program (url) + (let ((args (copy-sequence pgg-insert-url-extra-arguments)) + process) + (insert + (with-temp-buffer + (setq process + (apply #'start-process " *PGG url*" (current-buffer) + pgg-insert-url-program (nconc args (list url)))) + (set-process-sentinel process #'ignore) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (delete-process process) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (buffer-string))))) + +(defun pgg-fetch-key (keyserver key) + "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring." + (with-current-buffer (get-buffer-create pgg-output-buffer) + (buffer-disable-undo) + (erase-buffer) + (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) + (substring keyserver 0 (1- (match-end 0)))))) + (save-excursion + (funcall pgg-insert-url-function + (if proto keyserver + (format "http://%s:11371/pks/lookup?op=get&search=%s" + keyserver key)))) + (when (re-search-forward "^-+BEGIN" nil 'last) + (delete-region (point-min) (match-beginning 0)) + (when (re-search-forward "^-+END" nil t) + (delete-region (progn (end-of-line) (point)) + (point-max))) + (insert "\n") + (with-temp-buffer + (insert-buffer-substring pgg-output-buffer) + (pgg-snarf-keys-region (point-min)(point-max))))))) + + +(provide 'pgg) + +;;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4 +;;; pgg.el ends here
--- a/lisp/gnus/pop3.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/pop3.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; pop3.el --- Post Office Protocol (RFC 1460) interface -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Richard L. Pieri <ratinox@peorth.gweep.net> @@ -54,9 +54,6 @@ Defaults to 'pass, for the standard USER/PASS authentication. Other valid values are 'apop.") -(defvar pop3-leave-mail-on-server nil - "*Non-nil if the mail is to be left on the POP server after fetching.") - (defvar pop3-timestamp nil "Timestamp returned when initially connected to the POP server. Used for APOP authentication.") @@ -78,7 +75,7 @@ ;; query for password (if (and pop3-password-required (not pop3-password)) (setq pop3-password - (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) + (read-passwd (format "Password for %s: " pop3-maildrop)))) (cond ((equal 'apop pop3-authentication-scheme) (pop3-apop process pop3-maildrop)) ((equal 'pass pop3-authentication-scheme) @@ -88,8 +85,8 @@ (setq message-count (car (pop3-stat process))) (unwind-protect (while (<= n message-count) - (message (format "Retrieving message %d of %d from %s..." - n message-count pop3-mailhost)) + (message "Retrieving message %d of %d from %s..." + n message-count pop3-mailhost) (pop3-retr process n crashbuf) (save-excursion (set-buffer crashbuf) @@ -100,8 +97,7 @@ (goto-char (point-min)) (forward-line 50) (delete-region (point-min) (point)))) - (unless pop3-leave-mail-on-server - (pop3-dele process n)) + (pop3-dele process n) (setq n (+ 1 n)) (if pop3-debug (sit-for 1) (sit-for 0.1)) ) @@ -121,7 +117,7 @@ ;; query for password (if (and pop3-password-required (not pop3-password)) (setq pop3-password - (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) + (read-passwd (format "Password for %s: " pop3-maildrop)))) (cond ((equal 'apop pop3-authentication-scheme) (pop3-apop process pop3-maildrop)) ((equal 'pass pop3-authentication-scheme) @@ -177,8 +173,9 @@ (save-excursion (set-buffer (process-buffer process)) (goto-char pop3-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process 3) + (while (and (memq (process-status process) '(open run)) + (not (search-forward "\r\n" nil t))) + (nnheader-accept-process-output process) (goto-char pop3-read-point)) (setq match-end (point)) (goto-char pop3-read-point) @@ -192,17 +189,6 @@ t) ))))) -(defvar pop3-read-passwd nil) -(defun pop3-read-passwd (prompt) - (if (not pop3-read-passwd) - (if (fboundp 'read-passwd) - (setq pop3-read-passwd 'read-passwd) - (if (load "passwd" t) - (setq pop3-read-passwd 'read-passwd) - (autoload 'ange-ftp-read-passwd "ange-ftp") - (setq pop3-read-passwd 'ange-ftp-read-passwd)))) - (funcall pop3-read-passwd prompt)) - (defun pop3-clean-region (start end) (setq end (set-marker (make-marker) end)) (save-excursion @@ -263,7 +249,7 @@ ;; Tue Jul 9 09:04:21 1996 (setq date (cond ((not date) - "Tue Jan 1 00:00:0 1900") + "Tue Jan 1 00:00:0 1900") ((string-match "[A-Z]" (nth 0 date)) (format "%s %s %s %s %s" (nth 0 date) (nth 2 date) (nth 1 date) @@ -316,7 +302,7 @@ (let ((pass pop3-password)) (if (and pop3-password-required (not pass)) (setq pass - (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) + (read-passwd (format "Password for %s: " pop3-maildrop)))) (if pass (let ((hash (pop3-md5 (concat pop3-timestamp pass)))) (pop3-send-command process (format "APOP %s %s" user hash)) @@ -363,7 +349,8 @@ (save-excursion (set-buffer (process-buffer process)) (while (not (re-search-forward "^\\.\r\n" nil t)) - (accept-process-output process 3) + ;; Fixme: Shouldn't depend on nnheader. + (nnheader-accept-process-output process) ;; bill@att.com ... to save wear and tear on the heap ;; uncommented because the condensed version below is a problem for ;; some.
--- a/lisp/gnus/post.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/post.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,53 +1,35 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 23 1", -" c Gray0", -". c Gray6", -"X c Gray12", -"o c #2ff22ff22ff2", -"O c #3fff3fff3fff", -"+ c Gray28", -"@ c #53ee53ee53ee", -"# c #5fdf5fdf5fdf", -"$ c #67e767e767e7", -"% c #6fff6fff6fff", -"& c #77f777f777f7", -"* c #7bdb7bdb7bdb", -"= c Gray50", -"- c Gray56", -"; c #9bd69bd69bd6", -": c #9fff9fff9fff", -"> c #a7c7a7c7a7c7", -", c Gray70", -"< c Gray75", -"1 c Gray81", -"2 c #dfffdfffdfff", -"3 c #efffefffefff", -"4 c Gray100", -/* pixels */ -",><,><,><,><,><,><,><,><", -">-<>-<>-<>-<>-<>-<>-<>-<", -"<<<<<<<<<<<<<<<<<<<<<<<<", -",><,><,><,>;*O.,><,><,><", -">-<>-<>-<-o&:4O#-<>-<>-<", -"<<<<<<<<@@<31O:o<<<<<<<<", -",><,>;*O1444 X1@><,><,><", -">-<-o&:4444:=<4<#<>-<>-<", -"<<<,+<4444414443&;<<<<<<", -",><,#;4444444444:*,><,><", -">-<>-o44444444444O>-<>-<", -"<<<<<;%44444444441@<<<<<", -",><,><@24444444444@><,><", -">-<>-<-=4444444444<#<>-<", -"<<<<<<,$14444444443&;<<<", -",><,><,#;4444444444:*,><", -">-<>-<>-o4444444444<X>-<", -"<<<<<<<<;%4444444%O$-<<<", -",><,><,><@24444<&;,><,><", -">-<>-<>-<-=42==#-<>-<>-<", -"<<<<<<<<<,$Oo+-<<<<<<<<<", -",><,><,><,><,><,><,><,><", -">-<>-<>-<>-<>-<>-<>-<>-<", -"<<<<<<<<<<<<<<<<<<<<<<<<" -}; +static char * post_xpm[] = { +"24 24 8 1", +". c None", +" c #434343434343", +"X c #A5A5A5A59595", +"O c #000000000000", +"+ c #C7C7C6C6C6C6", +"@ c #FFFF00000000", +"# c #9A9A6C6C4E4E", +"$ c #E1E1E0E0E0E0", +"O..O..O..O..O..O..O..O..", +"........................", +"............X...........", +"O..O..O..O.XXX.O..O..O..", +".........XX++@X.........", +".......XX+++#@$X........", +"O..OXXX++++##$$$X.O..O..", +"....X$X++++++$$$X.......", +"....X$$X+++$$$$$$X......", +"O..OX$$XX++$$$$$$$X..O..", +"....X$$X++$$$$$$$$$X....", +"....X$X+$$$$$$$$$$$+X...", +"O..O+X++$$$$$$$$$$$$XO..", +"....+X+$$$$$$$$$$$$X+...", +".....+X$$$$$$$$$$$X+....", +"O..O.+X$$$$$$$$$XXO..O..", +"......+X$$$$$$$X++......", +"......+X$$$$$XX+........", +"O..O..O+X$$$X++O..O..O..", +".......+X$$X++..........", +"........+XX+............", +"O..O..O..O+.O..O..O..O..", +"........................", +"........................"};
--- a/lisp/gnus/prev-ur.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/prev-ur.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,65 +1,35 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 35 1", -" c Gray0", -". c Gray6", -"X c Gray9", -"o c Gray12", -"O c #23f323f323f3", -"+ c Gray15", -"@ c #2ff22ff22ff2", -"# c #399939993999", -"$ c #3fff3fff3fff", -"% c Gray28", -"& c #53ed53ed53ed", -"* c Gray35", -"= c #5b1a5b1a5b1a", -"- c Gray36", -"; c #5fef5fef5fef", -": c Gray40", -"> c #67e767e767e7", -", c #6ffa6ffa6ffa", -"< c Gray45", -"1 c #77ea77ea77ea", -"2 c #799979997999", -"3 c #7bdb7bdb7bdb", -"4 c Gray50", -"5 c Gray56", -"6 c Gray60", -"7 c #9bde9bde9bde", -"8 c #9fff9fff9fff", -"9 c #a7c7a7c7a7c7", -"0 c #acccacccaccc", -"q c Gray70", -"w c Gray75", -"e c Gray81", -"r c #dfffdfffdfff", -"t c #efffefffefff", -"y c Gray100", -/* pixels */ -"q9wq9wq9wq9wq9wq9wq9wq9w", -"95w95w95w95w95w95w95w95w", -"wwwwwwwwwwwwwwwwwwwwwwww", -"q9wq9wq9wq973$.q9wq9wq9w", -"95w95w95w5@18y$;5w95w95w", -"wwwwwwww&&wte$8@wwwwwwww", -"q9wq973$eyyy oe&9wq9wq9w", -"95w5@18yyyy84wyw;w95w95w", -"wwwq%wyyyyyeyyyt17wwwwww", -"q9wq;7yyyyyyyyyy45q9wq9w", -"95w9518yyr44yyyy4%%@995w", -"wwwww&.3;;w@yyye=<<#Owww", -"q9wq=;:$etw;$rt+w0777O9w", -"95w5+<8yy; wo44+77777X5w", -"ww&&wtyyy ;t@re+77777@ww", -"q%wyyyyy,yyyw4ye=<<#Oq9w", -"9@wyyyyyyyyyr4rywo;;995w", -"w9&yyyyyyyyyy4we$3wwwwww", -"q9&eyyyyyyyyyy,@wwq9wq9w", -"95w$yyyyyyyyyyy@ww95w95w", -"www38yyyyyyyyyy71wwwwwww", -"q9w54yyyyyyyyyye:qq9wq9w", -"95w9,ryyyyyyyyyy4595w95w", -"wwww9&yyyyyyyyyyr&wwwwww" -}; +static char * prev_ur_xpm[] = { +"24 24 8 1", +". c None", +" c #000000000000", +"X c #A5A5A5A59595", +"o c #C7C7C6C6C6C6", +"O c #FFFF00000000", +"+ c #9A9A6C6C4E4E", +"@ c #E1E1E0E0E0E0", +"# c #FFFFFFFFFFFF", +" .. .. .. .. .. .. .. ..", +"........................", +"............X...........", +" .. .. .. .XXX. .. .. ..", +".........XXooOX.........", +".......XXooo+O@X........", +" .. XXXoooo++@@@X. .. ..", +"....X@Xoooooo@@@X.......", +"....X@@Xooo@@@@@@X......", +" .. X@@XXoo@@@@@@@X.. ..", +"....X@@Xo @@@@@@ X....", +"....X@Xo ## X @ ## X...", +" .. oXo #XXXoO@ #### ..", +"....oXoXXooo+OX #### ...", +"....XXXoooo++@@X ## ....", +" .. X@Xoooooo@@@X .. ..", +"....X@@Xooo@@@@@@X......", +"....X@@XXoo@@@@@@@X.....", +" .. X@@Xoo@@@@@@@@@X. ..", +"....X@Xo@@@@@@@@@@@@X...", +"... oXoo@@@@@@@@@@@@X...", +" .. oXo@@@@@@@@@@@@X....", +".....oX@@@@@@@@@@@X.....", +".....oX@@@@@@@@@@X......"};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/preview.xbm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,10 @@ +#define preview_width 24 +#define preview_height 24 +static char preview_bits[] = { + 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, + 0x00,0xc0,0x03,0x00,0x3e,0x06,0xf0,0x03,0x04,0x08,0x00,0x0a,0x78,0x00,0x09, + 0x88,0xf9,0x08,0x10,0xc6,0x10,0x10,0x3a,0x13,0x10,0x06,0x15,0x20,0x02,0x29, + 0x20,0x02,0x31,0x20,0xad,0x0f,0x40,0xf9,0x03,0xc0,0xb8,0x07,0x80,0x07,0x0e, + 0x80,0x01,0x1c,0x00,0x00,0x18,0x00,0x00,0x00,0x00,0x00,0x00,0x00,0xc8,0x00, + 0x00,0x00,0x39,0x00,0x00,0x00,0x08,0xc0,0x12,0x42,0x00,0x00,0x00,0x00,0x38, + 0x82,0x18,0x08,0x00,0x00,0x00 };
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/preview.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,33 @@ +/* XPM */ +static char *prev1[]={ +"24 24 6 1", +". c None", +"# c #000000", +"d c #46463e", +"a c #676663", +"c c #a8a7a3", +"b c #ebeae4", +"........................", +"........................", +"........................", +"........................", +"........................", +"..............####......", +".........#####abbc#.....", +"....#####acbbbbbbc#.....", +"...#acbbbbbbbbbbacc#....", +"...#baabbbbbbbbcacb#....", +"...#cbcaabbd##dacbb#....", +"....#bbbccdcbbcdabbc#...", +"....#bbbbdccaaccdacb#...", +"....#cbbb#abbbbb#bac#...", +".....#bbb#cbbbbc#bbac#..", +".....#bbbdcbbbbddbbc##..", +".....#cbccdcbbd#####....", +"......#babbd##dd##......", +"......#acbc###.####.....", +"......#aa##......###....", +".......##.........###...", +"...................##...", +"........................", +"........................"};
--- a/lisp/gnus/qp.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/qp.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ ;;; qp.el --- Quoted-Printable functions -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: mail, extensions @@ -32,13 +32,18 @@ (require 'mm-util) (eval-when-compile (defvar mm-use-ultra-safe-encoding)) +;;;###autoload (defun quoted-printable-decode-region (from to &optional coding-system) "Decode quoted-printable in the region between FROM and TO, per RFC 2045. If CODING-SYSTEM is non-nil, decode bytes into characters with that coding-system. Interactively, you can supply the CODING-SYSTEM argument -with \\[universal-coding-system-argument]." +with \\[universal-coding-system-argument]. + +The CODING-SYSTEM argument is a historical hangover and is deprecated. +QP encodes raw bytes and should be decoded into raw bytes. Decoding +them into characters should be done separately." (interactive ;; Let the user determine the coding system with "C-x RET c". (list (region-beginning) (region-end) coding-system-for-read)) @@ -67,19 +72,19 @@ (+ 3 (point))) 16))) (mm-insert-byte byte 1) - (delete-char 3) - (unless (eq byte ?=) - (backward-char)))) + (delete-char 3))) (t - (error "Malformed quoted-printable text") + (message "Malformed quoted-printable text") (forward-char))))) (if coding-system (mm-decode-coding-region (point-min) (point-max) coding-system))))) (defun quoted-printable-decode-string (string &optional coding-system) "Decode the quoted-printable encoded STRING and return the result. -If CODING-SYSTEM is non-nil, decode the region with coding-system." - (with-temp-buffer +If CODING-SYSTEM is non-nil, decode the region with coding-system. +Use of CODING-SYSTEM is deprecated; this function should deal with +raw bytes, and coding conversion should be done separately." + (mm-with-unibyte-buffer (insert string) (quoted-printable-decode-region (point-min) (point-max) coding-system) (buffer-string)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/receipt.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,32 @@ +/* XPM */ +static char * receipt_xpm[] = { +"24 24 5 1", +" c None", +". c #FFFFFFFFFFFF", +"X c #676766666363", +"o c #FFFF00000000", +"O c #AEAE3E3E4848", +" ", +" ", +" .. ", +" . ", +" . ", +" . ", +" .. ", +" Xooo .. ", +" Xoooooooo.. ", +" Xoooooooooooooo ... ", +" oooooooooooOOoo . ", +" ooooooooooOOOOo. ", +" oooooooooOO...o ", +" ooooooooooOOooo ", +" ooooooooooooooo ", +" ooooooooooooooo ", +" oooooooooooooo ", +" ooooooooooo ", +" ooooooo ", +" oooo ", +" oo ", +" ", +" ", +" "};
--- a/lisp/gnus/reply-wo.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/reply-wo.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,65 +1,31 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 35 1", -" c Gray0", -". c Gray6", -"X c Gray9", -"o c Gray12", -"O c #23f323f323f3", -"+ c #2ffe2ffe2ffe", -"@ c #399939993999", -"# c #3fff3fff3fff", -"$ c Gray25", -"% c #499949994999", -"& c #4ccc4ccc4ccc", -"* c #519151915191", -"= c #53f353f353f3", -"- c Gray35", -"; c #5feb5feb5feb", -": c #67e767e767e7", -"> c #6fff6fff6fff", -", c Gray45", -"< c #77ef77ef77ef", -"1 c #7bdb7bdb7bdb", -"2 c Gray50", -"3 c Gray56", -"4 c Gray60", -"5 c #9bd39bd39bd3", -"6 c #9fff9fff9fff", -"7 c Gray64", -"8 c #a7c7a7c7a7c7", -"9 c Gray70", -"0 c #b998b998b998", -"q c #bcccbcccbccc", -"w c Gray75", -"e c Gray81", -"r c #dfffdfffdfff", -"t c #efffefffefff", -"y c Gray100", -/* pixels */ -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwwwwwwwwwwwwwwww", -"wwwwwwwwwww5+o1wwwwwwwww", -"wwwwwwwwww3<w26;3wwwwwww", -"wwwwwwwww5<tw2yw<5wwwwww", -"wwwwww93=#yy#yyyy>O8wwww", -"wwwww<:226yy#yyyw2 ;wwww", -"www5+5e66yyy#6##2w X5www", -"w8=>ye#6yy2+#6yyr+9y>$8w", -"w;;yw2yw22#wyyyr#@9yy@;w", -"w;3#o+#2w3;tyyy+@3w##3;w", -"w;wyy>wry66yyr+%0;>yyw;w", -"w;wyyy222#yyr#;-2ryyyw;w", -"7=wyyyyrw.6y+ +wryyyyw=7", -"5&wyyyyye#o3.#6yyyyyyw&5", -"5&wyyyyw2yw26y66yyyyyw&5", -"5&wyyye2tyyyyyy66yyyyw&5", -"5&wyr;>yyyyyyyyy6#eyyw&5", -"5&wr2ryyyyyyyyyyyy2wyw&5", -"5&+;ryyyyyyyyyyyyyt2#+&5", -"5& wwwwwwwwwwwwwwwwww &5", -"5,&&&&&&&&&&&&&&&&&&&&,5", -"555555555555555555555555" -}; +static char * reply_wo_xpm[] = { +"24 24 4 1", +" c None", +". c #000000000000", +"X c #E1E1E0E0E0E0", +"O c #FFFFFFFFFFFF", +" ", +" ", +" ", +" .... ", +" ..X.... ", +" ..XX.XX.. ", +" .O.XX.XXXX.. ", +" ..O.XXX.XXXX... ", +" .OO.XXXX.X....... ", +" .OO.XXXX...XXX.OO.. ", +" ..OO.XX....XXXX.OOOO.. ", +" .......XX.XXXX.OOO.... ", +" .OOO.XXX.XXXX.OO..OOO. ", +" .OOOO....XXX....OOOOO. ", +" .OOOOOOO..XX..OOOOOOO. ", +" .OOOOOOO......OOOOOOO. ", +" .OOOOOO.OO..O..OOOOOO. ", +" .OOOOO.OOOOOOOO.OOOOO. ", +" .OOOO.OOOOOOOOOO.OOOO. ", +" .OOO.OOOOOOOOOOOO.OOO. ", +" .O..OOOOOOOOOOOOOO..O. ", +" ..OOOOOOOOOOOOOOOOOO.. ", +" ...................... ", +" "};
--- a/lisp/gnus/reply.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/reply.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,64 +1,31 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 34 1", -" c Gray0", -". c Gray6", -"X c Gray9", -"o c Gray12", -"O c #2ffb2ffb2ffb", -"+ c #399939993999", -"@ c #3fff3fff3fff", -"# c Gray25", -"$ c #499949994999", -"% c #4ccc4ccc4ccc", -"& c #519151915191", -"* c #53f353f353f3", -"= c Gray35", -"- c #5feb5feb5feb", -"; c #67e767e767e7", -": c #6fff6fff6fff", -"> c Gray45", -", c #77ef77ef77ef", -"< c Gray50", -"1 c Gray56", -"2 c #933293329332", -"3 c Gray60", -"4 c #9bd29bd29bd2", -"5 c #9fff9fff9fff", -"6 c Gray64", -"7 c #a7c7a7c7a7c7", -"8 c Gray70", -"9 c #b998b998b998", -"0 c #bcccbcccbccc", -"q c Gray75", -"w c Gray81", -"e c #dfffdfffdfff", -"r c #efffefffefff", -"t c Gray100", -/* pixels */ -"qqqqqqqqqqqqqqqqqqqqqqqq", -"qqqqqqqqqqqqqqqqqqqqqqqq", -"qqqqqqqqqqqqqqqqqqqqqqqq", -"qqqqqqqqqqqqqq4qqqqqqqqq", -"qqqqqqqqqqqqq1,-1qqqqqqq", -"qqqqqqqqq4OO4,rq,4qqqqqq", -"qqqqqq81*:tw:tttt:*7qqqq", -"qqqqq,;<etq<tttttt--qqqq", -"qqq4O4wttt<qttttt: X4qqq", -"q7*Oewrew55ttttteO6qO#7q", -"q--<q5eq@5ttttte@+2<<+-q", -"q-1@@wtt@ttttttO+1q@@1-q", -"q-qtt:q<wtttteO$9-:ttq-q", -"q-qttt<<<ttte@-=<etttq-q", -"6*qtttteq:ttO Oqettttq*6", -"4%qtttttw@o1.@5ttttttq%4", -"4%qttttq<tq<5t55tttttq%4", -"4%qtttw<rtttttt55ttttq%4", -"4%qte-:ttttttttt5@wttq%4", -"4%qe<etttttttttttt<qtq%4", -"4%O-etttttttttttttr<@O%4", -"4% qqqqqqqqqqqqqqqqqq %4", -"4>%%%%%%%%%%%%%%%%%%%%>4", -"444444444444444444444444" -}; +static char * reply_xpm[] = { +"24 24 4 1", +" c None", +". c #000000000000", +"X c #E1E1E0E0E0E0", +"O c #FFFFFFFFFFFF", +" ", +" ", +" ", +" .... ", +" ..XXX.. ", +" ..XXXXX.. ", +" .O.XXXXXXX.. ", +" ..O.XXXXXXXXX.. ", +" .OO.XXXXXXXXXX... ", +" .OO.XXXXXXXXXX.OO.. ", +" ..OO.XXXXXXXXXX.OOOO.. ", +" .....XXXXXXXXX.OOO.... ", +" .OOO.XXXXXXXX.OO..OOO. ", +" .OOOO...XXXXX...OOOOO. ", +" .OOOOOOO..XX..OOOOOOO. ", +" .OOOOOOO......OOOOOOO. ", +" .OOOOOO.OO..O..OOOOOO. ", +" .OOOOO.OOOOOOOO.OOOOO. ", +" .OOOO.OOOOOOOOOO.OOOO. ", +" .OOO.OOOOOOOOOOOO.OOO. ", +" .O..OOOOOOOOOOOOOO..O. ", +" ..OOOOOOOOOOOOOOOOOO.. ", +" ...................... ", +" "};
--- a/lisp/gnus/rfc1843.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/rfc1843.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; rfc1843.el --- HZ (rfc1843) decoding -;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (c) 1998, 1999, 2000, 2003 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> ;; Keywords: news HZ HZ+ mail i18n @@ -43,18 +43,18 @@ (defvar rfc1843-hzp-word-regexp "~\\({\\([\041-\167][\041-\176]\\| \\)+\\|\ -[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") +\[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") (defvar rfc1843-hzp-word-regexp-strictly "~\\({\\([\041-\167][\041-\176]\\)+\\|\ -[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)") +\[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)") (defcustom rfc1843-decode-loosely nil "Loosely check HZ encoding if non-nil. When it is set non-nil, only buffers or strings with strictly HZ-encoded are decoded." :type 'boolean - :group 'gnus) + :group 'mime) (defcustom rfc1843-decode-hzp t "HZ+ decoding support if non-nil. @@ -64,12 +64,12 @@ The document of HZ+ 0.78 specification can be found at ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc" :type 'boolean - :group 'gnus) + :group 'mime) (defcustom rfc1843-newsgroups-regexp "chinese\\|hz" "Regexp of newsgroups in which might be HZ encoded." :type 'string - :group 'gnus) + :group 'mime) (defun rfc1843-decode-region (from to) "Decode HZ in the region between FROM and TO."
--- a/lisp/gnus/rfc2045.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/rfc2045.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,4 +1,4 @@ -;;; rfc2045.el --- functions for decoding rfc2045 headers +;;; rfc2045.el --- Functions for decoding rfc2045 headers ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
--- a/lisp/gnus/rfc2047.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/rfc2047.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,5 @@ ;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages -;; Copyright (C) 1998,1999,2000,02,03,2004 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> @@ -29,7 +29,24 @@ (eval-when-compile (require 'cl) - (defvar message-posting-charset)) + (defvar message-posting-charset) + (unless (fboundp 'with-syntax-table) ; not in Emacs 20 + (defmacro with-syntax-table (table &rest body) + "Evaluate BODY with syntax table of current buffer set to 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 ,table) + ,@body) + (save-current-buffer + (set-buffer ,old-buffer) + (set-syntax-table ,old-table)))))))) (require 'qp) (require 'mm-util) @@ -38,11 +55,24 @@ (require 'base64) (autoload 'mm-body-7-or-8 "mm-bodies") +(eval-and-compile + ;; Avoid gnus-util for mm- code. + (defalias 'rfc2047-point-at-bol + (if (fboundp 'point-at-bol) + 'point-at-bol + 'line-beginning-position)) + + (defalias 'rfc2047-point-at-eol + (if (fboundp 'point-at-eol) + 'point-at-eol + 'line-end-position))) + (defvar rfc2047-header-encoding-alist - '(("Newsgroups\\|Followup-To" . nil) + '(("Newsgroups" . nil) + ("Followup-To" . nil) ("Message-ID" . nil) - ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\)" . - address-mime) + ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\ +\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) (t . mime)) "*Header/encoding method alist. The list is traversed sequentially. The keys can either be @@ -80,7 +110,8 @@ (cn-gb-2312 . B) (euc-kr . B) (iso-2022-jp-2 . B) - (iso-2022-int-1 . B)) + (iso-2022-int-1 . B) + (viscii . Q)) "Alist of MIME charsets to RFC2047 encodings. Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding, quoted-printable and base64 respectively.") @@ -91,15 +122,6 @@ (nil . ignore)) "Alist of RFC2047 encodings to encoding functions.") -(defvar rfc2047-q-encoding-alist - '(("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|Reply-To\\|Sender\\):" - . "-A-Za-z0-9!*+/" ) - ;; = (\075), _ (\137), ? (\077) are used in the encoded word. - ;; Avoid using 8bit characters. - ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" - ("." . "\010\012\014\040-\074\076\100-\136\140-\177")) - "Alist of header regexps and valid Q characters.") - ;;; ;;; Functions for encoding RFC2047 messages ;;; @@ -112,12 +134,18 @@ (progn (forward-line 1) (if (re-search-forward "^[^ \n\t]" nil t) - (progn - (beginning-of-line) - (point)) + (rfc2047-point-at-bol) (point-max)))) (goto-char (point-min))) +(defun rfc2047-field-value () + "Return the value of the field at point." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (re-search-forward ":[ \t\n]*" nil t) + (buffer-substring (point) (point-max))))) + (defvar rfc2047-encoding-type 'address-mime "The type of encoding done by `rfc2047-encode-region'. This should be dynamically bound around calls to @@ -169,7 +197,7 @@ ((eq method 'address-mime) (rfc2047-encode-region (point) (point-max))) ((eq method 'mime) - (let ((rfc2047-encoding-type method)) + (let ((rfc2047-encoding-type 'mime)) (rfc2047-encode-region (point) (point-max)))) ((eq method 'default) (if (and (featurep 'mule) @@ -178,6 +206,26 @@ mail-parse-charset) (mm-encode-coding-region (point) (point-max) mail-parse-charset))) + ;; We get this when CC'ing messsages to newsgroups with + ;; 8-bit names. The group name mail copy just got + ;; unconditionally encoded. Previously, it would ask + ;; whether to encode, which was quite confusing for the + ;; user. If the new behaviour is wrong, tell me. I have + ;; left the old code commented out below. + ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07. + ;; Modified by Dave Love, with the commented-out code changed + ;; in accordance with changes elsewhere. + ((null method) + (rfc2047-encode-region (point) (point-max))) +;;; ((null method) +;;; (if (or (message-options-get +;;; 'rfc2047-encode-message-header-encode-any) +;;; (message-options-set +;;; 'rfc2047-encode-message-header-encode-any +;;; (y-or-n-p +;;; "Some texts are not encoded. Encode anyway?"))) +;;; (rfc2047-encode-region (point-min) (point-max)) +;;; (error "Cannot send unencoded text"))) ((mm-coding-system-p method) (if (and (featurep 'mule) (if (boundp 'default-enable-multibyte-characters) @@ -197,7 +245,8 @@ (require 'message) ; for message-posting-charset (let ((charsets (mm-find-mime-charset-region (point-min) (point-max)))) - (and charsets (not (equal charsets (list message-posting-charset)))))) + (and charsets + (not (equal charsets (list (car message-posting-charset))))))) ;; Use this syntax table when parsing into regions that may need ;; encoding. Double quotes are string delimiters, backslash is @@ -206,7 +255,19 @@ ;; skip to the end of regions appropriately. Nb. ietf-drums does ;; things differently. (defconst rfc2047-syntax-table - (let ((table (make-char-table 'syntax-table '(2)))) + ;; (make-char-table 'syntax-table '(2)) only works in Emacs. + (let ((table (make-syntax-table))) + ;; The following is done to work for setting all elements of the table + ;; in Emacs 21 and 22 and XEmacs; it appears to be the cleanest way. + ;; Play safe and don't assume the form of the word syntax entry -- + ;; copy it from ?a. + (if (fboundp 'set-char-table-range) ; Emacs + (funcall (intern "set-char-table-range") + table t (aref (standard-syntax-table) ?a)) + (if (fboundp 'put-char-table) + (if (fboundp 'get-char-table) ; warning avoidance + (put-char-table t (get-char-table ?a (standard-syntax-table)) + table)))) (modify-syntax-entry ?\\ "\\" table) (modify-syntax-entry ?\" "\"" table) (modify-syntax-entry ?\( "." table) @@ -228,22 +289,32 @@ (save-restriction (narrow-to-region b e) (if (eq 'mime rfc2047-encoding-type) - ;; Simple case -- treat as single word. + ;; Simple case. Treat as single word after any initial ASCII + ;; part and before any tailing ASCII part. The leading ASCII + ;; is relevant for instance in Subject headers with `Re:' for + ;; interoperability with non-MIME clients, and we might as + ;; well avoid the tail too. (progn (goto-char (point-min)) ;; Does it need encoding? - (skip-chars-forward "\000-\177" e) + (skip-chars-forward "\000-\177") (unless (eobp) - (rfc2047-encode b e))) + (skip-chars-backward "^ \n") ; beginning of space-delimited word + (rfc2047-encode (point) (progn + (goto-char e) + (skip-chars-backward "\000-\177") + (skip-chars-forward "^ \n") + ;; end of space-delimited word + (point))))) ;; `address-mime' case -- take care of quoted words, comments. (with-syntax-table rfc2047-syntax-table - (let ((start (point)) ; start of current token + (let ((start) ; start of current token end ; end of current token ;; Whether there's an encoded word before the current ;; token, either immediately or separated by space. last-encoded) (goto-char (point-min)) - (condition-case nil ; in case of unbalanced quotes + (condition-case nil ; in case of unbalanced quotes ;; Look for rfc2822-style: sequences of atoms, quoted ;; strings, specials, whitespace. (Specials mustn't be ;; encoded.) @@ -306,14 +377,15 @@ end (1+ end))) (rfc2047-encode start end) (setq last-encoded t))))) - (error (error "Invalid data for rfc2047 encoding: %s" - (buffer-substring b e))))))) + (error + (error "Invalid data for rfc2047 encoding: %s" + (buffer-substring b e))))))) (rfc2047-fold-region b (point)))) (defun rfc2047-encode-string (string) "Encode words in STRING. By default, the string is treated as containing addresses (see -`rfc2047-special-chars')." +`rfc2047-encoding-type')." (with-temp-buffer (insert string) (rfc2047-encode-region (point-min) (point-max)) @@ -322,7 +394,7 @@ (defun rfc2047-encode (b e) "Encode the word(s) in the region B to E. By default, the region is treated as containing addresses (see -`rfc2047-special-chars')." +`rfc2047-encoding-type')." (let* ((mime-charset (mm-find-mime-charset-region b e)) (cs (if (> (length mime-charset) 1) ;; Fixme: Instead of this, try to break region into @@ -333,14 +405,36 @@ (mm-charset-to-coding-system mime-charset))) ;; Fixme: Better, calculate the number of non-ASCII ;; characters, at least for 8-bit charsets. - (encoding (if (assq mime-charset - rfc2047-charset-encoding-alist) - (cdr (assq mime-charset + (encoding (or (cdr (assq mime-charset rfc2047-charset-encoding-alist)) - 'B)) + ;; For the charsets that don't have a preferred + ;; encoding, choose the one that's shorter. + (save-restriction + (narrow-to-region b e) + (if (eq (mm-qp-or-base64) 'base64) + 'B + 'Q)))) (start (concat "=?" (downcase (symbol-name mime-charset)) "?" (downcase (symbol-name encoding)) "?")) + (factor (case mime-charset + ((iso-8859-5 iso-8859-7 iso-8859-8 koi8-r) 1) + ((big5 gb2312 euc-kr) 2) + (utf-8 4) + (t 8))) + (pre (- b (save-restriction + (widen) + (rfc2047-point-at-bol)))) + ;; encoded-words must not be longer than 75 characters, + ;; including charset, encoding etc. This leaves us with + ;; 75 - (length start) - 2 - 2 characters. The last 2 is for + ;; possible base64 padding. In the worst case (iso-2022-*) + ;; each character expands to 8 bytes which is expanded by a + ;; factor of 4/3 by base64 encoding. + (length (floor (- 75 (length start) 4) (* factor (/ 4.0 3.0)))) + ;; Limit line length to 76 characters. + (length1 (max 1 (floor (- 76 (length start) 4 pre) + (* factor (/ 4.0 3.0))))) (first t)) (if mime-charset (save-restriction @@ -349,9 +443,14 @@ ;; break into lines before encoding (goto-char (point-min)) (while (not (eobp)) - (goto-char (min (point-max) (+ 15 (point)))) + (if first + (progn + (goto-char (min (point-max) (+ length1 (point)))) + (setq first nil)) + (goto-char (min (point-max) (+ length (point))))) (unless (eobp) - (insert ?\n)))) + (insert ?\n))) + (setq first t)) (if (and (mm-multibyte-p) (mm-coding-system-p cs)) (mm-encode-coding-region (point-min) (point-max) cs)) @@ -367,6 +466,13 @@ (insert "?=") (forward-line 1)))))) +(defun rfc2047-fold-field () + "Fold the current header field." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (rfc2047-fold-region (point-min) (point-max))))) + (defun rfc2047-fold-region (b e) "Fold long lines in region B to E." (save-restriction @@ -377,9 +483,10 @@ (first t) (bol (save-restriction (widen) - (mm-point-at-bol)))) + (rfc2047-point-at-bol)))) (while (not (eobp)) - (when (and (or break qword-break) (> (- (point) bol) 76)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) (goto-char (or break qword-break)) (setq break nil qword-break nil) @@ -389,7 +496,8 @@ (setq bol (1- (point))) ;; Don't break before the first non-LWSP characters. (skip-chars-forward " \t") - (unless (eobp) (forward-char 1))) + (unless (eobp) + (forward-char 1))) (cond ((eq (char-after) ?\n) (forward-char 1) @@ -412,11 +520,14 @@ (if (eq (char-after) ?=) (forward-char 1) (skip-chars-forward "^ \t\n\r=")) - (setq qword-break (point)) + ;; Don't break at the start of the field. + (unless (= (point) b) + (setq qword-break (point))) (skip-chars-forward "^ \t\n\r"))) (t (skip-chars-forward "^ \t\n\r")))) - (when (and (or break qword-break) (> (- (point) bol) 76)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) (goto-char (or break qword-break)) (setq break nil qword-break nil) @@ -426,7 +537,15 @@ (setq bol (1- (point))) ;; Don't break before the first non-LWSP characters. (skip-chars-forward " \t") - (unless (eobp) (forward-char 1)))))) + (unless (eobp) + (forward-char 1)))))) + +(defun rfc2047-unfold-field () + "Fold the current line." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (rfc2047-unfold-region (point-min) (point-max))))) (defun rfc2047-unfold-region (b e) "Unfold lines in region B to E." @@ -435,19 +554,18 @@ (goto-char (point-min)) (let ((bol (save-restriction (widen) - (mm-point-at-bol))) - (eol (mm-point-at-eol)) - leading) + (rfc2047-point-at-bol))) + (eol (rfc2047-point-at-eol))) (forward-line 1) (while (not (eobp)) (if (and (looking-at "[ \t]") - (< (- (mm-point-at-eol) bol) 76)) + (< (- (rfc2047-point-at-eol) bol) 76)) (delete-region eol (progn (goto-char eol) (skip-chars-forward "\r\n") (point))) - (setq bol (mm-point-at-bol))) - (setq eol (mm-point-at-eol)) + (setq bol (rfc2047-point-at-bol))) + (setq eol (rfc2047-point-at-eol)) (forward-line 1))))) (defun rfc2047-b-encode-region (b e) @@ -465,16 +583,21 @@ (save-excursion (save-restriction (narrow-to-region (goto-char b) e) - (let ((alist rfc2047-q-encoding-alist) - (bol (save-restriction + (let ((bol (save-restriction (widen) - (mm-point-at-bol)))) - (while alist - (when (looking-at (caar alist)) - (quoted-printable-encode-region b e nil (cdar alist)) - (subst-char-in-region (point-min) (point-max) ? ?_) - (setq alist nil)) - (pop alist)) + (rfc2047-point-at-bol)))) + (quoted-printable-encode-region + b e nil + ;; = (\075), _ (\137), ? (\077) are used in the encoded word. + ;; Avoid using 8bit characters. + ;; This list excludes `especials' (see the RFC2047 syntax), + ;; meaning that some characters in non-structured fields will + ;; get encoded when they con't need to be. The following is + ;; what it used to be. +;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" +;;; "\010\012\014\040-\074\076\100-\136\140-\177") + "-\b\n\f !#-'*+0-9A-Z\\^`-~\d") + (subst-char-in-region (point-min) (point-max) ? ?_) ;; The size of QP encapsulation is about 20, so set limit to ;; 56=76-20. (unless (< (- (point-max) (point-min)) 56) @@ -485,15 +608,27 @@ (goto-char (min (point-max) (+ 56 bol))) (search-backward "=" (- (point) 2) t) (unless (or (bobp) (eobp)) - (insert "\n") + (insert ?\n) (setq bol (point))))))))) ;;; ;;; Functions for decoding RFC2047 messages ;;; -(defvar rfc2047-encoded-word-regexp - "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]+\\)\\?=") +(eval-and-compile + (defconst rfc2047-encoded-word-regexp + "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\ +\\?\\([!->@-~ +]*\\)\\?=")) + +;; Fixme: This should decode in place, not cons intermediate strings. +;; Also check whether it needs to worry about delimiting fields like +;; encoding. + +;; In fact it's reported that (invalid) encoding of mailboxes in +;; addr-specs is in use, so delimiting fields might help. Probably +;; not decoding a word which isn't properly delimited is good enough +;; and worthwhile (is it more correct or not?), e.g. something like +;; `=?iso-8859-1?q?foo?=@'. (defun rfc2047-decode-region (start end) "Decode MIME-encoded words in region between START and END." @@ -506,9 +641,10 @@ (goto-char (point-min)) ;; Remove whitespace between encoded words. (while (re-search-forward - (concat "\\(" rfc2047-encoded-word-regexp "\\)" - "\\(\n?[ \t]\\)+" - "\\(" rfc2047-encoded-word-regexp "\\)") + (eval-when-compile + (concat "\\(" rfc2047-encoded-word-regexp "\\)" + "\\(\n?[ \t]\\)+" + "\\(" rfc2047-encoded-word-regexp "\\)")) nil t) (delete-region (goto-char (match-end 1)) (match-beginning 6))) ;; Decode the encoded words. @@ -519,8 +655,17 @@ (prog1 (match-string 0) (delete-region (match-beginning 0) (match-end 0))))) + ;; Remove newlines between decoded words, though such things + ;; essentially must not be there. + (save-restriction + (narrow-to-region e (point)) + (goto-char e) + (while (re-search-forward "[\n\r]+" nil t) + (replace-match " ")) + (goto-char (point-max))) (when (and (mm-multibyte-p) mail-parse-charset + (not (eq mail-parse-charset 'us-ascii)) (not (eq mail-parse-charset 'gnus-decoded))) (mm-decode-coding-region b e mail-parse-charset)) (setq b (point))) @@ -528,23 +673,37 @@ mail-parse-charset (not (eq mail-parse-charset 'us-ascii)) (not (eq mail-parse-charset 'gnus-decoded))) - (mm-decode-coding-region b (point-max) mail-parse-charset)) - (rfc2047-unfold-region (point-min) (point-max)))))) + (mm-decode-coding-region b (point-max) mail-parse-charset)))))) (defun rfc2047-decode-string (string) "Decode the quoted-printable-encoded STRING and return the results." (let ((m (mm-multibyte-p))) - (with-temp-buffer - (when m - (mm-enable-multibyte)) - (insert string) - (inline - (rfc2047-decode-region (point-min) (point-max))) - (buffer-string)))) + (if (string-match "=\\?" string) + (with-temp-buffer + ;; Fixme: This logic is wrong, but seems to be required by + ;; Gnus summary buffer generation. The value of `m' depends + ;; on the current buffer, not global multibyteness or that + ;; of the string. Also the string returned should always be + ;; multibyte in a multibyte session, i.e. the buffer should + ;; be multibyte before `buffer-string' is called. + (when m + (mm-enable-multibyte)) + (insert string) + (inline + (rfc2047-decode-region (point-min) (point-max))) + (buffer-string)) + ;; Fixme: As above, `m' here is inappropriate. + (if (and m + mail-parse-charset + (not (eq mail-parse-charset 'us-ascii)) + (not (eq mail-parse-charset 'gnus-decoded))) + (mm-decode-coding-string string mail-parse-charset) + (mm-string-as-multibyte string))))) (defun rfc2047-parse-and-decode (word) "Decode WORD and return it if it is an encoded word. -Return WORD if not." +Return WORD if it is not not an encoded word or if the charset isn't +decodable." (if (not (string-match rfc2047-encoded-word-regexp word)) word (or @@ -554,7 +713,18 @@ (upcase (match-string 2 word)) (match-string 3 word)) (error word)) - word))) + word))) ; un-decodable + +(defun rfc2047-pad-base64 (string) + "Pad STRING to quartets." + ;; Be more liberal to accept buggy base64 strings. If + ;; base64-decode-string accepts buggy strings, this function could + ;; be aliased to identity. + (case (mod (length string) 4) + (0 string) + (1 string) ;; Error, don't pad it. + (2 (concat string "==")) + (3 (concat string "=")))) (defun rfc2047-decode (charset encoding string) "Decode STRING from the given MIME CHARSET in the given ENCODING. @@ -576,18 +746,16 @@ (when (and (eq cs 'ascii) mail-parse-charset) (setq cs mail-parse-charset)) - ;; Ensure unibyte result in Emacs 20. - (let (default-enable-multibyte-characters) - (with-temp-buffer - (mm-decode-coding-string - (cond - ((equal "B" encoding) - (base64-decode-string string)) - ((equal "Q" encoding) - (quoted-printable-decode-string - (mm-replace-chars-in-string string ?_ ? ))) - (t (error "Invalid encoding: %s" encoding))) - cs)))))) + (mm-decode-coding-string + (cond + ((equal "B" encoding) + (base64-decode-string + (rfc2047-pad-base64 string))) + ((equal "Q" encoding) + (quoted-printable-decode-string + (mm-replace-chars-in-string string ?_ ? ))) + (t (error "Invalid encoding: %s" encoding))) + cs)))) (provide 'rfc2047)
--- a/lisp/gnus/rfc2231.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/rfc2231.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ -;;; rfc2231.el --- functions for decoding rfc2231 headers +;;; rfc2231.el --- Functions for decoding rfc2231 headers -;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; This file is part of GNU Emacs. @@ -26,11 +26,20 @@ (eval-when-compile (require 'cl)) (require 'ietf-drums) +(require 'rfc2047) +(autoload 'mm-encode-body "mm-bodies") +(autoload 'mail-header-remove-whitespace "mail-parse") +(autoload 'mail-header-remove-comments "mail-parse") (defun rfc2231-get-value (ct attribute) "Return the value of ATTRIBUTE from CT." (cdr (assq attribute (cdr ct)))) +(defun rfc2231-parse-qp-string (string) + "Parse QP-encoded string using `rfc2231-parse-string'. +N.B. This is in violation with RFC2047, but it seem to be in common use." + (rfc2231-parse-string (rfc2047-decode-string string))) + (defun rfc2231-parse-string (string) "Parse STRING and return a list. The list will be on the form @@ -47,6 +56,7 @@ (mail-header-remove-comments string))) (let ((table (copy-syntax-table ietf-drums-syntax-table))) (modify-syntax-entry ?\' "w" table) + (modify-syntax-entry ?= " " table) ;; The following isn't valid, but one should be liberal ;; in what one receives. (modify-syntax-entry ?\: "w" table) @@ -79,7 +89,9 @@ (when (eq c ?*) (forward-char 1) (setq c (char-after)) - (when (memq c ntoken) + (if (not (memq c ntoken)) + (setq encoded t + number nil) (setq number (string-to-number (buffer-substring @@ -104,10 +116,11 @@ (setq value (buffer-substring (1+ (point)) (progn (forward-sexp 1) (1- (point)))))) - ((and (memq c ttoken) + ((and (or (memq c ttoken) + (> c ?\177)) ;; EXTENSION: Support non-ascii chars. (not (memq c stoken))) (setq value (buffer-substring - (point) (progn (forward-sexp 1) (point))))) + (point) (progn (forward-sexp) (point))))) (t (error "Invalid header: %s" string))) (when encoded @@ -140,10 +153,11 @@ (string-to-number (buffer-substring (point) (+ (point) 2)) 16) (delete-region (1- (point)) (+ (point) 2))))) ;; Encode using the charset, if any. - (when (and (< (length elems) 1) - (not (equal (intern (car elems)) 'us-ascii))) + (when (and (mm-multibyte-p) + (> (length elems) 1) + (not (equal (intern (downcase (car elems))) 'us-ascii))) (mm-decode-coding-region (point-min) (point-max) - (intern (car elems)))) + (intern (downcase (car elems))))) (buffer-string)))) (defun rfc2231-encode-string (param value) @@ -175,7 +189,7 @@ (goto-char (point-min)) (while (not (eobp)) (when (> (current-column) 60) - (insert "\n") + (insert ";\n") (setq broken t)) (if (or (not (memq (following-char) ascii)) (memq (following-char) control) @@ -187,12 +201,13 @@ (delete-char 1)) (forward-char 1))) (goto-char (point-min)) - (insert (or charset "ascii") "''") + (insert (symbol-name (or charset 'us-ascii)) "''") (goto-char (point-min)) (if (not broken) (insert param "*=") (while (not (eobp)) - (insert param "*" (format "%d" (incf num)) "*=") + (insert (if (>= num 0) " " "\n ") + param "*" (format "%d" (incf num)) "*=") (forward-line 1)))) (spacep (goto-char (point-min))
--- a/lisp/gnus/rot13.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/rot13.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,50 +1,32 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 20 1", -" c Gray0", -". c Gray6", -"X c Gray12", -"o c #2ff52ff52ff5", -"O c #3fff3fff3fff", -"+ c Gray28", -"@ c #53e353e353e3", -"# c #5fe45fe45fe4", -"$ c #67e767e767e7", -"% c #6fff6fff6fff", -"& c #77d777d777d7", -"* c Gray50", -"= c Gray56", -"- c #9fff9fff9fff", -"; c Gray70", -": c Gray75", -"> c Gray81", -", c #dfffdfffdfff", -"< c #efffefffefff", -"1 c Gray100", -/* pixels */ -"::::::::::::::::::::::::", -"::::::::::::::::::::::::", -"::::::::::::::::::::::::", -"::::#oOOOOOOOOOo+;::::::", -"::::#:,*,,**11-#O$::::::", -"::::#:#:#:#:%--=*>@:::::", -"::::#:o:o:*%>*:>OOo#::::", -"::::#:X*X:O*-:**:1:#::::", -"::::#:>1><::11>:,1:#::::", -"::::#:>-111%111%11:#::::", -"::::#:*:-1:*1:*-11:#::::", -"::::#: *O>*:%*=--1:#::::", -"::::#:O* :*1O*o%11:#::::", -"::::#:O:X,**-*:111:#::::", -"::::#:>1>1,:1,<111:#::::", -"::::#:1,oo,1111111:#::::", -"::::#:,O##O*****:1:#::::", -"::::#:: :: *1:#::::", -"::::#:1-..-1:*O:*1:#::::", -"::::#:11--11,:O,:1:#::::", -"::::#:11111111>111:#::::", -"::::&oooooooooooooo&::::", -"::::::::::::::::::::::::", -"::::::::::::::::::::::::" -}; +static char * rot13_xpm[] = { +"24 24 5 1", +" c None", +". c #A5A5A5A59595", +"X c #C7C7C6C6C6C6", +"o c #E1E1E0E0E0E0", +"O c #919187876969", +" ", +" ", +" ", +" . ", +" ..X. ", +" ..XXX. ", +" ..XXXXXo. ", +" ...XXXXXXooo. ", +" .o.XXXXXoooo. ", +" .oo.XXXooOooo. ", +" .oo..XXoOXOOoo. ", +" .oo.XXoOXooOXoo. ", +" .o.XoooOOXXOXooX. ", +" .XXooOOXOOXoooo. ", +" .XooOOOooooooo. ", +" .oOOXOXooooo. ", +" .oOOXoooooo. ", +" .oOOXooo.. ", +" .oooooo. ", +" .ooo.. ", +" .oo. ", +" .. ", +" ", +" "};
--- a/lisp/gnus/save-aif.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/save-aif.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,55 +1,33 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 25 1", -" c Gray6", -". c #133313331333", -"X c #199919991999", -"o c Gray15", -"O c #2fef2fef2fef", -"+ c Gray20", -"@ c #398739873987", -"# c #3fff3fff3fff", -"$ c Gray28", -"% c #4ccc4ccc4ccc", -"& c #5fdf5fdf5fdf", -"* c #626262626262", -"= c Gray40", -"- c #72f272f272f2", -"; c Gray45", -": c #77d777d777d7", -"> c #7bdb7bdb7bdb", -", c #7ccc7ccc7ccc", -"< c Gray56", -"1 c Gray60", -"2 c #9fff9fff9fff", -"3 c #a7c7a7c7a7c7", -"4 c Gray75", -"5 c Gray90", -"6 c Gray100", -/* pixels */ -"444444444444444444444444", -"444444444444444444444444", -"4444444:OOOOOOOOOOO:4444", -"4444444&4666666666#2>444", -"4444444&4666666666#62:44", -"4444444&4666666666 ##O44", -"4444444&4666666666666O44", -"4444444&4666666666666O44", -"4444444&4666666666666O44", -"43<<<<<$<444444666666O44", -"4&@@@-------.%.666666O44", -"4&---5555555o1o666666O44", -"4&---5555555o1o666666O44", -"4&---5555555o1o666666O44", -"4&---5555555o1o666666O44", -"4&---5555555o1o666666O44", -"4&--@-------o1o666666O44", -"4&-<--------,1o666666O44", -"4&-<--------,1o444444O44", -"4&--X++++o@-o1o&&&&&&:44", -"4&--+====%-5o1o444444444", -"4:*-+====%-5o1o444444444", -"44:@X++++o@-.%.444444444", -"444<<<<<<<<<<<<444444444" -}; +static char * save_aif_xpm[] = { +"24 24 6 1", +" c None", +". c #999999999999", +"X c #E1E1E0E0E0E0", +"o c #C7C7C6C6C6C6", +"O c #000000000000", +"+ c #FFFFFFFFFFFF", +" ", +" ", +" ............. ", +" .XXXXXXXXXX.X.. ", +" .XXXXXXXXXX.XX. ", +" .XXXXXXXXXX.... ", +" .XXXXXXXXXXooo. ", +" .XXXXXXXXXXXXX. ", +" .XXXXXXXXXXXXX. ", +" .XXXXXXXXXXXXX. ", +" OOOOOOOOOOOOOOXXXXXX. ", +" O..O+++++++O.OXXXXXX. ", +" O..O+++++++O.OXXXXXX. ", +" O..O+++++++O.OXXXXXX. ", +" O..O+++++++O.OXXXXXX. ", +" O..O+++++++O.OXXXXXX. ", +" O..OOOOOOOOO.OXXXXXX. ", +" O............OXXXXXX. ", +" O............OXXXXXX. ", +" O..OOOOOOOOO.O....... ", +" O..OoooooO++.O ", +" O..OoooooO++.O ", +" O.OoooooO++.O ", +" OOOOOOOOOOOO "};
--- a/lisp/gnus/save-art.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/save-art.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,62 +1,32 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 32 1", -" c Gray0", -". c #133313331333", -"X c #199919991999", -"o c Gray12", -"O c #23f323f323f3", -"+ c Gray15", -"@ c #2fef2fef2fef", -"# c Gray20", -"$ c #398739873987", -"% c #3fff3fff3fff", -"& c #4ccc4ccc4ccc", -"* c #53e353e353e3", -"= c #5fe65fe65fe6", -"- c #626262626262", -"; c Gray40", -": c #6fff6fff6fff", -"> c #72f272f272f2", -", c Gray45", -"< c #77d777d777d7", -"1 c #7ccc7ccc7ccc", -"2 c Gray50", -"3 c Gray56", -"4 c Gray60", -"5 c #9bcb9bcb9bcb", -"6 c #9fff9fff9fff", -"7 c #a7c7a7c7a7c7", -"8 c Gray75", -"9 c Gray81", -"0 c #dfffdfffdfff", -"q c Gray90", -"w c #efffefffefff", -"e c Gray100", -/* pixels */ -"888888888888888888888888", -"888888888888888888888888", -"88888*@@@@@@@@@@@@@@@@@4", -"88888@%28eeeeeeeeee08%o3", -"88888@e8228eeeeeee222e23", -"88888@eee82%eeee6%80ee23", -"88888@eeew8=%28%28eeee23", -"88888@eee220e82e826eee23", -"88888@ee:9eeeeeeee6%9e23", -"87333O3 3888888eeeee:==3", -"8=$$$>>>>>>>.&.eeeeee0%3", -"8=>>>qqqqqqq+4+%%%%%%%o3", -"8=>>>qqqqqqq+4+888888888", -"8=>>>qqqqqqq+4+888888888", -"8=>>>qqqqqqq+4+888888888", -"8=>>>qqqqqqq+4+888888888", -"8=>>$>>>>>>>+4+888888888", -"8=>3>>>>>>>>24+888888888", -"8=>3>>>>>>>>24+888888888", -"8=>>X####+$>+4+888888888", -"8=>>#;;;;&>q+4+888888888", -"8<->#;;;;&>q+4+888888888", -"88<$X####+$>.&.888888888", -"888333333333333888888888" -}; +static char * save_art_xpm[] = { +"24 24 5 1", +" c None", +". c #000000000000", +"X c #FFFFFFFFFFFF", +"o c #999999999999", +"O c #C7C7C6C6C6C6", +" ", +" ", +" .................. ", +" ...XXXXXXXXXXXXX.. ", +" .XX..XXXXXXXXX..X. ", +" .XXXX..XXXXX..XXX. ", +" .XXXXX......XXXXX. ", +" .XXX..XX..XX..XXX. ", +" .XX..XXXXXXXX..XX. ", +" ...XXXXXXXXXXXX... ", +" ..............XXXXXXX. ", +" .oo.XXXXXXX.o......... ", +" .oo.XXXXXXX.o. ", +" .oo.XXXXXXX.o. ", +" .oo.XXXXXXX.o. ", +" .oo.XXXXXXX.o. ", +" .oo.........o. ", +" .oooooooooooo. ", +" .oooooooooooo. ", +" .oo.........o. ", +" .oo.OOOOO.XXo. ", +" .oo.OOOOO.XXo. ", +" .o.OOOOO.XXo. ", +" ............ "};
--- a/lisp/gnus/score-mode.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/score-mode.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,5 +1,6 @@ ;;; score-mode.el --- mode for editing Gnus score files -;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Copyright (C) 1996, 2001 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news, mail @@ -26,7 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl)) -(require 'mm-util) ; for mm-auto-save-coding-system +(require 'mm-util) ; for mm-universal-coding-system (defvar gnus-score-mode-hook nil "*Hook run in score mode buffers.") @@ -52,7 +53,7 @@ "Syntax table used in score-mode buffers.") ;; We need this to cope with non-ASCII scoring. -(defvar score-mode-coding-system mm-auto-save-coding-system) +(defvar score-mode-coding-system mm-universal-coding-system) ;;;###autoload (defun gnus-score-mode ()
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/sha1-el.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,445 @@ +;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp. + +;; Copyright (C) 1999, 2001, 2003 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. +;;; + +(defgroup sha1 nil + "Elisp interface for SHA1 hash computation." + :group 'extensions) + +(defcustom 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." + :type 'integer + :group 'sha1) + +(defcustom sha1-program '("sha1sum") + "*Name of program to compute SHA1. +It must be a string \(program name\) or list of strings \(name and its args\)." + :type '(repeat string) + :group 'sha1) + +(defcustom sha1-use-external (condition-case () + (executable-find (car sha1-program)) + (error)) + "*Use external SHA1 program. +If this variable is set to nil, use internal function only." + :type 'boolean + :group 'sha1) + +(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))) + +;;;###autoload +(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) + +;;; arch-tag: c0f9abd0-ffc1-4557-aac6-ece7f2d4c901 +;;; sha1-el.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/sieve-manage.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,616 @@ +;;; 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") + (autoload 'starttls-negotiate "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) + +;;; arch-tag: 321c4640-1371-4495-9baf-8ccb71dd5bd1 +;; sieve-manage.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/sieve-mode.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,205 @@ +;;; 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) + +;;; arch-tag: 3b8ab76d-065d-4c52-b1e8-ab2ec21f2ace +;; sieve-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/sieve.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,384 @@ +;;; 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)) + +(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map + "Sieve Menu." + '("Manage Sieve" + ["Edit script" sieve-edit-script t] + ["Activate script" sieve-activate t] + ["Deactivate script" sieve-deactivate t])) + +(define-derived-mode sieve-manage-mode fundamental-mode "SIEVE" + "Mode used for sieve script management." + (setq mode-name "SIEVE") + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (easy-menu-add-item nil nil sieve-manage-mode-menu)) + +(put 'sieve-manage-mode 'mode-class 'special) + +;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] +;; in substitute-command-keys. +;(fset 'sieve-manage-mode-map sieve-manage-mode-map) + +;; Commands used in sieve-manage mode: + +(defun sieve-activate (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (when (or (null name) (string-equal name sieve-new-script)) + (error "No sieve script at point")) + (message "Activating script %s..." name) + (setq err (sieve-manage-setactive name sieve-manage-buffer)) + (sieve-refresh-scriptlist) + (if (sieve-manage-ok-p err) + (message "Activating script %s...done" name) + (message "Activating script %s...failed: %s" name (nth 2 err))))) + +(defun sieve-deactivate-all (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (message "Deactivating scripts...") + (setq err (sieve-manage-setactive "" sieve-manage-buffer)) + (sieve-refresh-scriptlist) + (if (sieve-manage-ok-p err) + (message "Deactivating scripts...done") + (message "Deactivating scripts...failed" (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) + +;;; arch-tag: 7f6a6d94-94e1-4654-ab9a-aee21b9b8a94 +;; sieve.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/smiley.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,171 @@ +;;; smiley.el --- displaying smiley faces + +;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + +;; Author: Dave Love <fx@gnu.org> +;; Keywords: news mail multimedia + +;; 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: + +;; A re-written, simplified version of Wes Hardaker's XEmacs smiley.el +;; which might be merged back to smiley.el if we get an assignment for +;; that. We don't have assignments for the images smiley.el uses, but +;; I'm not sure we need that degree of rococoness and defaults like a +;; yellow background. Also, using PBM means we can display the images +;; more generally. -- fx + +;;; Test smileys: :-) :-\ :-( :-/ + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'nnheader) +(require 'gnus-art) + +(defgroup smiley nil + "Turn :-)'s into real images." + :group 'gnus-visual) + +;; Maybe this should go. +(defcustom smiley-data-directory (nnheader-find-etc-directory "smilies") + "*Location of the smiley faces files." + :type 'directory + :group 'smiley) + +;; The XEmacs version has a baroque, if not rococo, set of these. +(defcustom smiley-regexp-alist + '(("\\(:-?)\\)\\W" 1 "smile") + ("\\(;-?)\\)\\W" 1 "blink") + ("\\(:-]\\)\\W" 1 "forced") + ("\\(8-)\\)\\W" 1 "braindamaged") + ("\\(:-|\\)\\W" 1 "indifferent") + ("\\(:-[/\\]\\)\\W" 1 "wry") + ("\\(:-(\\)\\W" 1 "sad") + ("\\(:-{\\)\\W" 1 "frown")) + "*A list of regexps to map smilies to images. +The elements are (REGEXP MATCH FILE), where MATCH is the submatch in +regexp to replace with IMAGE. IMAGE is the name of a PBM file in +`smiley-data-directory'." + :type '(repeat (list regexp + (integer :tag "Regexp match number") + (string :tag "Image name"))) + :set (lambda (symbol value) + (set-default symbol value) + (smiley-update-cache)) + :initialize 'custom-initialize-default + :group 'smiley) + +(defcustom gnus-smiley-file-types + (let ((types (list "pbm"))) + (when (gnus-image-type-available-p 'xpm) + (push "xpm" types)) + types) + "*List of suffixes on picon file names to try." + :type '(repeat string) + :group 'smiley) + +(defvar smiley-cached-regexp-alist nil) + +(defun smiley-update-cache () + (dolist (elt (if (symbolp smiley-regexp-alist) + (symbol-value smiley-regexp-alist) + smiley-regexp-alist)) + (let ((types gnus-smiley-file-types) + file type) + (while (and (not file) + (setq type (pop types))) + (unless (file-exists-p + (setq file (expand-file-name (concat (nth 2 elt) "." type) + smiley-data-directory))) + (setq file nil))) + (when type + (let ((image (gnus-create-image file (intern type) nil + :ascent 'center))) + (when image + (push (list (car elt) (cadr elt) image) + smiley-cached-regexp-alist))))))) + +(defvar smiley-mouse-map + (let ((map (make-sparse-keymap))) + (define-key map [down-mouse-2] 'ignore) ; override widget + (define-key map [mouse-2] + 'smiley-mouse-toggle-buffer) + map)) + +;;;###autoload +(defun smiley-region (start end) + "Replace in the region `smiley-regexp-alist' matches with corresponding images. +A list of images is returned." + (interactive "r") + (when (gnus-graphic-display-p) + (unless smiley-cached-regexp-alist + (smiley-update-cache)) + (save-excursion + (let ((beg (or start (point-min))) + group image images string) + (dolist (entry smiley-cached-regexp-alist) + (setq group (nth 1 entry) + image (nth 2 entry)) + (goto-char beg) + (while (re-search-forward (car entry) end t) + (setq string (match-string group)) + (goto-char (match-end group)) + (delete-region (match-beginning group) (match-end group)) + (when image + (push image images) + (gnus-add-wash-type 'smiley) + (gnus-add-image 'smiley image) + (gnus-put-image image string 'smiley)))) + images)))) + +;;;###autoload +(defun smiley-buffer (&optional buffer) + "Run `smiley-region' at the buffer, specified in the argument or +interactively. If there's no argument, do it at the current buffer" + (interactive "bBuffer to run smiley-region: ") + (save-excursion + (if buffer + (set-buffer (get-buffer buffer))) + (smiley-region (point-min) (point-max)))) + +(defun smiley-toggle-buffer (&optional arg) + "Toggle displaying smiley faces in article buffer. +With arg, turn displaying on if and only if arg is positive." + (interactive "P") + (gnus-with-article-buffer + (if (if (numberp arg) + (> arg 0) + (not (memq 'smiley gnus-article-wash-types))) + (smiley-region (point-min) (point-max)) + (gnus-delete-images 'smiley)))) + +(defun smiley-mouse-toggle-buffer (event) + "Toggle displaying smiley faces. +With arg, turn displaying on if and only if arg is positive." + (interactive "e") + (save-excursion + (save-window-excursion + (mouse-set-point event) + (smiley-toggle-buffer)))) + +(provide 'smiley) + +;;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818 +;;; smiley.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/smime.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,644 @@ +;;; 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) +(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-crl-check nil + "*Check revocation status of signers certificate using CRLs. +Enabling this will have OpenSSL check the signers certificate +against a certificate revocation list (CRL). + +For this to work the CRL must be up-to-date and since they are +normally updated quite often (ie. several times a day) you +probably need some tool to keep them up-to-date. Unfortunately +Gnus cannot do this for you. + +The CRL should either be appended (in PEM format) to your +`smime-CA-file' or be located in a file (also in PEM format) in +your `smime-certificate-directory' named to the X.509 hash of the +certificate with .r0 as file name extension. + +At least OpenSSL version 0.9.7 is required for this to work." + :type '(choice (const :tag "No check" nil) + (const :tag "Check certificate" "-crl_check") + (const :tag "Check certificate chain" "-crl_check_all")) + :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*") + +;; Use mm-util? +(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 + (read-passwd + "Passphrase for secret key (RET for no passphrase): "))) + (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 smime-crl-check + (add-to-list 'CAs smime-crl-check)) + (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))))) + +;; Use mm-util? +(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) + +;;; arch-tag: e3f9b938-5085-4510-8a11-6625269c9a9e +;;; smime.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/spam-report.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,127 @@ +;;; spam-report.el --- Reporting spam +;; Copyright (C) 2002, 2003, 2004 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) + +(eval-and-compile + (autoload 'mm-url-insert "mm-url")) + +(defgroup spam-report nil + "Spam reporting configuration.") + +(defcustom spam-report-gmane-regex nil + "Regexp matching Gmane newsgroups, e.g. \"^nntp\\+.*:gmane\\.\" +If you are using spam.el, consider setting gnus-spam-process-newsgroups +or the gnus-group-spam-exit-processor-report-gmane group/topic parameter +instead." + :type '(radio (const nil) + (regexp :format "%t: %v\n" :size 0 :value "^nntp\+.*:gmane\.")) + :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) + +(defcustom spam-report-url-ping-function + 'spam-report-url-ping-plain + "Function to use for url ping spam reporting." + :type '(choice + (const :tag "Connect directly" + spam-report-url-ping-plain) + (const :tag "Use the external program specified in `mm-url-program'" + spam-report-url-ping-mm-url)) + :group 'spam-report) + +(defun spam-report-gmane (&rest articles) + "Report an article as spam through Gmane" + (dolist (article articles) + (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 7 "Reporting spam through URL %s..." url) + (spam-report-url-ping host report)) + (gnus-message 3 "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 using +the function specified by `spam-report-url-ping-function'." + (funcall spam-report-url-ping-function host report)) + +(defun spam-report-url-ping-plain (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\nUser-Agent: %s (spam-report.el)\nHost: %s\n\n" + report (gnus-emacs-version) host))))) + +(defun spam-report-url-ping-mm-url (host report) + "Ping a host through HTTP, addressing a specific GET resource. Use +the external program specified in `mm-url-program' to connect to +server." + (with-temp-buffer + (let ((url (concat "http://" host "/" report))) + (mm-url-insert url t)))) + +(provide 'spam-report) + +;;; arch-tag: f6683295-ec89-4ab5-8803-8cc842293022 +;;; spam-report.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/spam-stat.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,598 @@ +;;; 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> + + + +;;; 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-dirty nil + "Whether the spam-stat database needs saving.") + +(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))) + +;; 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)) + (setq spam-stat-dirty t)) + +(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)) + (setq spam-stat-dirty t)) + +(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)) + (setq spam-stat-dirty t)) + +(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)) + (setq spam-stat-dirty t)) + +;; Saving and Loading + +(defun spam-stat-save (&optional force) + "Save the `spam-stat' hash table as lisp file." + (interactive) + (when (or force spam-stat-dirty) + (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))) + (setq spam-stat-dirty nil))) + +(defun spam-stat-load () + "Read the `spam-stat' hash table from disk." + ;; TODO: maybe we should warn the user if spam-stat-dirty is t? + (load-file spam-stat-file) + (setq spam-stat-dirty nil)) + +(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) + (setq spam-stat-dirty t)) + +;; 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)) + +(defun spam-stat-install-hooks-function () + "Install the spam-stat function hooks" + (interactive) + (add-hook 'nnmail-prepare-incoming-message-hook + 'spam-stat-store-current-buffer) + (add-hook 'gnus-select-article-hook + 'spam-stat-store-gnus-article-buffer)) + +(when spam-stat-install-hooks + (spam-stat-install-hooks-function)) + +(defun spam-stat-unload-hook () + "Uninstall the spam-stat function hooks" + (interactive) + (remove-hook 'nnmail-prepare-incoming-message-hook + 'spam-stat-store-current-buffer) + (remove-hook 'gnus-select-article-hook + 'spam-stat-store-gnus-article-buffer)) + +(provide 'spam-stat) + +;;; arch-tag: ff1d2200-8ddb-42fb-bb7b-1b5e20448554 +;;; spam-stat.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/spam.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,1827 @@ +;;; spam.el --- Identifying spam +;; Copyright (C) 2002, 2003, 2004 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 + +;; TODO: spam scores, detection of spam in newsgroups, cross-server splitting, +;; remote processing, training through files + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus-sum) + +(require 'gnus-uu) ; because of key prefix issues +;;; for the definitions of group content classification and spam processors +(require 'gnus) +(require 'message) ;for the message-fetch-field functions + +;; for nnimap-split-download-body-default +(eval-when-compile (require 'nnimap)) + +;; autoload executable-find +(eval-and-compile + ;; executable-find is not autoloaded in Emacs 20 + (autoload 'executable-find "executable")) + +;; autoload query-dig +(eval-and-compile + (autoload 'query-dig "dig")) + +;; autoload spam-report +(eval-and-compile + (autoload 'spam-report-gmane "spam-report")) + +;; autoload gnus-registry +(eval-and-compile + (autoload 'gnus-registry-group-count "gnus-registry") + (autoload 'gnus-registry-add-group "gnus-registry") + (autoload 'gnus-registry-store-extra-entry "gnus-registry") + (autoload 'gnus-registry-fetch-extra "gnus-registry")) + +;; 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 t, only ham and unclassified groups will have their spam moved +to the spam-process-destination. When nil, spam will also be moved from +spam groups." + :type 'boolean + :group 'spam) + +(defcustom spam-process-ham-in-nonham-groups nil + "Whether ham should be processed in non-ham groups." + :type 'boolean + :group 'spam) + +(defcustom spam-log-to-registry nil + "Whether spam/ham processing should be logged in the registry." + :type 'boolean + :group 'spam) + +(defcustom spam-split-symbolic-return nil + "Whether `spam-split' should work with symbols or group names." + :type 'boolean + :group 'spam) + +(defcustom spam-split-symbolic-return-positive nil + "Whether `spam-split' should ALWAYS work with symbols or group names. +Do not set this if you use `spam-split' in a fancy split + method." + :type 'boolean + :group 'spam) + +(defcustom spam-process-ham-in-spam-groups nil + "Whether ham should be processed in 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. +The article is 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-disable-spam-split-during-ham-respool nil + "Whether `spam-split' should be ignored while resplitting ham in a process +destination. This is useful to prevent ham from ending up in the same spam +group after the resplit. Don't set this to t if you have spam-split as the +last rule in your split configuration." + :type 'boolean + :group 'spam) + +(defcustom spam-autodetect-recheck-messages nil + "Should spam.el recheck all meessages when autodetecting? +Normally this is nil, so only unseen messages will be checked." + :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-blacklist-ignored-regexes nil + "Regular expressions that the blacklist should ignore." + :type '(repeat (regexp :tag "Regular expression to ignore when blacklisting")) + :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 variables `spam-regex-headers-spam' and `spam-regex-headers-ham'." + :type 'boolean + :group 'spam) + +(defcustom spam-use-regex-body nil + "Whether a body regular expression match should be used by `spam-split'. +Also see the variables `spam-regex-body-spam' and `spam-regex-body-ham'." + :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-use-spamoracle nil + "Whether spamoracle should be used by `spam-split'." + :type 'boolean + :group 'spam) + +(defcustom spam-install-hooks (or + spam-use-dig + spam-use-blacklist + spam-use-whitelist + spam-use-whitelist-exclusive + spam-use-blackholes + spam-use-hashcash + spam-use-regex-headers + spam-use-regex-body + spam-use-bogofilter-headers + spam-use-bogofilter + spam-use-BBDB + spam-use-BBDB-exclusive + spam-use-ifile + spam-use-stat + spam-use-spamoracle) + "Whether the spam hooks should be installed. +Default to t if one of the spam-use-* variables is set." + :group 'spam + :type 'boolean) + +(defcustom spam-split-group "spam" + "Group name where incoming spam should be put by `spam-split'." + :type 'string + :group 'spam) + +;;; TODO: deprecate this variable, it's confusing since it's a list of strings, +;;; not regular expressions +(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 '(radio (const nil) + (regexp :format "%t: %v\n" :size 0)) + :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) + +(defcustom spam-regex-body-spam '() + "Regular expression for positive body spam matches." + :type '(repeat (regexp :tag "Regular expression to match spam body")) + :group 'spam) + +(defcustom spam-regex-body-ham '() + "Regular expression for positive body ham matches." + :type '(repeat (regexp :tag "Regular expression to match ham body")) + :group 'spam) + +(defgroup spam-ifile nil + "Spam ifile configuration." + :group 'spam) + +(defcustom spam-ifile-path (executable-find "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 (executable-find "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-spam-strong-switch "-S" + "The switch that Bogofilter uses to unregister ham messages." + :type 'string + :group 'spam-bogofilter) + +(defcustom spam-bogofilter-ham-strong-switch "-N" + "The switch that Bogofilter uses to unregister spam 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-bogofilter) + +(defgroup spam-spamoracle nil + "Spam spamoracle configuration." + :group 'spam) + +(defcustom spam-spamoracle-database nil + "Location of spamoracle database file. When nil, use the default +spamoracle database." + :type '(choice (directory :tag "Location of spamoracle database file.") + (const :tag "Use the default")) + :group 'spam-spamoracle) + +(defcustom spam-spamoracle-binary (executable-find "spamoracle") + "Location of the spamoracle binary." + :type '(choice (directory :tag "Location of the spamoracle binary") + (const :tag "Use the default")) + :group 'spam-spamoracle) + +;;; 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) + +(defvar spam-old-ham-articles nil + "List of old ham articles, generated when a group is entered.") + +(defvar spam-old-spam-articles nil + "List of old spam articles, generated when a group is entered.") + +(defvar spam-split-disabled nil + "If non-nil, `spam-split' is disabled, and always returns nil.") + +(defvar spam-split-last-successful-check nil + "`spam-split' will set this to nil or a spam-use-XYZ check if it + finds ham or spam.") + +;; convenience functions +(defun spam-xor (a b) + "Logical exclusive `or'." + (and (or a b) (not (and a b)))) + +(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)) + +(defvar spam-list-of-processors + '((gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) + (gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) + (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist) + (gnus-group-spam-exit-processor-ifile spam spam-use-ifile) + (gnus-group-spam-exit-processor-stat spam spam-use-stat) + (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle) + (gnus-group-ham-exit-processor-ifile ham spam-use-ifile) + (gnus-group-ham-exit-processor-bogofilter ham spam-use-bogofilter) + (gnus-group-ham-exit-processor-stat ham spam-use-stat) + (gnus-group-ham-exit-processor-whitelist ham spam-use-whitelist) + (gnus-group-ham-exit-processor-BBDB ham spam-use-BBDB) + (gnus-group-ham-exit-processor-copy ham spam-use-ham-copy) + (gnus-group-ham-exit-processor-spamoracle ham spam-use-spamoracle)) + "The spam-list-of-processors list contains pairs associating a +ham/spam exit processor variable with a classification and a +spam-use-* variable.") + +(defun spam-group-processor-p (group processor) + (if (and (stringp group) + (symbolp processor)) + (or (member processor (nth 0 (gnus-parameter-spam-process group))) + (spam-group-processor-multiple-p + group + (cdr-safe (assoc processor spam-list-of-processors)))) + nil)) + +(defun spam-group-processor-multiple-p (group processor-info) + (let* ((classification (nth 0 processor-info)) + (check (nth 1 processor-info)) + (parameters (nth 0 (gnus-parameter-spam-process group))) + found) + (dolist (parameter parameters) + (when (and (null found) + (listp parameter) + (eq classification (nth 0 parameter)) + (eq check (nth 1 parameter))) + (setq found t))) + found)) + +(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-spam-processor-spamoracle-p (group) + (spam-group-processor-p group 'gnus-group-spam-exit-processor-spamoracle)) + +(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)) + +(defun spam-group-ham-processor-spamoracle-p (group) + (spam-group-processor-p group 'gnus-group-ham-exit-processor-spamoracle)) + +;;; Summary entry and exit processing. + +(defun spam-summary-prepare () + (setq spam-old-ham-articles + (spam-list-articles gnus-newsgroup-articles 'ham)) + (setq spam-old-spam-articles + (spam-list-articles gnus-newsgroup-articles 'spam)) + (spam-mark-junk-as-spam-routine)) + +;; 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") + + ;; first of all, unregister any articles that are no longer ham or spam + ;; we have to iterate over the processors, or else we'll be too slow + (dolist (classification '(spam ham)) + (let* ((old-articles (if (eq classification 'spam) + spam-old-spam-articles + spam-old-ham-articles)) + (new-articles (spam-list-articles + gnus-newsgroup-articles + classification)) + (changed-articles (gnus-set-difference old-articles new-articles))) + ;; now that we have the changed articles, we go through the processors + (dolist (processor-param spam-list-of-processors) + (let ((processor (nth 0 processor-param)) + (processor-classification (nth 1 processor-param)) + (check (nth 2 processor-param)) + unregister-list) + (dolist (article changed-articles) + (let ((id (spam-fetch-field-message-id-fast article))) + (when (spam-log-unregistration-needed-p + id 'process classification check) + (push article unregister-list)))) + ;; call spam-register-routine with specific articles to unregister, + ;; when there are articles to unregister and the check is enabled + (when (and unregister-list (symbol-value check)) + (spam-register-routine classification check t unregister-list)))))) + + ;; find all the spam processors applicable to this group + (dolist (processor-param spam-list-of-processors) + (let ((processor (nth 0 processor-param)) + (classification (nth 1 processor-param)) + (check (nth 2 processor-param))) + (when (and (eq 'spam classification) + (spam-group-processor-p gnus-newsgroup-name processor)) + (spam-register-routine classification check)))) + + (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 (or (spam-group-ham-contents-p gnus-newsgroup-name) + (and (spam-group-spam-contents-p gnus-newsgroup-name) + spam-process-ham-in-spam-groups) + spam-process-ham-in-nonham-groups) + ;; find all the ham processors applicable to this group + (dolist (processor-param spam-list-of-processors) + (let ((processor (nth 0 processor-param)) + (classification (nth 1 processor-param)) + (check (nth 2 processor-param))) + (when (and (eq 'ham classification) + (spam-group-processor-p gnus-newsgroup-name processor)) + (spam-register-routine classification check))))) + + (when (spam-group-ham-processor-copy-p gnus-newsgroup-name) + (gnus-message 5 "Copying ham") + (spam-ham-copy-routine + (gnus-parameter-ham-process-destination gnus-newsgroup-name))) + + ;; 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)))) + + (setq spam-old-ham-articles nil) + (setq spam-old-spam-articles nil)) + +(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 (&rest groups) + (if (and (car-safe groups) (listp (car-safe groups))) + (apply 'spam-mark-spam-as-expired-and-move-routine (car groups)) + (gnus-summary-kill-process-mark) + (let ((articles gnus-newsgroup-articles) + (backend-supports-deletions + (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name)) + article tomove deletep) + (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 copies + (dolist (group groups) + (when (and tomove + (stringp group)) + (dolist (article tomove) + (gnus-summary-set-process-mark article)) + (when tomove + (if (or (not backend-supports-deletions) + (> (length groups) 1)) + (progn + (gnus-summary-copy-article nil group) + (setq deletep t)) + (gnus-summary-move-article nil group))))) + + ;; now delete the articles, if there was a copy done, and the + ;; backend allows it + (when (and deletep backend-supports-deletions) + (dolist (article tomove) + (gnus-summary-set-process-mark article)) + (when tomove + (let ((gnus-novice-user nil)) ; don't ask me if I'm sure + (gnus-summary-delete-article nil)))) + + (gnus-summary-yank-process-mark)))) + +(defun spam-ham-copy-or-move-routine (copy groups) + (gnus-summary-kill-process-mark) + (let ((todo (spam-list-articles gnus-newsgroup-articles 'ham)) + (backend-supports-deletions + (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name)) + (respool-method (gnus-find-method-for-group gnus-newsgroup-name)) + article mark todo deletep respool) + + (when (member 'respool groups) + (setq respool t) ; boolean for later + (setq groups '("fake"))) ; when respooling, groups are dynamic so fake it + + ;; now do the actual move + (dolist (group groups) + (when (and todo (stringp group)) + (dolist (article todo) + (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 respool ; respooling is with a "fake" group + (let ((spam-split-disabled + (or spam-split-disabled + spam-disable-spam-split-during-ham-respool))) + (gnus-summary-respool-article nil respool-method)) + (if (or (not backend-supports-deletions) ; else, we are not respooling + (> (length groups) 1)) + (progn ; if copying, copy and set deletep + (gnus-summary-copy-article nil group) + (setq deletep t)) + (gnus-summary-move-article nil group))))) ; else move articles + + ;; now delete the articles, unless a) copy is t, and there was a copy done + ;; b) a move was done to a single group + ;; c) backend-supports-deletions is nil + (unless copy + (when (and deletep backend-supports-deletions) + (dolist (article todo) + (gnus-summary-set-process-mark article)) + (when todo + (let ((gnus-novice-user nil)) ; don't ask me if I'm sure + (gnus-summary-delete-article nil)))))) + + (gnus-summary-yank-process-mark)) + +(defun spam-ham-copy-routine (&rest groups) + (if (and (car-safe groups) (listp (car-safe groups))) + (apply 'spam-ham-copy-routine (car groups)) + (spam-ham-copy-or-move-routine t groups))) + +(defun spam-ham-move-routine (&rest groups) + (if (and (car-safe groups) (listp (car-safe groups))) + (apply 'spam-ham-move-routine (car groups)) + (spam-ham-copy-or-move-routine nil groups))) + +(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)) + +(defun spam-fetch-field-message-id-fast (article) + "Fetch the `Message-ID' field quickly, using the internal + gnus-data-list function" + (if (and (numberp article) + (assoc article (gnus-data-list nil))) + (mail-header-message-id + (gnus-data-header (assoc article (gnus-data-list nil)))) + nil)) + + +;;;; Spam determination. + +(defvar spam-list-of-checks + '((spam-use-blacklist . spam-check-blacklist) + (spam-use-regex-headers . spam-check-regex-headers) + (spam-use-regex-body . spam-check-regex-body) + (spam-use-whitelist . spam-check-whitelist) + (spam-use-BBDB . spam-check-BBDB) + (spam-use-ifile . spam-check-ifile) + (spam-use-spamoracle . spam-check-spamoracle) + (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 or the symbol 'spam (depending on +spam-split-symbolic-return) 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-regex-body + spam-use-stat + spam-use-bogofilter + spam-use-spamoracle) + "The spam-list-of-statistical-checks list contains all the mail +splitters that need to have the full message body available.") + +;;;TODO: modify to invoke self with each check if invoked without specifics +(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 the variable `nnmail-split-fancy', +for example like this: (: spam-split). It can take checks as +parameters. A string as a parameter will set the +spam-split-group to that string. + +See the Info node `(gnus)Fancy Mail Splitting' for more details." + (interactive) + (setq spam-split-last-successful-check nil) + (unless spam-split-disabled + (let ((spam-split-group-choice spam-split-group)) + (dolist (check specific-checks) + (when (stringp check) + (setq spam-split-group-choice check) + (setq specific-checks (delq check specific-checks)))) + + (let ((spam-split-group spam-split-group-choice)) + (save-excursion + (save-restriction + (dolist (check spam-list-of-statistical-checks) + (when (and (symbolp check) (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 we got a decision at all, save the current check + (when decision + (setq spam-split-last-successful-check (car pair))) + + (when (eq decision 'spam) + (if spam-split-symbolic-return + (setq decision spam-split-group) + (gnus-error + 5 + (format "spam-split got %s but %s is nil" + (symbol-name decision) + (symbol-name spam-split-symbolic-return)))))))) + (if (eq decision t) + (if spam-split-symbolic-return-positive 'ham nil) + decision)))))))) + +(defun spam-find-spam () + "This function will detect spam in the current newsgroup using spam-split." + (interactive) + + (let* ((group gnus-newsgroup-name) + (autodetect (gnus-parameter-spam-autodetect group)) + (methods (gnus-parameter-spam-autodetect-methods group)) + (first-method (nth 0 methods))) + (when (and autodetect + (not (equal first-method 'none))) + (mapcar + (lambda (article) + (let ((id (spam-fetch-field-message-id-fast article)) + (subject (spam-fetch-field-subject-fast article)) + (sender (spam-fetch-field-from-fast article))) + (unless (and spam-log-to-registry + (spam-log-registered-p id 'incoming)) + (let* ((spam-split-symbolic-return t) + (spam-split-symbolic-return-positive t) + (split-return + (with-temp-buffer + (gnus-request-article-this-buffer + article + group) + (if (or (null first-method) + (equal first-method 'default)) + (spam-split) + (apply 'spam-split methods))))) + (if (equal split-return 'spam) + (gnus-summary-mark-article article gnus-spam-mark)) + + (when (and split-return spam-log-to-registry) + (when (zerop (gnus-registry-group-count id)) + (gnus-registry-add-group + id group subject sender)) + + (spam-log-processing-to-registry + id + 'incoming + split-return + spam-split-last-successful-check + group)))))) + (if spam-autodetect-recheck-messages + gnus-newsgroup-articles + gnus-newsgroup-unseen))))) + +(defvar spam-registration-functions + ;; first the ham register, second the spam register function + ;; third the ham unregister, fourth the spam unregister function + '((spam-use-blacklist nil + spam-blacklist-register-routine + nil + spam-blacklist-unregister-routine) + (spam-use-whitelist spam-whitelist-register-routine + nil + spam-whitelist-unregister-routine + nil) + (spam-use-BBDB spam-BBDB-register-routine + nil + spam-BBDB-unregister-routine + nil) + (spam-use-ifile spam-ifile-register-ham-routine + spam-ifile-register-spam-routine + spam-ifile-unregister-ham-routine + spam-ifile-unregister-spam-routine) + (spam-use-spamoracle spam-spamoracle-learn-ham + spam-spamoracle-learn-spam + spam-spamoracle-unlearn-ham + spam-spamoracle-unlearn-spam) + (spam-use-stat spam-stat-register-ham-routine + spam-stat-register-spam-routine + spam-stat-unregister-ham-routine + spam-stat-unregister-spam-routine) + ;; note that spam-use-gmane is not a legitimate check + (spam-use-gmane nil + spam-report-gmane-register-routine + ;; does Gmane support unregistration? + nil + nil) + (spam-use-bogofilter spam-bogofilter-register-ham-routine + spam-bogofilter-register-spam-routine + spam-bogofilter-unregister-ham-routine + spam-bogofilter-unregister-spam-routine)) + "The spam-registration-functions list contains pairs +associating a parameter variable with the ham and spam +registration functions, and the ham and spam unregistration +functions") + +(defun spam-classification-valid-p (classification) + (or (eq classification 'spam) + (eq classification 'ham))) + +(defun spam-process-type-valid-p (process-type) + (or (eq process-type 'incoming) + (eq process-type 'process))) + +(defun spam-registration-check-valid-p (check) + (assoc check spam-registration-functions)) + +(defun spam-unregistration-check-valid-p (check) + (assoc check spam-registration-functions)) + +(defun spam-registration-function (classification check) + (let ((flist (cdr-safe (assoc check spam-registration-functions)))) + (if (eq classification 'spam) + (nth 1 flist) + (nth 0 flist)))) + +(defun spam-unregistration-function (classification check) + (let ((flist (cdr-safe (assoc check spam-registration-functions)))) + (if (eq classification 'spam) + (nth 3 flist) + (nth 2 flist)))) + +(defun spam-list-articles (articles classification) + (let ((mark-check (if (eq classification 'spam) + 'spam-group-spam-mark-p + 'spam-group-ham-mark-p)) + list mark-cache-yes mark-cache-no) + (dolist (article articles) + (let ((mark (gnus-summary-article-mark article))) + (unless (memq mark mark-cache-no) + (if (memq mark mark-cache-yes) + (push article list) + ;; else, we have to actually check the mark + (if (funcall mark-check + gnus-newsgroup-name + mark) + (progn + (push article list) + (push mark mark-cache-yes)) + (push mark mark-cache-no)))))) + list)) + +(defun spam-register-routine (classification + check + &optional unregister + specific-articles) + (when (and (spam-classification-valid-p classification) + (spam-registration-check-valid-p check)) + (let* ((register-function + (spam-registration-function classification check)) + (unregister-function + (spam-unregistration-function classification check)) + (run-function (if unregister + unregister-function + register-function)) + (log-function (if unregister + 'spam-log-undo-registration + 'spam-log-processing-to-registry)) + article articles) + + (when run-function + ;; make list of articles, using specific-articles if given + (setq articles (or specific-articles + (spam-list-articles + gnus-newsgroup-articles + classification))) + ;; process them + (gnus-message 5 "%s %d %s articles with classification %s, check %s" + (if unregister "Unregistering" "Registering") + (length articles) + (if specific-articles "specific" "") + (symbol-name classification) + (symbol-name check)) + (funcall run-function articles) + ;; now log all the registrations (or undo them, depending on unregister) + (dolist (article articles) + (funcall log-function + (spam-fetch-field-message-id-fast article) + 'process + classification + check + gnus-newsgroup-name)))))) + +;;; log a ham- or spam-processor invocation to the registry +(defun spam-log-processing-to-registry (id type classification check group) + (when spam-log-to-registry + (if (and (stringp id) + (stringp group) + (spam-process-type-valid-p type) + (spam-classification-valid-p classification) + (spam-registration-check-valid-p check)) + (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + (cell (list classification check group))) + (push cell cell-list) + (gnus-registry-store-extra-entry + id + type + cell-list)) + + (gnus-message 5 (format "%s called with bad ID, type, classification, check, or group" + "spam-log-processing-to-registry"))))) + +;;; check if a ham- or spam-processor registration has been done +(defun spam-log-registered-p (id type) + (when spam-log-to-registry + (if (and (stringp id) + (spam-process-type-valid-p type)) + (cdr-safe (gnus-registry-fetch-extra id type)) + (progn + (gnus-message 5 (format "%s called with bad ID, type, classification, or check" + "spam-log-registered-p")) + nil)))) + +;;; check if a ham- or spam-processor registration needs to be undone +(defun spam-log-unregistration-needed-p (id type classification check) + (when spam-log-to-registry + (if (and (stringp id) + (spam-process-type-valid-p type) + (spam-classification-valid-p classification) + (spam-registration-check-valid-p check)) + (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + found) + (dolist (cell cell-list) + (unless found + (when (and (eq classification (nth 0 cell)) + (eq check (nth 1 cell))) + (setq found t)))) + found) + (progn + (gnus-message 5 (format "%s called with bad ID, type, classification, or check" + "spam-log-unregistration-needed-p")) + nil)))) + + +;;; undo a ham- or spam-processor registration (the group is not used) +(defun spam-log-undo-registration (id type classification check &optional group) + (when (and spam-log-to-registry + (spam-log-unregistration-needed-p id type classification check)) + (if (and (stringp id) + (spam-process-type-valid-p type) + (spam-classification-valid-p classification) + (spam-registration-check-valid-p check)) + (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + new-cell-list found) + (dolist (cell cell-list) + (unless (and (eq classification (nth 0 cell)) + (eq check (nth 1 cell))) + (push cell new-cell-list))) + (gnus-registry-store-extra-entry + id + type + new-cell-list)) + (progn + (gnus-message 5 (format "%s called with bad ID, type, check, or group" + "spam-log-undo-registration")) + nil)))) + +;;; set up IMAP widening if it's necessary +(defun spam-setup-widening () + (dolist (check spam-list-of-statistical-checks) + (when (symbol-value check) + (setq nnimap-split-download-body-default t)))) + + +;;;; Regex body + +(defun spam-check-regex-body () + (let ((spam-regex-headers-ham spam-regex-body-ham) + (spam-regex-headers-spam spam-regex-body-spam)) + (spam-check-regex-headers t))) + + +;;;; Regex headers + +(defun spam-check-regex-headers (&optional body) + (let ((type (if body "body" "header")) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group)) + 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 %s search positive." type) + (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 %s search positive." type) + (setq found t) + (setq ret spam-split-group)))) + ret)) + + +;;;; Blackholes. + +(defun spam-reverse-ip-string (ip) + (when (stringp ip) + (mapconcat 'identity + (nreverse (split-string ip "\\.")) + "."))) + +(defun spam-check-blackholes () + "Check the Received headers for blackholed relays." + (let ((headers (nnmail-fetch-field "received")) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group)) + 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 (spam-reverse-ip-string (match-string 1)) + ips))) + (dolist (server spam-blackhole-servers) + (dolist (ip ips) + (unless (and spam-blackhole-good-server-regex + ;; match the good-server-regex against the reversed (again) IP string + (string-match + spam-blackhole-good-server-regex + (spam-reverse-ip-string ip))) + (unless matches + (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))) + +;;;; 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)))) + +;;;; 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 (addresses &optional remove) + "Enter an address into the BBDB; implies ham (non-spam) sender" + (dolist (from addresses) + (when (stringp from) + (let* ((parsed-address (gnus-extract-address-components from)) + (name (or (nth 0 parsed-address) "Ham Sender")) + (remove-function (if remove + 'bbdb-delete-record-internal + 'ignore)) + (net-address (nth 1 parsed-address)) + (record (and net-address + (bbdb-search-simple nil net-address)))) + (when net-address + (gnus-message 5 "%s address %s %s BBDB" + (if remove "Deleting" "Adding") + from + (if remove "from" "to")) + (if record + (funcall remove-function record) + (bbdb-create-internal name nil net-address nil nil + "ham sender added by spam.el"))))))) + + (defun spam-BBDB-register-routine (articles &optional unregister) + (let (addresses) + (dolist (article articles) + (when (stringp (spam-fetch-field-from-fast article)) + (push (spam-fetch-field-from-fast article) addresses))) + ;; now do the register/unregister action + (spam-enter-ham-BBDB addresses unregister))) + + (defun spam-BBDB-unregister-routine (articles) + (spam-BBDB-register-routine articles t)) + + (defun spam-check-BBDB () + "Mail from people in the BBDB is classified as ham or non-spam" + (let ((who (nnmail-fetch-field "from")) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group))) + (when who + (setq who (nth 1 (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-delete-record-internal 'ignore) + (defalias 'bbdb-records 'ignore)))) + + +;;;; 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)) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group)) + 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) + (apply 'call-process-region + (point-min) (point-max) spam-ifile-path + nil temp-buffer-name nil "-c" + (if db-param `(,db-param "-q") `("-q")))) + ;; check the return now (we're back in the temp buffer) + (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)))))) ; note return is nil otherwise + return)) + +(defun spam-ifile-register-with-ifile (articles category &optional unregister) + "Register an article, given as a string, with a category. +Uses `gnus-newsgroup-name' if category is nil (for ham registration)." + (let ((category (or category gnus-newsgroup-name)) + (add-or-delete-option (if unregister "-d" "-i")) + (db (spam-get-ifile-database-parameter)) + parameters) + (with-temp-buffer + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article))) + (when (stringp article-string) + (insert article-string)))) + (apply 'call-process-region + (point-min) (point-max) spam-ifile-path + nil nil nil + add-or-delete-option category + (if db `(,db "-h") `("-h")))))) + +(defun spam-ifile-register-spam-routine (articles &optional unregister) + (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister)) + +(defun spam-ifile-unregister-spam-routine (articles) + (spam-ifile-register-spam-routine articles t)) + +(defun spam-ifile-register-ham-routine (articles &optional unregister) + (spam-ifile-register-with-ifile articles spam-ifile-ham-category unregister)) + +(defun spam-ifile-unregister-ham-routine (articles) + (spam-ifile-register-ham-routine articles t)) + + +;;;; 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-split-group (if spam-split-symbolic-return + 'spam + spam-split-group)) + (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 (articles &optional unregister) + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article))) + (with-temp-buffer + (insert article-string) + (if unregister + (spam-stat-buffer-change-to-non-spam) + (spam-stat-buffer-is-spam)))))) + + (defun spam-stat-unregister-spam-routine (articles) + (spam-stat-register-spam-routine articles t)) + + (defun spam-stat-register-ham-routine (articles &optional unregister) + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article))) + (with-temp-buffer + (insert article-string) + (if unregister + (spam-stat-buffer-change-to-spam) + (spam-stat-buffer-is-non-spam)))))) + + (defun spam-stat-unregister-ham-routine (articles) + (spam-stat-register-ham-routine articles t)) + + (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)))) + + (file-error (progn + (defalias 'spam-stat-load 'ignore) + (defalias 'spam-stat-save 'ignore) + (defalias 'spam-maybe-spam-stat-load 'ignore) + (defalias 'spam-maybe-spam-stat-save 'ignore) + (defalias 'spam-stat-register-ham-routine 'ignore) + (defalias 'spam-stat-unregister-ham-routine 'ignore) + (defalias 'spam-stat-register-spam-routine 'ignore) + (defalias 'spam-stat-unregister-spam-routine 'ignore) + (defalias 'spam-stat-buffer-is-spam 'ignore) + (defalias 'spam-stat-buffer-change-to-spam 'ignore) + (defalias 'spam-stat-buffer-is-non-spam 'ignore) + (defalias 'spam-stat-buffer-change-to-non-spam 'ignore) + (defalias 'spam-stat-split-fancy 'ignore) + (defalias 'spam-check-stat 'ignore)))) + + + +;;;; Blacklists and whitelists. + +(defvar spam-whitelist-cache nil) +(defvar spam-blacklist-cache nil) + +(defun spam-kill-whole-line () + (beginning-of-line) + (let ((kill-whole-line t)) + (kill-line))) + +;;; address can be a list, too +(defun spam-enter-whitelist (address &optional remove) + "Enter ADDRESS (list or single) into the whitelist. +With a non-nil REMOVE, remove them." + (interactive "sAddress: ") + (spam-enter-list address spam-whitelist remove) + (setq spam-whitelist-cache nil)) + +;;; address can be a list, too +(defun spam-enter-blacklist (address &optional remove) + "Enter ADDRESS (list or single) into the blacklist. +With a non-nil REMOVE, remove them." + (interactive "sAddress: ") + (spam-enter-list address spam-blacklist remove) + (setq spam-blacklist-cache nil)) + +(defun spam-enter-list (addresses file &optional remove) + "Enter ADDRESSES into the given FILE. +Either the whitelist or the blacklist files can be used. With +REMOVE not nil, remove the ADDRESSES." + (if (stringp addresses) + (spam-enter-list (list addresses) file remove) + ;; else, we have a list of addresses here + (unless (file-exists-p (file-name-directory file)) + (make-directory (file-name-directory file) t)) + (save-excursion + (set-buffer + (find-file-noselect file)) + (dolist (a addresses) + (when (stringp a) + (goto-char (point-min)) + (if (re-search-forward (regexp-quote a) nil t) + ;; found the address + (when remove + (spam-kill-whole-line)) + ;; else, the address was not found + (unless remove + (goto-char (point-max)) + (unless (bobp) + (insert "\n")) + (insert a "\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? + (let ((spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group))) + (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? + (let ((spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group))) + (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) + ;; insert the e-mail address if detected, otherwise the raw data + (unless (zerop (length address)) + (let ((pure-address (nth 1 (gnus-extract-address-components address)))) + (push (or pure-address address) contents))))) + (nreverse contents)))) + +(defun spam-from-listed-p (cache) + (let ((from (nnmail-fetch-field "from")) + found) + (while cache + (let ((address (pop cache))) + (unless (zerop (length address)) ; 0 for a nil address too + (setq address (regexp-quote address)) + ;; fix regexp-quote's treatment of user-intended regexes + (while (string-match "\\\\\\*" address) + (setq address (replace-match ".*" t t address)))) + (when (and address (string-match address from)) + (setq found t + cache nil)))) + found)) + +(defun spam-filelist-register-routine (articles blacklist &optional unregister) + (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist)) + (declassification (if blacklist 'ham 'spam)) + (enter-function + (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist)) + (remove-function + (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist)) + from addresses unregister-list) + (dolist (article articles) + (let ((from (spam-fetch-field-from-fast article)) + (id (spam-fetch-field-message-id-fast article)) + sender-ignored) + (when (stringp from) + (dolist (ignore-regex spam-blacklist-ignored-regexes) + (when (and (not sender-ignored) + (stringp ignore-regex) + (string-match ignore-regex from)) + (setq sender-ignored t))) + ;; remember the messages we need to unregister, unless remove is set + (when (and + (null unregister) + (spam-log-unregistration-needed-p + id 'process declassification de-symbol)) + (push from unregister-list)) + (unless sender-ignored + (push from addresses))))) + + (if unregister + (funcall enter-function addresses t) ; unregister all these addresses + ;; else, register normally and unregister what we need to + (funcall remove-function unregister-list t) + (dolist (article unregister-list) + (spam-log-undo-registration + (spam-fetch-field-message-id-fast article) + 'process + declassification + de-symbol)) + (funcall enter-function addresses nil)))) + +(defun spam-blacklist-unregister-routine (articles) + (spam-blacklist-register-routine articles t)) + +(defun spam-blacklist-register-routine (articles &optional unregister) + (spam-filelist-register-routine articles t unregister)) + +(defun spam-whitelist-unregister-routine (articles) + (spam-whitelist-register-routine articles t)) + +(defun spam-whitelist-register-routine (articles &optional unregister) + (spam-filelist-register-routine articles nil unregister)) + + +;;;; Spam-report glue +(defun spam-report-gmane-register-routine (articles) + (when articles + (apply 'spam-report-gmane articles))) + + +;;;; Bogofilter +(defun spam-check-bogofilter-headers (&optional score) + (let ((header (nnmail-fetch-field spam-bogofilter-header)) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group))) + (when header ; return nil when no header + (if score ; scoring mode + (if (string-match "spamicity=\\([0-9.]+\\)" header) + (match-string 1 header) + "0") + ;; spam detection mode + (when (string-match spam-bogofilter-bogosity-positive-spam-header + 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")) + (gnus-summary-show-article))) + +(defun spam-check-bogofilter (&optional score) + "Check the Bogofilter backend for the classification of this message" + (let ((article-buffer-name (buffer-name)) + (db spam-bogofilter-database-directory) + return) + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (save-excursion + (set-buffer article-buffer-name) + (apply 'call-process-region + (point-min) (point-max) + spam-bogofilter-path + nil temp-buffer-name nil + (if db `("-d" ,db "-v") `("-v")))) + (setq return (spam-check-bogofilter-headers score)))) + return)) + +(defun spam-bogofilter-register-with-bogofilter (articles + spam + &optional unregister) + "Register an article, given as a string, as spam or non-spam." + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article)) + (db spam-bogofilter-database-directory) + (switch (if unregister + (if spam + spam-bogofilter-spam-strong-switch + spam-bogofilter-ham-strong-switch) + (if spam + spam-bogofilter-spam-switch + spam-bogofilter-ham-switch)))) + (when (stringp article-string) + (with-temp-buffer + (insert article-string) + + (apply 'call-process-region + (point-min) (point-max) + spam-bogofilter-path + nil nil nil switch + (if db `("-d" ,db "-v") `("-v")))))))) + +(defun spam-bogofilter-register-spam-routine (articles &optional unregister) + (spam-bogofilter-register-with-bogofilter articles t unregister)) + +(defun spam-bogofilter-unregister-spam-routine (articles) + (spam-bogofilter-register-spam-routine articles t)) + +(defun spam-bogofilter-register-ham-routine (articles &optional unregister) + (spam-bogofilter-register-with-bogofilter articles nil unregister)) + +(defun spam-bogofilter-unregister-ham-routine (articles) + (spam-bogofilter-register-ham-routine articles t)) + + + +;;;; spamoracle +(defun spam-check-spamoracle () + "Run spamoracle on an article to determine whether it's spam." + (let ((article-buffer-name (buffer-name)) + (spam-split-group (if spam-split-symbolic-return + 'spam + spam-split-group))) + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (save-excursion + (set-buffer article-buffer-name) + (let ((status + (apply 'call-process-region + (point-min) (point-max) + spam-spamoracle-binary + nil temp-buffer-name nil + (if spam-spamoracle-database + `("-f" ,spam-spamoracle-database "mark") + '("mark"))))) + (if (eq 0 status) + (progn + (set-buffer temp-buffer-name) + (goto-char (point-min)) + (when (re-search-forward "^X-Spam: yes;" nil t) + spam-split-group)) + (error "Error running spamoracle" status)))))))) + +(defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister) + "Run spamoracle in training mode." + (with-temp-buffer + (let ((temp-buffer-name (buffer-name))) + (save-excursion + (goto-char (point-min)) + (dolist (article articles) + (insert (spam-get-article-as-string article))) + (let* ((arg (if (spam-xor unregister article-is-spam-p) + "-spam" + "-good")) + (status + (apply 'call-process-region + (point-min) (point-max) + spam-spamoracle-binary + nil temp-buffer-name nil + (if spam-spamoracle-database + `("-f" ,spam-spamoracle-database + "add" ,arg) + `("add" ,arg))))) + (when (not (eq 0 status)) + (error "Error running spamoracle" status))))))) + +(defun spam-spamoracle-learn-ham (articles &optional unregister) + (spam-spamoracle-learn articles nil unregister)) + +(defun spam-spamoracle-unlearn-ham (articles &optional unregister) + (spam-spamoracle-learn-ham articles t)) + +(defun spam-spamoracle-learn-spam (articles &optional unregister) + (spam-spamoracle-learn articles t unregister)) + +(defun spam-spamoracle-unlearn-spam (articles &optional unregister) + (spam-spamoracle-learn-spam articles t)) + + +;;;; Hooks + +;;;###autoload +(defun spam-initialize () + "Install the spam.el hooks and do other initialization" + (interactive) + (setq spam-install-hooks t) + ;; TODO: How do we redo this every time spam-face is customized? + (push '((eq mark gnus-spam-mark) . spam-face) + gnus-summary-highlight) + ;; 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) + (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) + (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare) + (add-hook 'gnus-get-new-news-hook 'spam-setup-widening) + (add-hook 'gnus-summary-prepare-hook 'spam-find-spam)) + +(defun spam-unload-hook () + "Uninstall the spam.el hooks" + (interactive) + (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) + (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) + (remove-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load) + (remove-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) + (remove-hook 'gnus-summary-prepare-hook 'spam-summary-prepare) + (remove-hook 'gnus-get-new-news-hook 'spam-setup-widening) + (remove-hook 'gnus-summary-prepare-hook 'spam-find-spam)) + +(when spam-install-hooks + (spam-initialize)) + +(provide 'spam) + +;;; spam.el ends here. + +(provide 'spam) + +;;; arch-tag: 07e6e0ca-ab0a-4412-b445-1f6c72a4f27f +;;; spam.el ends here
--- a/lisp/gnus/starttls.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/starttls.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,11 +1,10 @@ ;;; starttls.el --- STARTTLS functions -;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> -;; Author: Simon Josefsson <simon@josefsson.org> ;; Created: 1999/11/20 -;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news +;; Keywords: TLS, SSL, OpenSSL, mail, news ;; This file is part of GNU Emacs. @@ -28,93 +27,11 @@ ;; This module defines some utility functions for STARTTLS profiles. +;; Get "starttls" from ftp://ftp.opaopa.org/pub/elisp/. + ;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" ;; by Chris Newman <chris.newman@innosoft.com> (1999/06) -;; This file now contain a combination of the two previous -;; implementations both called "starttls.el". The first one is Daiki -;; Ueno's starttls.el which uses his own "starttls" command line tool, -;; and the second one is Simon Josefsson's starttls.el which uses -;; "gnutls-cli" from GNUTLS. -;; -;; If "starttls" is available, it is prefered by the code over -;; "gnutls-cli", for backwards compatibility. Use -;; `starttls-use-gnutls' to toggle between implementations if you have -;; both tools installed. It is recommended to use GNUTLS, though, as -;; it performs more verification of the certificates. - -;; The GNUTLS support require GNUTLS 0.9.90 (released 2003-10-08) or -;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls" -;; from <ftp://ftp.opaopa.org/pub/elisp/>. - -;; Usage is similar to `open-network-stream'. For example: -;; -;; (when (setq tmp (starttls-open-stream -;; "test" (current-buffer) "yxa.extundo.com" 25)) -;; (accept-process-output tmp 15) -;; (process-send-string tmp "STARTTLS\n") -;; (accept-process-output tmp 15) -;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) -;; (process-send-string tmp "EHLO foo\n")) - -;; An example run yield the following output: -;; -;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65] -;; 220 2.0.0 Ready to start TLS -;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you -;; 250-ENHANCEDSTATUSCODES -;; 250-PIPELINING -;; 250-EXPN -;; 250-VERB -;; 250-8BITMIME -;; 250-SIZE -;; 250-DSN -;; 250-ETRN -;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN -;; 250-DELIVERBY -;; 250 HELP -;; nil -;; -;; With the message buffer containing: -;; -;; STARTTLS output: -;; *** Starting TLS handshake -;; - Server's trusted authorities: -;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; - Certificate type: X.509 -;; - Got a certificate list of 2 certificates. -;; -;; - Certificate[0] info: -;; # The hostname in the certificate matches 'yxa.extundo.com'. -;; # valid since: Wed May 26 12:16:00 CEST 2004 -;; # expires at: Wed Jul 26 12:16:00 CEST 2023 -;; # serial number: 04 -;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a -;; # version: #1 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Certificate[1] info: -;; # valid since: Sun May 23 11:35:00 CEST 2004 -;; # expires at: Sun Jul 23 11:35:00 CEST 2023 -;; # serial number: 00 -;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae -;; # version: #3 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Peer's certificate issuer is unknown -;; - Peer's certificate is NOT trusted -;; - Version: TLS 1.0 -;; - Key Exchange: RSA -;; - Cipher: ARCFOUR 128 -;; - MAC: SHA -;; - Compression: NULL - ;;; Code: (defgroup starttls nil @@ -122,141 +39,18 @@ :version "21.1" :group 'mail) -(defcustom starttls-gnutls-program "gnutls-cli" - "Name of GNUTLS command line tool. -This program is used when GNUTLS is used, i.e. when -`starttls-use-gnutls' is non-nil." - :type 'string - :group 'starttls) - (defcustom starttls-program "starttls" - "The program to run in a subprocess to open an TLSv1 connection. -This program is used when the `starttls' command is used, -i.e. when `starttls-use-gnutls' is nil." + "The program to run in a subprocess to open an TLSv1 connection." :type 'string :group 'starttls) -(defcustom starttls-use-gnutls (not (executable-find starttls-program)) - "*Whether to use GNUTLS instead of the `starttls' command." - :type 'boolean - :group 'starttls) - (defcustom starttls-extra-args nil - "Extra arguments to `starttls-program'. -This program is used when the `starttls' command is used, -i.e. when `starttls-use-gnutls' is nil." - :type '(repeat string) - :group 'starttls) - -(defcustom starttls-extra-arguments nil - "Extra arguments to `starttls-program'. -This program is used when GNUTLS is used, i.e. when -`starttls-use-gnutls' is non-nil. - -For example, non-TLS compliant servers may require -'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to -find out which parameters are available." + "Extra arguments to `starttls-program'." :type '(repeat string) :group 'starttls) -(defcustom starttls-process-connection-type nil - "*Value for `process-connection-type' to use when starting STARTTLS process." - :type 'boolean - :group 'starttls) - -(defcustom starttls-connect "- Simple Client Mode:\n\n" - "*Regular expression indicating successful connection. -The default is what GNUTLS's \"gnutls-cli\" outputs." - ;; GNUTLS cli.c:main() print this string when it is starting to run - ;; in the application read/write phase. If the logic, or the string - ;; itself, is modified, this must be updated. - :type 'regexp - :group 'starttls) - -(defcustom starttls-failure "\\*\\*\\* Handshake has failed" - "*Regular expression indicating failed TLS handshake. -The default is what GNUTLS's \"gnutls-cli\" outputs." - ;; GNUTLS cli.c:do_handshake() print this string on failure. If the - ;; logic, or the string itself, is modified, this must be updated. - :type 'regexp - :group 'starttls) - -(defcustom starttls-success "- Compression: " - "*Regular expression indicating completed TLS handshakes. -The default is what GNUTLS's \"gnutls-cli\" outputs." - ;; GNUTLS cli.c:do_handshake() calls, on success, - ;; common.c:print_info(), that unconditionally print this string - ;; last. If that logic, or the string itself, is modified, this - ;; must be updated. - :type 'regexp - :group 'starttls) - -(defun starttls-negotiate-gnutls (process) - "Negotiate TLS on process opened by `open-starttls-stream'. -This should typically only be done once. It typically return a -multi-line informational message with information about the -handshake, or NIL on failure." - (let (buffer info old-max done-ok done-bad) - (if (null (setq buffer (process-buffer process))) - ;; XXX How to remove/extract the TLS negotiation junk? - (signal-process (process-id process) 'SIGALRM) - (with-current-buffer buffer - (save-excursion - (setq old-max (goto-char (point-max))) - (signal-process (process-id process) 'SIGALRM) - (while (and (processp process) - (eq (process-status process) 'run) - (save-excursion - (goto-char old-max) - (not (or (setq done-ok (re-search-forward - starttls-success nil t)) - (setq done-bad (re-search-forward - starttls-failure nil t)))))) - (accept-process-output process 1 100) - (sit-for 0.1)) - (setq info (buffer-substring-no-properties old-max (point-max))) - (delete-region old-max (point-max)) - (if (or (and done-ok (not done-bad)) - ;; Prevent mitm that fake success msg after failure msg. - (and done-ok done-bad (< done-ok done-bad))) - info - (message "STARTTLS negotiation failed: %s" info) - nil)))))) - (defun starttls-negotiate (process) - (if starttls-use-gnutls - (starttls-negotiate-gnutls process) - (signal-process (process-id process) 'SIGALRM))) - -(defun starttls-open-stream-gnutls (name buffer host service) - (message "Opening STARTTLS connection to `%s'..." host) - (let* (done - (old-max (with-current-buffer buffer (point-max))) - (process-connection-type starttls-process-connection-type) - (process (apply #'start-process name buffer - starttls-gnutls-program "-s" host - "-p" (if (integerp service) - (int-to-string service) - service) - starttls-extra-arguments))) - (process-kill-without-query process) - (while (and (processp process) - (eq (process-status process) 'run) - (save-excursion - (set-buffer buffer) - (goto-char old-max) - (not (setq done (re-search-forward - starttls-connect nil t))))) - (accept-process-output process 0 100) - (sit-for 0.1)) - (if done - (with-current-buffer buffer - (delete-region old-max done)) - (delete-process process) - (setq process nil)) - (message "Opening STARTTLS connection to `%s'...%s" - host (if done "done" "failed")) - process)) + (signal-process (process-id process) 'SIGALRM)) (defun starttls-open-stream (name buffer host service) "Open a TLS connection for a service to a host. @@ -272,15 +66,13 @@ 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." - (if starttls-use-gnutls - (starttls-open-stream-gnutls name buffer host service) - (let* ((process-connection-type starttls-process-connection-type) - (process (apply #'start-process - name buffer starttls-program - host (format "%s" service) - starttls-extra-args))) - (process-kill-without-query process) - process))) + (let* ((process-connection-type nil) + (process (apply #'start-process + name buffer starttls-program + host (format "%s" service) + starttls-extra-args))) + (process-kill-without-query process) + process)) (provide 'starttls)
--- a/lisp/gnus/subscribe.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/subscribe.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,49 +1,32 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 19 1", -" c Gray6", -". c Gray12", -"X c #2ff42ff42ff4", -"o c #3fff3fff3fff", -"O c Gray28", -"+ c #53e353e353e3", -"@ c #5fe25fe25fe2", -"# c #67e767e767e7", -"$ c #6fff6fff6fff", -"% c #77d777d777d7", -"& c Gray50", -"* c Gray56", -"= c #9fff9fff9fff", -"- c Gray70", -"; c Gray75", -": c Gray81", -"> c #dfffdfffdfff", -", c #efffefffefff", -"< c Gray100", -/* pixels */ -";;;;;;;;;;;;;;;;;;;;;;;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -";;;;@Xooooo oooXO-;;;;;;", -";;;;@;>;=<<o<<<;o#;;;;;;", -";;;;@;,&=<<o<<<;&:+;;;;;", -";;;;@;:=$<<o<<<:ooX@;;;;", -";;;;@@&&&&&.<<<<<<;@;;;;", -";;;;@*;;;;;X<<<<<<;@;;;;", -";;;;@;:&@<<o<<<<<<;@;;;;", -";;;;@;>&&<<o<<<<<<;@;;;;", -";;;;@;,>:<<o<<<<<<;@;;;;", -";;;;@Xooooo <<<<<<;@;;;;", -";;;;@;>;=<<o<<<<<<;@;;;;", -";;;;@;,&=<<o<<<<<<;@;;;;", -";;;;@;:=$<<o<<<<<<;@;;;;", -";;;;@@&&&&&.<<<<<<;@;;;;", -";;;;@*;;;;;X<<<<<<;@;;;;", -";;;;@;<<<<<o<<<<<<;@;;;;", -";;;;@;<<<<<o<<<<<<;@;;;;", -";;;;@;<<<<<o<<<<<<;@;;;;", -";;;;%XXXXXXXXXXXXXX%;;;;", -";;;;;;;;;;;;;;;;;;;;;;;;", -";;;;;;;;;;;;;;;;;;;;;;;;" -}; +static char * subscribe_xpm[] = { +"24 24 5 1", +" c None", +". c #A5A5A5A59595", +"X c #E1E1E0E0E0E0", +"o c #C7C7C6C6C6C6", +"O c #8686ADAD7D7D", +" ", +" ", +" ", +" ... ", +" ..XXX..... ", +"...XXXXX..XXX. ... ", +".X.XX...XXXX...XXX. ", +".XX.X.X.XX...XXXXX. ", +".XX...XX.X.X.XXXXXX. ", +".XX.o.XX...XX.XXXXXX. ", +".X.oo.XX.o.XX..XXXXXX. ", +"o.ooo.X.oo.XX.XXXOXXX. ", +"o.oXXo.ooo.X.oXXOXXXXX. ", +" o.XXo.oXXo.ooXXOXXXXX. ", +" o.XXXo.XXo.oXXXOXXXXXX.", +" o.XXo.XXXo.XOOOOXXXXX.", +" o.XXoo.XXo.XXXOOXXXXX.", +" o.XXo.XXXo.XXXXXXX...", +" o.XX.o.XXo.XXXXXX.oo ", +" o..oo.XX.o.XXX..o ", +" oo o..oo.XX.oo ", +" oo o..o ", +" oo ", +" "};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/tls.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,128 @@ +;;; 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: + +(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 TLS 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 (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) + +;;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac +;;; tls.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/unimportant.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,32 @@ +/* XPM */ +static char *magick[] = { +/* columns rows colors chars-per-pixel */ +"24 24 2 1", +"! c blue", +"w c Gray75", +/* pixels */ +"wwwwwwwwwwwwwwwwwwwwwwww", +"wwwwwwwwwwwwwwwwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"ww!!!wwwwww!!!wwwwww!!!w", +"www!!!wwwww!!!wwwww!!!ww", +"wwww!!!wwww!!!wwww!!!www", +"wwwww!!!www!!!www!!!wwww", +"wwwwww!!!ww!!!ww!!!wwwww", +"wwwwwww!!!w!!!w!!!wwwwww", +"wwwwwwww!!!!!!!!!wwwwwww", +"wwwwwwwww!!!!!!!wwwwwwww", +"wwwwwwwwww!!!!!wwwwwwwww", +"wwwwwwwwwww!!!wwwwwwwwww", +"wwwwwwwwwwwwwwwwwwwwwwww", +"wwwwwwwwwwwwwwwwwwwwwwww" +};
--- a/lisp/gnus/unsubscribe.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/unsubscribe.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,48 +1,32 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 18 1", -" c Gray6", -". c Gray12", -"X c #2ff42ff42ff4", -"o c #3fff3fff3fff", -"O c Gray28", -"+ c #53e353e353e3", -"@ c #5fe55fe55fe5", -"# c #67e767e767e7", -"$ c #77d777d777d7", -"% c Gray50", -"& c Gray56", -"* c #9fff9fff9fff", -"= c Gray70", -"- c Gray75", -"; c Gray81", -": c #dfffdfffdfff", -"> c #efffefffefff", -", c Gray100", -/* pixels */ -"------------------------", -"------------------------", -"------------------------", -"----@Xooooo oooXO=------", -"----@-,,,:-o,,,-o#------", -"----@-,,,@:o,,,-%;+-----", -"----@-;%@,,o,,,;ooX@----", -"----@@%o@%%.,,,,,,-@----", -"----@&-----X,,,,,,-@----", -"----@-,,,**o,,,,,,-@----", -"----@-:-**,o,,,,,,-@----", -"----@->%*,,o,,,,,,-@----", -"----@Xooooo ,,,,,,-@----", -"----@-,,,:-o,,,,,,-@----", -"----@-,,,@:o,,,,,,-@----", -"----@-;%@,,o,,,,,,-@----", -"----@@%o@%%.,,,,,,-@----", -"----@&-----X,,,,,,-@----", -"----@-,,,,,o,,,,,,-@----", -"----@-,,,,,o,,,,,,-@----", -"----@-,,,,,o,,,,,,-@----", -"----$XXXXXXXXXXXXXX$----", -"------------------------", -"------------------------" -}; +static char * unsubscribe_xpm[] = { +"24 24 5 1", +" c None", +". c #A5A5A5A59595", +"X c #E1E1E0E0E0E0", +"o c #C7C7C6C6C6C6", +"O c #FFFF00000000", +" ", +" ", +" ", +" ... ", +" ..XXX..... ", +"...XXXXX..XXX. ... ", +".X.XX...XXXX...XXX. ", +".XX.X.X.XX...XXXXX. ", +".XX...XX.X.X.XXXXXX. ", +".XX.o.XX...XX.XXXXXX. ", +".X.oo.XX.o.XX..XXXXXX. ", +"o.ooo.X.oo.XX.XXXXXXX. ", +"o.oXXo.ooo.X.oXXXXXXXX. ", +" o.XXo.oXXo.ooXXOXXXXX. ", +" o.XXXo.XXo.oXXXOXXXXXX.", +" o.XXo.XXXo.XOOOXXXXXX.", +" o.XXoo.XXo.XoOOOXXXXX.", +" o.XXo.XXXo.XOoOXXX...", +" o.XX.o.XXo.XOXoXX.oo ", +" o..oo.XX.o.oXX..o ", +" oo o..oo.XX.oo ", +" oo o..o ", +" oo ", +" "};
--- a/lisp/gnus/utf7.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/utf7.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,7 +1,8 @@ -;;; utf7.el --- UTF-7 encoding/decoding for Emacs -;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: iso-8859-1;-*- +;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc. ;; Author: Jon K Hellan <hellan@acm.org> +;; Maintainer: bugs@gnus.org ;; Keywords: mail ;; This file is part of GNU Emacs. @@ -22,37 +23,69 @@ ;; Boston, MA 02111-1307, USA. ;;; Commentary: -;;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152 -;;; This is a transformation format of Unicode that contains only 7-bit -;;; ASCII octets and is intended to be readable by humans in the limiting -;;; case that the document consists of characters from the US-ASCII -;;; repertoire. -;;; In short, runs of characters outside US-ASCII are encoded as base64 -;;; inside delimiters. -;;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way -;;; to represent characters outside US-ASCII in mailbox names in IMAP. -;;; This library supports both variants, but the IMAP variation was the -;;; reason I wrote it. -;;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode) -;;; -> current character set, and vice versa. -;;; However, until Emacs supports Unicode, the only Emacs character set -;;; supported here is ISO-8859.1, which can trivially be converted to/from -;;; Unicode. -;;; When decoding results in a character outside the Emacs character set, -;;; an error is thrown. It is up to the application to recover. + +;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152 +;; This is a transformation format of Unicode that contains only 7-bit +;; ASCII octets and is intended to be readable by humans in the limiting +;; case that the document consists of characters from the US-ASCII +;; repertoire. +;; In short, runs of characters outside US-ASCII are encoded as base64 +;; inside delimiters. +;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way +;; to represent characters outside US-ASCII in mailbox names in IMAP. +;; This library supports both variants, but the IMAP variation was the +;; reason I wrote it. +;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode) +;; -> current character set, and vice versa. +;; However, until Emacs supports Unicode, the only Emacs character set +;; supported here is ISO-8859.1, which can trivially be converted to/from +;; Unicode. +;; When decoding results in a character outside the Emacs character set, +;; an error is thrown. It is up to the application to recover. + +;; UTF-7 should be done by providing a coding system. Mule-UCS does +;; already, but I don't know if it does the IMAP version and it's not +;; clear whether that should really be a coding system. The UTF-16 +;; part of the conversion can be done with coding systems available +;; with Mule-UCS or some versions of Emacs. Unfortunately these were +;; done wrongly (regarding handling of byte-order marks and how the +;; variants were named), so we don't have a consistent name for the +;; necessary coding system. The code below doesn't seem to DTRT +;; generally. E.g.: +;; +;; (utf7-encode "a+£") +;; => "a+ACsAow-" +;; +;; $ echo "a+£"|iconv -f iso-8859-1 -t utf-7 +;; a+-+AKM +;; +;; -- fx + ;;; Code: (require 'base64) (eval-when-compile (require 'cl)) +(require 'mm-util) -(defvar utf7-direct-encoding-chars " -%'-*,-[]-}" +(defconst utf7-direct-encoding-chars " -%'-*,-[]-}" "Character ranges which do not need escaping in UTF-7.") -(defvar utf7-imap-direct-encoding-chars +(defconst utf7-imap-direct-encoding-chars (concat utf7-direct-encoding-chars "+\\~") "Character ranges which do not need escaping in the IMAP variant of UTF-7.") +(defconst utf7-utf-16-coding-system + (cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS + 'utf-16-be-no-signature) + ((and (mm-coding-system-p 'utf-16-be) ; Emacs 21.4 (?), Emacs 22 + ;; Avoid versions with BOM. + (= 2 (length (encode-coding-string "a" 'utf-16-be)))) + 'utf-16-be) + ((mm-coding-system-p 'utf-16-be-nosig) ; ? + 'utf-16-be-nosig)) + "Coding system which encodes big endian UTF-16 without a BOM signature.") + (defsubst utf7-imap-get-pad-length (len modulus) "Return required length of padding for IMAP modified base64 fragment." (mod (- len) modulus)) @@ -64,10 +97,11 @@ (end (point-max))) (narrow-to-region start end) (goto-char start) - (let ((esc-char (if for-imap ?& ?+)) - (direct-encoding-chars - (if for-imap utf7-imap-direct-encoding-chars - utf7-direct-encoding-chars))) + (let* ((esc-char (if for-imap ?& ?+)) + (direct-encoding-chars + (if for-imap utf7-imap-direct-encoding-chars + utf7-direct-encoding-chars)) + (not-direct-encoding-chars (concat "^" direct-encoding-chars))) (while (not (eobp)) (skip-chars-forward direct-encoding-chars) (unless (eobp) @@ -75,7 +109,7 @@ (let ((p (point)) (fc (following-char)) (run-length - (skip-chars-forward (concat "^" direct-encoding-chars)))) + (skip-chars-forward not-direct-encoding-chars))) (if (and (= fc esc-char) (= run-length 1)) ; Lone esc-char? (delete-backward-char 1) ; Now there's one too many @@ -88,7 +122,8 @@ (save-restriction (narrow-to-region start end) (funcall (utf7-get-u16char-converter 'to-utf-16)) - (base64-encode-region start (point-max)) + (mm-with-unibyte-current-buffer + (base64-encode-region start (point-max))) (goto-char start) (let ((pm (point-max))) (when for-imap @@ -135,15 +170,24 @@ (defun utf7-get-u16char-converter (which-way) "Return a function to convert between UTF-16 and current character set." - ;; Add test to check if we are really Latin-1. - ;; Support other character sets once Emacs groks Unicode. - (if (eq which-way 'to-utf-16) - 'utf7-latin1-u16-char-converter - 'utf7-u16-latin1-char-converter)) + (if utf7-utf-16-coding-system + (if (eq which-way 'to-utf-16) + (lambda () + (encode-coding-region (point-min) (point-max) + utf7-utf-16-coding-system)) + (lambda () + (decode-coding-region (point-min) (point-max) + utf7-utf-16-coding-system))) + ;; Add test to check if we are really Latin-1. + (if (eq which-way 'to-utf-16) + 'utf7-latin1-u16-char-converter + 'utf7-u16-latin1-char-converter))) (defun utf7-latin1-u16-char-converter () "Convert latin 1 (ISO-8859.1) characters to 16 bit Unicode. Characters are converted to raw byte pairs in narrowed buffer." + (mm-encode-coding-region (point-min) (point-max) 'iso-8859-1) + (mm-disable-multibyte) (goto-char (point-min)) (while (not (eobp)) (insert 0) @@ -157,11 +201,13 @@ (if (= 0 (following-char)) (delete-char 1) (error "Unable to convert from Unicode")) - (forward-char))) + (forward-char)) + (mm-decode-coding-region (point-min) (point-max) 'iso-8859-1) + (mm-enable-multibyte)) (defun utf7-encode (string &optional for-imap) "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." - (let ((default-enable-multibyte-characters nil)) + (let ((default-enable-multibyte-characters t)) (with-temp-buffer (insert string) (utf7-encode-internal for-imap) @@ -173,6 +219,7 @@ (with-temp-buffer (insert string) (utf7-decode-internal for-imap) + (mm-enable-multibyte) (buffer-string)))) (provide 'utf7)
--- a/lisp/gnus/uu-decode.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/uu-decode.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,48 +1,36 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 18 1", -" c #2fef2fef2fef", -". c #3fff3fff3fff", -"X c #4ccc4ccc4ccc", -"o c #53e353e353e3", -"O c #566656665666", -"+ c #5fe35fe35fe3", -"@ c Gray45", -"# c #77d777d777d7", -"$ c Gray50", -"% c #866586658665", -"& c Gray56", -"* c Gray60", -"= c #9fff9fff9fff", -"- c Gray75", -"; c Gray81", -": c #dfffdfffdfff", -"> c #efffefffefff", -", c Gray100", -/* pixels */ -"------------------------", -"------------------------", -"------------------------", -"------------------------", -"-----#+++++++++++++&----", -"----- @@@@@@@@@@@@O+----", -"----- *%@@@@@@@@@&@+----", -"----- *X+$$$$$$$.@@+----", -"----- *X-,,,,,,,$@@+----", -"----- *X-,,;,,,,$@@+----", -"----- *X-:$$$-=,$@@+----", -"----- *X-+-+-$=,$@@+----", -"----- *X->$;;,,,$@@+----", -"----- *X--.$.,,,$@@+----", -"----- *X->--==,,$@@+----", -"----- *X-,,,,=;,$@@+----", -"----- *X-,,,,,,,$@@+----", -"----- *X-,,,,,,,$@@+----", -"----- *X&-------+@@+----", -"----- *@XXXXXXXXX%@+----", -"----- ************@+----", -"-----o #----", -"------------------------", -"------------------------" -}; +static char * uu_decode_xpm[] = { +"24 24 9 1", +" c None", +". c #919187876969", +"X c #C2C2B9B99C9C", +"o c #868686868686", +"O c #8F8F8F8F8F8F", +"+ c #000000000000", +"@ c #4C4C4C4C4C4C", +"# c #E9E9EFEFE8E8", +"$ c #8686ADAD7D7D", +" ", +" ", +" ", +" .............. ", +" X.o.........O.++ ", +" XX++++++++++..++ ", +" XX@########+..++ ", +" XX@########+..++ ", +" XX@$#$$$#$#+..++ ", +" XX@#$$$$$$#+..++ ", +" XX@##$#####+..++ ", +" XX@##$#$$##+..++ ", +" XX@##$#$$##+..++ ", +" XX@##$$#$$#+..++ ", +" XX@######$#+..++ ", +" XX@########+..++ ", +" XX@########+..++ ", +" XX.@@@@@@@@@..++ ", +" X.XXXXXXXXXX..++ ", +" .XXXXXXXXXXXX.++ ", +" +++++++++++++++ ", +" +++++++++++++++ ", +" ", +" "};
--- a/lisp/gnus/uu-post.xpm Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/uu-post.xpm Thu Jul 22 16:45:51 2004 +0000 @@ -1,57 +1,35 @@ /* XPM */ -static char *magick[] = { -/* columns rows colors chars-per-pixel */ -"24 24 27 1", -" c Gray0", -". c #0bfb0bfb0bfb", -"X c Gray9", -"o c Gray12", -"O c #2fef2fef2fef", -"+ c #3fff3fff3fff", -"@ c Gray28", -"# c #4ccc4ccc4ccc", -"$ c #53e353e353e3", -"% c #566656665666", -"& c #5fe25fe25fe2", -"* c #6fff6fff6fff", -"= c Gray45", -"- c #77d777d777d7", -"; c Gray50", -": c #866586658665", -"> c Gray56", -", c Gray60", -"< c #9bcb9bcb9bcb", -"1 c #9fff9fff9fff", -"2 c #a7c7a7c7a7c7", -"3 c Gray70", -"4 c Gray75", -"5 c Gray81", -"6 c #dfffdfffdfff", -"7 c #efffefffefff", -"8 c Gray100", -/* pixels */ -"$44$44$44$44$44$44$44$44", -"444444444444-44444444444", -"4444444444-O-O,444444444", -"$44$44$2>O-4$4$@>3$44$44", -"444444&&&4444442&&-44444", -"44444$ XOOOOOOOOO..-4444", -"$44$4O,,,,,,,,,,,,=&4$44", -"44444O,=#########:=&4444", -"44444O,#>4444444&==&4444", -"$44$4O,#48888888;==&4$44", -"44444O,#48818888;==&4444", -"44444O,#45+1+1*8;==&4444", -"$44$4O,#4*6&8158;==&4$44", -"44444O,#46;61888;==&4444", -"44444O,#44o++888;==&4444", -"$44$4O,#48885;78;==&4$44", -"44444O,#48888468;==&4444", -"44444O,#48888888;==&4444", -"$44$4O,#48888888;==&4$44", -"44444O,#&;;;;;;;+==&4444", -"44444O,:=========>=&4444", -"$44$4O============%&4$44", -"44444-&&&&&&&&&&&&&>4444", -"444444444444444444444444" -}; +static char * uu_post_xpm[] = { +"24 24 8 1", +". c None", +"X c #000000000000", +"+ c #C2C2B9B99C9C", +"@ c #919187876969", +"# c #868686868686", +"% c #4C4C4C4C4C4C", +"& c #E9E9EFEFE8E8", +"* c #8686ADAD7D7D", +"X..X..X..X.XX..X..X..X..", +"..........X.X...........", +".........X...X..........", +"X..X..X.XX..X.XX..X..X..", +".......X.......X........", +"......X.........X.......", +"X..X+X@@@@@@@@@@@XX..X..", +"....+@@@@@@@@@@@@@......", +"....++XXXXXXXXXX@@......", +"X..X++%&&&&&&&&X@@X..X..", +"....++%&&&&&&&&X@@......", +"....++%*&***&*&X@@......", +"X..X++%&******&X@@X..X..", +"....++%&&*&&&&&X@@......", +"....++%&&*&**&&X@@......", +"X..X++%&&*&**&&X@@X..X..", +"....++%&&**&**&X@@......", +"....++%&&&&&&*&X@@......", +"X..X++%&&&&&&&&X@@X..X..", +"....++%&&&&&&&&X@@......", +"....++@%%%%%%%%%@@......", +"X..X+@++++++++++@@X..X..", +"....+++++++++++++@......", +"........................"};
--- a/lisp/gnus/uudecode.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/uudecode.el Thu Jul 22 16:45:51 2004 +0000 @@ -1,6 +1,6 @@ -;;; uudecode.el --- elisp native uudecode +;;; uudecode.el -- elisp native uudecode -;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (c) 1998, 1999, 2000, 2001, 2003 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> ;; Keywords: uudecode news @@ -24,19 +24,9 @@ ;;; Commentary: -;; Lots of codes are stolen from mm-decode.el, gnus-uu.el and -;; base64.el +;;; Code: -;; This looks as though it could be made rather more efficient for -;; internal working. Encoding could use a lookup table and decoding -;; should presumably use a vector or list buffer for partial results -;; rather than with-current-buffer. -- fx - -;; Only `uudecode-decode-region' should be advertised, and whether or -;; not that uses a program should be customizable, but I guess it's -;; too late now. -- fx - -;;; Code: +(autoload 'executable-find "executable") (eval-when-compile (require 'cl)) @@ -44,15 +34,7 @@ (defalias 'uudecode-char-int (if (fboundp 'char-int) 'char-int - 'identity)) - - (if (featurep 'xemacs) - (defalias 'uudecode-insert-char 'insert-char) - (defun uudecode-insert-char (char &optional count ignored buffer) - (if (or (null buffer) (eq buffer (current-buffer))) - (insert-char char count) - (with-current-buffer buffer - (insert-char char count)))))) + 'identity))) (defcustom uudecode-decoder-program "uudecode" "*Non-nil value should be a string that names a uu decoder. @@ -66,6 +48,12 @@ :group 'gnus-extract :type '(repeat string)) +(defcustom uudecode-use-external + (executable-find uudecode-decoder-program) + "*Use external uudecode program." + :group 'gnus-extract + :type 'boolean) + (defconst uudecode-alphabet "\040-\140") (defconst uudecode-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") @@ -102,9 +90,13 @@ (match-string 1))))) (setq tempfile (if file-name (expand-file-name file-name) - (let ((temporary-file-directory - uudecode-temporary-file-directory)) - (make-temp-file "uu")))) + (if (fboundp 'make-temp-file) + (let ((temporary-file-directory + uudecode-temporary-file-directory)) + (make-temp-file "uu")) + (expand-file-name + (make-temp-name "uu") + uudecode-temporary-file-directory)))) (let ((cdir default-directory) default-process-coding-system) (unwind-protect @@ -131,86 +123,92 @@ (ignore-errors (or file-name (delete-file tempfile)))))) ;;;###autoload -(defun uudecode-decode-region (start end &optional file-name) +(defun uudecode-decode-region-internal (start end &optional file-name) "Uudecode region between START and END without using an external program. If FILE-NAME is non-nil, save the result to FILE-NAME." (interactive "r\nP") - (let ((work-buffer nil) - (done nil) + (let ((done nil) (counter 0) (remain 0) (bits 0) - (lim 0) inputpos + (lim 0) inputpos result (non-data-chars (concat "^" uudecode-alphabet))) - (unwind-protect - (save-excursion + (save-excursion + (goto-char start) + (when (re-search-forward uudecode-begin-line nil t) + (cond ((null file-name)) + ((stringp file-name)) + (t + (setq file-name (expand-file-name + (read-file-name "File to Name:" + nil nil nil + (match-string 1)))))) + (forward-line 1) + (skip-chars-forward non-data-chars end) + (while (not done) + (setq inputpos (point)) + (setq remain 0 bits 0 counter 0) + (cond + ((> (skip-chars-forward uudecode-alphabet end) 0) + (setq lim (point)) + (setq remain + (logand (- (uudecode-char-int (char-after inputpos)) 32) + 63)) + (setq inputpos (1+ inputpos)) + (if (= remain 0) (setq done t)) + (while (and (< inputpos lim) (> remain 0)) + (setq bits (+ bits + (logand + (- + (uudecode-char-int (char-after inputpos)) 32) + 63))) + (if (/= counter 0) (setq remain (1- remain))) + (setq counter (1+ counter) + inputpos (1+ inputpos)) + (cond ((= counter 4) + (setq result (cons + (concat + (char-to-string (lsh bits -16)) + (char-to-string (logand (lsh bits -8) 255)) + (char-to-string (logand bits 255))) + result)) + (setq bits 0 counter 0)) + (t (setq bits (lsh bits 6))))))) + (cond + (done) + ((> 0 remain) + (error "uucode line ends unexpectly") + (setq done t)) + ((and (= (point) end) (not done)) + ;;(error "uucode ends unexpectly") + (setq done t)) + ((= counter 3) + (setq result (cons + (concat + (char-to-string (logand (lsh bits -16) 255)) + (char-to-string (logand (lsh bits -8) 255))) + result))) + ((= counter 2) + (setq result (cons + (char-to-string (logand (lsh bits -10) 255)) + result)))) + (skip-chars-forward non-data-chars end)) + (if file-name + (let (default-enable-multibyte-characters) + (with-temp-file file-name + (insert (apply 'concat (nreverse result))))) + (or (markerp end) (setq end (set-marker (make-marker) end))) (goto-char start) - (when (re-search-forward uudecode-begin-line nil t) - (cond ((null file-name)) - ((stringp file-name)) - (t - (setq file-name (expand-file-name - (read-file-name "File to Name:" - nil nil nil - (match-string 1)))))) - (setq work-buffer (generate-new-buffer " *uudecode-work*")) - (forward-line 1) - (skip-chars-forward non-data-chars end) - (while (not done) - (setq inputpos (point)) - (setq remain 0 bits 0 counter 0) - (cond - ((> (skip-chars-forward uudecode-alphabet end) 0) - (setq lim (point)) - (setq remain - (logand (- (uudecode-char-int (char-after inputpos)) 32) - 63)) - (setq inputpos (1+ inputpos)) - (if (= remain 0) (setq done t)) - (while (and (< inputpos lim) (> remain 0)) - (setq bits (+ bits - (logand - (- - (uudecode-char-int (char-after inputpos)) 32) - 63))) - (if (/= counter 0) (setq remain (1- remain))) - (setq counter (1+ counter) - inputpos (1+ inputpos)) - (cond ((= counter 4) - (uudecode-insert-char - (lsh bits -16) 1 nil work-buffer) - (uudecode-insert-char - (logand (lsh bits -8) 255) 1 nil work-buffer) - (uudecode-insert-char (logand bits 255) 1 nil - work-buffer) - (setq bits 0 counter 0)) - (t (setq bits (lsh bits 6))))))) - (cond - (done) - ((> 0 remain) - (error "uucode line ends unexpectly") - (setq done t)) - ((and (= (point) end) (not done)) - ;;(error "uucode ends unexpectly") - (setq done t)) - ((= counter 3) - (uudecode-insert-char (logand (lsh bits -16) 255) 1 nil - work-buffer) - (uudecode-insert-char (logand (lsh bits -8) 255) 1 nil - work-buffer)) - ((= counter 2) - (uudecode-insert-char (logand (lsh bits -10) 255) 1 nil - work-buffer))) - (skip-chars-forward non-data-chars end)) - (if file-name - (save-excursion - (set-buffer work-buffer) - (write-file file-name)) - (or (markerp end) (setq end (set-marker (make-marker) end))) - (goto-char start) - (insert-buffer-substring work-buffer) - (delete-region (point) end)))) - (and work-buffer (kill-buffer work-buffer))))) + (insert (apply 'concat (nreverse result))) + (delete-region (point) end)))))) + +;;;###autoload +(defun uudecode-decode-region (start end &optional file-name) + "Uudecode region between START and END. +If FILE-NAME is non-nil, save the result to FILE-NAME." + (if uudecode-use-external + (uudecode-decode-region-external start end file-name) + (uudecode-decode-region-internal start end file-name))) (provide 'uudecode)
--- a/lisp/gnus/webmail.el Thu Jul 22 14:26:26 2004 +0000 +++ b/lisp/gnus/webmail.el Thu Jul 22 16:45:51 2004 +0000 @@ -48,21 +48,16 @@ (require 'gnus) (require 'nnmail) (require 'mm-util) +(require 'mm-url) (require 'mml) (eval-when-compile (ignore-errors - (require 'w3) (require 'url) - (require 'url-cookie) - (require 'w3-forms) - (require 'nnweb))) + (require 'url-cookie))) ;; Report failure to find w3 at load time if appropriate. (eval '(progn - (require 'w3) (require 'url) - (require 'url-cookie) - (require 'w3-forms) - (require 'nnweb))) + (require 'url-cookie))) ;;; @@ -144,14 +139,12 @@ (my-deja (paranoid cookie post) (address . "www.my-deja.com") - (open-url "http://www.deja.com/my/pr.xp") - (open-snarf . webmail-my-deja-open) + ;;(open-snarf . webmail-my-deja-open) (login-url content - ("%s" webmail-aux) - "member_name=%s&pw=%s&go=&priv_opt_MyDeja99=" + ("http://mydeja.google.com/cgi-bin/deja/maillogin.py") + "userid=%s&password=%s" user password) - (list-url "http://www.deja.com/rg_gotomail.xp") (list-snarf . webmail-my-deja-list) (article-snarf . webmail-my-deja-article) (trash-url webmail-aux id)))) @@ -228,31 +221,6 @@ (set (intern (concat "webmail-" (symbol-name var))) (cdr pair)) (set (intern (concat "webmail-" (symbol-name var))) nil))))) -(defun webmail-encode-www-form-urlencoded (pairs) - "Return PAIRS encoded for forms." - (mapconcat - (function - (lambda (data) - (concat (w3-form-encode-xwfu (car data)) "=" - (w3-form-encode-xwfu (cdr data))))) - pairs "&")) - -(defun webmail-fetch-simple (url content) - (let ((url-request-data content) - (url-request-method "POST") - (url-request-extra-headers - '(("Content-type" . "application/x-www-form-urlencoded")))) - (nnweb-insert url)) - t) - -(defun webmail-fetch-form (url pairs) - (let ((url-request-data (webmail-encode-www-form-urlencoded pairs)) - (url-request-method "POST") - (url-request-extra-headers - '(("Content-type" . "application/x-www-form-urlencoded")))) - (nnweb-insert url)) - t) - (defun webmail-eval (expr) (cond ((consp expr) @@ -267,15 +235,15 @@ (cond ((eq (car xurl) 'content) (pop xurl) - (webmail-fetch-simple (if (stringp (car xurl)) + (mm-url-fetch-simple (if (stringp (car xurl)) (car xurl) (apply 'format (webmail-eval (car xurl)))) (apply 'format (webmail-eval (cdr xurl))))) ((eq (car xurl) 'post) (pop xurl) - (webmail-fetch-form (car xurl) (webmail-eval (cdr xurl)))) + (mm-url-fetch-form (car xurl) (webmail-eval (cdr xurl)))) (t - (nnweb-insert (apply 'format (webmail-eval xurl))))))) + (mm-url-insert (apply 'format (webmail-eval xurl))))))) (defun webmail-init () "Initialize buffers and such." @@ -317,7 +285,7 @@ (let ((url (match-string 1))) (erase-buffer) (mm-with-unibyte-current-buffer - (nnweb-insert url))) + (mm-url-insert url))) (goto-char (point-min)))) (defun webmail-fetch (file subtype user password) @@ -359,7 +327,7 @@ (message "Fetching mail #%d..." (setq n (1+ n))) (erase-buffer) (mm-with-unibyte-current-buffer - (nnweb-insert (cdr item))) + (mm-url-insert (cdr item))) (setq id (car item)) (if webmail-article-snarf (funcall webmail-article-snarf file id)) @@ -461,9 +429,8 @@ (if (not (search-forward "</pre>" nil t)) (webmail-error "article@3.1")) (delete-region (match-beginning 0) (point-max)) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-min)) (while (re-search-forward "\r\n?" nil t) (replace-match "\n")) @@ -494,9 +461,8 @@ (setq p (match-beginning 0)) (search-forward "</a>" nil t) (delete-region p (match-end 0))) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-min)) (delete-blank-lines) (goto-char (point-min)) @@ -516,7 +482,7 @@ (delete-region p (match-end 0)) (save-excursion (set-buffer (generate-new-buffer " *webmail-att*")) - (nnweb-insert attachment) + (mm-url-insert attachment) (push (current-buffer) webmail-buffer-list) (setq bufname (buffer-name))) (setq mime t) @@ -551,9 +517,8 @@ (goto-char (match-end 0)) (if (looking-at "$") (forward-char)) (delete-region (point-min) (point)) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) nil) (t (setq mime t) @@ -648,9 +613,8 @@ (setq p (match-beginning 0)) (search-forward "</a>" nil t) (delete-region p (match-end 0))) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-min)) (delete-blank-lines) (goto-char (point-max)) @@ -666,9 +630,8 @@ (if (not (search-forward "</table>" nil t)) (webmail-error "article@5")) (narrow-to-region p (match-end 0)) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-min)) (delete-blank-lines) (setq ct (mail-fetch-field "content-type") @@ -681,7 +644,7 @@ (widen) (save-excursion (set-buffer (generate-new-buffer " *webmail-att*")) - (nnweb-insert (concat webmail-aux attachment)) + (mm-url-insert (concat webmail-aux attachment)) (push (current-buffer) webmail-buffer-list) (setq bufname (buffer-name))) (insert "<#part") @@ -776,9 +739,8 @@ (goto-char (point-min)) (while (re-search-forward "<br>" nil t) (replace-match "\n")) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) nil) (t (insert "<#part type=\"text/html\" disposition=inline>") @@ -806,9 +768,8 @@ (goto-char (point-min)) (while (search-forward "<b>" nil t) (replace-match "\n")) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-min)) (delete-blank-lines) (goto-char (point-min)) @@ -850,7 +811,7 @@ (let (bufname);; Attachment (save-excursion (set-buffer (generate-new-buffer " *webmail-att*")) - (nnweb-insert (concat (car webmail-open-url) attachment)) + (mm-url-insert (concat (car webmail-open-url) attachment)) (push (current-buffer) webmail-buffer-list) (setq bufname (buffer-name))) (insert "<#part type=" type) @@ -934,9 +895,8 @@ (goto-char (point-min)) (while (search-forward "<b>" nil t) (replace-match "\n")) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-min)) (delete-blank-lines) (goto-char (point-min)) @@ -978,7 +938,7 @@ (let (bufname);; Attachment (save-excursion (set-buffer (generate-new-buffer " *webmail-att*")) - (nnweb-insert (concat (car webmail-open-url) attachment)) + (mm-url-insert (concat (car webmail-open-url) attachment)) (push (current-buffer) webmail-buffer-list) (setq bufname (buffer-name))) (insert "<#part type=" type) @@ -1045,7 +1005,7 @@ (defun webmail-my-deja-open () (webmail-refresh-redirect) (goto-char (point-min)) - (if (re-search-forward "action=\"\\([^\"]+login_confirm\\.xp[^\"]*\\)\"" + (if (re-search-forward "action=\"\\([^\"]+maillogin\\.py[^\"]*\\)\"" nil t) (setq webmail-aux (match-string 1)) (webmail-error "open@1"))) @@ -1058,7 +1018,7 @@ (let ((url (match-string 1))) (setq base (match-string 2)) (erase-buffer) - (nnweb-insert url))) + (mm-url-insert url))) (goto-char (point-min)) (when (re-search-forward "(\\([0-9]+\\) Message.?-[^>]*\\([0-9]+\\) New" @@ -1095,9 +1055,8 @@ (match-beginning 0) (point-max))) (goto-char (point-min)) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-max)))) ((looking-at "[\t\040\r\n]*<TABLE") (save-restriction @@ -1126,7 +1085,7 @@ (delete-region (point-min) (point-max)) (save-excursion (set-buffer (generate-new-buffer " *webmail-att*")) - (nnweb-insert url) + (mm-url-insert url) (push (current-buffer) webmail-buffer-list) (setq bufname (buffer-name))) (insert "<#part type=\"" type "\"") @@ -1159,9 +1118,8 @@ (narrow-to-region (point-min) (point)) (while (search-forward "\r\n" nil t) (replace-match "\n")) - (nnweb-remove-markup) - (let ((w3-html-entities (cons '(nbsp . 32) w3-html-entities))) - (nnweb-decode-entities)) + (mm-url-remove-markup) + (mm-url-decode-entities-nbsp) (goto-char (point-min)) (while (re-search-forward "\n\n+" nil t) (replace-match "\n"))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/yenc.el Thu Jul 22 16:45:51 2004 +0000 @@ -0,0 +1,121 @@ +;;; 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) + +;;; arch-tag: 74df17e8-6fa8-4071-9f7d-54d548d79d9a +;;; yenc.el ends here