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

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