X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=4221af663d5b2bdb911c5d0fe3e0173c5f47efa1;hb=bbe68edb313e02acb4557e5cc4ff2f87a41ca66c;hp=35cd2a77bbbd7ea540357c035de69532aa3d3553;hpb=0934016eaa49a051b9ff5ccc2bb0ec852e2da0fd;p=gnus diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 35cd2a77b..4221af663 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,57 +1,78 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. + +;; Copyright (C) 2002-2012 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 2, 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; 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 +;; This is the gnus-registry.el package, which works with all +;; Gnus backends, not just 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). +;; better documentation in the manual (also on my to-do list). + +;; If you want to track recipients (and you should to make the +;; gnus-registry splitting work better), you need the To and Cc +;; headers collected by Gnus. Note that in more recent Gnus versions +;; this is already the case: look at `gnus-extra-headers' to be sure. + +;; ;;; you may also want Gcc Newsgroups Keywords X-Face +;; (add-to-list 'gnus-extra-headers 'To) +;; (add-to-list 'gnus-extra-headers 'Cc) +;; (setq nnmail-extra-headers gnus-extra-headers) -;; Put this in your startup file (~/.gnus.el for instance) +;; Put this in your startup file (~/.gnus.el for instance) or use Customize: -;; (setq gnus-registry-install t -;; gnus-registry-max-entries 2500 -;; gnus-registry-use-long-group-names t) +;; (setq gnus-registry-max-entries 2500 +;; gnus-registry-track-extra '(sender subject recipient)) -;; (require 'gnus-registry) +;; (gnus-registry-initialize) ;; Then use this in your fancy-split: ;; (: gnus-registry-split-fancy-with-parent) +;; You should also consider using the nnregistry backend to look up +;; articles. See the Gnus manual for more information. + +;; Finally, you can put %uM in your summary line format to show the +;; registry marks if you do this: + +;; show the marks as single characters (see the :char property in +;; `gnus-registry-marks'): +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) + +;; show the marks by name (see `gnus-registry-marks'): +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) + ;; TODO: ;; - get the correct group on spool actions -;; - articles that are spooled to a different backend should be handled +;; - articles that are spooled to a different backend should be moved +;; after splitting ;;; Code: @@ -60,63 +81,151 @@ (require 'gnus) (require 'gnus-int) (require 'gnus-sum) +(require 'gnus-art) +(require 'gnus-util) (require 'nnmail) +(require 'easymenu) +(require 'registry) + +(defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t "Boolean set to t when the registry is modified") (defgroup gnus-registry nil "The Gnus registry." + :version "22.1" :group 'gnus) -(defvar gnus-registry-hashtb nil - "*The article registry by Message ID.") +(defvar gnus-registry-marks + '((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.") + +(defcustom gnus-registry-default-mark 'To-Do + "The default mark. Should be a valid key for `gnus-registry-marks'." + :group 'gnus-registry + :type 'symbol) + +(defcustom gnus-registry-unfollowed-addresses + (list (regexp-quote user-mail-address)) + "List of addresses that gnus-registry-split-fancy-with-parent won't trace. +The addresses are matched, they don't have to be fully qualified. +In the messages, these addresses can be the sender or the +recipients." + :version "24.1" + :group 'gnus-registry + :type '(repeat regexp)) + +(defcustom gnus-registry-unfollowed-groups + '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive") + "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 Gnus registry 'never split a +message into a group that matches one of these, regardless of +references.' -(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." +nnmairix groups are specifically excluded because they are ephemeral." :group 'gnus-registry - :type '(repeat string)) + :type '(repeat regexp)) -(defcustom gnus-registry-install nil +(defcustom gnus-registry-install 'ask "Whether the registry should be installed." :group 'gnus-registry - :type 'boolean) + :type '(choice (const :tag "Never Install" nil) + (const :tag "Always Install" t) + (const :tag "Ask Me" ask))) -(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) +(defvar gnus-registry-enabled nil) -(defcustom gnus-registry-use-long-group-names nil - "Whether the registry should use long group names (BUGGY)." - :group 'gnus-registry - :type 'boolean) +(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. + +(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus + +(make-obsolete-variable 'gnus-registry-clean-empty nil "23.4") +(make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4") +(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4") +(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4") +(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4") -(defcustom gnus-registry-track-extra nil - "Whether the registry should track other things about a message. -The Subject header is currently the only thing that can be -tracked this way." +(defcustom gnus-registry-track-extra '(subject sender recipient) + "Whether the registry should track extra data about a message. +The subject, recipients (To: and Cc:), and Sender (From:) headers +are tracked this way by default." :group 'gnus-registry - :type 'boolean) + :type + '(set :tag "Tracking choices" + (const :tag "Track by subject (Subject: header)" subject) + (const :tag "Track by recipient (To: and Cc: headers)" recipient) + (const :tag "Track by sender (From: header)" sender))) + +(defcustom gnus-registry-split-strategy nil + "The splitting strategy applied to the keys in `gnus-registry-track-extra'. + +Given a set of unique found groups G and counts for each element +of G, and a key K (typically 'sender or 'subject): + +When nil, if G has only one element, use it. Otherwise give up. +This is the fastest but also least useful strategy. -(defcustom gnus-registry-entry-caching t - "Whether the registry should cache extra information." +When 'majority, use the majority by count. So if there is a +group with the most articles counted by K, use that. Ties are +resolved in no particular order, simply the first one found wins. +This is the slowest strategy but also the most accurate one. + +When 'first, the first element of G wins. This is fast and +should be OK if your senders and subjects don't \"bleed\" across +groups." :group 'gnus-registry - :type 'boolean) + :type + '(choice :tag "Splitting strategy" + (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-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." +(defcustom gnus-registry-extra-entries-precious '(mark) + "What extra keys are precious, meaning entries with them won't get pruned. +By default, 'mark is included, so articles with marks are +considered precious. + +Before you save the Gnus registry, it's pruned. Any entries with +keys in this list will not be pruned. All other entries go to +the Bit Bucket." :group 'gnus-registry - :type 'boolean) + :type '(repeat symbol)) -(defcustom gnus-registry-cache-file "~/.gnus.registry.eld" +(defcustom gnus-registry-cache-file + (nnheader-concat + (or gnus-dribble-directory gnus-home-directory "~/") + ".gnus.registry.eioio") "File where the Gnus registry will be stored." :group 'gnus-registry :type 'file) @@ -125,212 +234,180 @@ tracked this way." "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))) + (integer :format "Maximum number: %v"))) -;; 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))) +(defcustom gnus-registry-max-pruned-entries nil + "Maximum number of pruned entries in the registry, nil for unlimited." + :version "24.1" + :group 'gnus-registry + :type '(radio (const :format "Unlimited " nil) + (integer :format "Maximum number: %v"))) + +(defun gnus-registry-fixup-registry (db) + (when db + (let ((old (oref db :tracked))) + (oset db :precious + (append gnus-registry-extra-entries-precious + '())) + (oset db :max-hard + (or gnus-registry-max-entries + most-positive-fixnum)) + (oset db :prune-factor + 0.1) + (oset db :max-soft + (or gnus-registry-max-pruned-entries + most-positive-fixnum)) + (oset db :tracked + (append gnus-registry-track-extra + '(mark group keyword))) + (when (not (equal old (oref db :tracked))) + (gnus-message 9 "Reindexing the Gnus registry (tracked change)") + (registry-reindex db)))) + db) + +(defun gnus-registry-make-db (&optional file) + (interactive "fGnus registry persistence file: \n") + (gnus-registry-fixup-registry + (registry-db + "Gnus Registry" + :file (or file gnus-registry-cache-file) + ;; these parameters are set in `gnus-registry-fixup-registry' + :max-hard most-positive-fixnum + :max-soft most-positive-fixnum + :precious nil + :tracked nil))) + +(defvar gnus-registry-db (gnus-registry-make-db) + "*The article registry by Message ID. See `registry-db'") + +;; top-level registry data management +(defun gnus-registry-remake-db (&optional forsure) + "Remake the registry database after customization. +This is not required after changing `gnus-registry-cache-file'." + (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? "))) + (when forsure + (gnus-message 4 "Remaking the Gnus registry") + (setq gnus-registry-db (gnus-registry-make-db)))) -(defun gnus-registry-cache-read () +(defun gnus-registry-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 () + (condition-case nil + (progn + (gnus-message 5 "Reading Gnus registry from %s..." file) + (setq gnus-registry-db (gnus-registry-fixup-registry + (eieio-persistent-read file))) + (gnus-message 5 "Reading Gnus registry from %s...done" file)) + (error + (gnus-message + 1 + "The Gnus registry could not be loaded from %s, creating a new one" + file) + (gnus-registry-remake-db t))))) + +(defun gnus-registry-save (&optional file db) "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 -;; 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)) - + (let ((file (or file gnus-registry-cache-file)) + (db (or db gnus-registry-db))) + (gnus-message 5 "Saving Gnus registry (%d entries) to %s..." + (registry-size db) file) + (registry-prune db) + ;; TODO: call (gnus-string-remove-all-properties v) on all elements? + (eieio-persistent-save db file) + (gnus-message 5 "Saving Gnus registry (size %d) to %s...done" + (registry-size db) file))) + +(defun gnus-registry-remove-ignored () + (interactive) + (let* ((db gnus-registry-db) + (grouphashtb (registry-lookup-secondary db 'group)) + (old-size (registry-size db))) + (registry-reindex db) + (loop for k being the hash-keys of grouphashtb + using (hash-values v) + when (gnus-registry-ignore-group-p k) + do (registry-delete db v nil)) + (registry-reindex db) + (gnus-message 4 "Removed %d ignored entries from the Gnus registry" + (- old-size (registry-size db))))) + +;; article move/copy/spool/delete actions (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))) - (from (gnus-group-guess-full-name from)) - (to (if to (gnus-group-guess-full-name to) nil)) - (to-name (if to to "the Bit Bucket")) - (old-entry (gethash id gnus-registry-hashtb))) - (gnus-message 5 "Registry: article %s %s from %s to %s" - id - (if method "respooling" "going") - from - to) - - ;; All except copy will need a delete - (gnus-registry-delete-group id from) - - (when (equal 'copy action) - (gnus-registry-add-group id from subject)) ; undo the delete - - (gnus-registry-add-group id to subject))) - -(defun gnus-registry-spool-action (id group &optional subject) - ;; do not process the draft IDs -; (unless (string-match "totally-fudged-out-message-id" id) -; (let ((group (gnus-group-guess-full-name group))) - (when (string-match "\r$" id) - (setq id (substring id 0 -1))) - (gnus-message 5 "Registry: article %s spooled to %s" - id - group) - (gnus-registry-add-group id group subject)) -;) + (subject (mail-header-subject data-header)) + (extra (mail-header-extra data-header)) + (recipients (gnus-registry-sort-addresses + (or (cdr-safe (assq 'Cc extra)) "") + (or (cdr-safe (assq 'To extra)) ""))) + (sender (nth 0 (gnus-registry-extract-addresses + (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"))) + (gnus-message 7 "Gnus registry: article %s %s from %s to %s" + id (if method "respooling" "going") from to) + + (gnus-registry-handle-action + id + ;; unless copying, remove the old "from" group + (if (not (equal 'copy action)) from nil) + to subject sender recipients))) + +(defun gnus-registry-spool-action (id group &optional subject sender recipients) + (let ((to (gnus-group-guess-full-name-from-command-method group)) + (recipients (or recipients + (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") "")))) + (subject (or subject (message-fetch-field "subject"))) + (sender (or sender (message-fetch-field "from")))) + (when (and (stringp id) (string-match "\r$" id)) + (setq id (substring id 0 -1))) + (gnus-message 7 "Gnus registry: article %s spooled to %s" + id + to) + (gnus-registry-handle-action id nil to subject sender recipients))) + +(defun gnus-registry-handle-action (id from to subject sender + &optional recipients) + (gnus-message + 10 + "gnus-registry-handle-action %S" (list id from to subject sender recipients)) + (let ((db gnus-registry-db) + ;; if the group is ignored, set the destination to nil (same as delete) + (to (if (gnus-registry-ignore-group-p to) nil to)) + ;; safe if not found + (entry (gnus-registry-get-or-make-entry id)) + (subject (gnus-string-remove-all-properties + (gnus-registry-simplify-subject subject))) + (sender (gnus-string-remove-all-properties sender))) + + ;; this could be done by calling `gnus-registry-set-id-key' + ;; several times but it's better to bunch the transactions + ;; together + + (registry-delete db (list id) nil) + (when from + (setq entry (cons (delete from (assoc 'group entry)) + (assq-delete-all 'group entry)))) + + (dolist (kv `((group ,to) + (sender ,sender) + (recipient ,@recipients) + (subject ,subject))) + (when (second kv) + (let ((new (or (assq (first kv) entry) + (list (first kv))))) + (dolist (toadd (cdr kv)) + (add-to-list 'new toadd t)) + (setq entry (cons new + (assq-delete-all (first kv) entry)))))) + (gnus-message 10 "Gnus registry: new entry for %s is %S" + id + entry) + (gnus-registry-insert db id entry))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. @@ -338,235 +415,682 @@ tracked this way." "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) +this: (: gnus-registry-split-fancy-with-parent) + +This function tracks ALL backends, unlike +`nnmail-split-fancy-with-parent' which tracks only nnmail +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. +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 `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") - (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)) - ;; there were no references, now try the extra tracking - (when gnus-registry-track-extra - (let ((subject (gnus-registry-simplify-subject - (message-fetch-field "subject")))) - (when (and subject - (< gnus-registry-minimum-subject-length (length subject))) - (maphash - (lambda (key value) - (let ((this-subject (cdr - (gnus-registry-fetch-extra key 'subject)))) - (when (and this-subject - (equal subject this-subject)) - (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))))) - (debug res) + (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)) + (references (and refstr (gnus-extract-references refstr))) + ;; these may not be used, but the code is cleaner having them up here + (sender (gnus-string-remove-all-properties + (message-fetch-field "from"))) + (recipients (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") ""))) + (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)))) + (gnus-registry--split-fancy-with-parent-internal + :references references + :refstr refstr + :sender sender + :recipients recipients + :subject subject + :log-agent "Gnus registry fancy splitting with parent"))) + +(defun* gnus-registry--split-fancy-with-parent-internal + (&rest spec + &key references refstr sender subject recipients log-agent + &allow-other-keys) + (gnus-message + 10 + "gnus-registry--split-fancy-with-parent-internal %S" spec) + (let ((db gnus-registry-db) + found) + ;; this is a big chain of statements. it uses + ;; gnus-registry-post-process-groups to filter the results after + ;; every step. + ;; the references string must be valid and parse to valid references + (when references (gnus-message - 5 - "gnus-registry-split-fancy-with-parent traced %s to group %s" - refstr (if res res "nil")) - res)) + 9 + "%s is tracing references %s" + log-agent refstr) + (dolist (reference (nreverse references)) + (gnus-message 9 "%s is looking up %s" log-agent reference) + (loop for group in (gnus-registry-get-id-key reference 'group) + when (gnus-registry-follow-group-p group) + do + (progn + (gnus-message 7 "%s traced %s to %s" log-agent reference group) + (push group found)))) + ;; filter the found groups and return them + ;; the found groups are the full groups + (setq found (gnus-registry-post-process-groups + "references" refstr found))) + + ;; else: there were no matches, now try the extra tracking by subject + (when (and (null found) + (memq 'subject gnus-registry-track-extra) + subject + (< gnus-registry-minimum-subject-length (length subject))) + (let ((groups (apply + 'append + (mapcar + (lambda (reference) + (gnus-registry-get-id-key reference 'group)) + (registry-lookup-secondary-value db 'subject subject))))) + (setq found + (loop for group in groups + when (gnus-registry-follow-group-p group) + do (gnus-message + ;; warn more if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced subject '%s' to %s" + log-agent subject group) + and collect group)) + ;; filter the found groups and return them + ;; the found groups are NOT the full groups + (setq found (gnus-registry-post-process-groups + "subject" subject found)))) + + ;; else: there were no matches, try the extra tracking by sender + (when (and (null found) + (memq 'sender gnus-registry-track-extra) + sender + (not (gnus-grep-in-list + sender + gnus-registry-unfollowed-addresses))) + (let ((groups (apply + 'append + (mapcar + (lambda (reference) + (gnus-registry-get-id-key reference 'group)) + (registry-lookup-secondary-value db 'sender sender))))) + (setq found + (loop for group in groups + when (gnus-registry-follow-group-p group) + do (gnus-message + ;; warn more if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced sender '%s' to %s" + log-agent sender group) + and collect group))) + + ;; filter the found groups and return them + ;; the found groups are NOT the full groups + (setq found (gnus-registry-post-process-groups + "sender" sender found))) + + ;; else: there were no matches, try the extra tracking by recipient + (when (and (null found) + (memq 'recipient gnus-registry-track-extra) + recipients) + (dolist (recp recipients) + (when (and (null found) + (not (gnus-grep-in-list + recp + gnus-registry-unfollowed-addresses))) + (let ((groups (apply 'append + (mapcar + (lambda (reference) + (gnus-registry-get-id-key reference 'group)) + (registry-lookup-secondary-value + db 'recipient recp))))) + (setq found + (loop for group in groups + when (gnus-registry-follow-group-p group) + do (gnus-message + ;; warn more if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced recipient '%s' to %s" + log-agent recp group) + and collect group))))) + + ;; filter the found groups and return them + ;; the found groups are NOT the full groups + (setq found (gnus-registry-post-process-groups + "recipients" (mapconcat 'identity recipients ", ") found))) + + ;; after the (cond) we extract the actual value safely + (car-safe found))) + +(defun gnus-registry-post-process-groups (mode key groups) + "Inspects 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. +Foreign methods are not supported so they are rejected. + +Reduces the list to a single group, or complains if that's not +possible. Uses `gnus-registry-split-strategy'." + (let ((log-agent "gnus-registry-post-process-group") + (desc (format "%d groups" (length groups))) + out chosen) + ;; the strategy can be nil, in which case chosen is nil + (setq chosen + (case gnus-registry-split-strategy + ;; default, take only one-element lists into chosen + ((nil) + (and (= (length groups) 1) + (car-safe groups))) + + ((first) + (car-safe groups)) + + ((majority) + (let ((freq (make-hash-table + :size 256 + :test 'equal))) + (mapc (lambda (x) (let ((x (gnus-group-short-name x))) + (puthash x (1+ (gethash x freq 0)) freq))) + groups) + (setq desc (format "%d groups, %d unique" + (length groups) + (hash-table-count freq))) + (car-safe + (sort groups + (lambda (a b) + (> (gethash (gnus-group-short-name a) freq 0) + (gethash (gnus-group-short-name b) freq 0))))))))) + + (if chosen + (gnus-message + 9 + "%s: strategy %s on %s produced %s" + log-agent gnus-registry-split-strategy desc chosen) + (gnus-message + 9 + "%s: strategy %s on %s did not produce an answer" + log-agent + (or gnus-registry-split-strategy "default") + desc)) + + (setq groups (and chosen (list chosen))) + + (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 + (when (not (equal group short-name)) + (gnus-message + 10 + "%s: stripped group %s to %s" + log-agent group short-name)) + (add-to-list 'out short-name)) + ;; else... + (gnus-message + 7 + "%s: ignored foreign group %s" + log-agent group)))) + + (setq out (delq nil out)) + + (cond + ((= (length out) 1) out) + ((null out) + (gnus-message + 5 + "%s: no matches for %s '%s'." + log-agent mode key) + nil) + (t (gnus-message + 5 + "%s: too many extra matches (%s) for %s '%s'. Returning none." + log-agent out mode key) + nil)))) + +(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'." + (and group + (not (or (gnus-grep-in-list + group + gnus-registry-unfollowed-groups) + (gnus-grep-in-list + group + nnmail-split-fancy-with-parent-ignore-groups))))) + +;; note that gnus-registry-ignored-groups is defined in gnus.el as a +;; group/topic parameter and an associated variable! + +;; we do special logic for ignoring to accept regular expressions and +;; nnmail-split-fancy-with-parent-ignore-groups as well +(defun gnus-registry-ignore-group-p (group) + "Determines if a group name should be ignored. +Consults `gnus-registry-ignored-groups' and +`nnmail-split-fancy-with-parent-ignore-groups'." + (and group + (or (gnus-grep-in-list + group + (delq nil (mapcar (lambda (g) + (cond + ((stringp g) g) + ((and (listp g) (nth 1 g)) + (nth 0 g)) + (t nil))) gnus-registry-ignored-groups))) + ;; only use `gnus-parameter-registry-ignore' if + ;; `gnus-registry-ignored-groups' is a list of lists + ;; (it can be a list of regexes) + (and (listp (nth 0 gnus-registry-ignored-groups)) + (get-buffer "*Group*") ; in automatic tests this is false + (gnus-parameter-registry-ignore group)) + (gnus-grep-in-list + group + nnmail-split-fancy-with-parent-ignore-groups)))) + +(defun gnus-registry-wash-for-keywords (&optional force) + "Get the keywords of the current article. +Overrides existing keywords with FORCE set non-nil." + (interactive) + (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) + word words) + (if (or (not (gnus-registry-get-id-key id 'keyword)) + force) + (with-current-buffer gnus-article-buffer + (article-goto-body) + (save-window-excursion + (save-restriction + (narrow-to-region (point) (point-max)) + (with-syntax-table gnus-adaptive-word-syntax-table + (while (re-search-forward "\\b\\w+\\b" nil t) + (setq word (gnus-string-remove-all-properties + (downcase (buffer-substring + (match-beginning 0) (match-end 0))))) + (if (> (length word) 2) + (push word words)))))) + (gnus-registry-set-id-key id 'keyword words))))) + +(defun gnus-registry-keywords () + (let ((table (registry-lookup-secondary gnus-registry-db 'keyword))) + (when table (maphash (lambda (k v) k) table)))) + +(defun gnus-registry-find-keywords (keyword) + (interactive (list + (completing-read "Keyword: " (gnus-registry-keywords) nil t))) + (registry-lookup-secondary-value gnus-registry-db 'keyword keyword)) (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))))))) - + (let* ((id (gnus-registry-fetch-message-id-fast article)) + (groups (gnus-registry-get-id-key id 'group))) + (unless (member gnus-newsgroup-name groups) + (gnus-message 9 "Registry: Registering article %d with group %s" + article gnus-newsgroup-name) + (gnus-registry-handle-action id nil gnus-newsgroup-name + (gnus-registry-fetch-simplified-message-subject-fast article) + (gnus-registry-fetch-sender-fast article) + (gnus-registry-fetch-recipients-fast article))))))) + +;; message field fetchers (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))) + (assoc article (gnus-data-list nil))) (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) nil)) +(defun gnus-registry-extract-addresses (text) + "Extract all the addresses in a normalized way from TEXT. +Returns an unsorted list of strings in the name
format. +Addresses without a name will say \"noname\"." + (mapcar (lambda (add) + (gnus-string-remove-all-properties + (let* ((name (or (nth 0 add) "noname")) + (addr (nth 1 add)) + (addr (if (bufferp addr) + (with-current-buffer addr + (buffer-string)) + addr))) + (format "%s <%s>" name addr)))) + (mail-extract-address-components text t))) + +(defun gnus-registry-sort-addresses (&rest addresses) + "Return a normalized and sorted list of ADDRESSES." + (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses)) + 'string-lessp)) + (defun gnus-registry-simplify-subject (subject) - (if (null subject) - nil - (gnus-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))))) + (assoc article (gnus-data-list nil))) + (gnus-string-remove-all-properties + (gnus-registry-simplify-subject + (mail-header-subject (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))) - (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))) - (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 (gnus-group-short-name crumb))))))) +(defun gnus-registry-fetch-sender-fast (article) + (gnus-registry-fetch-header-fast "from" article)) + +(defun gnus-registry-fetch-recipients-fast (article) + (gnus-registry-sort-addresses + (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "") + (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) ""))) + +(defun gnus-registry-fetch-header-fast (article header) + "Fetch the HEADER quickly, using the internal gnus-data-list function" + (if (and (numberp article) + (assoc article (gnus-data-list nil))) + (gnus-string-remove-all-properties + (cdr (assq header (gnus-data-header + (assoc article (gnus-data-list nil)))))) + nil)) + +;; registry marks glue +(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)) + (cell-data (plist-get data type))) + (when cell-data + (funcall function mark cell-data))))) + +;;; this is ugly code, but I don't know how to do it better +(defun gnus-registry-install-shortcuts () + "Install the keyboard shortcuts and menus for the registry. +Uses `gnus-registry-marks' to find what shortcuts to install." + (let (keys-plist) + (setq gnus-registry-misc-menus nil) + (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 obarray) + (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 + + ;; if this is called and the user doesn't want the + ;; registry enabled, we'll ask anyhow + (unless gnus-registry-install + (let ((gnus-registry-install 'ask)) + (gnus-registry-install-p))) + + ;; now the user is asked if gnus-registry-install is 'ask + (when (gnus-registry-install-p) + (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 + (assoc article (gnus-data-list nil))))))) + (push (intern function-name) keys-plist) + (push shortcut keys-plist) + (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) + (add-hook 'gnus-summary-menu-hook + (lambda () + (easy-menu-add-item + gnus-summary-misc-menu + nil + (cons "Registry Marks" gnus-registry-misc-menus)))))) + +(make-obsolete 'gnus-registry-user-format-function-M + 'gnus-registry-article-marks-to-chars "24.1") ? + +(defalias 'gnus-registry-user-format-function-M + 'gnus-registry-article-marks-to-chars) + +;; use like this: +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +(defun gnus-registry-article-marks-to-chars (headers) + "Show the marks for an article by the :char property" + (let* ((id (mail-header-message-id headers)) + (marks (when id (gnus-registry-get-id-key id 'mark)))) + (mapconcat (lambda (mark) + (plist-get + (cdr-safe + (assoc mark gnus-registry-marks)) + :char)) + marks ""))) + +;; use like this: +;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +(defun gnus-registry-article-marks-to-names (headers) + "Show the marks for an article by name" + (let* ((id (mail-header-message-id headers)) + (marks (when id (gnus-registry-get-id-key id 'mark)))) + (mapconcat (lambda (mark) (symbol-name mark)) marks ","))) + +(defun gnus-registry-read-mark () + "Read a mark name from the user with completion." + (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)))) + +(defun gnus-registry-set-article-mark (&rest articles) + "Apply a mark to process-marked ARTICLES." + (interactive (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) + articles nil t)) + +(defun gnus-registry-remove-article-mark (&rest articles) + "Remove a mark from process-marked ARTICLES." + (interactive (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) + articles t t)) + +(defun gnus-registry-set-article-mark-internal (mark + articles + &optional remove + show-message) + "Apply or remove MARK across a list of ARTICLES." + (let ((article-id-list + (mapcar 'gnus-registry-fetch-message-id-fast articles))) + (dolist (id article-id-list) + (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) + (marks (if remove marks (cons mark marks)))) + (when show-message + (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" + (if remove "Removing" "Adding") + mark id marks)) + (gnus-registry-set-id-key id 'mark marks))))) + +(defun gnus-registry-get-article-marks (&rest articles) + "Get the Gnus registry marks for ARTICLES and show them if interactive. +Uses process/prefix conventions. For multiple articles, +only the last one's marks are returned." + (interactive (gnus-summary-work-articles 1)) + (let* ((article (last articles)) + (id (gnus-registry-fetch-message-id-fast article)) + (marks (when id (gnus-registry-get-id-key id 'mark)))) + (when (interactive-p) + (gnus-message 1 "Marks are %S" marks)) + marks)) (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) - (remhash id gnus-registry-hashtb))) - (gnus-registry-store-extra-entry id 'mtime (current-time))))) - -(defun gnus-registry-add-group (id group &optional subject) - "Add a group for a message, based on the message ID." - ;; make sure there are no duplicate entries - (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 - (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 gnus-registry-track-extra - (gnus-registry-store-extra-entry - id - 'subject - (gnus-registry-simplify-subject subject))) - - (gnus-registry-store-extra-entry id 'mtime (current-time))))))) - -(defun gnus-registry-clear () - "Clear the Gnus registry." + (length (gnus-registry-get-id-key id 'group))) + +(defun gnus-registry-get-or-make-entry (id) + (let* ((db gnus-registry-db) + ;; safe if not found + (entries (registry-lookup db (list id)))) + + (when (null entries) + (gnus-registry-insert db id (list (list 'creation-time (current-time)) + '(group) '(sender) '(subject))) + (setq entries (registry-lookup db (list id)))) + + (nth 1 (assoc id entries)))) + +(defun gnus-registry-delete-entries (idlist) + (registry-delete gnus-registry-db idlist nil)) + +(defun gnus-registry-get-id-key (id key) + (cdr-safe (assq key (gnus-registry-get-or-make-entry id)))) + +(defun gnus-registry-set-id-key (id key vals) + (let* ((db gnus-registry-db) + (entry (gnus-registry-get-or-make-entry id))) + (registry-delete db (list id) nil) + (setq entry (cons (cons key vals) (assq-delete-all key entry))) + (gnus-registry-insert db id entry) + entry)) + +(defun gnus-registry-insert (db id entry) + "Just like `registry-insert' but tries to prune on error." + (when (registry-full db) + (message "Trying to prune the registry because it's full") + (registry-prune db)) + (registry-insert db id entry) + entry) + +(defun gnus-registry-import-eld (file) + (interactive "fOld registry file to import? ") + ;; example content: + ;; (setq gnus-registry-alist '( + ;; ("" ((marks nil) + ;; (mtime 19365 1776 440496) + ;; (sender . "root (Cron Daemon)") + ;; (subject . "Cron")) + ;; "cron" "nnml+private:cron") + (load file t) + (when (boundp 'gnus-registry-alist) + (let* ((old (symbol-value 'gnus-registry-alist)) + (count 0) + (expected (length old)) + entry) + (while (car-safe old) + (incf count) + ;; don't use progress reporters for backwards compatibility + (when (and (< 0 expected) + (= 0 (mod count 100))) + (message "importing: %d of %d (%.2f%%)" + count expected (/ (* 100 count) expected))) + (setq entry (car-safe old) + old (cdr-safe old)) + (let* ((id (car-safe entry)) + (new-entry (gnus-registry-get-or-make-entry id)) + (rest (cdr-safe entry)) + (groups (loop for p in rest + when (stringp p) + collect p)) + extra-cell key val) + ;; remove all the strings from the entry + (dolist (elem rest) + (if (stringp elem) (setq rest (delq elem rest)))) + (gnus-registry-set-id-key id 'group groups) + ;; just use the first extra element + (setq rest (car-safe rest)) + (while (car-safe rest) + (setq extra-cell (car-safe rest) + key (car-safe extra-cell) + val (cdr-safe extra-cell) + rest (cdr-safe rest)) + (when (and val (atom val)) + (setq val (list val))) + (gnus-registry-set-id-key id key val)))) + (message "Import done, collected %d entries" count)))) + +;;;###autoload +(defun gnus-registry-initialize () +"Initialize the Gnus registry." (interactive) - (setq gnus-registry-alist nil) - (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) - (setq gnus-registry-dirty t)) + (gnus-message 5 "Initializing the registry") + (gnus-registry-install-hooks) + (gnus-registry-install-shortcuts) + (gnus-registry-read)) +;;;###autoload (defun gnus-registry-install-hooks () "Install the registry hooks." (interactive) - (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) + (setq gnus-registry-enabled t) + (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) @@ -575,21 +1099,35 @@ Returns the first place where the trail finds a group name." (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-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)) + (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (setq gnus-registry-enabled nil)) -(when gnus-registry-install - (gnus-registry-install-hooks) - (gnus-registry-read)) +(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) -;; TODO: a lot of things +(defun gnus-registry-install-p () + "If the registry is not already enabled, and `gnus-registry-install' is t, +the registry is enabled. If `gnus-registry-install' is `ask', +the user is asked first. Returns non-nil iff the registry is enabled." + (interactive) + (unless gnus-registry-enabled + (when (if (eq gnus-registry-install 'ask) + (gnus-y-or-n-p + (concat "Enable the Gnus registry? " + "See the variable `gnus-registry-install' " + "to get rid of this query permanently. ")) + gnus-registry-install) + (gnus-registry-initialize))) + gnus-registry-enabled) + +;; TODO: a few things (provide 'gnus-registry)