2004-09-04 13:13:48 +00:00
|
|
|
;;; gnus-registry.el --- article registry for Gnus
|
2005-08-06 19:51:42 +00:00
|
|
|
|
2012-01-05 01:46:05 -08:00
|
|
|
;; Copyright (C) 2002-2012 Free Software Foundation, Inc.
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;; Author: Ted Zlatanov <tzz@lifelogs.com>
|
2008-05-08 09:59:46 +00:00
|
|
|
;; Keywords: news registry
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
|
|
2008-05-06 03:56:49 +00:00
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
2004-09-04 13:13:48 +00:00
|
|
|
;; it under the terms of the GNU General Public License as published by
|
2008-05-06 03:56:49 +00:00
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
;; (at your option) any later version.
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
2008-05-06 03:56:49 +00:00
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
2004-09-04 13:13:48 +00:00
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
2008-05-06 03:56:49 +00:00
|
|
|
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
|
2007-10-28 09:18:39 +00:00
|
|
|
;; This is the gnus-registry.el package, which works with all
|
2011-04-05 22:35:05 +00:00
|
|
|
;; Gnus backends, not just nnmail. The major issue is that it
|
2007-10-28 09:18:39 +00:00
|
|
|
;; doesn't go across backends, so for instance if an article is in
|
|
|
|
|
;; nnml:sys and you see a reference to it in nnimap splitting, the
|
|
|
|
|
;; article will end up in nnimap:sys
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;; gnus-registry.el intercepts article respooling, moving, deleting,
|
|
|
|
|
;; and copying for all backends. If it doesn't work correctly for
|
|
|
|
|
;; you, submit a bug report and I'll be glad to fix it. It needs
|
2011-04-21 22:06:12 +00:00
|
|
|
;; better documentation in the manual (also on my to-do list).
|
|
|
|
|
|
|
|
|
|
;; If you want to track recipients (and you should to make the
|
|
|
|
|
;; gnus-registry splitting work better), you need the To and Cc
|
2011-04-22 00:37:01 +00:00
|
|
|
;; headers collected by Gnus. Note that in more recent Gnus versions
|
|
|
|
|
;; this is already the case: look at `gnus-extra-headers' to be sure.
|
2011-04-21 22:06:12 +00:00
|
|
|
|
|
|
|
|
;; ;;; you may also want Gcc Newsgroups Keywords X-Face
|
|
|
|
|
;; (add-to-list 'gnus-extra-headers 'To)
|
|
|
|
|
;; (add-to-list 'gnus-extra-headers 'Cc)
|
|
|
|
|
;; (setq nnmail-extra-headers gnus-extra-headers)
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-04-14 10:41:00 +00:00
|
|
|
;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-04-14 10:41:00 +00:00
|
|
|
;; (setq gnus-registry-max-entries 2500
|
2011-04-16 06:56:17 +00:00
|
|
|
;; gnus-registry-track-extra '(sender subject recipient))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;; (gnus-registry-initialize)
|
|
|
|
|
|
|
|
|
|
;; Then use this in your fancy-split:
|
|
|
|
|
|
|
|
|
|
;; (: gnus-registry-split-fancy-with-parent)
|
|
|
|
|
|
2010-10-08 23:55:33 +00:00
|
|
|
;; You should also consider using the nnregistry backend to look up
|
|
|
|
|
;; articles. See the Gnus manual for more information.
|
|
|
|
|
|
2011-05-18 22:16:26 +00:00
|
|
|
;; Finally, you can put %uM in your summary line format to show the
|
|
|
|
|
;; registry marks if you do this:
|
|
|
|
|
|
|
|
|
|
;; show the marks as single characters (see the :char property in
|
|
|
|
|
;; `gnus-registry-marks'):
|
2011-05-31 22:08:51 +00:00
|
|
|
;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
|
2011-05-18 22:16:26 +00:00
|
|
|
|
|
|
|
|
;; show the marks by name (see `gnus-registry-marks'):
|
2011-05-31 22:08:51 +00:00
|
|
|
;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
|
2011-05-18 22:16:26 +00:00
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
;; TODO:
|
|
|
|
|
|
|
|
|
|
;; - get the correct group on spool actions
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
;; - articles that are spooled to a different backend should be moved
|
|
|
|
|
;; after splitting
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
(eval-when-compile (require 'cl))
|
|
|
|
|
|
2011-04-06 12:55:49 +00:00
|
|
|
(eval-when-compile
|
2011-04-06 22:08:31 +00:00
|
|
|
(when (null (ignore-errors (require 'ert)))
|
2011-04-06 12:55:49 +00:00
|
|
|
(defmacro* ert-deftest (name () &body docstring-keys-and-body))))
|
|
|
|
|
|
2011-04-06 22:08:31 +00:00
|
|
|
(ignore-errors
|
|
|
|
|
(require 'ert))
|
2004-09-04 13:13:48 +00:00
|
|
|
(require 'gnus)
|
|
|
|
|
(require 'gnus-int)
|
|
|
|
|
(require 'gnus-sum)
|
2011-04-05 22:35:05 +00:00
|
|
|
(require 'gnus-art)
|
2006-10-07 01:51:54 +00:00
|
|
|
(require 'gnus-util)
|
2004-09-04 13:13:48 +00:00
|
|
|
(require 'nnmail)
|
Synch with Gnus trunk
=====================
2010-03-23 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (canlock-verify): Autoload it for Emacs 21.
* message.el (ecomplete-setup): Autoload it for Emacs <23.
* mml-sec.el (mml-secure-cache-passphrase): Default to t that is
password-cache's default if it is not bound.
(mml-secure-passphrase-cache-expiry): Default to 16 that is
password-cache-expiry's default if it is not bound.
* pop3.el (pop3-list): Don't use 3rd arg of `split-string' which is not
available in Emacs 21.
2010-03-23 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el (auth-sources): Fix up definition so extra parameters
are always inline.
2010-03-22 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-verify-uidvalidity): Fixed bug where uidvalidity
wasn't updated after mismatch. Clear cached mailbox info correctly
when uidvalidity changes.
(nnimap-group-prefixed-name): New function to avoid some code
duplication.
(nnimap-verify-uidvalidity, nnimap-group-overview-filename)
(nnimap-request-group): Use it.
(nnimap-retrieve-groups, nnimap-verify-uidvalidity)
(nnimap-update-unseen): Significantly improved speed of Gnus startup
with many imap folders. This is done by caching the group status from
the imap server persistently in a group parameter `imap-status'. (This
was cached before too if `nnimap-retrieve-groups-asynchronous' was set,
but not persistently, so every Gnus startup was still very slow.)
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el: Set up autoloads. Bump to 23.2 because of the
secrets.el dependency.
(auth-sources): Add optional user name. Add secrets.el configuration
choice (unused right now).
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* gnus-sum.el (gnus-summary-make-menu-bar): Let
`gnus-registry-install-shortcuts' fill in the functions.
* gnus-registry.el (gnus-summary-misc-menu): Declare to avoid
warnings.
(gnus-registry-misc-menus): Variable to hold registry mark menus.
(gnus-registry-install-shortcuts): Populate and use it in a
`gnus-summary-menu-hook' lambda, under "Gnus"->"Registry Marks".
2010-03-20 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-decode-group-name, nnimap-encode-group-name):
In-place substitutions for the group name encoding/decoding.
(nnimap-find-minmax-uid, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-request-article-part)
(nnimap-update-unseen, nnimap-request-list)
(nnimap-retrieve-groups, nnimap-request-update-info-internal)
(nnimap-request-set-mark, nnimap-split-to-groups)
(nnimap-split-articles, nnimap-request-newgroups)
(nnimap-request-create-group, nnimap-request-accept-article)
(nnimap-request-delete-group, nnimap-request-rename-group)
(nnimap-acl-get, nnimap-acl-edit): Use them. Replace `mbx' with
`encoded-mbx' for consistency.
(nnimap-close-group): Call `imap-current-mailbox' instead of using the
variable `imap-current-mailbox'.
* gnus-agent.el (gnus-agent-fetch-articles, gnus-agent-fetch-headers)
(gnus-agent-regenerate-group): Use `gnus-agent-decoded-group-name'.
2010-03-20 Bojan Petrovic <bpetrovi@f.bg.ac.rs>
* pop3.el (pop3-display-message-size-flag): Display message size byte
counts during POP3 download.
(pop3-movemail): Use it.
(pop3-list): Implement listing of available messages.
2010-03-20 Mark Triggs <mst@dishevelled.net> (tiny change)
* nnir.el (nnir-get-article-nov-override-function): New function to
override the normal NOV retrieval.
(nnir-retrieve-headers): Use it.
2010-03-23 07:37:09 +00:00
|
|
|
(require 'easymenu)
|
2011-04-05 22:35:05 +00:00
|
|
|
(require 'registry)
|
2004-09-04 13:13:48 +00:00
|
|
|
|
* smime.el (from):
* rfc2047.el (message-posting-charset):
* qp.el (mm-use-ultra-safe-encoding):
* pop3.el (parse-time-months):
* nnrss.el (mm-text-html-renderer, mm-text-html-washer-alist):
* nnml.el (files):
* nnheader.el (gnus-newsgroup-name, nnheader-file-coding-system)
(jka-compr-compression-info-list, ange-ftp-path-format)
(efs-path-regexp):
* nndiary.el (files):
* mml2015.el (mc-default-scheme, mc-schemes, pgg-default-user-id)
(pgg-errors-buffer, pgg-output-buffer, epg-user-id-alist)
(epg-digest-algorithm-alist, inhibit-redisplay)
(password-cache-expiry):
* mml1991.el (pgg-default-user-id, pgg-errors-buffer)
(pgg-output-buffer, password-cache-expiry):
* mml.el (mml-dnd-protocol-alist, ange-ftp-name-format)
(efs-path-regexp):
* mml-smime.el (epg-user-id-alist, epg-digest-algorithm-alist)
(inhibit-redisplay):
* mm-uu.el (file-name, start-point, end-point, entry)
(gnus-newsgroup-name, gnus-newsgroup-charset):
* mm-util.el (mm-mime-mule-charset-alist, latin-unity-coding-systems)
(latin-unity-ucs-list):
* mm-bodies.el (mm-uu-yenc-decode-function, mm-uu-decode-function)
(mm-uu-binhex-decode-function):
* message.el (gnus-message-group-art, gnus-list-identifiers, )
(rmail-enable-mime-composing, gnus-local-organization)
(gnus-post-method, gnus-select-method, gnus-active-hashtb)
(gnus-read-active-file, facemenu-add-face-function)
(facemenu-remove-face-function, gnus-article-decoded-p)
(tool-bar-mode):
* mail-source.el (display-time-mail-function):
* gnus-util.el (nnmail-pathname-coding-system)
(nnmail-active-file-coding-system, gnus-emphasize-whitespace-regexp)
(gnus-original-article-buffer, gnus-user-agent)
(rmail-default-rmail-file, mm-text-coding-system, tool-bar-mode)
(xemacs-codename, sxemacs-codename, emacs-program-version):
* gnus-sum.el (tool-bar-mode, gnus-tmp-header, number):
* gnus-start.el (gnus-agent-covered-methods)
(gnus-agent-file-loading-local, gnus-agent-file-loading-cache)
(gnus-current-headers, gnus-thread-indent-array, gnus-newsgroup-name)
(gnus-newsgroup-headers, gnus-group-list-mode)
(gnus-group-mark-positions, gnus-newsgroup-data)
(gnus-newsgroup-unreads, nnoo-state-alist)
(gnus-current-select-method, mail-sources)
(nnmail-scan-directory-mail-source-once, nnmail-split-history)
(nnmail-spool-file, gnus-cache-active-hashtb):
* gnus-mh.el (mh-lib-progs):
* gnus-ems.el (gnus-tmp-unread, gnus-tmp-replied)
(gnus-tmp-score-char, gnus-tmp-indentation, gnus-tmp-opening-bracket)
(gnus-tmp-lines, gnus-tmp-name, gnus-tmp-closing-bracket)
(gnus-tmp-subject-or-nil, gnus-check-before-posting, gnus-mouse-face)
(gnus-group-buffer):
* gnus-cite.el (font-lock-defaults-computed, font-lock-keywords)
(font-lock-set-defaults):
* gnus-art.el (tool-bar-map, w3m-minor-mode-map)
(gnus-face-properties-alist, charset, gnus-summary-article-menu)
(gnus-summary-post-menu, total-parts, type, condition, length):
* gnus-agent.el (gnus-agent-read-agentview):
* flow-fill.el (show-trailing-whitespace):
* gnus-group.el (tool-bar-mode, nnrss-group-alist): Remove unnecessary
eval-and-compile wrappers for byte compiler pacifiers.
* mm-view.el (mm-inline-image-xemacs): Only do something for XEmacs.
(mm-display-inline-fontify): Check for featurep 'xemacs not
extent-list.
* mm-decode.el (mm-display-external): Check for featurep 'xemacs not
itimer-list.
(mm-create-image-xemacs): Only do something for XEmacs.
(mm-image-fit-p): Check for featurep 'xemacs not glyph-width.
* mm-util.el (mm-find-buffer-file-coding-system): Add check for XEmacs.
* gnus-registry.el (gnus-adaptive-word-syntax-table):
* gnus-fun.el (gnus-face-properties-alist): Pacify byte compiler.
* textmodes/reftex-dcr.el (reftex-start-itimer-once): Add check
for XEmacs.
* calc/calc-menu.el (calc-mode-map): Pacify byte compiler.
* doc-view.el (doc-view-resolution): Add missing :group.
2007-11-16 16:50:35 +00:00
|
|
|
(defvar gnus-adaptive-word-syntax-table)
|
|
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
(defvar gnus-registry-dirty t
|
|
|
|
|
"Boolean set to t when the registry is modified")
|
|
|
|
|
|
|
|
|
|
(defgroup gnus-registry nil
|
|
|
|
|
"The Gnus registry."
|
2005-02-09 15:50:47 +00:00
|
|
|
:version "22.1"
|
2004-09-04 13:13:48 +00:00
|
|
|
:group 'gnus)
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defvar gnus-registry-marks
|
2008-03-01 01:28:14 +00:00
|
|
|
'((Important
|
2008-03-10 00:50:22 +00:00
|
|
|
:char ?i
|
|
|
|
|
:image "summary_important")
|
2008-03-01 01:28:14 +00:00
|
|
|
(Work
|
2008-03-10 00:50:22 +00:00
|
|
|
:char ?w
|
|
|
|
|
:image "summary_work")
|
2008-03-01 01:28:14 +00:00
|
|
|
(Personal
|
2008-03-10 00:50:22 +00:00
|
|
|
:char ?p
|
|
|
|
|
:image "summary_personal")
|
2008-03-01 01:28:14 +00:00
|
|
|
(To-Do
|
2008-03-10 00:50:22 +00:00
|
|
|
:char ?t
|
|
|
|
|
:image "summary_todo")
|
2008-03-01 01:28:14 +00:00
|
|
|
(Later
|
2008-03-10 00:50:22 +00:00
|
|
|
:char ?l
|
|
|
|
|
:image "summary_later"))
|
2008-03-01 01:28:14 +00:00
|
|
|
|
|
|
|
|
"List of registry marks and their options.
|
|
|
|
|
|
|
|
|
|
`gnus-registry-mark-article' will offer symbols from this list
|
2010-09-02 01:42:32 +00:00
|
|
|
for completion.
|
2008-03-01 01:28:14 +00:00
|
|
|
|
|
|
|
|
Each entry must have a character to be useful for summary mode
|
|
|
|
|
line display and for keyboard shortcuts.
|
|
|
|
|
|
|
|
|
|
Each entry must have an image string to be useful for visual
|
2011-04-05 22:35:05 +00:00
|
|
|
display.")
|
2008-01-20 05:17:57 +00:00
|
|
|
|
|
|
|
|
(defcustom gnus-registry-default-mark 'To-Do
|
2008-03-01 01:28:14 +00:00
|
|
|
"The default mark. Should be a valid key for `gnus-registry-marks'."
|
2008-01-20 05:17:57 +00:00
|
|
|
:group 'gnus-registry
|
|
|
|
|
:type 'symbol)
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defcustom gnus-registry-unfollowed-addresses
|
|
|
|
|
(list (regexp-quote user-mail-address))
|
|
|
|
|
"List of addresses that gnus-registry-split-fancy-with-parent won't trace.
|
2011-04-16 06:56:17 +00:00
|
|
|
The addresses are matched, they don't have to be fully qualified.
|
|
|
|
|
In the messages, these addresses can be the sender or the
|
|
|
|
|
recipients."
|
Add missing :version tags to new defgroups and defcustoms
* window.el (window-sides-slots):
* tool-bar.el (tool-bar-position):
* term/xterm.el (xterm-extra-capabilities):
* ses.el (ses-self-reference-early-detection):
* progmodes/verilog-mode.el (verilog-auto-declare-nettype)
(verilog-auto-wire-type)
(verilog-auto-delete-trailing-whitespace)
(verilog-auto-reset-blocking-in-non, verilog-auto-inst-sort)
(verilog-auto-tieoff-declaration):
* progmodes/sql.el (sql-login-hook, sql-ansi-statement-starters)
(sql-oracle-statement-starters, sql-oracle-scan-on):
* progmodes/prolog.el (prolog-align-comments-flag)
(prolog-indent-mline-comments-flag, prolog-object-end-to-0-flag)
(prolog-left-indent-regexp, prolog-paren-indent-p)
(prolog-paren-indent, prolog-parse-mode, prolog-keywords)
(prolog-types, prolog-mode-specificators)
(prolog-determinism-specificators, prolog-directives)
(prolog-electric-newline-flag, prolog-hungry-delete-key-flag)
(prolog-electric-dot-flag)
(prolog-electric-dot-full-predicate-template)
(prolog-electric-underscore-flag, prolog-electric-tab-flag)
(prolog-electric-if-then-else-flag, prolog-electric-colon-flag)
(prolog-electric-dash-flag, prolog-old-sicstus-keys-flag)
(prolog-program-switches, prolog-prompt-regexp)
(prolog-debug-on-string, prolog-debug-off-string)
(prolog-trace-on-string, prolog-trace-off-string)
(prolog-zip-on-string, prolog-zip-off-string)
(prolog-use-standard-consult-compile-method-flag)
(prolog-use-prolog-tokenizer-flag, prolog-imenu-flag)
(prolog-imenu-max-lines, prolog-info-predicate-index)
(prolog-underscore-wordchar-flag, prolog-use-sicstus-sd)
(prolog-char-quote-workaround):
* progmodes/cc-vars.el (c-defun-tactic):
* net/tramp.el (tramp-encoding-command-interactive)
(tramp-local-end-of-line):
* net/soap-client.el (soap-client):
* net/netrc.el (netrc-file):
* net/gnutls.el (gnutls):
* minibuffer.el (completion-category-overrides)
(completion-cycle-threshold)
(completion-pcm-complete-word-inserts-delimiters):
* man.el (Man-name-local-regexp):
* mail/feedmail.el (feedmail-display-full-frame):
* international/characters.el (glyphless-char-display-control):
* eshell/em-ls.el (eshell-ls-date-format):
* emacs-lisp/cl-indent.el (lisp-lambda-list-keyword-alignment)
(lisp-lambda-list-keyword-parameter-indentation)
(lisp-lambda-list-keyword-parameter-alignment):
* doc-view.el (doc-view-image-width, doc-view-unoconv-program):
* dired-x.el (dired-omit-verbose):
* cus-theme.el (custom-theme-allow-multiple-selections):
* calc/calc.el (calc-highlight-selections-with-faces)
(calc-lu-field-reference, calc-lu-power-reference)
(calc-note-threshold):
* battery.el (battery-mode-line-limit):
* arc-mode.el (archive-7z-extract, archive-7z-expunge)
(archive-7z-update):
* allout.el (allout-prefixed-keybindings)
(allout-unprefixed-keybindings)
(allout-inhibit-auto-fill-on-headline)
(allout-flattened-numbering-abbreviation):
* allout-widgets.el (allout-widgets-auto-activation)
(allout-widgets-icons-dark-subdir)
(allout-widgets-icons-light-subdir, allout-widgets-icon-types)
(allout-widgets-theme-dark-background)
(allout-widgets-theme-light-background)
(allout-widgets-item-image-properties-emacs)
(allout-widgets-item-image-properties-xemacs)
(allout-widgets-run-unit-tests-on-load)
(allout-widgets-time-decoration-activity)
(allout-widgets-hook-error-post-time)
(allout-widgets-track-decoration):
* gnus/sieve-manage.el (sieve-manage-default-stream):
* gnus/shr.el (shr):
* gnus/nnir.el (nnir-ignored-newsgroups, nnir-summary-line-format)
(nnir-retrieve-headers-override-function)
(nnir-imap-default-search-key, nnir-notmuch-program)
(nnir-notmuch-additional-switches, nnir-notmuch-remove-prefix)
(nnir-method-default-engines):
* gnus/message.el (message-cite-reply-position):
* gnus/gssapi.el (gssapi-program):
* gnus/gravatar.el (gravatar):
* gnus/gnus-sum.el (gnus-refer-thread-use-nnir):
* gnus/gnus-registry.el (gnus-registry-unfollowed-addresses)
(gnus-registry-max-pruned-entries):
* gnus/gnus-picon.el (gnus-picon-inhibit-top-level-domains):
* gnus/gnus-int.el (gnus-after-set-mark-hook)
(gnus-before-update-mark-hook):
* gnus/gnus-async.el (gnus-async-post-fetch-function):
* gnus/auth-source.el (auth-source-cache-expiry):
Add missing :version tags to new defcustoms and defgroups.
2012-02-11 14:13:29 -08:00
|
|
|
:version "24.1"
|
2011-04-05 22:35:05 +00:00
|
|
|
:group 'gnus-registry
|
|
|
|
|
:type '(repeat regexp))
|
|
|
|
|
|
2010-09-02 01:42:32 +00:00
|
|
|
(defcustom gnus-registry-unfollowed-groups
|
2011-03-30 14:59:42 +00:00
|
|
|
'("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
|
2007-10-28 09:18:39 +00:00
|
|
|
"List of groups that gnus-registry-split-fancy-with-parent won't return.
|
|
|
|
|
The group names are matched, they don't have to be fully
|
2011-04-05 22:35:05 +00:00
|
|
|
qualified. This parameter tells the Gnus registry 'never split a
|
2007-10-28 09:18:39 +00:00
|
|
|
message into a group that matches one of these, regardless of
|
2010-10-01 00:25:50 +00:00
|
|
|
references.'
|
|
|
|
|
|
|
|
|
|
nnmairix groups are specifically excluded because they are ephemeral."
|
2004-09-04 13:13:48 +00:00
|
|
|
:group 'gnus-registry
|
2007-10-28 09:18:39 +00:00
|
|
|
:type '(repeat regexp))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2008-03-10 00:50:22 +00:00
|
|
|
(defcustom gnus-registry-install 'ask
|
2004-09-04 13:13:48 +00:00
|
|
|
"Whether the registry should be installed."
|
|
|
|
|
:group 'gnus-registry
|
2008-03-10 00:50:22 +00:00
|
|
|
:type '(choice (const :tag "Never Install" nil)
|
2011-04-05 22:35:05 +00:00
|
|
|
(const :tag "Always Install" t)
|
|
|
|
|
(const :tag "Ask Me" ask)))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-10-31 22:11:23 +00:00
|
|
|
(defvar gnus-registry-enabled nil)
|
2011-10-17 22:51:37 +00:00
|
|
|
|
Synch with Gnus trunk
=====================
2010-03-23 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (canlock-verify): Autoload it for Emacs 21.
* message.el (ecomplete-setup): Autoload it for Emacs <23.
* mml-sec.el (mml-secure-cache-passphrase): Default to t that is
password-cache's default if it is not bound.
(mml-secure-passphrase-cache-expiry): Default to 16 that is
password-cache-expiry's default if it is not bound.
* pop3.el (pop3-list): Don't use 3rd arg of `split-string' which is not
available in Emacs 21.
2010-03-23 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el (auth-sources): Fix up definition so extra parameters
are always inline.
2010-03-22 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-verify-uidvalidity): Fixed bug where uidvalidity
wasn't updated after mismatch. Clear cached mailbox info correctly
when uidvalidity changes.
(nnimap-group-prefixed-name): New function to avoid some code
duplication.
(nnimap-verify-uidvalidity, nnimap-group-overview-filename)
(nnimap-request-group): Use it.
(nnimap-retrieve-groups, nnimap-verify-uidvalidity)
(nnimap-update-unseen): Significantly improved speed of Gnus startup
with many imap folders. This is done by caching the group status from
the imap server persistently in a group parameter `imap-status'. (This
was cached before too if `nnimap-retrieve-groups-asynchronous' was set,
but not persistently, so every Gnus startup was still very slow.)
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el: Set up autoloads. Bump to 23.2 because of the
secrets.el dependency.
(auth-sources): Add optional user name. Add secrets.el configuration
choice (unused right now).
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* gnus-sum.el (gnus-summary-make-menu-bar): Let
`gnus-registry-install-shortcuts' fill in the functions.
* gnus-registry.el (gnus-summary-misc-menu): Declare to avoid
warnings.
(gnus-registry-misc-menus): Variable to hold registry mark menus.
(gnus-registry-install-shortcuts): Populate and use it in a
`gnus-summary-menu-hook' lambda, under "Gnus"->"Registry Marks".
2010-03-20 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-decode-group-name, nnimap-encode-group-name):
In-place substitutions for the group name encoding/decoding.
(nnimap-find-minmax-uid, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-request-article-part)
(nnimap-update-unseen, nnimap-request-list)
(nnimap-retrieve-groups, nnimap-request-update-info-internal)
(nnimap-request-set-mark, nnimap-split-to-groups)
(nnimap-split-articles, nnimap-request-newgroups)
(nnimap-request-create-group, nnimap-request-accept-article)
(nnimap-request-delete-group, nnimap-request-rename-group)
(nnimap-acl-get, nnimap-acl-edit): Use them. Replace `mbx' with
`encoded-mbx' for consistency.
(nnimap-close-group): Call `imap-current-mailbox' instead of using the
variable `imap-current-mailbox'.
* gnus-agent.el (gnus-agent-fetch-articles, gnus-agent-fetch-headers)
(gnus-agent-regenerate-group): Use `gnus-agent-decoded-group-name'.
2010-03-20 Bojan Petrovic <bpetrovi@f.bg.ac.rs>
* pop3.el (pop3-display-message-size-flag): Display message size byte
counts during POP3 download.
(pop3-movemail): Use it.
(pop3-list): Implement listing of available messages.
2010-03-20 Mark Triggs <mst@dishevelled.net> (tiny change)
* nnir.el (nnir-get-article-nov-override-function): New function to
override the normal NOV retrieval.
(nnir-retrieve-headers): Use it.
2010-03-23 07:37:09 +00:00
|
|
|
(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
|
|
|
|
|
(make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
|
|
|
|
|
(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
|
|
|
|
|
(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
|
|
|
|
|
(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
|
2008-08-31 10:43:43 +00:00
|
|
|
|
2011-04-16 06:56:17 +00:00
|
|
|
(defcustom gnus-registry-track-extra '(subject sender recipient)
|
2004-09-04 13:13:48 +00:00
|
|
|
"Whether the registry should track extra data about a message.
|
2011-04-16 06:56:17 +00:00
|
|
|
The subject, recipients (To: and Cc:), and Sender (From:) headers
|
|
|
|
|
are tracked this way by default."
|
2004-09-04 13:13:48 +00:00
|
|
|
:group 'gnus-registry
|
2005-02-09 15:50:47 +00:00
|
|
|
:type
|
2004-09-04 13:13:48 +00:00
|
|
|
'(set :tag "Tracking choices"
|
|
|
|
|
(const :tag "Track by subject (Subject: header)" subject)
|
2011-04-16 06:56:17 +00:00
|
|
|
(const :tag "Track by recipient (To: and Cc: headers)" recipient)
|
2004-09-04 13:13:48 +00:00
|
|
|
(const :tag "Track by sender (From: header)" sender)))
|
|
|
|
|
|
2008-04-26 04:29:42 +00:00
|
|
|
(defcustom gnus-registry-split-strategy nil
|
2011-04-05 22:35:05 +00:00
|
|
|
"The splitting strategy applied to the keys in `gnus-registry-track-extra'.
|
2008-04-26 04:29:42 +00:00
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
Given a set of unique found groups G and counts for each element
|
|
|
|
|
of G, and a key K (typically 'sender or 'subject):
|
|
|
|
|
|
|
|
|
|
When nil, if G has only one element, use it. Otherwise give up.
|
|
|
|
|
This is the fastest but also least useful strategy.
|
|
|
|
|
|
|
|
|
|
When 'majority, use the majority by count. So if there is a
|
|
|
|
|
group with the most articles counted by K, use that. Ties are
|
|
|
|
|
resolved in no particular order, simply the first one found wins.
|
|
|
|
|
This is the slowest strategy but also the most accurate one.
|
|
|
|
|
|
|
|
|
|
When 'first, the first element of G wins. This is fast and
|
|
|
|
|
should be OK if your senders and subjects don't \"bleed\" across
|
|
|
|
|
groups."
|
2004-09-04 13:13:48 +00:00
|
|
|
:group 'gnus-registry
|
2011-04-05 22:35:05 +00:00
|
|
|
:type
|
|
|
|
|
'(choice :tag "Splitting strategy"
|
|
|
|
|
(const :tag "Only use single choices, discard multiple matches" nil)
|
|
|
|
|
(const :tag "Majority of matches wins" majority)
|
|
|
|
|
(const :tag "First found wins" first)))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
(defcustom gnus-registry-minimum-subject-length 5
|
|
|
|
|
"The minimum length of a subject before it's considered trackable."
|
|
|
|
|
:group 'gnus-registry
|
|
|
|
|
:type 'integer)
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defcustom gnus-registry-extra-entries-precious '(mark)
|
|
|
|
|
"What extra keys are precious, meaning entries with them won't get pruned.
|
|
|
|
|
By default, 'mark is included, so articles with marks are
|
|
|
|
|
considered precious.
|
|
|
|
|
|
|
|
|
|
Before you save the Gnus registry, it's pruned. Any entries with
|
|
|
|
|
keys in this list will not be pruned. All other entries go to
|
|
|
|
|
the Bit Bucket."
|
2008-01-20 05:17:57 +00:00
|
|
|
:group 'gnus-registry
|
|
|
|
|
:type '(repeat symbol))
|
|
|
|
|
|
2010-09-02 01:42:32 +00:00
|
|
|
(defcustom gnus-registry-cache-file
|
|
|
|
|
(nnheader-concat
|
|
|
|
|
(or gnus-dribble-directory gnus-home-directory "~/")
|
2011-04-05 22:35:05 +00:00
|
|
|
".gnus.registry.eioio")
|
2004-09-04 13:13:48 +00:00
|
|
|
"File where the Gnus registry will be stored."
|
|
|
|
|
:group 'gnus-registry
|
|
|
|
|
:type 'file)
|
|
|
|
|
|
|
|
|
|
(defcustom gnus-registry-max-entries nil
|
|
|
|
|
"Maximum number of entries in the registry, nil for unlimited."
|
|
|
|
|
:group 'gnus-registry
|
|
|
|
|
:type '(radio (const :format "Unlimited " nil)
|
2011-04-05 22:35:05 +00:00
|
|
|
(integer :format "Maximum number: %v")))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defcustom gnus-registry-max-pruned-entries nil
|
|
|
|
|
"Maximum number of pruned entries in the registry, nil for unlimited."
|
Add missing :version tags to new defgroups and defcustoms
* window.el (window-sides-slots):
* tool-bar.el (tool-bar-position):
* term/xterm.el (xterm-extra-capabilities):
* ses.el (ses-self-reference-early-detection):
* progmodes/verilog-mode.el (verilog-auto-declare-nettype)
(verilog-auto-wire-type)
(verilog-auto-delete-trailing-whitespace)
(verilog-auto-reset-blocking-in-non, verilog-auto-inst-sort)
(verilog-auto-tieoff-declaration):
* progmodes/sql.el (sql-login-hook, sql-ansi-statement-starters)
(sql-oracle-statement-starters, sql-oracle-scan-on):
* progmodes/prolog.el (prolog-align-comments-flag)
(prolog-indent-mline-comments-flag, prolog-object-end-to-0-flag)
(prolog-left-indent-regexp, prolog-paren-indent-p)
(prolog-paren-indent, prolog-parse-mode, prolog-keywords)
(prolog-types, prolog-mode-specificators)
(prolog-determinism-specificators, prolog-directives)
(prolog-electric-newline-flag, prolog-hungry-delete-key-flag)
(prolog-electric-dot-flag)
(prolog-electric-dot-full-predicate-template)
(prolog-electric-underscore-flag, prolog-electric-tab-flag)
(prolog-electric-if-then-else-flag, prolog-electric-colon-flag)
(prolog-electric-dash-flag, prolog-old-sicstus-keys-flag)
(prolog-program-switches, prolog-prompt-regexp)
(prolog-debug-on-string, prolog-debug-off-string)
(prolog-trace-on-string, prolog-trace-off-string)
(prolog-zip-on-string, prolog-zip-off-string)
(prolog-use-standard-consult-compile-method-flag)
(prolog-use-prolog-tokenizer-flag, prolog-imenu-flag)
(prolog-imenu-max-lines, prolog-info-predicate-index)
(prolog-underscore-wordchar-flag, prolog-use-sicstus-sd)
(prolog-char-quote-workaround):
* progmodes/cc-vars.el (c-defun-tactic):
* net/tramp.el (tramp-encoding-command-interactive)
(tramp-local-end-of-line):
* net/soap-client.el (soap-client):
* net/netrc.el (netrc-file):
* net/gnutls.el (gnutls):
* minibuffer.el (completion-category-overrides)
(completion-cycle-threshold)
(completion-pcm-complete-word-inserts-delimiters):
* man.el (Man-name-local-regexp):
* mail/feedmail.el (feedmail-display-full-frame):
* international/characters.el (glyphless-char-display-control):
* eshell/em-ls.el (eshell-ls-date-format):
* emacs-lisp/cl-indent.el (lisp-lambda-list-keyword-alignment)
(lisp-lambda-list-keyword-parameter-indentation)
(lisp-lambda-list-keyword-parameter-alignment):
* doc-view.el (doc-view-image-width, doc-view-unoconv-program):
* dired-x.el (dired-omit-verbose):
* cus-theme.el (custom-theme-allow-multiple-selections):
* calc/calc.el (calc-highlight-selections-with-faces)
(calc-lu-field-reference, calc-lu-power-reference)
(calc-note-threshold):
* battery.el (battery-mode-line-limit):
* arc-mode.el (archive-7z-extract, archive-7z-expunge)
(archive-7z-update):
* allout.el (allout-prefixed-keybindings)
(allout-unprefixed-keybindings)
(allout-inhibit-auto-fill-on-headline)
(allout-flattened-numbering-abbreviation):
* allout-widgets.el (allout-widgets-auto-activation)
(allout-widgets-icons-dark-subdir)
(allout-widgets-icons-light-subdir, allout-widgets-icon-types)
(allout-widgets-theme-dark-background)
(allout-widgets-theme-light-background)
(allout-widgets-item-image-properties-emacs)
(allout-widgets-item-image-properties-xemacs)
(allout-widgets-run-unit-tests-on-load)
(allout-widgets-time-decoration-activity)
(allout-widgets-hook-error-post-time)
(allout-widgets-track-decoration):
* gnus/sieve-manage.el (sieve-manage-default-stream):
* gnus/shr.el (shr):
* gnus/nnir.el (nnir-ignored-newsgroups, nnir-summary-line-format)
(nnir-retrieve-headers-override-function)
(nnir-imap-default-search-key, nnir-notmuch-program)
(nnir-notmuch-additional-switches, nnir-notmuch-remove-prefix)
(nnir-method-default-engines):
* gnus/message.el (message-cite-reply-position):
* gnus/gssapi.el (gssapi-program):
* gnus/gravatar.el (gravatar):
* gnus/gnus-sum.el (gnus-refer-thread-use-nnir):
* gnus/gnus-registry.el (gnus-registry-unfollowed-addresses)
(gnus-registry-max-pruned-entries):
* gnus/gnus-picon.el (gnus-picon-inhibit-top-level-domains):
* gnus/gnus-int.el (gnus-after-set-mark-hook)
(gnus-before-update-mark-hook):
* gnus/gnus-async.el (gnus-async-post-fetch-function):
* gnus/auth-source.el (auth-source-cache-expiry):
Add missing :version tags to new defcustoms and defgroups.
2012-02-11 14:13:29 -08:00
|
|
|
:version "24.1"
|
2011-04-05 22:35:05 +00:00
|
|
|
:group 'gnus-registry
|
|
|
|
|
:type '(radio (const :format "Unlimited " nil)
|
|
|
|
|
(integer :format "Maximum number: %v")))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-fixup-registry (db)
|
|
|
|
|
(when db
|
2011-04-16 06:56:17 +00:00
|
|
|
(let ((old (oref db :tracked)))
|
|
|
|
|
(oset db :precious
|
|
|
|
|
(append gnus-registry-extra-entries-precious
|
|
|
|
|
'()))
|
|
|
|
|
(oset db :max-hard
|
|
|
|
|
(or gnus-registry-max-entries
|
|
|
|
|
most-positive-fixnum))
|
2011-05-13 04:12:37 +00:00
|
|
|
(oset db :prune-factor
|
|
|
|
|
0.1)
|
2011-04-16 06:56:17 +00:00
|
|
|
(oset db :max-soft
|
|
|
|
|
(or gnus-registry-max-pruned-entries
|
|
|
|
|
most-positive-fixnum))
|
|
|
|
|
(oset db :tracked
|
|
|
|
|
(append gnus-registry-track-extra
|
|
|
|
|
'(mark group keyword)))
|
|
|
|
|
(when (not (equal old (oref db :tracked)))
|
|
|
|
|
(gnus-message 4 "Reindexing the Gnus registry (tracked change)")
|
|
|
|
|
(registry-reindex db))))
|
2011-04-05 22:35:05 +00:00
|
|
|
db)
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-make-db (&optional file)
|
|
|
|
|
(interactive "fGnus registry persistence file: \n")
|
|
|
|
|
(gnus-registry-fixup-registry
|
|
|
|
|
(registry-db
|
|
|
|
|
"Gnus Registry"
|
|
|
|
|
:file (or file gnus-registry-cache-file)
|
|
|
|
|
;; these parameters are set in `gnus-registry-fixup-registry'
|
|
|
|
|
:max-hard most-positive-fixnum
|
|
|
|
|
:max-soft most-positive-fixnum
|
|
|
|
|
:precious nil
|
|
|
|
|
:tracked nil)))
|
|
|
|
|
|
|
|
|
|
(defvar gnus-registry-db (gnus-registry-make-db)
|
|
|
|
|
"*The article registry by Message ID. See `registry-db'")
|
|
|
|
|
|
|
|
|
|
;; top-level registry data management
|
|
|
|
|
(defun gnus-registry-remake-db (&optional forsure)
|
|
|
|
|
"Remake the registry database after customization.
|
|
|
|
|
This is not required after changing `gnus-registry-cache-file'."
|
|
|
|
|
(interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
|
|
|
|
|
(when forsure
|
2011-04-12 22:18:02 +00:00
|
|
|
(gnus-message 4 "Remaking the Gnus registry")
|
2011-04-05 22:35:05 +00:00
|
|
|
(setq gnus-registry-db (gnus-registry-make-db))))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defun gnus-registry-read ()
|
2004-09-04 13:13:48 +00:00
|
|
|
"Read the registry cache file."
|
|
|
|
|
(interactive)
|
|
|
|
|
(let ((file gnus-registry-cache-file))
|
2011-04-05 22:35:05 +00:00
|
|
|
(condition-case nil
|
|
|
|
|
(progn
|
|
|
|
|
(gnus-message 5 "Reading Gnus registry from %s..." file)
|
|
|
|
|
(setq gnus-registry-db (gnus-registry-fixup-registry
|
|
|
|
|
(eieio-persistent-read file)))
|
|
|
|
|
(gnus-message 5 "Reading Gnus registry from %s...done" file))
|
|
|
|
|
(error
|
|
|
|
|
(gnus-message
|
|
|
|
|
1
|
|
|
|
|
"The Gnus registry could not be loaded from %s, creating a new one"
|
|
|
|
|
file)
|
|
|
|
|
(gnus-registry-remake-db t)))))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-save (&optional file db)
|
2004-09-04 13:13:48 +00:00
|
|
|
"Save the registry cache file."
|
|
|
|
|
(interactive)
|
2011-04-05 22:35:05 +00:00
|
|
|
(let ((file (or file gnus-registry-cache-file))
|
|
|
|
|
(db (or db gnus-registry-db)))
|
|
|
|
|
(gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
|
|
|
|
|
(registry-size db) file)
|
|
|
|
|
(registry-prune db)
|
|
|
|
|
;; TODO: call (gnus-string-remove-all-properties v) on all elements?
|
|
|
|
|
(eieio-persistent-save db file)
|
|
|
|
|
(gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
|
|
|
|
|
(registry-size db) file)))
|
|
|
|
|
|
2011-06-01 22:35:26 +00:00
|
|
|
(defun gnus-registry-remove-ignored ()
|
|
|
|
|
(interactive)
|
|
|
|
|
(let* ((db gnus-registry-db)
|
|
|
|
|
(grouphashtb (registry-lookup-secondary db 'group))
|
|
|
|
|
(old-size (registry-size db)))
|
|
|
|
|
(registry-reindex db)
|
|
|
|
|
(loop for k being the hash-keys of grouphashtb
|
|
|
|
|
using (hash-values v)
|
|
|
|
|
when (gnus-registry-ignore-group-p k)
|
|
|
|
|
do (registry-delete db v nil))
|
|
|
|
|
(registry-reindex db)
|
|
|
|
|
(gnus-message 4 "Removed %d ignored entries from the Gnus registry"
|
|
|
|
|
(- old-size (registry-size db)))))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
;; article move/copy/spool/delete actions
|
2004-09-04 13:13:48 +00:00
|
|
|
(defun gnus-registry-action (action data-header from &optional to method)
|
|
|
|
|
(let* ((id (mail-header-id data-header))
|
2011-04-11 22:17:30 +00:00
|
|
|
(subject (mail-header-subject data-header))
|
2011-04-21 22:06:12 +00:00
|
|
|
(extra (mail-header-extra data-header))
|
2011-04-18 22:59:02 +00:00
|
|
|
(recipients (gnus-registry-sort-addresses
|
2011-04-21 22:06:12 +00:00
|
|
|
(or (cdr-safe (assq 'Cc extra)) "")
|
|
|
|
|
(or (cdr-safe (assq 'To extra)) "")))
|
2011-04-16 06:56:17 +00:00
|
|
|
(sender (nth 0 (gnus-registry-extract-addresses
|
|
|
|
|
(mail-header-from data-header))))
|
2011-04-05 22:35:05 +00:00
|
|
|
(from (gnus-group-guess-full-name-from-command-method from))
|
|
|
|
|
(to (if to (gnus-group-guess-full-name-from-command-method to) nil))
|
|
|
|
|
(to-name (if to to "the Bit Bucket")))
|
|
|
|
|
(gnus-message 7 "Gnus registry: article %s %s from %s to %s"
|
|
|
|
|
id (if method "respooling" "going") from to)
|
|
|
|
|
|
|
|
|
|
(gnus-registry-handle-action
|
|
|
|
|
id
|
|
|
|
|
;; unless copying, remove the old "from" group
|
|
|
|
|
(if (not (equal 'copy action)) from nil)
|
2011-04-16 06:56:17 +00:00
|
|
|
to subject sender recipients)))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-04-16 06:56:17 +00:00
|
|
|
(defun gnus-registry-spool-action (id group &optional subject sender recipients)
|
2011-04-11 22:17:30 +00:00
|
|
|
(let ((to (gnus-group-guess-full-name-from-command-method group))
|
2011-04-16 06:56:17 +00:00
|
|
|
(recipients (or recipients
|
2011-04-21 22:06:12 +00:00
|
|
|
(gnus-registry-sort-addresses
|
|
|
|
|
(or (message-fetch-field "cc") "")
|
|
|
|
|
(or (message-fetch-field "to") ""))))
|
2011-04-11 22:17:30 +00:00
|
|
|
(subject (or subject (message-fetch-field "subject")))
|
|
|
|
|
(sender (or sender (message-fetch-field "from"))))
|
2004-09-04 13:13:48 +00:00
|
|
|
(when (and (stringp id) (string-match "\r$" id))
|
|
|
|
|
(setq id (substring id 0 -1)))
|
2011-04-05 22:35:05 +00:00
|
|
|
(gnus-message 7 "Gnus registry: article %s spooled to %s"
|
|
|
|
|
id
|
|
|
|
|
to)
|
2011-04-16 06:56:17 +00:00
|
|
|
(gnus-registry-handle-action id nil to subject sender recipients)))
|
2011-04-05 22:35:05 +00:00
|
|
|
|
2011-04-16 06:56:17 +00:00
|
|
|
(defun gnus-registry-handle-action (id from to subject sender
|
|
|
|
|
&optional recipients)
|
2011-04-07 22:48:21 +00:00
|
|
|
(gnus-message
|
|
|
|
|
10
|
2011-04-16 06:56:17 +00:00
|
|
|
"gnus-registry-handle-action %S" (list id from to subject sender recipients))
|
2011-04-05 22:35:05 +00:00
|
|
|
(let ((db gnus-registry-db)
|
2011-04-20 22:12:08 +00:00
|
|
|
;; if the group is ignored, set the destination to nil (same as delete)
|
|
|
|
|
(to (if (gnus-registry-ignore-group-p to) nil to))
|
2011-04-05 22:35:05 +00:00
|
|
|
;; safe if not found
|
2011-04-11 22:17:30 +00:00
|
|
|
(entry (gnus-registry-get-or-make-entry id))
|
|
|
|
|
(subject (gnus-string-remove-all-properties
|
|
|
|
|
(gnus-registry-simplify-subject subject)))
|
|
|
|
|
(sender (gnus-string-remove-all-properties sender)))
|
2011-04-05 22:35:05 +00:00
|
|
|
|
|
|
|
|
;; this could be done by calling `gnus-registry-set-id-key'
|
|
|
|
|
;; several times but it's better to bunch the transactions
|
|
|
|
|
;; together
|
|
|
|
|
|
|
|
|
|
(registry-delete db (list id) nil)
|
|
|
|
|
(when from
|
|
|
|
|
(setq entry (cons (delete from (assoc 'group entry))
|
|
|
|
|
(assq-delete-all 'group entry))))
|
|
|
|
|
|
2011-04-16 06:56:17 +00:00
|
|
|
(dolist (kv `((group ,to)
|
|
|
|
|
(sender ,sender)
|
|
|
|
|
(recipient ,@recipients)
|
|
|
|
|
(subject ,subject)))
|
2011-04-05 22:35:05 +00:00
|
|
|
(when (second kv)
|
|
|
|
|
(let ((new (or (assq (first kv) entry)
|
|
|
|
|
(list (first kv)))))
|
2011-04-16 06:56:17 +00:00
|
|
|
(dolist (toadd (cdr kv))
|
|
|
|
|
(add-to-list 'new toadd t))
|
2011-04-05 22:35:05 +00:00
|
|
|
(setq entry (cons new
|
|
|
|
|
(assq-delete-all (first kv) entry))))))
|
|
|
|
|
(gnus-message 10 "Gnus registry: new entry for %s is %S"
|
|
|
|
|
id
|
|
|
|
|
entry)
|
2011-05-09 22:27:17 +00:00
|
|
|
(gnus-registry-insert db id entry)))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;; Function for nn{mail|imap}-split-fancy: look up all references in
|
|
|
|
|
;; the cache and if a match is found, return that group.
|
|
|
|
|
(defun gnus-registry-split-fancy-with-parent ()
|
|
|
|
|
"Split this message into the same group as its parent. The parent
|
|
|
|
|
is obtained from the registry. This function can be used as an entry
|
|
|
|
|
in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
|
2005-02-09 15:50:47 +00:00
|
|
|
this: (: gnus-registry-split-fancy-with-parent)
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2007-10-28 09:18:39 +00:00
|
|
|
This function tracks ALL backends, unlike
|
|
|
|
|
`nnmail-split-fancy-with-parent' which tracks only nnmail
|
|
|
|
|
messages.
|
|
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
For a message to be split, it looks for the parent message in the
|
2007-10-28 09:18:39 +00:00
|
|
|
References or In-Reply-To header and then looks in the registry
|
|
|
|
|
to see which group that message was put in. This group is
|
2008-03-01 01:28:14 +00:00
|
|
|
returned, unless `gnus-registry-follow-group-p' return nil for
|
|
|
|
|
that group.
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
See the Info node `(gnus)Fancy Mail Splitting' for more details."
|
2008-03-01 01:28:14 +00:00
|
|
|
(let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
|
2011-04-05 22:35:05 +00:00
|
|
|
(reply-to (message-fetch-field "in-reply-to")) ; may be nil
|
|
|
|
|
;; now, if reply-to is valid, append it to the References
|
|
|
|
|
(refstr (if reply-to
|
|
|
|
|
(concat refstr " " reply-to)
|
|
|
|
|
refstr))
|
|
|
|
|
(references (and refstr (gnus-extract-references refstr)))
|
|
|
|
|
;; these may not be used, but the code is cleaner having them up here
|
|
|
|
|
(sender (gnus-string-remove-all-properties
|
|
|
|
|
(message-fetch-field "from")))
|
2011-04-18 22:59:02 +00:00
|
|
|
(recipients (gnus-registry-sort-addresses
|
2011-04-21 22:06:12 +00:00
|
|
|
(or (message-fetch-field "cc") "")
|
|
|
|
|
(or (message-fetch-field "to") "")))
|
2011-04-05 22:35:05 +00:00
|
|
|
(subject (gnus-string-remove-all-properties
|
|
|
|
|
(gnus-registry-simplify-subject
|
|
|
|
|
(message-fetch-field "subject"))))
|
|
|
|
|
|
|
|
|
|
(nnmail-split-fancy-with-parent-ignore-groups
|
|
|
|
|
(if (listp nnmail-split-fancy-with-parent-ignore-groups)
|
|
|
|
|
nnmail-split-fancy-with-parent-ignore-groups
|
|
|
|
|
(list nnmail-split-fancy-with-parent-ignore-groups))))
|
|
|
|
|
(gnus-registry--split-fancy-with-parent-internal
|
|
|
|
|
:references references
|
|
|
|
|
:refstr refstr
|
|
|
|
|
:sender sender
|
2011-04-16 06:56:17 +00:00
|
|
|
:recipients recipients
|
2011-04-05 22:35:05 +00:00
|
|
|
:subject subject
|
|
|
|
|
:log-agent "Gnus registry fancy splitting with parent")))
|
|
|
|
|
|
|
|
|
|
(defun* gnus-registry--split-fancy-with-parent-internal
|
|
|
|
|
(&rest spec
|
2011-04-16 06:56:17 +00:00
|
|
|
&key references refstr sender subject recipients log-agent
|
2011-04-05 22:35:05 +00:00
|
|
|
&allow-other-keys)
|
|
|
|
|
(gnus-message
|
|
|
|
|
10
|
2011-04-06 22:08:31 +00:00
|
|
|
"gnus-registry--split-fancy-with-parent-internal %S" spec)
|
2011-04-05 22:35:05 +00:00
|
|
|
(let ((db gnus-registry-db)
|
|
|
|
|
found)
|
2011-04-06 22:08:31 +00:00
|
|
|
;; this is a big chain of statements. it uses
|
2008-03-01 01:28:14 +00:00
|
|
|
;; gnus-registry-post-process-groups to filter the results after
|
|
|
|
|
;; every step.
|
2011-04-06 22:08:31 +00:00
|
|
|
;; the references string must be valid and parse to valid references
|
|
|
|
|
(when references
|
|
|
|
|
(gnus-message
|
|
|
|
|
9
|
|
|
|
|
"%s is tracing references %s"
|
|
|
|
|
log-agent refstr)
|
2011-04-05 22:35:05 +00:00
|
|
|
(dolist (reference (nreverse references))
|
2011-04-06 22:08:31 +00:00
|
|
|
(gnus-message 9 "%s is looking up %s" log-agent reference)
|
|
|
|
|
(loop for group in (gnus-registry-get-id-key reference 'group)
|
|
|
|
|
when (gnus-registry-follow-group-p group)
|
2011-04-20 22:12:08 +00:00
|
|
|
do
|
|
|
|
|
(progn
|
|
|
|
|
(gnus-message 7 "%s traced %s to %s" log-agent reference group)
|
|
|
|
|
(push group found))))
|
2008-03-01 01:28:14 +00:00
|
|
|
;; filter the found groups and return them
|
2008-04-26 04:29:42 +00:00
|
|
|
;; the found groups are the full groups
|
2010-09-02 01:42:32 +00:00
|
|
|
(setq found (gnus-registry-post-process-groups
|
2011-04-05 22:35:05 +00:00
|
|
|
"references" refstr found)))
|
|
|
|
|
|
2011-04-15 14:29:02 +00:00
|
|
|
;; else: there were no matches, now try the extra tracking by subject
|
|
|
|
|
(when (and (null found)
|
|
|
|
|
(memq 'subject gnus-registry-track-extra)
|
|
|
|
|
subject
|
|
|
|
|
(< gnus-registry-minimum-subject-length (length subject)))
|
|
|
|
|
(let ((groups (apply
|
|
|
|
|
'append
|
|
|
|
|
(mapcar
|
|
|
|
|
(lambda (reference)
|
|
|
|
|
(gnus-registry-get-id-key reference 'group))
|
|
|
|
|
(registry-lookup-secondary-value db 'subject subject)))))
|
|
|
|
|
(setq found
|
|
|
|
|
(loop for group in groups
|
|
|
|
|
when (gnus-registry-follow-group-p group)
|
|
|
|
|
do (gnus-message
|
|
|
|
|
;; warn more if gnus-registry-track-extra
|
|
|
|
|
(if gnus-registry-track-extra 7 9)
|
|
|
|
|
"%s (extra tracking) traced subject '%s' to %s"
|
|
|
|
|
log-agent subject group)
|
2011-04-20 22:12:08 +00:00
|
|
|
and collect group))
|
2011-04-15 14:29:02 +00:00
|
|
|
;; filter the found groups and return them
|
|
|
|
|
;; the found groups are NOT the full groups
|
|
|
|
|
(setq found (gnus-registry-post-process-groups
|
|
|
|
|
"subject" subject found))))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
;; else: there were no matches, try the extra tracking by sender
|
2011-04-06 22:08:31 +00:00
|
|
|
(when (and (null found)
|
|
|
|
|
(memq 'sender gnus-registry-track-extra)
|
|
|
|
|
sender
|
2011-04-12 22:18:02 +00:00
|
|
|
(not (gnus-grep-in-list
|
|
|
|
|
sender
|
|
|
|
|
gnus-registry-unfollowed-addresses)))
|
2011-04-06 22:08:31 +00:00
|
|
|
(let ((groups (apply
|
|
|
|
|
'append
|
|
|
|
|
(mapcar
|
|
|
|
|
(lambda (reference)
|
|
|
|
|
(gnus-registry-get-id-key reference 'group))
|
|
|
|
|
(registry-lookup-secondary-value db 'sender sender)))))
|
|
|
|
|
(setq found
|
|
|
|
|
(loop for group in groups
|
|
|
|
|
when (gnus-registry-follow-group-p group)
|
|
|
|
|
do (gnus-message
|
|
|
|
|
;; warn more if gnus-registry-track-extra
|
|
|
|
|
(if gnus-registry-track-extra 7 9)
|
|
|
|
|
"%s (extra tracking) traced sender '%s' to %s"
|
|
|
|
|
log-agent sender group)
|
2011-04-20 22:12:08 +00:00
|
|
|
and collect group)))
|
2011-04-06 22:08:31 +00:00
|
|
|
|
|
|
|
|
;; filter the found groups and return them
|
|
|
|
|
;; the found groups are NOT the full groups
|
|
|
|
|
(setq found (gnus-registry-post-process-groups
|
|
|
|
|
"sender" sender found)))
|
2010-09-02 01:42:32 +00:00
|
|
|
|
2011-04-16 06:56:17 +00:00
|
|
|
;; else: there were no matches, try the extra tracking by recipient
|
|
|
|
|
(when (and (null found)
|
|
|
|
|
(memq 'recipient gnus-registry-track-extra)
|
|
|
|
|
recipients)
|
|
|
|
|
(dolist (recp recipients)
|
|
|
|
|
(when (and (null found)
|
|
|
|
|
(not (gnus-grep-in-list
|
|
|
|
|
recp
|
|
|
|
|
gnus-registry-unfollowed-addresses)))
|
|
|
|
|
(let ((groups (apply 'append
|
|
|
|
|
(mapcar
|
|
|
|
|
(lambda (reference)
|
|
|
|
|
(gnus-registry-get-id-key reference 'group))
|
|
|
|
|
(registry-lookup-secondary-value
|
|
|
|
|
db 'recipient recp)))))
|
|
|
|
|
(setq found
|
|
|
|
|
(loop for group in groups
|
|
|
|
|
when (gnus-registry-follow-group-p group)
|
|
|
|
|
do (gnus-message
|
|
|
|
|
;; warn more if gnus-registry-track-extra
|
|
|
|
|
(if gnus-registry-track-extra 7 9)
|
|
|
|
|
"%s (extra tracking) traced recipient '%s' to %s"
|
|
|
|
|
log-agent recp group)
|
2011-04-20 22:12:08 +00:00
|
|
|
and collect group)))))
|
2011-04-16 06:56:17 +00:00
|
|
|
|
|
|
|
|
;; filter the found groups and return them
|
|
|
|
|
;; the found groups are NOT the full groups
|
|
|
|
|
(setq found (gnus-registry-post-process-groups
|
|
|
|
|
"recipients" (mapconcat 'identity recipients ", ") found)))
|
|
|
|
|
|
2011-04-06 22:08:31 +00:00
|
|
|
;; after the (cond) we extract the actual value safely
|
|
|
|
|
(car-safe found)))
|
2008-03-01 01:28:14 +00:00
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defun gnus-registry-post-process-groups (mode key groups)
|
|
|
|
|
"Inspects GROUPS found by MODE for KEY to determine which ones to follow.
|
2008-03-01 01:28:14 +00:00
|
|
|
|
|
|
|
|
MODE can be 'subject' or 'sender' for example. The KEY is the
|
|
|
|
|
value by which MODE was searched.
|
|
|
|
|
|
|
|
|
|
Transforms each group name to the equivalent short name.
|
|
|
|
|
|
|
|
|
|
Checks if the current Gnus method (from `gnus-command-method' or
|
|
|
|
|
from `gnus-newsgroup-name') is the same as the group's method.
|
2011-04-05 22:35:05 +00:00
|
|
|
Foreign methods are not supported so they are rejected.
|
2008-03-01 01:28:14 +00:00
|
|
|
|
|
|
|
|
Reduces the list to a single group, or complains if that's not
|
2011-04-05 22:35:05 +00:00
|
|
|
possible. Uses `gnus-registry-split-strategy'."
|
2008-03-01 01:28:14 +00:00
|
|
|
(let ((log-agent "gnus-registry-post-process-group")
|
2011-04-06 22:08:31 +00:00
|
|
|
(desc (format "%d groups" (length groups)))
|
|
|
|
|
out chosen)
|
|
|
|
|
;; the strategy can be nil, in which case chosen is nil
|
|
|
|
|
(setq chosen
|
2011-04-05 22:35:05 +00:00
|
|
|
(case gnus-registry-split-strategy
|
2011-04-06 22:08:31 +00:00
|
|
|
;; default, take only one-element lists into chosen
|
|
|
|
|
((nil)
|
|
|
|
|
(and (= (length groups) 1)
|
|
|
|
|
(car-safe groups)))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
((first)
|
2011-04-06 22:08:31 +00:00
|
|
|
(car-safe groups))
|
2011-04-05 22:35:05 +00:00
|
|
|
|
|
|
|
|
((majority)
|
|
|
|
|
(let ((freq (make-hash-table
|
|
|
|
|
:size 256
|
|
|
|
|
:test 'equal)))
|
2011-04-06 22:08:31 +00:00
|
|
|
(mapc (lambda (x) (let ((x (gnus-group-short-name x)))
|
|
|
|
|
(puthash x (1+ (gethash x freq 0)) freq)))
|
2011-04-05 22:35:05 +00:00
|
|
|
groups)
|
2011-04-06 22:08:31 +00:00
|
|
|
(setq desc (format "%d groups, %d unique"
|
|
|
|
|
(length groups)
|
|
|
|
|
(hash-table-count freq)))
|
|
|
|
|
(car-safe
|
|
|
|
|
(sort groups
|
|
|
|
|
(lambda (a b)
|
|
|
|
|
(> (gethash (gnus-group-short-name a) freq 0)
|
|
|
|
|
(gethash (gnus-group-short-name b) freq 0)))))))))
|
|
|
|
|
|
|
|
|
|
(if chosen
|
|
|
|
|
(gnus-message
|
|
|
|
|
9
|
|
|
|
|
"%s: strategy %s on %s produced %s"
|
|
|
|
|
log-agent gnus-registry-split-strategy desc chosen)
|
|
|
|
|
(gnus-message
|
|
|
|
|
9
|
|
|
|
|
"%s: strategy %s on %s did not produce an answer"
|
|
|
|
|
log-agent
|
|
|
|
|
(or gnus-registry-split-strategy "default")
|
|
|
|
|
desc))
|
|
|
|
|
|
|
|
|
|
(setq groups (and chosen (list chosen)))
|
2011-04-05 22:35:05 +00:00
|
|
|
|
|
|
|
|
(dolist (group groups)
|
|
|
|
|
(let ((m1 (gnus-find-method-for-group group))
|
|
|
|
|
(m2 (or gnus-command-method
|
|
|
|
|
(gnus-find-method-for-group gnus-newsgroup-name)))
|
|
|
|
|
(short-name (gnus-group-short-name group)))
|
|
|
|
|
(if (gnus-methods-equal-p m1 m2)
|
|
|
|
|
(progn
|
|
|
|
|
;; this is REALLY just for debugging
|
2011-04-06 22:08:31 +00:00
|
|
|
(when (not (equal group short-name))
|
|
|
|
|
(gnus-message
|
|
|
|
|
10
|
|
|
|
|
"%s: stripped group %s to %s"
|
|
|
|
|
log-agent group short-name))
|
2011-04-05 22:35:05 +00:00
|
|
|
(add-to-list 'out short-name))
|
|
|
|
|
;; else...
|
|
|
|
|
(gnus-message
|
|
|
|
|
7
|
2011-04-06 22:08:31 +00:00
|
|
|
"%s: ignored foreign group %s"
|
2011-04-05 22:35:05 +00:00
|
|
|
log-agent group))))
|
|
|
|
|
|
2011-04-06 22:08:31 +00:00
|
|
|
(setq out (delq nil out))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(cond
|
|
|
|
|
((= (length out) 1) out)
|
|
|
|
|
((null out)
|
|
|
|
|
(gnus-message
|
|
|
|
|
5
|
2011-04-12 22:18:02 +00:00
|
|
|
"%s: no matches for %s '%s'."
|
|
|
|
|
log-agent mode key)
|
2011-04-05 22:35:05 +00:00
|
|
|
nil)
|
|
|
|
|
(t (gnus-message
|
|
|
|
|
5
|
2011-04-12 22:18:02 +00:00
|
|
|
"%s: too many extra matches (%s) for %s '%s'. Returning none."
|
2011-04-05 22:35:05 +00:00
|
|
|
log-agent out mode key)
|
|
|
|
|
nil))))
|
2008-03-01 01:28:14 +00:00
|
|
|
|
|
|
|
|
(defun gnus-registry-follow-group-p (group)
|
|
|
|
|
"Determines if a group name should be followed.
|
|
|
|
|
Consults `gnus-registry-unfollowed-groups' and
|
|
|
|
|
`nnmail-split-fancy-with-parent-ignore-groups'."
|
2011-04-05 22:35:05 +00:00
|
|
|
(and group
|
|
|
|
|
(not (or (gnus-grep-in-list
|
|
|
|
|
group
|
|
|
|
|
gnus-registry-unfollowed-groups)
|
|
|
|
|
(gnus-grep-in-list
|
|
|
|
|
group
|
|
|
|
|
nnmail-split-fancy-with-parent-ignore-groups)))))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2011-04-21 22:06:12 +00:00
|
|
|
;; note that gnus-registry-ignored-groups is defined in gnus.el as a
|
|
|
|
|
;; group/topic parameter and an associated variable!
|
|
|
|
|
|
|
|
|
|
;; we do special logic for ignoring to accept regular expressions and
|
|
|
|
|
;; nnmail-split-fancy-with-parent-ignore-groups as well
|
2011-04-20 22:12:08 +00:00
|
|
|
(defun gnus-registry-ignore-group-p (group)
|
|
|
|
|
"Determines if a group name should be ignored.
|
|
|
|
|
Consults `gnus-registry-ignored-groups' and
|
|
|
|
|
`nnmail-split-fancy-with-parent-ignore-groups'."
|
|
|
|
|
(and group
|
2011-04-23 00:08:28 +00:00
|
|
|
(or (gnus-grep-in-list
|
2011-04-21 22:06:12 +00:00
|
|
|
group
|
|
|
|
|
(delq nil (mapcar (lambda (g)
|
|
|
|
|
(cond
|
|
|
|
|
((stringp g) g)
|
|
|
|
|
((and (listp g) (nth 1 g))
|
|
|
|
|
(nth 0 g))
|
|
|
|
|
(t nil))) gnus-registry-ignored-groups)))
|
2011-04-23 00:08:28 +00:00
|
|
|
;; only use `gnus-parameter-registry-ignore' if
|
|
|
|
|
;; `gnus-registry-ignored-groups' is a list of lists
|
|
|
|
|
;; (it can be a list of regexes)
|
|
|
|
|
(and (listp (nth 0 gnus-registry-ignored-groups))
|
2011-04-25 04:32:07 +00:00
|
|
|
(get-buffer "*Group*") ; in automatic tests this is false
|
2011-04-23 00:08:28 +00:00
|
|
|
(gnus-parameter-registry-ignore group))
|
2011-04-21 22:06:12 +00:00
|
|
|
(gnus-grep-in-list
|
|
|
|
|
group
|
|
|
|
|
nnmail-split-fancy-with-parent-ignore-groups))))
|
2011-04-20 22:12:08 +00:00
|
|
|
|
2007-10-28 09:18:39 +00:00
|
|
|
(defun gnus-registry-wash-for-keywords (&optional force)
|
2011-04-05 22:35:05 +00:00
|
|
|
"Get the keywords of the current article.
|
|
|
|
|
Overrides existing keywords with FORCE set non-nil."
|
2007-10-28 09:18:39 +00:00
|
|
|
(interactive)
|
|
|
|
|
(let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
|
2011-04-05 22:35:05 +00:00
|
|
|
word words)
|
|
|
|
|
(if (or (not (gnus-registry-get-id-key id 'keyword))
|
|
|
|
|
force)
|
|
|
|
|
(with-current-buffer gnus-article-buffer
|
|
|
|
|
(article-goto-body)
|
|
|
|
|
(save-window-excursion
|
|
|
|
|
(save-restriction
|
|
|
|
|
(narrow-to-region (point) (point-max))
|
|
|
|
|
(with-syntax-table gnus-adaptive-word-syntax-table
|
|
|
|
|
(while (re-search-forward "\\b\\w+\\b" nil t)
|
|
|
|
|
(setq word (gnus-string-remove-all-properties
|
|
|
|
|
(downcase (buffer-substring
|
|
|
|
|
(match-beginning 0) (match-end 0)))))
|
|
|
|
|
(if (> (length word) 2)
|
|
|
|
|
(push word words))))))
|
|
|
|
|
(gnus-registry-set-id-key id 'keyword words)))))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-keywords ()
|
|
|
|
|
(let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
|
|
|
|
|
(when table (maphash (lambda (k v) k) table))))
|
2007-10-28 09:18:39 +00:00
|
|
|
|
|
|
|
|
(defun gnus-registry-find-keywords (keyword)
|
2011-04-05 22:35:05 +00:00
|
|
|
(interactive (list
|
|
|
|
|
(completing-read "Keyword: " (gnus-registry-keywords) nil t)))
|
|
|
|
|
(registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
|
2007-10-28 09:18:39 +00:00
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
(defun gnus-registry-register-message-ids ()
|
|
|
|
|
"Register the Message-ID of every article in the group"
|
|
|
|
|
(unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
|
|
|
|
|
(dolist (article gnus-newsgroup-articles)
|
2011-04-05 22:35:05 +00:00
|
|
|
(let* ((id (gnus-registry-fetch-message-id-fast article))
|
|
|
|
|
(groups (gnus-registry-get-id-key id 'group)))
|
|
|
|
|
(unless (member gnus-newsgroup-name groups)
|
|
|
|
|
(gnus-message 9 "Registry: Registering article %d with group %s"
|
|
|
|
|
article gnus-newsgroup-name)
|
|
|
|
|
(gnus-registry-handle-action id nil gnus-newsgroup-name
|
|
|
|
|
(gnus-registry-fetch-simplified-message-subject-fast article)
|
2011-04-16 06:56:17 +00:00
|
|
|
(gnus-registry-fetch-sender-fast article)
|
|
|
|
|
(gnus-registry-fetch-recipients-fast article)))))))
|
2011-04-05 22:35:05 +00:00
|
|
|
|
|
|
|
|
;; message field fetchers
|
2004-09-04 13:13:48 +00:00
|
|
|
(defun gnus-registry-fetch-message-id-fast (article)
|
|
|
|
|
"Fetch the Message-ID quickly, using the internal gnus-data-list function"
|
|
|
|
|
(if (and (numberp article)
|
2011-04-05 22:35:05 +00:00
|
|
|
(assoc article (gnus-data-list nil)))
|
2004-09-04 13:13:48 +00:00
|
|
|
(mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
|
|
|
|
|
nil))
|
|
|
|
|
|
2011-04-16 06:56:17 +00:00
|
|
|
(defun gnus-registry-extract-addresses (text)
|
|
|
|
|
"Extract all the addresses in a normalized way from TEXT.
|
|
|
|
|
Returns an unsorted list of strings in the name <address> format.
|
|
|
|
|
Addresses without a name will say \"noname\"."
|
|
|
|
|
(mapcar (lambda (add)
|
|
|
|
|
(gnus-string-remove-all-properties
|
|
|
|
|
(let* ((name (or (nth 0 add) "noname"))
|
|
|
|
|
(addr (nth 1 add))
|
|
|
|
|
(addr (if (bufferp addr)
|
|
|
|
|
(with-current-buffer addr
|
|
|
|
|
(buffer-string))
|
|
|
|
|
addr)))
|
|
|
|
|
(format "%s <%s>" name addr))))
|
|
|
|
|
(mail-extract-address-components text t)))
|
|
|
|
|
|
2011-04-18 22:59:02 +00:00
|
|
|
(defun gnus-registry-sort-addresses (&rest addresses)
|
|
|
|
|
"Return a normalized and sorted list of ADDRESSES."
|
|
|
|
|
(sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
|
2011-04-21 22:06:12 +00:00
|
|
|
'string-lessp))
|
2011-04-18 22:59:02 +00:00
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
(defun gnus-registry-simplify-subject (subject)
|
|
|
|
|
(if (stringp subject)
|
|
|
|
|
(gnus-simplify-subject subject)
|
|
|
|
|
nil))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-fetch-simplified-message-subject-fast (article)
|
|
|
|
|
"Fetch the Subject quickly, using the internal gnus-data-list function"
|
|
|
|
|
(if (and (numberp article)
|
2011-04-05 22:35:05 +00:00
|
|
|
(assoc article (gnus-data-list nil)))
|
2007-10-28 09:18:39 +00:00
|
|
|
(gnus-string-remove-all-properties
|
|
|
|
|
(gnus-registry-simplify-subject
|
2011-04-05 22:35:05 +00:00
|
|
|
(mail-header-subject (gnus-data-header
|
|
|
|
|
(assoc article (gnus-data-list nil))))))
|
2004-09-04 13:13:48 +00:00
|
|
|
nil))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-fetch-sender-fast (article)
|
2011-04-16 06:56:17 +00:00
|
|
|
(gnus-registry-fetch-header-fast "from" article))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-fetch-recipients-fast (article)
|
2011-04-18 22:59:02 +00:00
|
|
|
(gnus-registry-sort-addresses
|
|
|
|
|
(or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
|
|
|
|
|
(or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
|
2011-04-16 06:56:17 +00:00
|
|
|
|
|
|
|
|
(defun gnus-registry-fetch-header-fast (article header)
|
|
|
|
|
"Fetch the HEADER quickly, using the internal gnus-data-list function"
|
2004-09-04 13:13:48 +00:00
|
|
|
(if (and (numberp article)
|
2011-04-05 22:35:05 +00:00
|
|
|
(assoc article (gnus-data-list nil)))
|
2007-10-28 09:18:39 +00:00
|
|
|
(gnus-string-remove-all-properties
|
2011-04-20 00:43:48 +00:00
|
|
|
(cdr (assq header (gnus-data-header
|
2011-04-21 22:06:12 +00:00
|
|
|
(assoc article (gnus-data-list nil))))))
|
2004-09-04 13:13:48 +00:00
|
|
|
nil))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
;; registry marks glue
|
2008-03-01 01:28:14 +00:00
|
|
|
(defun gnus-registry-do-marks (type function)
|
|
|
|
|
"For each known mark, call FUNCTION for each cell of type TYPE.
|
|
|
|
|
|
|
|
|
|
FUNCTION should take two parameters, a mark symbol and the cell value."
|
|
|
|
|
(dolist (mark-info gnus-registry-marks)
|
2008-03-10 00:50:22 +00:00
|
|
|
(let* ((mark (car-safe mark-info))
|
2011-04-05 22:35:05 +00:00
|
|
|
(data (cdr-safe mark-info))
|
|
|
|
|
(cell-data (plist-get data type)))
|
2008-03-10 00:50:22 +00:00
|
|
|
(when cell-data
|
2011-04-05 22:35:05 +00:00
|
|
|
(funcall function mark cell-data)))))
|
2008-03-01 01:28:14 +00:00
|
|
|
|
|
|
|
|
;;; this is ugly code, but I don't know how to do it better
|
2008-03-10 00:50:22 +00:00
|
|
|
(defun gnus-registry-install-shortcuts ()
|
2008-03-01 01:28:14 +00:00
|
|
|
"Install the keyboard shortcuts and menus for the registry.
|
|
|
|
|
Uses `gnus-registry-marks' to find what shortcuts to install."
|
2008-03-10 00:50:22 +00:00
|
|
|
(let (keys-plist)
|
Synch with Gnus trunk
=====================
2010-03-23 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (canlock-verify): Autoload it for Emacs 21.
* message.el (ecomplete-setup): Autoload it for Emacs <23.
* mml-sec.el (mml-secure-cache-passphrase): Default to t that is
password-cache's default if it is not bound.
(mml-secure-passphrase-cache-expiry): Default to 16 that is
password-cache-expiry's default if it is not bound.
* pop3.el (pop3-list): Don't use 3rd arg of `split-string' which is not
available in Emacs 21.
2010-03-23 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el (auth-sources): Fix up definition so extra parameters
are always inline.
2010-03-22 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-verify-uidvalidity): Fixed bug where uidvalidity
wasn't updated after mismatch. Clear cached mailbox info correctly
when uidvalidity changes.
(nnimap-group-prefixed-name): New function to avoid some code
duplication.
(nnimap-verify-uidvalidity, nnimap-group-overview-filename)
(nnimap-request-group): Use it.
(nnimap-retrieve-groups, nnimap-verify-uidvalidity)
(nnimap-update-unseen): Significantly improved speed of Gnus startup
with many imap folders. This is done by caching the group status from
the imap server persistently in a group parameter `imap-status'. (This
was cached before too if `nnimap-retrieve-groups-asynchronous' was set,
but not persistently, so every Gnus startup was still very slow.)
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el: Set up autoloads. Bump to 23.2 because of the
secrets.el dependency.
(auth-sources): Add optional user name. Add secrets.el configuration
choice (unused right now).
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* gnus-sum.el (gnus-summary-make-menu-bar): Let
`gnus-registry-install-shortcuts' fill in the functions.
* gnus-registry.el (gnus-summary-misc-menu): Declare to avoid
warnings.
(gnus-registry-misc-menus): Variable to hold registry mark menus.
(gnus-registry-install-shortcuts): Populate and use it in a
`gnus-summary-menu-hook' lambda, under "Gnus"->"Registry Marks".
2010-03-20 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-decode-group-name, nnimap-encode-group-name):
In-place substitutions for the group name encoding/decoding.
(nnimap-find-minmax-uid, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-request-article-part)
(nnimap-update-unseen, nnimap-request-list)
(nnimap-retrieve-groups, nnimap-request-update-info-internal)
(nnimap-request-set-mark, nnimap-split-to-groups)
(nnimap-split-articles, nnimap-request-newgroups)
(nnimap-request-create-group, nnimap-request-accept-article)
(nnimap-request-delete-group, nnimap-request-rename-group)
(nnimap-acl-get, nnimap-acl-edit): Use them. Replace `mbx' with
`encoded-mbx' for consistency.
(nnimap-close-group): Call `imap-current-mailbox' instead of using the
variable `imap-current-mailbox'.
* gnus-agent.el (gnus-agent-fetch-articles, gnus-agent-fetch-headers)
(gnus-agent-regenerate-group): Use `gnus-agent-decoded-group-name'.
2010-03-20 Bojan Petrovic <bpetrovi@f.bg.ac.rs>
* pop3.el (pop3-display-message-size-flag): Display message size byte
counts during POP3 download.
(pop3-movemail): Use it.
(pop3-list): Implement listing of available messages.
2010-03-20 Mark Triggs <mst@dishevelled.net> (tiny change)
* nnir.el (nnir-get-article-nov-override-function): New function to
override the normal NOV retrieval.
(nnir-retrieve-headers): Use it.
2010-03-23 07:37:09 +00:00
|
|
|
(setq gnus-registry-misc-menus nil)
|
|
|
|
|
(gnus-registry-do-marks
|
2008-03-10 00:50:22 +00:00
|
|
|
:char
|
|
|
|
|
(lambda (mark data)
|
|
|
|
|
(let ((function-format
|
2011-04-05 22:35:05 +00:00
|
|
|
(format "gnus-registry-%%s-article-%s-mark" mark)))
|
2008-03-01 01:28:14 +00:00
|
|
|
|
|
|
|
|
;;; The following generates these functions:
|
|
|
|
|
;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
|
|
|
|
|
;;; "Apply the Important mark to process-marked ARTICLES."
|
|
|
|
|
;;; (interactive (gnus-summary-work-articles current-prefix-arg))
|
|
|
|
|
;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
|
|
|
|
|
;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
|
|
|
|
|
;;; "Apply the Important mark to process-marked ARTICLES."
|
|
|
|
|
;;; (interactive (gnus-summary-work-articles current-prefix-arg))
|
|
|
|
|
;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(dolist (remove '(t nil))
|
|
|
|
|
(let* ((variant-name (if remove "remove" "set"))
|
|
|
|
|
(function-name (format function-format variant-name))
|
|
|
|
|
(shortcut (format "%c" data))
|
|
|
|
|
(shortcut (if remove (upcase shortcut) shortcut)))
|
|
|
|
|
(unintern function-name obarray)
|
|
|
|
|
(eval
|
|
|
|
|
`(defun
|
|
|
|
|
;; function name
|
|
|
|
|
,(intern function-name)
|
|
|
|
|
;; parameter definition
|
|
|
|
|
(&rest articles)
|
|
|
|
|
;; documentation
|
|
|
|
|
,(format
|
|
|
|
|
"%s the %s mark over process-marked ARTICLES."
|
|
|
|
|
(upcase-initials variant-name)
|
|
|
|
|
mark)
|
|
|
|
|
;; interactive definition
|
|
|
|
|
(interactive
|
|
|
|
|
(gnus-summary-work-articles current-prefix-arg))
|
|
|
|
|
;; actual code
|
|
|
|
|
|
|
|
|
|
;; if this is called and the user doesn't want the
|
|
|
|
|
;; registry enabled, we'll ask anyhow
|
2011-10-17 22:51:37 +00:00
|
|
|
(unless gnus-registry-install
|
|
|
|
|
(let ((gnus-registry-install 'ask))
|
|
|
|
|
(gnus-registry-install-p)))
|
2011-04-05 22:35:05 +00:00
|
|
|
|
|
|
|
|
;; now the user is asked if gnus-registry-install is 'ask
|
|
|
|
|
(when (gnus-registry-install-p)
|
|
|
|
|
(gnus-registry-set-article-mark-internal
|
|
|
|
|
;; all this just to get the mark, I must be doing it wrong
|
|
|
|
|
(intern ,(symbol-name mark))
|
|
|
|
|
articles ,remove t)
|
|
|
|
|
(gnus-message
|
|
|
|
|
9
|
|
|
|
|
"Applying mark %s to %d articles"
|
|
|
|
|
,(symbol-name mark) (length articles))
|
|
|
|
|
(dolist (article articles)
|
|
|
|
|
(gnus-summary-update-article
|
|
|
|
|
article
|
|
|
|
|
(assoc article (gnus-data-list nil)))))))
|
|
|
|
|
(push (intern function-name) keys-plist)
|
|
|
|
|
(push shortcut keys-plist)
|
|
|
|
|
(push (vector (format "%s %s"
|
|
|
|
|
(upcase-initials variant-name)
|
|
|
|
|
(symbol-name mark))
|
|
|
|
|
(intern function-name) t)
|
|
|
|
|
gnus-registry-misc-menus)
|
|
|
|
|
(gnus-message
|
|
|
|
|
9
|
|
|
|
|
"Defined mark handling function %s"
|
|
|
|
|
function-name))))))
|
2008-03-10 00:50:22 +00:00
|
|
|
(gnus-define-keys-1
|
Synch with Gnus trunk
=====================
2010-03-23 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (canlock-verify): Autoload it for Emacs 21.
* message.el (ecomplete-setup): Autoload it for Emacs <23.
* mml-sec.el (mml-secure-cache-passphrase): Default to t that is
password-cache's default if it is not bound.
(mml-secure-passphrase-cache-expiry): Default to 16 that is
password-cache-expiry's default if it is not bound.
* pop3.el (pop3-list): Don't use 3rd arg of `split-string' which is not
available in Emacs 21.
2010-03-23 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el (auth-sources): Fix up definition so extra parameters
are always inline.
2010-03-22 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-verify-uidvalidity): Fixed bug where uidvalidity
wasn't updated after mismatch. Clear cached mailbox info correctly
when uidvalidity changes.
(nnimap-group-prefixed-name): New function to avoid some code
duplication.
(nnimap-verify-uidvalidity, nnimap-group-overview-filename)
(nnimap-request-group): Use it.
(nnimap-retrieve-groups, nnimap-verify-uidvalidity)
(nnimap-update-unseen): Significantly improved speed of Gnus startup
with many imap folders. This is done by caching the group status from
the imap server persistently in a group parameter `imap-status'. (This
was cached before too if `nnimap-retrieve-groups-asynchronous' was set,
but not persistently, so every Gnus startup was still very slow.)
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* auth-source.el: Set up autoloads. Bump to 23.2 because of the
secrets.el dependency.
(auth-sources): Add optional user name. Add secrets.el configuration
choice (unused right now).
2010-03-20 Teodor Zlatanov <tzz@lifelogs.com>
* gnus-sum.el (gnus-summary-make-menu-bar): Let
`gnus-registry-install-shortcuts' fill in the functions.
* gnus-registry.el (gnus-summary-misc-menu): Declare to avoid
warnings.
(gnus-registry-misc-menus): Variable to hold registry mark menus.
(gnus-registry-install-shortcuts): Populate and use it in a
`gnus-summary-menu-hook' lambda, under "Gnus"->"Registry Marks".
2010-03-20 Martin Stjernholm <mast@lysator.liu.se>
* nnimap.el (nnimap-decode-group-name, nnimap-encode-group-name):
In-place substitutions for the group name encoding/decoding.
(nnimap-find-minmax-uid, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-possibly-change-group)
(nnimap-retrieve-headers-progress, nnimap-request-article-part)
(nnimap-update-unseen, nnimap-request-list)
(nnimap-retrieve-groups, nnimap-request-update-info-internal)
(nnimap-request-set-mark, nnimap-split-to-groups)
(nnimap-split-articles, nnimap-request-newgroups)
(nnimap-request-create-group, nnimap-request-accept-article)
(nnimap-request-delete-group, nnimap-request-rename-group)
(nnimap-acl-get, nnimap-acl-edit): Use them. Replace `mbx' with
`encoded-mbx' for consistency.
(nnimap-close-group): Call `imap-current-mailbox' instead of using the
variable `imap-current-mailbox'.
* gnus-agent.el (gnus-agent-fetch-articles, gnus-agent-fetch-headers)
(gnus-agent-regenerate-group): Use `gnus-agent-decoded-group-name'.
2010-03-20 Bojan Petrovic <bpetrovi@f.bg.ac.rs>
* pop3.el (pop3-display-message-size-flag): Display message size byte
counts during POP3 download.
(pop3-movemail): Use it.
(pop3-list): Implement listing of available messages.
2010-03-20 Mark Triggs <mst@dishevelled.net> (tiny change)
* nnir.el (nnir-get-article-nov-override-function): New function to
override the normal NOV retrieval.
(nnir-retrieve-headers): Use it.
2010-03-23 07:37:09 +00:00
|
|
|
'(gnus-registry-mark-map "M" gnus-summary-mark-map)
|
|
|
|
|
keys-plist)
|
|
|
|
|
(add-hook 'gnus-summary-menu-hook
|
2011-04-05 22:35:05 +00:00
|
|
|
(lambda ()
|
|
|
|
|
(easy-menu-add-item
|
|
|
|
|
gnus-summary-misc-menu
|
|
|
|
|
nil
|
|
|
|
|
(cons "Registry Marks" gnus-registry-misc-menus))))))
|
2008-03-10 00:50:22 +00:00
|
|
|
|
2011-05-31 22:08:51 +00:00
|
|
|
(make-obsolete 'gnus-registry-user-format-function-M
|
|
|
|
|
'gnus-registry-article-marks-to-chars "24.1") ?
|
|
|
|
|
|
2011-06-26 22:21:48 +00:00
|
|
|
(defalias 'gnus-registry-user-format-function-M
|
|
|
|
|
'gnus-registry-article-marks-to-chars)
|
|
|
|
|
|
2011-05-18 22:16:26 +00:00
|
|
|
;; use like this:
|
2011-05-31 22:08:51 +00:00
|
|
|
;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
|
|
|
|
|
(defun gnus-registry-article-marks-to-chars (headers)
|
2011-05-18 22:16:26 +00:00
|
|
|
"Show the marks for an article by the :char property"
|
|
|
|
|
(let* ((id (mail-header-message-id headers))
|
|
|
|
|
(marks (when id (gnus-registry-get-id-key id 'mark))))
|
|
|
|
|
(mapconcat (lambda (mark)
|
|
|
|
|
(plist-get
|
|
|
|
|
(cdr-safe
|
|
|
|
|
(assoc mark gnus-registry-marks))
|
|
|
|
|
:char))
|
|
|
|
|
marks "")))
|
|
|
|
|
|
|
|
|
|
;; use like this:
|
2011-05-31 22:08:51 +00:00
|
|
|
;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
|
|
|
|
|
(defun gnus-registry-article-marks-to-names (headers)
|
2011-05-18 22:16:26 +00:00
|
|
|
"Show the marks for an article by name"
|
2008-03-10 00:50:22 +00:00
|
|
|
(let* ((id (mail-header-message-id headers))
|
2011-04-05 22:35:05 +00:00
|
|
|
(marks (when id (gnus-registry-get-id-key id 'mark))))
|
2011-05-18 22:16:26 +00:00
|
|
|
(mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
|
2008-01-20 05:17:57 +00:00
|
|
|
|
|
|
|
|
(defun gnus-registry-read-mark ()
|
|
|
|
|
"Read a mark name from the user with completion."
|
Merge changes made in Gnus trunk.
nndraft.el (nndraft-request-expire-articles): Use the group name instead if "nndraft".
gnus.texi (Using IMAP): Remove the @acronyms from the headings.
nnregistry.el: Added.
nnimap.el (nnimap-insert-partial-structure): Be way more permissive when interpreting the structures.
GNUS-NEWS: Minor error in GNUS-NEWS - password-cache.el.
nnimap.el (nnimap-request-accept-article): Add \r\n to the lines to make this work with Cyrus.
gnus-registry.el: Don't prompt on load, which makes it impossible to build Gnus.
gnus-gravatar.el: Add gnus-gravatar-properties.
gnus-agent.el, gnus-art.el, gnus-bookmark.el, gnus-dired.el, gnus-group.el,\
gnus-int.el, gnus-msg.el, gnus-registry.el, gnus-score.el, gnus-srvr.el,\
gnus-sum.el, gnus-topic.el, gnus-util.el, gnus.el, mm-decode.el, mm-util.el,\
mm-view.el, mml-smime.el, mml.el, nnmairix.el, nnrss.el, smime.el:\
Introduce gnus-completing-read.
gnus-util.el: Make completing-read function configurable.
gnus-util.el: Add requires and fix history for iswitchb.
webmail.el: Remove netscape/my-deja, since they no longer exist.
gnus.el (gnus-local-domain): Declare variable obsolete.
nnimap.el (nnimap-insert-partial-structure): Get the type from the correct slot, too.
pop3.el (pop3-send-streaming-command, pop3-stream-length): New variable.
nnimap.el (nnimap-open-connection): Revert the auto-network->starttls code.
nnimap.el (nnimap-request-set-mark): Erase the buffer before issuing commands.
nnimap.el (nnimap-split-rule): Mark as obsolete.
gnus-sum.el (gnus-valid-move-group-p): Make sure that `group' is a symbol.
nnimap.el (nnimap-split-incoming-mail): Allow `default' as nnimap-split-methods value.
nnimap.el (nnimap-request-article): Downcase the NILs so that they are nil.
nndoc.el (nndoc-retrieve-groups): New function.
gnus.texi: Fix Gravatar documentation.
2010-09-30 08:39:23 +00:00
|
|
|
(let ((mark (gnus-completing-read
|
|
|
|
|
"Label"
|
|
|
|
|
(mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
|
|
|
|
|
nil nil nil
|
2011-04-05 22:35:05 +00:00
|
|
|
(symbol-name gnus-registry-default-mark))))
|
2008-01-20 05:17:57 +00:00
|
|
|
(when (stringp mark)
|
|
|
|
|
(intern mark))))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-set-article-mark (&rest articles)
|
|
|
|
|
"Apply a mark to process-marked ARTICLES."
|
|
|
|
|
(interactive (gnus-summary-work-articles current-prefix-arg))
|
2011-04-05 22:35:05 +00:00
|
|
|
(gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
|
|
|
|
|
articles nil t))
|
2008-01-20 05:17:57 +00:00
|
|
|
|
|
|
|
|
(defun gnus-registry-remove-article-mark (&rest articles)
|
|
|
|
|
"Remove a mark from process-marked ARTICLES."
|
|
|
|
|
(interactive (gnus-summary-work-articles current-prefix-arg))
|
2011-04-05 22:35:05 +00:00
|
|
|
(gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
|
|
|
|
|
articles t t))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-set-article-mark-internal (mark
|
|
|
|
|
articles
|
|
|
|
|
&optional remove
|
|
|
|
|
show-message)
|
|
|
|
|
"Apply or remove MARK across a list of ARTICLES."
|
2008-01-20 05:17:57 +00:00
|
|
|
(let ((article-id-list
|
2011-04-05 22:35:05 +00:00
|
|
|
(mapcar 'gnus-registry-fetch-message-id-fast articles)))
|
2008-01-20 05:17:57 +00:00
|
|
|
(dolist (id article-id-list)
|
2011-04-05 22:35:05 +00:00
|
|
|
(let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
|
|
|
|
|
(marks (if remove marks (cons mark marks))))
|
|
|
|
|
(when show-message
|
|
|
|
|
(gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
|
|
|
|
|
(if remove "Removing" "Adding")
|
|
|
|
|
mark id marks))
|
|
|
|
|
(gnus-registry-set-id-key id 'mark marks)))))
|
2008-01-20 05:17:57 +00:00
|
|
|
|
|
|
|
|
(defun gnus-registry-get-article-marks (&rest articles)
|
|
|
|
|
"Get the Gnus registry marks for ARTICLES and show them if interactive.
|
|
|
|
|
Uses process/prefix conventions. For multiple articles,
|
|
|
|
|
only the last one's marks are returned."
|
|
|
|
|
(interactive (gnus-summary-work-articles 1))
|
2011-04-05 22:35:05 +00:00
|
|
|
(let* ((article (last articles))
|
|
|
|
|
(id (gnus-registry-fetch-message-id-fast article))
|
|
|
|
|
(marks (when id (gnus-registry-get-id-key id 'mark))))
|
2008-01-20 05:17:57 +00:00
|
|
|
(when (interactive-p)
|
2011-04-05 22:35:05 +00:00
|
|
|
(gnus-message 1 "Marks are %S" marks))
|
2008-01-20 05:17:57 +00:00
|
|
|
marks))
|
|
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
(defun gnus-registry-group-count (id)
|
|
|
|
|
"Get the number of groups of a message, based on the message ID."
|
2011-04-05 22:35:05 +00:00
|
|
|
(length (gnus-registry-get-id-key id 'group)))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-get-or-make-entry (id)
|
|
|
|
|
(let* ((db gnus-registry-db)
|
|
|
|
|
;; safe if not found
|
|
|
|
|
(entries (registry-lookup db (list id))))
|
|
|
|
|
|
|
|
|
|
(when (null entries)
|
2011-05-09 22:27:17 +00:00
|
|
|
(gnus-registry-insert db id (list (list 'creation-time (current-time))
|
|
|
|
|
'(group) '(sender) '(subject)))
|
2011-04-05 22:35:05 +00:00
|
|
|
(setq entries (registry-lookup db (list id))))
|
|
|
|
|
|
|
|
|
|
(nth 1 (assoc id entries))))
|
|
|
|
|
|
2011-04-06 12:55:49 +00:00
|
|
|
(defun gnus-registry-delete-entries (idlist)
|
|
|
|
|
(registry-delete gnus-registry-db idlist nil))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(defun gnus-registry-get-id-key (id key)
|
|
|
|
|
(cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-set-id-key (id key vals)
|
|
|
|
|
(let* ((db gnus-registry-db)
|
|
|
|
|
(entry (gnus-registry-get-or-make-entry id)))
|
|
|
|
|
(registry-delete db (list id) nil)
|
|
|
|
|
(setq entry (cons (cons key vals) (assq-delete-all key entry)))
|
2011-05-09 22:27:17 +00:00
|
|
|
(gnus-registry-insert db id entry)
|
2011-04-05 22:35:05 +00:00
|
|
|
entry))
|
|
|
|
|
|
2011-05-09 22:27:17 +00:00
|
|
|
(defun gnus-registry-insert (db id entry)
|
|
|
|
|
"Just like `registry-insert' but tries to prune on error."
|
|
|
|
|
(when (registry-full db)
|
|
|
|
|
(message "Trying to prune the registry because it's full")
|
|
|
|
|
(registry-prune db))
|
|
|
|
|
(registry-insert db id entry)
|
|
|
|
|
entry)
|
|
|
|
|
|
2011-04-06 12:55:49 +00:00
|
|
|
(defun gnus-registry-import-eld (file)
|
|
|
|
|
(interactive "fOld registry file to import? ")
|
|
|
|
|
;; example content:
|
|
|
|
|
;; (setq gnus-registry-alist '(
|
|
|
|
|
;; ("<messageID>" ((marks nil)
|
|
|
|
|
;; (mtime 19365 1776 440496)
|
|
|
|
|
;; (sender . "root (Cron Daemon)")
|
|
|
|
|
;; (subject . "Cron"))
|
|
|
|
|
;; "cron" "nnml+private:cron")
|
|
|
|
|
(load file t)
|
|
|
|
|
(when (boundp 'gnus-registry-alist)
|
|
|
|
|
(let* ((old (symbol-value 'gnus-registry-alist))
|
|
|
|
|
(count 0)
|
|
|
|
|
(expected (length old))
|
|
|
|
|
entry)
|
|
|
|
|
(while (car-safe old)
|
|
|
|
|
(incf count)
|
|
|
|
|
;; don't use progress reporters for backwards compatibility
|
|
|
|
|
(when (and (< 0 expected)
|
|
|
|
|
(= 0 (mod count 100)))
|
|
|
|
|
(message "importing: %d of %d (%.2f%%)"
|
|
|
|
|
count expected (/ (* 100 count) expected)))
|
|
|
|
|
(setq entry (car-safe old)
|
|
|
|
|
old (cdr-safe old))
|
|
|
|
|
(let* ((id (car-safe entry))
|
|
|
|
|
(new-entry (gnus-registry-get-or-make-entry id))
|
|
|
|
|
(rest (cdr-safe entry))
|
|
|
|
|
(groups (loop for p in rest
|
|
|
|
|
when (stringp p)
|
|
|
|
|
collect p))
|
|
|
|
|
extra-cell key val)
|
|
|
|
|
;; remove all the strings from the entry
|
2011-04-18 22:59:02 +00:00
|
|
|
(dolist (elem rest)
|
2011-04-21 22:06:12 +00:00
|
|
|
(if (stringp elem) (setq rest (delq elem rest))))
|
2011-04-06 12:55:49 +00:00
|
|
|
(gnus-registry-set-id-key id 'group groups)
|
|
|
|
|
;; just use the first extra element
|
|
|
|
|
(setq rest (car-safe rest))
|
|
|
|
|
(while (car-safe rest)
|
|
|
|
|
(setq extra-cell (car-safe rest)
|
|
|
|
|
key (car-safe extra-cell)
|
|
|
|
|
val (cdr-safe extra-cell)
|
|
|
|
|
rest (cdr-safe rest))
|
|
|
|
|
(when (and val (atom val))
|
|
|
|
|
(setq val (list val)))
|
|
|
|
|
(gnus-registry-set-id-key id key val))))
|
|
|
|
|
(message "Import done, collected %d entries" count))))
|
2011-04-05 22:35:05 +00:00
|
|
|
|
2011-04-16 06:56:17 +00:00
|
|
|
(ert-deftest gnus-registry-misc-test ()
|
|
|
|
|
(should-error (gnus-registry-extract-addresses '("" "")))
|
|
|
|
|
|
|
|
|
|
(should (equal '("Ted Zlatanov <tzz@lifelogs.com>"
|
|
|
|
|
"noname <ed@you.me>"
|
|
|
|
|
"noname <cyd@stupidchicken.com>"
|
|
|
|
|
"noname <tzz@lifelogs.com>")
|
|
|
|
|
(gnus-registry-extract-addresses
|
|
|
|
|
(concat "Ted Zlatanov <tzz@lifelogs.com>, "
|
|
|
|
|
"ed <ed@you.me>, " ; "ed" is not a valid name here
|
|
|
|
|
"cyd@stupidchicken.com, "
|
|
|
|
|
"tzz@lifelogs.com")))))
|
|
|
|
|
|
2011-04-05 22:35:05 +00:00
|
|
|
(ert-deftest gnus-registry-usage-test ()
|
|
|
|
|
(let* ((n 100)
|
|
|
|
|
(tempfile (make-temp-file "gnus-registry-persist"))
|
|
|
|
|
(db (gnus-registry-make-db tempfile))
|
|
|
|
|
(gnus-registry-db db)
|
|
|
|
|
back size)
|
|
|
|
|
(message "Adding %d keys to the test Gnus registry" n)
|
|
|
|
|
(dotimes (i n)
|
|
|
|
|
(let ((id (number-to-string i)))
|
|
|
|
|
(gnus-registry-handle-action id
|
|
|
|
|
(if (>= 50 i) "fromgroup" nil)
|
|
|
|
|
"togroup"
|
|
|
|
|
(when (>= 70 i)
|
|
|
|
|
(format "subject %d" (mod i 10)))
|
|
|
|
|
(when (>= 80 i)
|
|
|
|
|
(format "sender %d" (mod i 10))))))
|
|
|
|
|
(message "Testing Gnus registry size is %d" n)
|
|
|
|
|
(should (= n (registry-size db)))
|
|
|
|
|
(message "Looking up individual keys (registry-lookup)")
|
|
|
|
|
(should (equal (loop for e
|
|
|
|
|
in (mapcar 'cadr
|
|
|
|
|
(registry-lookup db '("20" "83" "72")))
|
|
|
|
|
collect (assq 'subject e)
|
|
|
|
|
collect (assq 'sender e)
|
|
|
|
|
collect (assq 'group e))
|
|
|
|
|
'((subject "subject 0") (sender "sender 0") (group "togroup")
|
|
|
|
|
(subject) (sender) (group "togroup")
|
|
|
|
|
(subject) (sender "sender 2") (group "togroup"))))
|
|
|
|
|
|
|
|
|
|
(message "Looking up individual keys (gnus-registry-id-key)")
|
|
|
|
|
(should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
|
|
|
|
|
(should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
|
|
|
|
|
(message "Trying to insert a duplicate key")
|
2011-05-09 22:27:17 +00:00
|
|
|
(should-error (gnus-registry-insert db "55" '()))
|
2011-04-05 22:35:05 +00:00
|
|
|
(message "Looking up individual keys (gnus-registry-get-or-make-entry)")
|
|
|
|
|
(should (gnus-registry-get-or-make-entry "22"))
|
|
|
|
|
(message "Saving the Gnus registry to %s" tempfile)
|
|
|
|
|
(should (gnus-registry-save tempfile db))
|
|
|
|
|
(setq size (nth 7 (file-attributes tempfile)))
|
|
|
|
|
(message "Saving the Gnus registry to %s: size %d" tempfile size)
|
|
|
|
|
(should (< 0 size))
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(insert-file-contents-literally tempfile)
|
|
|
|
|
(should (looking-at (concat ";; Object "
|
|
|
|
|
"Gnus Registry"
|
|
|
|
|
"\n;; EIEIO PERSISTENT OBJECT"))))
|
|
|
|
|
(message "Reading Gnus registry back")
|
|
|
|
|
(setq back (eieio-persistent-read tempfile))
|
|
|
|
|
(should back)
|
|
|
|
|
(message "Read Gnus registry back: %d keys, expected %d==%d"
|
|
|
|
|
(registry-size back) n (registry-size db))
|
|
|
|
|
(should (= (registry-size back) n))
|
|
|
|
|
(should (= (registry-size back) (registry-size db)))
|
|
|
|
|
(delete-file tempfile)
|
|
|
|
|
(message "Pruning Gnus registry to 0 by setting :max-soft")
|
|
|
|
|
(oset db :max-soft 0)
|
|
|
|
|
(registry-prune db)
|
|
|
|
|
(should (= (registry-size db) 0)))
|
|
|
|
|
(message "Done with Gnus registry usage testing."))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun gnus-registry-initialize ()
|
2008-03-10 00:50:22 +00:00
|
|
|
"Initialize the Gnus registry."
|
2004-09-04 13:13:48 +00:00
|
|
|
(interactive)
|
2008-03-10 00:50:22 +00:00
|
|
|
(gnus-message 5 "Initializing the registry")
|
2004-09-04 13:13:48 +00:00
|
|
|
(gnus-registry-install-hooks)
|
2008-03-10 00:50:22 +00:00
|
|
|
(gnus-registry-install-shortcuts)
|
2004-09-04 13:13:48 +00:00
|
|
|
(gnus-registry-read))
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun gnus-registry-install-hooks ()
|
|
|
|
|
"Install the registry hooks."
|
|
|
|
|
(interactive)
|
2011-10-17 22:51:37 +00:00
|
|
|
(setq gnus-registry-enabled t)
|
2005-02-09 15:50:47 +00:00
|
|
|
(add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
|
2004-09-04 13:13:48 +00:00
|
|
|
(add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
|
|
|
|
|
(add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
|
|
|
|
|
(add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
|
2005-02-09 15:50:47 +00:00
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
(add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
|
|
|
|
|
(add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
|
|
|
|
|
|
|
|
|
|
(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
|
|
|
|
|
|
|
|
|
|
(defun gnus-registry-unload-hook ()
|
|
|
|
|
"Uninstall the registry hooks."
|
|
|
|
|
(interactive)
|
2005-02-09 15:50:47 +00:00
|
|
|
(remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
|
2004-09-04 13:13:48 +00:00
|
|
|
(remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
|
|
|
|
|
(remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
|
|
|
|
|
(remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
|
2005-02-09 15:50:47 +00:00
|
|
|
|
2004-09-04 13:13:48 +00:00
|
|
|
(remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
|
|
|
|
|
(remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
|
|
|
|
|
|
2011-10-17 22:51:37 +00:00
|
|
|
(remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
|
|
|
|
|
(setq gnus-registry-enabled nil))
|
2004-09-04 13:13:48 +00:00
|
|
|
|
2004-10-17 07:11:15 +00:00
|
|
|
(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
|
|
|
|
|
|
2008-03-10 00:50:22 +00:00
|
|
|
(defun gnus-registry-install-p ()
|
2011-10-17 22:51:37 +00:00
|
|
|
"If the registry is not already enabled, and `gnus-registry-install' is t,
|
|
|
|
|
the registry is enabled. If `gnus-registry-install' is `ask',
|
|
|
|
|
the user is asked first. Returns non-nil iff the registry is enabled."
|
2008-03-10 00:50:22 +00:00
|
|
|
(interactive)
|
2011-10-17 22:51:37 +00:00
|
|
|
(unless gnus-registry-enabled
|
|
|
|
|
(when (if (eq gnus-registry-install 'ask)
|
|
|
|
|
(gnus-y-or-n-p
|
|
|
|
|
(concat "Enable the Gnus registry? "
|
|
|
|
|
"See the variable `gnus-registry-install' "
|
|
|
|
|
"to get rid of this query permanently. "))
|
|
|
|
|
gnus-registry-install)
|
2008-03-10 00:50:22 +00:00
|
|
|
(gnus-registry-initialize)))
|
2011-10-17 22:51:37 +00:00
|
|
|
gnus-registry-enabled)
|
2008-03-10 00:50:22 +00:00
|
|
|
|
|
|
|
|
;; TODO: a few things
|
2004-09-04 13:13:48 +00:00
|
|
|
|
|
|
|
|
(provide 'gnus-registry)
|
|
|
|
|
|
|
|
|
|
;;; gnus-registry.el ends here
|