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

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