Mercurial > emacs
changeset 110799:d2b45bb936b6
gnus-int.el, gnus-util.el: Gnus hooks for the mark get/set operations.
gnus-sync.el: Update docs to explain state and plans.
auth-source.el: Update docs with TODO items.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Thu, 07 Oct 2010 03:49:38 +0000 |
| parents | 908c176ec969 |
| children | 751b2ae689b5 |
| files | lisp/gnus/ChangeLog lisp/gnus/auth-source.el lisp/gnus/gnus-int.el lisp/gnus/gnus-sync.el lisp/gnus/gnus-util.el |
| diffstat | 5 files changed, 257 insertions(+), 212 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/gnus/ChangeLog Wed Oct 06 19:42:30 2010 -0700 +++ b/lisp/gnus/ChangeLog Thu Oct 07 03:49:38 2010 +0000 @@ -1,3 +1,16 @@ +2010-10-07 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el: Update docs with TODO items. + + * gnus-sync.el: Update docs to explain state and plans. + + * gnus-int.el (gnus-after-set-mark-hook, gnus-before-update-mark-hook): + Hooks for mark updates. + (gnus-request-set-mark, gnus-request-update-mark): Use them. + + * gnus-util.el (gnus-run-hooks-with-args): Convenience function to run + hooks with arguments, which is needed for mark update hooks. + 2010-10-06 Julien Danjou <julien@danjou.info> * sieve-manage.el: Update example in `Commentary'.
--- a/lisp/gnus/auth-source.el Wed Oct 06 19:42:30 2010 -0700 +++ b/lisp/gnus/auth-source.el Thu Oct 07 03:49:38 2010 +0000 @@ -29,6 +29,14 @@ ;; See the auth.info Info documentation for details. +;; TODO: + +;; - never decode the backend file unless it's necessary +;; - a more generic way to match backends and search backend contents +;; - absorb netrc.el and simplify it +;; - protect passwords better +;; - allow creating and changing netrc lines (not files) e.g. change a password + ;;; Code: (require 'gnus-util) @@ -49,29 +57,29 @@ :group 'gnus) (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993") - (pop3 "pop3" "pop" "pop3s" "110" "995") - (ssh "ssh" "22") - (sftp "sftp" "115") - (smtp "smtp" "25")) + (pop3 "pop3" "pop" "pop3s" "110" "995") + (ssh "ssh" "22") + (sftp "sftp" "115") + (smtp "smtp" "25")) "List of authentication protocols and their names" :group 'auth-source :version "23.2" ;; No Gnus :type '(repeat :tag "Authentication Protocols" - (cons :tag "Protocol Entry" - (symbol :tag "Protocol") - (repeat :tag "Names" - (string :tag "Name"))))) + (cons :tag "Protocol Entry" + (symbol :tag "Protocol") + (repeat :tag "Names" + (string :tag "Name"))))) ;;; generate all the protocols in a format Customize can use ;;; TODO: generate on the fly from auth-source-protocols (defconst auth-source-protocols-customize (mapcar (lambda (a) - (let ((p (car-safe a))) - (list 'const - :tag (upcase (symbol-name p)) - p))) - auth-source-protocols)) + (let ((p (car-safe a))) + (list 'const + :tag (upcase (symbol-name p)) + p))) + auth-source-protocols)) (defvar auth-source-cache (make-hash-table :test 'equal) "Cache for auth-source data") @@ -94,11 +102,11 @@ that function using the same arguments as `message'." :group 'auth-source :version "23.2" ;; No Gnus - :type `(choice - :tag "auth-source debugging mode" - (const :tag "Log using `message' to the *Messages* buffer" t) - (function :tag "Function that takes arguments like `message'") - (const :tag "Don't log anything" nil))) + :type `(choice + :tag "auth-source debugging mode" + (const :tag "Log using `message' to the *Messages* buffer" t) + (function :tag "Function that takes arguments like `message'") + (const :tag "Don't log anything" nil))) (defcustom auth-source-hide-passwords t "Whether auth-source should hide passwords in log messages. @@ -108,7 +116,7 @@ :type `boolean) (defcustom auth-sources '((:source "~/.authinfo.gpg") - (:source "~/.authinfo")) + (:source "~/.authinfo")) "List of authentication sources. The default will get login and password information from a .gpg @@ -122,34 +130,34 @@ :group 'auth-source :version "23.2" ;; No Gnus :type `(repeat :tag "Authentication Sources" - (list :tag "Source definition" - (const :format "" :value :source) - (choice :tag "Authentication backend choice" - (string :tag "Authentication Source (file)") - (list :tag "secrets.el (Secret Service API/KWallet/GNOME Keyring)" + (list :tag "Source definition" + (const :format "" :value :source) + (choice :tag "Authentication backend choice" + (string :tag "Authentication Source (file)") + (list :tag "secrets.el (Secret Service API/KWallet/GNOME Keyring)" (const :format "" :value :secrets) (choice :tag "Collection to use" (string :tag "Collection name") (const :tag "Default" 'default) (const :tag "Login" "login") (const :tag "Temporary" "session")))) - (repeat :tag "Extra Parameters" :inline t - (choice :tag "Extra parameter" - (list :tag "Host (omit to match as a fallback)" - (const :format "" :value :host) - (choice :tag "Host (machine) choice" - (const :tag "Any" t) - (regexp :tag "Host (machine) regular expression"))) - (list :tag "Protocol (omit to match as a fallback)" - (const :format "" :value :protocol) - (choice :tag "Protocol" - (const :tag "Any" t) - ,@auth-source-protocols-customize)) - (list :tag "User (omit to match as a fallback)" :inline t - (const :format "" :value :user) - (choice :tag "Personality or username" - (const :tag "Any" t) - (string :tag "Specific user name")))))))) + (repeat :tag "Extra Parameters" :inline t + (choice :tag "Extra parameter" + (list :tag "Host (omit to match as a fallback)" + (const :format "" :value :host) + (choice :tag "Host (machine) choice" + (const :tag "Any" t) + (regexp :tag "Host (machine) regular expression"))) + (list :tag "Protocol (omit to match as a fallback)" + (const :format "" :value :protocol) + (choice :tag "Protocol" + (const :tag "Any" t) + ,@auth-source-protocols-customize)) + (list :tag "User (omit to match as a fallback)" :inline t + (const :format "" :value :user) + (choice :tag "Personality or username" + (const :tag "Any" t) + (string :tag "Specific user name")))))))) ;; temp for debugging ;; (unintern 'auth-source-protocols) @@ -176,21 +184,21 @@ ;; we also check the value (when auth-source-debug (let ((logger (if (functionp auth-source-debug) - auth-source-debug - 'message))) + auth-source-debug + 'message))) (apply logger msg)))) ;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe") ;; (auth-source-pick t :host "any" :protocol 'imap :user "joe") ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe") -;; (:source (:secrets "session") :host t :protocol t :user "joe") -;; (:source (:secrets "login") :host t :protocol t) -;; (:source "~/.authinfo.gpg" :host t :protocol t))) +;; (:source (:secrets "session") :host t :protocol t :user "joe") +;; (:source (:secrets "login") :host t :protocol t) +;; (:source "~/.authinfo.gpg" :host t :protocol t))) ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe") -;; (:source (:secrets "session") :host t :protocol t :user "joe") -;; (:source (:secrets "login") :host t :protocol t) -;; )) +;; (:source (:secrets "session") :host t :protocol t :user "joe") +;; (:source (:secrets "login") :host t :protocol t) +;; )) ;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t))) @@ -200,11 +208,11 @@ the file name." (let ((source (plist-get entry :source))) (if (stringp source) - source + source ;; Secret Service API. (setq source (plist-get source :secrets)) (when (eq source 'default) - (setq source (or (secrets-get-alias "default") "login"))) + (setq source (or (secrets-get-alias "default") "login"))) (or source "session")))) (defun auth-source-pick (&rest spec) @@ -214,124 +222,124 @@ SPEC means to always succeed in the match. A string value is matched as a regex." (let ((keys (loop for i below (length spec) by 2 collect (nth i spec))) - choices) + choices) (dolist (choice (copy-tree auth-sources) choices) (let ((source (plist-get choice :source)) - (match t)) - (when - (and - ;; Check existence of source. - (if (consp source) - ;; Secret Service API. - (member (auth-get-source choice) (secrets-list-collections)) - ;; authinfo file. - (file-exists-p source)) + (match t)) + (when + (and + ;; Check existence of source. + (if (consp source) + ;; Secret Service API. + (member (auth-get-source choice) (secrets-list-collections)) + ;; authinfo file. + (file-exists-p source)) - ;; Check keywords. - (dolist (k keys match) - (let* ((v (plist-get spec k)) - (choicev (if (plist-member choice k) - (plist-get choice k) t))) - (setq match - (and match - (or - ;; source always matches spec key - (eq t choicev) - ;; source key gives regex to match against spec - (and (stringp choicev) (string-match choicev v)) - ;; source key gives symbol to match against spec - (and (symbolp choicev) (eq choicev v)))))))) + ;; Check keywords. + (dolist (k keys match) + (let* ((v (plist-get spec k)) + (choicev (if (plist-member choice k) + (plist-get choice k) t))) + (setq match + (and match + (or + ;; source always matches spec key + (eq t choicev) + ;; source key gives regex to match against spec + (and (stringp choicev) (string-match choicev v)) + ;; source key gives symbol to match against spec + (and (symbolp choicev) (eq choicev v)))))))) - (add-to-list 'choices choice 'append)))))) + (add-to-list 'choices choice 'append)))))) (defun auth-source-retrieve (mode entry &rest spec) "Retrieve MODE credentials according to SPEC from ENTRY." (catch 'no-password (let ((host (plist-get spec :host)) - (user (plist-get spec :user)) - (prot (plist-get spec :protocol)) - (source (plist-get entry :source)) - result) + (user (plist-get spec :user)) + (prot (plist-get spec :protocol)) + (source (plist-get entry :source)) + result) (cond ;; Secret Service API. ((consp source) - (let ((coll (auth-get-source entry)) - item) - ;; Loop over candidates with a matching host attribute. - (dolist (elt (secrets-search-items coll :host host) item) - (when (and (or (not user) - (string-equal - user (secrets-get-attribute coll elt :user))) - (or (not prot) - (string-equal - prot (secrets-get-attribute coll elt :protocol)))) - (setq item elt) - (return elt))) - ;; Compose result. - (when item - (setq result - (mapcar (lambda (m) - (if (string-equal "password" m) - (or (secrets-get-secret coll item) - ;; When we do not find a password, - ;; we return nil anyway. - (throw 'no-password nil)) - (or (secrets-get-attribute coll item :user) - user))) - (if (consp mode) mode (list mode))))) - (if (consp mode) result (car result)))) + (let ((coll (auth-get-source entry)) + item) + ;; Loop over candidates with a matching host attribute. + (dolist (elt (secrets-search-items coll :host host) item) + (when (and (or (not user) + (string-equal + user (secrets-get-attribute coll elt :user))) + (or (not prot) + (string-equal + prot (secrets-get-attribute coll elt :protocol)))) + (setq item elt) + (return elt))) + ;; Compose result. + (when item + (setq result + (mapcar (lambda (m) + (if (string-equal "password" m) + (or (secrets-get-secret coll item) + ;; When we do not find a password, + ;; we return nil anyway. + (throw 'no-password nil)) + (or (secrets-get-attribute coll item :user) + user))) + (if (consp mode) mode (list mode))))) + (if (consp mode) result (car result)))) ;; Anything else is netrc. (t - (let ((search (list source (list host) (list (format "%s" prot)) - (auth-source-protocol-defaults prot)))) - (setq result - (mapcar (lambda (m) - (if (string-equal "password" m) - (or (apply - 'netrc-machine-user-or-password m search) - ;; When we do not find a password, we - ;; return nil anyway. - (throw 'no-password nil)) - (or (apply - 'netrc-machine-user-or-password m search) - user))) - (if (consp mode) mode (list mode))))) - (if (consp mode) result (car result))))))) + (let ((search (list source (list host) (list (format "%s" prot)) + (auth-source-protocol-defaults prot)))) + (setq result + (mapcar (lambda (m) + (if (string-equal "password" m) + (or (apply + 'netrc-machine-user-or-password m search) + ;; When we do not find a password, we + ;; return nil anyway. + (throw 'no-password nil)) + (or (apply + 'netrc-machine-user-or-password m search) + user))) + (if (consp mode) mode (list mode))))) + (if (consp mode) result (car result))))))) (defun auth-source-create (mode entry &rest spec) "Create interactively credentials according to SPEC in ENTRY. Return structure as specified by MODE." (let* ((host (plist-get spec :host)) - (user (plist-get spec :user)) - (prot (plist-get spec :protocol)) - (source (plist-get entry :source)) - (name (concat (if user (format "%s@" user)) - host - (if prot (format ":%s" prot)))) - result) + (user (plist-get spec :user)) + (prot (plist-get spec :protocol)) + (source (plist-get entry :source)) + (name (concat (if user (format "%s@" user)) + host + (if prot (format ":%s" prot)))) + result) (setq result - (mapcar - (lambda (m) - (cons - m - (cond - ((equal "password" m) - (let ((passwd (read-passwd - (format "Password for %s on %s: " prot host)))) - (cond - ;; Secret Service API. - ((consp source) - (apply - 'secrets-create-item - (auth-get-source entry) name passwd spec)) - (t)) ;; netrc not implemented yes. - passwd)) - ((equal "login" m) - (or user - (read-string (format "User name for %s on %s: " prot host)))) - (t - "unknownuser")))) - (if (consp mode) mode (list mode)))) + (mapcar + (lambda (m) + (cons + m + (cond + ((equal "password" m) + (let ((passwd (read-passwd + (format "Password for %s on %s: " prot host)))) + (cond + ;; Secret Service API. + ((consp source) + (apply + 'secrets-create-item + (auth-get-source entry) name passwd spec)) + (t)) ;; netrc not implemented yes. + passwd)) + ((equal "login" m) + (or user + (read-string (format "User name for %s on %s: " prot host)))) + (t + "unknownuser")))) + (if (consp mode) mode (list mode)))) ;; Allow the source to save the data. (cond ((consp source) @@ -340,33 +348,33 @@ (t ;; netrc interface. (when (y-or-n-p (format "Do you want to save this password in %s? " - source)) - (netrc-store-data source host prot - (or user (cdr (assoc "login" result))) - (cdr (assoc "password" result)))))) + source)) + (netrc-store-data source host prot + (or user (cdr (assoc "login" result))) + (cdr (assoc "password" result)))))) (if (consp mode) - (mapcar #'cdr result) + (mapcar #'cdr result) (cdar result)))) (defun auth-source-delete (entry &rest spec) "Delete credentials according to SPEC in ENTRY." (let ((host (plist-get spec :host)) - (user (plist-get spec :user)) - (prot (plist-get spec :protocol)) - (source (plist-get entry :source))) + (user (plist-get spec :user)) + (prot (plist-get spec :protocol)) + (source (plist-get entry :source))) (cond ;; Secret Service API. ((consp source) (let ((coll (auth-get-source entry))) - ;; Loop over candidates with a matching host attribute. - (dolist (elt (secrets-search-items coll :host host)) - (when (and (or (not user) - (string-equal - user (secrets-get-attribute coll elt :user))) - (or (not prot) - (string-equal - prot (secrets-get-attribute coll elt :protocol)))) - (secrets-delete-item coll elt))))) + ;; Loop over candidates with a matching host attribute. + (dolist (elt (secrets-search-items coll :host host)) + (when (and (or (not user) + (string-equal + user (secrets-get-attribute coll elt :user))) + (or (not prot) + (string-equal + prot (secrets-get-attribute coll elt :protocol)))) + (secrets-delete-item coll elt))))) (t)))) ;; netrc not implemented yes. (defun auth-source-forget-user-or-password @@ -416,57 +424,57 @@ "auth-source-user-or-password: get %s for %s (%s) + user=%s" mode host protocol username) (let* ((listy (listp mode)) - (mode (if listy mode (list mode))) - (cname (if username - (format "%s %s:%s %s" mode host protocol username) - (format "%s %s:%s" mode host protocol))) - (search (list :host host :protocol protocol)) - (search (if username (append search (list :user username)) search)) - (found (if (not delete-existing) - (gethash cname auth-source-cache) - (remhash cname auth-source-cache) - nil))) + (mode (if listy mode (list mode))) + (cname (if username + (format "%s %s:%s %s" mode host protocol username) + (format "%s %s:%s" mode host protocol))) + (search (list :host host :protocol protocol)) + (search (if username (append search (list :user username)) search)) + (found (if (not delete-existing) + (gethash cname auth-source-cache) + (remhash cname auth-source-cache) + nil))) (if found - (progn - (auth-source-do-debug - "auth-source-user-or-password: cached %s=%s for %s (%s) + %s" - mode - ;; don't show the password - (if (and (member "password" mode) auth-source-hide-passwords) - "SECRET" - found) - host protocol username) - found) ; return the found data + (progn + (auth-source-do-debug + "auth-source-user-or-password: cached %s=%s for %s (%s) + %s" + mode + ;; don't show the password + (if (and (member "password" mode) auth-source-hide-passwords) + "SECRET" + found) + host protocol username) + found) ; return the found data ;; else, if not found (let ((choices (apply 'auth-source-pick search))) - (dolist (choice choices) - (if delete-existing - (apply 'auth-source-delete choice search) - (setq found (apply 'auth-source-retrieve mode choice search))) - (and found (return found))) + (dolist (choice choices) + (if delete-existing + (apply 'auth-source-delete choice search) + (setq found (apply 'auth-source-retrieve mode choice search))) + (and found (return found))) - ;; We haven't found something, so we will create it interactively. - (when (and (not found) create-missing) - (setq found (apply 'auth-source-create - mode (if choices - (car choices) - (car auth-sources)) - search))) + ;; We haven't found something, so we will create it interactively. + (when (and (not found) create-missing) + (setq found (apply 'auth-source-create + mode (if choices + (car choices) + (car auth-sources)) + search))) - ;; Cache the result. - (when found - (auth-source-do-debug - "auth-source-user-or-password: found %s=%s for %s (%s) + %s" - mode - ;; don't show the password - (if (and (member "password" mode) auth-source-hide-passwords) - "SECRET" found) - host protocol username) - (setq found (if listy found (car-safe found))) - (when auth-source-do-cache - (puthash cname found auth-source-cache))) + ;; Cache the result. + (when found + (auth-source-do-debug + "auth-source-user-or-password: found %s=%s for %s (%s) + %s" + mode + ;; don't show the password + (if (and (member "password" mode) auth-source-hide-passwords) + "SECRET" found) + host protocol username) + (setq found (if listy found (car-safe found))) + (when auth-source-do-cache + (puthash cname found auth-source-cache))) - found)))) + found)))) (defun auth-source-protocol-defaults (protocol) "Return a list of default ports and names for PROTOCOL."
--- a/lisp/gnus/gnus-int.el Wed Oct 06 19:42:30 2010 -0700 +++ b/lisp/gnus/gnus-int.el Thu Oct 07 03:49:38 2010 +0000 @@ -41,6 +41,16 @@ :group 'gnus-start :type 'hook) +(defcustom gnus-after-set-mark-hook nil + "Hook called just after marks are set in a group." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-before-update-mark-hook nil + "Hook called just before marks are updated in a group." + :group 'gnus-start + :type 'hook) + (defcustom gnus-server-unopen-status nil "The default status if the server is not able to open. If the server is covered by Gnus agent, the possible values are @@ -471,7 +481,8 @@ action (funcall (gnus-get-function gnus-command-method 'request-set-mark) (gnus-group-real-name group) action - (nth 1 gnus-command-method))))) + (nth 1 gnus-command-method)) + (gnus-run-hook-with-args gnus-after-set-mark-hook group action)))) (defun gnus-request-update-mark (group article mark) "Allow the back end to change the mark the user tries to put on an article." @@ -479,6 +490,7 @@ (if (not (gnus-check-backend-function 'request-update-mark (car gnus-command-method))) mark + (gnus-run-hook-with-args gnus-before-update-mark-hook group article mark) (funcall (gnus-get-function gnus-command-method 'request-update-mark) (gnus-group-real-name group) article mark))))
--- a/lisp/gnus/gnus-sync.el Wed Oct 06 19:42:30 2010 -0700 +++ b/lisp/gnus/gnus-sync.el Thu Oct 07 03:49:38 2010 +0000 @@ -24,6 +24,10 @@ ;; This is the gnus-sync.el package. +;; It's due for a rewrite using gnus-after-set-mark-hook and +;; gnus-before-update-mark-hook. Until then please consider it +;; experimental. + ;; Put this in your startup file (~/.gnus.el for instance) ;; possibilities for gnus-sync-backend: @@ -40,6 +44,9 @@ ;; - after gnus-sync-read, the message counts are wrong +;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to +;; catch the mark updates + ;;; Code: (eval-when-compile (require 'cl))
--- a/lisp/gnus/gnus-util.el Wed Oct 06 19:42:30 2010 -0700 +++ b/lisp/gnus/gnus-util.el Thu Oct 07 03:49:38 2010 +0000 @@ -1290,6 +1290,11 @@ (save-current-buffer (apply 'run-hooks funcs))) +(defun gnus-run-hook-with-args (hook &rest args) + "Does the same as `run-hook-with-args', but saves the current buffer." + (save-current-buffer + (apply 'run-hook-with-args hook args))) + (defun gnus-run-mode-hooks (&rest funcs) "Run `run-mode-hooks' if it is available, otherwise `run-hooks'. This function saves the current buffer."