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