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