projects
/
gnus
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Revision: miles@gnu.org--gnu-2005/gnus--devo--0--patch-37
[gnus]
/
lisp
/
gnus-registry.el
diff --git
a/lisp/gnus-registry.el
b/lisp/gnus-registry.el
index
4fcc7cd
..
879b670
100644
(file)
--- a/
lisp/gnus-registry.el
+++ b/
lisp/gnus-registry.el
@@
-1,5
+1,5
@@
;;; gnus-registry.el --- article registry for Gnus
;;; gnus-registry.el --- article registry for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
, 2004
;; Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
;; Free Software Foundation, Inc.
;; Author: Ted Zlatanov <tzz@lifelogs.com>
@@
-66,9
+66,12
@@
(defgroup gnus-registry nil
"The Gnus registry."
(defgroup gnus-registry nil
"The Gnus registry."
+ :version "22.1"
:group 'gnus)
:group 'gnus)
-(defvar gnus-registry-hashtb nil
+(defvar gnus-registry-hashtb (make-hash-table
+ :size 256
+ :test 'equal)
"*The article registry by Message ID.")
(defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
"*The article registry by Message ID.")
(defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
@@
-99,7
+102,7
@@
and no extra data."
The Subject and Sender (From:) headers are currently tracked this
way."
:group 'gnus-registry
The Subject and Sender (From:) headers are currently tracked this
way."
:group 'gnus-registry
- :type
+ :type
'(set :tag "Tracking choices"
(const :tag "Track by subject (Subject: header)" subject)
(const :tag "Track by sender (From: header)" sender)))
'(set :tag "Tracking choices"
(const :tag "Track by subject (Subject: header)" subject)
(const :tag "Track by sender (From: header)" sender)))
@@
-131,7
+134,7
@@
way."
"Maximum number of entries in the registry, nil for unlimited."
:group 'gnus-registry
:type '(radio (const :format "Unlimited " nil)
"Maximum number of entries in the registry, nil for unlimited."
:group 'gnus-registry
:type '(radio (const :format "Unlimited " nil)
- (integer :format "Maximum number: %v
\n" :size 0
)))
+ (integer :format "Maximum number: %v
"
)))
(defun gnus-registry-track-subject-p ()
(memq 'subject gnus-registry-track-extra))
(defun gnus-registry-track-subject-p ()
(memq 'subject gnus-registry-track-extra))
@@
-184,12
+187,12
@@
way."
"%s#tmp#%d"))
working-dir (setq i (1+ i))))
(file-exists-p working-file)))
"%s#tmp#%d"))
working-dir (setq i (1+ i))))
(file-exists-p working-file)))
-
+
(unwind-protect
(progn
(gnus-with-output-to-file working-file
(gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
(unwind-protect
(progn
(gnus-with-output-to-file working-file
(gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
-
+
;; These bindings will mislead the current buffer
;; into thinking that it is visiting the startup
;; file.
;; These bindings will mislead the current buffer
;; into thinking that it is visiting the startup
;; file.
@@
-199,14
+202,14
@@
way."
(setmodes (file-modes startup-file)))
;; Backup the current version of the startup file.
(backup-buffer)
(setmodes (file-modes startup-file)))
;; Backup the current version of the startup file.
(backup-buffer)
-
+
;; Replace the existing startup file with the temp file.
(rename-file working-file startup-file t)
(gnus-set-file-modes startup-file setmodes)))
(condition-case nil
(delete-file working-file)
(file-error nil)))))
;; Replace the existing startup file with the temp file.
(rename-file working-file startup-file t)
(gnus-set-file-modes startup-file setmodes)))
(condition-case nil
(delete-file working-file)
(file-error nil)))))
-
+
(gnus-kill-buffer (current-buffer))
(gnus-message 5 "Saving %s...done" file))))
(gnus-kill-buffer (current-buffer))
(gnus-message 5 "Saving %s...done" file))))
@@
-234,10
+237,10
@@
way."
(remhash key gnus-registry-hashtb)))
gnus-registry-hashtb)
;; remove empty entries
(remhash key gnus-registry-hashtb)))
gnus-registry-hashtb)
;; remove empty entries
- (when gnus-registry-clean-empty
+ (when gnus-registry-clean-empty
(gnus-registry-clean-empty-function))
;; now trim the registry appropriately
(gnus-registry-clean-empty-function))
;; now trim the registry appropriately
- (setq gnus-registry-alist (gnus-registry-trim
+ (setq gnus-registry-alist (gnus-registry-trim
(hashtable-to-alist gnus-registry-hashtb)))
;; really save
(gnus-registry-cache-save)
(hashtable-to-alist gnus-registry-hashtb)))
;; really save
(gnus-registry-cache-save)
@@
-267,16
+270,16
@@
way."
(defun gnus-registry-trim (alist)
"Trim alist to size, using gnus-registry-max-entries."
(if (null gnus-registry-max-entries)
(defun gnus-registry-trim (alist)
"Trim alist to size, using gnus-registry-max-entries."
(if (null gnus-registry-max-entries)
- alist ; just return the alist
+ alist
; just return the alist
;; else, when given max-entries, trim the alist
(let* ((timehash (make-hash-table
;; else, when given max-entries, trim the alist
(let* ((timehash (make-hash-table
- :size 4096
- :test 'equal))
- (trim-length (- (length alist) gnus-registry-max-entries))
- (trim-length (if (natnump trim-length) trim-length 0)))
+
:size 4096
+
:test 'equal))
+
(trim-length (- (length alist) gnus-registry-max-entries))
+
(trim-length (if (natnump trim-length) trim-length 0)))
(maphash
(lambda (key value)
(maphash
(lambda (key value)
- (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
+
(puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
gnus-registry-hashtb)
;; we use the return value of this setq, which is the trimmed alist
gnus-registry-hashtb)
;; we use the return value of this setq, which is the trimmed alist
@@
-291,7
+294,7
@@
way."
(defun alist-to-hashtable (alist)
"Build a hashtable from the values in ALIST."
(defun alist-to-hashtable (alist)
"Build a hashtable from the values in ALIST."
- (let ((ht (make-hash-table
+ (let ((ht (make-hash-table
:size 4096
:test 'equal)))
(mapc
:size 4096
:test 'equal)))
(mapc
@@
-311,7
+314,7
@@
way."
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
- (subject (gnus-registry-simplify-subject
+ (subject (gnus-registry-simplify-subject
(mail-header-subject data-header)))
(sender (mail-header-from data-header))
(from (gnus-group-guess-full-name-from-command-method from))
(mail-header-subject data-header)))
(sender (mail-header-from data-header))
(from (gnus-group-guess-full-name-from-command-method from))
@@
-327,7
+330,7
@@
way."
;; All except copy will need a delete
(gnus-registry-delete-group id from)
;; All except copy will need a delete
(gnus-registry-delete-group id from)
- (when (equal 'copy action)
+ (when (equal 'copy action)
(gnus-registry-add-group id from subject sender)) ; undo the delete
(gnus-registry-add-group id to subject sender)))
(gnus-registry-add-group id from subject sender)) ; undo the delete
(gnus-registry-add-group id to subject sender)))
@@
-347,7
+350,7
@@
way."
"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
"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
-this: (: gnus-registry-split-fancy-with-parent)
+this: (: gnus-registry-split-fancy-with-parent)
This function tracks ALL backends, unlike
`nnmail-split-fancy-with-parent' which tracks only nnmail
This function tracks ALL backends, unlike
`nnmail-split-fancy-with-parent' which tracks only nnmail
@@
-369,15
+372,16
@@
See the Info node `(gnus)Fancy Mail Splitting' for more details."
nnmail-split-fancy-with-parent-ignore-groups
(list nnmail-split-fancy-with-parent-ignore-groups)))
references res)
nnmail-split-fancy-with-parent-ignore-groups
(list nnmail-split-fancy-with-parent-ignore-groups)))
references res)
- (if refstr
+ ;; the references string must be valid and parse to valid references
+ (if (and refstr (gnus-extract-references refstr))
(progn
(progn
- (setq references (nreverse (gnus-
spli
t-references refstr)))
+ (setq references (nreverse (gnus-
extrac
t-references refstr)))
(mapcar (lambda (x)
(setq res (or (gnus-registry-fetch-group x) res))
(when (or (gnus-registry-grep-in-list
res
gnus-registry-unfollowed-groups)
(mapcar (lambda (x)
(setq res (or (gnus-registry-fetch-group x) res))
(when (or (gnus-registry-grep-in-list
res
gnus-registry-unfollowed-groups)
- (gnus-registry-grep-in-list
+ (gnus-registry-grep-in-list
res
nnmail-split-fancy-with-parent-ignore-groups))
(setq res nil)))
res
nnmail-split-fancy-with-parent-ignore-groups))
(setq res nil)))
@@
-417,7
+421,7
@@
See the Info node `(gnus)Fancy Mail Splitting' for more details."
(< gnus-registry-minimum-subject-length (length subject)))
(maphash
(lambda (key value)
(< gnus-registry-minimum-subject-length (length subject)))
(maphash
(lambda (key value)
- (let ((this-subject (cdr
+ (let ((this-subject (cdr
(gnus-registry-fetch-extra key 'subject))))
(when (and single-match
this-subject
(gnus-registry-fetch-extra key 'subject))))
(when (and single-match
this-subject
@@
-449,13
+453,13
@@
See the Info node `(gnus)Fancy Mail Splitting' for more details."
(when (and res gnus-registry-use-long-group-names)
(let ((m1 (gnus-find-method-for-group res))
(when (and res gnus-registry-use-long-group-names)
(let ((m1 (gnus-find-method-for-group res))
- (m2 (or gnus-command-method
+ (m2 (or gnus-command-method
(gnus-find-method-for-group gnus-newsgroup-name)))
(short-res (gnus-group-short-name res)))
(if (gnus-methods-equal-p m1 m2)
(progn
(gnus-message
(gnus-find-method-for-group gnus-newsgroup-name)))
(short-res (gnus-group-short-name res)))
(if (gnus-methods-equal-p m1 m2)
(progn
(gnus-message
- 9
+ 9
"gnus-registry-split-fancy-with-parent stripped group %s to %s"
res
short-res)
"gnus-registry-split-fancy-with-parent stripped group %s to %s"
res
short-res)
@@
-474,9
+478,9
@@
See the Info node `(gnus)Fancy Mail Splitting' for more details."
(dolist (article gnus-newsgroup-articles)
(let ((id (gnus-registry-fetch-message-id-fast article)))
(unless (gnus-registry-fetch-group id)
(dolist (article gnus-newsgroup-articles)
(let ((id (gnus-registry-fetch-message-id-fast article)))
(unless (gnus-registry-fetch-group id)
- (gnus-message 9 "Registry: Registering article %d with group %s"
+ (gnus-message 9 "Registry: Registering article %d with group %s"
article gnus-newsgroup-name)
article gnus-newsgroup-name)
- (gnus-registry-add-group
+ (gnus-registry-add-group
(gnus-registry-fetch-message-id-fast article)
gnus-newsgroup-name
(gnus-registry-fetch-simplified-message-subject-fast article)
(gnus-registry-fetch-message-id-fast article)
gnus-newsgroup-name
(gnus-registry-fetch-simplified-message-subject-fast article)
@@
-515,7
+519,7
@@
See the Info node `(gnus)Fancy Mail Splitting' for more details."
(when word
(memq nil
(mapcar 'not
(when word
(memq nil
(mapcar 'not
- (mapcar
+ (mapcar
(lambda (x)
(string-match x word))
list)))))
(lambda (x)
(string-match x word))
list)))))
@@
-551,7
+555,7
@@
Update the entry cache if needed."
;; get the entree from the hash table or from the alist
(setq entree (gethash id entry-cache)))
;; get the entree from the hash table or from the alist
(setq entree (gethash id entry-cache)))
-
+
(unless entree
(setq entree (assq entry alist))
(when gnus-registry-entry-caching
(unless entree
(setq entree (assq entry alist))
(when gnus-registry-entry-caching
@@
-592,8
+596,8
@@
Returns the first place where the trail finds a group name."
(let ((trail (gethash id gnus-registry-hashtb)))
(dolist (crumb trail)
(when (stringp crumb)
(let ((trail (gethash id gnus-registry-hashtb)))
(dolist (crumb trail)
(when (stringp crumb)
- (return (if gnus-registry-use-long-group-names
- crumb
+ (return (if gnus-registry-use-long-group-names
+ crumb
(gnus-group-short-name crumb))))))))
(defun gnus-registry-group-count (id)
(gnus-group-short-name crumb))))))))
(defun gnus-registry-group-count (id)
@@
-617,7
+621,9
@@
Returns the first place where the trail finds a group name."
(when gnus-registry-trim-articles-without-groups
(unless (gnus-registry-group-count id)
(gnus-registry-delete-id id)))
(when gnus-registry-trim-articles-without-groups
(unless (gnus-registry-group-count id)
(gnus-registry-delete-id id)))
- (gnus-registry-store-extra-entry id 'mtime (current-time)))))
+ ;; is this ID still in the registry?
+ (when (gethash id gnus-registry-hashtb)
+ (gnus-registry-store-extra-entry id 'mtime (current-time))))))
(defun gnus-registry-delete-id (id)
"Delete a message ID from the registry."
(defun gnus-registry-delete-id (id)
"Delete a message ID from the registry."
@@
-635,8
+641,8
@@
Returns the first place where the trail finds a group name."
(when (and id
(not (string-match "totally-fudged-out-message-id" id)))
(let ((full-group group)
(when (and id
(not (string-match "totally-fudged-out-message-id" id)))
(let ((full-group group)
- (group (if gnus-registry-use-long-group-names
- group
+ (group (if gnus-registry-use-long-group-names
+ group
(gnus-group-short-name group))))
(gnus-registry-delete-group id group)
(gnus-group-short-name group))))
(gnus-registry-delete-group id group)
@@
-652,16
+658,16
@@
Returns the first place where the trail finds a group name."
(when (and (gnus-registry-track-subject-p)
subject)
(gnus-registry-store-extra-entry
(when (and (gnus-registry-track-subject-p)
subject)
(gnus-registry-store-extra-entry
- id
- 'subject
+ id
+ 'subject
(gnus-registry-simplify-subject subject)))
(when (and (gnus-registry-track-sender-p)
sender)
(gnus-registry-store-extra-entry
(gnus-registry-simplify-subject subject)))
(when (and (gnus-registry-track-sender-p)
sender)
(gnus-registry-store-extra-entry
- id
+ id
'sender
sender))
'sender
sender))
-
+
(gnus-registry-store-extra-entry id 'mtime (current-time)))))))
(defun gnus-registry-clear ()
(gnus-registry-store-extra-entry id 'mtime (current-time)))))))
(defun gnus-registry-clear ()
@@
-682,11
+688,11
@@
Returns the first place where the trail finds a group name."
(defun gnus-registry-install-hooks ()
"Install the registry hooks."
(interactive)
(defun gnus-registry-install-hooks ()
"Install the registry hooks."
(interactive)
- (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
+ (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
(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)
(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)
-
+
(add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
(add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
(add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
(add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
@@
-695,16
+701,18
@@
Returns the first place where the trail finds a group name."
(defun gnus-registry-unload-hook ()
"Uninstall the registry hooks."
(interactive)
(defun gnus-registry-unload-hook ()
"Uninstall the registry hooks."
(interactive)
- (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
+ (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
(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)
(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)
-
+
(remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
(remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
(remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
(remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
(remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
(remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
+
(when gnus-registry-install
(gnus-registry-install-hooks)
(gnus-registry-read))
(when gnus-registry-install
(gnus-registry-install-hooks)
(gnus-registry-read))