[Emacs-diffs] Changes to emacs/lisp/gnus/auth-source.el,v

[Miles Bader]

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Changes by:     Miles Bader <miles>     08/03/29 19:54:11

Index: lisp/gnus/auth-source.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/auth-source.el,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -b -r1.1 -r1.2
--- lisp/gnus/auth-source.el    10 Mar 2008 00:50:21 -0000      1.1
+++ lisp/gnus/auth-source.el    29 Mar 2008 19:54:09 -0000      1.2
@@ -1,7 +1,6 @@
 ;;; auth-source.el --- authentication sources for Gnus and Emacs
 
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2008 Free Software Foundation, Inc.
 
 ;; Author: Ted Zlatanov <address@hidden>
 ;; Keywords: news
@@ -32,53 +31,128 @@
 ;;; Code:
 
 (eval-when-compile (require 'cl))
+(eval-when-compile (require 'netrc))
 
 (defgroup auth-source nil
   "Authentication sources."
-  :version "22.1"
+  :version "23.1" ;; No Gnus
   :group 'gnus)
 
-(defcustom auth-source-choices nil
+(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
+                                  (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.1" ;; No Gnus
+  :type '(repeat :tag "Authentication Protocols"
+                (cons :tag "Protocol Entry"
+                      (symbol :tag "Protocol")
+                      (repeat :tag "Names"
+                              (string :tag "Name")))))
+
+;;; generate all the protocols in a format Customize can use
+(defconst auth-source-protocols-customize
+  (mapcar (lambda (a)
+           (let ((p (car-safe a)))
+             (list 'const 
+                   :tag (upcase (symbol-name p))
+                   p)))
+         auth-source-protocols))
+
+;;; this default will be changed to ~/.authinfo.gpg
+(defcustom auth-sources '((:source "~/.authinfo.enc" :host t :protocol t))
   "List of authentication sources.
 
 Each entry is the authentication type with optional properties."
   :group 'auth-source
-  :type '(repeat :tag "Authentication Sources"
-                (cons :tag "Source definition"
-                      (group :tag "Select a source" :inline t
+  :version "23.1" ;; No Gnus
+  :type `(repeat :tag "Authentication Sources"
+                (list :tag "Source definition"
                              (const :format "" :value :source)
-                             (choice :tag "Authentication information"
-                                     (const :tag "None" nil)
-                                     (file :tag "File")))
-                      (checklist :tag "Options" :greedy t
-                                 (group :inline t
-                                        (choice :tag "Choose the hosts"
-                                         (group :tag "Select host by name" 
:inline t
+                      (string :tag "Authentication Source")
                                                 (const :format "" :value :host)
-                                                (string :tag "Host name"))
-                                         (group :tag "Select host by regular 
expression" :inline t
-                                                (const :format "" :value 
:host-regex)
-                                                (regexp :tag "Host regular 
expression"))
-                                         (group :tag "Use any host" :inline t
-                                                (const :format "" :value 
:host-any)
-                                                (const :tag "Any" t))
-                                         (group :tag "Use if no other host 
matches" :inline t
-                                                (const :tag "Fallback" nil))))
-                                 (group :tag "Choose the protocol" :inline t
+                      (choice :tag "Host choice"
+                              (const :tag "Any" t)
+                              (regexp :tag "Host regular expression (TODO)")
+                              (const :tag "Fallback" nil))
                                         (const :format "" :value :protocol)
                                         (choice :tag "Protocol"
                                                 (const :tag "Any" t)
-                                                (const :tag "Fallback (used if 
no others match)" nil)
-                                                (const :tag "IMAP" imap)
-                                                (const :tag "POP3" pop3)
-                                                (const :tag "SSH"  ssh)
-                                                (const :tag "SFTP" sftp)
-                                                (const :tag "SMTP" smtp)))))))
+                              (const :tag "Fallback" nil)
+                              ,@auth-source-protocols-customize))))
 
 ;; temp for debugging
-;; (customize-variable 'auth-source-choices)
-;; (setq auth-source-choices nil)
-;; (format "%S" auth-source-choices)
+;; (unintern 'auth-source-protocols)
+;; (unintern 'auth-sources)
+;; (customize-variable 'auth-sources)
+;; (setq auth-sources nil)
+;; (format "%S" auth-sources)
+;; (customize-variable 'auth-source-protocols)
+;; (setq auth-source-protocols nil)
+;; (format "%S" auth-source-protocols)
+;; (auth-source-pick "a" 'imap)
+;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
+;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
+;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
+;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
+;; (auth-source-protocol-defaults 'imap)
+
+(defun auth-source-pick (host protocol &optional fallback)
+  "Parse `auth-sources' for HOST and PROTOCOL matches.
+
+Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t."
+  (interactive "sHost: \nsProtocol: \n") ;for testing
+  (let (choices)
+    (dolist (choice auth-sources)
+      (let ((h (plist-get choice :host))
+           (p (plist-get choice :protocol)))
+       (when (and
+              (or (equal t h)
+                  (and (stringp h) (string-match h host))
+                  (and fallback (equal h nil)))
+              (or (equal t p)
+                  (and (symbolp p) (equal p protocol))
+                  (and fallback (equal p nil))))
+         (push choice choices))))
+    (if choices
+       choices
+      (unless fallback
+       (auth-source-pick host protocol t)))))
+
+(defun auth-source-user-or-password (mode host protocol)
+  "Find user or password (from the string MODE) matching HOST and PROTOCOL."
+  (let (found)
+    (dolist (choice (auth-source-pick host protocol))
+      (setq found (netrc-machine-user-or-password 
+                  mode
+                  (plist-get choice :source)
+                  (list host)
+                  (list (format "%s" protocol))
+                  (auth-source-protocol-defaults protocol)))
+      (when found
+       (return found)))))
+
+(defun auth-source-protocol-defaults (protocol)
+  "Return a list of default ports and names for PROTOCOL."
+  (cdr-safe (assoc protocol auth-source-protocols)))
+
+(defun auth-source-user-or-password-imap (mode host)
+  (auth-source-user-or-password mode host 'imap))
+
+(defun auth-source-user-or-password-pop3 (mode host)
+  (auth-source-user-or-password mode host 'pop3))
+
+(defun auth-source-user-or-password-ssh (mode host)
+  (auth-source-user-or-password mode host 'ssh))
+
+(defun auth-source-user-or-password-sftp (mode host)
+  (auth-source-user-or-password mode host 'sftp))
+
+(defun auth-source-user-or-password-smtp (mode host)
+  (auth-source-user-or-password mode host 'smtp))
 
 (provide 'auth-source)