Commits

Anonymous committed 9d2c658

synch with v1.0

Comments (0)

Files changed (5)

+1998-03-15  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc: Released 1.0/pkg1.1 
+
+	* eudc-ldap.el: 
+	(eudc-ldap-clear-inline-query-format-on-exit): New var
+	(eudc-ldap-set-inline-query-format-maybe): New defun
+	(eudc-ldap-protocol-switch-init): New defun
+	(eudc-ldap-protocol-switch-exit): New defun
+
+	* eudc.el: (eudc-protocol-switch-init-function): New var
+	(eudc-protocol-switch-exit-function): New var
+	(eudc-switch-to-protocol): Reswitch to previous protocol in case
+	of error.  Run protocol specific init and exit functions.
+	(eudc-expand-inline): Use eudc-inline-query-format if if query
+	string is a single word.  
+	Discard words in query string if there is no corresponding
+ 	attribute in eudc-inline-query-format
+	New selection mechanism for multiple matches	
+
+1998-03-01  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc.el: (eudc-use-raw-directory-names): New var
+	(eudc-query-form): Take previous var into account
+	(eudc-tail-menu): Changed some menu entry names
+	(eudc-load-eudc): New function
+	Attach a basic menu for EUDC at autoload time.
+
 1998-02-25  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
 
 	* eudc: Released 0.2/pkg0.9 
 # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 # Boston, MA 02111-1307, USA.
 
-VERSION = 1.0
-AUTHOR_VERSION = 0.2
+VERSION = 1.1
+AUTHOR_VERSION = 1.0
 MAINTAINER = Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
 PACKAGE = eudc
 PKG_TYPE = regular
 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
 ;; Created: Feb 1998
-;; Version: 1.3
+;; Version: $Revision$
 ;; Keywords: help
 
 ;; This file is part of XEmacs
 
 ;;{{{      Internal cooking
 
+;; Whether eudc-inline-query-format should be cleared on switching protocols
+;; from LDAP
+(defvar eudc-ldap-clear-inline-query-format-on-exit nil)
+
 (defvar eudc-ldap-attributes-translation-alist
   '((name . sn)
     (email . mail)
 (defconst eudc-ldap-protocol-locals 
   '((eudc-query-function . eudc-ldap-simple-query-internal)
     (eudc-protocol-attributes-translation-alist . eudc-ldap-attributes-translation-alist)
-    (eudc-bbdb-conversion-alist . eudc-ldap-bbdb-conversion-alist))
+    (eudc-bbdb-conversion-alist . eudc-ldap-bbdb-conversion-alist)
+    (eudc-protocol-switch-init-function . eudc-ldap-protocol-switch-init)
+    (eudc-protocol-switch-exit-function . eudc-ldap-protocol-switch-exit))
   "LDAP protocol specific values of EUDC variables.
 This should be an alist of the form (EUDC-VAR . LDAP-VAR) where
 EUDC-VAR is the name of a EUDC variable and LDAP-VAR is 
 					    (format "(%s=%s)" (car item) (cdr item)))
 					 query))))
 
+;; Set eudc-inline-query-format for LDAP since LDAP does not
+;; have default query attributes and hence won't accept plain
+;; string queries without an associated attribute name
+(defun eudc-ldap-set-inline-query-format-maybe ()
+  (when (null eudc-inline-query-format)
+    (setq eudc-inline-query-format '(name))
+    (setq eudc-ldap-clear-inline-query-format-on-exit t)))
+
+(defun eudc-ldap-protocol-switch-init ()
+  (eudc-ldap-set-inline-query-format-maybe))
+
+(defun eudc-ldap-protocol-switch-exit ()
+  (if eudc-ldap-clear-inline-query-format-on-exit
+      (setq eudc-inline-query-format nil)))
 
 ;;}}}        
 
 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
 ;; Created: Feb 1998
-;; Version: 1.4
+;; Version: $Revision$
 ;; Keywords: help
 
 ;; This file is part of XEmacs
 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
 ;; Created: Feb 1998
-;; Version: 1.5
+;; Version: $Revision$
 ;; Keywords: help
 
 ;; This file is part of XEmacs
 
 
 (defcustom eudc-strict-return-matches t
-  "*If non-nil, entries not containing all requested return attributes are ignored."
+  "*If non-nil, ignore entries that do not contain all requested return attributes."
   :type  'boolean
   :group 'eudc)
 
 			(string :tag "User name")))
   :group 'eudc)
 
