*** empty log message ***
This commit is contained in:
Gerd Moellmann
parent
e4936aa97c
commit
7970b22996
10 changed files with 3742 additions and 0 deletions
|
|
@ -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)'.
|
||||
|
||||
|
|
|
|||
329
lisp/net/eudc-bob.el
Normal file
329
lisp/net/eudc-bob.el
Normal file
|
|
@ -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
|
||||
218
lisp/net/eudc-export.el
Normal file
218
lisp/net/eudc-export.el
Normal file
|
|
@ -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
|
||||
197
lisp/net/eudc-hotlist.el
Normal file
197
lisp/net/eudc-hotlist.el
Normal file
|
|
@ -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
|
||||
405
lisp/net/eudc-vars.el
Normal file
405
lisp/net/eudc-vars.el
Normal file
|
|
@ -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
|
||||
1277
lisp/net/eudc.el
Normal file
1277
lisp/net/eudc.el
Normal file
File diff suppressed because it is too large
Load diff
234
lisp/net/eudcb-bbdb.el
Normal file
234
lisp/net/eudcb-bbdb.el
Normal file
|
|
@ -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
|
||||
210
lisp/net/eudcb-ldap.el
Normal file
210
lisp/net/eudcb-ldap.el
Normal file
|
|
@ -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
|
||||
257
lisp/net/eudcb-ph.el
Normal file
257
lisp/net/eudcb-ph.el
Normal file
|
|
@ -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
|
||||
611
lisp/net/ldap.el
Normal file
611
lisp/net/ldap.el
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue