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