-;;; pldap.el -- A portable LDAP support for Emacs.
+;;; pldap.el --- A portable LDAP support for Emacs.
;; Copyright (C) 1998 Free Software Foundation, Inc.
;; Copyright (C) 2000 Yuuichi Teranishi <teranisi@gohome.org>
;;; Commentary:
;;; Code:
-;;
+;;
(eval-when-compile (require 'cl))
(defmacro ldap-static-if (cond then &rest else)
+ "`if' expression but COND is evaluated at compile-time."
(if (eval cond)
then
- (` (progn (,@ else)))))
+ `(progn ,@else)))
(ldap-static-if (and (not (featurep 'pldap))
(fboundp 'ldap-open))
;; SAFE-CHAR = %x01-09 / %x0B-0C / %x0E-7F
(defconst ldap-ldif-safe-char-regexp
"[\000-\011\013\014\016-\177]"
- "A Regexp for safe-char")
+ "A Regexp for safe-char.")
;; SAFE-INIT-CHAR = %x01-09 / %x0B-0C / %x0E-1F /
;; %x21-39 / %x3B / %x3D-7F
(defconst ldap-ldif-safe-init-char-regexp
(concat ldap-ldif-safe-init-char-regexp ldap-ldif-safe-char-regexp "*")
"A Regexp for safe-string.")
-(defconst ldap-ldif-field-name-regexp "[a-zA-Z][a-zA-Z0-9-]*"
+(defconst ldap-ldif-field-name-regexp "[a-zA-Z][a-zA-Z0-9-;]*"
"A Regexp for field name.")
(defconst ldap-ldif-field-head-regexp
(concat "\n" ldap-ldif-field-name-regexp ":")
"A Regexp for next field head.")
-(defmacro ldap/ldif-safe-string-p (string)
+(defun ldap/ldif-safe-string-p (string)
"Return t if STRING is a safe-string for LDIF."
;; Need better implentation.
- (` (string-match ldap-ldif-safe-string-regexp (, string))))
+ (string-match ldap-ldif-safe-string-regexp string))
(defgroup ldap nil
"Lightweight Directory Access Protocol"
(defvar ldap-modify-program "ldapmodify"
"LDAP modify program.")
-(defcustom ldap-search-program-arguments '("-L" "-B")
+(defcustom ldap-search-program-arguments '("-LL" "-x")
"*A list of additional arguments to pass to `ldapsearch'.
It is recommended to use the `-T' switch with Nescape's
implementation to avoid line wrapping.
`-L' is needed to get LDIF outout.
+\(`-LL' is needed to get rid of comments from OpenLDAP's ldapsearch.\)
+`-x' is needed to use simple authentication.
The `-B' switch should be used to enable the retrieval of
binary values."
:type '(repeat :tag "`ldapsearch' Arguments"
:group 'ldap)
(defcustom ldap-default-host nil
- "*Default LDAP server hostname.
-A TCP port number can be appended to that name using a colon as
-a separator."
+ "*Default LDAP server hostname."
:type '(choice (string :tag "Host name")
(const :tag "Use library default" nil))
:group 'ldap)
:type 'symbol
:group 'ldap)
-(defcustom ldap-coding-system (if (boundp 'NEMACS) 0
- nil)
+(defcustom ldap-coding-system nil
"*Coding system of LDAP string values.
LDAP v3 specifies the coding system of strings to be UTF-8.
Mule support is needed for this."
nil (current-buffer) t
(append arglist
(list dn))))
- (if (integerp ret)
- (if (not (zerop ret))
- (error (car (split-string (buffer-string) "\n"))))
- (if (and (setq ret (buffer-string)); Nemacs
- (string-match "ldap_delete:" ret))
- (error (car (split-string ret "\n"))))))))
+ (cond ((integerp ret)
+ (or (zerop ret)
+ (error "%s" (car (split-string (buffer-string) "\n")))))
+ ((and (setq ret (buffer-string)); Nemacs
+ (string-match "ldap_delete:" ret))
+ (error "%s" (car (split-string ret "\n"))))))))
(defmacro ldap/ldif-insert-field (attr value)
- (` (if (not (ldap/ldif-safe-string-p (, value)))
- (insert (, attr) ":: " (base64-encode-string (, value)) "\n")
- (insert (, attr) ": " (, value) "\n"))))
+ `(if (not (ldap/ldif-safe-string-p ,value))
+ (insert ,attr ":: " (base64-encode-string ,value) "\n")
+ (insert ,attr ": " ,value "\n")))
(defun ldap-modify (ldap dn mods)
"Add an entry to an LDAP directory.
ldap-modify-program
t t nil
arglist))
- (if (integerp ret)
- (if (not (zerop ret))
- (error (car (split-string (buffer-string) "\n"))))
- (if (and (setq ret (buffer-string)); Nemacs
- (string-match "ldap_modify:" ret))
- (error (car (split-string ret "\n"))))))))
+ (cond ((integerp ret)
+ (or (zerop ret)
+ (error "%s" (car (split-string (buffer-string) "\n")))))
+ ((and (setq ret (buffer-string)); Nemacs
+ (string-match "ldap_modify:" ret))
+ (error "%s" (car (split-string ret "\n"))))))))
(defun ldap-add (ldap dn entry)
"Add an entry to an LDAP directory.
ldap-add-program
t t nil
arglist))
- (if (integerp ret)
- (if (not (zerop ret))
- (error (car (split-string (buffer-string) "\n"))))
- (if (and (setq ret (buffer-string)) ; Nemacs
- (string-match "ldap_add:" ret))
- (error (car (split-string ret "\n"))))))))
+ (cond ((integerp ret)
+ (or (zerop ret)
+ (error "%s" (car (split-string (buffer-string) "\n")))))
+ ((and (setq ret (buffer-string)) ; Nemacs
+ (string-match "ldap_add:" ret))
+ (error "%s" (car (split-string ret "\n"))))))))
(defun ldap-search-basic (ldap filter base scope
&optional attrs attrsonly withdn verbose)
(list filter)
attrs)))
(if (and (integerp ret)
- (not (zerop ret)))
+ (not (zerop ret))
+ ;; When openldap's `ldapsearch' exceeds response size limit,
+ ;; it's exit status becomes `4'.
+ (/= ret 4)
+ ;; When openldap's `ldapsearch' uses referral,
+ ;; it's exit status becomes `32'.
+ (/= ret 32))
(error "LDAP error: \"No such object\""))
(goto-char (point-min))
(setq start (point))
(if (not (eobp)) (forward-char 1))
(setq start (point)))
(if verbose
- (message "Parsing ldap results...done."))
+ (message "Parsing ldap results...done"))
(delq nil (nreverse result)))))
(defun ldap/field-end ()
(let ((case-fold-search t)
(field-body nil)
body)
- (while (re-search-forward (concat "^" name ":[ \t]*") nil t)
+ ;; search for the line which have name with options.
+ (while (re-search-forward (concat "^" name
+ "\\(;[a-zA-Z0-9-]+\\)?:[ \t]*") nil t)
;; Base64
(if (string-match "^:[ \t]*" (setq body
(buffer-substring-no-properties
"Collect fields without WITHOUT."
(goto-char (point-min))
(let ((regexp (concat "\\(" ldap-ldif-field-head-regexp "\\)[ \t]*"))
- dest name body entry)
+ dest name name-option body entry)
(while (re-search-forward regexp nil t)
- (setq name (downcase (buffer-substring-no-properties
- (match-beginning 1)(1- (match-end 1)))))
+ ;; name with options.
+ (setq name-option (split-string (downcase (buffer-substring-no-properties
+ (match-beginning 1)
+ (1- (match-end 1))))
+ ";"))
+ ;; XXX options are discarded.
+ (setq name (car name-option))
(setq body (buffer-substring-no-properties
(match-end 0) (ldap/field-end)))
(if (string-match "^:[ \t]*" body)
nil)
(t
(error "Wrong LDAP boolean string: %s" str))))
-
+
(defun ldap-encode-country-string (str)
"Encode STR to LDAP country string."
;; We should do something useful here...
(defun ldap-decode-string (str)
"Decode LDAP STR."
- (if (fboundp 'decode-coding-string)
- (decode-coding-string str ldap-coding-system)))
+ (if (and (fboundp 'decode-coding-string)
+ ldap-coding-system)
+ (decode-coding-string str ldap-coding-system)
+ str))
(defun ldap-encode-string (str)
"Encode LDAP STR."
- (if (fboundp 'encode-coding-string)
- (encode-coding-string str ldap-coding-system)))
+ (if (and (fboundp 'encode-coding-string)
+ ldap-coding-system)
+ (encode-coding-string str ldap-coding-system)
+ str))
(defun ldap-decode-address (str)
"Decode LDAP address STR."
"$"))
;;; LDAP protocol functions
-;;
+;;
(defun ldap-get-host-parameter (host parameter)
"Get HOST's PARAMETER in `ldap-host-parameters-alist'."
(plist-get (cdr (assoc host ldap-host-parameters-alist))
(if encoder
(cons name (mapcar encoder values))
attr)))
-
+
(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'
(cons name (mapcar decoder values))
attr))
attr))
-
+
(defun ldap-search (arg1 &rest args)
"Perform an LDAP search.if ARG1 is LDAP object, invoke `ldap-search-basic'.
Otherwise, invoke `ldap-search-entries'. ARGS are passed to each function."
(setq ldap (ldap-open host host-plist))
(if ldap-verbose
(message "Searching with LDAP on %s..." host))
- (setq result (ldap-search ldap filter
+ (setq result (ldap-search ldap (ldap-encode-string filter)
(plist-get host-plist 'base)
(plist-get host-plist 'scope)
attributes attrsonly withdn
(set-buffer-multibyte nil)
(if ldap-ignore-attribute-codings
result
- (mapcar (function
- (lambda (record)
- (mapcar 'ldap-decode-attribute record)))
- result)))))
+ (mapcar
+ (lambda (record)
+ (mapcar 'ldap-decode-attribute record))
+ result)))))
(defun ldap-add-entries (entries &optional host binddn passwd)
"Add entries to an LDAP directory.
(setq ldap (ldap-open host host-plist))
(if ldap-verbose
(message "Adding LDAP entries..."))
- (mapcar (lambda (thisentry)
- (setcdr thisentry
- (mapcar
- (lambda (add-spec)
- (setq add-spec (ldap-encode-attribute
- (list (car add-spec)
- (cdr add-spec))))
- (cons (nth 0 add-spec)
- (nth 1 add-spec)))
- (cdr thisentry)))
- (setq thisentry (ldap-encode-attribute thisentry))
- (ldap-add ldap (car thisentry) (cdr thisentry))
- (if ldap-verbose
- (message "%d added" i))
- (setq i (1+ i)))
- entries)
+ (mapc (lambda (thisentry)
+ (setcdr thisentry
+ (mapcar
+ (lambda (add-spec)
+ (setq add-spec (ldap-encode-attribute
+ (list (car add-spec)
+ (cdr add-spec))))
+ (cons (nth 0 add-spec)
+ (nth 1 add-spec)))
+ (cdr thisentry)))
+ (setq thisentry (ldap-encode-attribute thisentry))
+ (ldap-add ldap (car thisentry) (cdr thisentry))
+ (if ldap-verbose
+ (message "%d added" i))
+ (setq i (1+ i)))
+ entries)
(ldap-close ldap)))
(defun ldap-modify-entries (entry-mods &optional host binddn passwd)
(setq ldap (ldap-open host host-plist))
(if ldap-verbose
(message "Modifying LDAP entries..."))
- (mapcar (lambda (thisentry)
- (setcdr thisentry
- (mapcar
- (lambda (mod-spec)
- (if (or (eq (car mod-spec) 'add)
- (eq (car mod-spec) 'replace))
- (append (list (nth 0 mod-spec))
- (ldap-encode-attribute
- (cdr mod-spec)))))
- (cdr thisentry)))
- (ldap-modify ldap (car thisentry) (cdr thisentry))
- (if ldap-verbose
- (message "%d modified" i))
- (setq i (1+ i)))
- entry-mods)
+ (mapc
+ (lambda (thisentry)
+ (setcdr thisentry
+ (mapcar
+ (lambda (mod-spec)
+ (if (or (eq (car mod-spec) 'add)
+ (eq (car mod-spec) 'replace))
+ (append (list (nth 0 mod-spec))
+ (ldap-encode-attribute
+ (cdr mod-spec)))))
+ (cdr thisentry)))
+ (ldap-modify ldap (car thisentry) (cdr thisentry))
+ (if ldap-verbose
+ (message "%d modified" i))
+ (setq i (1+ i)))
+ entry-mods)
(ldap-close ldap)))
(defun ldap-delete-entries (dn &optional host binddn passwd)
(let ((i 1))
(if ldap-verbose
(message "Deleting LDAP entries..."))
- (mapcar (function
- (lambda (thisdn)
- (ldap-delete ldap thisdn)
- (if ldap-verbose
- (message "%d deleted" i))
- (setq i (1+ i))))
- dn))
+ (mapc
+ (lambda (thisdn)
+ (ldap-delete ldap thisdn)
+ (if ldap-verbose
+ (message "%d deleted" i))
+ (setq i (1+ i)))
+ dn))
(if ldap-verbose
(message "Deleting LDAP entry..."))
(ldap-delete ldap dn))
projects / elisp / wanderlust.git / blobdiff