From 14e8de0c3f87a228c05902be66c5bcf953636611 Mon Sep 17 00:00:00 2001 From: Miles Bader Date: Sat, 1 Mar 2008 01:28:14 +0000 Subject: [PATCH] Merge from gnus--devo--0 Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1089 --- lisp/gnus/ChangeLog | 48 +++++- lisp/gnus/gnus-registry.el | 369 +++++++++++++++++++++++++++++++-------------- lisp/gnus/mm-uu.el | 12 +- lisp/gnus/nnmairix.el | 22 +-- lisp/gnus/nnweb.el | 2 +- 5 files changed, 321 insertions(+), 132 deletions(-) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 1657f08b22c..93bf2c1e1e5 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,20 @@ +2008-02-29 Andreas Seltenreich + + * nnweb.el (nnweb-google-parse-1): Fix date parsing on articles with + empty author. + +2008-02-29 Teodor Zlatanov + + * gnus-registry.el (gnus-registry-marks): Add variable for + customization of marks and their appearance. + (gnus-registry-read-mark): Use it. + (gnus-registry-do-marks): Add utility function to loop through + `gnus-registry-marks'. + (gnus-registry-install-shortcuts-and-menus): Add function to install + shortcuts and menus. + (gnus-registry-initialize): Use it. + (gnus-registry-default-mark): Clarify documentation. + 2008-02-29 Glenn Morris * gnus-art.el, gnus-bookmark.el, gnus-dired.el, gnus-draft.el: @@ -6,10 +23,38 @@ * nnmail.el, pop3.el, smiley.el, smime.el, spam-report.el: Change defcustom :version from 23.0 to 23.1. +2008-02-28 Teodor Zlatanov + + * gnus-registry.el (gnus-registry-follow-group-p) + (gnus-registry-post-process-groups): Add functions to aid registry + splitting and improve logging. Clarify behavior in function + documentation. + (gnus-registry-split-fancy-with-parent): Use them. + 2008-02-28 Stefan Monnier * gnus-art.el: Use with-current-buffer. +2008-02-27 David Engster + + * nnmairix.el (nnmairix-request-group-with-article-number-correction): + Express real group name in the response. + +2008-02-27 Katsumi Yamaoka + + * nnmairix.el (nnmairix-group-regexp, nnmairix-valid-backends) + (nnmairix-last-server, nnmairix-current-server): Defvar them. + (nnmairix-goto-original-article): Defvar gnus-registry-install and + autoload gnus-registry-fetch-group when compiling. + (nnmairix-request-group-with-article-number-correction): remove + unreferenced argument passed to nnmairix-call-backend. + +2008-02-27 Reiner Steib + + * mm-uu.el (mm-uu-type-alist): Fix message-marks non-hide arguments. + (mm-uu-extract): Improve face for low color ttys. Reported by Sascha + Wilde. + 2008-02-27 Glenn Morris * nnmairix.el: Change defcustom :version from 23.0 to 23.1. @@ -20,7 +65,8 @@ (gnus-registry-fetch-group): Autoload. (nnmairix-replace-group-and-numbers): Use mapc rather than mapcar. (nnmairix-widget-get-values, nnmairix-widget-make-query-from-widgets) - (nnmairix-widget-build-editable-fields): Use car cddr rather than caddr. + (nnmairix-widget-build-editable-fields): Use car cddr rather than + caddr. (nnmairix-request-group): Bind nnmairix-fast and nnmairix-group around nnmairix-request-group-with-article-number-correction call. (nnmairix-fast, nnmairix-group): New, less general names, for free diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 873ebb604f9..2803cd9db6d 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -79,17 +79,49 @@ "*The article registry by Message ID.") (defcustom gnus-registry-marks - '(Important Work Personal To-Do Later) - "List of marks that `gnus-registry-mark-article' will offer for completion." + '((Important + (char . ?i) + (image . "summary_important")) + (Work + (char . ?w) + (image . "summary_work")) + (Personal + (char . ?p) + (image . "summary_personal")) + (To-Do + (char . ?t) + (image . "summary_todo")) + (Later + (char . ?l) + (image . "summary_later"))) + + "List of registry marks and their options. + +`gnus-registry-mark-article' will offer symbols from this list +for completion. + +Each entry must have a character to be useful for summary mode +line display and for keyboard shortcuts. + +Each entry must have an image string to be useful for visual +display." :group 'gnus-registry - :type '(repeat symbol)) + :type '(alist :key-type symbol + :value-type (set :tag "Mark details" + (cons :tag "Shortcut" + (const :tag "Character code" char) + character) + (cons :tag "Visual" + (const :tag "Image" image) + string)))) (defcustom gnus-registry-default-mark 'To-Do - "The default mark." + "The default mark. Should be a valid key for `gnus-registry-marks'." :group 'gnus-registry :type 'symbol) -(defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$") +(defcustom gnus-registry-unfollowed-groups + '("delayed$" "drafts$" "queue$" "INBOX$") "List of groups that gnus-registry-split-fancy-with-parent won't return. The group names are matched, they don't have to be fully qualified. This parameter tells the Registry 'never split a @@ -197,7 +229,8 @@ considered precious) will not be trimmed." (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-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) @@ -221,7 +254,8 @@ considered precious) will not be trimmed." (unwind-protect (progn (gnus-with-output-to-file working-file - (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) + (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 @@ -382,7 +416,8 @@ Any entries with extra data (marks, currently) are left alone." (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (mail-header-subject data-header)))) - (sender (gnus-string-remove-all-properties (mail-header-from data-header))) + (sender (gnus-string-remove-all-properties + (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")) @@ -425,119 +460,152 @@ messages. 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, unless it matches one of the entries in -gnus-registry-unfollowed-groups or -nnmail-split-fancy-with-parent-ignore-groups. +returned, unless `gnus-registry-follow-group-p' return nil for +that group. See the Info node `(gnus)Fancy Mail Splitting' for more details." - (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string - (reply-to (message-fetch-field "in-reply-to")) ; grab reply-to + (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed + (reply-to (message-fetch-field "in-reply-to")) ; may be nil ;; now, if reply-to is valid, append it to the References (refstr (if reply-to (concat refstr " " reply-to) refstr)) - (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))) - res) - ;; the references string must be valid and parse to valid references - (if (and refstr (gnus-extract-references refstr)) - (dolist (reference (nreverse (gnus-extract-references refstr))) - (setq res (or (gnus-registry-fetch-group reference) 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))) - - ;; else: there were no references, now try the extra tracking - (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from"))) - (subject (gnus-string-remove-all-properties - (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)) - (when (and sender res) - (gnus-message - ;; raise level of messaging if gnus-registry-track-extra - (if gnus-registry-track-extra 7 9) - "%s (extra tracking) traced sender %s to group %s" - "gnus-registry-split-fancy-with-parent" - sender - res))))) - 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)) - (when (and subject res) - (gnus-message - ;; raise level of messaging if gnus-registry-track-extra - (if gnus-registry-track-extra 7 9) - "%s (extra tracking) traced subject %s to group %s" - "gnus-registry-split-fancy-with-parent" - subject - res))))) - gnus-registry-hashtb)) - (unless single-match - (gnus-message - 3 - "gnus-registry-split-fancy-with-parent: too many extra matches for %s" - refstr) - (setq res nil)))) - (when (and refstr res) - (gnus-message - 5 - "gnus-registry-split-fancy-with-parent traced %s to group %s" - refstr res)) - - (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 + ;; these may not be used, but the code is cleaner having them up here + (sender (gnus-string-remove-all-properties + (message-fetch-field "from"))) + (subject (gnus-string-remove-all-properties + (gnus-registry-simplify-subject + (message-fetch-field "subject")))) + + (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))) + (log-agent "gnus-registry-split-fancy-with-parent") + found) + + ;; this is a big if-else statement. it uses + ;; gnus-registry-post-process-groups to filter the results after + ;; every step. + (cond + ;; the references string must be valid and parse to valid references + ((and refstr (gnus-extract-references refstr)) + (dolist (reference (nreverse (gnus-extract-references refstr))) + (gnus-message + 9 + "%s is looking for matches for reference %s from [%s]" + log-agent reference refstr) + (dolist (group (gnus-registry-fetch-groups reference)) + (when (and group (gnus-registry-follow-group-p group)) (gnus-message - 9 - "gnus-registry-split-fancy-with-parent stripped group %s to %s" - res - short-res) - (setq res short-res)) - ;; else... + 7 + "%s traced the reference %s from [%s] to group %s" + log-agent reference refstr group) + (push group found)))) + ;; filter the found groups and return them + (setq found (gnus-registry-post-process-groups + "references" refstr found))) + + ;; else: there were no matches, now try the extra tracking by sender + ((and (gnus-registry-track-sender-p) + sender) + (maphash + (lambda (key value) + (let ((this-sender (cdr + (gnus-registry-fetch-extra key 'sender))) + matches) + (when (and this-sender + (equal sender this-sender)) + (setq found (append (gnus-registry-fetch-groups key) found)) + (push key matches) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced sender %s to groups %s (keys %s)" + log-agent sender found matches)))) + gnus-registry-hashtb) + ;; filter the found groups and return them + (setq found (gnus-registry-post-process-groups "sender" sender found))) + + ;; else: there were no matches, now try the extra tracking by subject + ((and (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))) + matches) + (when (and this-subject + (equal subject this-subject)) + (setq found (append (gnus-registry-fetch-groups key) found)) + (push key matches) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced subject %s to groups %s (keys %s)" + log-agent subject found matches)))) + gnus-registry-hashtb) + ;; filter the found groups and return them + (setq found (gnus-registry-post-process-groups + "subject" subject found)))))) + +(defun gnus-registry-post-process-groups (mode key groups) + "Modifies GROUPS found by MODE for KEY to determine which ones to follow. + +MODE can be 'subject' or 'sender' for example. The KEY is the +value by which MODE was searched. + +Transforms each group name to the equivalent short name. + +Checks if the current Gnus method (from `gnus-command-method' or +from `gnus-newsgroup-name') is the same as the group's method. +This is not possible if gnus-registry-use-long-group-names is +false. Foreign methods are not supported so they are rejected. + +Reduces the list to a single group, or complains if that's not +possible." + (let ((log-agent "gnus-registry-post-process-group") + out) + (if gnus-registry-use-long-group-names + (dolist (group groups) + (let ((m1 (gnus-find-method-for-group group)) + (m2 (or gnus-command-method + (gnus-find-method-for-group gnus-newsgroup-name))) + (short-name (gnus-group-short-name group))) + (if (gnus-methods-equal-p m1 m2) + (progn + ;; this is REALLY just for debugging + (gnus-message + 10 + "%s stripped group %s to %s" + log-agent group short-name) + (unless (member short-name out) + (push short-name out))) + ;; else... + (gnus-message + 7 + "%s ignored foreign group %s" + log-agent group)))) + (setq out groups)) + (when (cdr-safe out) (gnus-message - 7 - "gnus-registry-split-fancy-with-parent ignored foreign group %s" - res) - (setq res nil)))) - res)) + 5 + "%s: too many extra matches (%s) for %s %s. Returning none." + log-agent out mode key) + (setq out nil)) + out)) + +(defun gnus-registry-follow-group-p (group) + "Determines if a group name should be followed. +Consults `gnus-registry-unfollowed-groups' and +`nnmail-split-fancy-with-parent-ignore-groups'." + (not (or (gnus-registry-grep-in-list + group + gnus-registry-unfollowed-groups) + (gnus-registry-grep-in-list + group + nnmail-split-fancy-with-parent-ignore-groups)))) (defun gnus-registry-wash-for-keywords (&optional force) (interactive) @@ -627,6 +695,78 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (string-match word x)) list))))) +(defun gnus-registry-do-marks (type function) + "For each known mark, call FUNCTION for each cell of type TYPE. + +FUNCTION should take two parameters, a mark symbol and the cell value." + (dolist (mark-info gnus-registry-marks) + (let ((mark (car-safe mark-info)) + (data (cdr-safe mark-info))) + (dolist (cell data) + (let ((cell-type (car-safe cell)) + (cell-data (cdr-safe cell))) + (when (equal type cell-type) + (funcall function mark cell-data))))))) + +;;; this is ugly code, but I don't know how to do it better +;;; TODO: clear the gnus-registry-mark-map before running +(defun gnus-registry-install-shortcuts-and-menus () + "Install the keyboard shortcuts and menus for the registry. +Uses `gnus-registry-marks' to find what shortcuts to install." + (gnus-registry-do-marks + 'char + (lambda (mark data) + (let ((function-format + (format "gnus-registry-%%s-article-%s-mark" mark))) + +;;; The following generates these functions: +;;; (defun gnus-registry-set-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) +;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) + + (dolist (remove '(t nil)) + (let* ((variant-name (if remove "remove" "set")) + (function-name (format function-format variant-name)) + (shortcut (format "%c" data)) + (shortcut (if remove (upcase shortcut) shortcut))) + (unintern function-name) + (eval + `(defun + ;; function name + ,(intern function-name) + ;; parameter definition + (&rest articles) + ;; documentation + ,(format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark) + ;; interactive definition + (interactive + (gnus-summary-work-articles current-prefix-arg)) + ;; actual code + (gnus-registry-set-article-mark-internal + ;; all this just to get the mark, I must be doing it wrong + (intern ,(symbol-name mark)) + articles ,remove t)))))))) + ;; I don't know how to do this inside the loop above, because + ;; gnus-define-keys is a macro + (gnus-define-keys (gnus-registry-mark-map "M" gnus-summary-mark-map) + "i" gnus-registry-set-article-Important-mark + "I" gnus-registry-remove-article-Important-mark + "w" gnus-registry-set-article-Work-mark + "W" gnus-registry-remove-article-Work-mark + "l" gnus-registry-set-article-Later-mark + "L" gnus-registry-remove-article-Later-mark + "p" gnus-registry-set-article-Personal-mark + "P" gnus-registry-remove-article-Personal-mark + "t" gnus-registry-set-article-To-Do-mark + "T" gnus-registry-remove-article-To-Do-mark)) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." @@ -634,7 +774,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (symbol-name gnus-registry-default-mark) "Label" (mapcar (lambda (x) ; completion list - (cons (symbol-name x) x)) + (cons (symbol-name (car-safe x)) (car-safe x))) gnus-registry-marks)))) (when (stringp mark) (intern mark)))) @@ -896,6 +1036,7 @@ Returns the first place where the trail finds a group name." (interactive) (setq gnus-registry-install t) (gnus-registry-install-hooks) + (gnus-registry-install-shortcuts-and-menus) (gnus-registry-read)) ;;;###autoload diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index 898be5a5bac..bf5125e37a2 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -167,7 +167,7 @@ This can be either \"inline\" or \"attachment\".") ;; dependency on `message.el'. "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" - (lambda () (mm-uu-verbatim-marks-extract 0 -1 1 -1)) + (lambda () (mm-uu-verbatim-marks-extract -1 0 1 -1)) nil) ;; Omitting [a-z8<] leads to false positives (bogus signature separators ;; and mailing list banners). @@ -248,11 +248,19 @@ The value should be nil on displays where the face :version "23.1" ;; No Gnus :group 'gnus-article-mime) -(defface mm-uu-extract '(;; Colors from `gnus-cite-3' plus background: +(defface mm-uu-extract '(;; Inspired by `gnus-cite-3' + (((type tty) + (class color) + (background dark)) + (:background "dark blue")) (((class color) (background dark)) (:foreground "light yellow" :background "dark green")) + (((type tty) + (class color) + (background light)) + (:foreground "dark blue")) (((class color) (background light)) (:foreground "dark green" diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 27f8fa035d7..57b840ff692 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -434,10 +434,8 @@ Other backends might or might not work.") "request-scan" folder nnmairix-backend-server) (if fast t - (let ((nnmairix-fast fast) - (nnmairix-group group)) - (nnmairix-request-group-with-article-number-correction - folder qualgroup)))) + (nnmairix-request-group-with-article-number-correction + folder qualgroup))) ((and (= rval 1) (save-excursion (set-buffer nnmairix-mairix-output-buffer) (goto-char (point-min)) @@ -849,7 +847,10 @@ with `nnmairix-mairix-update-options'." (set-process-sentinel (apply 'start-process args) 'nnmairix-sentinel-mairix-update-finished)))))) -(autoload 'gnus-registry-fetch-group "gnus-registry") +;; Silence byte-compiler. +(eval-when-compile + (defvar gnus-registry-install) + (autoload 'gnus-registry-fetch-group "gnus-registry")) (defun nnmairix-goto-original-article (&optional no-registry) "Jump to the original group and display article. @@ -978,17 +979,10 @@ search in raw mode." ;;; ==== Helper functions -;; Set locally in nnmairix-request-group, which is the only caller of -;; this function. -(defvar nnmairix-fast) -(defvar nnmairix-group) - (defun nnmairix-request-group-with-article-number-correction (folder qualgroup) "Request FOLDER on backend for nnmairix QUALGROUP and article number correction." (save-excursion - ;; FIXME nnmairix-request-group only calls this when fast is nil (?). - (nnmairix-call-backend - "request-group" folder nnmairix-backend-server nnmairix-fast) + (nnmairix-call-backend "request-group" folder nnmairix-backend-server) (set-buffer nnmairix-mairix-output-buffer) (goto-char (point-min)) (re-search-forward "^Matched.*messages") @@ -1021,7 +1015,7 @@ search in raw mode." qualgroup 'numcorr (list nil 0 high)))) (erase-buffer) (insert (format "%d %d %d %d %s" status total low high - nnmairix-group)) + (gnus-group-real-name qualgroup))) t) (progn (nnheader-report diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index f472aeacb14..56a287ef5e7 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -367,7 +367,7 @@ Valid types include `google', `dejanews', and `gmane'.") (goto-char (point-max)) (when (re-search-backward - "^\\(?:\\(\\w+\\) \\([0-9]+\\)\\|\\S-+\\)\\(?: \\([0-9]\\{4\\}\\)\\)? by \\(.*\\)" + "^\\(?:\\(\\w+\\) \\([0-9]+\\)\\|\\S-+\\)\\(?: \\([0-9]\\{4\\}\\)\\)? by ?\\(.*\\)" nil t) (setq Date (if (match-string 1) (format "%s %s 00:00:00 %s" -- 2.11.4.GIT