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

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