+(defcustom eudc-use-raw-directory-names nil
+  "*If non-nil, use attributes names as defined in the directory.
+Otherwise, directory query/response forms display the user attribute
+names defined in `eudc-user-attribute-names-alist'."
+  :type  'boolean
+  :group 'eudc)
+
 (defcustom eudc-options-file "~/.eudc-options"
   "*A file where the `servers' hotlist is stored."
   :type '(file :Tag "File Name:"))
 
 (defvar eudc-form-widget-list nil)
 
+;; Used by the selection insertion mechanism
+(defvar eudc-pre-select-window-configuration nil)
+(defvar eudc-insertion-marker nil)
+
 ;; List of known servers
 ;; Alist of (SERVER . PROTOCOL)
 (defvar eudc-server-hotlist nil)
 ;; in that list: `name' , `email', `phone'
 (defvar eudc-protocol-attributes-translation-alist nil)
 
+;; A function called each time EUDC switches to a protocol
+(defvar eudc-protocol-switch-init-function nil)
+
+;; A function called each time EUDC switches from a protocol to
+;; another one
+(defvar eudc-protocol-switch-exit-function nil)
+
 ;; Protocol locals
 ;; List of (PROTOCOL (EUDC-VAR . VALUE) (EUDC-VAR .VALUE) ...)
 (defvar eudc-protocol-locals '((default 
 				 (eudc-query-function . nil) 
 				 (eudc-list-attributes-function . nil)
 				 (eudc-protocol-attributes-translation-alist . nil)
-				 (eudc-bbdb-conversion-alist . nil))))
+				 (eudc-bbdb-conversion-alist . nil)
+				 (eudc-protocol-switch-init-function . nil)
+				 (eudc-protocol-switch-exit-function . nil))))
 
 
 ;;; Emacs does not provide that one
 	  (cons (cons protocol locals)
 		eudc-protocol-locals))))
 
