From 6a3cdbc8524dcb968a063a3356937432d6ad2465 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Thu, 17 Apr 2003 22:16:07 +0000 Subject: [PATCH] Synch to Oort Gnus 200304171901. --- lisp/ChangeLog | 23 +++++++++ lisp/gnus-art.el | 12 ++--- lisp/gnus-registry.el | 127 +++++++++++++++++++++++++++++++++++++------------ lisp/gnus.el | 15 +++++- lisp/nnmail.el | 2 +- lisp/rfc1843.el | 4 +- 6 files changed, 143 insertions(+), 40 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 3d8bbd6..9492a9a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,26 @@ +2003-04-17 Teodor Zlatanov + + * gnus.el (gnus-group-short-name, gnus-group-prefixed-p): new functions + (gnus-group-guess-full-name): don't prefix the group twice + + * nnmail.el (nnmail-split-fancy-with-parent): docstring fix + + * gnus-registry.el (gnus-registry-clear) + (gnus-registry-fetch-group, gnus-registry-grep-in-list) + (gnus-registry-split-fancy-with-parent): new functions + (gnus-register-spool-action, gnus-register-action): simplified the format + (gnus-registry): new customization group + (gnus-registry-unfollowed-groups): new variable + +2003-04-17 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-button-alist): Add nntp: urls. + (gnus-header-button-alist): Ditto. + +2003-04-17 Dave Love + + * gnus-util.el (gnus-string-equal): Revert last change. + 2003-04-17 Lars Magne Ingebrigtsen * gnus-srvr.el (gnus-browse-make-menu-bar): Fix typo. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index edc58e5..197ec03 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -6446,10 +6446,10 @@ positives are possible." 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 ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" - 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 4) - ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" - 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 2) + ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(news\\|nntp\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" + 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5) + ("\\b\\(news\\|nntp\\):\\(//\\)?\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3) ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) ("\\( \n\t]+\\)>" @@ -6575,8 +6575,8 @@ variable it the real callback function." 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: \\)?news:\\([^>\n ]*\\)>\\)" - 1 (>= gnus-button-message-level 0) gnus-button-message-id 3)) + ("^[^:]+:" "\\(<\\(url: \\)?\\(news\\|nntp\\):\\([^>\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 diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 37a4994..401663f 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -33,21 +33,21 @@ (require 'gnus-sum) (require 'nnmail) +(defgroup gnus-registry nil + "The Gnus registry." + :group 'gnus) + (defvar gnus-registry-hashtb nil "*The article registry by Message ID.") (defvar gnus-registry-headers-hashtb nil "*The article header registry by Message ID.") -;; (setq gnus-registry-hashtb (make-hash-table -;; :size 4096 -;; :test 'equal)) ; we test message ID strings equality - -;; sample data-header -;; (defvar tzz-header '(49 "Re[2]: good news" "\"Jonathan Pryor\" " "Mon, 17 Feb 2003 10:41:46 +-0800" "<88288020@dytqq>" "" 896 18 "lockgroove.bwh.harvard.edu spam.asian:49" nil)) -;; (maphash (lambda (key value) (message "key: %s value: %s" key value)) gnus-registry-hashtb) -;; (clrhash gnus-registry-hashtb) -;; (setq gnus-registry-alist nil) +(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)) ;; Function(s) missing in Emacs 20 (when (memq nil (mapcar 'fboundp '(puthash))) @@ -58,11 +58,13 @@ (defun gnus-registry-translate-to-alist () (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb)) - (setq gnus-registry-headers-alist (hashtable-to-alist gnus-registry-headers-hashtb))) + (setq gnus-registry-headers-alist (hashtable-to-alist + gnus-registry-headers-hashtb))) (defun gnus-registry-translate-from-alist () (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) - (setq gnus-registry-headers-hashtb (alist-to-hashtable gnus-registry-headers-alist))) + (setq gnus-registry-headers-hashtb (alist-to-hashtable + gnus-registry-headers-alist))) (defun alist-to-hashtable (alist) "Build a hashtable from the values in ALIST." @@ -85,30 +87,95 @@ list)) (defun gnus-register-action (action data-header from &optional to method) - (let* ((id (mail-header-id data-header))) + (let* ((id (mail-header-id data-header)) + (from (gnus-group-guess-full-name from)) + (to (if to (gnus-group-guess-full-name to) nil)) + (to-name (if to to "the Bit Bucket"))) (gnus-message 5 "Registry: article %s %s from %s to %s" - id - (if method "respooling" "going") - (gnus-group-guess-full-name from) - (if to (gnus-group-guess-full-name to) "the Bit Bucket")) + id + (if method "respooling" "going") + from + to) (unless (gethash id gnus-registry-headers-hashtb) (puthash id (list data-header) gnus-registry-headers-hashtb)) - (puthash id (cons (list action from to method) - (gethash id gnus-registry-hashtb)) gnus-registry-hashtb))) + (puthash id (cons (list action from to) + (gethash id gnus-registry-hashtb)) + gnus-registry-hashtb))) (defun gnus-register-spool-action (id group) - (when (string-match " $" id) - (setq id (substring id 0 -1))) - (gnus-message 5 "Registry: article %s spooled to %s" - id - (gnus-group-prefixed-name - group - gnus-internal-registry-spool-current-method - t)) - (puthash id (cons (list 'spool nil group nil) - (gethash id gnus-registry-hashtb)) gnus-registry-hashtb)) - -(add-hook 'gnus-summary-article-move-hook 'gnus-register-action) ; also does copy, respool, and crosspost + ;; do not process the draft IDs +; (unless (string-match "totally-fudged-out-message-id" id) + (let ((group (gnus-group-guess-full-name group))) + (when (string-match " $" id) + (setq id (substring id 0 -1))) + (gnus-message 5 "Registry: article %s spooled to %s" + id + group) + (puthash id (cons (list 'spool nil group) + (gethash id gnus-registry-hashtb)) + gnus-registry-hashtb))) +;) + +;; Function for nn{mail|imap}-split-fancy: look up all references in +;; the cache and if a match is found, return that group. +(defun gnus-registry-split-fancy-with-parent () + "Split this message into the same group as its parent. The parent +is obtained from the registry. This function can be used as an entry +in `nnmail-split-fancy' or `nnimap-split-fancy', for example like +this: (: gnus-registry-split-fancy-with-parent) + +For a message to be split, it looks for the parent message in the +References or In-Reply-To header and then looks in the registry to +see which group that message was put in. This group is returned. + +See the Info node `(gnus)Fancy Mail Splitting' for more details." + (let ((refstr (or (message-fetch-field "references") + (message-fetch-field "in-reply-to"))) + (references nil) + (res nil)) + (when refstr + (setq references (nreverse (gnus-split-references refstr))) + (mapcar (lambda (x) + (setq res (or (gnus-registry-fetch-group x) res)) + (when (or (gnus-registry-grep-in-list + res + gnus-registry-unfollowed-groups) + (gnus-registry-grep-in-list + res + nnmail-split-fancy-with-parent-ignore-groups)) + (setq res nil))) + references) + res))) + +(defun gnus-registry-grep-in-list (word list) + (memq nil + (mapcar 'not + (mapcar + (lambda (x) + (string-match x word)) + list)))) + + +(defun gnus-registry-fetch-group (id) + "Get the group of a message, based on the message ID. +Returns the first place where the trail finds a spool action." + (let ((trail (gethash id gnus-registry-hashtb))) + (dolist (crumb trail) + (let ((action (nth 0 crumb)) + (from (nth 1 crumb)) + (to (nth 2 crumb))) + (when (eq action 'spool) + (return to)))))) + +(defun gnus-registry-clear () + "Clear the Gnus registry." + (interactive) + (setq gnus-registry-alist nil + gnus-registry-headers-alist nil) + (gnus-registry-translate-from-alist)) + +; also does copy, respool, and crosspost +(add-hook 'gnus-summary-article-move-hook 'gnus-register-action) (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action) (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action) (add-hook 'nnmail-spool-hook 'gnus-register-spool-action) diff --git a/lisp/gnus.el b/lisp/gnus.el index c4222e1..336c361 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -3296,7 +3296,9 @@ native." (defun gnus-group-guess-full-name (group) "Guess the full name from GROUP, even if the method is native." - (gnus-group-full-name group (gnus-find-method-for-group group))) + (if (gnus-group-prefixed-p group) + group + (gnus-group-full-name group (gnus-find-method-for-group group)))) (defun gnus-group-real-prefix (group) "Return the prefix of the current group name." @@ -3304,6 +3306,17 @@ native." (substring group 0 (match-end 0)) "")) +(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) "*")) diff --git a/lisp/nnmail.el b/lisp/nnmail.el index a249612..06ee776 100644 --- a/lisp/nnmail.el +++ b/lisp/nnmail.el @@ -1546,7 +1546,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." (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) +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 diff --git a/lisp/rfc1843.el b/lisp/rfc1843.el index 13a9cbe..cba8ece 100644 --- a/lisp/rfc1843.el +++ b/lisp/rfc1843.el @@ -43,11 +43,11 @@ (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. -- 1.7.10.4