X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Fpldap.el;h=540a2e34d98122ae5490e3d3787994cdb92b34bf;hb=fceaa7d966c72630d1b8b146ae0414b4d144a8c6;hp=9437722cd280f0028b3ed6b46be7689bf1704d05;hpb=c9f2a10e8442b96e2c43962dfe9099153d0c011f;p=elisp%2Fwanderlust.git diff --git a/elmo/pldap.el b/elmo/pldap.el index 9437722..540a2e3 100644 --- a/elmo/pldap.el +++ b/elmo/pldap.el @@ -1,4 +1,4 @@ -;;; 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 @@ -34,7 +34,7 @@ ;;; Commentary: ;;; Code: -;; +;; (eval-when-compile (require 'cl)) @@ -42,7 +42,7 @@ "`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)) @@ -67,7 +67,7 @@ (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 @@ -81,7 +81,7 @@ (defmacro 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" @@ -99,11 +99,13 @@ (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" @@ -111,9 +113,7 @@ binary values." :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) @@ -235,8 +235,7 @@ Valid properties include: :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." @@ -510,17 +509,17 @@ DN is the distinguished name of the entry to delete." 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. @@ -568,12 +567,12 @@ or `replace'. ATTR is the LDAP attribute type to modify." 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. @@ -608,12 +607,12 @@ containing attribute/value string pairs." 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) @@ -689,7 +688,13 @@ entry according to the value of WITHDN." (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)) @@ -747,7 +752,9 @@ entry according to the value of WITHDN." (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 @@ -761,10 +768,15 @@ entry according to the value of WITHDN." "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) @@ -792,7 +804,7 @@ entry according to the value of WITHDN." 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... @@ -801,13 +813,17 @@ entry according to the value of WITHDN." (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." @@ -822,7 +838,7 @@ entry according to the value of WITHDN." "$")) ;;; 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)) @@ -845,7 +861,7 @@ and the corresponding decoder is then retrieved from (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' @@ -865,7 +881,7 @@ and the corresponding decoder is then retrieved from (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." @@ -904,7 +920,7 @@ entry according to the value of WITHDN." (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 @@ -914,10 +930,10 @@ entry according to the value of 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. @@ -945,22 +961,22 @@ PASSWD is the corresponding password" (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) @@ -993,21 +1009,22 @@ PASSWD is the corresponding password" (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) @@ -1035,13 +1052,13 @@ PASSWD is the corresponding password." (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))