-;; If eudc-protocol-locals has been corrupted, things can go bad here as part
-;; of the variables may be set for the new protocol while some will remain
-;; for the old one.  A condition-case would partly solve the problem but the
-;; code increase to be really foolproof is too big.
 (defun eudc-switch-to-protocol (protocol)
-  "From now on, use PROTOCOL for directory queries"
+  "Use PROTOCOL for directory queries from now on."
   (unless (or (member protocol
 		      eudc-supported-protocols)
 	      (load (concat "eudc-" (symbol-name protocol)) t))
       (error "Unsupported protocol: %s" protocol))
-  (let ((locals (assq 'default eudc-protocol-locals)))
-    ;; First reset protocol locals to their default values
-    (setq locals (cdr locals))
-    (while locals
-      (set (car (car locals)) (cdr (car locals)))
-      (setq locals (cdr locals)))
-    (setq locals (assq protocol eudc-protocol-locals))
-    (if (null locals)
-	(error "No protocol specific settings found"))
-    (setq locals (cdr locals))
-    (while locals
-      (set (car (car locals)) (cdr (car locals)))
-      (setq locals (cdr locals))))
-  (setq eudc-protocol protocol))
+  (condition-case nil
+      (let ((locals (assq 'default eudc-protocol-locals)))
+	(if eudc-protocol-switch-exit-function
+	    (funcall eudc-protocol-switch-exit-function))
+	;; Reset protocol locals to their default values
+	(setq locals (cdr locals))
+	(while locals
+	  (set (car (car locals)) (cdr (car locals)))
+	  (setq locals (cdr locals)))
+	(setq locals (assq protocol eudc-protocol-locals))
+	(if (null locals)
+	    (error "No protocol specific settings found"))
+	(setq locals (cdr locals))
+	(while locals
+	  (set (car (car locals)) (cdr (car locals)))
+	  (setq locals (cdr locals)))
+	(setq eudc-protocol protocol)
+	(if eudc-protocol-switch-init-function
+	    (funcall eudc-protocol-switch-init-function)))
+    ;; If something bad happens return to the previous protocol
+    (t
+     (if eudc-protocol
+	 (eudc-switch-to-protocol eudc-protocol)))))
 
 (defun eudc-translate-query (query)
   "Translate attribute names of QUERY according to `eudc-protocol-attributes-translation-alist'."
     query)) 
 
 (defun eudc-translate-attribute-list (list)
-  "Translate a list of attribute names ccording to `eudc-protocol-attributes-translation-alist'."
+  "Translate a list of attribute names according to `eudc-protocol-attributes-translation-alist'."
   (if eudc-protocol-attributes-translation-alist
       (let (trans)
 	(mapcar '(lambda (attribute)
 		list))
     list))
 
+(defun eudc-select (choices)
+  "Choose one from CHOICES using a completion buffer."
+  (setq eudc-pre-select-window-configuration (current-window-configuration))
+  (setq eudc-insertion-marker (point-marker))
+  (with-output-to-temp-buffer "*EUDC Completions*"
+    (display-completion-list 
+     response-strings 
+     :activate-callback 'eudc-insert-selected)))
+
+(defun eudc-insert-selected (event extent user)
+  "Insert a completion at the appropriate point."
+  (when eudc-insertion-marker
+    (set-buffer (marker-buffer eudc-insertion-marker))
+    (goto-char eudc-insertion-marker)
+    (insert (extent-string extent)))
+  (if eudc-pre-select-window-configuration
+      (set-window-configuration eudc-pre-select-window-configuration))
+  (setq eudc-pre-select-window-configuration nil
+	eudc-insertion-marker nil))
+
 (defun eudc-query (query &optional return-attributes no-translation)
    "Query the directory server with QUERY.
 QUERY is a list of cons cells (ATTR . VALUE) where 
 		    (setq attribute (if raw-attr-names
 					 (symbol-name (car field))
 				      (or (and (assq (car field) eudc-user-attribute-names-alist)
-						(cdr (assq (car field) eudc-user-attribute-names-alist)))
+					       (cdr (assq (car field) eudc-user-attribute-names-alist)))
 					   (capitalize (mapconcat '(lambda (char)
 								     (if (eq char ?_)
 									 " "
 					     query-alist)))))
 	      eudc-form-widget-list)
       (kill-buffer (current-buffer))
-      (eudc-display-records (eudc-query query-alist))
+      (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names)
       )))
          
            
   (interactive)
   (customize-group 'eudc))
 
+;;;###autoload
 (defun eudc-set-server (server protocol)
   "Set the directory server to SERVER using PROTOCOL."
   (interactive "sDirectory Server: \nSProtocol: ")
 (defun eudc-expand-inline (&optional replace)
   "Query the directory server, and expand the query string before point.
 The query string consists of the buffer substring from the point back to
-the preceding comma, colon or beginning of line.  If it contains more than
-one word, the variable `eudc-inline-query-format' controls to map these
-onto directory attribute names.
+the preceding comma, colon or beginning of line.  
+The variable `eudc-inline-query-format' controls how to associate the 
+individual inline query words with directory attribute names.
 After querying the server for the given string, the expansion specified by 
 `eudc-inline-expansion-format' is inserted in the buffer at point.
 If REPLACE is non nil, then this expansion replaces the name in the buffer.
 	 key val cell)
     
     ;; Prepare the query
-    (if (or (not query-format)
-	    (not (string-match "[ \t]+" words)))
+    (if (not query-format)
 	(setq query words)
       (setq words (split-string words "[ \t]+"))
       (while (and words query-format)
 	(setq query-alist (cons (cons (car query-format) (car words)) query-alist))
 	(setq words (cdr words)
 	      query-format (cdr query-format)))
-      (if words
-	  (setcdr (car query-alist)
-		  (concat (eudc-cdar query-alist) " "
-			  (mapconcat 'identity words " "))))
-      ;; Uniquify query-alist
+
+      ;; If the same attribute appears more than once, merge
+      ;; the corresponding values
       (setq query-alist (nreverse query-alist))
       (while query-alist
 	(setq key (eudc-caar query-alist)
 	      cell (assq key query))
 	(if cell
 	    (setcdr cell (concat val " " (cdr cell)))
-	  (setq query (cons (car query-alist) query))))
-      (setq query-alist (cdr query-alist)))
+	  (setq query (cons (car query-alist) query)))
+	(setq query-alist (cdr query-alist))))
 
     (setq response (eudc-query query (cdr eudc-inline-expansion-format)))
 
 	    (eq eudc-multiple-match-handling-method 'first))
 	(insert (car response-strings)))
        ((eq eudc-multiple-match-handling-method 'select)
-	(with-output-to-temp-buffer "*Completions*"
-	  (display-completion-list response-strings)))
+	(eudc-select response-strings))
        ((eq eudc-multiple-match-handling-method 'all)
 	(insert (mapconcat 'identity response-strings ", ")))
        ((eq eudc-multiple-match-handling-method 'abort)
 			 (eudc-get-attribute-list))
 		    eudc-query-form-attributes))
 	(buffer (get-buffer-create "*Directory Query Form*"))
-	field-name
+	prompts
 	widget
 	(width 0)
 	inhibit-read-only
 					       eudc-server))
 					     "\n")
     (widget-insert "Protocol         : " (symbol-name eudc-protocol) "\n")
-    ;; Loop over prompt strings to find the biggest one
-    (setq fields 
-	  (mapcar (function
-		   (lambda (field)
-		     (setq field-name (or (and (assq field eudc-user-attribute-names-alist)
-					       (cdr (assq field eudc-user-attribute-names-alist)))
-					  (capitalize (symbol-name field))))
-		     (if (> (length field-name) width)
-			 (setq width (length field-name)))
-		     (cons field field-name)))
-		  fields))
+    ;; Build the list of prompts
+    (setq prompts (if eudc-use-raw-directory-names
+		      (mapcar 'symbol-name (eudc-translate-attribute-list fields))
+		    (mapcar (function
+			     (lambda (field)
+			       (or (and (assq field eudc-user-attribute-names-alist)
+					(cdr (assq field eudc-user-attribute-names-alist)))
+				   (capitalize (symbol-name field)))))
+			    fields)))
+    ;; Loop over prompt strings to find the longest one
+    (mapcar (function
+	     (lambda (prompt)
+		     (if (> (length prompt) width)
+			 (setq width (length prompt)))))
+	    prompts)
     ;; Insert the first widget out of the mapcar to leave the cursor 
     ;; in the first field 
-    (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr (car fields))))
+    (widget-insert "\n\n" (format (concat "%" width "s: ") (car prompts)))
     (setq pt (point))
     (setq widget (widget-create 'editable-field :size 15))
-    (setq eudc-form-widget-list (cons (cons (car (car fields)) widget)
+    (setq eudc-form-widget-list (cons (cons (car fields) widget)
 				      eudc-form-widget-list))
     (setq fields (cdr fields))
+    (setq prompts (cdr prompts))
     (mapcar (function
 	     (lambda (field)
-	       (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr field)))
+	       (widget-insert "\n\n" (format (concat "%" width "s: ") (car prompts)))
 	       (setq widget (widget-create 'editable-field
 					   :size 15))
-	       (setq eudc-form-widget-list (cons (cons (car field) widget)
-						 eudc-form-widget-list))))
+	       (setq eudc-form-widget-list (cons (cons field widget)
+						 eudc-form-widget-list))
+	       (setq prompts (cdr prompts))))
 	    fields)
     (widget-insert "\n\n")
     (widget-create 'push-button
 
 (defconst eudc-tail-menu 
   `(["---" nil nil]
-    ["Query Directory Server" eudc-query-form t]
-    ["Expand Inline" eudc-expand-inline t]
+    ["Query with Form" eudc-query-form t]
+    ["Inline Query" eudc-expand-inline t]
     ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb 
      (and (or (featurep 'bbdb)
 	      (prog1 (locate-library "bbdb") (message "")))
     ,(cons "Customize" (cdr (custom-menu-create 'eudc)))))
 
 (defconst eudc-server-menu 
-  '(["---" eudc-bookmark-server t]
+  '(["---" nil nil]
     ["Bookmark Current Server" eudc-bookmark-current-server t]
     ["New Server" eudc-set-server t]))
 
 	    (easy-menu-create-keymaps "Directory" (cdr (eudc-menu))))))
    ))
 
+
+;;; Load time initializations :
+
 ;;; Load the options file
 (if (and (and (locate-library eudc-options-file)
 	      (message ""))		; Remove modeline message
 	 (not (featurep 'eudc-options-file)))
-    (load eudc-options-file))
-	 
+    (load eudc-options-file))	 
+;;; Install the full menu
+(eudc-install-menu)
 
-(eudc-install-menu)
-  
-      
+
+
+;;; The following installs a short menu for EUDC at XEmacs startup.
+
+;;;###autoload
+(defun eudc-load-eudc ()
+  "Load the Emacs Unified Directory Client.
+This does nothing except loading eudc by autoload side-effect."
+  (interactive)
+  nil)
+
+;;;###autoload
+(unless (featurep 'eudc)
+  (add-submenu '("Tools")
+	       '("Directory"
+		 ["Load Hotlist of Servers" eudc-load-eudc t]
+		 ["New Server" eudc-set-server t]
+		 ["---" nil nil]
+		 ["Query with Form" eudc-query-form t]
+		 ["Expand Inline Query" eudc-expand-inline t]
+		 ["---" nil nil]
+		 ["Get Email" eudc-get-email t]
+		 ["Get Phone" eudc-get-phone t])))
+        
 ;;}}}
 
 (provide 'eudc)