(require 'gnus-sum)
(require 'nnmail)
+(defvar gnus-registry-dirty t
+ "Boolean set to t when the registry is modified")
+
(defgroup gnus-registry nil
"The Gnus registry."
:group 'gnus)
:group 'gnus-registry
:type 'boolean)
+(defcustom gnus-registry-use-long-group-names nil
+ "Whether the registry should use long group names (BUGGY)."
+ :group 'gnus-registry
+ :type 'boolean)
+
+(defcustom gnus-registry-trim-articles-without-groups t
+ "Whether the registry should clean out message IDs without groups."
+ :group 'gnus-registry
+ :type 'boolean)
+
(defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
"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 'integer)
+
;; Function(s) missing in Emacs 20
(when (memq nil (mapcar 'fboundp '(puthash)))
(require 'cl)
(interactive)
(let ((file gnus-registry-cache-file))
(save-excursion
- ;; Save .newsrc.eld.
(set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
(make-local-variable 'version-control)
(setq version-control gnus-backup-startup-file)
(while (re-search-forward " $" nil t)
(replace-match "" t t))))
-(defun gnus-registry-save ()
- (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb))
- (gnus-registry-cache-save))
+(defun gnus-registry-save (&optional force)
+;; TODO: delete entries with 0 groups
+ (when (or gnus-registry-dirty force)
+ (setq gnus-registry-alist (gnus-registry-trim
+ (hashtable-to-alist gnus-registry-hashtb)))
+ (gnus-registry-cache-save)
+ (setq gnus-registry-dirty nil)))
(defun gnus-registry-read ()
(gnus-registry-cache-read)
- (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
+ (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+ (setq gnus-registry-dirty nil))
+
+(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
+ ;; else, when given max-entries, trim the alist
+ (let ((timehash (make-hash-table
+ :size 4096
+ :test 'equal)))
+ (maphash
+ (lambda (key value)
+ (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
+ (setq alist
+ (nthcdr
+ (- (length alist) gnus-registry-max-entries)
+ (sort alist
+ (lambda (a b)
+ (time-less-p
+ (cdr (gethash (car a) timehash))
+ (cdr (gethash (car b) timehash))))))))))
(defun alist-to-hashtable (alist)
"Build a hashtable from the values in ALIST."
(let ((trail (gethash id gnus-registry-hashtb))
(old-extra (gnus-registry-fetch-extra id)))
(puthash id (cons extra (delete old-extra trail))
- gnus-registry-hashtb))))
+ gnus-registry-hashtb)
+ (setq gnus-registry-dirty t))))
(defun gnus-registry-store-extra-entry (id key value)
"Put a specific entry in the extras field of the registry entry for id."
(let* ((extra (gnus-registry-fetch-extra id))
(alist (cons (cons key value)
- (assq-delete-all key (gnus-registry-fetch-extra id)))))
+ (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
(gnus-registry-store-extra id alist)))
(defun gnus-registry-fetch-group (id)
(let ((trail (gethash id gnus-registry-hashtb)))
(dolist (crumb trail)
(when (stringp crumb)
- (return crumb))))))
+ (return (gnus-group-short-name crumb)))))))
(defun gnus-registry-group-count (id)
"Get the number of groups of a message, based on the message ID."
nil)
gnus-registry-hashtb))
;; now, clear the entry if there are no more groups
- (unless (gnus-registry-group-count id)
- (remhash id gnus-registry-hashtb))
+ (when gnus-registry-trim-articles-without-groups
+ (unless (gnus-registry-group-count id)
+ (remhash id gnus-registry-hashtb)))
(gnus-registry-store-extra-entry id 'mtime (current-time)))))
(defun gnus-registry-add-group (id group &rest extra)
(when group
(when (and id
(not (string-match "totally-fudged-out-message-id" id)))
- (let ((group (gnus-group-short-name group)))
- (gnus-registry-delete-group id group)
+ (let ((full-group group)
+ (group (if gnus-registry-use-long-group-names
+ group
+ (gnus-group-short-name group))))
+ (gnus-registry-delete-group id group)
+ (unless gnus-registry-use-long-group-names
+ (gnus-registry-delete-group id full-group))
(let ((trail (gethash id gnus-registry-hashtb)))
(puthash id (if trail
(cons group trail)
"Clear the Gnus registry."
(interactive)
(setq gnus-registry-alist nil)
- (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
+ (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+ (setq gnus-registry-dirty t))
(defun gnus-registry-install-hooks ()
"Install the registry hooks."
(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+(defun gnus-registry-unload-hook ()
+ "Uninstall the registry hooks."
+ (interactive)
+ (remove-hook 'gnus-summary-article-move-hook 'gnus-register-action)
+ (remove-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
+ (remove-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
+ (remove-hook 'nnmail-spool-hook 'gnus-register-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))
+
(when gnus-registry-install
(gnus-registry-install-hooks))
projects / gnus / blobdiff