X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-registry.el;h=45fa95617820f1d56268d30d052b42b5c456c035;hp=ddb6696422a932d0fe54d88a9c253d6d49ba2fb2;hb=bd8720765d1f53fac4b3d2fd9cd5844a3f90c8d6;hpb=20bc985a3232ebba106d335afcfd6b596bb8efba diff --git a/lisp/gnus-registry.el b/lisp/gnus-registry.el index ddb669642..45fa95617 100644 --- a/lisp/gnus-registry.el +++ b/lisp/gnus-registry.el @@ -1,26 +1,25 @@ ;;; gnus-registry.el --- article registry for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. + +;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;;; Free Software Foundation, Inc. ;; Author: Ted Zlatanov -;; Keywords: news +;; Keywords: news registry ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -37,10 +36,12 @@ ;; Put this in your startup file (~/.gnus.el for instance) +;; (require 'nnregistry) ;; optional, or see below (automatically calls `gnus-registry-install-nnregistry' when `gnus-registry-initialize' is called) ;; (setq gnus-registry-max-entries 2500 ;; gnus-registry-use-long-group-names t) ;; (gnus-registry-initialize) +;; (gnus-registry-install-nnregistry) ;; optional, or see above (loading nnregistry makes it unnecessary) ;; Then use this in your fancy-split: @@ -59,7 +60,11 @@ (require 'gnus) (require 'gnus-int) (require 'gnus-sum) +(require 'gnus-util) (require 'nnmail) +(require 'easymenu) + +(defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t "Boolean set to t when the registry is modified") @@ -69,21 +74,77 @@ :version "22.1" :group 'gnus) -(defvar gnus-registry-hashtb (make-hash-table +(defvar gnus-registry-hashtb (make-hash-table :size 256 :test 'equal) "*The article registry by Message ID.") -(defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue") - "List of groups that gnus-registry-split-fancy-with-parent won't follow. -The group names are matched, they don't have to be fully qualified." +(defcustom gnus-registry-marks + '((Important + :char ?i + :image "summary_important") + (Work + :char ?w + :image "summary_work") + (Personal + :char ?p + :image "summary_personal") + (To-Do + :char ?t + :image "summary_todo") + (Later + :char ?l + :image "summary_later")) + + "List of registry marks and their options. + +`gnus-registry-mark-article' will offer symbols from this list +for completion. + +Each entry must have a character to be useful for summary mode +line display and for keyboard shortcuts. + +Each entry must have an image string to be useful for visual +display." :group 'gnus-registry - :type '(repeat string)) + :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")))))) + +(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-groups + '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:") + "List of groups that gnus-registry-split-fancy-with-parent won't return. +The group names are matched, they don't have to be fully +qualified. This parameter tells the Registry 'never split a +message into a group that matches one of these, regardless of +references.' -(defcustom gnus-registry-install nil +nnmairix groups are specifically excluded because they are ephemeral." + :group 'gnus-registry + :type '(repeat regexp)) + +(defcustom gnus-registry-install 'ask "Whether the registry should be installed." :group 'gnus-registry - :type 'boolean) + :type '(choice (const :tag "Never Install" nil) + (const :tag "Always Install" t) + (const :tag "Ask Me" ask))) + +(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. + +(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus (defcustom gnus-registry-clean-empty t "Whether the empty registry entries should be deleted. @@ -92,11 +153,17 @@ and no extra data." :group 'gnus-registry :type 'boolean) -(defcustom gnus-registry-use-long-group-names nil - "Whether the registry should use long group names (BUGGY)." +(defcustom gnus-registry-use-long-group-names t + "Whether the registry should use long group names." :group 'gnus-registry :type 'boolean) +(defcustom gnus-registry-max-track-groups 20 + "The maximum number of non-unique group matches to check for a message ID." + :group 'gnus-registry + :type '(radio (const :format "Unlimited " nil) + (integer :format "Maximum non-unique matches: %v"))) + (defcustom gnus-registry-track-extra nil "Whether the registry should track extra data about a message. The Subject and Sender (From:) headers are currently tracked this @@ -107,6 +174,17 @@ way." (const :tag "Track by subject (Subject: header)" subject) (const :tag "Track by sender (From: header)" sender))) +(defcustom gnus-registry-split-strategy nil + "Whether the registry should track extra data about a message. +The Subject and Sender (From:) headers are currently tracked this +way." + :group 'gnus-registry + :type + '(choice :tag "Tracking choices" + (const :tag "Only use single choices, discard multiple matches" nil) + (const :tag "Majority of matches wins" majority) + (const :tag "First found wins" first))) + (defcustom gnus-registry-entry-caching t "Whether the registry should cache extra information." :group 'gnus-registry @@ -122,9 +200,19 @@ way." :group 'gnus-registry :type 'boolean) -(defcustom gnus-registry-cache-file - (nnheader-concat - (or gnus-dribble-directory gnus-home-directory "~/") +(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." + :group 'gnus-registry + :type '(repeat symbol)) + +(defcustom gnus-registry-cache-file + (nnheader-concat + (or gnus-dribble-directory gnus-home-directory "~/") ".gnus.registry.eld") "File where the Gnus registry will be stored." :group 'gnus-registry @@ -151,12 +239,13 @@ way." (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 () "Save the registry cache file." (interactive) (let ((file gnus-registry-cache-file)) - (save-excursion - (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) + (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*") (make-local-variable 'version-control) (setq version-control gnus-backup-startup-file) (setq buffer-file-name file) @@ -167,7 +256,8 @@ way." (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-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) @@ -182,16 +272,15 @@ way." (if (and (eq system-type 'ms-dos) (not (gnus-long-file-names))) "%s#%d.tm#" ; MSDOS limits files to 8+3 - (if (memq system-type '(vax-vms axp-vms)) - "%s$tmp$%d" - "%s#tmp#%d")) + "%s#tmp#%d") working-dir (setq i (1+ i)))) (file-exists-p working-file))) (unwind-protect (progn (gnus-with-output-to-file working-file - (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) + (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 @@ -239,9 +328,12 @@ way." ;; remove empty entries (when gnus-registry-clean-empty (gnus-registry-clean-empty-function)) - ;; now trim the registry appropriately - (setq gnus-registry-alist (gnus-registry-trim - (hashtable-to-alist gnus-registry-hashtb))) + ;; 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) @@ -256,8 +348,8 @@ way." (when (stringp key) (dolist (group (gnus-registry-fetch-groups key)) (when (gnus-parameter-registry-ignore group) - (gnus-message - 10 + (gnus-message + 10 "gnus-registry: deleted ignored group %s from key %s" group key) (gnus-registry-delete-group key group))) @@ -269,77 +361,88 @@ way." (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) - (stringp key)) + (gnus-registry-fetch-extra key 'label)) (incf count) (gnus-registry-delete-id key)) - + (unless (stringp key) - (gnus-message - 10 - "gnus-registry key %s was not a string, removing" + (gnus-message + 10 + "gnus-registry key %s was not a string, removing" key) (gnus-registry-delete-id key)))) - + gnus-registry-hashtb) count)) (defun gnus-registry-read () (gnus-registry-cache-read) - (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) + (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. -Also, drop all gnus-registry-ignored-groups matches." +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 4096 + :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))) + (trim-length (if (natnump trim-length) trim-length 0)) + precious-list junk-list) (maphash (lambda (key value) - (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) + (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 - (nthcdr - trim-length - (sort alist - (lambda (a b) - (time-less-p - (or (cdr (gethash (car a) timehash)) '(0 0 0)) - (or (cdr (gethash (car b) timehash)) '(0 0 0)))))))))) - -(defun alist-to-hashtable (alist) - "Build a hashtable from the values in ALIST." - (let ((ht (make-hash-table - :size 4096 - :test 'equal))) - (mapc - (lambda (kv-pair) - (puthash (car kv-pair) (cdr kv-pair) ht)) - alist) - ht)) - -(defun hashtable-to-alist (hash) - "Build an alist from the values in HASH." - (let ((list nil)) - (maphash - (lambda (key value) - (setq list (cons (cons key value) list))) - hash) - list)) + (setq alist (append precious-list + (nthcdr trim-length junk-list)))))) (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) - (subject (gnus-registry-simplify-subject - (mail-header-subject data-header))) - (sender (mail-header-from 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")) @@ -380,131 +483,235 @@ This function tracks ALL backends, unlike messages. For a message to be split, it looks for the parent message in the -References or In-Reply-To header and then looks in the registry to -see which group that message was put in. This group is returned. +References or In-Reply-To header and then looks in the registry +to see which group that message was put in. This group is +returned, unless `gnus-registry-follow-group-p' return nil for +that group. See the Info node `(gnus)Fancy Mail Splitting' for more details." - (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string - (reply-to (message-fetch-field "in-reply-to")) ; grab reply-to + (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed + (reply-to (message-fetch-field "in-reply-to")) ; may be nil ;; now, if reply-to is valid, append it to the References - (refstr (if reply-to + (refstr (if reply-to (concat refstr " " reply-to) refstr)) - (nnmail-split-fancy-with-parent-ignore-groups - (if (listp nnmail-split-fancy-with-parent-ignore-groups) - nnmail-split-fancy-with-parent-ignore-groups - (list nnmail-split-fancy-with-parent-ignore-groups))) - references res) - ;; the references string must be valid and parse to valid references - (if (and refstr (gnus-extract-references refstr)) - (progn - (setq references (nreverse (gnus-extract-references refstr))) - (mapcar (lambda (x) - (setq res (or (gnus-registry-fetch-group x) res)) - (when (or (gnus-registry-grep-in-list - res - gnus-registry-unfollowed-groups) - (gnus-registry-grep-in-list - res - nnmail-split-fancy-with-parent-ignore-groups)) - (setq res nil))) - references)) - - ;; else: there were no references, now try the extra tracking - (let ((sender (message-fetch-field "from")) - (subject (gnus-registry-simplify-subject - (message-fetch-field "subject"))) - (single-match t)) - (when (and single-match - (gnus-registry-track-sender-p) - sender) - (maphash - (lambda (key value) - (let ((this-sender (cdr - (gnus-registry-fetch-extra key 'sender)))) - (when (and single-match - this-sender - (equal sender this-sender)) - ;; too many matches, bail - (unless (equal res (gnus-registry-fetch-group key)) - (setq single-match nil)) - (setq res (gnus-registry-fetch-group key)) - (when (and sender res) - (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 group %s" - "gnus-registry-split-fancy-with-parent" - sender - res))))) - gnus-registry-hashtb)) - (when (and single-match - (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)))) - (when (and single-match - this-subject - (equal subject this-subject)) - ;; too many matches, bail - (unless (equal res (gnus-registry-fetch-group key)) - (setq single-match nil)) - (setq res (gnus-registry-fetch-group key)) - (when (and subject res) - (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 group %s" - "gnus-registry-split-fancy-with-parent" - subject - res))))) - gnus-registry-hashtb)) - (unless single-match - (gnus-message - 3 - "gnus-registry-split-fancy-with-parent: too many extra matches for %s" - refstr) - (setq res nil)))) - (when (and refstr res) - (gnus-message - 5 - "gnus-registry-split-fancy-with-parent traced %s to group %s" - refstr res)) - - (when (and res gnus-registry-use-long-group-names) - (let ((m1 (gnus-find-method-for-group res)) - (m2 (or gnus-command-method - (gnus-find-method-for-group gnus-newsgroup-name))) - (short-res (gnus-group-short-name res))) - (if (gnus-methods-equal-p m1 m2) - (progn + ;; 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) + + ;; 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 - 9 - "gnus-registry-split-fancy-with-parent stripped group %s to %s" - res - short-res) - (setq res short-res)) - ;; else... + 7 + "%s traced the reference %s from [%s] to group %s" + log-agent reference refstr group) + (push group found)))) + ;; filter the found groups and return them + ;; the found groups are the full groups + (setq found (gnus-registry-post-process-groups + "references" refstr found 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) + (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) + (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) + ;; 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))) + + ;; 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) + (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) + ;; 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)))) + ;; 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. + +MODE can be 'subject' or 'sender' for example. The KEY is the +value by which MODE was searched. + +Transforms each group name to the equivalent short name. + +Checks if the current Gnus method (from `gnus-command-method' or +from `gnus-newsgroup-name') is the same as the group's method. +This is not possible if gnus-registry-use-long-group-names is +false. Foreign methods are not supported so they are rejected. + +Reduces the list to a single group, or complains if that's not +possible. Uses `gnus-registry-split-strategy' and GROUPS-FULL if +necessary." + (let ((log-agent "gnus-registry-post-process-group") + out) + + ;; the strategy can be 'first, 'majority, or nil + (when (eq gnus-registry-split-strategy 'first) + (when groups + (setq groups (list (car-safe groups))))) + + (when (eq gnus-registry-split-strategy 'majority) + (let ((freq (make-hash-table + :size 256 + :test 'equal))) + (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full) + (setq groups (list (car-safe + (sort + groups + (lambda (a b) + (> (gethash a freq 0) + (gethash b freq 0))))))))) + + (if gnus-registry-use-long-group-names + (dolist (group groups) + (let ((m1 (gnus-find-method-for-group group)) + (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 - 7 - "gnus-registry-split-fancy-with-parent ignored foreign group %s" - res) - (setq res nil)))) - res)) + 5 + "%s: too many extra matches (%s) for %s %s. Returning none." + log-agent out mode key) + (setq out nil)) + out)) + +(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)))) + +(defun gnus-registry-wash-for-keywords (&optional force) + (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))))) + +(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)) (defun gnus-registry-register-message-ids () "Register the Message-ID of every article in the group" (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) (dolist (article gnus-newsgroup-articles) (let ((id (gnus-registry-fetch-message-id-fast article))) - (unless (gnus-registry-fetch-group id) + (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 - (gnus-registry-fetch-message-id-fast article) + id gnus-newsgroup-name (gnus-registry-fetch-simplified-message-subject-fast article) (gnus-registry-fetch-sender-fast article))))))) @@ -525,27 +732,216 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." "Fetch the Subject quickly, using the internal gnus-data-list function" (if (and (numberp article) (assoc article (gnus-data-list nil))) - (gnus-registry-simplify-subject - (mail-header-subject (gnus-data-header - (assoc article (gnus-data-list nil))))) + (gnus-string-remove-all-properties + (gnus-registry-simplify-subject + (mail-header-subject (gnus-data-header + (assoc article (gnus-data-list nil)))))) nil)) (defun gnus-registry-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))) - (mail-header-from (gnus-data-header - (assoc article (gnus-data-list nil)))) + (gnus-string-remove-all-properties + (mail-header-from (gnus-data-header + (assoc article (gnus-data-list nil))))) nil)) -(defun gnus-registry-grep-in-list (word list) - (when word - (memq nil - (mapcar 'not - (mapcar - (lambda (x) - (string-match x word)) - list))))) +(defun gnus-registry-do-marks (type function) + "For each known mark, call FUNCTION for each cell of type TYPE. + +FUNCTION should take two parameters, a mark symbol and the cell value." + (dolist (mark-info gnus-registry-marks) + (let* ((mark (car-safe mark-info)) + (data (cdr-safe mark-info)) + (cell-data (plist-get data type))) + (when cell-data + (funcall function mark cell-data))))) + +;;; this is ugly code, but I don't know how to do it better +(defun gnus-registry-install-shortcuts () + "Install the keyboard shortcuts and menus for the registry. +Uses `gnus-registry-marks' to find what shortcuts to install." + (let (keys-plist) + (setq gnus-registry-misc-menus nil) + (gnus-registry-do-marks + :char + (lambda (mark data) + (let ((function-format + (format "gnus-registry-%%s-article-%s-mark" mark))) + +;;; The following generates these functions: +;;; (defun gnus-registry-set-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) +;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) +;;; "Apply the Important mark to process-marked ARTICLES." +;;; (interactive (gnus-summary-work-articles current-prefix-arg)) +;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) + + (dolist (remove '(t nil)) + (let* ((variant-name (if remove "remove" "set")) + (function-name (format function-format variant-name)) + (shortcut (format "%c" data)) + (shortcut (if remove (upcase shortcut) shortcut))) + (unintern function-name obarray) + (eval + `(defun + ;; function name + ,(intern function-name) + ;; parameter definition + (&rest articles) + ;; documentation + ,(format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark) + ;; interactive definition + (interactive + (gnus-summary-work-articles current-prefix-arg)) + ;; actual code + + ;; if this is called and the user doesn't want the + ;; registry enabled, we'll ask anyhow + (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)))))) + +;;; 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)))) + +(defun gnus-registry-read-mark () + "Read a mark name from the user with completion." + (let ((mark (gnus-completing-read + "Label" + (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + nil nil nil + (symbol-name gnus-registry-default-mark)))) + (when (stringp mark) + (intern mark)))) + +(defun gnus-registry-set-article-mark (&rest articles) + "Apply a mark to process-marked ARTICLES." + (interactive (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t)) + +(defun gnus-registry-remove-article-mark (&rest articles) + "Remove a mark from process-marked ARTICLES." + (interactive (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t)) + +(defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message) + "Apply a mark to a list of ARTICLES." + (let ((article-id-list + (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))))) + +(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)))) + (when (interactive-p) + (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. @@ -604,11 +1000,20 @@ The message must have at least one group name." 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)) - (alist (cons (cons key value) - (gnus-assq-delete-all key (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) @@ -623,20 +1028,22 @@ Returns the first place where the trail finds a group name." crumb (gnus-group-short-name crumb)))))))) -(defun gnus-registry-fetch-groups (id) - "Get the groups of a message, based on the message ID." +(defun gnus-registry-fetch-groups (id &optional max) + "Get the groups (up to MAX, if given) of a message, based on the message ID." (let ((trail (gethash id gnus-registry-hashtb)) groups) (dolist (crumb trail) (when (stringp crumb) ;; push the group name into the list - (setq + (setq groups (cons (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) crumb (gnus-group-short-name crumb)) - groups)))) + groups)) + (when (and max (> (length groups) max)) + (return)))) ;; return the list of groups groups)) @@ -713,14 +1120,19 @@ Returns the first place where the trail finds a group name." "Clear the Gnus registry." (interactive) (setq gnus-registry-alist nil) - (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) + (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) (setq gnus-registry-dirty t)) ;;;###autoload (defun gnus-registry-initialize () +"Initialize the Gnus registry." (interactive) - (setq gnus-registry-install t) + (gnus-message 5 "Initializing the registry") + (setq gnus-registry-install t) ; in case it was 'ask or nil (gnus-registry-install-hooks) + (gnus-registry-install-shortcuts) + (when (featurep 'nnregistry) + (gnus-registry-install-nnregistry)) (gnus-registry-read)) ;;;###autoload @@ -737,6 +1149,21 @@ Returns the first place where the trail finds a group name." (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) +;;;###autoload +(defun gnus-registry-install-nnregistry () + "Install the nnregistry refer method in `gnus-refer-article-method'." + (interactive) + (cond ((eq 'nnregistry gnus-refer-article-method)) + ((null gnus-refer-article-method) + (setq gnus-refer-article-method 'nnregistry)) + ((consp gnus-refer-article-method) + (unless (memq 'nnregistry gnus-refer-article-method) + (setq gnus-refer-article-method + (append gnus-refer-article-method '(nnregistry))))) + (t + (setq gnus-refer-article-method + (list gnus-refer-article-method 'nnregistry))))) + (defun gnus-registry-unload-hook () "Uninstall the registry hooks." (interactive) @@ -752,13 +1179,22 @@ Returns the first place where the trail finds a group name." (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) -(when gnus-registry-install - (gnus-registry-install-hooks) - (gnus-registry-read)) - -;; TODO: a lot of things +(defun gnus-registry-install-p () + (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. "))) + (when gnus-registry-install + ;; we just set gnus-registry-install to t, so initialize the registry! + (gnus-registry-initialize))) +;;; we could call it here: (customize-variable 'gnus-registry-install) + gnus-registry-install) + +;; TODO: a few things (provide 'gnus-registry) -;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 ;;; gnus-registry.el ends here