;;; eudc.el --- Emacs Unified Directory Client
-;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
-;; Author: Oscar Figueiredo <oscar@xemacs.org>
-;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Author: Oscar Figueiredo <oscar@cpe.fr>
+;; Maintainer: Pavel JanÃk <Pavel@Janik.cz>
;; Keywords: comm
;; This file is part of GNU Emacs.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This package provides a common interface to query directory servers using
;; The main entry points of EUDC are:
;; `eudc-query-form': Query a directory server from a query form
;; `eudc-expand-inline': Query a directory server for the e-mail address
-;; of the name before cursor and insert it in the
+;; of the name before cursor and insert it in the
;; buffer
;; `eudc-get-phone': Get a phone number from a directory server
;; `eudc-get-email': Get an e-mail address from a directory server
(defvar eudc-form-widget-list nil)
(defvar eudc-mode-map nil)
-;; Used by the selection insertion mechanism
-(defvar eudc-pre-select-window-configuration nil)
-(defvar eudc-insertion-marker nil)
+
+(defvar mode-popup-menu)
;; List of known servers
;; Alist of (SERVER . PROTOCOL)
(defun eudc-plist-get (plist prop &optional default)
"Extract a value from a property list.
PLIST is a property list, which is a list of the form
-(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
+\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
corresponding to the given PROP, or DEFAULT if PROP is not
one of the properties on the list."
(if (eudc-plist-member plist prop)
(defun eudc-default-set (var val)
"Set the EUDC default value of VAR to VAL.
The current binding of VAR is not changed."
- (put var 'eudc-locals
+ (put var 'eudc-locals
(plist-put (get var 'eudc-locals) 'default val))
(add-to-list 'eudc-local-vars var))
(protocol-locals (eudc-plist-get eudc-locals 'protocol)))
(setq protocol-locals (plist-put protocol-locals (or protocol
eudc-protocol) val))
- (setq eudc-locals
+ (setq eudc-locals
(plist-put eudc-locals 'protocol protocol-locals))
(put var 'eudc-locals eudc-locals)
(add-to-list 'eudc-local-vars var)
(eudc-plist-member eudc-locals 'server)))
'unbound
(setq server-locals (eudc-plist-get eudc-locals 'server))
- (eudc-lax-plist-get server-locals
+ (eudc-lax-plist-get server-locals
(or server
eudc-server) 'unbound))))
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*"
- (apply 'display-completion-list
- choices
- (if eudc-xemacs-p
- '(: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-select (choices beg end)
+ "Choose one from CHOICES using a completion.
+BEG and END delimit the text which is to be replaced."
+ (let ((replacement))
+ (setq replacement
+ (completing-read "Multiple matches found; choose one: "
+ (mapcar 'list choices)))
+ (delete-region beg end)
+ (insert replacement)))
(defun eudc-query (query &optional return-attributes no-translation)
"Query the current directory server with QUERY.
"Display the record list RECORDS in a formatted buffer.
If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
otherwise they are formatted according to `eudc-user-attribute-names-alist'."
- (let ((buffer (get-buffer-create "*Directory Query Results*"))
- inhibit-read-only
+ (let (inhibit-read-only
precords
(width 0)
beg
first-record
attribute-name)
- (switch-to-buffer buffer)
- (setq buffer-read-only t)
- (setq inhibit-read-only t)
- (erase-buffer)
- (insert "Directory Query Result\n")
- (insert "======================\n\n\n")
- (if (null records)
- (insert "No match found.\n"
- (if eudc-strict-return-matches
- "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n"
- ""))
- ;; Replace field names with user names, compute max width
- (setq precords
- (mapcar
- (function
- (lambda (record)
+ (with-output-to-temp-buffer "*Directory Query Results*"
+ (with-current-buffer standard-output
+ (setq buffer-read-only t)
+ (setq inhibit-read-only t)
+ (erase-buffer)
+ (insert "Directory Query Result\n")
+ (insert "======================\n\n\n")
+ (if (null records)
+ (insert "No match found.\n"
+ (if eudc-strict-return-matches
+ "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n"
+ ""))
+ ;; Replace field names with user names, compute max width
+ (setq precords
(mapcar
(function
- (lambda (field)
- (setq attribute-name
- (if raw-attr-names
- (symbol-name (car field))
- (eudc-format-attribute-name-for-display (car field))))
- (if (> (length attribute-name) width)
- (setq width (length attribute-name)))
- (cons attribute-name (cdr field))))
- record)))
- records))
- ;; Display the records
- (setq first-record (point))
- (mapcar
- (function
- (lambda (record)
- (setq beg (point))
- ;; Map over the record fields to print the attribute/value pairs
- (mapcar (function
- (lambda (field)
- (eudc-print-record-field field width)))
- record)
- ;; Store the record internal format in some convenient place
- (overlay-put (make-overlay beg (point))
- 'eudc-record
- (car records))
- (setq records (cdr records))
- (insert "\n")))
- precords))
- (insert "\n")
- (widget-create 'push-button
- :notify (lambda (&rest ignore)
- (eudc-query-form))
- "New query")
- (widget-insert " ")
- (widget-create 'push-button
- :notify (lambda (&rest ignore)
- (kill-this-buffer))
- "Quit")
- (eudc-mode)
- (widget-setup)
- (if first-record
- (goto-char first-record))))
+ (lambda (record)
+ (mapcar
+ (function
+ (lambda (field)
+ (setq attribute-name
+ (if raw-attr-names
+ (symbol-name (car field))
+ (eudc-format-attribute-name-for-display (car field))))
+ (if (> (length attribute-name) width)
+ (setq width (length attribute-name)))
+ (cons attribute-name (cdr field))))
+ record)))
+ records))
+ ;; Display the records
+ (setq first-record (point))
+ (mapcar
+ (function
+ (lambda (record)
+ (setq beg (point))
+ ;; Map over the record fields to print the attribute/value pairs
+ (mapcar (function
+ (lambda (field)
+ (eudc-print-record-field field width)))
+ record)
+ ;; Store the record internal format in some convenient place
+ (overlay-put (make-overlay beg (point))
+ 'eudc-record
+ (car records))
+ (setq records (cdr records))
+ (insert "\n")))
+ precords))
+ (insert "\n")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (eudc-query-form))
+ "New query")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (kill-this-buffer))
+ "Quit")
+ (eudc-mode)
+ (widget-setup)
+ (if first-record
+ (goto-char first-record))))))
(defun eudc-process-form ()
"Process the query form in current buffer and display the results."
(if eudc-emacs-p
(easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu))
(setq mode-popup-menu (eudc-menu)))
- (run-hooks 'eudc-mode-hook)
- )
+ (run-mode-hooks 'eudc-mode-hook))
;;}}}
(eudc-save-options)))
;;;###autoload
-(defun eudc-get-email (name)
- "Get the email field of NAME from the directory server."
- (interactive "sName: ")
+(defun eudc-get-email (name &optional error)
+ "Get the email field of NAME from the directory server.
+If ERROR is non-nil, report an error if there is none."
+ (interactive "sName: \np")
(or eudc-server
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(email)))
email)
(if (null (cdr result))
(setq email (eudc-cdaar result))
- (error "Multiple match. Use the query form"))
- (if (interactive-p)
+ (error "Multiple match--use the query form"))
+ (if error
(if email
(message "%s" email)
(error "No record matching %s" name)))
email))
;;;###autoload
-(defun eudc-get-phone (name)
- "Get the phone field of NAME from the directory server."
- (interactive "sName: ")
+(defun eudc-get-phone (name &optional error)
+ "Get the phone field of NAME from the directory server.
+If ERROR is non-nil, report an error if there is none."
+ (interactive "sName: \np")
(or eudc-server
(call-interactively 'eudc-set-server))
(let ((result (eudc-query (list (cons 'name name)) '(phone)))
phone)
(if (null (cdr result))
(setq phone (eudc-cdaar result))
- (error "Multiple match. Use the query form"))
- (if (interactive-p)
+ (error "Multiple match--use the query form"))
+ (if error
(if phone
(message "%s" phone)
(error "No record matching %s" name)))
(let (formats)
(while (and (null formats)
(> n 0))
- (setq formats
+ (setq formats
(delq nil
(mapcar '(lambda (format)
(if (= n
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.
-`eudc-expansion-overwrites-query' being non nil inverts the meaning of REPLACE.
+If REPLACE is non-nil, then this expansion replaces the name in the buffer.
+`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE.
Multiple servers can be tried with the same query until one finds a match,
see `eudc-inline-expansion-servers'"
(interactive)
(if (or
(and replace (not eudc-expansion-overwrites-query))
(and (not replace) eudc-expansion-overwrites-query))
- (delete-region beg end))
+ (kill-ring-save beg end))
(cond
((or (= (length response-strings) 1)
(null eudc-multiple-match-handling-method)
(eq eudc-multiple-match-handling-method 'first))
+ (delete-region beg end)
(insert (car response-strings)))
((eq eudc-multiple-match-handling-method 'select)
- (eudc-select response-strings))
+ (eudc-select response-strings beg end))
((eq eudc-multiple-match-handling-method 'all)
+ (delete-region beg end)
(insert (mapconcat 'identity response-strings ", ")))
((eq eudc-multiple-match-handling-method 'abort)
- (error "There is more than one match for the query"))
- ))
+ (error "There is more than one match for the query"))))
(or (and (equal eudc-server eudc-former-server)
(equal eudc-protocol eudc-former-protocol))
(eudc-set-server eudc-former-server eudc-former-protocol t)))
(goto-char pt)
(error "No more records before point")))))
-
;;}}}
-;;{{{ Menus an keymaps
+;;{{{ Menus and keymaps
(require 'easymenu)
(add-submenu '("Tools") (eudc-menu)))
(eudc-emacs-p
(cond
+ ((fboundp 'easy-menu-create-menu)
+ (define-key
+ global-map
+ [menu-bar tools directory-search]
+ (cons "Directory Search"
+ (easy-menu-create-menu "Directory Search" (cdr (eudc-menu))))))
((fboundp 'easy-menu-add-item)
(let ((menu (eudc-menu)))
(easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
;;; Load the options file
(if (and (not noninteractive)
(and (locate-library eudc-options-file)
- (message "")) ; Remove modeline message
+ (progn (message "") t)) ; Remove modeline message
(not (featurep 'eudc-options-file)))
(load eudc-options-file))
(provide 'eudc)
+;;; arch-tag: e18872b6-db83-400b-869d-be54e9a4160c
;;; eudc.el ends here