2000-01-12 Gerd Moellmann <gerd@gnu.org>
+ * net/eudc-bob.el, net/eudc-export.el, net/eudc-hotlist.el,
+ net/eudc-vars.el, net/eudc.el, net/eudcb-bbdb.el,
+ net/eudcb-ldap.el, net/eudcb-ph.el, net/ldap.el: New files.
+
* add-log.el (add-change-log-entry): Fix error trying an `(insert
nil)'.
--- /dev/null
+;;; eudc-bob.el --- Binary Objects Support for EUDC
+
+;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Usage:
+;; See the corresponding info file
+
+;;; Code:
+
+(require 'eudc)
+
+(defvar eudc-bob-generic-keymap nil
+ "Keymap for multimedia objects.")
+
+(defvar eudc-bob-image-keymap nil
+ "Keymap for inline images.")
+
+(defvar eudc-bob-sound-keymap nil
+ "Keymap for inline images.")
+
+(defvar eudc-bob-url-keymap nil
+ "Keymap for inline images.")
+
+(defconst eudc-bob-generic-menu
+ '("EUDC Binary Object Menu"
+ ["---" nil nil]
+ ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
+ ["Save object" eudc-bob-save-object t]))
+
+(defconst eudc-bob-image-menu
+ `("EUDC Image Menu"
+ ["---" nil nil]
+ ["Toggle inline display" eudc-bob-toggle-inline-display
+ (eudc-bob-can-display-inline-images)]
+ ,@(cdr (cdr eudc-bob-generic-menu))))
+
+(defconst eudc-bob-sound-menu
+ `("EUDC Sound Menu"
+ ["---" nil nil]
+ ["Play sound" eudc-bob-play-sound-at-point
+ (fboundp 'play-sound)]
+ ,@(cdr (cdr eudc-bob-generic-menu))))
+
+(defun eudc-jump-to-event (event)
+ "Jump to the window and point where EVENT occurred."
+ (if eudc-xemacs-p
+ (goto-char (event-closest-point event))
+ (set-buffer (window-buffer (posn-window (event-start event))))
+ (goto-char (posn-point (event-start event)))))
+
+(defun eudc-bob-get-overlay-prop (prop)
+ "Get property PROP from one of the overlays around."
+ (let ((overlays (append (overlays-at (1- (point)))
+ (overlays-at (point))))
+ overlay value
+ (notfound t))
+ (while (and notfound
+ (setq overlay (car overlays)))
+ (if (setq value (overlay-get overlay prop))
+ (setq notfound nil))
+ (setq overlays (cdr overlays)))
+ value))
+
+(defun eudc-bob-can-display-inline-images ()
+ "Return non-nil if we can display images inline."
+ (and eudc-xemacs-p
+ (memq (console-type)
+ '(x mswindows))
+ (fboundp 'make-glyph)))
+
+(defun eudc-bob-make-button (label keymap &optional menu plist)
+ "Create a button with LABEL.
+Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
+LABEL."
+ (let (overlay
+ (p (point))
+ prop val)
+ (insert label)
+ (put-text-property p (point) 'face 'bold)
+ (setq overlay (make-overlay p (point)))
+ (overlay-put overlay 'mouse-face 'highlight)
+ (overlay-put overlay 'keymap keymap)
+ (overlay-put overlay 'local-map keymap)
+ (overlay-put overlay 'menu menu)
+ (while plist
+ (setq prop (car plist)
+ plist (cdr plist)
+ val (car plist)
+ plist (cdr plist))
+ (overlay-put overlay prop val))))
+
+(defun eudc-bob-display-jpeg (data inline)
+ "Display the JPEG DATA at point.
+if INLINE is non-nil, try to inline the image otherwise simply
+display a button."
+ (let ((glyph (if (eudc-bob-can-display-inline-images)
+ (make-glyph (list (vector 'jpeg :data data)
+ [string :data "[JPEG Picture]"])))))
+ (eudc-bob-make-button "[JPEG Picture]"
+ eudc-bob-image-keymap
+ eudc-bob-image-menu
+ (list 'glyph glyph
+ 'end-glyph (if inline glyph)
+ 'duplicable t
+ 'invisible inline
+ 'start-open t
+ 'end-open t
+ 'object-data data))))
+
+(defun eudc-bob-toggle-inline-display ()
+ "Toggle inline display of an image."
+ (interactive)
+ (if (eudc-bob-can-display-inline-images)
+ (let ((overlays (append (overlays-at (1- (point)))
+ (overlays-at (point))))
+ overlay glyph)
+ (setq overlay (car overlays))
+ (while (and overlay
+ (not (setq glyph (overlay-get overlay 'glyph))))
+ (setq overlays (cdr overlays))
+ (setq overlay (car overlays)))
+ (if overlay
+ (if (overlay-get overlay 'end-glyph)
+ (progn
+ (overlay-put overlay 'end-glyph nil)
+ (overlay-put overlay 'invisible nil))
+ (overlay-put overlay 'end-glyph glyph)
+ (overlay-put overlay 'invisible t))))))
+
+(defun eudc-bob-display-audio (data)
+ "Display a button for audio DATA."
+ (eudc-bob-make-button "[Audio Sound]"
+ eudc-bob-sound-keymap
+ eudc-bob-sound-menu
+ (list 'duplicable t
+ 'start-open t
+ 'end-open t
+ 'object-data data)))
+
+
+(defun eudc-bob-display-generic-binary (data)
+ "Display a button for unidentified binary DATA."
+ (eudc-bob-make-button "[Binary Data]"
+ eudc-bob-generic-keymap
+ eudc-bob-generic-menu
+ (list 'duplicable t
+ 'start-open t
+ 'end-open t
+ 'object-data data)))
+
+(defun eudc-bob-play-sound-at-point ()
+ "Play the sound data contained in the button at point."
+ (interactive)
+ (let (sound)
+ (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
+ (error "No sound data available here")
+ (if (not (and (boundp 'sound-alist)
+ sound-alist))
+ (error "Don't know how to play sound on this Emacs version")
+ (setq sound-alist
+ (cons (list 'eudc-sound
+ :sound sound)
+ sound-alist))
+ (condition-case nil
+ (play-sound 'eudc-sound)
+ (t
+ (setq sound-alist (cdr sound-alist))))))))
+
+
+(defun eudc-bob-play-sound-at-mouse (event)
+ "Play the sound data contained in the button where EVENT occurred."
+ (interactive "e")
+ (save-excursion
+ (eudc-jump-to-event event)
+ (eudc-bob-play-sound-at-point)))
+
+
+(defun eudc-bob-save-object ()
+ "Save the object data of the button at point."
+ (interactive)
+ (let ((data (eudc-bob-get-overlay-prop 'object-data))
+ (buffer (generate-new-buffer "*eudc-tmp*")))
+ (save-excursion
+ (if (fboundp 'set-buffer-file-coding-system)
+ (set-buffer-file-coding-system 'binary))
+ (set-buffer buffer)
+ (insert data)
+ (save-buffer))
+ (kill-buffer buffer)))
+
+(defun eudc-bob-pipe-object-to-external-program ()
+ "Pipe the object data of the button at point to an external program."
+ (interactive)
+ (let ((data (eudc-bob-get-overlay-prop 'object-data))
+ (buffer (generate-new-buffer "*eudc-tmp*"))
+ program
+ viewer)
+ (condition-case nil
+ (save-excursion
+ (if (fboundp 'set-buffer-file-coding-system)
+ (set-buffer-file-coding-system 'binary))
+ (set-buffer buffer)
+ (insert data)
+ (setq program (completing-read "Viewer: " eudc-external-viewers))
+ (if (setq viewer (assoc program eudc-external-viewers))
+ (call-process-region (point-min) (point-max)
+ (car (cdr viewer))
+ (cdr (cdr viewer)))
+ (call-process-region (point-min) (point-max) program)))
+ (t
+ (kill-buffer buffer)))))
+
+(defun eudc-bob-menu ()
+ "Retrieve the menu attached to a binary object."
+ (eudc-bob-get-overlay-prop 'menu))
+
+(defun eudc-bob-popup-menu (event)
+ "Pop-up a menu of EUDC multimedia commands."
+ (interactive "@e")
+ (run-hooks 'activate-menubar-hook)
+ (eudc-jump-to-event event)
+ (if eudc-xemacs-p
+ (progn
+ (run-hooks 'activate-popup-menu-hook)
+ (popup-menu (eudc-bob-menu)))
+ (let ((result (x-popup-menu t (eudc-bob-menu)))
+ command)
+ (if result
+ (progn
+ (setq command (lookup-key (eudc-bob-menu)
+ (apply 'vector result)))
+ (command-execute command))))))
+
+(setq eudc-bob-generic-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "s" 'eudc-bob-save-object)
+ (define-key map (if eudc-xemacs-p
+ [button3]
+ [down-mouse-3]) 'eudc-bob-popup-menu)
+ map))
+
+(setq eudc-bob-image-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map "t" 'eudc-bob-toggle-inline-display)
+ map))
+
+(setq eudc-bob-sound-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [return] 'eudc-bob-play-sound-at-point)
+ (define-key map (if eudc-xemacs-p
+ [button2]
+ [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
+ map))
+
+(setq eudc-bob-url-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [return] 'browse-url-at-point)
+ (define-key map (if eudc-xemacs-p
+ [button2]
+ [down-mouse-2]) 'browse-url-at-mouse)
+ map))
+
+(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
+(set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
+
+
+(if eudc-emacs-p
+ (progn
+ (easy-menu-define eudc-bob-generic-menu
+ eudc-bob-generic-keymap
+ ""
+ eudc-bob-generic-menu)
+ (easy-menu-define eudc-bob-image-menu
+ eudc-bob-image-keymap
+ ""
+ eudc-bob-image-menu)
+ (easy-menu-define eudc-bob-sound-menu
+ eudc-bob-sound-keymap
+ ""
+ eudc-bob-sound-menu)))
+
+;;;###autoload
+(defun eudc-display-generic-binary (data)
+ "Display a button for unidentified binary DATA."
+ (eudc-bob-display-generic-binary data))
+
+;;;###autoload
+(defun eudc-display-url (url)
+ "Display URL and make it clickable."
+ (require 'browse-url)
+ (eudc-bob-make-button url eudc-bob-url-keymap))
+
+;;;###autoload
+(defun eudc-display-sound (data)
+ "Display a button to play the sound DATA."
+ (eudc-bob-display-audio data))
+
+;;;###autoload
+(defun eudc-display-jpeg-inline (data)
+ "Display the JPEG DATA inline at point if possible."
+ (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
+
+;;;###autoload
+(defun eudc-display-jpeg-as-button (data)
+ "Display a button for the JPEG DATA."
+ (eudc-bob-display-jpeg data nil))
+
+;;; eudc-bob.el ends here
--- /dev/null
+;;; eudc-export.el --- Functions to export EUDC qeuery results
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Commentary:
+
+;;; Usage:
+;; See the corresponding info file
+
+;;; Code:
+
+(require 'eudc)
+
+(if (not (featurep 'bbdb))
+ (load-library "bbdb"))
+(if (not (featurep 'bbdb-com))
+ (load-library "bbdb-com"))
+
+(defun eudc-create-bbdb-record (record &optional silent)
+ "Create a BBDB record using the RECORD alist.
+RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
+symbol and VALUE is the corresponding value for the record.
+If SILENT is non-nil then the created BBDB record is not displayed."
+ ;; This function runs in a special context where lisp symbols corresponding
+ ;; to field names in record are bound to the corresponding values
+ (eval
+ `(let* (,@(mapcar '(lambda (c)
+ (list (car c) (if (listp (cdr c))
+ (list 'quote (cdr c))
+ (cdr c))))
+ record)
+ bbdb-name
+ bbdb-company
+ bbdb-net
+ bbdb-address
+ bbdb-phones
+ bbdb-notes
+ spec
+ bbdb-record
+ value
+ (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
+
+ ;; BBDB standard fields
+ (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
+ bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
+ bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
+ bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
+ (setq spec (cdr (assq 'address conversion-alist)))
+ (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
+ spec
+ (list spec))
+ record t)))
+ (setq spec (cdr (assq 'phone conversion-alist)))
+ (setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec))
+ spec
+ (list spec))
+ record t)))
+ ;; BBDB custom fields
+ (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
+ (mapcar (function
+ (lambda (mapping)
+ (if (and (not (memq (car mapping)
+ '(name company net address phone notes)))
+ (setq value (eudc-parse-spec (cdr mapping) record nil)))
+ (cons (car mapping) value))))
+ conversion-alist)))
+ (setq bbdb-notes (delq nil bbdb-notes))
+ (setq bbdb-record (bbdb-create-internal bbdb-name
+ bbdb-company
+ bbdb-net
+ bbdb-address
+ bbdb-phones
+ bbdb-notes))
+ (or silent
+ (bbdb-display-records (list bbdb-record))))))
+
+(defun eudc-parse-spec (spec record recurse)
+ "Parse the conversion SPEC using RECORD.
+If RECURSE is non-nil then SPEC may be a list of atomic specs."
+ (cond
+ ((or (stringp spec)
+ (symbolp spec)
+ (and (listp spec)
+ (symbolp (car spec))
+ (fboundp (car spec))))
+ (condition-case nil
+ (eval spec)
+ (void-variable nil)))
+ ((and recurse
+ (listp spec))
+ (mapcar '(lambda (spec-elem)
+ (eudc-parse-spec spec-elem record nil))
+ spec))
+ (t
+ (error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))
+
+(defun eudc-bbdbify-address (addr location)
+ "Parse ADDR into a vector compatible with BBDB.
+ADDR should be an address string of no more than four lines or a
+list of lines.
+The last two lines are searched for the zip code, city and state name.
+LOCATION is used as the address location for bbdb."
+ (let* ((addr-components (if (listp addr)
+ (reverse addr)
+ (reverse (split-string addr "\n"))))
+ (last1 (pop addr-components))
+ (last2 (pop addr-components))
+ zip city state)
+ (setq addr-components (nreverse addr-components))
+ ;; If not containing the zip code the last line is supposed to contain a
+ ;; country name and the addres is supposed to be in european style
+ (if (not (string-match "[0-9][0-9][0-9]" last1))
+ (progn
+ (setq state last1)
+ (if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
+ (setq city (match-string 2 last2)
+ zip (string-to-number (match-string 1 last2)))
+ (error "Cannot parse the address")))
+ (cond
+ ;; American style
+ ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
+ (setq city (match-string 1 last1)
+ state (match-string 2 last1)
+ zip (string-to-number (match-string 3 last1))))
+ ;; European style
+ ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
+ (setq city (match-string 2 last1)
+ zip (string-to-number (match-string 1 last1))))
+ (t
+ (error "Cannot parse the address"))))
+ (vector location
+ (or (nth 0 addr-components) "")
+ (or (nth 1 addr-components) "")
+ (or (nth 2 addr-components) "")
+ (or city "")
+ (or state "")
+ zip)))
+
+(defun eudc-bbdbify-phone (phone location)
+ "Parse PHONE into a vector compatible with BBDB.
+PHONE is either a string supposedly containing a phone number or
+a list of such strings which are concatenated.
+LOCATION is used as the phone location for BBDB."
+ (cond
+ ((stringp phone)
+ (let (phone-list)
+ (condition-case err
+ (setq phone-list (bbdb-parse-phone-number phone))
+ (error
+ (if (string= "phone number unparsable." (eudc-cadr err))
+ (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
+ (error "Phone number unparsable")
+ (setq phone-list (list (bbdb-string-trim phone))))
+ (signal (car err) (cdr err)))))
+ (if (= 3 (length phone-list))
+ (setq phone-list (append phone-list '(nil))))
+ (apply 'vector location phone-list)))
+ ((listp phone)
+ (vector location (mapconcat 'identity phone ", ")))
+ (t
+ (error "Invalid phone specification"))))
+
+(defun eudc-batch-export-records-to-bbdb ()
+ "Insert all the records returned by a directory query into BBDB."
+ (interactive)
+ (goto-char (point-min))
+ (let ((nbrec 0)
+ record)
+ (while (eudc-move-to-next-record)
+ (and (overlays-at (point))
+ (setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
+ (1+ nbrec)
+ (eudc-create-bbdb-record record t)))
+ (message "%d records imported into BBDB" nbrec)))
+
+;;;###autoload
+(defun eudc-insert-record-at-point-into-bbdb ()
+ "Insert record at point into the BBDB database.
+This function can only be called from a directory query result buffer."
+ (interactive)
+ (let ((record (and (overlays-at (point))
+ (overlay-get (car (overlays-at (point))) 'eudc-record))))
+ (if (null record)
+ (error "Point is not over a record")
+ (eudc-create-bbdb-record record))))
+
+;;;###autoload
+(defun eudc-try-bbdb-insert ()
+ "Call `eudc-insert-record-at-point-into-bbdb' if on a record."
+ (interactive)
+ (and (or (featurep 'bbdb)
+ (prog1 (locate-library "bbdb") (message "")))
+ (overlays-at (point))
+ (overlay-get (car (overlays-at (point))) 'eudc-record)
+ (eudc-insert-record-at-point-into-bbdb)))
+
+;;; eudc-export.el ends here
--- /dev/null
+;;; eudc-hotlist.el --- Hotlist Management for EUDC
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Commentary:
+
+;;; Usage:
+;; See the corresponding info file
+
+;;; Code:
+
+(require 'eudc)
+
+(defvar eudc-hotlist-menu nil)
+(defvar eudc-hotlist-mode-map nil)
+(defvar eudc-hotlist-list-beginning nil)
+
+(defun eudc-hotlist-mode ()
+ "Major mode used to edit the hotlist of servers.
+
+These are the special commands of this mode:
+ a -- Add a new server to the list.
+ d -- Delete the server at point from the list.
+ s -- Select the server at point.
+ t -- Transpose the server at point and the previous one
+ q -- Commit the changes and quit.
+ x -- Quit without commiting the changes."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'eudc-hotlist-mode)
+ (setq mode-name "EUDC-Servers")
+ (use-local-map eudc-hotlist-mode-map)
+ (setq mode-popup-menu eudc-hotlist-menu)
+ (when (and eudc-xemacs-p
+ (featurep 'menubar))
+ (set-buffer-menubar current-menubar)
+ (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))
+ (setq buffer-read-only t))
+
+;;;###autoload
+(defun eudc-edit-hotlist ()
+ "Edit the hotlist of directory servers in a specialized buffer."
+ (interactive)
+ (let ((proto-col 0)
+ gap)
+ (switch-to-buffer (get-buffer-create "*EUDC Servers*"))
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (mapcar (function
+ (lambda (entry)
+ (setq proto-col (max (length (car entry)) proto-col))))
+ eudc-server-hotlist)
+ (setq proto-col (+ 3 proto-col))
+ (setq gap (make-string (- proto-col 6) ?\ ))
+ (insert " EUDC Servers\n"
+ " ============\n"
+ "\n"
+ "Server" gap "Protocol\n"
+ "------" gap "--------\n"
+ "\n")
+ (setq eudc-hotlist-list-beginning (point))
+ (mapcar '(lambda (entry)
+ (insert (car entry))
+ (indent-to proto-col)
+ (insert (symbol-name (cdr entry)) "\n"))
+ eudc-server-hotlist)
+ (eudc-hotlist-mode)))
+
+(defun eudc-hotlist-add-server ()
+ "Add a new server to the list after current one."
+ (interactive)
+ (if (not (eq major-mode 'eudc-hotlist-mode))
+ (error "Not in a EUDC hotlist edit buffer"))
+ (let ((server (read-from-minibuffer "Server: "))
+ (protocol (completing-read "Protocol: "
+ (mapcar '(lambda (elt)
+ (cons (symbol-name elt)
+ elt))
+ eudc-known-protocols)))
+ (buffer-read-only nil))
+ (if (not (eobp))
+ (forward-line 1))
+ (insert server)
+ (indent-to 30)
+ (insert protocol "\n")))
+
+(defun eudc-hotlist-delete-server ()
+ "Delete the server at point from the list."
+ (interactive)
+ (if (not (eq major-mode 'eudc-hotlist-mode))
+ (error "Not in a EUDC hotlist edit buffer"))
+ (let ((buffer-read-only nil))
+ (save-excursion
+ (beginning-of-line)
+ (if (and (>= (point) eudc-hotlist-list-beginning)
+ (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)"))
+ (kill-line 1)
+ (error "No server on this line")))))
+
+(defun eudc-hotlist-quit-edit ()
+ "Quit the hotlist editing mode and save changes to the hotlist."
+ (interactive)
+ (if (not (eq major-mode 'eudc-hotlist-mode))
+ (error "Not in a EUDC hotlist edit buffer"))
+ (let (hotlist)
+ (goto-char eudc-hotlist-list-beginning)
+ (while (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")
+ (setq hotlist (cons (cons (match-string 1)
+ (intern (match-string 2)))
+ hotlist))
+ (forward-line 1))
+ (if (not (looking-at "^[ \t]*$"))
+ (error "Malformed entry in hotlist, discarding edits"))
+ (setq eudc-server-hotlist (nreverse hotlist))
+ (eudc-install-menu)
+ (eudc-save-options)
+ (kill-this-buffer)))
+
+(defun eudc-hotlist-select-server ()
+ "Select the server at point as the current server."
+ (interactive)
+ (if (not (eq major-mode 'eudc-hotlist-mode))
+ (error "Not in a EUDC hotlist edit buffer"))
+ (save-excursion
+ (beginning-of-line)
+ (if (and (>= (point) eudc-hotlist-list-beginning)
+ (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)"))
+ (progn
+ (eudc-set-server (match-string 1) (intern (match-string 2)))
+ (message "Current directory server is %s (%s)" eudc-server eudc-protocol))
+ (error "No server on this line"))))
+
+(defun eudc-hotlist-transpose-servers ()
+ "Swap the order of the server with the previous one in the list."
+ (interactive)
+ (if (not (eq major-mode 'eudc-hotlist-mode))
+ (error "Not in a EUDC hotlist edit buffer"))
+ (let ((buffer-read-only nil))
+ (save-excursion
+ (beginning-of-line)
+ (if (and (>= (point) eudc-hotlist-list-beginning)
+ (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")
+ (progn
+ (forward-line -1)
+ (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")))
+ (progn
+ (forward-line 1)
+ (transpose-lines 1))))))
+
+(setq eudc-hotlist-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "a" 'eudc-hotlist-add-server)
+ (define-key map "d" 'eudc-hotlist-delete-server)
+ (define-key map "s" 'eudc-hotlist-select-server)
+ (define-key map "t" 'eudc-hotlist-transpose-servers)
+ (define-key map "q" 'eudc-hotlist-quit-edit)
+ (define-key map "x" 'kill-this-buffer)
+ map))
+
+(defconst eudc-hotlist-menu
+ '("EUDC Hotlist Edit"
+ ["---" nil nil]
+ ["Add New Server" eudc-hotlist-add-server t]
+ ["Delete Server" eudc-hotlist-delete-server t]
+ ["Select Server" eudc-hotlist-select-server t]
+ ["Transpose Servers" eudc-hotlist-transpose-servers t]
+ ["Save and Quit" eudc-hotlist-quit-edit t]
+ ["Exit without Saving" kill-this-buffer t]))
+
+(if eudc-emacs-p
+ (easy-menu-define eudc-hotlist-emacs-menu
+ eudc-hotlist-mode-map
+ ""
+ eudc-hotlist-menu))
+
+;;; eudc-hotlist.el ends here
--- /dev/null
+;;; eudc-vars.el --- Emacs Unified Directory Client
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Code:
+
+(require 'custom)
+
+;;{{{ EUDC Main Custom Group
+
+(defgroup eudc nil
+ "Emacs Unified Directory Client."
+ :group 'mail
+ :group 'comm)
+
+(defcustom eudc-server nil
+ "*The name or IP address of the directory server.
+A port number may be specified by appending a colon and a
+number to the name of the server. Use `localhost' if the directory
+server resides on your computer (BBDB backend)."
+ :type '(string :tag "Server")
+ :group 'eudc)
+
+;; Known protocols (used in completion)
+;; Not to be mistaken with `eudc-supported-protocols'
+(defvar eudc-known-protocols '(bbdb ph ldap))
+
+(defvar eudc-supported-protocols nil
+ "Protocols currently supported by EUDC.
+This variable is updated when protocol-specific libraries
+are loaded, *do not change manually*.")
+
+(defcustom eudc-protocol nil
+ "*The directory protocol to use to query the server.
+Supported protocols are specified by `eudc-supported-protocols'."
+ :type `(choice :menu-tag "Protocol"
+ ,@(mapcar (lambda (s)
+ (list 'const ':tag (symbol-name s) s))
+ eudc-known-protocols))
+ :group 'eudc)
+
+
+(defcustom eudc-strict-return-matches t
+ "*Ignore or allow entries not containing all requested return attributes.
+If non-nil, such entries are ignored."
+ :type 'boolean
+ :group 'eudc)
+
+(defcustom eudc-default-return-attributes nil
+ "*A list of default attributes to extract from directory entries.
+If set to the symbol `all', return all attributes.
+A value of nil means return the default attributes as configured in the
+server."
+ :type '(choice :menu-tag "Return Attributes"
+ (const :menu-tag "Server defaults (nil)" nil)
+ (const :menu-tag "All" all)
+ (repeat :menu-tag "Attribute list"
+ :tag "Attribute name"
+ :value (nil)
+ (symbol :tag "Attribute name")))
+ :group 'eudc)
+
+(defcustom eudc-multiple-match-handling-method 'select
+ "*What to do when multiple entries match an inline expansion query.
+Possible values are:
+`first' (equivalent to nil) which means keep the first match only,
+`select' pop-up a selection buffer,
+`all' expand to all matches,
+`abort' the operation is aborted, an error is signaled."
+ :type '(choice :menu-tag "Method"
+ (const :menu-tag "Use First"
+ :tag "Use First" first)
+ (const :menu-tag "Select Interactively"
+ :tag "Select Interactively" select)
+ (const :menu-tag "Use All"
+ :tag "Use All" all)
+ (const :menu-tag "Abort Operation"
+ :tag "Abort Operation" abort)
+ (const :menu-tag "Default (Use First)"
+ :tag "Default (Use First)" nil))
+ :group 'eudc)
+
+(defcustom eudc-duplicate-attribute-handling-method '((email . duplicate))
+ "*A method to handle entries containing duplicate attributes.
+This is either an alist (ATTR . METHOD) or a symbol METHOD.
+The alist form of the variable associates a method to an individual attribute,
+the second form specifies a method applicable to all attributes.
+Available methods are:
+`list' or nil lets the value of the attribute be a list of values,
+`first' keeps the first value and discards the others,
+`concat' concatenates the values into a single multiline string,
+`duplicate' duplicates the entire entry into as many instances as
+different values."
+ :type '(choice (const :menu-tag "List" list)
+ (const :menu-tag "First" first)
+ (const :menu-tag "Concat" concat)
+ (const :menu-tag "Duplicate" duplicate)
+ (repeat :menu-tag "Per Attribute Specification"
+ :tag "Per Attribute Specification"
+ (cons :tag "Attribute/Method"
+ :value (nil . list)
+ (symbol :tag "Attribute name")
+ (choice :tag "Method"
+ :menu-tag "Method"
+ (const :menu-tag "List" list)
+ (const :menu-tag "First" first)
+ (const :menu-tag "Concat" concat)
+ (const :menu-tag "Duplicate" duplicate)))))
+ :group 'eudc)
+
+(defcustom eudc-inline-query-format '((name)
+ (firstname name))
+ "*Format of an inline expansion query.
+This is a list of FORMATs. A FORMAT is itself a list of one or more
+EUDC attribute names. A FORMAT applies if it contains as many attributes as
+there are individual words in the inline query string.
+If several FORMATs apply then they are tried in order until a match
+is found.
+If nil, all the words are mapped onto the default server or protocol
+attribute name.
+
+The attribute names in FORMATs are not restricted to EUDC attribute names
+but can also be protocol/server specific names. In this case, this variable
+must be set in a protocol/server-local fashion, see `eudc-server-set' and
+`eudc-protocol-set'."
+ :tag "Format of Inline Expansion Queries"
+ :type '(repeat
+ (repeat
+ :menu-tag "Format"
+ :tag "Format"
+ (choice
+ :tag "Attribute"
+ (const :menu-tag "First Name" :tag "First Name" firstname)
+ (const :menu-tag "Surname" :tag "Surname" name)
+ (const :menu-tag "Email Address" :tag "Email Address" email)
+ (const :menu-tag "Phone" :tag "Phone" phone)
+ (symbol :menu-tag "Other" :tag "Attribute name"))))
+ :group 'eudc)
+
+(defcustom eudc-expansion-overwrites-query t
+ "*If non nil, expanding a query overwrites the query string."
+ :type 'boolean
+ :group 'eudc)
+
+(defcustom eudc-inline-expansion-format '("%s" email)
+ "*A list specifying the format of the expansion of inline queries.
+This variable controls what `eudc-expand-inline' actually inserts in
+the buffer. First element is a string passed to `format'. Remaining
+elements are symbols indicating attribute names; the corresponding values
+are passed as additional arguments to `format'."
+ :type '(list
+ (string :tag "Format String")
+ (repeat :inline t
+ :tag "Attributes"
+ (choice
+ :tag "Attribute"
+ (const :menu-tag "First Name" :tag "First Name" firstname)
+ (const :menu-tag "Surname" :tag "Surname" name)
+ (const :menu-tag "Email Address" :tag "Email Address" email)
+ (const :menu-tag "Phone" :tag "Phone" phone)
+ (symbol :menu-tag "Other")
+ (symbol :tag "Attribute name"))))
+ :group 'eudc)
+
+(defcustom eudc-inline-expansion-servers 'server-then-hotlist
+ "*Which servers to contact for the expansion of inline queries.
+Possible values are:
+ `current-server': the EUDC current server.
+ `hotlist': the servers of the hotlist in the order they appear,
+ `server-then-hotlist': the current server and then the servers of
+ the hotlist."
+ :type '(choice :tag "Servers"
+ :menu-tag "Servers"
+ (const :menu-tag "Current server" current-server)
+ (const :menu-tag "Servers in the hotlist" hotlist)
+ (const :menu-tag "Current server then hotlist" server-then-hotlist))
+ :group 'eudc)
+
+(defcustom eudc-max-servers-to-query nil
+ "*Maximum number of servers to query for an inline expansion.
+If nil, query all servers available from `eudc-inline-expansion-servers'."
+ :tag "Max Number of Servers to Query"
+ :type '(choice :tag "Max. Servers"
+ :menu-tag "Max. Servers"
+ (const :menu-tag "No limit" nil)
+ (const :menu-tag "1" 1)
+ (const :menu-tag "2" 2)
+ (const :menu-tag "3" 3)
+ (const :menu-tag "4" 4)
+ (const :menu-tag "5" 5)
+ (integer :menu-tag "Set"))
+ :group 'eudc)
+
+(defcustom eudc-query-form-attributes '(name firstname email phone)
+ "*A list of attributes presented in the query form."
+ :tag "Attributes in Query Forms"
+ :type '(repeat
+ (choice
+ :tag "Attribute"
+ (const :menu-tag "First Name" :tag "First Name" firstname)
+ (const :menu-tag "Surname" :tag "Surname" name)
+ (const :menu-tag "Email Address" :tag "Email Address" email)
+ (const :menu-tag "Phone" :tag "Phone" phone)
+ (symbol :menu-tag "Other" :tag "Attribute name")))
+ :group 'eudc)
+
+(defcustom eudc-user-attribute-names-alist '((url . "URL")
+ (callsign . "HAM Call Sign")
+ (id . "ID")
+ (email . "E-Mail")
+ (firstname . "First Name")
+ (cn . "Full Name")
+ (sn . "Surname")
+ (givenname . "First Name")
+ (ou . "Unit")
+ (labeledurl . "URL")
+ (postaladdress . "Address")
+ (postalcode . "Postal Code")
+ (l . "Location")
+ (c . "Country")
+ (o . "Organization")
+ (roomnumber . "Office")
+ (telephonenumber . "Phone")
+ (uniqueidentifier . "ID")
+ (objectclass . "Object Class"))
+ "*Alist of user-defined names for directory attributes.
+These names are used as prompt strings in query/response forms
+instead of the raw directory attribute names.
+Prompt strings for attributes that are not listed here
+are derived by splitting the attribute name
+at `_' characters and capitalizing the individual words."
+ :tag "User-defined Names of Directory Attributes"
+ :type '(repeat (cons :tag "Field"
+ (symbol :tag "Directory attribute")
+ (string :tag "User friendly 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-attribute-display-method-alist nil
+ "*An alist specifying methods to display attribute values.
+Each member of the list is of the form (NAME . FUNC) where NAME is a lowercased
+string naming a directory attribute (translated according to
+`eudc-user-attribute-names-alist' if `eudc-use-raw-directory-names' is
+non-nil) and FUNC a function that will be passed the corresponding
+attribute values for display."
+ :tag "Attribute Decoding Functions"
+ :type '(repeat (cons :tag "Attribute"
+ (symbol :tag "Name")
+ (symbol :tag "Display Function")))
+ :group 'eudc)
+
+(defcustom eudc-external-viewers '(("XV" "xv" "-")
+ ("ImageMagick" "display" "-")
+ ("ShowAudio" "showaudio"))
+ "*A list of viewer program specifications.
+Viewers are programs which can be piped a directory attribute value for
+display or arbitrary processing. Each specification is a list whose
+first element is a string naming the viewer. The second element is the
+executable program which should be invoked, and following elements are
+arguments that should be passed to the program."
+ :tag "External Viewer Programs"
+ :type '(repeat (list :tag "Viewer"
+ (string :tag "Name")
+ (string :tag "Executable program")
+ (repeat
+ :tag "Arguments"
+ :inline t
+ (string :tag "Argument"))))
+ :group 'eudc)
+
+(defcustom eudc-options-file "~/.eudc-options"
+ "*A file where the `servers' hotlist is stored."
+ :type '(file :Tag "File Name:")
+ :group 'eudc)
+
+(defcustom eudc-mode-hook nil
+ "*Normal hook run on entry to EUDC mode."
+ :type '(repeat (sexp :tag "Hook definition"))
+ :group 'eudc)
+
+;;}}}
+
+;;{{{ PH Custom Group
+
+(defgroup eudc-ph nil
+ "Emacs Unified Directory Client - CCSO PH/QI Backend."
+ :group 'eudc)
+
+(defcustom eudc-ph-bbdb-conversion-alist
+ '((name . name)
+ (net . email)
+ (address . (eudc-bbdbify-address address "Address"))
+ (phone . ((eudc-bbdbify-phone phone "Phone")
+ (eudc-bbdbify-phone office_phone "Office Phone"))))
+ "*A mapping from BBDB to PH/QI fields.
+This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
+BBDB-FIELD is the name of a field that must be defined in your BBDB
+environment (standard field names are `name', `company', `net', `phone',
+`address' and `notes'). SPEC-OR-LIST is either a single SPEC or a list
+of SPECs. Lists of specs are valid only for the `phone' and `address'
+BBDB fields. SPECs are sexps which are evaluated:
+ a string evaluates to itself,
+ a symbol evaluates to the symbol value. Symbols naming PH/QI fields
+ present in the record evaluate to the value of the field in the record,
+ a form is evaluated as a function. The argument list may contain PH/QI
+ field names which eval to the corresponding values in the
+ record. The form evaluation should return something appropriate for
+ the particular BBDB-FIELD (see `bbdb-create-internal').
+ `eudc-bbdbify-phone' and `eudc-bbdbify-address' are provided as convenience
+ functions to parse phones and addresses."
+ :tag "BBDB to PH Field Name Mapping"
+ :type '(repeat (cons :tag "Field Name"
+ (symbol :tag "BBDB Field")
+ (sexp :tag "Conversion Spec")))
+ :group 'eudc-ph)
+
+;;}}}
+
+;;{{{ LDAP Custom Group
+
+(defgroup eudc-ldap nil
+ "Emacs Unified Directory Client - LDAP Backend."
+ :group 'eudc)
+
+(defcustom eudc-ldap-bbdb-conversion-alist
+ '((name . cn)
+ (net . mail)
+ (address . (eudc-bbdbify-address postaladdress "Address"))
+ (phone . ((eudc-bbdbify-phone telephonenumber "Phone"))))
+ "*A mapping from BBDB to LDAP attributes.
+This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
+BBDB-FIELD is the name of a field that must be defined in your BBDB
+environment (standard field names are `name', `company', `net', `phone',
+`address' and `notes'). SPEC-OR-LIST is either a single SPEC or a list
+of SPECs. Lists of specs are valid only for the `phone' and `address'
+BBDB fields. SPECs are sexps which are evaluated:
+ a string evaluates to itself,
+ a symbol evaluates to the symbol value. Symbols naming LDAP attributes
+ present in the record evaluate to the value of the field in the record,
+ a form is evaluated as a function. The argument list may contain LDAP
+ field names which eval to the corresponding values in the
+ record. The form evaluation should return something appropriate for
+ the particular BBDB-FIELD (see `bbdb-create-internal').
+ `eudc-bbdbify-phone' and `eudc-bbdbify-address' are provided as convenience
+ functions to parse phones and addresses."
+ :tag "BBDB to LDAP Attribute Names Mapping"
+ :type '(repeat (cons :tag "Field Name"
+ (symbol :tag "BBDB Field")
+ (sexp :tag "Conversion Spec")))
+ :group 'eudc-ldap)
+
+;;}}}
+
+;;{{{ BBDB Custom Group
+
+(defgroup eudc-bbdb nil
+ "Emacs Unified Directory Client - BBDB Backend."
+ :group 'eudc)
+
+(defcustom eudc-bbdb-use-locations-as-attribute-names t
+ "If non-nil, BBDB address and phone locations are used as attribute names.
+This has no effect on queries (you can't search for a specific location)
+but influences the way records are displayed"
+ :type 'boolean
+ :group 'eudc-bbdb)
+
+(defcustom eudc-bbdb-enable-substring-matches t
+ "If non-nil, authorize substring match in the same way BBDB does.
+Otherwise records must match queries exactly."
+ :type 'boolean
+ :group 'eudc-bbdb)
+
+;;}}}
+
+
+(provide 'eudc-vars)
+
+;;; eudc-vars.el ends here
--- /dev/null
+;;; eudc.el --- Emacs Unified Directory Client
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Commentary:
+;; This package provides a common interface to query directory servers using
+;; different protocols such as LDAP, CCSO PH/QI or BBDB. Queries can be
+;; made through an interactive form or inline. Inline query strings in
+;; buffers are expanded with appropriately formatted query results
+;; (especially used to expand email addresses in message buffers). EUDC
+;; also interfaces with the BBDB package to let you register query results
+;; into your own BBDB database.
+
+;;; Usage:
+;; EUDC comes with an extensive documentation, please refer to it.
+;;
+;; 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
+;; buffer
+;; `eudc-get-phone': Get a phone number from a directory server
+;; `eudc-get-email': Get an e-mail address from a directory server
+;; `eudc-customize': Customize various aspects of EUDC
+
+;;; Code:
+
+(require 'wid-edit)
+
+(eval-and-compile
+ (if (not (fboundp 'make-overlay))
+ (require 'overlay))
+ (if (not (fboundp 'unless))
+ (require 'cl)))
+
+(unless (fboundp 'custom-menu-create)
+ (autoload 'custom-menu-create "cus-edit"))
+
+(require 'eudc-vars)
+
+
+
+;;{{{ Internal cooking
+
+;;{{{ Internal variables and compatibility tricks
+
+(defconst eudc-xemacs-p (string-match "XEmacs" emacs-version))
+(defconst eudc-emacs-p (not eudc-xemacs-p))
+(defconst eudc-xemacs-mule-p (and eudc-xemacs-p
+ (featurep 'mule)))
+(defconst eudc-emacs-mule-p (and eudc-emacs-p
+ (featurep 'mule)))
+
+(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)
+
+;; List of known servers
+;; Alist of (SERVER . PROTOCOL)
+(defvar eudc-server-hotlist nil)
+
+;; List of variables that have server- or protocol-local bindings
+(defvar eudc-local-vars nil)
+
+;; Protocol local. Query function
+(defvar eudc-query-function nil)
+
+;; Protocol local. A function that retrieves a list of valid attribute names
+(defvar eudc-list-attributes-function nil)
+
+;; Protocol local. A mapping between EUDC attribute names and corresponding
+;; protocol specific names. The following names are defined by EUDC and may be
+;; included in that list: `name' , `firstname', `email', `phone'
+(defvar eudc-protocol-attributes-translation-alist nil)
+
+;; Protocol local. Mapping between protocol attribute names and BBDB field
+;; names
+(defvar eudc-bbdb-conversion-alist nil)
+
+;; Protocol/Server local. Hook called upon switching to that server
+(defvar eudc-switch-to-server-hook nil)
+
+;; Protocol/Server local. Hook called upon switching from that server
+(defvar eudc-switch-from-server-hook nil)
+
+;; Protocol local. Whether the protocol supports queries with no specified
+;; attribute name
+(defvar eudc-protocol-has-default-query-attributes nil)
+
+(defun eudc-cadr (obj)
+ (car (cdr obj)))
+
+(defun eudc-cdar (obj)
+ (cdr (car obj)))
+
+(defun eudc-caar (obj)
+ (car (car obj)))
+
+(defun eudc-cdaar (obj)
+ (cdr (car (car obj))))
+
+(defun eudc-plist-member (plist prop)
+ "Return t if PROP has a value specified in PLIST."
+ (if (not (= 0 (% (length plist) 2)))
+ (error "Malformed plist"))
+ (catch 'found
+ (while plist
+ (if (eq prop (car plist))
+ (throw 'found t))
+ (setq plist (cdr (cdr plist))))
+ nil))
+
+;; Emacs' plist-get lacks third parameter
+(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
+corresponding to the given PROP, or DEFAULT if PROP is not
+one of the properties on the list."
+ (if (eudc-plist-member plist prop)
+ (plist-get plist prop)
+ default))
+
+(defun eudc-lax-plist-get (plist prop &optional default)
+ "Extract a value from a lax property list.
+
+PLIST is a lax property list, which is a list of the form (PROP1
+VALUE1 PROP2 VALUE2...), where comparisons between properties are done
+using `equal' instead of `eq'. This function returns the value
+corresponding to PROP, or DEFAULT if PROP is not one of the
+properties on the list."
+ (if (not (= 0 (% (length plist) 2)))
+ (error "Malformed plist"))
+ (catch 'found
+ (while plist
+ (if (equal prop (car plist))
+ (throw 'found (car (cdr plist))))
+ (setq plist (cdr (cdr plist))))
+ default))
+
+(if (not (fboundp 'split-string))
+ (defun split-string (string &optional pattern)
+ "Return a list of substrings of STRING which are separated by PATTERN.
+If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
+ (or pattern
+ (setq pattern "[ \f\t\n\r\v]+"))
+ (let (parts (start 0))
+ (when (string-match pattern string 0)
+ (if (> (match-beginning 0) 0)
+ (setq parts (cons (substring string 0 (match-beginning 0)) nil)))
+ (setq start (match-end 0))
+ (while (and (string-match pattern string start)
+ (> (match-end 0) start))
+ (setq parts (cons (substring string start (match-beginning 0)) parts)
+ start (match-end 0))))
+ (nreverse (if (< start (length string))
+ (cons (substring string start) parts)
+ parts)))))
+
+(defun eudc-replace-in-string (str regexp newtext)
+ "Replace all matches in STR for REGEXP with NEWTEXT.
+Value is the new string."
+ (let ((rtn-str "")
+ (start 0)
+ match prev-start)
+ (while (setq match (string-match regexp str start))
+ (setq prev-start start
+ start (match-end 0)
+ rtn-str
+ (concat rtn-str
+ (substring str prev-start match)
+ newtext)))
+ (concat rtn-str (substring str start))))
+
+;;}}}
+
+;;{{{ Server and Protocol Variable Routines
+
+(defun eudc-server-local-variable-p (var)
+ "Return non-nil if VAR has server-local bindings."
+ (eudc-plist-member (get var 'eudc-locals) 'server))
+
+(defun eudc-protocol-local-variable-p (var)
+ "Return non-nil if VAR has protocol-local bindings."
+ (eudc-plist-member (get var 'eudc-locals) 'protocol))
+
+(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
+ (plist-put (get var 'eudc-locals) 'default val))
+ (add-to-list 'eudc-local-vars var))
+
+(defun eudc-protocol-set (var val &optional protocol)
+ "Set the PROTOCOL-local binding of VAR to VAL.
+If omitted PROTOCOL defaults to the current value of `eudc-protocol'.
+The current binding of VAR is changed only if PROTOCOL is omitted."
+ (if (eq 'unbound (eudc-variable-default-value var))
+ (eudc-default-set var (symbol-value var)))
+ (let* ((eudc-locals (get var 'eudc-locals))
+ (protocol-locals (eudc-plist-get eudc-locals 'protocol)))
+ (setq protocol-locals (plist-put protocol-locals (or protocol
+ eudc-protocol) val))
+ (setq eudc-locals
+ (plist-put eudc-locals 'protocol protocol-locals))
+ (put var 'eudc-locals eudc-locals)
+ (add-to-list 'eudc-local-vars var)
+ (unless protocol
+ (eudc-update-variable var))))
+
+(defun eudc-server-set (var val &optional server)
+ "Set the SERVER-local binding of VAR to VAL.
+If omitted SERVER defaults to the current value of `eudc-server'.
+The current binding of VAR is changed only if SERVER is omitted."
+ (if (eq 'unbound (eudc-variable-default-value var))
+ (eudc-default-set var (symbol-value var)))
+ (let* ((eudc-locals (get var 'eudc-locals))
+ (server-locals (eudc-plist-get eudc-locals 'server)))
+ (setq server-locals (plist-put server-locals (or server
+ eudc-server) val))
+ (setq eudc-locals
+ (plist-put eudc-locals 'server server-locals))
+ (put var 'eudc-locals eudc-locals)
+ (add-to-list 'eudc-local-vars var)
+ (unless server
+ (eudc-update-variable var))))
+
+
+(defun eudc-set (var val)
+ "Set the most local (server, protocol or default) binding of VAR to VAL.
+The current binding of VAR is also set to VAL"
+ (cond
+ ((not (eq 'unbound (eudc-variable-server-value var)))
+ (eudc-server-set var val))
+ ((not (eq 'unbound (eudc-variable-protocol-value var)))
+ (eudc-protocol-set var val))
+ (t
+ (eudc-default-set var val)))
+ (set var val))
+
+(defun eudc-variable-default-value (var)
+ "Return the default binding of VAR.
+Return `unbound' if VAR has no EUDC default value."
+ (let ((eudc-locals (get var 'eudc-locals)))
+ (if (and (boundp var)
+ eudc-locals)
+ (eudc-plist-get eudc-locals 'default 'unbound)
+ 'unbound)))
+
+(defun eudc-variable-protocol-value (var &optional protocol)
+ "Return the value of VAR local to PROTOCOL.
+Return `unbound' if VAR has no value local to PROTOCOL.
+PROTOCOL defaults to `eudc-protocol'"
+ (let* ((eudc-locals (get var 'eudc-locals))
+ protocol-locals)
+ (if (not (and (boundp var)
+ eudc-locals
+ (eudc-plist-member eudc-locals 'protocol)))
+ 'unbound
+ (setq protocol-locals (eudc-plist-get eudc-locals 'protocol))
+ (eudc-lax-plist-get protocol-locals
+ (or protocol
+ eudc-protocol) 'unbound))))
+
+(defun eudc-variable-server-value (var &optional server)
+ "Return the value of VAR local to SERVER.
+Return `unbound' if VAR has no value local to SERVER.
+SERVER defaults to `eudc-server'"
+ (let* ((eudc-locals (get var 'eudc-locals))
+ server-locals)
+ (if (not (and (boundp var)
+ eudc-locals
+ (eudc-plist-member eudc-locals 'server)))
+ 'unbound
+ (setq server-locals (eudc-plist-get eudc-locals 'server))
+ (eudc-lax-plist-get server-locals
+ (or server
+ eudc-server) 'unbound))))
+
+(defun eudc-update-variable (var)
+ "Set the value of VAR according to its locals.
+If the VAR has a server- or protocol-local value corresponding
+to the current `eudc-server' and `eudc-protocol' then it is set
+accordingly. Otherwise it is set to its EUDC default binding"
+ (let (val)
+ (cond
+ ((not (eq 'unbound (setq val (eudc-variable-server-value var))))
+ (set var val))
+ ((not (eq 'unbound (setq val (eudc-variable-protocol-value var))))
+ (set var val))
+ ((not (eq 'unbound (setq val (eudc-variable-default-value var))))
+ (set var val)))))
+
+(defun eudc-update-local-variables ()
+ "Update all EUDC variables according to their local settings."
+ (interactive)
+ (mapcar 'eudc-update-variable eudc-local-vars))
+
+(eudc-default-set 'eudc-query-function nil)
+(eudc-default-set 'eudc-list-attributes-function nil)
+(eudc-default-set 'eudc-protocol-attributes-translation-alist nil)
+(eudc-default-set 'eudc-bbdb-conversion-alist nil)
+(eudc-default-set 'eudc-switch-to-server-hook nil)
+(eudc-default-set 'eudc-switch-from-server-hook nil)
+(eudc-default-set 'eudc-protocol-has-default-query-attributes nil)
+(eudc-default-set 'eudc-attribute-display-method-alist nil)
+
+;;}}}
+
+
+;; Add PROTOCOL to the list of supported protocols
+(defun eudc-register-protocol (protocol)
+ (unless (memq protocol eudc-supported-protocols)
+ (setq eudc-supported-protocols
+ (cons protocol eudc-supported-protocols))
+ (put 'eudc-protocol 'custom-type
+ `(choice :menu-tag "Protocol"
+ ,@(mapcar (lambda (s)
+ (list 'string ':tag (symbol-name s)))
+ eudc-supported-protocols))))
+ (or (memq protocol eudc-known-protocols)
+ (setq eudc-known-protocols
+ (cons protocol eudc-known-protocols))))
+
+
+(defun eudc-translate-query (query)
+ "Translate attribute names of QUERY.
+The translation is done according to
+`eudc-protocol-attributes-translation-alist'."
+ (if eudc-protocol-attributes-translation-alist
+ (mapcar '(lambda (attribute)
+ (let ((trans (assq (car attribute)
+ (symbol-value eudc-protocol-attributes-translation-alist))))
+ (if trans
+ (cons (cdr trans) (cdr attribute))
+ attribute)))
+ query)
+ query))
+
+(defun eudc-translate-attribute-list (list)
+ "Translate a list of attribute names LIST.
+The translation is done according to
+`eudc-protocol-attributes-translation-alist'."
+ (if eudc-protocol-attributes-translation-alist
+ (let (trans)
+ (mapcar '(lambda (attribute)
+ (setq trans (assq attribute
+ (symbol-value eudc-protocol-attributes-translation-alist)))
+ (if trans
+ (cdr trans)
+ 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*"
+ (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-query (query &optional return-attributes no-translation)
+ "Query the current directory server with QUERY.
+QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
+name and VALUE the corresponding value.
+If NO-TRANSLATION is non-nil, ATTR is translated according to
+`eudc-protocol-attributes-translation-alist'.
+RETURN-ATTRIBUTES is a list of attributes to return defaulting to
+`eudc-default-return-attributes'."
+ (unless eudc-query-function
+ (error "Don't know how to perform the query"))
+ (if no-translation
+ (funcall eudc-query-function query (or return-attributes
+ eudc-default-return-attributes))
+
+ (funcall eudc-query-function
+ (eudc-translate-query query)
+ (cond
+ (return-attributes
+ (eudc-translate-attribute-list return-attributes))
+ ((listp eudc-default-return-attributes)
+ (eudc-translate-attribute-list eudc-default-return-attributes))
+ (t
+ eudc-default-return-attributes)))))
+
+(defun eudc-format-attribute-name-for-display (attribute)
+ "Format a directory attribute name for display.
+ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced
+by the corresponding user name if any. Otherwise it is capitalized and
+underscore characters are replaced by spaces."
+ (let ((match (assq attribute eudc-user-attribute-names-alist)))
+ (if match
+ (cdr match)
+ (capitalize
+ (mapconcat 'identity
+ (split-string (symbol-name attribute) "_")
+ " ")))))
+
+(defun eudc-print-attribute-value (field)
+ "Insert the value of the directory FIELD at point.
+The directory attribute name in car of FIELD is looked up in
+`eudc-attribute-display-method-alist' and the corresponding method,
+if any, is called to print the value in cdr of FIELD."
+ (let ((match (assoc (downcase (car field))
+ eudc-attribute-display-method-alist))
+ (col (current-column))
+ (val (cdr field)))
+ (if match
+ (progn
+ (eval (list (cdr match) val))
+ (insert "\n"))
+ (mapcar
+ (function
+ (lambda (val-elem)
+ (indent-to col)
+ (insert val-elem "\n")))
+ (cond
+ ((listp val) val)
+ ((stringp val) (split-string val "\n"))
+ ((null val) '(""))
+ (t (list val)))))))
+
+(defun eudc-print-record-field (field column-width)
+ "Print the record field FIELD.
+FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
+COLUMN-WIDTH is the width of the first display column containing the
+attribute name ATTR."
+ (let ((field-beg (point)))
+;; The record field that is passed to this function has already been processed
+;; by `eudc-format-attribute-name-for-display' so we don't need to call it
+;; again to display the attribute name
+ (insert (format (concat "%" (int-to-string column-width) "s: ")
+ (car field)))
+ (put-text-property field-beg (point) 'face 'bold)
+ (indent-to (+ 2 column-width))
+ (eudc-print-attribute-value field)))
+
+(defun eudc-display-records (records &optional raw-attr-names)
+ "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
+ 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)
+ (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."
+ (let (query-alist
+ value)
+ (if (not (and (boundp 'eudc-form-widget-list)
+ eudc-form-widget-list))
+ (error "Not in a directory query form buffer")
+ (mapcar (function
+ (lambda (wid-field)
+ (setq value (widget-value (cdr wid-field)))
+ (if (not (string= value ""))
+ (setq query-alist (cons (cons (car wid-field) value)
+ query-alist)))))
+ eudc-form-widget-list)
+ (kill-buffer (current-buffer))
+ (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names))))
+
+
+
+(defun eudc-filter-duplicate-attributes (record)
+ "Filter RECORD according to `eudc-duplicate-attribute-handling-method'."
+ (let ((rec record)
+ unique
+ duplicates
+ result)
+
+ ;; Search for multiple records
+ (while (and rec
+ (not (listp (eudc-cdar rec))))
+ (setq rec (cdr rec)))
+
+ (if (null (eudc-cdar rec))
+ (list record) ; No duplicate attrs in this record
+ (mapcar (function
+ (lambda (field)
+ (if (listp (cdr field))
+ (setq duplicates (cons field duplicates))
+ (setq unique (cons field unique)))))
+ record)
+ (setq result (list unique))
+ ;; Map over the record fields that have multiple values
+ (mapcar
+ (function
+ (lambda (field)
+ (let ((method (if (consp eudc-duplicate-attribute-handling-method)
+ (cdr
+ (assq
+ (or
+ (car
+ (rassq
+ (car field)
+ (symbol-value
+ eudc-protocol-attributes-translation-alist)))
+ (car field))
+ eudc-duplicate-attribute-handling-method))
+ eudc-duplicate-attribute-handling-method)))
+ (cond
+ ((or (null method) (eq 'list method))
+ (setq result
+ (eudc-add-field-to-records field result)))
+ ((eq 'first method)
+ (setq result
+ (eudc-add-field-to-records (cons (car field)
+ (eudc-cadr field))
+ result)))
+ ((eq 'concat method)
+ (setq result
+ (eudc-add-field-to-records (cons (car field)
+ (mapconcat
+ 'identity
+ (cdr field)
+ "\n")) result)))
+ ((eq 'duplicate method)
+ (setq result
+ (eudc-distribute-field-on-records field result)))))))
+ duplicates)
+ result)))
+
+(defun eudc-filter-partial-records (records attrs)
+ "Eliminate records that do not caontain all ATTRS from RECORDS."
+ (delq nil
+ (mapcar
+ (function
+ (lambda (rec)
+ (if (eval (cons 'and
+ (mapcar
+ (function
+ (lambda (attr)
+ (consp (assq attr rec))))
+ attrs)))
+ rec)))
+ records)))
+
+(defun eudc-add-field-to-records (field records)
+ "Add FIELD to each individual record in RECORDS and return the resulting list."
+ (mapcar (function
+ (lambda (r)
+ (cons field r)))
+ records))
+
+(defun eudc-distribute-field-on-records (field records)
+ "Duplicate each individual record in RECORDS according to value of FIELD.
+Each copy is added a new field containing one of the values of FIELD."
+ (let (result
+ (values (cdr field)))
+ ;; Uniquify values first
+ (while values
+ (setcdr values (delete (car values) (cdr values)))
+ (setq values (cdr values)))
+ (mapcar
+ (function
+ (lambda (value)
+ (let ((result-list (copy-sequence records)))
+ (setq result-list (eudc-add-field-to-records
+ (cons (car field) value)
+ result-list))
+ (setq result (append result-list result))
+ )))
+ (cdr field))
+ result))
+
+
+(defun eudc-mode ()
+ "Major mode used in buffers displaying the results of directory queries.
+There is no sense in calling this command from a buffer other than
+one containing the results of a directory query.
+
+These are the special commands of EUDC mode:
+ q -- Kill this buffer.
+ f -- Display a form to query the current directory server.
+ n -- Move to next record.
+ p -- Move to previous record.
+ b -- Insert record at point into the BBDB database."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'eudc-mode)
+ (setq mode-name "EUDC")
+ (use-local-map eudc-mode-map)
+ (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)
+ )
+
+;;}}}
+
+;;{{{ High-level interfaces (interactive functions)
+
+(defun eudc-customize ()
+ "Customize the EUDC package."
+ (interactive)
+ (customize-group 'eudc))
+
+;;;###autoload
+(defun eudc-set-server (server protocol &optional no-save)
+ "Set the directory server to SERVER using PROTOCOL.
+Unless NO-SAVE is non-nil, the server is saved as the default
+server for future sessions."
+ (interactive (list
+ (read-from-minibuffer "Directory Server: ")
+ (intern (completing-read "Protocol: "
+ (mapcar '(lambda (elt)
+ (cons (symbol-name elt)
+ elt))
+ eudc-known-protocols)))))
+ (unless (or (member protocol
+ eudc-supported-protocols)
+ (load (concat "eudcb-" (symbol-name protocol)) t))
+ (error "Unsupported protocol: %s" protocol))
+ (run-hooks 'eudc-switch-from-server-hook)
+ (setq eudc-protocol protocol)
+ (setq eudc-server server)
+ (eudc-update-local-variables)
+ (run-hooks 'eudc-switch-to-server-hook)
+ (if (interactive-p)
+ (message "Current directory server is now %s (%s)" eudc-server eudc-protocol))
+ (if (null no-save)
+ (eudc-save-options)))
+
+;;;###autoload
+(defun eudc-get-email (name)
+ "Get the email field of NAME from the directory server."
+ (interactive "sName: ")
+ (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)
+ (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: ")
+ (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)
+ (if phone
+ (message "%s" phone)
+ (error "No record matching %s" name)))
+ phone))
+
+(defun eudc-get-attribute-list ()
+ "Return a list of valid attributes for the current server.
+When called interactively the list is formatted in a dedicated buffer
+otherwise a list of symbols is returned."
+ (interactive)
+ (if eudc-list-attributes-function
+ (let ((entries (funcall eudc-list-attributes-function (interactive-p))))
+ (if entries
+ (if (interactive-p)
+ (eudc-display-records entries t)
+ entries)))
+ (error "The %s protocol has no support for listing attributes" eudc-protocol)))
+
+(defun eudc-format-query (words format)
+ "Use FORMAT to build a EUDC query from WORDS."
+ (let (query
+ query-alist
+ key val cell)
+ (if format
+ (progn
+ (while (and words format)
+ (setq query-alist (cons (cons (car format) (car words))
+ query-alist))
+ (setq words (cdr words)
+ format (cdr format)))
+ ;; 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)
+ val (eudc-cdar query-alist)
+ cell (assq key query))
+ (if cell
+ (setcdr cell (concat (cdr cell) " " val))
+ (setq query (cons (car query-alist) query)))
+ (setq query-alist (cdr query-alist)))
+ query)
+ (if eudc-protocol-has-default-query-attributes
+ (mapconcat 'identity words " ")
+ (list (cons 'name (mapconcat 'identity words " ")))))))
+
+(defun eudc-extract-n-word-formats (format-list n)
+ "Extract a list of N-long formats from FORMAT-LIST.
+If none try N - 1 and so forth."
+ (let (formats)
+ (while (and (null formats)
+ (> n 0))
+ (setq formats
+ (delq nil
+ (mapcar '(lambda (format)
+ (if (= n
+ (length format))
+ format
+ nil))
+ format-list)))
+ (setq n (1- n)))
+ formats))
+
+
+
+;;;###autoload
+(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.
+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.
+`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 (memq eudc-inline-expansion-servers
+ '(current-server server-then-hotlist))
+ (or eudc-server
+ (call-interactively 'eudc-set-server))
+ (or eudc-server-hotlist
+ (error "No server in the hotlist")))
+ (let* ((end (point))
+ (beg (save-excursion
+ (if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ 'move)
+ (goto-char (match-end 0)))
+ (point)))
+ (query-words (split-string (buffer-substring beg end) "[ \t]+"))
+ query-formats
+ response
+ response-string
+ response-strings
+ (eudc-former-server eudc-server)
+ (eudc-former-protocol eudc-protocol)
+ servers)
+
+ ;; Prepare the list of servers to query
+ (setq servers (copy-sequence eudc-server-hotlist))
+ (setq servers
+ (cond
+ ((eq eudc-inline-expansion-servers 'hotlist)
+ eudc-server-hotlist)
+ ((eq eudc-inline-expansion-servers 'server-then-hotlist)
+ (cons (cons eudc-server eudc-protocol)
+ (delete (cons eudc-server eudc-protocol) servers)))
+ ((eq eudc-inline-expansion-servers 'current-server)
+ (list (cons eudc-server eudc-protocol)))
+ (t
+ (error "Wrong value for `eudc-inline-expansion-servers': %S"
+ eudc-inline-expansion-servers))))
+ (if (and eudc-max-servers-to-query
+ (> (length servers) eudc-max-servers-to-query))
+ (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil))
+
+ (condition-case signal
+ (progn
+ (setq response
+ (catch 'found
+ ;; Loop on the servers
+ (while servers
+ (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t)
+
+ ;; Determine which formats apply in the query-format list
+ (setq query-formats
+ (or
+ (eudc-extract-n-word-formats eudc-inline-query-format
+ (length query-words))
+ (if (null eudc-protocol-has-default-query-attributes)
+ '(name))))
+
+ ;; Loop on query-formats
+ (while query-formats
+ (setq response
+ (eudc-query
+ (eudc-format-query query-words (car query-formats))
+ (eudc-translate-attribute-list
+ (cdr eudc-inline-expansion-format))))
+ (if response
+ (throw 'found response))
+ (setq query-formats (cdr query-formats)))
+ (setq servers (cdr servers)))
+ ;; No more servers to try... no match found
+ nil))
+
+
+ (if (null response)
+ (error "No match")
+
+ ;; Process response through eudc-inline-expansion-format
+ (while response
+ (setq response-string (apply 'format
+ (car eudc-inline-expansion-format)
+ (mapcar (function
+ (lambda (field)
+ (or (cdr (assq field (car response)))
+ "")))
+ (eudc-translate-attribute-list
+ (cdr eudc-inline-expansion-format)))))
+ (if (> (length response-string) 0)
+ (setq response-strings
+ (cons response-string response-strings)))
+ (setq response (cdr response)))
+
+ (if (or
+ (and replace (not eudc-expansion-overwrites-query))
+ (and (not replace) eudc-expansion-overwrites-query))
+ (delete-region beg end))
+ (cond
+ ((or (= (length response-strings) 1)
+ (null eudc-multiple-match-handling-method)
+ (eq eudc-multiple-match-handling-method 'first))
+ (insert (car response-strings)))
+ ((eq eudc-multiple-match-handling-method 'select)
+ (eudc-select response-strings))
+ ((eq eudc-multiple-match-handling-method 'all)
+ (insert (mapconcat 'identity response-strings ", ")))
+ ((eq eudc-multiple-match-handling-method 'abort)
+ (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)))
+ (t
+ (or (and (equal eudc-server eudc-former-server)
+ (equal eudc-protocol eudc-former-protocol))
+ (eudc-set-server eudc-former-server eudc-former-protocol t))
+ (signal (car signal) (cdr signal))))))
+
+;;;###autoload
+(defun eudc-query-form (&optional get-fields-from-server)
+ "Display a form to query the directory server.
+If given a non-nil argument GET-FIELDS-FROM-SERVER, the function first
+queries the server for the existing fields and displays a corresponding form."
+ (interactive "P")
+ (let ((fields (or (and get-fields-from-server
+ (eudc-get-attribute-list))
+ eudc-query-form-attributes))
+ (buffer (get-buffer-create "*Directory Query Form*"))
+ prompts
+ widget
+ (width 0)
+ inhibit-read-only
+ pt)
+ (switch-to-buffer buffer)
+ (setq inhibit-read-only t)
+ (erase-buffer)
+ (kill-all-local-variables)
+ (make-local-variable 'eudc-form-widget-list)
+ (widget-insert "Directory Query Form\n")
+ (widget-insert "====================\n\n")
+ (widget-insert "Current server is: " (or eudc-server
+ (progn
+ (call-interactively 'eudc-set-server)
+ eudc-server))
+ "\n")
+ (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n")
+ ;; 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 "%" (int-to-string width) "s: ") (car prompts)))
+ (setq pt (point))
+ (setq widget (widget-create 'editable-field :size 15))
+ (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 "%" (int-to-string width) "s: ") (car prompts)))
+ (setq widget (widget-create 'editable-field
+ :size 15))
+ (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
+ :notify (lambda (&rest ignore)
+ (eudc-process-form))
+ "Query Server")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (eudc-query-form))
+ "Reset Form")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (kill-this-buffer))
+ "Quit")
+ (goto-char pt)
+ (use-local-map widget-keymap)
+ (widget-setup))
+ )
+
+(defun eudc-bookmark-server (server protocol)
+ "Add SERVER using PROTOCOL to the EUDC `servers' hotlist."
+ (interactive "sDirectory server: \nsProtocol: ")
+ (if (member (cons server protocol) eudc-server-hotlist)
+ (error "%s:%s is already in the hotlist" protocol server)
+ (setq eudc-server-hotlist (cons (cons server protocol) eudc-server-hotlist))
+ (eudc-install-menu)
+ (eudc-save-options)))
+
+(defun eudc-bookmark-current-server ()
+ "Add current server to the EUDC `servers' hotlist."
+ (interactive)
+ (eudc-bookmark-server eudc-server eudc-protocol))
+
+(defun eudc-save-options ()
+ "Save options to `eudc-options-file'."
+ (interactive)
+ (save-excursion
+ (set-buffer (find-file-noselect eudc-options-file t))
+ (goto-char (point-min))
+ ;; delete the previous setq
+ (let ((standard-output (current-buffer))
+ provide-p
+ set-hotlist-p
+ set-server-p)
+ (catch 'found
+ (while t
+ (let ((sexp (condition-case nil
+ (read (current-buffer))
+ (end-of-file (throw 'found nil)))))
+ (if (listp sexp)
+ (cond
+ ((eq (car sexp) 'eudc-set-server)
+ (delete-region (save-excursion
+ (backward-sexp)
+ (point))
+ (point))
+ (setq set-server-p t))
+ ((and (eq (car sexp) 'setq)
+ (eq (eudc-cadr sexp) 'eudc-server-hotlist))
+ (delete-region (save-excursion
+ (backward-sexp)
+ (point))
+ (point))
+ (setq set-hotlist-p t))
+ ((and (eq (car sexp) 'provide)
+ (equal (eudc-cadr sexp) '(quote eudc-options-file)))
+ (setq provide-p t)))
+ (if (and provide-p
+ set-hotlist-p
+ set-server-p)
+ (throw 'found t))))))
+ (if (eq (point-min) (point-max))
+ (princ ";; This file was automatically generated by eudc.el.\n\n"))
+ (or provide-p
+ (princ "(provide 'eudc-options-file)\n"))
+ (or (bolp)
+ (princ "\n"))
+ (delete-blank-lines)
+ (princ "(eudc-set-server ")
+ (prin1 eudc-server)
+ (princ " '")
+ (prin1 eudc-protocol)
+ (princ " t)\n")
+ (princ "(setq eudc-server-hotlist '")
+ (prin1 eudc-server-hotlist)
+ (princ ")\n")
+ (save-buffer))))
+
+(defun eudc-move-to-next-record ()
+ "Move to next record, in a buffer displaying directory query results."
+ (interactive)
+ (if (not (eq major-mode 'eudc-mode))
+ (error "Not in a EUDC buffer")
+ (let ((pt (next-overlay-change (point))))
+ (if (< pt (point-max))
+ (goto-char (1+ pt))
+ (error "No more records after point")))))
+
+(defun eudc-move-to-previous-record ()
+ "Move to previous record, in a buffer displaying directory query results."
+ (interactive)
+ (if (not (eq major-mode 'eudc-mode))
+ (error "Not in a EUDC buffer")
+ (let ((pt (previous-overlay-change (point))))
+ (if (> pt (point-min))
+ (goto-char pt)
+ (error "No more records before point")))))
+
+
+
+;;}}}
+
+;;{{{ Menus an keymaps
+
+(require 'easymenu)
+
+(setq eudc-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "q" 'kill-this-buffer)
+ (define-key map "x" 'kill-this-buffer)
+ (define-key map "f" 'eudc-query-form)
+ (define-key map "b" 'eudc-try-bbdb-insert)
+ (define-key map "n" 'eudc-move-to-next-record)
+ (define-key map "p" 'eudc-move-to-previous-record)
+ map))
+(set-keymap-parent eudc-mode-map widget-keymap)
+
+(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc)))
+
+(defconst eudc-tail-menu
+ `(["---" nil nil]
+ ["Query with Form" eudc-query-form t]
+ ["Expand 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 "")))
+ (overlays-at (point))
+ (overlay-get (car (overlays-at (point))) 'eudc-record))]
+ ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb
+ (and (eq major-mode 'eudc-mode)
+ (or (featurep 'bbdb)
+ (prog1 (locate-library "bbdb") (message ""))))]
+ ["---" nil nil]
+ ["Get Email" eudc-get-email t]
+ ["Get Phone" eudc-get-phone t]
+ ["List Valid Attribute Names" eudc-get-attribute-list t]
+ ["---" nil nil]
+ ,(cons "Customize" eudc-custom-generated-menu)))
+
+
+(defconst eudc-server-menu
+ '(["---" nil nil]
+ ["Bookmark Current Server" eudc-bookmark-current-server t]
+ ["Edit Server List" eudc-edit-hotlist t]
+ ["New Server" eudc-set-server t]))
+
+(defun eudc-menu ()
+ (let (command)
+ (append '("Directory Search")
+ (list
+ (append
+ '("Server")
+ (mapcar
+ (function
+ (lambda (servspec)
+ (let* ((server (car servspec))
+ (protocol (cdr servspec))
+ (proto-name (symbol-name protocol)))
+ (setq command (intern (concat "eudc-set-server-"
+ server
+ "-"
+ proto-name)))
+ (if (not (fboundp command))
+ (fset command
+ `(lambda ()
+ (interactive)
+ (eudc-set-server ,server (quote ,protocol))
+ (message "Selected directory server is now %s (%s)"
+ ,server
+ ,proto-name))))
+ (vector (format "%s (%s)" server proto-name)
+ command
+ :style 'radio
+ :selected `(equal eudc-server ,server)))))
+ eudc-server-hotlist)
+ eudc-server-menu))
+ eudc-tail-menu)))
+
+(defun eudc-install-menu ()
+ (cond
+ ((and eudc-xemacs-p (featurep 'menubar))
+ (add-submenu '("Tools") (eudc-menu)))
+ (eudc-emacs-p
+ (cond
+ ((fboundp 'easy-menu-add-item)
+ (let ((menu (eudc-menu)))
+ (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
+ (cdr menu)))))
+ ((fboundp 'easy-menu-create-keymaps)
+ (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu))
+ (define-key
+ global-map
+ [menu-bar tools eudc]
+ (cons "Directory Search"
+ (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu))))))
+ (t
+ (error "Unknown version of easymenu"))))
+ ))
+
+
+;;; Load time initializations :
+
+;;; Load the options file
+(if (and (not noninteractive)
+ (and (locate-library eudc-options-file)
+ (message "")) ; Remove modeline message
+ (not (featurep 'eudc-options-file)))
+ (load eudc-options-file))
+
+
+;;; Install the full menu
+(unless (featurep 'infodock)
+ (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
+(let ((menu '("Directory Search"
+ ["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])))
+ (if (not (featurep 'eudc-autoloads))
+ (if (string-match "XEmacs" emacs-version)
+ (if (and (featurep 'menubar)
+ (not (featurep 'infodock)))
+ (add-submenu '("Tools") menu))
+ (require 'easymenu)
+ (cond
+ ((fboundp 'easy-menu-add-item)
+ (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu)
+ (cdr menu))))
+ ((fboundp 'easy-menu-create-keymaps)
+ (define-key
+ global-map
+ [menu-bar tools eudc]
+ (cons "Directory Search"
+ (easy-menu-create-keymaps "Directory Search" (cdr menu)))))))))
+
+;;}}}
+
+(provide 'eudc)
+
+;;; eudc.el ends here
--- /dev/null
+;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Commentary:
+;; This library provides an interface to use BBDB as a backend of
+;; the Emacs Unified Directory Client.
+
+;;; Code:
+
+(require 'eudc)
+(if (not (featurep 'bbdb))
+ (load-library "bbdb"))
+(if (not (featurep 'bbdb-com))
+ (load-library "bbdb-com"))
+
+;;{{{ Internal cooking
+
+;; I don't like this but mapcar does not accept a parameter to the function and
+;; I don't want to use mapcar*
+(defvar eudc-bbdb-current-query nil)
+(defvar eudc-bbdb-current-return-attributes nil)
+
+(defvar eudc-bbdb-attributes-translation-alist
+ '((name . lastname)
+ (email . net)
+ (phone . phones))
+ "Alist mapping EUDC attribute names to BBDB names.")
+
+(eudc-protocol-set 'eudc-query-function 'eudc-bbdb-query-internal 'bbdb)
+(eudc-protocol-set 'eudc-list-attributes-function nil 'bbdb)
+(eudc-protocol-set 'eudc-protocol-attributes-translation-alist
+ 'eudc-bbdb-attributes-translation-alist 'bbdb)
+(eudc-protocol-set 'eudc-bbdb-conversion-alist nil 'bbdb)
+(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'bbdb)
+
+(defun eudc-bbdb-format-query (query)
+ "Format a EUDC query alist into a list suitable to `bbdb-search'."
+ (let* ((firstname (cdr (assq 'firstname query)))
+ (lastname (cdr (assq 'lastname query)))
+ (name (or (and firstname lastname
+ (concat firstname " " lastname))
+ firstname
+ lastname))
+ (company (cdr (assq 'company query)))
+ (net (cdr (assq 'net query)))
+ (notes (cdr (assq 'notes query)))
+ (phone (cdr (assq 'phone query))))
+ (list name company net notes phone)))
+
+
+(defun eudc-bbdb-filter-non-matching-record (record)
+ "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
+ (catch 'unmatch
+ (progn
+ (mapcar
+ (function
+ (lambda (condition)
+ (let ((attr (car condition))
+ (val (cdr condition))
+ (case-fold-search t)
+ bbdb-val)
+ (or (and (memq attr '(firstname lastname aka company phones addresses net))
+ (progn
+ (setq bbdb-val
+ (eval (list (intern (concat "bbdb-record-"
+ (symbol-name attr)))
+ 'record)))
+ (if (listp bbdb-val)
+ (if eudc-bbdb-enable-substring-matches
+ (eval `(or ,@(mapcar '(lambda (subval)
+ (string-match val
+ subval))
+ bbdb-val)))
+ (member (downcase val)
+ (mapcar 'downcase bbdb-val)))
+ (if eudc-bbdb-enable-substring-matches
+ (string-match val bbdb-val)
+ (string-equal (downcase val) (downcase bbdb-val))))))
+ (throw 'unmatch nil)))))
+ eudc-bbdb-current-query)
+ record)))
+
+(defun eudc-bbdb-extract-phones (record)
+ (mapcar (function
+ (lambda (phone)
+ (if eudc-bbdb-use-locations-as-attribute-names
+ (cons (intern (bbdb-phone-location phone))
+ (bbdb-phone-string phone))
+ (cons 'phones (format "%s: %s"
+ (bbdb-phone-location phone)
+ (bbdb-phone-string phone))))))
+ (bbdb-record-phones record)))
+
+(defun eudc-bbdb-extract-addresses (record)
+ (let (s c val)
+ (mapcar (function
+ (lambda (address)
+ (setq val (concat (unless (= 0 (length (setq s (bbdb-address-street1 address))))
+ (concat s "\n"))
+ (unless (= 0 (length (setq s (bbdb-address-street2 address))))
+ (concat s "\n"))
+ (unless (= 0 (length (setq s (bbdb-address-street3 address))))
+ (concat s "\n"))
+ (progn
+ (setq c (bbdb-address-city address))
+ (setq s (bbdb-address-state address))
+ (if (and (> (length c) 0) (> (length s) 0))
+ (concat c ", " s " ")
+ (concat c " ")))
+ (bbdb-address-zip-string address)))
+ (if eudc-bbdb-use-locations-as-attribute-names
+ (cons (intern (bbdb-address-location address)) val)
+ (cons 'addresses (concat (bbdb-address-location address) "\n" val)))))
+ (bbdb-record-addresses record))))
+
+(defun eudc-bbdb-format-record-as-result (record)
+ "Format the BBDB RECORD as a EUDC query result record.
+The record is filtered according to `eudc-bbdb-current-return-attributes'"
+ (let ((attrs (or eudc-bbdb-current-return-attributes
+ '(firstname lastname aka company phones addresses net notes)))
+ attr
+ eudc-rec
+ val)
+ (while (prog1
+ (setq attr (car attrs))
+ (setq attrs (cdr attrs)))
+ (cond
+ ((eq attr 'phones)
+ (setq val (eudc-bbdb-extract-phones record)))
+ ((eq attr 'addresses)
+ (setq val (eudc-bbdb-extract-addresses record)))
+ ((memq attr '(firstname lastname aka company net notes))
+ (setq val (eval
+ (list (intern
+ (concat "bbdb-record-"
+ (symbol-name attr)))
+ 'record))))
+ (t
+ (setq val "Unknown BBDB attribute")))
+ (if val
+ (cond
+ ((memq attr '(phones addresses))
+ (setq eudc-rec (append val eudc-rec)))
+ ((and (listp val)
+ (= 1 (length val)))
+ (setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
+ ((> (length val) 0)
+ (setq eudc-rec (cons (cons attr val) eudc-rec)))
+ (t
+ (error "Unexpected attribute value")))))
+ (nreverse eudc-rec)))
+
+
+
+(defun eudc-bbdb-query-internal (query &optional return-attrs)
+ "Query BBDB with QUERY.
+QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
+BBDB attribute names.
+RETURN-ATTRS is a list of attributes to return, defaulting to
+`eudc-default-return-attributes'."
+
+ (let ((eudc-bbdb-current-query query)
+ (eudc-bbdb-current-return-attributes return-attrs)
+ (query-attrs (eudc-bbdb-format-query query))
+ bbdb-attrs
+ (records (bbdb-records))
+ result
+ filtered)
+ ;; BBDB ORs its query attributes while EUDC ANDs them, hence we need to
+ ;; call bbdb-search iteratively on the returned records for each of the
+ ;; requested attributes
+ (while (and records (> (length query-attrs) 0))
+ (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs))))
+ (if (car query-attrs)
+ (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs))))
+ (setq query-attrs (cdr query-attrs)))
+ (mapcar (function
+ (lambda (record)
+ (setq filtered (eudc-filter-duplicate-attributes record))
+ ;; If there were duplicate attributes reverse the order of the
+ ;; record so the unique attributes appear first
+ (if (> (length filtered) 1)
+ (setq filtered (mapcar (function
+ (lambda (rec)
+ (reverse rec)))
+ filtered)))
+ (setq result (append result filtered))))
+ (delq nil
+ (mapcar 'eudc-bbdb-format-record-as-result
+ (delq nil
+ (mapcar 'eudc-bbdb-filter-non-matching-record
+ records)))))
+ result))
+
+;;}}}
+
+;;{{{ High-level interfaces (interactive functions)
+
+(defun eudc-bbdb-set-server (dummy)
+ "Set the EUDC server to BBDB."
+ (interactive)
+ (eudc-set-server dummy 'bbdb)
+ (message "BBDB server selected"))
+
+;;;}}}
+
+
+(eudc-register-protocol 'bbdb)
+
+(provide 'eudcb-bbdb)
+
+;;; eudcb-bbdb.el ends here
--- /dev/null
+;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Commentary:
+;; This library provides specific LDAP protocol support for the
+;; Emacs Unified Directory Client package
+
+;;; Installation:
+;; Install EUDC first. See EUDC documentation.
+
+;;; Code:
+
+(require 'eudc)
+(require 'ldap)
+
+
+;;{{{ Internal cooking
+
+(eval-and-compile
+ (if (fboundp 'ldap-get-host-parameter)
+ (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter)
+ (defun eudc-ldap-get-host-parameter (host parameter)
+ "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
+ (plist-get (cdr (assoc host ldap-host-parameters-alist))
+ parameter))))
+
+(defvar eudc-ldap-attributes-translation-alist
+ '((name . sn)
+ (firstname . givenname)
+ (email . mail)
+ (phone . telephonenumber))
+ "Alist mapping EUDC attribute names to LDAP names.")
+
+(eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal
+ 'ldap)
+(eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list
+ 'ldap)
+(eudc-protocol-set 'eudc-protocol-attributes-translation-alist
+ 'eudc-ldap-attributes-translation-alist 'ldap)
+(eudc-protocol-set 'eudc-bbdb-conversion-alist
+ 'eudc-ldap-bbdb-conversion-alist
+ 'ldap)
+(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap)
+(eudc-protocol-set 'eudc-attribute-display-method-alist
+ '(("jpegphoto" . eudc-display-jpeg-inline)
+ ("labeledurl" . eudc-display-url)
+ ("audio" . eudc-display-sound)
+ ("labeledurl" . eudc-display-url)
+ ("url" . eudc-display-url))
+ 'ldap)
+(eudc-protocol-set 'eudc-switch-to-server-hook
+ '(eudc-ldap-check-base)
+ 'ldap)
+
+(defun eudc-ldap-cleanup-record-simple (record)
+ "Do some cleanup in a RECORD to make it suitable for EUDC."
+ (mapcar
+ (function
+ (lambda (field)
+ (cons (intern (car field))
+ (if (cdr (cdr field))
+ (cdr field)
+ (car (cdr field))))))
+ record))
+
+(defun eudc-filter-$ (string)
+ (mapconcat 'identity (split-string string "\\$") "\n"))
+
+;; Cleanup a LDAP record to make it suitable for EUDC:
+;; Make the record a cons-cell instead of a list if the it's single-valued
+;; Filter the $ character in addresses into \n if not done by the LDAP lib
+(defun eudc-ldap-cleanup-record-filtering-addresses (record)
+ (mapcar
+ (function
+ (lambda (field)
+ (let ((name (intern (car field)))
+ (value (cdr field)))
+ (if (memq name '(postaladdress registeredaddress))
+ (setq value (mapcar 'eudc-filter-$ value)))
+ (cons name
+ (if (cdr value)
+ value
+ (car value))))))
+ record))
+
+(defun eudc-ldap-simple-query-internal (query &optional return-attrs)
+ "Query the LDAP server with QUERY.
+QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
+LDAP attribute names.
+RETURN-ATTRS is a list of attributes to return, defaulting to
+`eudc-default-return-attributes'."
+ (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query)
+ eudc-server
+ (if (listp return-attrs)
+ (mapcar 'symbol-name return-attrs))))
+ final-result)
+ (if (or (not (boundp 'ldap-ignore-attribute-codings))
+ ldap-ignore-attribute-codings)
+ (setq result
+ (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result))
+ (setq result (mapcar 'eudc-ldap-cleanup-record-simple result)))
+
+ (if (and eudc-strict-return-matches
+ return-attrs
+ (not (eq 'all return-attrs)))
+ (setq result (eudc-filter-partial-records result return-attrs)))
+ ;; Apply eudc-duplicate-attribute-handling-method
+ (if (not (eq 'list eudc-duplicate-attribute-handling-method))
+ (mapcar
+ (function (lambda (record)
+ (setq final-result
+ (append (eudc-filter-duplicate-attributes record)
+ final-result))))
+ result))
+ final-result))
+
+(defun eudc-ldap-get-field-list (dummy &optional objectclass)
+ "Return a list of valid attribute names for the current server.
+OBJECTCLASS is the LDAP object class for which the valid
+attribute names are returned. Default to `person'"
+ (interactive)
+ (or eudc-server
+ (call-interactively 'eudc-set-server))
+ (let ((ldap-host-parameters-alist
+ (list (cons eudc-server
+ '(scope subtree sizelimit 1)))))
+ (mapcar 'eudc-ldap-cleanup-record
+ (ldap-search
+ (eudc-ldap-format-query-as-rfc1558
+ (list (cons "objectclass"
+ (or objectclass
+ "person"))))
+ eudc-server nil t))))
+
+(defun eudc-ldap-escape-query-special-chars (string)
+ "Value is STRING with characters forbidden in LDAP queries escaped."
+;; Note that * should also be escaped but in most situations I suppose
+;; the user doesn't want this
+ (eudc-replace-in-string
+ (eudc-replace-in-string
+ (eudc-replace-in-string
+ (eudc-replace-in-string
+ string
+ "\\\\" "\\5c")
+ "(" "\\28")
+ ")" "\\29")
+ (char-to-string ?\0) "\\00"))
+
+(defun eudc-ldap-format-query-as-rfc1558 (query)
+ "Format the EUDC QUERY list as a RFC1558 LDAP search filter."
+ (format "(&%s)"
+ (apply 'concat
+ (mapcar '(lambda (item)
+ (format "(%s=%s)"
+ (car item)
+ (eudc-ldap-escape-query-special-chars (cdr item))))
+ query))))
+
+
+;;}}}
+
+;;{{{ High-level interfaces (interactive functions)
+
+(defun eudc-ldap-customize ()
+ "Customize the EUDC LDAP support."
+ (interactive)
+ (customize-group 'eudc-ldap))
+
+(defun eudc-ldap-check-base ()
+ "Check if the current LDAP server has a configured search base."
+ (unless (or (eudc-ldap-get-host-parameter eudc-server 'base)
+ ldap-default-base
+ (null (y-or-n-p "No search base defined. Configure it now ?")))
+ ;; If the server is not in ldap-host-parameters-alist we add it for the
+ ;; user
+ (if (null (assoc eudc-server ldap-host-parameters-alist))
+ (setq ldap-host-parameters-alist
+ (cons (list eudc-server) ldap-host-parameters-alist)))
+ (customize-variable 'ldap-host-parameters-alist)))
+
+;;;}}}
+
+
+(eudc-register-protocol 'ldap)
+
+(provide 'eudcb-ldap)
+
+;;; eudcb-ldap.el ends here
--- /dev/null
+;;; eudcb-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Keywords: help
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Commentary:
+;; This library provides specific CCSO PH/QI protocol support for the
+;; Emacs Unified Directory Client package
+
+;;; Code:
+
+(require 'eudc)
+
+
+;;{{{ Internal cooking
+
+(eudc-protocol-set 'eudc-bbdb-conversion-alist 'eudc-ph-bbdb-conversion-alist 'ph)
+(eudc-protocol-set 'eudc-query-function 'eudc-ph-query-internal 'ph)
+(eudc-protocol-set 'eudc-list-attributes-function 'eudc-ph-get-field-list 'ph)
+(eudc-protocol-set 'eudc-protocol-has-default-query-attributes t 'ph)
+
+(defvar eudc-ph-process-buffer nil)
+(defvar eudc-ph-read-point)
+
+(defconst eudc-ph-default-server-port 105
+ "Default TCP port for CCSO PH/QI directory services.")
+
+
+
+
+(defun eudc-ph-query-internal (query &optional return-fields)
+ "Query the PH/QI server with QUERY.
+QUERY can be a string NAME or a list made of strings NAME
+and/or cons cells (KEY . VALUE) where KEYs should be valid
+CCSO database keys. NAME is equivalent to (DEFAULT . NAME),
+where DEFAULT is the default key of the database.
+RETURN-FIELDS is a list of database fields to return,
+defaulting to `eudc-default-return-attributes'."
+ (let (request)
+ (if (null return-fields)
+ (setq return-fields eudc-default-return-attributes))
+ (if (eq 'all return-fields)
+ (setq return-fields '(all)))
+ (setq request
+ (concat "query "
+ (if (stringp query)
+ query
+ (mapconcat (function (lambda (elt)
+ (if (stringp elt) elt)
+ (format "%s=%s" (car elt) (cdr elt))))
+ query
+ " "))
+ (if return-fields
+ (concat " return " (mapconcat 'symbol-name return-fields " ")))))
+ (and (> (length request) 6)
+ (eudc-ph-do-request request)
+ (eudc-ph-parse-query-result return-fields))))
+
+(defun eudc-ph-get-field-list (full-records)
+ "Return a list of valid field names for the current server.
+If FULL-RECORDS is non-nil, full records including field description
+are returned"
+ (interactive)
+ (eudc-ph-do-request "fields")
+ (if full-records
+ (eudc-ph-parse-query-result)
+ (mapcar 'eudc-caar (eudc-ph-parse-query-result))))
+
+
+(defun eudc-ph-parse-query-result (&optional fields)
+ "Return a list of alists of key/values from in `eudc-ph-process-buffer'.
+Fields not in FIELDS are discarded."
+ (let (record
+ records
+ line-regexp
+ current-key
+ key
+ value
+ ignore)
+ (save-excursion
+ (message "Parsing results...")
+ (set-buffer eudc-ph-process-buffer)
+ (goto-char (point-min))
+ (while (re-search-forward "^\\(-[0-9]+\\):\\([0-9]+\\):" nil t)
+ (catch 'ignore
+ (setq line-regexp (concat "^\\(-[0-9]+\\):" (match-string 2) ":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$"))
+ (beginning-of-line)
+ (setq record nil
+ ignore nil
+ current-key nil)
+ (while (re-search-forward line-regexp nil t)
+ (catch 'skip-line
+ (if (string= "-508" (match-string 1))
+ ;; A field is missing in this entry. Skip it or skip the
+ ;; whole record (see `eudc-strict-return-matches')
+ (if (not eudc-strict-return-matches)
+ (throw 'skip-line t)
+ (while (re-search-forward line-regexp nil t))
+ (setq ignore t)
+ (throw 'ignore t)))
+ (setq key (and (not (string= (match-string 2) ""))
+ (intern (match-string 2)))
+ value (match-string 3))
+ (if (and current-key
+ (eq key current-key))
+ (setq key nil)
+ (setq current-key key))
+ (if (or (null fields)
+ (eq 'all fields)
+ (memq current-key fields))
+ (if key
+ (setq record (cons (cons key value) record)) ; New key
+ (setcdr (car record) (if (listp (eudc-cdar record))
+ (append (eudc-cdar record) (list value))
+ (list (eudc-cdar record) value))))))))
+ (and (not ignore)
+ (or (null fields)
+ (eq 'all fields)
+ (setq record (nreverse record)))
+ (setq record (if (not (eq 'list eudc-duplicate-attribute-handling-method))
+ (eudc-filter-duplicate-attributes record)
+ (list record)))
+ (setq records (append record records))))
+ )
+ (message "Done")
+ records)
+ )
+
+(defun eudc-ph-do-request (request)
+ "Send REQUEST to the server.
+Wait for response and return the buffer containing it."
+ (let (process
+ buffer)
+ (unwind-protect
+ (progn
+ (message "Contacting server...")
+ (setq process (eudc-ph-open-session))
+ (if process
+ (save-excursion
+ (set-buffer (setq buffer (process-buffer process)))
+ (eudc-ph-send-command process request)
+ (message "Request sent, waiting for reply...")
+ (eudc-ph-read-response process))))
+ (if process
+ (eudc-ph-close-session process)))
+ buffer))
+
+(defun eudc-ph-open-session (&optional server)
+ "Open a connection to the given CCSO/QI SERVER.
+SERVER is either a string naming the server or a list (NAME PORT)."
+ (let (process
+ host
+ port)
+ (catch 'done
+ (if (null server)
+ (setq server (or eudc-server
+ (call-interactively 'eudc-ph-set-server))))
+ (string-match "\\(.*\\)\\(:\\(.*\\)\\)?" server)
+ (setq host (match-string 1 server))
+ (setq port (or (match-string 3 server)
+ eudc-ph-default-server-port))
+ (setq eudc-ph-process-buffer (get-buffer-create (format " *PH-%s*" host)))
+ (save-excursion
+ (set-buffer eudc-ph-process-buffer)
+ (erase-buffer)
+ (setq eudc-ph-read-point (point))
+ (and eudc-xemacs-mule-p
+ (set-buffer-file-coding-system 'binary t)))
+ (setq process (open-network-stream "ph" eudc-ph-process-buffer host port))
+ (if (null process)
+ (throw 'done nil))
+ (process-kill-without-query process)
+ process)))
+
+
+(defun eudc-ph-close-session (process)
+ (save-excursion
+ (set-buffer (process-buffer process))
+ (eudc-ph-send-command process "quit")
+ (eudc-ph-read-response process)
+ (if (fboundp 'add-async-timeout)
+ (add-async-timeout 10 'delete-process process)
+ (run-at-time 2 nil 'delete-process process))))
+
+(defun eudc-ph-send-command (process command)
+ (goto-char (point-max))
+ (process-send-string process command)
+ (process-send-string process "\r\n")
+ )
+
+(defun eudc-ph-read-response (process &optional return-response)
+ "Read a response from the PH/QI query process PROCESS.
+Returns nil if response starts with an error code. If the
+response is successful the return code or the response itself is returned
+depending on RETURN-RESPONSE."
+ (let ((case-fold-search nil)
+ return-code
+ match-end)
+ (goto-char eudc-ph-read-point)
+ ;; CCSO protocol : response complete if status >= 200
+ (while (not (re-search-forward "^\\(^[2-5].*\\):.*\n" nil t))
+ (accept-process-output process)
+ (goto-char eudc-ph-read-point))
+ (setq match-end (point))
+ (goto-char eudc-ph-read-point)
+ (if (and (setq return-code (match-string 1))
+ (setq return-code (string-to-number return-code))
+ (>= (abs return-code) 300))
+ (progn (setq eudc-ph-read-point match-end) nil)
+ (setq eudc-ph-read-point match-end)
+ (if return-response
+ (buffer-substring (point) match-end)
+ return-code))))
+
+;;}}}
+
+;;{{{ High-level interfaces (interactive functions)
+
+(defun eudc-ph-customize ()
+ "Customize the EUDC PH support."
+ (interactive)
+ (customize-group 'eudc-ph))
+
+(defun eudc-ph-set-server (server)
+ "Set the PH server to SERVER."
+ (interactive "sNew PH/QI Server: ")
+ (message "Selected PH/QI server is now %s" server)
+ (eudc-set-server server 'ph))
+
+;;}}}
+
+
+(eudc-register-protocol 'ph)
+
+(provide 'eudcb-ph)
+
+;;; eudcb-ph.el ends here
--- /dev/null
+;;; ldap.el --- Client interface to LDAP for Emacs
+
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
+;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
+;; Created: April 1998
+;; Keywords: comm
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; 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.
+
+;;; Commentary:
+
+;; This package provides basic functionality to perform searches on LDAP
+;; servers. It requires a command line utility generally named
+;; `ldapsearch' to actually perform the searches. That program can be
+;; found in all LDAP developer kits such as:
+;; - UM-LDAP 3.3 (http://www.umich.edu/~dirsvcs/ldap/)
+;; - OpenLDAP (http://www.openldap.org/)
+
+;;; Code:
+
+(require 'custom)
+
+(defgroup ldap nil
+ "Lightweight Directory Access Protocol."
+ :group 'comm)
+
+(defcustom ldap-default-host nil
+ "*Default LDAP server.
+A TCP port number can be appended to that name using a colon as
+a separator."
+ :type '(choice (string :tag "Host name")
+ (const :tag "Use library default" nil))
+ :group 'ldap)
+
+(defcustom ldap-default-port nil
+ "*Default TCP port for LDAP connections.
+Initialized from the LDAP library at build time. Default value is 389."
+ :type '(choice (const :tag "Use library default" nil)
+ (integer :tag "Port number"))
+ :group 'ldap)
+
+(defcustom ldap-default-base nil
+ "*Default base for LDAP searches.
+This is a string using the syntax of RFC 1779.
+For instance, \"o=ACME, c=US\" limits the search to the
+Acme organization in the United States."
+ :type '(choice (const :tag "Use library default" nil)
+ (string :tag "Search base"))
+ :group 'ldap)
+
+
+(defcustom ldap-host-parameters-alist nil
+ "*Alist of host-specific options for LDAP transactions.
+The format of each list element is (HOST PROP1 VAL1 PROP2 VAL2 ...).
+HOST is the hostname of an LDAP server(with an optional TCP port number
+appended to it using a colon as a separator).
+PROPn and VALn are property/value pairs describing parameters for the server.
+Valid properties include:
+ `binddn' is the distinguished name of the user to bind as
+ (in RFC 1779 syntax).
+ `passwd' is the password to use for simple authentication.
+ `auth' is the authentication method to use.
+ Possible values are: `simple', `krbv41' and `krbv42'.
+ `base' is the base for the search as described in RFC 1779.
+ `scope' is one of the three symbols `subtree', `base' or `onelevel'.
+ `deref' is one of the symbols `never', `always', `search' or `find'.
+ `timelimit' is the timeout limit for the connection in seconds.
+ `sizelimit' is the maximum number of matches to return."
+ :type '(repeat :menu-tag "Host parameters"
+ :tag "Host parameters"
+ (list :menu-tag "Host parameters"
+ :tag "Host parameters"
+ :value nil
+ (string :tag "Host name")
+ (checklist :inline t
+ :greedy t
+ (list
+ :tag "Search Base"
+ :inline t
+ (const :tag "Search Base" base)
+ string)
+ (list
+ :tag "Binding DN"
+ :inline t
+ (const :tag "Binding DN" binddn)
+ string)
+ (list
+ :tag "Password"
+ :inline t
+ (const :tag "Password" passwd)
+ string)
+ (list
+ :tag "Authentication Method"
+ :inline t
+ (const :tag "Authentication Method" auth)
+ (choice
+ (const :menu-tag "None" :tag "None" nil)
+ (const :menu-tag "Simple" :tag "Simple" simple)
+ (const :menu-tag "Kerberos 4.1" :tag "Kerberos 4.1" krbv41)
+ (const :menu-tag "Kerberos 4.2" :tag "Kerberos 4.2" krbv42)))
+ (list
+ :tag "Search Base"
+ :inline t
+ (const :tag "Search Base" base)
+ string)
+ (list
+ :tag "Search Scope"
+ :inline t
+ (const :tag "Search Scope" scope)
+ (choice
+ (const :menu-tag "Default" :tag "Default" nil)
+ (const :menu-tag "Subtree" :tag "Subtree" subtree)
+ (const :menu-tag "Base" :tag "Base" base)
+ (const :menu-tag "One Level" :tag "One Level" onelevel)))
+ (list
+ :tag "Dereferencing"
+ :inline t
+ (const :tag "Dereferencing" deref)
+ (choice
+ (const :menu-tag "Default" :tag "Default" nil)
+ (const :menu-tag "Never" :tag "Never" never)
+ (const :menu-tag "Always" :tag "Always" always)
+ (const :menu-tag "When searching" :tag "When searching" search)
+ (const :menu-tag "When locating base" :tag "When locating base" find)))
+ (list
+ :tag "Time Limit"
+ :inline t
+ (const :tag "Time Limit" timelimit)
+ (integer :tag "(in seconds)"))
+ (list
+ :tag "Size Limit"
+ :inline t
+ (const :tag "Size Limit" sizelimit)
+ (integer :tag "(number of records)")))))
+ :group 'ldap)
+
+(defcustom ldap-ldapsearch-prog "ldapsearch"
+ "*The name of the ldapsearch command line program."
+ :type '(string :tag "`ldapsearch' Program")
+ :group 'ldap)
+
+(defcustom ldap-ldapsearch-args '("-B")
+ "*A list of additional arguments to pass to `ldapsearch'.
+It is recommended to use the `-T' switch with Netscape's
+implementation to avoid line wrapping.
+The `-B' switch should be used to enable the retrieval of
+binary values."
+ :type '(repeat :tag "`ldapsearch' Arguments"
+ (string :tag "Argument"))
+ :group 'ldap)
+
+(defcustom ldap-ignore-attribute-codings t
+ "*If non-nil, do not encode/decode LDAP attribute values."
+ :type 'boolean
+ :group 'ldap)
+
+(defcustom ldap-default-attribute-decoder nil
+ "*Decoder function to use for attributes whose syntax is unknown."
+ :type 'symbol
+ :group 'ldap)
+
+(defcustom ldap-coding-system nil
+ "*Coding system of LDAP string values.
+LDAP v3 specifies the coding system of strings to be UTF-8 but
+Emacs still does not have reasonable support for that."
+ :type 'symbol
+ :group 'ldap)
+
+(defvar ldap-attribute-syntax-encoders
+ [nil ; 1 ACI Item N
+ nil ; 2 Access Point Y
+ nil ; 3 Attribute Type Description Y
+ nil ; 4 Audio N
+ nil ; 5 Binary N
+ nil ; 6 Bit String Y
+ ldap-encode-boolean ; 7 Boolean Y
+ nil ; 8 Certificate N
+ nil ; 9 Certificate List N
+ nil ; 10 Certificate Pair N
+ ldap-encode-country-string ; 11 Country String Y
+ ldap-encode-string ; 12 DN Y
+ nil ; 13 Data Quality Syntax Y
+ nil ; 14 Delivery Method Y
+ ldap-encode-string ; 15 Directory String Y
+ nil ; 16 DIT Content Rule Description Y
+ nil ; 17 DIT Structure Rule Description Y
+ nil ; 18 DL Submit Permission Y
+ nil ; 19 DSA Quality Syntax Y
+ nil ; 20 DSE Type Y
+ nil ; 21 Enhanced Guide Y
+ nil ; 22 Facsimile Telephone Number Y
+ nil ; 23 Fax N
+ nil ; 24 Generalized Time Y
+ nil ; 25 Guide Y
+ nil ; 26 IA5 String Y
+ number-to-string ; 27 INTEGER Y
+ nil ; 28 JPEG N
+ nil ; 29 Master And Shadow Access Points Y
+ nil ; 30 Matching Rule Description Y
+ nil ; 31 Matching Rule Use Description Y
+ nil ; 32 Mail Preference Y
+ nil ; 33 MHS OR Address Y
+ nil ; 34 Name And Optional UID Y
+ nil ; 35 Name Form Description Y
+ nil ; 36 Numeric String Y
+ nil ; 37 Object Class Description Y
+ nil ; 38 OID Y
+ nil ; 39 Other Mailbox Y
+ nil ; 40 Octet String Y
+ ldap-encode-address ; 41 Postal Address Y
+ nil ; 42 Protocol Information Y
+ nil ; 43 Presentation Address Y
+ ldap-encode-string ; 44 Printable String Y
+ nil ; 45 Subtree Specification Y
+ nil ; 46 Supplier Information Y
+ nil ; 47 Supplier Or Consumer Y
+ nil ; 48 Supplier And Consumer Y
+ nil ; 49 Supported Algorithm N
+ nil ; 50 Telephone Number Y
+ nil ; 51 Teletex Terminal Identifier Y
+ nil ; 52 Telex Number Y
+ nil ; 53 UTC Time Y
+ nil ; 54 LDAP Syntax Description Y
+ nil ; 55 Modify Rights Y
+ nil ; 56 LDAP Schema Definition Y
+ nil ; 57 LDAP Schema Description Y
+ nil ; 58 Substring Assertion Y
+ ]
+ "A vector of functions used to encode LDAP attribute values.
+The sequence of functions corresponds to the sequence of LDAP attribute syntax
+object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
+RFC2252 section 4.3.2")
+
+(defvar ldap-attribute-syntax-decoders
+ [nil ; 1 ACI Item N
+ nil ; 2 Access Point Y
+ nil ; 3 Attribute Type Description Y
+ nil ; 4 Audio N
+ nil ; 5 Binary N
+ nil ; 6 Bit String Y
+ ldap-decode-boolean ; 7 Boolean Y
+ nil ; 8 Certificate N
+ nil ; 9 Certificate List N
+ nil ; 10 Certificate Pair N
+ ldap-decode-string ; 11 Country String Y
+ ldap-decode-string ; 12 DN Y
+ nil ; 13 Data Quality Syntax Y
+ nil ; 14 Delivery Method Y
+ ldap-decode-string ; 15 Directory String Y
+ nil ; 16 DIT Content Rule Description Y
+ nil ; 17 DIT Structure Rule Description Y
+ nil ; 18 DL Submit Permission Y
+ nil ; 19 DSA Quality Syntax Y
+ nil ; 20 DSE Type Y
+ nil ; 21 Enhanced Guide Y
+ nil ; 22 Facsimile Telephone Number Y
+ nil ; 23 Fax N
+ nil ; 24 Generalized Time Y
+ nil ; 25 Guide Y
+ nil ; 26 IA5 String Y
+ string-to-number ; 27 INTEGER Y
+ nil ; 28 JPEG N
+ nil ; 29 Master And Shadow Access Points Y
+ nil ; 30 Matching Rule Description Y
+ nil ; 31 Matching Rule Use Description Y
+ nil ; 32 Mail Preference Y
+ nil ; 33 MHS OR Address Y
+ nil ; 34 Name And Optional UID Y
+ nil ; 35 Name Form Description Y
+ nil ; 36 Numeric String Y
+ nil ; 37 Object Class Description Y
+ nil ; 38 OID Y
+ nil ; 39 Other Mailbox Y
+ nil ; 40 Octet String Y
+ ldap-decode-address ; 41 Postal Address Y
+ nil ; 42 Protocol Information Y
+ nil ; 43 Presentation Address Y
+ ldap-decode-string ; 44 Printable String Y
+ nil ; 45 Subtree Specification Y
+ nil ; 46 Supplier Information Y
+ nil ; 47 Supplier Or Consumer Y
+ nil ; 48 Supplier And Consumer Y
+ nil ; 49 Supported Algorithm N
+ nil ; 50 Telephone Number Y
+ nil ; 51 Teletex Terminal Identifier Y
+ nil ; 52 Telex Number Y
+ nil ; 53 UTC Time Y
+ nil ; 54 LDAP Syntax Description Y
+ nil ; 55 Modify Rights Y
+ nil ; 56 LDAP Schema Definition Y
+ nil ; 57 LDAP Schema Description Y
+ nil ; 58 Substring Assertion Y
+ ]
+ "A vector of functions used to decode LDAP attribute values.
+The sequence of functions corresponds to the sequence of LDAP attribute syntax
+object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
+RFC2252 section 4.3.2")
+
+
+(defvar ldap-attribute-syntaxes-alist
+ '((createtimestamp . 24)
+ (modifytimestamp . 24)
+ (creatorsname . 12)
+ (modifiersname . 12)
+ (subschemasubentry . 12)
+ (attributetypes . 3)
+ (objectclasses . 37)
+ (matchingrules . 30)
+ (matchingruleuse . 31)
+ (namingcontexts . 12)
+ (altserver . 26)
+ (supportedextension . 38)
+ (supportedcontrol . 38)
+ (supportedsaslmechanisms . 15)
+ (supportedldapversion . 27)
+ (ldapsyntaxes . 16)
+ (ditstructurerules . 17)
+ (nameforms . 35)
+ (ditcontentrules . 16)
+ (objectclass . 38)
+ (aliasedobjectname . 12)
+ (cn . 15)
+ (sn . 15)
+ (serialnumber . 44)
+ (c . 15)
+ (l . 15)
+ (st . 15)
+ (street . 15)
+ (o . 15)
+ (ou . 15)
+ (title . 15)
+ (description . 15)
+ (searchguide . 25)
+ (businesscategory . 15)
+ (postaladdress . 41)
+ (postalcode . 15)
+ (postofficebox . 15)
+ (physicaldeliveryofficename . 15)
+ (telephonenumber . 50)
+ (telexnumber . 52)
+ (telexterminalidentifier . 51)
+ (facsimiletelephonenumber . 22)
+ (x121address . 36)
+ (internationalisdnnumber . 36)
+ (registeredaddress . 41)
+ (destinationindicator . 44)
+ (preferreddeliverymethod . 14)
+ (presentationaddress . 43)
+ (supportedapplicationcontext . 38)
+ (member . 12)
+ (owner . 12)
+ (roleoccupant . 12)
+ (seealso . 12)
+ (userpassword . 40)
+ (usercertificate . 8)
+ (cacertificate . 8)
+ (authorityrevocationlist . 9)
+ (certificaterevocationlist . 9)
+ (crosscertificatepair . 10)
+ (name . 15)
+ (givenname . 15)
+ (initials . 15)
+ (generationqualifier . 15)
+ (x500uniqueidentifier . 6)
+ (dnqualifier . 44)
+ (enhancedsearchguide . 21)
+ (protocolinformation . 42)
+ (distinguishedname . 12)
+ (uniquemember . 34)
+ (houseidentifier . 15)
+ (supportedalgorithms . 49)
+ (deltarevocationlist . 9)
+ (dmdname . 15))
+ "A map of LDAP attribute names to their type object id minor number.
+This table is built from RFC2252 Section 5 and RFC2256 Section 5")
+
+
+;; Coding/decoding functions
+
+(defun ldap-encode-boolean (bool)
+ (if bool
+ "TRUE"
+ "FALSE"))
+
+(defun ldap-decode-boolean (str)
+ (cond
+ ((string-equal str "TRUE")
+ t)
+ ((string-equal str "FALSE")
+ nil)
+ (t
+ (error "Wrong LDAP boolean string: %s" str))))
+
+(defun ldap-encode-country-string (str)
+ ;; We should do something useful here...
+ (if (not (= 2 (length str)))
+ (error "Invalid country string: %s" str)))
+
+(defun ldap-decode-string (str)
+ (decode-coding-string str ldap-coding-system))
+
+(defun ldap-encode-string (str)
+ (encode-coding-string str ldap-coding-system))
+
+(defun ldap-decode-address (str)
+ (mapconcat 'ldap-decode-string
+ (split-string str "\\$")
+ "\n"))
+
+(defun ldap-encode-address (str)
+ (mapconcat 'ldap-encode-string
+ (split-string str "\n")
+ "$"))
+
+
+;; LDAP protocol functions
+
+(defun ldap-get-host-parameter (host parameter)
+ "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
+ (plist-get (cdr (assoc host ldap-host-parameters-alist))
+ parameter))
+
+(defun ldap-decode-attribute (attr)
+ "Decode the attribute/value pair ATTR according to LDAP rules.
+The attribute name is looked up in `ldap-attribute-syntaxes-alist'
+and the corresponding decoder is then retrieved from
+`ldap-attribute-syntax-decoders' and applied on the value(s)."
+ (let* ((name (car attr))
+ (values (cdr attr))
+ (syntax-id (cdr (assq (intern (downcase name))
+ ldap-attribute-syntaxes-alist)))
+ decoder)
+ (if syntax-id
+ (setq decoder (aref ldap-attribute-syntax-decoders
+ (1- syntax-id)))
+ (setq decoder ldap-default-attribute-decoder))
+ (if decoder
+ (cons name (mapcar decoder values))
+ attr)))
+
+
+(defun ldap-search (filter &optional host attributes attrsonly withdn)
+ "Perform an LDAP search.
+FILTER is the search filter in RFC1558 syntax.
+HOST is the LDAP host on which to perform the search.
+ATTRIBUTES are the specific attributes to retrieve, nil means
+retrieve all.
+ATTRSONLY, if non-nil, retrieves the attributes only, without
+the associated values.
+If WITHDN is non-nil, each entry in the result will be prepended with
+its distinguished name WITHDN.
+Additional search parameters can be specified through
+`ldap-host-parameters-alist', which see."
+ (interactive "sFilter:")
+ (or host
+ (setq host ldap-default-host)
+ (error "No LDAP host specified"))
+ (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
+ result)
+ (setq result (ldap-search-internal (append host-plist
+ (list 'host host
+ 'filter filter
+ 'attributes attributes
+ 'attrsonly attrsonly
+ 'withdn withdn))))
+ (if ldap-ignore-attribute-codings
+ result
+ (mapcar (function
+ (lambda (record)
+ (mapcar 'ldap-decode-attribute record)))
+ result))))
+
+
+(defun ldap-search-internal (search-plist)
+ "Perform a search on a LDAP server.
+SEARCH-PLIST is a property list describing the search request.
+Valid keys in that list are:
+ `host' is a string naming one or more (blank-separated) LDAP servers to
+to try to connect to. Each host name may optionally be of the form HOST:PORT.
+ `filter' is a filter string for the search as described in RFC 1558.
+ `attributes' is a list of strings indicating which attributes to retrieve
+for each matching entry. If nil, return all available attributes.
+ `attrsonly', if non-nil, indicates that only attributes are retrieved,
+not their associated values.
+ `base' is the base for the search as described in RFC 1779.
+ `scope' is one of the three symbols `sub', `base' or `one'.
+ `binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax).
+ `passwd' is the password to use for simple authentication.
+ `deref' is one of the symbols `never', `always', `search' or `find'.
+ `timelimit' is the timeout limit for the connection in seconds.
+ `sizelimit' is the maximum number of matches to return.
+ `withdn' if non-nil each entry in the result will be prepended with
+its distinguished name DN.
+The function returns a list of matching entries. Each entry is itself
+an alist of attribute/value pairs."
+ (let ((buf (get-buffer-create " *ldap-search*"))
+ (bufval (get-buffer-create " *ldap-value*"))
+ (host (or (plist-get search-plist 'host)
+ ldap-default-host))
+ (filter (plist-get search-plist 'filter))
+ (attributes (plist-get search-plist 'attributes))
+ (attrsonly (plist-get search-plist 'attrsonly))
+ (base (or (plist-get search-plist 'base)
+ ldap-default-base))
+ (scope (plist-get search-plist 'scope))
+ (binddn (plist-get search-plist 'binddn))
+ (passwd (plist-get search-plist 'passwd))
+ (deref (plist-get search-plist 'deref))
+ (timelimit (plist-get search-plist 'timelimit))
+ (sizelimit (plist-get search-plist 'sizelimit))
+ (withdn (plist-get search-plist 'withdn))
+ (numres 0)
+ arglist dn name value record result)
+ (if (or (null filter)
+ (equal "" filter))
+ (error "No search filter"))
+ (setq filter (cons filter attributes))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (if (and host
+ (not (equal "" host)))
+ (setq arglist (nconc arglist (list (format "-h%s" host)))))
+ (if (and attrsonly
+ (not (equal "" attrsonly)))
+ (setq arglist (nconc arglist (list "-A"))))
+ (if (and base
+ (not (equal "" base)))
+ (setq arglist (nconc arglist (list (format "-b%s" base)))))
+ (if (and scope
+ (not (equal "" scope)))
+ (setq arglist (nconc arglist (list (format "-s%s" scope)))))
+ (if (and binddn
+ (not (equal "" binddn)))
+ (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
+ (if (and passwd
+ (not (equal "" passwd)))
+ (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
+ (if (and deref
+ (not (equal "" deref)))
+ (setq arglist (nconc arglist (list (format "-a%s" deref)))))
+ (if (and timelimit
+ (not (equal "" timelimit)))
+ (setq arglist (nconc arglist (list (format "-l%s" timelimit)))))
+ (if (and sizelimit
+ (not (equal "" sizelimit)))
+ (setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
+ (eval `(call-process ldap-ldapsearch-prog
+ nil
+ buf
+ nil
+ ,@arglist
+ "-t" ; Write values to temp files
+ ,@ldap-ldapsearch-args
+ ,@filter))
+ (insert "\n")
+ (goto-char (point-min))
+
+ (if (looking-at "usage")
+ (error "Incorrect ldapsearch invocation")
+ (message "Parsing results... ")
+ (while (progn
+ (skip-chars-forward " \t\n")
+ (not (eobp)))
+ (setq dn (buffer-substring (point) (save-excursion
+ (end-of-line)
+ (point))))
+ (forward-line 1)
+ (while (looking-at "^\\(\\w*\\)[=:\t ]+\\(.*\\)$")
+ (setq name (match-string 1)
+ value (match-string 2))
+ (save-excursion
+ (set-buffer bufval)
+ (erase-buffer)
+ (insert-file-contents-literally value)
+ (delete-file value)
+ (setq value (buffer-substring (point-min) (point-max))))
+ (setq record (cons (list name value)
+ record))
+ (forward-line 1))
+ (setq result (cons (if withdn
+ (cons dn (nreverse record))
+ (nreverse record)) result))
+ (setq record nil)
+ (skip-chars-forward " \t\n")
+ (message "Parsing results... %d" numres)
+ (1+ numres))
+ (message "Parsing results... done")
+ (nreverse result)))))
+
+
+(provide 'ldap)
+
+;;; ldap.el ends here
projects / emacs.git / commitdiff