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