diff options
Diffstat (limited to 'lisp/gnus/gnus-registry.el')
| -rw-r--r-- | lisp/gnus/gnus-registry.el | 200 |
1 files changed, 121 insertions, 79 deletions
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 2803cd9db6d..5141a5e2d32 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -80,20 +80,20 @@ (defcustom gnus-registry-marks '((Important - (char . ?i) - (image . "summary_important")) + :char ?i + :image "summary_important") (Work - (char . ?w) - (image . "summary_work")) + :char ?w + :image "summary_work") (Personal - (char . ?p) - (image . "summary_personal")) + :char ?p + :image "summary_personal") (To-Do - (char . ?t) - (image . "summary_todo")) + :char ?t + :image "summary_todo") (Later - (char . ?l) - (image . "summary_later"))) + :char ?l + :image "summary_later")) "List of registry marks and their options. @@ -106,14 +106,16 @@ line display and for keyboard shortcuts. Each entry must have an image string to be useful for visual display." :group 'gnus-registry - :type '(alist :key-type symbol - :value-type (set :tag "Mark details" - (cons :tag "Shortcut" - (const :tag "Character code" char) - character) - (cons :tag "Visual" - (const :tag "Image" image) - string)))) + :type '(repeat :tag "Registry Marks" + (cons :tag "Mark" + (symbol :tag "Name") + (checklist :tag "Options" :greedy t + (group :inline t + (const :format "" :value :char) + (character :tag "Character code")) + (group :inline t + (const :format "" :value :image) + (string :tag "Image")))))) (defcustom gnus-registry-default-mark 'To-Do "The default mark. Should be a valid key for `gnus-registry-marks'." @@ -130,10 +132,12 @@ references.'" :group 'gnus-registry :type '(repeat regexp)) -(defcustom gnus-registry-install nil +(defcustom gnus-registry-install 'ask "Whether the registry should be installed." :group 'gnus-registry - :type 'boolean) + :type '(choice (const :tag "Never Install" nil) + (const :tag "Always Install" t) + (const :tag "Ask Me" ask))) (defcustom gnus-registry-clean-empty t "Whether the empty registry entries should be deleted. @@ -700,24 +704,22 @@ Consults `gnus-registry-unfollowed-groups' and FUNCTION should take two parameters, a mark symbol and the cell value." (dolist (mark-info gnus-registry-marks) - (let ((mark (car-safe mark-info)) - (data (cdr-safe mark-info))) - (dolist (cell data) - (let ((cell-type (car-safe cell)) - (cell-data (cdr-safe cell))) - (when (equal type cell-type) - (funcall function mark cell-data))))))) + (let* ((mark (car-safe mark-info)) + (data (cdr-safe mark-info)) + (cell-data (plist-get data type))) + (when cell-data + (funcall function mark cell-data))))) ;;; this is ugly code, but I don't know how to do it better -;;; TODO: clear the gnus-registry-mark-map before running -(defun gnus-registry-install-shortcuts-and-menus () +(defun gnus-registry-install-shortcuts () "Install the keyboard shortcuts and menus for the registry. Uses `gnus-registry-marks' to find what shortcuts to install." - (gnus-registry-do-marks - 'char - (lambda (mark data) - (let ((function-format - (format "gnus-registry-%%s-article-%s-mark" mark))) + (let (keys-plist) + (gnus-registry-do-marks + :char + (lambda (mark data) + (let ((function-format + (format "gnus-registry-%%s-article-%s-mark" mark))) ;;; The following generates these functions: ;;; (defun gnus-registry-set-article-Important-mark (&rest articles) @@ -729,44 +731,69 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) ;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) - (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) - (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 - (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)))))))) - ;; I don't know how to do this inside the loop above, because - ;; gnus-define-keys is a macro - (gnus-define-keys (gnus-registry-mark-map "M" gnus-summary-mark-map) - "i" gnus-registry-set-article-Important-mark - "I" gnus-registry-remove-article-Important-mark - "w" gnus-registry-set-article-Work-mark - "W" gnus-registry-remove-article-Work-mark - "l" gnus-registry-set-article-Later-mark - "L" gnus-registry-remove-article-Later-mark - "p" gnus-registry-set-article-Personal-mark - "P" gnus-registry-remove-article-Personal-mark - "t" gnus-registry-set-article-To-Do-mark - "T" gnus-registry-remove-article-To-Do-mark)) + (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) + (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 + (when (eq gnus-registry-install nil) + (setq gnus-registry-install 'ask)) + + ;; 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) + (dolist (article articles) + (gnus-summary-update-article + article + (assoc article (gnus-data-list nil))))))) + (push (intern function-name) keys-plist) + (push shortcut keys-plist) + (gnus-message + 9 + "Defined mark handling function %s" + function-name)))))) + (gnus-define-keys-1 + '(gnus-registry-mark-map "M" gnus-summary-mark-map) + keys-plist))) + +;;; use like this: +;;; (defalias 'gnus-user-format-function-M +;;; 'gnus-registry-user-format-function-M) +(defun gnus-registry-user-format-function-M (headers) + (let* ((id (mail-header-message-id headers)) + (marks (when id (gnus-registry-fetch-extra-marks id)))) + (apply 'concat (mapcar (lambda(mark) + (let ((c + (plist-get + (cdr-safe + (assoc mark gnus-registry-marks)) + :char))) + (if c + (list c) + nil))) + marks)))) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." @@ -1033,10 +1060,12 @@ Returns the first place where the trail finds a group name." ;;;###autoload (defun gnus-registry-initialize () +"Initialize the Gnus registry." (interactive) - (setq gnus-registry-install t) + (gnus-message 5 "Initializing the registry") + (setq gnus-registry-install t) ; in case it was 'ask or nil (gnus-registry-install-hooks) - (gnus-registry-install-shortcuts-and-menus) + (gnus-registry-install-shortcuts) (gnus-registry-read)) ;;;###autoload @@ -1068,11 +1097,24 @@ Returns the first place where the trail finds a group name." (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) -(when gnus-registry-install - (gnus-registry-install-hooks) - (gnus-registry-read)) - -;; TODO: a lot of things +(defun gnus-registry-install-p () + (interactive) + (when (eq gnus-registry-install 'ask) + (setq gnus-registry-install + (gnus-y-or-n-p + (concat "Enable the Gnus registry? " + "See the variable `gnus-registry-install' " + "to get rid of this query permanently. "))) + (when gnus-registry-install + ;; we just set gnus-registry-install to t, so initialize the registry! + (gnus-registry-initialize))) +;;; we could call it here: (customize-variable 'gnus-registry-install) + gnus-registry-install) + +(when (gnus-registry-install-p) + (gnus-registry-initialize)) + +;; TODO: a few things (provide 'gnus-registry) |