;;; Commentary:
;; This is the gnus-registry.el package, which works with all
-;; backends, not just nnmail (e.g. NNTP). The major issue is that it
+;; 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
;; Put this in your startup file (~/.gnus.el for instance)
-;; (setq gnus-registry-max-entries 2500
-;; gnus-registry-use-long-group-names t)
+;; (setq gnus-registry-max-entries 2500)
;; (gnus-registry-initialize)
;; - 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:
(eval-when-compile (require 'cl))
+(require 'ert)
(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)
:version "22.1"
:group 'gnus)
-(defvar gnus-registry-hashtb (make-hash-table
- :size 256
- :test 'equal)
- "*The article registry by Message ID.")
-
-(defcustom gnus-registry-marks
+(defvar gnus-registry-marks
'((Important
:char ?i
:image "summary_important")
line display and for keyboard shortcuts.
Each entry must have an image string to be useful for visual
-display."
- :group 'gnus-registry
- :type '(repeat :tag "Registry Marks"
- (cons :tag "Mark"
- (symbol :tag "Name")
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :char)
- (character :tag "Character code"))
- (group :inline t
- (const :format "" :value :image)
- (string :tag "Image"))))))
+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."
+ :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 Registry 'never split a
+qualified. This parameter tells the Gnus registry 'never split a
message into a group that matches one of these, regardless of
references.'
"Whether the registry should be installed."
:group 'gnus-registry
:type '(choice (const :tag "Never Install" nil)
- (const :tag "Always Install" t)
- (const :tag "Ask Me" ask)))
+ (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
+(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
-and no extra data."
- :group 'gnus-registry
- :type 'boolean)
-
-(defcustom gnus-registry-use-long-group-names t
- "Whether the registry should use long group names."
- :group 'gnus-registry
- :type 'boolean)
+(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-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
+(defcustom gnus-registry-track-extra '(subject sender)
"Whether the registry should track extra data about a message.
-The Subject and Sender (From:) headers are currently tracked this
-way."
+The Subject and Sender (From:) headers are tracked this way by
+default."
:group 'gnus-registry
:type
'(set :tag "Tracking choices"
(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)))
+ "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.
+
+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.
-(defcustom gnus-registry-entry-caching t
- "Whether the registry should cache extra information."
+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."
- :group 'gnus-registry
- :type 'boolean)
-
-(defcustom gnus-registry-extra-entries-precious '(marks)
- "What extra entries are precious, meaning they won't get trimmed.
-When you save the Gnus registry, it's trimmed to be no longer
-than `gnus-registry-max-entries' (which is nil by default, so no
-trimming happens). Any entries with extra data in this list (by
-default, marks are included, so articles with marks are
-considered precious) will not be trimmed."
+(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 '(repeat symbol))
(defcustom gnus-registry-cache-file
(nnheader-concat
(or gnus-dribble-directory gnus-home-directory "~/")
- ".gnus.registry.eld")
+ ".gnus.registry.eioio")
"File where the Gnus registry will be stored."
:group 'gnus-registry
:type 'file)
"Maximum number of entries in the registry, nil for unlimited."
:group 'gnus-registry
:type '(radio (const :format "Unlimited " nil)
- (integer :format "Maximum number: %v")))
+ (integer :format "Maximum number: %v")))
-(defun gnus-registry-track-subject-p ()
- (memq 'subject gnus-registry-track-extra))
-
-(defun gnus-registry-track-sender-p ()
- (memq 'sender gnus-registry-track-extra))
+(defcustom gnus-registry-max-pruned-entries nil
+ "Maximum number of pruned entries in the registry, nil for unlimited."
+ :group 'gnus-registry
+ :type '(radio (const :format "Unlimited " nil)
+ (integer :format "Maximum number: %v")))
+
+(defun gnus-registry-make-db (&optional file)
+ (interactive "fGnus registry persistence file: \n")
+ (registry-db
+ "Gnus Registry"
+ :file (or file gnus-registry-cache-file)
+ :max-hard (or gnus-registry-max-entries
+ most-positive-fixnum)
+ :max-soft (or gnus-registry-max-pruned-entries
+ most-positive-fixnum)
+ :precious (append gnus-registry-extra-entries-precious
+ '())
+ :tracked (append gnus-registry-track-extra
+ '(mark group keyword))))
+
+(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 1 "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))))
-
-;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in
-;; `gnus-start.el'. --rsteib
-(defun gnus-registry-cache-save ()
+ (condition-case nil
+ (progn
+ (gnus-message 5 "Reading Gnus registry from %s..." file)
+ (setq gnus-registry-db (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))
- (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)
- (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
- "%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)
- (gnus-set-file-modes startup-file setmodes)))
- (condition-case nil
- (delete-file working-file)
- (file-error nil)))))
-
- (gnus-kill-buffer (current-buffer))
- (gnus-message 5 "Saving %s...done" file))))
-
-;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
-;; Save the gnus-registry file with extra line breaks.
-(defun gnus-registry-cache-whitespace (filename)
- (gnus-message 7 "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 and clean text properties from the registry appropriately
- (setq gnus-registry-alist
- (gnus-registry-remove-alist-text-properties
- (gnus-registry-trim
- (gnus-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)
- (when (stringp key)
- (dolist (group (gnus-registry-fetch-groups key))
- (when (gnus-parameter-registry-ignore group)
- (gnus-message
- 10
- "gnus-registry: deleted ignored group %s from key %s"
- group key)
- (gnus-registry-delete-group key group)))
-
- (unless (gnus-registry-group-count key)
- (gnus-registry-delete-id key))
-
- (unless (or
- (gnus-registry-fetch-group key)
- ;; TODO: look for specific extra data here!
- ;; in this example, we look for 'label
- (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"
- key)
- (gnus-registry-delete-id key))))
-
- gnus-registry-hashtb)
- count))
-
-(defun gnus-registry-read ()
- (gnus-registry-cache-read)
- (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
- (setq gnus-registry-dirty nil))
-
-(defun gnus-registry-remove-alist-text-properties (v)
- "Remove text properties from all strings in alist."
- (if (stringp v)
- (gnus-string-remove-all-properties v)
- (if (and (listp v) (listp (cdr v)))
- (mapcar 'gnus-registry-remove-alist-text-properties v)
- (if (and (listp v) (stringp (cdr v)))
- (cons (gnus-registry-remove-alist-text-properties (car v))
- (gnus-registry-remove-alist-text-properties (cdr v)))
- v))))
-
-(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)
- alist ; just return the alist
- ;; else, when given max-entries, trim the alist
- (let* ((timehash (make-hash-table
- :size 20000
- :test 'equal))
- (precious (make-hash-table
- :size 20000
- :test 'equal))
- (trim-length (- (length alist) gnus-registry-max-entries))
- (trim-length (if (natnump trim-length) trim-length 0))
- precious-list junk-list)
- (maphash
- (lambda (key value)
- (let ((extra (gnus-registry-fetch-extra key)))
- (dolist (item gnus-registry-extra-entries-precious)
- (dolist (e extra)
- (when (equal (nth 0 e) item)
- (puthash key t precious)
- (return))))
- (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)))
- gnus-registry-hashtb)
-
- (dolist (item alist)
- (let ((key (nth 0 item)))
- (if (gethash key precious)
- (push item precious-list)
- (push item junk-list))))
-
- (sort
- junk-list
- (lambda (a b)
- (let ((t1 (or (cdr (gethash (car a) timehash))
- '(0 0 0)))
- (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))))))
-
+ (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)))
+
+;; 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-string-remove-all-properties
- (gnus-registry-simplify-subject
- (mail-header-subject 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"))
- (old-entry (gethash id gnus-registry-hashtb)))
- (gnus-message 7 "Registry: article %s %s from %s to %s"
- id
- (if method "respooling" "going")
- from
- to)
-
- ;; All except copy will need a delete
- (gnus-registry-delete-group id from)
-
- (when (equal 'copy action)
- (gnus-registry-add-group id from subject sender)) ; undo the delete
-
- (gnus-registry-add-group id to subject sender)))
+ (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)))
+ (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)))
(defun gnus-registry-spool-action (id group &optional subject sender)
- (let ((group (gnus-group-guess-full-name-from-command-method group)))
+ (let ((to (gnus-group-guess-full-name-from-command-method group)))
(when (and (stringp id) (string-match "\r$" id))
(setq id (substring id 0 -1)))
(gnus-message 7 "Registry: article %s spooled to %s"
- id
- group)
- (gnus-registry-add-group id group subject sender)))
+ id
+ to)
+ (gnus-registry-handle-action id nil to subject sender)))
+
+(defun gnus-registry-handle-action (id from to subject sender)
+ (let ((db gnus-registry-db)
+ ;; safe if not found
+ (entry (gnus-registry-get-or-make-entry id)))
+
+ ;; 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) (subject ,subject)))
+ (when (second kv)
+ (let ((new (or (assq (first kv) entry)
+ (list (first kv)))))
+ (add-to-list 'new (second kv) t)
+ (setq entry (cons new
+ (assq-delete-all (first kv) entry))))))
+ (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.
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
- (concat refstr " " reply-to)
- 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")))
- (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 found-full)
-
+ (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")))
+ (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
+ :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 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 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
- gnus-registry-max-track-groups))
- (when (and group (gnus-registry-follow-group-p group))
- (gnus-message
- 7
- "%s traced the reference %s from [%s] to group %s"
- log-agent reference refstr group)
- (push group found))))
+ (references
+ (dolist (reference (nreverse references))
+ (gnus-message
+ 9
+ "%s is looking for matches for reference %s from [%s]"
+ log-agent reference refstr)
+ (loop for group in (gnus-registry-get-id-key reference 'group)
+ when (gnus-registry-follow-group-p group)
+ do (gnus-message
+ 7
+ "%s traced the reference %s from [%s] to group %s"
+ log-agent reference refstr group)
+ collect group into 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 found)))
-
- ;; else: there were no matches, now try the extra tracking by sender
- ((and (gnus-registry-track-sender-p)
- sender
- (not (equal (gnus-extract-address-component-email sender)
- user-mail-address)))
- (maphash
- (lambda (key value)
- ;; don't use more than gnus-registry-max-track-groups
- (when (< (length found-full) gnus-registry-max-track-groups)
- (let ((this-sender
- (cdr (gnus-registry-fetch-extra key 'sender)))
- matches)
- (when (and this-sender
- (equal sender this-sender))
- (let ((groups (gnus-registry-fetch-groups
- key
- gnus-registry-max-track-groups)))
- (dolist (group groups)
- (when (and group (gnus-registry-follow-group-p group))
- (push group found-full)
- (setq found (append (list group) (delete group 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)
+ "references" refstr found)))
+
+ ;; else: there were no matches, try the extra tracking by sender
+ ((and (memq 'sender gnus-registry-track-extra)
+ sender
+ (gnus-grep-in-list
+ sender
+ gnus-registry-unfollowed-addresses))
+ (setq found
+ (loop for group
+ in (registry-lookup-secondary-value db 'sender sender)
+
+ when (gnus-registry-follow-group-p group)
+
+ do (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"
+ log-agent sender found)
+ 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 found-full)))
+ "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))
- (let ((groups (gnus-registry-fetch-groups
- key
- gnus-registry-max-track-groups)))
- (dolist (group groups)
- (when (and group (gnus-registry-follow-group-p group))
- (push group found-full)
- (setq found (append (list group) (delete group 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)
+ ((and (memq 'subject gnus-registry-track-extra)
+ subject
+ (< gnus-registry-minimum-subject-length (length subject)))
+ (setq found
+ (loop for group
+ in (registry-lookup-secondary-value db 'subject subject)
+
+ when (gnus-registry-follow-group-p group)
+
+ do (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"
+ log-agent subject found)
+ 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 found-full))))
+ "subject" subject found))))
;; after the (cond) we extract the actual value safely
(car-safe found)))
-(defun gnus-registry-post-process-groups (mode key groups groups-full)
- "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
+(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.
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.
+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' and GROUPS-FULL if
-necessary."
+possible. Uses `gnus-registry-split-strategy'."
(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))
- (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
- 5
- "%s: too many extra matches (%s) for %s %s. Returning none."
- log-agent out mode key)
- (setq out nil))
- out))
+ out)
+
+ ;; the strategy can be nil, in which case groups is nil
+ (setq groups
+ (case gnus-registry-split-strategy
+ ;; first strategy
+ ((first)
+ (and groups (list (car-safe groups))))
+
+ ((majority)
+ (let ((freq (make-hash-table
+ :size 256
+ :test 'equal)))
+ (mapc (lambda (x) (puthash x (1+ (gethash x freq 0)) freq))
+ groups)
+ (list (car-safe
+ (sort groups (lambda (a b)
+ (> (gethash a freq 0)
+ (gethash b freq 0))))))))))
+
+ (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)
+ (add-to-list 'out short-name))
+ ;; else...
+ (gnus-message
+ 7
+ "%s ignored foreign group %s"
+ log-agent group))))
+
+ ;; is there just one group?
+ (if (= (length out) 1)
+ out
+ (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'."
- (not (or (gnus-grep-in-list
- group
- gnus-registry-unfollowed-groups)
- (gnus-grep-in-list
- group
- 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)))))
(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-fetch-extra id 'keywords))
- 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-registry-remove-alist-text-properties
- (downcase (buffer-substring
- (match-beginning 0) (match-end 0)))))
- (if (> (length word) 3)
- (push word words))))))
- (gnus-registry-store-extra-entry id 'keywords words)))))
+ 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 "skeyword: ")
- (let (articles)
- (maphash
- (lambda (key value)
- (when (member keyword
- (cdr-safe (gnus-registry-fetch-extra key 'keywords)))
- (push key articles)))
- gnus-registry-hashtb)
- articles))
+ (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 (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-newsgroup-name
- (gnus-registry-fetch-simplified-message-subject-fast article)
- (gnus-registry-fetch-sender-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)))))))
+
+;; 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-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)))
+ (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))))))
+ (mail-header-subject (gnus-data-header
+ (assoc article (gnus-data-list nil))))))
nil))
(defun gnus-registry-fetch-sender-fast (article)
"Fetch the Sender quickly, using the internal gnus-data-list function"
(if (and (numberp article)
- (assoc article (gnus-data-list nil)))
+ (assoc article (gnus-data-list nil)))
(gnus-string-remove-all-properties
(mail-header-from (gnus-data-header
- (assoc article (gnus-data-list nil)))))
+ (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)))
+ (data (cdr-safe mark-info))
+ (cell-data (plist-get data type)))
(when cell-data
- (funcall function mark 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 ()
:char
(lambda (mark data)
(let ((function-format
- (format "gnus-registry-%%s-article-%s-mark" mark)))
+ (format "gnus-registry-%%s-article-%s-mark" mark)))
;;; The following generates these functions:
;;; (defun gnus-registry-set-article-Important-mark (&rest 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
- (when (eq gnus-registry-install nil)
- (setq gnus-registry-install 'ask))
-
- ;; 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))))))
+ (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
+ (when (eq gnus-registry-install nil)
+ (setq gnus-registry-install 'ask))
+
+ ;; 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))))))
+ (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
;;; '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
- (plist-get
- (cdr-safe
- (assoc mark gnus-registry-marks))
- :char)))
- (if c
- (list c)
- nil)))
- marks))))
+ (marks (when id (gnus-registry-get-id-key id 'mark))))
+ (apply 'concat (mapcar (lambda (mark)
+ (let ((c
+ (plist-get
+ (cdr-safe
+ (assoc mark gnus-registry-marks))
+ :char)))
+ (if c
+ (list c)
+ nil)))
+ marks))))
(defun gnus-registry-read-mark ()
"Read a mark name from the user with completion."
"Label"
(mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
nil nil nil
- (symbol-name gnus-registry-default-mark))))
+ (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))
+ (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 a mark to a list of ARTICLES."
+ (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)))
+ (mapcar 'gnus-registry-fetch-message-id-fast articles)))
(dolist (id article-id-list)
- (let* (
- ;; all the marks for this article without the mark of
- ;; interest
- (marks
- (delq mark (gnus-registry-fetch-extra-marks id)))
- ;; the new marks we want to use
- (new-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 new-marks))
-
- (apply 'gnus-registry-store-extra-marks ; set the extra marks
- id ; for the message ID
- new-marks)))))
+ (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 (marks)
- (dolist (article articles)
- (let ((article-id
- (gnus-registry-fetch-message-id-fast article)))
- (setq marks (gnus-registry-fetch-extra-marks article-id))))
+ (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))
+ (gnus-message 1 "Marks are %S" marks))
marks))
-;;; if this extends to more than 'marks, it should be improved to be more generic.
-(defun gnus-registry-fetch-extra-marks (id)
- "Get the marks of a message, based on the message ID.
-Returns a list of symbol marks or nil."
- (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
-
-(defun gnus-registry-has-extra-mark (id mark)
- "Checks if a message has `mark', based on the message ID `id'."
- (memq mark (gnus-registry-fetch-extra-marks id)))
-
-(defun gnus-registry-store-extra-marks (id &rest mark-list)
- "Set the marks of a message, based on the message ID.
-The `mark-list' can be nil, in which case no marks are left."
- (gnus-registry-store-extra-entry id 'marks (list mark-list)))
-
-(defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
- "Delete the message marks in `mark-delete-list', based on the message ID."
- (let ((marks (gnus-registry-fetch-extra-marks id)))
- (when marks
- (dolist (mark mark-delete-list)
- (setq marks (delq mark marks))))
- (gnus-registry-store-extra-marks id (car marks))))
-
-(defun gnus-registry-delete-all-extra-marks (id)
- "Delete all the marks for a message ID."
- (gnus-registry-store-extra-marks id nil))
-
-(defun gnus-registry-fetch-extra (id &optional entry)
- "Get the extra data of a message, based on the message ID.
-Returns the first place where the trail finds a nonstring."
- (let ((entry-cache (gethash entry gnus-registry-hashtb)))
- (if (and entry
- (hash-table-p entry-cache)
- (gethash id entry-cache))
- (gethash id entry-cache)
- ;; else, if there is no caching possible...
- (let ((trail (gethash id gnus-registry-hashtb)))
- (when (listp trail)
- (dolist (crumb trail)
- (unless (stringp crumb)
- (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
-
-(defun gnus-registry-fetch-extra-entry (alist &optional entry id)
- "Get the extra data of a message, or a specific entry in it.
-Update the entry cache if needed."
- (if (and entry id)
- (let ((entry-cache (gethash entry gnus-registry-hashtb))
- entree)
- (when gnus-registry-entry-caching
- ;; create the hash table
- (unless (hash-table-p entry-cache)
- (setq entry-cache (make-hash-table
- :size 4096
- :test 'equal))
- (puthash entry entry-cache gnus-registry-hashtb))
-
- ;; get the entree from the hash table or from the alist
- (setq entree (gethash id entry-cache)))
-
- (unless entree
- (setq entree (assq entry alist))
- (when gnus-registry-entry-caching
- (puthash id entree entry-cache)))
- entree)
- alist))
-
-(defun gnus-registry-store-extra (id extra)
- "Store the extra data of a message, based on the message ID.
-The message must have at least one group name."
- (when (gnus-registry-group-count id)
- ;; we now know the trail has at least 1 group name, so it's not empty
- (let ((trail (gethash id gnus-registry-hashtb))
- (old-extra (gnus-registry-fetch-extra id))
- entry-cache)
- (dolist (crumb trail)
- (unless (stringp crumb)
- (dolist (entry crumb)
- (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
- (when entry-cache
- (remhash id entry-cache))))
- (puthash id (cons extra (delete old-extra trail))
- gnus-registry-hashtb)
- (setq gnus-registry-dirty t)))))
-
-(defun gnus-registry-delete-extra-entry (id key)
- "Delete a specific entry in the extras field of the registry entry for id."
- (gnus-registry-store-extra-entry id key nil))
-
-(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))
- ;; all the entries except the one for `key'
- (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)
- the-rest))
- the-rest)))
- (gnus-registry-store-extra id alist)))
-
-(defun gnus-registry-fetch-group (id)
- "Get the group of a message, based on the message ID.
-Returns the first place where the trail finds a group name."
- (when (gnus-registry-group-count id)
- ;; we now know the trail has at least 1 group name
- (let ((trail (gethash id gnus-registry-hashtb)))
- (dolist (crumb trail)
- (when (stringp crumb)
- (return (if gnus-registry-use-long-group-names
- crumb
- (gnus-group-short-name crumb))))))))
-
-(defun gnus-registry-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
- groups
- (cons
- (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
- crumb
- (gnus-group-short-name crumb))
- groups))
- (when (and max (> (length groups) max))
- (return))))
- ;; return the list of groups
- groups))
-
(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 (and group id)
- (let ((trail (gethash id gnus-registry-hashtb))
- (short-group (gnus-group-short-name group)))
- (puthash id (if trail
- (delete short-group (delete group trail))
- nil)
- gnus-registry-hashtb))
- ;; now, clear the entry if there are no more groups
- (when gnus-registry-trim-articles-without-groups
- (unless (gnus-registry-group-count id)
- (gnus-registry-delete-id id)))
- ;; is this ID still in the registry?
- (when (gethash id gnus-registry-hashtb)
- (gnus-registry-store-extra-entry id 'mtime (current-time)))))
-
-(defun gnus-registry-delete-id (id)
- "Delete a message ID from the registry."
- (when (stringp id)
- (remhash id gnus-registry-hashtb)
- (maphash
- (lambda (key value)
- (when (hash-table-p value)
- (remhash id value)))
- gnus-registry-hashtb)))
-
-(defun gnus-registry-add-group (id group &optional subject sender)
- "Add a group for a message, based on the message ID."
- (when group
- (when (and id
- (not (string-match "totally-fudged-out-message-id" id)))
- (let ((full-group group)
- (group (if gnus-registry-use-long-group-names
- group
- (gnus-group-short-name group))))
- (gnus-registry-delete-group id group)
-
- (unless gnus-registry-use-long-group-names ;; unnecessary in this case
- (gnus-registry-delete-group id full-group))
-
- (let ((trail (gethash id gnus-registry-hashtb)))
- (puthash id (if trail
- (cons group trail)
- (list group))
- gnus-registry-hashtb)
-
- (when (and (gnus-registry-track-subject-p)
- subject)
- (gnus-registry-store-extra-entry
- id
- 'subject
- (gnus-registry-simplify-subject subject)))
- (when (and (gnus-registry-track-sender-p)
- sender)
- (gnus-registry-store-extra-entry
- id
- 'sender
- sender))
-
- (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
-
-(defun gnus-registry-clear ()
- "Clear the Gnus registry."
- (interactive)
- (setq gnus-registry-alist nil)
- (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
- (setq gnus-registry-dirty t))
+ (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)
+ (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-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)))
+ (registry-insert db id entry)
+ entry))
+
+
+(ert-deftest gnus-registry-usage-test ()
+ (let* ((n 100)
+ (tempfile (make-temp-file "gnus-registry-persist"))
+ (db (gnus-registry-make-db tempfile))
+ (gnus-registry-db db)
+ back size)
+ (message "Adding %d keys to the test Gnus registry" n)
+ (dotimes (i n)
+ (let ((id (number-to-string i)))
+ (gnus-registry-handle-action id
+ (if (>= 50 i) "fromgroup" nil)
+ "togroup"
+ (when (>= 70 i)
+ (format "subject %d" (mod i 10)))
+ (when (>= 80 i)
+ (format "sender %d" (mod i 10))))))
+ (message "Testing Gnus registry size is %d" n)
+ (should (= n (registry-size db)))
+ (message "Looking up individual keys (registry-lookup)")
+ (should (equal (loop for e
+ in (mapcar 'cadr
+ (registry-lookup db '("20" "83" "72")))
+ collect (assq 'subject e)
+ collect (assq 'sender e)
+ collect (assq 'group e))
+ '((subject "subject 0") (sender "sender 0") (group "togroup")
+ (subject) (sender) (group "togroup")
+ (subject) (sender "sender 2") (group "togroup"))))
+
+ (message "Looking up individual keys (gnus-registry-id-key)")
+ (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
+ (message "Trying to insert a duplicate key")
+ (should-error (registry-insert db "55" '()))
+ (message "Looking up individual keys (gnus-registry-get-or-make-entry)")
+ (should (gnus-registry-get-or-make-entry "22"))
+ (message "Saving the Gnus registry to %s" tempfile)
+ (should (gnus-registry-save tempfile db))
+ (setq size (nth 7 (file-attributes tempfile)))
+ (message "Saving the Gnus registry to %s: size %d" tempfile size)
+ (should (< 0 size))
+ (with-temp-buffer
+ (insert-file-contents-literally tempfile)
+ (should (looking-at (concat ";; Object "
+ "Gnus Registry"
+ "\n;; EIEIO PERSISTENT OBJECT"))))
+ (message "Reading Gnus registry back")
+ (setq back (eieio-persistent-read tempfile))
+ (should back)
+ (message "Read Gnus registry back: %d keys, expected %d==%d"
+ (registry-size back) n (registry-size db))
+ (should (= (registry-size back) n))
+ (should (= (registry-size back) (registry-size db)))
+ (delete-file tempfile)
+ (message "Pruning Gnus registry to 0 by setting :max-soft")
+ (oset db :max-soft 0)
+ (registry-prune db)
+ (should (= (registry-size db) 0)))
+ (message "Done with Gnus registry usage testing."))
;;;###autoload
(defun gnus-registry-initialize ()
"Initialize the Gnus registry."
(interactive)
(gnus-message 5 "Initializing the registry")
- (setq gnus-registry-install t) ; in case it was 'ask or nil
+ (setq gnus-registry-install t) ; in case it was 'ask or nil
(gnus-registry-install-hooks)
(gnus-registry-install-shortcuts)
(gnus-registry-read))
(interactive)
(when (eq gnus-registry-install 'ask)
(setq gnus-registry-install
- (gnus-y-or-n-p
- (concat "Enable the Gnus registry? "
- "See the variable `gnus-registry-install' "
- "to get rid of this query permanently. ")))
+ (gnus-y-or-n-p
+ (concat "Enable the Gnus registry? "
+ "See the variable `gnus-registry-install' "
+ "to get rid of this query permanently. ")))
(when gnus-registry-install
;; we just set gnus-registry-install to t, so initialize the registry!
(gnus-registry-initialize)))
--- /dev/null
+;;; registry.el --- Track and remember data items by various fields
+
+;; Copyright (C) 2011 Teodor Zlatanov
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.com>
+;; Keywords: data
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides a general-purpose EIEIO-based registry
+;; database with persistence, initialized with these fields:
+
+;; version: a float, 0.1 currently (don't change it)
+
+;; max-hard: an integer, default 5000000
+
+;; max-soft: an integer, default 50000
+
+;; precious: a list of symbols
+
+;; tracked: a list of symbols
+
+;; tracker: a hashtable tuned for 100 symbols to track (you should
+;; only access this with the :lookup2-function and the
+;; :lookup2+-function)
+
+;; data: a hashtable with default size 10K and resize threshold 2.0
+;; (this reflects the expected usage so override it if you know better)
+
+;; ...plus methods to do all the work: `registry-search',
+;; `registry-lookup', `registry-lookup-secondary',
+;; `registry-lookup-secondary-value', `registry-insert',
+;; `registry-delete', `registry-prune', `registry-size' which see
+
+;; and with the following properties:
+
+;; Every piece of data has a unique ID and some general-purpose fields
+;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g.
+
+;; ((F1 D1) (F2 D2) (F3 a b c))
+
+;; Note that whether a field has one or many pieces of data, the data
+;; is always a list of values.
+
+;; The user decides which fields are "precious", F2 for example. At
+;; PRUNE TIME (when the :prune-function is called), the registry will
+;; trim any entries without the F2 field until the size is :max-soft
+;; or less. No entries with the F2 field will be removed at PRUNE
+;; TIME.
+
+;; When an entry is inserted, the registry will reject new entries
+;; if they bring it over the max-hard limit, even if they have the F2
+;; field.
+
+;; The user decides which fields are "tracked", F1 for example. Any
+;; new entry is then indexed by all the tracked fields so it can be
+;; quickly looked up that way. The data is always a list (see example
+;; above) and each list element is indexed.
+
+;; Precious and tracked field names must be symbols. All other
+;; fields can be any other Emacs Lisp types.
+
+;;; Code:
+
+(eval-when-compile (require 'ert))
+(eval-when-compile (require 'cl))
+(eval-and-compile
+ (or (ignore-errors (progn
+ (require 'eieio)
+ (require 'eieio-base)))
+ ;; gnus-fallback-lib/ from gnus/lisp/gnus-fallback-lib
+ (ignore-errors
+ (let ((load-path (cons (expand-file-name
+ "gnus-fallback-lib/eieio"
+ (file-name-directory (locate-library "gnus")))
+ load-path)))
+ (require 'eieio)
+ (require 'eieio-base)))
+ (error
+ "eieio not found in `load-path' or gnus-fallback-lib/ directory.")))
+
+(defclass registry-db (eieio-persistent)
+ ((version :initarg :version
+ :initform 0.1
+ :type float
+ :custom float
+ :documentation "The registry version.")
+ (max-hard :initarg :max-hard
+ :initform 5000000
+ :type integer
+ :custom integer
+ :documentation "Never accept more than this many elements.")
+ (max-soft :initarg :max-soft
+ :initform 50000
+ :type integer
+ :custom integer
+ :documentation "Prune as much as possible to get to this size.")
+ (tracked :initarg :tracked
+ :initform nil
+ :type t
+ :documentation "The tracked (indexed) fields, a list of symbols.")
+ (precious :initarg :precious
+ :initform nil
+ :type t
+ :documentation "The precious fields, a list of symbols.")
+ (tracker :initarg :tracker
+ :initform (make-hash-table :size 100 :rehash-size 2.0)
+ :type t
+ :documentation "The field tracking hashtable.")
+ (data :initarg :data
+ :initform (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)
+ :type t
+ :documentation "The data hashtable.")))
+
+;; (defmethod initialize-instance :after ((this registry-db) slots)
+;; "Set value of data slot of THIS after initialization."
+;; (with-slots (data tracker max-hard max-soft tracked precious version) this
+;; (setq data (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)
+;; tracker (make-hash-table :size 100 :rehash-size 2.0)
+;; max-hard 5000000
+;; max-soft 50000
+;; tracked nil
+;; precious nil
+;; version 0.1)))
+
+(defmethod registry-lookup ((db registry-db) keys)
+ "Search for KEYS in the registry-db THIS.
+Returns a alist of the key followed by the entry in a list, not a cons cell."
+ (let ((data (oref db :data)))
+ (delq nil
+ (mapcar
+ (lambda (k)
+ (when (gethash k data)
+ (list k (gethash k data))))
+ keys))))
+
+(defmethod registry-lookup-secondary ((db registry-db) tracksym
+ &optional create)
+ "Search for TRACKSYM in the registry-db THIS.
+When CREATE is not nil, create the secondary index hashtable if needed."
+ (let ((h (gethash tracksym (oref db :tracker))))
+ (if h
+ h
+ (when create
+ (puthash tracksym
+ (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
+ (oref db :tracker))
+ (gethash tracksym (oref db :tracker))))))
+
+(defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
+ &optional set)
+ "Search for TRACKSYM with value VAL in the registry-db THIS.
+When SET is not nil, set it for VAL (use t for an empty list)."
+ ;; either we're asked for creation or there should be an existing index
+ (when (or set (registry-lookup-secondary db tracksym))
+ ;; set the entry if requested,
+ (when set
+ (puthash val (if (eq t set) '() set)
+ (registry-lookup-secondary db tracksym t)))
+ (gethash val (registry-lookup-secondary db tracksym))))
+
+(defun registry--match (mode entry check-list)
+ ;; for all members
+ (when check-list
+ (let ((key (nth 0 (nth 0 check-list)))
+ (vals (cdr-safe (nth 0 check-list)))
+ found)
+ (while (and key vals (not found))
+ (setq found (case mode
+ (:member
+ (member (car-safe vals) (cdr-safe (assoc key entry))))
+ (:regex
+ (string-match (car vals)
+ (mapconcat
+ 'prin1-to-string
+ (cdr-safe (assoc key entry))
+ "\0"))))
+ vals (cdr-safe vals)))
+ (or found
+ (registry--match mode entry (cdr-safe check-list))))))
+
+(defmethod registry-search ((db registry-db) &rest spec)
+ "Search for SPEC across the registry-db THIS.
+For example calling with :member '(a 1 2) will match entry '((a 3 1)).
+Calling with :all t (any non-nil value) will match all.
+Calling with :regex '\(a \"h.llo\") will match entry '((a \"hullo\" \"bye\").
+The test order is to check :all first, then :member, then :regex."
+ (when db
+ (let ((all (plist-get spec :all))
+ (member (plist-get spec :member))
+ (regex (plist-get spec :regex)))
+ (loop for k being the hash-keys of (oref db :data) using (hash-values v)
+ when (or
+ ;; :all non-nil returns all
+ all
+ ;; member matching
+ (and member (registry--match :member v member))
+ ;; regex matching
+ (and regex (registry--match :regex v regex)))
+ collect k))))
+
+(defmethod registry-delete ((db registry-db) keys assert &rest spec)
+ "Delete KEYS from the registry-db THIS.
+If KEYS is nil, use SPEC to do a search.
+Updates the secondary ('tracked') indices as well.
+With assert non-nil, errors out if the key does not exist already."
+ (let* ((data (oref db :data))
+ (keys (or keys
+ (apply 'registry-search db spec)))
+ (tracked (oref db :tracked)))
+
+ (dolist (key keys)
+ (let ((entry (gethash key data)))
+ (when assert
+ (assert entry nil
+ "Key %s does not exists in database" key))
+ ;; clean entry from the secondary indices
+ (dolist (tr tracked)
+ ;; is this tracked symbol indexed?
+ (when (registry-lookup-secondary db tr)
+ ;; for every value in the entry under that key...
+ (dolist (val (cdr-safe (assq tr entry)))
+ (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+ (when (member key value-keys)
+ ;; override the previous value
+ (registry-lookup-secondary-value
+ db tr val
+ ;; with the indexed keys MINUS the current key
+ ;; (we pass t when the list is empty)
+ (or (delete key value-keys) t)))))))
+ (remhash key data)))
+ keys))
+
+(defmethod registry-insert ((db registry-db) key entry)
+ "Insert ENTRY under KEY into the registry-db THIS.
+Updates the secondary ('tracked') indices as well.
+Errors out if the key exists already."
+
+ (assert (not (gethash key (oref db :data))) nil
+ "Key already exists in database")
+
+ (assert (< (registry-size db)
+ (oref db :max-hard))
+ nil
+ "max-hard size limit reached")
+
+ ;; store the entry
+ (puthash key entry (oref db :data))
+
+ ;; store the secondary indices
+ (dolist (tr (oref db :tracked))
+ ;; for every value in the entry under that key...
+ (dolist (val (cdr-safe (assq tr entry)))
+ (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+ (pushnew key value-keys :test 'equal)
+ (registry-lookup-secondary-value db tr val value-keys))))
+ entry)
+
+(defmethod registry-size ((db registry-db))
+ "Returns the size of the registry-db object THIS.
+This is the key count of the :data slot."
+ (hash-table-count (oref db :data)))
+
+(defmethod registry-prune ((db registry-db))
+ "Prunes the registry-db object THIS.
+Removes only entries without the :precious keys."
+ (let* ((precious (oref db :precious))
+ (precious-p (lambda (entry-key) (cdr (memq (car entry-key) precious))))
+ (data (oref db :data))
+ (limit (oref db :max-soft))
+ (size (registry-size db))
+ (candidates (loop for k being the hash-keys of data
+ using (hash-values v)
+ when (notany precious-p v)
+ collect k))
+ (candidates-count (length candidates))
+ ;; are we over max-soft?
+ (prune-needed (> size limit)))
+
+ ;; while we have more candidates than we need to remove...
+ (while (and (> candidates-count (- size limit)) candidates)
+ (decf candidates-count)
+ (setq candidates (cdr candidates)))
+
+ (registry-delete db candidates nil)))
+
+(ert-deftest registry-instantiation-test ()
+ (should (registry-db "Testing")))
+
+(ert-deftest registry-match-test ()
+ (let ((entry '((hello "goodbye" "bye") (blank))))
+
+ (message "Testing :regex matching")
+ (should (registry--match :regex entry '((hello "nye" "bye"))))
+ (should (registry--match :regex entry '((hello "good"))))
+ (should-not (registry--match :regex entry '((hello "nye"))))
+ (should-not (registry--match :regex entry '((hello))))
+
+ (message "Testing :member matching")
+ (should (registry--match :member entry '((hello "bye"))))
+ (should (registry--match :member entry '((hello "goodbye"))))
+ (should-not (registry--match :member entry '((hello "good"))))
+ (should-not (registry--match :member entry '((hello "nye"))))
+ (should-not (registry--match :member entry '((hello)))))
+ (message "Done with matching testing."))
+
+(defun registry-make-testable-db (n &optional name file)
+ (let* ((db (registry-db
+ (or name "Testing")
+ :file (or file "unused")
+ :max-hard n
+ :max-soft 0 ; keep nothing not precious
+ :precious '(extra more-extra)
+ :tracked '(sender subject groups))))
+ (dotimes (i n)
+ (registry-insert db i `((sender "me")
+ (subject "about you")
+ (more-extra) ; empty data key should be pruned
+ ;; first 5 entries will NOT have this extra data
+ ,@(when (< 5 i) (list (list 'extra "more data")))
+ (groups ,(number-to-string i)))))
+ db))
+
+(ert-deftest registry-usage-test ()
+ (let* ((n 100)
+ (db (registry-make-testable-db n)))
+ (message "size %d" n)
+ (should (= n (registry-size db)))
+ (message "max-hard test")
+ (should-error (registry-insert db "new" '()))
+ (message "Individual lookup")
+ (should (= 58 (caadr (registry-lookup db '(1 58 99)))))
+ (message "Grouped individual lookup")
+ (should (= 3 (length (registry-lookup db '(1 58 99)))))
+ (message "Search")
+ (should (= n (length (registry-search db :all t))))
+ (should (= n (length (registry-search db :member '((sender "me"))))))
+ (message "Secondary index search")
+ (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
+ (should (equal '(74) (registry-lookup-secondary-value db 'groups "74")))
+ (message "Delete")
+ (should (registry-delete db '(1) t))
+ (decf n)
+ (message "Search after delete")
+ (should (= n (length (registry-search db :all t))))
+ (message "Secondary search after delete")
+ (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
+ (message "Pruning")
+ (let* ((tokeep (registry-search db :member '((extra "more data"))))
+ (count (- n (length tokeep)))
+ (pruned (registry-prune db))
+ (prune-count (length pruned)))
+ (message "Expecting to prune %d entries and pruned %d"
+ count prune-count)
+ (should (and (= count 5)
+ (= count prune-count))))
+ (message "Done with usage testing.")))
+
+(ert-deftest registry-persistence-test ()
+ (let* ((n 100)
+ (tempfile (make-temp-file "registry-persistence-"))
+ (name "persistence tester")
+ (db (registry-make-testable-db n name tempfile))
+ size back)
+ (message "Saving to %s" tempfile)
+ (eieio-persistent-save db)
+ (setq size (nth 7 (file-attributes tempfile)))
+ (message "Saved to %s: size %d" tempfile size)
+ (should (< 0 size))
+ (with-temp-buffer
+ (insert-file-contents-literally tempfile)
+ (should (looking-at (concat ";; Object "
+ name
+ "\n;; EIEIO PERSISTENT OBJECT"))))
+ (message "Reading object back")
+ (setq back (eieio-persistent-read tempfile))
+ (should back)
+ (message "Read object back: %d keys, expected %d==%d"
+ (registry-size back) n (registry-size db))
+ (should (= (registry-size back) n))
+ (should (= (registry-size back) (registry-size db)))
+ (delete-file tempfile))
+ (message "Done with persistence testing."))
+
+(provide 'registry)
+;;; registry.el ends here
projects / gnus / commitdiff