X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=cbea1e17ed85cc4458caa47bf321e30df3f08d5f;hb=08f6e480c169912013f4302fec8b5592befed5ad;hp=fd08d4d1e390fec959700fae9cc4b09b6b4e4c98;hpb=6d3039252bb175eba53a2028cbf3c0e90112388d;p=gnus diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index fd08d4d1e..cbea1e17e 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,27 +1,25 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;;; Free Software Foundation, Inc. ;; Author: Ted Zlatanov -;; Keywords: news +;; Keywords: news registry ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 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 +;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -38,10 +36,12 @@ ;; Put this in your startup file (~/.gnus.el for instance) +;; (require 'nnregistry) ;; optional, or see below (automatically calls `gnus-registry-install-nnregistry' when `gnus-registry-initialize' is called) ;; (setq gnus-registry-max-entries 2500 ;; gnus-registry-use-long-group-names t) ;; (gnus-registry-initialize) +;; (gnus-registry-install-nnregistry) ;; optional, or see above (loading nnregistry makes it unnecessary) ;; Then use this in your fancy-split: @@ -62,6 +62,7 @@ (require 'gnus-sum) (require 'gnus-util) (require 'nnmail) +(require 'easymenu) (defvar gnus-adaptive-word-syntax-table) @@ -73,7 +74,7 @@ :version "22.1" :group 'gnus) -(defvar gnus-registry-hashtb (make-hash-table +(defvar gnus-registry-hashtb (make-hash-table :size 256 :test 'equal) "*The article registry by Message ID.") @@ -98,7 +99,7 @@ "List of registry marks and their options. `gnus-registry-mark-article' will offer symbols from this list -for completion. +for completion. Each entry must have a character to be useful for summary mode line display and for keyboard shortcuts. @@ -122,13 +123,15 @@ display." :group 'gnus-registry :type 'symbol) -(defcustom gnus-registry-unfollowed-groups - '("delayed$" "drafts$" "queue$" "INBOX$") +(defcustom gnus-registry-unfollowed-groups + '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:") "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 message into a group that matches one of these, regardless of -references.'" +references.' + +nnmairix groups are specifically excluded because they are ephemeral." :group 'gnus-registry :type '(repeat regexp)) @@ -139,6 +142,10 @@ references.'" (const :tag "Always Install" t) (const :tag "Ask Me" ask))) +(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. + +(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus + (defcustom gnus-registry-clean-empty t "Whether the empty registry entries should be deleted. Registry entries are considered empty when they have no groups @@ -146,11 +153,17 @@ and no extra data." :group 'gnus-registry :type 'boolean) -(defcustom gnus-registry-use-long-group-names nil - "Whether the registry should use long group names (BUGGY)." +(defcustom gnus-registry-use-long-group-names t + "Whether the registry should use long group names." :group 'gnus-registry :type 'boolean) +(defcustom gnus-registry-max-track-groups 20 + "The maximum number of non-unique group matches to check for a message ID." + :group 'gnus-registry + :type '(radio (const :format "Unlimited " nil) + (integer :format "Maximum non-unique matches: %v"))) + (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 @@ -161,6 +174,17 @@ way." (const :tag "Track by subject (Subject: header)" subject) (const :tag "Track by sender (From: header)" sender))) +(defcustom gnus-registry-split-strategy 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 + '(choice :tag "Tracking choices" + (const :tag "Only use single choices, discard multiple matches" nil) + (const :tag "Majority of matches wins" majority) + (const :tag "First found wins" first))) + (defcustom gnus-registry-entry-caching t "Whether the registry should cache extra information." :group 'gnus-registry @@ -186,9 +210,9 @@ considered precious) will not be trimmed." :group 'gnus-registry :type '(repeat symbol)) -(defcustom gnus-registry-cache-file - (nnheader-concat - (or gnus-dribble-directory gnus-home-directory "~/") +(defcustom gnus-registry-cache-file + (nnheader-concat + (or gnus-dribble-directory gnus-home-directory "~/") ".gnus.registry.eld") "File where the Gnus registry will be stored." :group 'gnus-registry @@ -221,8 +245,7 @@ considered precious) will not be trimmed." "Save the registry cache file." (interactive) (let ((file gnus-registry-cache-file)) - (save-excursion - (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) + (with-current-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) @@ -233,7 +256,7 @@ 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 + (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist) (gnus-registry-cache-whitespace file) (save-buffer)) @@ -249,16 +272,14 @@ considered precious) will not be trimmed." (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")) + "%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-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) ;; These bindings will mislead the current buffer @@ -308,7 +329,7 @@ considered precious) will not be trimmed." (when gnus-registry-clean-empty (gnus-registry-clean-empty-function)) ;; now trim and clean text properties from the registry appropriately - (setq gnus-registry-alist + (setq gnus-registry-alist (gnus-registry-remove-alist-text-properties (gnus-registry-trim (gnus-hashtable-to-alist @@ -328,7 +349,7 @@ considered precious) will not be trimmed." (dolist (group (gnus-registry-fetch-groups key)) (when (gnus-parameter-registry-ignore group) (gnus-message - 10 + 10 "gnus-registry: deleted ignored group %s from key %s" group key) (gnus-registry-delete-group key group))) @@ -343,14 +364,14 @@ considered precious) will not be trimmed." (gnus-registry-fetch-extra key 'label)) (incf count) (gnus-registry-delete-id key)) - + (unless (stringp key) - (gnus-message - 10 - "gnus-registry key %s was not a string, removing" + (gnus-message + 10 + "gnus-registry key %s was not a string, removing" key) (gnus-registry-delete-id key)))) - + gnus-registry-hashtb) count)) @@ -373,7 +394,7 @@ considered precious) will not be trimmed." (defun gnus-registry-trim (alist) "Trim alist to size, using gnus-registry-max-entries. Any entries with extra data (marks, currently) are left alone." - (if (null 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 @@ -402,25 +423,25 @@ Any entries with extra data (marks, currently) are left alone." (push item precious-list) (push item junk-list)))) - (sort + (sort junk-list (lambda (a b) - (let ((t1 (or (cdr (gethash (car a) timehash)) + (let ((t1 (or (cdr (gethash (car a) timehash)) '(0 0 0))) - (t2 (or (cdr (gethash (car b) timehash)) + (t2 (or (cdr (gethash (car b) timehash)) '(0 0 0)))) (time-less-p t1 t2)))) ;; we use the return value of this setq, which is the trimmed alist (setq alist (append precious-list (nthcdr trim-length junk-list)))))) - + (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (mail-header-subject data-header)))) - (sender (gnus-string-remove-all-properties + (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)) @@ -471,7 +492,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (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 + (refstr (if reply-to (concat refstr " " reply-to) refstr)) ;; these may not be used, but the code is cleaner having them up here @@ -486,7 +507,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." nnmail-split-fancy-with-parent-ignore-groups (list nnmail-split-fancy-with-parent-ignore-groups))) (log-agent "gnus-registry-split-fancy-with-parent") - found) + found found-full) ;; this is a big if-else statement. it uses ;; gnus-registry-post-process-groups to filter the results after @@ -499,7 +520,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 9 "%s is looking for matches for reference %s from [%s]" log-agent reference refstr) - (dolist (group (gnus-registry-fetch-groups reference)) + (dolist (group (gnus-registry-fetch-groups + reference + gnus-registry-max-track-groups)) (when (and group (gnus-registry-follow-group-p group)) (gnus-message 7 @@ -507,12 +530,15 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 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))) + ;; the found groups are the full groups + (setq found (gnus-registry-post-process-groups + "references" refstr found found))) ;; else: there were no matches, now try the extra tracking by sender - ((and (gnus-registry-track-sender-p) - sender) + ((and (gnus-registry-track-sender-p) + sender + (not (equal (gnus-extract-address-component-email sender) + user-mail-address))) (maphash (lambda (key value) (let ((this-sender (cdr @@ -520,8 +546,11 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." matches) (when (and this-sender (equal sender this-sender)) - (let ((groups (gnus-registry-fetch-groups key))) + (let ((groups (gnus-registry-fetch-groups + key + gnus-registry-max-track-groups))) (dolist (group groups) + (push group found-full) (setq found (append (list group) (delete group found))))) (push key matches) (gnus-message @@ -531,8 +560,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 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))) - + ;; the found groups are NOT the full groups + (setq found (gnus-registry-post-process-groups + "sender" sender found found-full))) + ;; else: there were no matches, now try the extra tracking by subject ((and (gnus-registry-track-subject-p) subject @@ -544,8 +575,11 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." matches) (when (and this-subject (equal subject this-subject)) - (let ((groups (gnus-registry-fetch-groups key))) + (let ((groups (gnus-registry-fetch-groups + key + gnus-registry-max-track-groups))) (dolist (group groups) + (push group found-full) (setq found (append (list group) (delete group found))))) (push key matches) (gnus-message @@ -555,10 +589,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 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)))))) + ;; the found groups are NOT the full groups + (setq found (gnus-registry-post-process-groups + "subject" subject found found-full)))) + ;; after the (cond) we extract the actual value safely + (car-safe found))) -(defun gnus-registry-post-process-groups (mode key groups) +(defun gnus-registry-post-process-groups (mode key groups groups-full) "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 @@ -572,9 +609,28 @@ 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." +possible. Uses `gnus-registry-split-strategy' and GROUPS-FULL if +necessary." (let ((log-agent "gnus-registry-post-process-group") out) + + ;; the strategy can be 'first, 'majority, or nil + (when (eq gnus-registry-split-strategy 'first) + (when groups + (setq groups (list (car-safe groups))))) + + (when (eq gnus-registry-split-strategy 'majority) + (let ((freq (make-hash-table + :size 256 + :test 'equal))) + (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full) + (setq groups (list (car-safe + (sort + groups + (lambda (a b) + (> (gethash a freq 0) + (gethash b freq 0))))))))) + (if gnus-registry-use-long-group-names (dolist (group groups) (let ((m1 (gnus-find-method-for-group group)) @@ -608,10 +664,10 @@ possible." "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 + (not (or (gnus-grep-in-list group gnus-registry-unfollowed-groups) - (gnus-registry-grep-in-list + (gnus-grep-in-list group nnmail-split-fancy-with-parent-ignore-groups)))) @@ -621,8 +677,7 @@ Consults `gnus-registry-unfollowed-groups' and word words) (if (or (not (gnus-registry-fetch-extra id 'keywords)) force) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (article-goto-body) (save-window-excursion (save-restriction @@ -641,9 +696,8 @@ Consults `gnus-registry-unfollowed-groups' and (let (articles) (maphash (lambda (key value) - (when (gnus-registry-grep-in-list - keyword - (cdr (gnus-registry-fetch-extra key 'keywords))) + (when (member keyword + (cdr-safe (gnus-registry-fetch-extra key 'keywords))) (push key articles))) gnus-registry-hashtb) articles)) @@ -656,8 +710,8 @@ Consults `gnus-registry-unfollowed-groups' and (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id)) (gnus-message 9 "Registry: Registering article %d with group %s" article gnus-newsgroup-name) - (gnus-registry-add-group - id + (gnus-registry-add-group + id gnus-newsgroup-name (gnus-registry-fetch-simplified-message-subject-fast article) (gnus-registry-fetch-sender-fast article))))))) @@ -693,16 +747,6 @@ Consults `gnus-registry-unfollowed-groups' and (assoc article (gnus-data-list nil))))) nil)) -;;; this should be redone with catch/throw -(defun gnus-registry-grep-in-list (word list) - (when word - (memq nil - (mapcar 'not - (mapcar - (lambda (x) - (string-match word x)) - list))))) - (defun gnus-registry-do-marks (type function) "For each known mark, call FUNCTION for each cell of type TYPE. @@ -719,7 +763,8 @@ FUNCTION should take two parameters, a mark symbol and the cell value." "Install the keyboard shortcuts and menus for the registry. Uses `gnus-registry-marks' to find what shortcuts to install." (let (keys-plist) - (gnus-registry-do-marks + (setq gnus-registry-misc-menus nil) + (gnus-registry-do-marks :char (lambda (mark data) (let ((function-format @@ -740,20 +785,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (function-name (format function-format variant-name)) (shortcut (format "%c" data)) (shortcut (if remove (upcase shortcut) shortcut))) - (unintern function-name) + (unintern function-name obarray) (eval - `(defun + `(defun ;; function name - ,(intern function-name) + ,(intern function-name) ;; parameter definition (&rest articles) ;; documentation - ,(format + ,(format "%s the %s mark over process-marked ARTICLES." (upcase-initials variant-name) mark) ;; interactive definition - (interactive + (interactive (gnus-summary-work-articles current-prefix-arg)) ;; actual code @@ -764,34 +809,49 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; now the user is asked if gnus-registry-install is 'ask (when (gnus-registry-install-p) - (gnus-registry-set-article-mark-internal + (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) + (gnus-message + 9 + "Applying mark %s to %d articles" + ,(symbol-name mark) (length articles)) (dolist (article articles) - (gnus-summary-update-article - article + (gnus-summary-update-article + article (assoc article (gnus-data-list nil))))))) (push (intern function-name) keys-plist) (push shortcut keys-plist) - (gnus-message - 9 - "Defined mark handling function %s" + (push (vector (format "%s %s" + (upcase-initials variant-name) + (symbol-name mark)) + (intern function-name) t) + gnus-registry-misc-menus) + (gnus-message + 9 + "Defined mark handling function %s" function-name)))))) (gnus-define-keys-1 - '(gnus-registry-mark-map "M" gnus-summary-mark-map) - keys-plist))) + '(gnus-registry-mark-map "M" gnus-summary-mark-map) + keys-plist) + (add-hook 'gnus-summary-menu-hook + (lambda () + (easy-menu-add-item + gnus-summary-misc-menu + nil + (cons "Registry Marks" gnus-registry-misc-menus)))))) ;;; use like this: -;;; (defalias 'gnus-user-format-function-M +;;; (defalias 'gnus-user-format-function-M ;;; 'gnus-registry-user-format-function-M) (defun gnus-registry-user-format-function-M (headers) (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-fetch-extra-marks id)))) (apply 'concat (mapcar (lambda(mark) - (let ((c + (let ((c (plist-get - (cdr-safe + (cdr-safe (assoc mark gnus-registry-marks)) :char))) (if c @@ -801,12 +861,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (defun gnus-registry-read-mark () "Read a mark name from the user with completion." - (let ((mark (gnus-completing-read-with-default - (symbol-name gnus-registry-default-mark) - "Label" - (mapcar (lambda (x) ; completion list - (cons (symbol-name (car-safe x)) (car-safe x))) - gnus-registry-marks)))) + (let ((mark (gnus-completing-read + "Label" + (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + nil nil nil + (symbol-name gnus-registry-default-mark)))) (when (stringp mark) (intern mark)))) @@ -838,7 +897,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" (if remove "Removing" "Adding") mark id new-marks)) - + (apply 'gnus-registry-store-extra-marks ; set the extra marks id ; for the message ID new-marks))))) @@ -949,7 +1008,7 @@ The message must have at least one group name." "Put a specific entry in the extras field of the registry entry for id." (let* ((extra (gnus-registry-fetch-extra id)) ;; all the entries except the one for `key' - (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) + (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) (alist (if value (gnus-registry-remove-alist-text-properties (cons (cons key value) @@ -969,20 +1028,22 @@ Returns the first place where the trail finds a group name." crumb (gnus-group-short-name crumb)))))))) -(defun gnus-registry-fetch-groups (id) - "Get the groups of a message, based on the message ID." +(defun gnus-registry-fetch-groups (id &optional max) + "Get the groups (up to MAX, if given) of a message, based on the message ID." (let ((trail (gethash id gnus-registry-hashtb)) groups) (dolist (crumb trail) (when (stringp crumb) ;; push the group name into the list - (setq + (setq groups (cons (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) crumb (gnus-group-short-name crumb)) - groups)))) + groups)) + (when (and max (> (length groups) max)) + (return)))) ;; return the list of groups groups)) @@ -1070,6 +1131,8 @@ Returns the first place where the trail finds a group name." (setq gnus-registry-install t) ; in case it was 'ask or nil (gnus-registry-install-hooks) (gnus-registry-install-shortcuts) + (when (featurep 'nnregistry) + (gnus-registry-install-nnregistry)) (gnus-registry-read)) ;;;###autoload @@ -1086,6 +1149,18 @@ Returns the first place where the trail finds a group name." (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) +;;;###autoload +(defun gnus-registry-install-nnregistry () + "Install the nnregistry refer method in `gnus-refer-article-method'." + (interactive) + (setq gnus-refer-article-method + (delete-dups + (append + (if (listp gnus-refer-article-method) + gnus-refer-article-method + (list gnus-refer-article-method)) + (list 'nnregistry))))) + (defun gnus-registry-unload-hook () "Uninstall the registry hooks." (interactive) @@ -1115,13 +1190,8 @@ Returns the first place where the trail finds a group name." ;;; we could call it here: (customize-variable 'gnus-registry-install) gnus-registry-install) -(when (or (eq gnus-registry-install t) - (gnus-registry-install-p)) - (gnus-registry-initialize)) - ;; TODO: a few things (provide 'gnus-registry) -;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 ;;; gnus-registry.el ends here