Mercurial > emacs
changeset 27313:babfd92e24bf
*** empty log message ***
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Wed, 12 Jan 2000 20:50:20 +0000 |
| parents | 1fb75ba2452d |
| children | 556645e6675e |
| files | lisp/ChangeLog lisp/net/eudc-bob.el lisp/net/eudc-export.el lisp/net/eudc-hotlist.el lisp/net/eudc-vars.el lisp/net/eudc.el lisp/net/eudcb-bbdb.el lisp/net/eudcb-ldap.el lisp/net/eudcb-ph.el lisp/net/ldap.el |
| diffstat | 10 files changed, 3742 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Wed Jan 12 14:16:29 2000 +0000 +++ b/lisp/ChangeLog Wed Jan 12 20:50:20 2000 +0000 @@ -1,5 +1,9 @@ 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudc-bob.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,329 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudc-export.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,218 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudc-hotlist.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,197 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudc-vars.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,405 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudc.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,1277 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudcb-bbdb.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,234 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudcb-ldap.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,210 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/eudcb-ph.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,257 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/ldap.el Wed Jan 12 20:50:20 2000 +0000 @@ -0,0 +1,611 @@ +;;; 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