X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=f3b81f77b5090ea4a0e102d49faf453a15e8d0a4;hp=42762a444e2d4930e4d1b3d910946985ba1a5e19;hb=8bb74da7932287e4f5fd806aa6c7dae35256bdce;hpb=4b33d9287652b0d133fd6fe59971da5cece40ef8 diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index 42762a444..f3b81f77b 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-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;; Author: Ted Zlatanov ;; Keywords: news registry @@ -87,10 +87,16 @@ (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 - "Boolean set to t when the registry is modified") + "Boolean set to t when the registry is modified.") (defgroup gnus-registry nil "The Gnus registry." @@ -278,7 +284,7 @@ the Bit Bucket." :tracked nil))) (defvar gnus-registry-db (gnus-registry-make-db) - "*The article registry by Message ID. See `registry-db'") + "The article registry by Message ID. See `registry-db'.") ;; top-level registry data management (defun gnus-registry-remake-db (&optional forsure) @@ -296,8 +302,14 @@ This is not required after changing `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 - (eieio-persistent-read 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)) (error (gnus-message @@ -412,9 +424,9 @@ This is not required after changing `gnus-registry-cache-file'." ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. (defun gnus-registry-split-fancy-with-parent () - "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 + "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 function tracks ALL backends, unlike @@ -740,7 +752,7 @@ Overrides existing keywords with FORCE set non-nil." (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" + "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)) @@ -755,7 +767,7 @@ Overrides existing keywords with FORCE set non-nil." ;; message field fetchers (defun gnus-registry-fetch-message-id-fast (article) - "Fetch the Message-ID quickly, using the internal gnus-data-list function" + "Fetch the Message-ID quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) @@ -787,7 +799,7 @@ Addresses without a name will say \"noname\"." nil)) (defun gnus-registry-fetch-simplified-message-subject-fast (article) - "Fetch the Subject quickly, using the internal gnus-data-list function" + "Fetch the Subject quickly, using the internal gnus-data-list function." (if (and (numberp article) (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties @@ -805,7 +817,7 @@ Addresses without a name will say \"noname\"." (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" + "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 @@ -825,7 +837,34 @@ FUNCTION should take two parameters, a mark symbol and the cell value." (when cell-data (funcall function mark cell-data))))) -;;; this is ugly code, but I don't know how to do it better +;; 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) + "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. + (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. + mark articles remove t) + ;; FIXME: Why do we do the above only here and not directly inside + ;; gnus-registry-set-article-mark-internal? I.e. we wouldn't we want to do + ;; the things below when gnus-registry-set-article-mark-internal is called + ;; from gnus-registry-set-article-mark or + ;; gnus-registry-remove-article-mark? + (gnus-message 9 "Applying mark %s to %d articles" + mark (length articles)) + (dolist (article articles) + (gnus-summary-update-article + article + (assoc article (gnus-data-list nil)))))) + +;; 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." @@ -837,69 +876,41 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (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)) +;;; 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) + (function-name + (intern (format function-format variant-name))) + (shortcut (format "%c" (if remove (upcase data) data)))) + (defalias function-name + ;; If it weren't for the function's docstring, we could + ;; use a closure, with lexical-let :-( + `(lambda (&rest articles) + ,(format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark ',mark ',remove articles))) + (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" (upcase-initials variant-name) (symbol-name mark)) - (intern function-name) t) + function-name t) gnus-registry-misc-menus) - (gnus-message - 9 - "Defined mark handling function %s" - function-name)))))) + (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) @@ -919,7 +930,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; 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" + "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) @@ -932,7 +943,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; 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" + "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 ","))) @@ -983,7 +994,7 @@ only the last one's marks are returned." (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) + (when (gmm-called-interactively-p 'any) (gnus-message 1 "Marks are %S" marks)) marks)) @@ -1074,13 +1085,14 @@ only the last one's marks are returned." ;;;###autoload (defun gnus-registry-initialize () -"Initialize the Gnus registry." + "Initialize the Gnus registry." (interactive) (gnus-message 5 "Initializing the registry") (gnus-registry-install-hooks) (gnus-registry-install-shortcuts) (gnus-registry-read)) +;; FIXME: Why autoload this function? ;;;###autoload (defun gnus-registry-install-hooks () "Install the registry hooks." @@ -1113,9 +1125,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) @@ -1169,9 +1181,33 @@ data stored in the registry." ;; Try to activate the group. If that fails, just move ;; along. We may have more groups to work with - (ignore-errors - (gnus-select-group-with-message-id group message-id)) - (throw 'found t))))))) + (when + (ignore-errors + (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