cgit.sxemacs.org Git - gnus/blob - lisp/gnus-registry.el

   1 ;;; gnus-registry.el --- article registry for Gnus
   2
   3 ;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4 ;;; Free Software Foundation, Inc.
   5
   6 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   7 ;; Keywords: news registry
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This is the gnus-registry.el package, which works with all
  27 ;; backends, not just nnmail (e.g. NNTP).  The major issue is that it
  28 ;; doesn't go across backends, so for instance if an article is in
  29 ;; nnml:sys and you see a reference to it in nnimap splitting, the
  30 ;; article will end up in nnimap:sys
  31
  32 ;; gnus-registry.el intercepts article respooling, moving, deleting,
  33 ;; and copying for all backends.  If it doesn't work correctly for
  34 ;; you, submit a bug report and I'll be glad to fix it.  It needs
  35 ;; documentation in the manual (also on my to-do list).
  36
  37 ;; Put this in your startup file (~/.gnus.el for instance)
  38
  39 ;; (setq gnus-registry-max-entries 2500
  40 ;;       gnus-registry-use-long-group-names t)
  41
  42 ;; (gnus-registry-initialize)
  43
  44 ;; Then use this in your fancy-split:
  45
  46 ;; (: gnus-registry-split-fancy-with-parent)
  47
  48 ;; TODO:
  49
  50 ;; - get the correct group on spool actions
  51
  52 ;; - articles that are spooled to a different backend should be handled
  53
  54 ;;; Code:
  55
  56 (eval-when-compile (require 'cl))
  57
  58 (require 'gnus)
  59 (require 'gnus-int)
  60 (require 'gnus-sum)
  61 (require 'gnus-util)
  62 (require 'nnmail)
  63 (require 'easymenu)
  64
  65 (defvar gnus-adaptive-word-syntax-table)
  66
  67 (defvar gnus-registry-dirty t
  68  "Boolean set to t when the registry is modified")
  69
  70 (defgroup gnus-registry nil
  71   "The Gnus registry."
  72   :version "22.1"
  73   :group 'gnus)
  74
  75 (defvar gnus-registry-hashtb (make-hash-table
  76                               :size 256
  77                               :test 'equal)
  78   "*The article registry by Message ID.")
  79
  80 (defcustom gnus-registry-marks
  81   '((Important
  82      :char ?i
  83      :image "summary_important")
  84     (Work
  85      :char ?w
  86      :image "summary_work")
  87     (Personal
  88      :char ?p
  89      :image "summary_personal")
  90     (To-Do
  91      :char ?t
  92      :image "summary_todo")
  93     (Later
  94      :char ?l
  95      :image "summary_later"))
  96
  97   "List of registry marks and their options.
  98
  99 `gnus-registry-mark-article' will offer symbols from this list
 100 for completion.
 101
 102 Each entry must have a character to be useful for summary mode
 103 line display and for keyboard shortcuts.
 104
 105 Each entry must have an image string to be useful for visual
 106 display."
 107   :group 'gnus-registry
 108   :type '(repeat :tag "Registry Marks"
 109                  (cons :tag "Mark"
 110                        (symbol :tag "Name")
 111                        (checklist :tag "Options" :greedy t
 112                                   (group :inline t
 113                                          (const :format "" :value :char)
 114                                          (character :tag "Character code"))
 115                                   (group :inline t
 116                                          (const :format "" :value :image)
 117                                          (string :tag "Image"))))))
 118
 119 (defcustom gnus-registry-default-mark 'To-Do
 120   "The default mark.  Should be a valid key for `gnus-registry-marks'."
 121   :group 'gnus-registry
 122   :type 'symbol)
 123
 124 (defcustom gnus-registry-unfollowed-groups
 125   '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:")
 126   "List of groups that gnus-registry-split-fancy-with-parent won't return.
 127 The group names are matched, they don't have to be fully
 128 qualified.  This parameter tells the Registry 'never split a
 129 message into a group that matches one of these, regardless of
 130 references.'
 131
 132 nnmairix groups are specifically excluded because they are ephemeral."
 133   :group 'gnus-registry
 134   :type '(repeat regexp))
 135
 136 (defcustom gnus-registry-install 'ask
 137   "Whether the registry should be installed."
 138   :group 'gnus-registry
 139   :type '(choice (const :tag "Never Install" nil)
 140                  (const :tag "Always Install" t)
 141                  (const :tag "Ask Me" ask)))
 142
 143 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
 144
 145 (defvar gnus-registry-misc-menus nil)   ; ugly way to keep the menus
 146
 147 (defcustom gnus-registry-clean-empty t
 148   "Whether the empty registry entries should be deleted.
 149 Registry entries are considered empty when they have no groups
 150 and no extra data."
 151   :group 'gnus-registry
 152   :type 'boolean)
 153
 154 (defcustom gnus-registry-use-long-group-names t
 155   "Whether the registry should use long group names."
 156   :group 'gnus-registry
 157   :type 'boolean)
 158
 159 (defcustom gnus-registry-max-track-groups 20
 160   "The maximum number of non-unique group matches to check for a message ID."
 161   :group 'gnus-registry
 162   :type '(radio (const :format "Unlimited " nil)
 163                 (integer :format "Maximum non-unique matches: %v")))
 164
 165 (defcustom gnus-registry-track-extra nil
 166   "Whether the registry should track extra data about a message.
 167 The Subject and Sender (From:) headers are currently tracked this
 168 way."
 169   :group 'gnus-registry
 170   :type
 171   '(set :tag "Tracking choices"
 172     (const :tag "Track by subject (Subject: header)" subject)
 173     (const :tag "Track by sender (From: header)"  sender)))
 174
 175 (defcustom gnus-registry-split-strategy nil
 176   "Whether the registry should track extra data about a message.
 177 The Subject and Sender (From:) headers are currently tracked this
 178 way."
 179   :group 'gnus-registry
 180   :type
 181   '(choice :tag "Tracking choices"
 182            (const :tag "Only use single choices, discard multiple matches" nil)
 183            (const :tag "Majority of matches wins" majority)
 184            (const :tag "First found wins"  first)))
 185
 186 (defcustom gnus-registry-entry-caching t
 187   "Whether the registry should cache extra information."
 188   :group 'gnus-registry
 189   :type 'boolean)
 190
 191 (defcustom gnus-registry-minimum-subject-length 5
 192   "The minimum length of a subject before it's considered trackable."
 193   :group 'gnus-registry
 194   :type 'integer)
 195
 196 (defcustom gnus-registry-trim-articles-without-groups t
 197   "Whether the registry should clean out message IDs without groups."
 198   :group 'gnus-registry
 199   :type 'boolean)
 200
 201 (defcustom gnus-registry-extra-entries-precious '(marks)
 202   "What extra entries are precious, meaning they won't get trimmed.
 203 When you save the Gnus registry, it's trimmed to be no longer
 204 than `gnus-registry-max-entries' (which is nil by default, so no
 205 trimming happens).  Any entries with extra data in this list (by
 206 default, marks are included, so articles with marks are
 207 considered precious) will not be trimmed."
 208   :group 'gnus-registry
 209   :type '(repeat symbol))
 210
 211 (defcustom gnus-registry-cache-file
 212   (nnheader-concat
 213    (or gnus-dribble-directory gnus-home-directory "~/")
 214    ".gnus.registry.eld")
 215   "File where the Gnus registry will be stored."
 216   :group 'gnus-registry
 217   :type 'file)
 218
 219 (defcustom gnus-registry-max-entries nil
 220   "Maximum number of entries in the registry, nil for unlimited."
 221   :group 'gnus-registry
 222   :type '(radio (const :format "Unlimited " nil)
 223                 (integer :format "Maximum number: %v")))
 224
 225 (defun gnus-registry-track-subject-p ()
 226   (memq 'subject gnus-registry-track-extra))
 227
 228 (defun gnus-registry-track-sender-p ()
 229   (memq 'sender gnus-registry-track-extra))
 230
 231 (defun gnus-registry-cache-read ()
 232   "Read the registry cache file."
 233   (interactive)
 234   (let ((file gnus-registry-cache-file))
 235     (when (file-exists-p file)
 236       (gnus-message 5 "Reading %s..." file)
 237       (gnus-load file)
 238       (gnus-message 5 "Reading %s...done" file))))
 239
 240 ;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in
 241 ;; `gnus-start.el'.  --rsteib
 242 (defun gnus-registry-cache-save ()
 243   "Save the registry cache file."
 244   (interactive)
 245   (let ((file gnus-registry-cache-file))
 246     (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")
 247       (make-local-variable 'version-control)
 248     (setq version-control gnus-backup-startup-file)
 249     (setq buffer-file-name file)
 250     (setq default-directory (file-name-directory buffer-file-name))
 251     (buffer-disable-undo)
 252     (erase-buffer)
 253     (gnus-message 5 "Saving %s..." file)
 254     (if gnus-save-startup-file-via-temp-buffer
 255         (let ((coding-system-for-write gnus-ding-file-coding-system)
 256               (standard-output (current-buffer)))
 257           (gnus-gnus-to-quick-newsrc-format
 258            t "gnus registry startup file" 'gnus-registry-alist)
 259           (gnus-registry-cache-whitespace file)
 260           (save-buffer))
 261       (let ((coding-system-for-write gnus-ding-file-coding-system)
 262             (version-control gnus-backup-startup-file)
 263             (startup-file file)
 264             (working-dir (file-name-directory file))
 265             working-file
 266             (i -1))
 267         ;; Generate the name of a non-existent file.
 268         (while (progn (setq working-file
 269                             (format
 270                              (if (and (eq system-type 'ms-dos)
 271                                       (not (gnus-long-file-names)))
 272                                  "%s#%d.tm#" ; MSDOS limits files to 8+3
 273                                "%s#tmp#%d")
 274                              working-dir (setq i (1+ i))))
 275                       (file-exists-p working-file)))
 276
 277         (unwind-protect
 278             (progn
 279               (gnus-with-output-to-file working-file
 280                 (gnus-gnus-to-quick-newsrc-format
 281                  t "gnus registry startup file" 'gnus-registry-alist))
 282
 283               ;; These bindings will mislead the current buffer
 284               ;; into thinking that it is visiting the startup
 285               ;; file.
 286               (let ((buffer-backed-up nil)
 287                     (buffer-file-name startup-file)
 288                     (file-precious-flag t)
 289                     (setmodes (file-modes startup-file)))
 290                 ;; Backup the current version of the startup file.
 291                 (backup-buffer)
 292
 293                 ;; Replace the existing startup file with the temp file.
 294                 (rename-file working-file startup-file t)
 295                 (gnus-set-file-modes startup-file setmodes)))
 296           (condition-case nil
 297               (delete-file working-file)
 298             (file-error nil)))))
 299
 300     (gnus-kill-buffer (current-buffer))
 301     (gnus-message 5 "Saving %s...done" file))))
 302
 303 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 304 ;; Save the gnus-registry file with extra line breaks.
 305 (defun gnus-registry-cache-whitespace (filename)
 306   (gnus-message 7 "Adding whitespace to %s" filename)
 307   (save-excursion
 308     (goto-char (point-min))
 309     (while (re-search-forward "^(\\|(\\\"" nil t)
 310       (replace-match "\n\\&" t))
 311     (goto-char (point-min))
 312     (while (re-search-forward " $" nil t)
 313       (replace-match "" t t))))
 314
 315 (defun gnus-registry-save (&optional force)
 316   (when (or gnus-registry-dirty force)
 317     (let ((caching gnus-registry-entry-caching))
 318       ;; turn off entry caching, so mtime doesn't get recorded
 319       (setq gnus-registry-entry-caching nil)
 320       ;; remove entry caches
 321       (maphash
 322        (lambda (key value)
 323          (if (hash-table-p value)
 324              (remhash key gnus-registry-hashtb)))
 325        gnus-registry-hashtb)
 326       ;; remove empty entries
 327       (when gnus-registry-clean-empty
 328         (gnus-registry-clean-empty-function))
 329       ;; now trim and clean text properties from the registry appropriately
 330       (setq gnus-registry-alist
 331             (gnus-registry-remove-alist-text-properties
 332              (gnus-registry-trim
 333               (gnus-hashtable-to-alist
 334                gnus-registry-hashtb))))
 335       ;; really save
 336       (gnus-registry-cache-save)
 337       (setq gnus-registry-entry-caching caching)
 338       (setq gnus-registry-dirty nil))))
 339
 340 (defun gnus-registry-clean-empty-function ()
 341   "Remove all empty entries from the registry.  Returns count thereof."
 342   (let ((count 0))
 343
 344     (maphash
 345      (lambda (key value)
 346        (when (stringp key)
 347          (dolist (group (gnus-registry-fetch-groups key))
 348            (when (gnus-parameter-registry-ignore group)
 349              (gnus-message
 350               10
 351               "gnus-registry: deleted ignored group %s from key %s"
 352               group key)
 353              (gnus-registry-delete-group key group)))
 354
 355          (unless (gnus-registry-group-count key)
 356            (gnus-registry-delete-id key))
 357
 358          (unless (or
 359                   (gnus-registry-fetch-group key)
 360                   ;; TODO: look for specific extra data here!
 361                   ;; in this example, we look for 'label
 362                   (gnus-registry-fetch-extra key 'label))
 363            (incf count)
 364            (gnus-registry-delete-id key))
 365
 366          (unless (stringp key)
 367            (gnus-message
 368             10
 369             "gnus-registry key %s was not a string, removing"
 370             key)
 371            (gnus-registry-delete-id key))))
 372
 373      gnus-registry-hashtb)
 374     count))
 375
 376 (defun gnus-registry-read ()
 377   (gnus-registry-cache-read)
 378   (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
 379   (setq gnus-registry-dirty nil))
 380
 381 (defun gnus-registry-remove-alist-text-properties (v)
 382   "Remove text properties from all strings in alist."
 383   (if (stringp v)
 384       (gnus-string-remove-all-properties v)
 385     (if (and (listp v) (listp (cdr v)))
 386         (mapcar 'gnus-registry-remove-alist-text-properties v)
 387       (if (and (listp v) (stringp (cdr v)))
 388           (cons (gnus-registry-remove-alist-text-properties (car v))
 389                 (gnus-registry-remove-alist-text-properties (cdr v)))
 390       v))))
 391
 392 (defun gnus-registry-trim (alist)
 393   "Trim alist to size, using gnus-registry-max-entries.
 394 Any entries with extra data (marks, currently) are left alone."
 395   (if (null gnus-registry-max-entries)
 396       alist                             ; just return the alist
 397     ;; else, when given max-entries, trim the alist
 398     (let* ((timehash (make-hash-table
 399                       :size 20000
 400                       :test 'equal))
 401            (precious (make-hash-table
 402                       :size 20000
 403                       :test 'equal))
 404            (trim-length (- (length alist) gnus-registry-max-entries))
 405            (trim-length (if (natnump trim-length) trim-length 0))
 406            precious-list junk-list)
 407       (maphash
 408        (lambda (key value)
 409          (let ((extra (gnus-registry-fetch-extra key)))
 410            (dolist (item gnus-registry-extra-entries-precious)
 411              (dolist (e extra)
 412                (when (equal (nth 0 e) item)
 413                  (puthash key t precious)
 414                  (return))))
 415            (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)))
 416        gnus-registry-hashtb)
 417
 418       (dolist (item alist)
 419         (let ((key (nth 0 item)))
 420           (if (gethash key precious)
 421               (push item precious-list)
 422             (push item junk-list))))
 423
 424       (sort
 425        junk-list
 426        (lambda (a b)
 427          (let ((t1 (or (cdr (gethash (car a) timehash))
 428                        '(0 0 0)))
 429                (t2 (or (cdr (gethash (car b) timehash))
 430                        '(0 0 0))))
 431            (time-less-p t1 t2))))
 432
 433       ;; we use the return value of this setq, which is the trimmed alist
 434       (setq alist (append precious-list
 435                           (nthcdr trim-length junk-list))))))
 436
 437 (defun gnus-registry-action (action data-header from &optional to method)
 438   (let* ((id (mail-header-id data-header))
 439          (subject (gnus-string-remove-all-properties
 440                    (gnus-registry-simplify-subject
 441                     (mail-header-subject data-header))))
 442          (sender (gnus-string-remove-all-properties
 443                   (mail-header-from data-header)))
 444          (from (gnus-group-guess-full-name-from-command-method from))
 445          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
 446          (to-name (if to to "the Bit Bucket"))
 447          (old-entry (gethash id gnus-registry-hashtb)))
 448     (gnus-message 7 "Registry: article %s %s from %s to %s"
 449                   id
 450                   (if method "respooling" "going")
 451                   from
 452                   to)
 453
 454     ;; All except copy will need a delete
 455     (gnus-registry-delete-group id from)
 456
 457     (when (equal 'copy action)
 458       (gnus-registry-add-group id from subject sender)) ; undo the delete
 459
 460     (gnus-registry-add-group id to subject sender)))
 461
 462 (defun gnus-registry-spool-action (id group &optional subject sender)
 463   (let ((group (gnus-group-guess-full-name-from-command-method group)))
 464     (when (and (stringp id) (string-match "\r$" id))
 465       (setq id (substring id 0 -1)))
 466     (gnus-message 7 "Registry: article %s spooled to %s"
 467                   id
 468                   group)
 469     (gnus-registry-add-group id group subject sender)))
 470
 471 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 472 ;; the cache and if a match is found, return that group.
 473 (defun gnus-registry-split-fancy-with-parent ()
 474   "Split this message into the same group as its parent.  The parent
 475 is obtained from the registry.  This function can be used as an entry
 476 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 477 this: (: gnus-registry-split-fancy-with-parent)
 478
 479 This function tracks ALL backends, unlike
 480 `nnmail-split-fancy-with-parent' which tracks only nnmail
 481 messages.
 482
 483 For a message to be split, it looks for the parent message in the
 484 References or In-Reply-To header and then looks in the registry
 485 to see which group that message was put in.  This group is
 486 returned, unless `gnus-registry-follow-group-p' return nil for
 487 that group.
 488
 489 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 490   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
 491          (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
 492          ;; now, if reply-to is valid, append it to the References
 493          (refstr (if reply-to
 494                      (concat refstr " " reply-to)
 495                    refstr))
 496          ;; these may not be used, but the code is cleaner having them up here
 497          (sender (gnus-string-remove-all-properties
 498                   (message-fetch-field "from")))
 499          (subject (gnus-string-remove-all-properties
 500                    (gnus-registry-simplify-subject
 501                     (message-fetch-field "subject"))))
 502
 503          (nnmail-split-fancy-with-parent-ignore-groups
 504           (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 505               nnmail-split-fancy-with-parent-ignore-groups
 506             (list nnmail-split-fancy-with-parent-ignore-groups)))
 507          (log-agent "gnus-registry-split-fancy-with-parent")
 508          found found-full)
 509
 510     ;; this is a big if-else statement.  it uses
 511     ;; gnus-registry-post-process-groups to filter the results after
 512     ;; every step.
 513     (cond
 514      ;; the references string must be valid and parse to valid references
 515      ((and refstr (gnus-extract-references refstr))
 516       (dolist (reference (nreverse (gnus-extract-references refstr)))
 517         (gnus-message
 518          9
 519          "%s is looking for matches for reference %s from [%s]"
 520          log-agent reference refstr)
 521         (dolist (group (gnus-registry-fetch-groups
 522                         reference
 523                         gnus-registry-max-track-groups))
 524           (when (and group (gnus-registry-follow-group-p group))
 525             (gnus-message
 526              7
 527              "%s traced the reference %s from [%s] to group %s"
 528              log-agent reference refstr group)
 529             (push group found))))
 530       ;; filter the found groups and return them
 531       ;; the found groups are the full groups
 532       (setq found (gnus-registry-post-process-groups
 533                    "references" refstr found found)))
 534
 535      ;; else: there were no matches, now try the extra tracking by sender
 536      ((and (gnus-registry-track-sender-p)
 537            sender
 538            (not (equal (gnus-extract-address-component-email sender)
 539                        user-mail-address)))
 540       (maphash
 541        (lambda (key value)
 542          (let ((this-sender (cdr
 543                              (gnus-registry-fetch-extra key 'sender)))
 544                matches)
 545            (when (and this-sender
 546                       (equal sender this-sender))
 547              (let ((groups (gnus-registry-fetch-groups
 548                             key
 549                             gnus-registry-max-track-groups)))
 550                (dolist (group groups)
 551                  (push group found-full)
 552                  (setq found (append (list group) (delete group found)))))
 553              (push key matches)
 554              (gnus-message
 555               ;; raise level of messaging if gnus-registry-track-extra
 556               (if gnus-registry-track-extra 7 9)
 557               "%s (extra tracking) traced sender %s to groups %s (keys %s)"
 558               log-agent sender found matches))))
 559        gnus-registry-hashtb)
 560       ;; filter the found groups and return them
 561       ;; the found groups are NOT the full groups
 562       (setq found (gnus-registry-post-process-groups
 563                    "sender" sender found found-full)))
 564
 565      ;; else: there were no matches, now try the extra tracking by subject
 566      ((and (gnus-registry-track-subject-p)
 567            subject
 568            (< gnus-registry-minimum-subject-length (length subject)))
 569       (maphash
 570        (lambda (key value)
 571          (let ((this-subject (cdr
 572                               (gnus-registry-fetch-extra key 'subject)))
 573                matches)
 574            (when (and this-subject
 575                       (equal subject this-subject))
 576              (let ((groups (gnus-registry-fetch-groups
 577                             key
 578                             gnus-registry-max-track-groups)))
 579                (dolist (group groups)
 580                  (push group found-full)
 581                  (setq found (append (list group) (delete group found)))))
 582              (push key matches)
 583              (gnus-message
 584               ;; raise level of messaging if gnus-registry-track-extra
 585               (if gnus-registry-track-extra 7 9)
 586               "%s (extra tracking) traced subject %s to groups %s (keys %s)"
 587               log-agent subject found matches))))
 588        gnus-registry-hashtb)
 589       ;; filter the found groups and return them
 590       ;; the found groups are NOT the full groups
 591       (setq found (gnus-registry-post-process-groups
 592                    "subject" subject found found-full))))
 593     ;; after the (cond) we extract the actual value safely
 594     (car-safe found)))
 595
 596 (defun gnus-registry-post-process-groups (mode key groups groups-full)
 597   "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
 598
 599 MODE can be 'subject' or 'sender' for example.  The KEY is the
 600 value by which MODE was searched.
 601
 602 Transforms each group name to the equivalent short name.
 603
 604 Checks if the current Gnus method (from `gnus-command-method' or
 605 from `gnus-newsgroup-name') is the same as the group's method.
 606 This is not possible if gnus-registry-use-long-group-names is
 607 false.  Foreign methods are not supported so they are rejected.
 608
 609 Reduces the list to a single group, or complains if that's not
 610 possible.  Uses `gnus-registry-split-strategy' and GROUPS-FULL if
 611 necessary."
 612   (let ((log-agent "gnus-registry-post-process-group")
 613         out)
 614
 615     ;; the strategy can be 'first, 'majority, or nil
 616     (when (eq gnus-registry-split-strategy 'first)
 617       (when groups
 618         (setq groups (list (car-safe groups)))))
 619
 620     (when (eq gnus-registry-split-strategy 'majority)
 621       (let ((freq (make-hash-table
 622                    :size 256
 623                    :test 'equal)))
 624         (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full)
 625         (setq groups (list (car-safe
 626                             (sort
 627                              groups
 628                              (lambda (a b)
 629                                (> (gethash a freq 0)
 630                                   (gethash b freq 0)))))))))
 631
 632     (if gnus-registry-use-long-group-names
 633         (dolist (group groups)
 634           (let ((m1 (gnus-find-method-for-group group))
 635                 (m2 (or gnus-command-method
 636                         (gnus-find-method-for-group gnus-newsgroup-name)))
 637                 (short-name (gnus-group-short-name group)))
 638             (if (gnus-methods-equal-p m1 m2)
 639                 (progn
 640                   ;; this is REALLY just for debugging
 641                   (gnus-message
 642                    10
 643                    "%s stripped group %s to %s"
 644                    log-agent group short-name)
 645                   (unless (member short-name out)
 646                     (push short-name out)))
 647               ;; else...
 648               (gnus-message
 649                7
 650                "%s ignored foreign group %s"
 651                log-agent group))))
 652       (setq out groups))
 653     (when (cdr-safe out)
 654         (gnus-message
 655          5
 656          "%s: too many extra matches (%s) for %s %s.  Returning none."
 657          log-agent out mode key)
 658         (setq out nil))
 659     out))
 660
 661 (defun gnus-registry-follow-group-p (group)
 662   "Determines if a group name should be followed.
 663 Consults `gnus-registry-unfollowed-groups' and
 664 `nnmail-split-fancy-with-parent-ignore-groups'."
 665   (not (or (gnus-grep-in-list
 666             group
 667             gnus-registry-unfollowed-groups)
 668            (gnus-grep-in-list
 669             group
 670             nnmail-split-fancy-with-parent-ignore-groups))))
 671
 672 (defun gnus-registry-wash-for-keywords (&optional force)
 673   (interactive)
 674   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
 675         word words)
 676     (if (or (not (gnus-registry-fetch-extra id 'keywords))
 677             force)
 678         (with-current-buffer gnus-article-buffer
 679           (article-goto-body)
 680           (save-window-excursion
 681             (save-restriction
 682               (narrow-to-region (point) (point-max))
 683               (with-syntax-table gnus-adaptive-word-syntax-table
 684                 (while (re-search-forward "\\b\\w+\\b" nil t)
 685                   (setq word (gnus-registry-remove-alist-text-properties
 686                               (downcase (buffer-substring
 687                                          (match-beginning 0) (match-end 0)))))
 688                   (if (> (length word) 3)
 689                       (push word words))))))
 690           (gnus-registry-store-extra-entry id 'keywords words)))))
 691
 692 (defun gnus-registry-find-keywords (keyword)
 693   (interactive "skeyword: ")
 694   (let (articles)
 695     (maphash
 696      (lambda (key value)
 697        (when (member keyword
 698                    (cdr-safe (gnus-registry-fetch-extra key 'keywords)))
 699          (push key articles)))
 700      gnus-registry-hashtb)
 701     articles))
 702
 703 (defun gnus-registry-register-message-ids ()
 704   "Register the Message-ID of every article in the group"
 705   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 706     (dolist (article gnus-newsgroup-articles)
 707       (let ((id (gnus-registry-fetch-message-id-fast article)))
 708         (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id))
 709           (gnus-message 9 "Registry: Registering article %d with group %s"
 710                         article gnus-newsgroup-name)
 711           (gnus-registry-add-group
 712            id
 713            gnus-newsgroup-name
 714            (gnus-registry-fetch-simplified-message-subject-fast article)
 715            (gnus-registry-fetch-sender-fast article)))))))
 716
 717 (defun gnus-registry-fetch-message-id-fast (article)
 718   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 719   (if (and (numberp article)
 720            (assoc article (gnus-data-list nil)))
 721       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 722     nil))
 723
 724 (defun gnus-registry-simplify-subject (subject)
 725   (if (stringp subject)
 726       (gnus-simplify-subject subject)
 727     nil))
 728
 729 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 730   "Fetch the Subject quickly, using the internal gnus-data-list function"
 731   (if (and (numberp article)
 732            (assoc article (gnus-data-list nil)))
 733       (gnus-string-remove-all-properties
 734        (gnus-registry-simplify-subject
 735         (mail-header-subject (gnus-data-header
 736                               (assoc article (gnus-data-list nil))))))
 737     nil))
 738
 739 (defun gnus-registry-fetch-sender-fast (article)
 740   "Fetch the Sender quickly, using the internal gnus-data-list function"
 741   (if (and (numberp article)
 742            (assoc article (gnus-data-list nil)))
 743       (gnus-string-remove-all-properties
 744        (mail-header-from (gnus-data-header
 745                           (assoc article (gnus-data-list nil)))))
 746     nil))
 747
 748 (defun gnus-registry-do-marks (type function)
 749   "For each known mark, call FUNCTION for each cell of type TYPE.
 750
 751 FUNCTION should take two parameters, a mark symbol and the cell value."
 752   (dolist (mark-info gnus-registry-marks)
 753     (let* ((mark (car-safe mark-info))
 754            (data (cdr-safe mark-info))
 755            (cell-data (plist-get data type)))
 756       (when cell-data
 757         (funcall function mark cell-data)))))
 758
 759 ;;; this is ugly code, but I don't know how to do it better
 760 (defun gnus-registry-install-shortcuts ()
 761   "Install the keyboard shortcuts and menus for the registry.
 762 Uses `gnus-registry-marks' to find what shortcuts to install."
 763   (let (keys-plist)
 764     (setq gnus-registry-misc-menus nil)
 765     (gnus-registry-do-marks
 766      :char
 767      (lambda (mark data)
 768        (let ((function-format
 769               (format "gnus-registry-%%s-article-%s-mark" mark)))
 770
 771 ;;; The following generates these functions:
 772 ;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
 773 ;;;   "Apply the Important mark to process-marked ARTICLES."
 774 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 775 ;;;   (gnus-registry-set-article-mark-internal 'Important articles nil t))
 776 ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
 777 ;;;   "Apply the Important mark to process-marked ARTICLES."
 778 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 779 ;;;   (gnus-registry-set-article-mark-internal 'Important articles t t))
 780
 781          (dolist (remove '(t nil))
 782            (let* ((variant-name (if remove "remove" "set"))
 783                   (function-name (format function-format variant-name))
 784                   (shortcut (format "%c" data))
 785                   (shortcut (if remove (upcase shortcut) shortcut)))
 786              (unintern function-name obarray)
 787              (eval
 788               `(defun
 789                  ;; function name
 790                  ,(intern function-name)
 791                  ;; parameter definition
 792                  (&rest articles)
 793                  ;; documentation
 794                  ,(format
 795                    "%s the %s mark over process-marked ARTICLES."
 796                    (upcase-initials variant-name)
 797                    mark)
 798                  ;; interactive definition
 799                  (interactive
 800                   (gnus-summary-work-articles current-prefix-arg))
 801                  ;; actual code
 802
 803                  ;; if this is called and the user doesn't want the
 804                  ;; registry enabled, we'll ask anyhow
 805                  (when (eq gnus-registry-install nil)
 806                    (setq gnus-registry-install 'ask))
 807
 808                  ;; now the user is asked if gnus-registry-install is 'ask
 809                  (when (gnus-registry-install-p)
 810                    (gnus-registry-set-article-mark-internal
 811                     ;; all this just to get the mark, I must be doing it wrong
 812                     (intern ,(symbol-name mark))
 813                     articles ,remove t)
 814                    (gnus-message
 815                     9
 816                     "Applying mark %s to %d articles"
 817                     ,(symbol-name mark) (length articles))
 818                    (dolist (article articles)
 819                      (gnus-summary-update-article
 820                       article
 821                       (assoc article (gnus-data-list nil)))))))
 822              (push (intern function-name) keys-plist)
 823              (push shortcut keys-plist)
 824              (push (vector (format "%s %s"
 825                                    (upcase-initials variant-name)
 826                                    (symbol-name mark))
 827                            (intern function-name) t)
 828                    gnus-registry-misc-menus)
 829              (gnus-message
 830               9
 831               "Defined mark handling function %s"
 832               function-name))))))
 833     (gnus-define-keys-1
 834      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
 835      keys-plist)
 836     (add-hook 'gnus-summary-menu-hook
 837               (lambda ()
 838                 (easy-menu-add-item
 839                  gnus-summary-misc-menu
 840                  nil
 841                  (cons "Registry Marks" gnus-registry-misc-menus))))))
 842
 843 ;;; use like this:
 844 ;;; (defalias 'gnus-user-format-function-M
 845 ;;;           'gnus-registry-user-format-function-M)
 846 (defun gnus-registry-user-format-function-M (headers)
 847   (let* ((id (mail-header-message-id headers))
 848          (marks (when id (gnus-registry-fetch-extra-marks id))))
 849     (apply 'concat (mapcar (lambda(mark)
 850                              (let ((c
 851                                     (plist-get
 852                                      (cdr-safe
 853                                       (assoc mark gnus-registry-marks))
 854                                      :char)))
 855                                (if c
 856                                    (list c)
 857                                  nil)))
 858                            marks))))
 859
 860 (defun gnus-registry-read-mark ()
 861   "Read a mark name from the user with completion."
 862   (let ((mark (gnus-completing-read
 863                "Label"
 864                (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
 865                nil nil nil
 866                (symbol-name gnus-registry-default-mark))))
 867     (when (stringp mark)
 868       (intern mark))))
 869
 870 (defun gnus-registry-set-article-mark (&rest articles)
 871   "Apply a mark to process-marked ARTICLES."
 872   (interactive (gnus-summary-work-articles current-prefix-arg))
 873   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t))
 874
 875 (defun gnus-registry-remove-article-mark (&rest articles)
 876   "Remove a mark from process-marked ARTICLES."
 877   (interactive (gnus-summary-work-articles current-prefix-arg))
 878   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t))
 879
 880 (defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message)
 881   "Apply a mark to a list of ARTICLES."
 882   (let ((article-id-list
 883          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
 884     (dolist (id article-id-list)
 885       (let* (
 886              ;; all the marks for this article without the mark of
 887              ;; interest
 888              (marks
 889               (delq mark (gnus-registry-fetch-extra-marks id)))
 890              ;; the new marks we want to use
 891              (new-marks (if remove
 892                             marks
 893                           (cons mark marks))))
 894         (when show-message
 895           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
 896                         (if remove "Removing" "Adding")
 897                         mark id new-marks))
 898
 899         (apply 'gnus-registry-store-extra-marks ; set the extra marks
 900                id                               ; for the message ID
 901                new-marks)))))
 902
 903 (defun gnus-registry-get-article-marks (&rest articles)
 904   "Get the Gnus registry marks for ARTICLES and show them if interactive.
 905 Uses process/prefix conventions.  For multiple articles,
 906 only the last one's marks are returned."
 907   (interactive (gnus-summary-work-articles 1))
 908   (let (marks)
 909     (dolist (article articles)
 910       (let ((article-id
 911              (gnus-registry-fetch-message-id-fast article)))
 912         (setq marks (gnus-registry-fetch-extra-marks article-id))))
 913     (when (interactive-p)
 914         (gnus-message 1 "Marks are %S" marks))
 915     marks))
 916
 917 ;;; if this extends to more than 'marks, it should be improved to be more generic.
 918 (defun gnus-registry-fetch-extra-marks (id)
 919   "Get the marks of a message, based on the message ID.
 920 Returns a list of symbol marks or nil."
 921   (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
 922
 923 (defun gnus-registry-has-extra-mark (id mark)
 924   "Checks if a message has `mark', based on the message ID `id'."
 925   (memq mark (gnus-registry-fetch-extra-marks id)))
 926
 927 (defun gnus-registry-store-extra-marks (id &rest mark-list)
 928   "Set the marks of a message, based on the message ID.
 929 The `mark-list' can be nil, in which case no marks are left."
 930   (gnus-registry-store-extra-entry id 'marks (list mark-list)))
 931
 932 (defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
 933   "Delete the message marks in `mark-delete-list', based on the message ID."
 934   (let ((marks (gnus-registry-fetch-extra-marks id)))
 935     (when marks
 936       (dolist (mark mark-delete-list)
 937         (setq marks (delq mark marks))))
 938     (gnus-registry-store-extra-marks id (car marks))))
 939
 940 (defun gnus-registry-delete-all-extra-marks (id)
 941   "Delete all the marks for a message ID."
 942   (gnus-registry-store-extra-marks id nil))
 943
 944 (defun gnus-registry-fetch-extra (id &optional entry)
 945   "Get the extra data of a message, based on the message ID.
 946 Returns the first place where the trail finds a nonstring."
 947   (let ((entry-cache (gethash entry gnus-registry-hashtb)))
 948     (if (and entry
 949              (hash-table-p entry-cache)
 950              (gethash id entry-cache))
 951         (gethash id entry-cache)
 952       ;; else, if there is no caching possible...
 953       (let ((trail (gethash id gnus-registry-hashtb)))
 954         (when (listp trail)
 955           (dolist (crumb trail)
 956             (unless (stringp crumb)
 957               (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
 958
 959 (defun gnus-registry-fetch-extra-entry (alist &optional entry id)
 960   "Get the extra data of a message, or a specific entry in it.
 961 Update the entry cache if needed."
 962   (if (and entry id)
 963       (let ((entry-cache (gethash entry gnus-registry-hashtb))
 964             entree)
 965         (when gnus-registry-entry-caching
 966           ;; create the hash table
 967           (unless (hash-table-p entry-cache)
 968             (setq entry-cache (make-hash-table
 969                                :size 4096
 970                                :test 'equal))
 971             (puthash entry entry-cache gnus-registry-hashtb))
 972
 973           ;; get the entree from the hash table or from the alist
 974           (setq entree (gethash id entry-cache)))
 975
 976         (unless entree
 977           (setq entree (assq entry alist))
 978           (when gnus-registry-entry-caching
 979             (puthash id entree entry-cache)))
 980         entree)
 981     alist))
 982
 983 (defun gnus-registry-store-extra (id extra)
 984   "Store the extra data of a message, based on the message ID.
 985 The message must have at least one group name."
 986   (when (gnus-registry-group-count id)
 987     ;; we now know the trail has at least 1 group name, so it's not empty
 988     (let ((trail (gethash id gnus-registry-hashtb))
 989           (old-extra (gnus-registry-fetch-extra id))
 990           entry-cache)
 991       (dolist (crumb trail)
 992         (unless (stringp crumb)
 993           (dolist (entry crumb)
 994             (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
 995           (when entry-cache
 996             (remhash id entry-cache))))
 997       (puthash id (cons extra (delete old-extra trail))
 998                gnus-registry-hashtb)
 999       (setq gnus-registry-dirty t)))))
1000
1001 (defun gnus-registry-delete-extra-entry (id key)
1002   "Delete a specific entry in the extras field of the registry entry for id."
1003   (gnus-registry-store-extra-entry id key nil))
1004
1005 (defun gnus-registry-store-extra-entry (id key value)
1006   "Put a specific entry in the extras field of the registry entry for id."
1007   (let* ((extra (gnus-registry-fetch-extra id))
1008          ;; all the entries except the one for `key'
1009          (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
1010          (alist (if value
1011                     (gnus-registry-remove-alist-text-properties
1012                      (cons (cons key value)
1013                            the-rest))
1014                   the-rest)))
1015     (gnus-registry-store-extra id alist)))
1016
1017 (defun gnus-registry-fetch-group (id)
1018   "Get the group of a message, based on the message ID.
1019 Returns the first place where the trail finds a group name."
1020   (when (gnus-registry-group-count id)
1021     ;; we now know the trail has at least 1 group name
1022     (let ((trail (gethash id gnus-registry-hashtb)))
1023       (dolist (crumb trail)
1024         (when (stringp crumb)
1025           (return (if gnus-registry-use-long-group-names
1026                        crumb
1027                      (gnus-group-short-name crumb))))))))
1028
1029 (defun gnus-registry-fetch-groups (id &optional max)
1030   "Get the groups (up to MAX, if given) of a message, based on the message ID."
1031   (let ((trail (gethash id gnus-registry-hashtb))
1032         groups)
1033     (dolist (crumb trail)
1034       (when (stringp crumb)
1035         ;; push the group name into the list
1036         (setq
1037          groups
1038          (cons
1039           (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
1040               crumb
1041             (gnus-group-short-name crumb))
1042          groups))
1043         (when (and max (> (length groups) max))
1044           (return))))
1045     ;; return the list of groups
1046     groups))
1047
1048 (defun gnus-registry-group-count (id)
1049   "Get the number of groups of a message, based on the message ID."
1050   (let ((trail (gethash id gnus-registry-hashtb)))
1051     (if (and trail (listp trail))
1052         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
1053       0)))
1054
1055 (defun gnus-registry-delete-group (id group)
1056   "Delete a group for a message, based on the message ID."
1057   (when (and group id)
1058       (let ((trail (gethash id gnus-registry-hashtb))
1059             (short-group (gnus-group-short-name group)))
1060         (puthash id (if trail
1061                         (delete short-group (delete group trail))
1062                       nil)
1063                  gnus-registry-hashtb))
1064       ;; now, clear the entry if there are no more groups
1065       (when gnus-registry-trim-articles-without-groups
1066         (unless (gnus-registry-group-count id)
1067           (gnus-registry-delete-id id)))
1068       ;; is this ID still in the registry?
1069       (when (gethash id gnus-registry-hashtb)
1070         (gnus-registry-store-extra-entry id 'mtime (current-time)))))
1071
1072 (defun gnus-registry-delete-id (id)
1073   "Delete a message ID from the registry."
1074   (when (stringp id)
1075     (remhash id gnus-registry-hashtb)
1076     (maphash
1077      (lambda (key value)
1078        (when (hash-table-p value)
1079          (remhash id value)))
1080      gnus-registry-hashtb)))
1081
1082 (defun gnus-registry-add-group (id group &optional subject sender)
1083   "Add a group for a message, based on the message ID."
1084   (when group
1085     (when (and id
1086                (not (string-match "totally-fudged-out-message-id" id)))
1087       (let ((full-group group)
1088             (group (if gnus-registry-use-long-group-names
1089                        group
1090                      (gnus-group-short-name group))))
1091         (gnus-registry-delete-group id group)
1092
1093         (unless gnus-registry-use-long-group-names ;; unnecessary in this case
1094           (gnus-registry-delete-group id full-group))
1095
1096         (let ((trail (gethash id gnus-registry-hashtb)))
1097           (puthash id (if trail
1098                           (cons group trail)
1099                         (list group))
1100                    gnus-registry-hashtb)
1101
1102           (when (and (gnus-registry-track-subject-p)
1103                      subject)
1104             (gnus-registry-store-extra-entry
1105              id
1106              'subject
1107              (gnus-registry-simplify-subject subject)))
1108           (when (and (gnus-registry-track-sender-p)
1109                      sender)
1110             (gnus-registry-store-extra-entry
1111              id
1112              'sender
1113              sender))
1114
1115           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
1116
1117 (defun gnus-registry-clear ()
1118   "Clear the Gnus registry."
1119   (interactive)
1120   (setq gnus-registry-alist nil)
1121   (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
1122   (setq gnus-registry-dirty t))
1123
1124 ;;;###autoload
1125 (defun gnus-registry-initialize ()
1126 "Initialize the Gnus registry."
1127   (interactive)
1128   (gnus-message 5 "Initializing the registry")
1129   (setq gnus-registry-install t)        ; in case it was 'ask or nil
1130   (gnus-registry-install-hooks)
1131   (gnus-registry-install-shortcuts)
1132   (gnus-registry-install-nnregistry)
1133   (gnus-registry-read))
1134
1135 ;;;###autoload
1136 (defun gnus-registry-install-hooks ()
1137   "Install the registry hooks."
1138   (interactive)
1139   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1140   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1141   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1142   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1143
1144   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1145   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1146
1147   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1148
1149 ;;;###autoload
1150 (defun gnus-registry-install-nnregistry ()
1151   "Install the nnregistry refer method in `gnus-refer-article-method'."
1152   (interactive)
1153   (when (featurep 'nnregistry)
1154     (setq gnus-refer-article-method
1155           (delete-dups
1156            (append
1157             (if (listp gnus-refer-article-method)
1158                 gnus-refer-article-method
1159               (list gnus-refer-article-method))
1160             (list 'nnregistry))))))
1161
1162 (defun gnus-registry-unload-hook ()
1163   "Uninstall the registry hooks."
1164   (interactive)
1165   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1166   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1167   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1168   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1169
1170   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1171   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1172
1173   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1174
1175 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
1176
1177 (defun gnus-registry-install-p ()
1178   (interactive)
1179   (when (eq gnus-registry-install 'ask)
1180     (setq gnus-registry-install
1181           (gnus-y-or-n-p
1182            (concat "Enable the Gnus registry?  "
1183                    "See the variable `gnus-registry-install' "
1184                    "to get rid of this query permanently. ")))
1185     (when gnus-registry-install
1186       ;; we just set gnus-registry-install to t, so initialize the registry!
1187       (gnus-registry-initialize)))
1188 ;;; we could call it here: (customize-variable 'gnus-registry-install)
1189   gnus-registry-install)
1190
1191 ;; TODO: a few things
1192
1193 (provide 'gnus-registry)
1194
1195 ;;; gnus-registry.el ends here