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 ;;   2011  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                  (when (and group (gnus-registry-follow-group-p group))
 555                    (push group found-full)
 556                    (setq found (append (list group) (delete group found))))))
 557              (push key matches)
 558              (gnus-message
 559               ;; raise level of messaging if gnus-registry-track-extra
 560               (if gnus-registry-track-extra 7 9)
 561               "%s (extra tracking) traced sender %s to groups %s (keys %s)"
 562               log-agent sender found matches))))
 563        gnus-registry-hashtb)
 564       ;; filter the found groups and return them
 565       ;; the found groups are NOT the full groups
 566       (setq found (gnus-registry-post-process-groups
 567                    "sender" sender found found-full)))
 568
 569      ;; else: there were no matches, now try the extra tracking by subject
 570      ((and (gnus-registry-track-subject-p)
 571            subject
 572            (< gnus-registry-minimum-subject-length (length subject)))
 573       (maphash
 574        (lambda (key value)
 575          (let ((this-subject (cdr
 576                               (gnus-registry-fetch-extra key 'subject)))
 577                matches)
 578            (when (and this-subject
 579                       (equal subject this-subject))
 580              (let ((groups (gnus-registry-fetch-groups
 581                             key
 582                             gnus-registry-max-track-groups)))
 583                (dolist (group groups)
 584                  (when (and group (gnus-registry-follow-group-p group))
 585                    (push group found-full)
 586                    (setq found (append (list group) (delete group found))))))
 587              (push key matches)
 588              (gnus-message
 589               ;; raise level of messaging if gnus-registry-track-extra
 590               (if gnus-registry-track-extra 7 9)
 591               "%s (extra tracking) traced subject %s to groups %s (keys %s)"
 592               log-agent subject found matches))))
 593        gnus-registry-hashtb)
 594       ;; filter the found groups and return them
 595       ;; the found groups are NOT the full groups
 596       (setq found (gnus-registry-post-process-groups
 597                    "subject" subject found found-full))))
 598     ;; after the (cond) we extract the actual value safely
 599     (car-safe found)))
 600
 601 (defun gnus-registry-post-process-groups (mode key groups groups-full)
 602   "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
 603
 604 MODE can be 'subject' or 'sender' for example.  The KEY is the
 605 value by which MODE was searched.
 606
 607 Transforms each group name to the equivalent short name.
 608
 609 Checks if the current Gnus method (from `gnus-command-method' or
 610 from `gnus-newsgroup-name') is the same as the group's method.
 611 This is not possible if gnus-registry-use-long-group-names is
 612 false.  Foreign methods are not supported so they are rejected.
 613
 614 Reduces the list to a single group, or complains if that's not
 615 possible.  Uses `gnus-registry-split-strategy' and GROUPS-FULL if
 616 necessary."
 617   (let ((log-agent "gnus-registry-post-process-group")
 618         out)
 619
 620     ;; the strategy can be 'first, 'majority, or nil
 621     (when (eq gnus-registry-split-strategy 'first)
 622       (when groups
 623         (setq groups (list (car-safe groups)))))
 624
 625     (when (eq gnus-registry-split-strategy 'majority)
 626       (let ((freq (make-hash-table
 627                    :size 256
 628                    :test 'equal)))
 629         (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full)
 630         (setq groups (list (car-safe
 631                             (sort
 632                              groups
 633                              (lambda (a b)
 634                                (> (gethash a freq 0)
 635                                   (gethash b freq 0)))))))))
 636
 637     (if gnus-registry-use-long-group-names
 638         (dolist (group groups)
 639           (let ((m1 (gnus-find-method-for-group group))
 640                 (m2 (or gnus-command-method
 641                         (gnus-find-method-for-group gnus-newsgroup-name)))
 642                 (short-name (gnus-group-short-name group)))
 643             (if (gnus-methods-equal-p m1 m2)
 644                 (progn
 645                   ;; this is REALLY just for debugging
 646                   (gnus-message
 647                    10
 648                    "%s stripped group %s to %s"
 649                    log-agent group short-name)
 650                   (unless (member short-name out)
 651                     (push short-name out)))
 652               ;; else...
 653               (gnus-message
 654                7
 655                "%s ignored foreign group %s"
 656                log-agent group))))
 657       (setq out groups))
 658     (when (cdr-safe out)
 659         (gnus-message
 660          5
 661          "%s: too many extra matches (%s) for %s %s.  Returning none."
 662          log-agent out mode key)
 663         (setq out nil))
 664     out))
 665
 666 (defun gnus-registry-follow-group-p (group)
 667   "Determines if a group name should be followed.
 668 Consults `gnus-registry-unfollowed-groups' and
 669 `nnmail-split-fancy-with-parent-ignore-groups'."
 670   (not (or (gnus-grep-in-list
 671             group
 672             gnus-registry-unfollowed-groups)
 673            (gnus-grep-in-list
 674             group
 675             nnmail-split-fancy-with-parent-ignore-groups))))
 676
 677 (defun gnus-registry-wash-for-keywords (&optional force)
 678   (interactive)
 679   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
 680         word words)
 681     (if (or (not (gnus-registry-fetch-extra id 'keywords))
 682             force)
 683         (with-current-buffer gnus-article-buffer
 684           (article-goto-body)
 685           (save-window-excursion
 686             (save-restriction
 687               (narrow-to-region (point) (point-max))
 688               (with-syntax-table gnus-adaptive-word-syntax-table
 689                 (while (re-search-forward "\\b\\w+\\b" nil t)
 690                   (setq word (gnus-registry-remove-alist-text-properties
 691                               (downcase (buffer-substring
 692                                          (match-beginning 0) (match-end 0)))))
 693                   (if (> (length word) 3)
 694                       (push word words))))))
 695           (gnus-registry-store-extra-entry id 'keywords words)))))
 696
 697 (defun gnus-registry-find-keywords (keyword)
 698   (interactive "skeyword: ")
 699   (let (articles)
 700     (maphash
 701      (lambda (key value)
 702        (when (member keyword
 703                    (cdr-safe (gnus-registry-fetch-extra key 'keywords)))
 704          (push key articles)))
 705      gnus-registry-hashtb)
 706     articles))
 707
 708 (defun gnus-registry-register-message-ids ()
 709   "Register the Message-ID of every article in the group"
 710   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 711     (dolist (article gnus-newsgroup-articles)
 712       (let ((id (gnus-registry-fetch-message-id-fast article)))
 713         (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id))
 714           (gnus-message 9 "Registry: Registering article %d with group %s"
 715                         article gnus-newsgroup-name)
 716           (gnus-registry-add-group
 717            id
 718            gnus-newsgroup-name
 719            (gnus-registry-fetch-simplified-message-subject-fast article)
 720            (gnus-registry-fetch-sender-fast article)))))))
 721
 722 (defun gnus-registry-fetch-message-id-fast (article)
 723   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 724   (if (and (numberp article)
 725            (assoc article (gnus-data-list nil)))
 726       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 727     nil))
 728
 729 (defun gnus-registry-simplify-subject (subject)
 730   (if (stringp subject)
 731       (gnus-simplify-subject subject)
 732     nil))
 733
 734 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
 735   "Fetch the Subject quickly, using the internal gnus-data-list function"
 736   (if (and (numberp article)
 737            (assoc article (gnus-data-list nil)))
 738       (gnus-string-remove-all-properties
 739        (gnus-registry-simplify-subject
 740         (mail-header-subject (gnus-data-header
 741                               (assoc article (gnus-data-list nil))))))
 742     nil))
 743
 744 (defun gnus-registry-fetch-sender-fast (article)
 745   "Fetch the Sender quickly, using the internal gnus-data-list function"
 746   (if (and (numberp article)
 747            (assoc article (gnus-data-list nil)))
 748       (gnus-string-remove-all-properties
 749        (mail-header-from (gnus-data-header
 750                           (assoc article (gnus-data-list nil)))))
 751     nil))
 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     (setq gnus-registry-misc-menus nil)
 770     (gnus-registry-do-marks
 771      :char
 772      (lambda (mark data)
 773        (let ((function-format
 774               (format "gnus-registry-%%s-article-%s-mark" mark)))
 775
 776 ;;; The following generates these functions:
 777 ;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
 778 ;;;   "Apply the Important mark to process-marked ARTICLES."
 779 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 780 ;;;   (gnus-registry-set-article-mark-internal 'Important articles nil t))
 781 ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
 782 ;;;   "Apply the Important mark to process-marked ARTICLES."
 783 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 784 ;;;   (gnus-registry-set-article-mark-internal 'Important articles t t))
 785
 786          (dolist (remove '(t nil))
 787            (let* ((variant-name (if remove "remove" "set"))
 788                   (function-name (format function-format variant-name))
 789                   (shortcut (format "%c" data))
 790                   (shortcut (if remove (upcase shortcut) shortcut)))
 791              (unintern function-name obarray)
 792              (eval
 793               `(defun
 794                  ;; function name
 795                  ,(intern function-name)
 796                  ;; parameter definition
 797                  (&rest articles)
 798                  ;; documentation
 799                  ,(format
 800                    "%s the %s mark over process-marked ARTICLES."
 801                    (upcase-initials variant-name)
 802                    mark)
 803                  ;; interactive definition
 804                  (interactive
 805                   (gnus-summary-work-articles current-prefix-arg))
 806                  ;; actual code
 807
 808                  ;; if this is called and the user doesn't want the
 809                  ;; registry enabled, we'll ask anyhow
 810                  (when (eq gnus-registry-install nil)
 811                    (setq gnus-registry-install 'ask))
 812
 813                  ;; now the user is asked if gnus-registry-install is 'ask
 814                  (when (gnus-registry-install-p)
 815                    (gnus-registry-set-article-mark-internal
 816                     ;; all this just to get the mark, I must be doing it wrong
 817                     (intern ,(symbol-name mark))
 818                     articles ,remove t)
 819                    (gnus-message
 820                     9
 821                     "Applying mark %s to %d articles"
 822                     ,(symbol-name mark) (length articles))
 823                    (dolist (article articles)
 824                      (gnus-summary-update-article
 825                       article
 826                       (assoc article (gnus-data-list nil)))))))
 827              (push (intern function-name) keys-plist)
 828              (push shortcut keys-plist)
 829              (push (vector (format "%s %s"
 830                                    (upcase-initials variant-name)
 831                                    (symbol-name mark))
 832                            (intern function-name) t)
 833                    gnus-registry-misc-menus)
 834              (gnus-message
 835               9
 836               "Defined mark handling function %s"
 837               function-name))))))
 838     (gnus-define-keys-1
 839      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
 840      keys-plist)
 841     (add-hook 'gnus-summary-menu-hook
 842               (lambda ()
 843                 (easy-menu-add-item
 844                  gnus-summary-misc-menu
 845                  nil
 846                  (cons "Registry Marks" gnus-registry-misc-menus))))))
 847
 848 ;;; use like this:
 849 ;;; (defalias 'gnus-user-format-function-M
 850 ;;;           'gnus-registry-user-format-function-M)
 851 (defun gnus-registry-user-format-function-M (headers)
 852   (let* ((id (mail-header-message-id headers))
 853          (marks (when id (gnus-registry-fetch-extra-marks id))))
 854     (apply 'concat (mapcar (lambda(mark)
 855                              (let ((c
 856                                     (plist-get
 857                                      (cdr-safe
 858                                       (assoc mark gnus-registry-marks))
 859                                      :char)))
 860                                (if c
 861                                    (list c)
 862                                  nil)))
 863                            marks))))
 864
 865 (defun gnus-registry-read-mark ()
 866   "Read a mark name from the user with completion."
 867   (let ((mark (gnus-completing-read
 868                "Label"
 869                (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
 870                nil nil nil
 871                (symbol-name gnus-registry-default-mark))))
 872     (when (stringp mark)
 873       (intern mark))))
 874
 875 (defun gnus-registry-set-article-mark (&rest articles)
 876   "Apply a mark to process-marked ARTICLES."
 877   (interactive (gnus-summary-work-articles current-prefix-arg))
 878   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t))
 879
 880 (defun gnus-registry-remove-article-mark (&rest articles)
 881   "Remove a mark from process-marked ARTICLES."
 882   (interactive (gnus-summary-work-articles current-prefix-arg))
 883   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t))
 884
 885 (defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message)
 886   "Apply a mark to a list of ARTICLES."
 887   (let ((article-id-list
 888          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
 889     (dolist (id article-id-list)
 890       (let* (
 891              ;; all the marks for this article without the mark of
 892              ;; interest
 893              (marks
 894               (delq mark (gnus-registry-fetch-extra-marks id)))
 895              ;; the new marks we want to use
 896              (new-marks (if remove
 897                             marks
 898                           (cons mark marks))))
 899         (when show-message
 900           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
 901                         (if remove "Removing" "Adding")
 902                         mark id new-marks))
 903
 904         (apply 'gnus-registry-store-extra-marks ; set the extra marks
 905                id                               ; for the message ID
 906                new-marks)))))
 907
 908 (defun gnus-registry-get-article-marks (&rest articles)
 909   "Get the Gnus registry marks for ARTICLES and show them if interactive.
 910 Uses process/prefix conventions.  For multiple articles,
 911 only the last one's marks are returned."
 912   (interactive (gnus-summary-work-articles 1))
 913   (let (marks)
 914     (dolist (article articles)
 915       (let ((article-id
 916              (gnus-registry-fetch-message-id-fast article)))
 917         (setq marks (gnus-registry-fetch-extra-marks article-id))))
 918     (when (interactive-p)
 919         (gnus-message 1 "Marks are %S" marks))
 920     marks))
 921
 922 ;;; if this extends to more than 'marks, it should be improved to be more generic.
 923 (defun gnus-registry-fetch-extra-marks (id)
 924   "Get the marks of a message, based on the message ID.
 925 Returns a list of symbol marks or nil."
 926   (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
 927
 928 (defun gnus-registry-has-extra-mark (id mark)
 929   "Checks if a message has `mark', based on the message ID `id'."
 930   (memq mark (gnus-registry-fetch-extra-marks id)))
 931
 932 (defun gnus-registry-store-extra-marks (id &rest mark-list)
 933   "Set the marks of a message, based on the message ID.
 934 The `mark-list' can be nil, in which case no marks are left."
 935   (gnus-registry-store-extra-entry id 'marks (list mark-list)))
 936
 937 (defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
 938   "Delete the message marks in `mark-delete-list', based on the message ID."
 939   (let ((marks (gnus-registry-fetch-extra-marks id)))
 940     (when marks
 941       (dolist (mark mark-delete-list)
 942         (setq marks (delq mark marks))))
 943     (gnus-registry-store-extra-marks id (car marks))))
 944
 945 (defun gnus-registry-delete-all-extra-marks (id)
 946   "Delete all the marks for a message ID."
 947   (gnus-registry-store-extra-marks id nil))
 948
 949 (defun gnus-registry-fetch-extra (id &optional entry)
 950   "Get the extra data of a message, based on the message ID.
 951 Returns the first place where the trail finds a nonstring."
 952   (let ((entry-cache (gethash entry gnus-registry-hashtb)))
 953     (if (and entry
 954              (hash-table-p entry-cache)
 955              (gethash id entry-cache))
 956         (gethash id entry-cache)
 957       ;; else, if there is no caching possible...
 958       (let ((trail (gethash id gnus-registry-hashtb)))
 959         (when (listp trail)
 960           (dolist (crumb trail)
 961             (unless (stringp crumb)
 962               (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
 963
 964 (defun gnus-registry-fetch-extra-entry (alist &optional entry id)
 965   "Get the extra data of a message, or a specific entry in it.
 966 Update the entry cache if needed."
 967   (if (and entry id)
 968       (let ((entry-cache (gethash entry gnus-registry-hashtb))
 969             entree)
 970         (when gnus-registry-entry-caching
 971           ;; create the hash table
 972           (unless (hash-table-p entry-cache)
 973             (setq entry-cache (make-hash-table
 974                                :size 4096
 975                                :test 'equal))
 976             (puthash entry entry-cache gnus-registry-hashtb))
 977
 978           ;; get the entree from the hash table or from the alist
 979           (setq entree (gethash id entry-cache)))
 980
 981         (unless entree
 982           (setq entree (assq entry alist))
 983           (when gnus-registry-entry-caching
 984             (puthash id entree entry-cache)))
 985         entree)
 986     alist))
 987
 988 (defun gnus-registry-store-extra (id extra)
 989   "Store the extra data of a message, based on the message ID.
 990 The message must have at least one group name."
 991   (when (gnus-registry-group-count id)
 992     ;; we now know the trail has at least 1 group name, so it's not empty
 993     (let ((trail (gethash id gnus-registry-hashtb))
 994           (old-extra (gnus-registry-fetch-extra id))
 995           entry-cache)
 996       (dolist (crumb trail)
 997         (unless (stringp crumb)
 998           (dolist (entry crumb)
 999             (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
1000           (when entry-cache
1001             (remhash id entry-cache))))
1002       (puthash id (cons extra (delete old-extra trail))
1003                gnus-registry-hashtb)
1004       (setq gnus-registry-dirty t)))))
1005
1006 (defun gnus-registry-delete-extra-entry (id key)
1007   "Delete a specific entry in the extras field of the registry entry for id."
1008   (gnus-registry-store-extra-entry id key nil))
1009
1010 (defun gnus-registry-store-extra-entry (id key value)
1011   "Put a specific entry in the extras field of the registry entry for id."
1012   (let* ((extra (gnus-registry-fetch-extra id))
1013          ;; all the entries except the one for `key'
1014          (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
1015          (alist (if value
1016                     (gnus-registry-remove-alist-text-properties
1017                      (cons (cons key value)
1018                            the-rest))
1019                   the-rest)))
1020     (gnus-registry-store-extra id alist)))
1021
1022 (defun gnus-registry-fetch-group (id)
1023   "Get the group of a message, based on the message ID.
1024 Returns the first place where the trail finds a group name."
1025   (when (gnus-registry-group-count id)
1026     ;; we now know the trail has at least 1 group name
1027     (let ((trail (gethash id gnus-registry-hashtb)))
1028       (dolist (crumb trail)
1029         (when (stringp crumb)
1030           (return (if gnus-registry-use-long-group-names
1031                        crumb
1032                      (gnus-group-short-name crumb))))))))
1033
1034 (defun gnus-registry-fetch-groups (id &optional max)
1035   "Get the groups (up to MAX, if given) of a message, based on the message ID."
1036   (let ((trail (gethash id gnus-registry-hashtb))
1037         groups)
1038     (dolist (crumb trail)
1039       (when (stringp crumb)
1040         ;; push the group name into the list
1041         (setq
1042          groups
1043          (cons
1044           (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
1045               crumb
1046             (gnus-group-short-name crumb))
1047          groups))
1048         (when (and max (> (length groups) max))
1049           (return))))
1050     ;; return the list of groups
1051     groups))
1052
1053 (defun gnus-registry-group-count (id)
1054   "Get the number of groups of a message, based on the message ID."
1055   (let ((trail (gethash id gnus-registry-hashtb)))
1056     (if (and trail (listp trail))
1057         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
1058       0)))
1059
1060 (defun gnus-registry-delete-group (id group)
1061   "Delete a group for a message, based on the message ID."
1062   (when (and group id)
1063       (let ((trail (gethash id gnus-registry-hashtb))
1064             (short-group (gnus-group-short-name group)))
1065         (puthash id (if trail
1066                         (delete short-group (delete group trail))
1067                       nil)
1068                  gnus-registry-hashtb))
1069       ;; now, clear the entry if there are no more groups
1070       (when gnus-registry-trim-articles-without-groups
1071         (unless (gnus-registry-group-count id)
1072           (gnus-registry-delete-id id)))
1073       ;; is this ID still in the registry?
1074       (when (gethash id gnus-registry-hashtb)
1075         (gnus-registry-store-extra-entry id 'mtime (current-time)))))
1076
1077 (defun gnus-registry-delete-id (id)
1078   "Delete a message ID from the registry."
1079   (when (stringp id)
1080     (remhash id gnus-registry-hashtb)
1081     (maphash
1082      (lambda (key value)
1083        (when (hash-table-p value)
1084          (remhash id value)))
1085      gnus-registry-hashtb)))
1086
1087 (defun gnus-registry-add-group (id group &optional subject sender)
1088   "Add a group for a message, based on the message ID."
1089   (when group
1090     (when (and id
1091                (not (string-match "totally-fudged-out-message-id" id)))
1092       (let ((full-group group)
1093             (group (if gnus-registry-use-long-group-names
1094                        group
1095                      (gnus-group-short-name group))))
1096         (gnus-registry-delete-group id group)
1097
1098         (unless gnus-registry-use-long-group-names ;; unnecessary in this case
1099           (gnus-registry-delete-group id full-group))
1100
1101         (let ((trail (gethash id gnus-registry-hashtb)))
1102           (puthash id (if trail
1103                           (cons group trail)
1104                         (list group))
1105                    gnus-registry-hashtb)
1106
1107           (when (and (gnus-registry-track-subject-p)
1108                      subject)
1109             (gnus-registry-store-extra-entry
1110              id
1111              'subject
1112              (gnus-registry-simplify-subject subject)))
1113           (when (and (gnus-registry-track-sender-p)
1114                      sender)
1115             (gnus-registry-store-extra-entry
1116              id
1117              'sender
1118              sender))
1119
1120           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
1121
1122 (defun gnus-registry-clear ()
1123   "Clear the Gnus registry."
1124   (interactive)
1125   (setq gnus-registry-alist nil)
1126   (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
1127   (setq gnus-registry-dirty t))
1128
1129 ;;;###autoload
1130 (defun gnus-registry-initialize ()
1131 "Initialize the Gnus registry."
1132   (interactive)
1133   (gnus-message 5 "Initializing the registry")
1134   (setq gnus-registry-install t)        ; in case it was 'ask or nil
1135   (gnus-registry-install-hooks)
1136   (gnus-registry-install-shortcuts)
1137   (gnus-registry-read))
1138
1139 ;;;###autoload
1140 (defun gnus-registry-install-hooks ()
1141   "Install the registry hooks."
1142   (interactive)
1143   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1144   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1145   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1146   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1147
1148   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1149   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1150
1151   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1152
1153 (defun gnus-registry-unload-hook ()
1154   "Uninstall the registry hooks."
1155   (interactive)
1156   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1157   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1158   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1159   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1160
1161   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1162   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1163
1164   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1165
1166 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
1167
1168 (defun gnus-registry-install-p ()
1169   (interactive)
1170   (when (eq gnus-registry-install 'ask)
1171     (setq gnus-registry-install
1172           (gnus-y-or-n-p
1173            (concat "Enable the Gnus registry?  "
1174                    "See the variable `gnus-registry-install' "
1175                    "to get rid of this query permanently. ")))
1176     (when gnus-registry-install
1177       ;; we just set gnus-registry-install to t, so initialize the registry!
1178       (gnus-registry-initialize)))
1179 ;;; we could call it here: (customize-variable 'gnus-registry-install)
1180   gnus-registry-install)
1181
1182 ;; TODO: a few things
1183
1184 (provide 'gnus-registry)
1185
1186 ;;; gnus-registry.el ends here