X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=b233ad718685db229dbb548d8ff851763859dc7a;hb=851278bf56a0156a4dd5896e9959f63e33d07ee2;hp=829734f17c3c1e153c72fe15f73e8cae9917680d;hpb=68819187129126e5cfb9aa0cf0249f98cddc375c;p=gnus diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 829734f17..b233ad718 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,6 +1,6 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ;; Author: Ted Zlatanov ;; Keywords: news registry @@ -87,6 +87,12 @@ (require 'easymenu) (require 'registry) +;; Silence XEmacs byte compiler, which will otherwise complain about +;; call to `eieio-persistent-read'. +(when (featurep 'xemacs) + (byte-compiler-options + (warnings (- callargs)))) + (defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t @@ -170,6 +176,8 @@ nnmairix groups are specifically excluded because they are ephemeral." (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") +;; FIXME it was simply deleted. +(make-obsolete-variable 'gnus-registry-max-pruned-entries nil "25.1") (defcustom gnus-registry-track-extra '(subject sender recipient) "Whether the registry should track extra data about a message. @@ -225,7 +233,7 @@ the Bit Bucket." (defcustom gnus-registry-cache-file (nnheader-concat (or gnus-dribble-directory gnus-home-directory "~/") - ".gnus.registry.eioio") + ".gnus.registry.eieio") "File where the Gnus registry will be stored." :group 'gnus-registry :type 'file) @@ -236,31 +244,52 @@ the Bit Bucket." :type '(radio (const :format "Unlimited " nil) (integer :format "Maximum number: %v"))) -(defcustom gnus-registry-max-pruned-entries nil - "Maximum number of pruned entries in the registry, nil for unlimited." - :version "24.1" +(defcustom gnus-registry-prune-factor 0.1 + "When pruning, try to prune back to this factor less than the maximum size. + +In order to prevent constant pruning, we prune back to a number +somewhat less than the maximum size. This option controls +exactly how much less. For example, given a maximum size of +50000 and a prune factor of 0.1, the pruning process will try to +cut the registry back to \(- 50000 \(* 50000 0.1\)\) -> 45000 +entries. The pruning process is constrained by the presence of +\"precious\" entries." + :version "25.1" :group 'gnus-registry - :type '(radio (const :format "Unlimited " nil) - (integer :format "Maximum number: %v"))) + :type 'float) + +(defcustom gnus-registry-default-sort-function + #'gnus-registry-sort-by-creation-time + "Sort function to use when pruning the registry. +Entries that sort to the front of the list are pruned first. +This can slow pruning down. Set to nil to perform no sorting." + :version "25.1" + :group 'gnus-registry + :type '(choice (const :tag "No sorting" nil) function)) + +(defun gnus-registry-sort-by-creation-time (l r) + "Sort older entries to front of list." + ;; Pruning starts from the front of the list. + (time-less-p + (cadr (assq 'creation-time r)) + (cadr (assq 'creation-time l)))) (defun gnus-registry-fixup-registry (db) (when db - (let ((old (oref db :tracked))) - (oset db :precious + (let ((old (oref db tracked))) + (setf (oref db precious) (append gnus-registry-extra-entries-precious '())) - (oset db :max-hard + (setf (oref db max-size) (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 + (setf (oref db prune-factor) + (or gnus-registry-prune-factor + 0.1)) + (setf (oref db tracked) (append gnus-registry-track-extra '(mark group keyword))) - (when (not (equal old (oref db :tracked))) + (when (not (equal old (oref db tracked))) (gnus-message 9 "Reindexing the Gnus registry (tracked change)") (registry-reindex db)))) db) @@ -268,14 +297,13 @@ the Bit Bucket." (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))) + (make-instance 'registry-db + :file (or file gnus-registry-cache-file) + ;; these parameters are set in `gnus-registry-fixup-registry' + :max-size most-positive-fixnum + :version registry-db-version + :precious nil + :tracked nil))) (defvar gnus-registry-db (gnus-registry-make-db) "The article registry by Message ID. See `registry-db'.") @@ -289,21 +317,27 @@ This is not required after changing `gnus-registry-cache-file'." (gnus-message 4 "Remaking the Gnus registry") (setq gnus-registry-db (gnus-registry-make-db)))) -(defun gnus-registry-read () - "Read the registry cache file." +(defun gnus-registry-load () + "Load the registry from the cache file." (interactive) (let ((file gnus-registry-cache-file)) (condition-case nil - (progn - (gnus-message 5 "Reading Gnus registry from %s..." file) - (setq gnus-registry-db - (gnus-registry-fixup-registry - (condition-case nil - (eieio-persistent-read file 'registry-db) - ;; Older EIEIO versions do not check the class name. - ('wrong-number-of-arguments - (eieio-persistent-read file))))) - (gnus-message 5 "Reading Gnus registry from %s...done" file)) + (gnus-registry-read file) + (file-error + ;; Fix previous mis-naming of the registry file. + (let ((old-file-name + (concat (file-name-sans-extension + gnus-registry-cache-file) + ".eioio"))) + (if (and (file-exists-p old-file-name) + (yes-or-no-p + (format "Rename registry file from %s to %s? " + old-file-name file))) + (progn + (gnus-registry-read old-file-name) + (setf (oref gnus-registry-db file) file) + (gnus-message 1 "Registry filename changed to %s" file)) + (gnus-registry-remake-db t)))) (error (gnus-message 1 @@ -311,6 +345,19 @@ This is not required after changing `gnus-registry-cache-file'." file) (gnus-registry-remake-db t))))) +(defun gnus-registry-read (file) + "Do the actual reading of the registry persistence file." + (gnus-message 5 "Reading Gnus registry from %s..." file) + (setq gnus-registry-db + (gnus-registry-fixup-registry + (condition-case nil + (with-no-warnings + (eieio-persistent-read file 'registry-db)) + ;; Older EIEIO versions do not check the class name. + ('wrong-number-of-arguments + (eieio-persistent-read file))))) + (gnus-message 5 "Reading Gnus registry from %s...done" file)) + (defun gnus-registry-save (&optional file db) "Save the registry cache file." (interactive) @@ -318,7 +365,8 @@ This is not required after changing `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) + (registry-prune + db gnus-registry-default-sort-function) ;; 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" @@ -349,8 +397,7 @@ This is not required after changing `gnus-registry-cache-file'." (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"))) + (to (if to (gnus-group-guess-full-name-from-command-method to) nil))) (gnus-message 7 "Gnus registry: article %s %s from %s to %s" id (if method "respooling" "going") from to) @@ -406,7 +453,8 @@ This is not required after changing `gnus-registry-cache-file'." (let ((new (or (assq (first kv) entry) (list (first kv))))) (dolist (toadd (cdr kv)) - (add-to-list 'new toadd t)) + (unless (member toadd new) + (setq new (append new (list toadd))))) (setq entry (cons new (assq-delete-all (first kv) entry)))))) (gnus-message 10 "Gnus registry: new entry for %s is %S" @@ -510,7 +558,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 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" + "%s (extra tracking) traced subject `%s' to %s" log-agent subject group) and collect group)) ;; filter the found groups and return them @@ -537,7 +585,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 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" + "%s (extra tracking) traced sender `%s' to %s" log-agent sender group) and collect group))) @@ -567,7 +615,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 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" + "%s (extra tracking) traced recipient `%s' to %s" log-agent recp group) and collect group))))) @@ -582,7 +630,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (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 +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. @@ -650,7 +698,7 @@ possible. Uses `gnus-registry-split-strategy'." 10 "%s: stripped group %s to %s" log-agent group short-name)) - (add-to-list 'out short-name)) + (pushnew short-name out :test #'equal)) ;; else... (gnus-message 7 @@ -664,12 +712,12 @@ possible. Uses `gnus-registry-split-strategy'." ((null out) (gnus-message 5 - "%s: no matches for %s '%s'." + "%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." + "%s: too many extra matches (%s) for %s `%s'. Returning none." log-agent out mode key) nil)))) @@ -736,8 +784,9 @@ Overrides existing keywords with FORCE set non-nil." (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)))) + (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)) + (ks ())) + (when table (maphash (lambda (k _v) (push k ks)) table) ks))) (defun gnus-registry-find-keywords (keyword) (interactive (list @@ -832,7 +881,7 @@ FUNCTION should take two parameters, a mark symbol and the cell value." ;; FIXME: Why not merge gnus-registry--set/remove-mark and ;; gnus-registry-set-article-mark-internal? -(defun gnus-registry--set/remove-mark (remove mark articles) +(defun gnus-registry--set/remove-mark (mark remove articles) "Set/remove the MARK over process-marked ARTICLES." ;; If this is called and the user doesn't want the ;; registry enabled, we'll ask anyhow. @@ -1025,7 +1074,8 @@ only the last one's marks are returned." "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-prune + db gnus-registry-default-sort-function)) (registry-insert db id entry) entry) @@ -1050,11 +1100,10 @@ only the last one's marks are returned." (when (and (< 0 expected) (= 0 (mod count 100))) (message "importing: %d of %d (%.2f%%)" - count expected (/ (* 100 count) expected))) + count expected (/ (* 100.0 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) @@ -1083,7 +1132,7 @@ only the last one's marks are returned." (gnus-message 5 "Initializing the registry") (gnus-registry-install-hooks) (gnus-registry-install-shortcuts) - (gnus-registry-read)) + (gnus-registry-load)) ;; FIXME: Why autoload this function? ;;;###autoload @@ -1097,7 +1146,7 @@ only the last one's marks are returned." (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) + (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) @@ -1110,7 +1159,7 @@ only the last one's marks are returned." (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-read-newsrc-el-hook 'gnus-registry-load) (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) (setq gnus-registry-enabled nil)) @@ -1118,9 +1167,9 @@ only the last one's marks are returned." (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) (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." + "Return non-nil if the registry is enabled (and maybe enable it first). +If the registry is not already enabled, then if `gnus-registry-install' +is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it." (interactive) (unless gnus-registry-enabled (when (if (eq gnus-registry-install 'ask) @@ -1179,6 +1228,29 @@ data stored in the registry." (gnus-select-group-with-message-id group message-id) t) (throw 'found t)))))))) +(defun gnus-registry-remove-extra-data (extra) + "Remove tracked EXTRA data from the gnus registry. +EXTRA is a list of symbols. Valid symbols are those contained in +the docs of `gnus-registry-track-extra'. This command is useful +when you stop tracking some extra data and now want to purge it +from your existing entries." + (interactive (list (mapcar 'intern + (completing-read-multiple + "Extra data: " + '("subject" "sender" "recipient"))))) + (when extra + (let ((db gnus-registry-db)) + (registry-reindex db) + (loop for k being the hash-keys of (oref db data) + using (hash-value v) + do (let ((newv (delq nil (mapcar #'(lambda (entry) + (unless (member (car entry) extra) + entry)) + v)))) + (registry-delete db (list k) nil) + (gnus-registry-insert db k newv))) + (registry-reindex db)))) + ;; TODO: a few things (provide 'gnus-registry)