Mercurial > hg > xemacs-beta
diff lisp/ldap.el @ 412:697ef44129c6 r21-2-14
Import from CVS: tag r21-2-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 11:20:41 +0200 |
| parents | a86b2b5e0111 |
| children | da8ed4261e83 |
line wrap: on
line diff
--- a/lisp/ldap.el Mon Aug 13 11:19:22 2007 +0200 +++ b/lisp/ldap.el Mon Aug 13 11:20:41 2007 +0200 @@ -5,7 +5,7 @@ ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> ;; Created: Jan 1998 -;; Version: $Revision: 1.7.2.7 $ +;; Version: $Revision: 1.7.2.4 $ ;; Keywords: help comm ;; This file is part of XEmacs @@ -35,10 +35,6 @@ ;;; Code: -(eval-when '(load) - (if (not (fboundp 'ldap-open)) - (error "No LDAP support compiled in this XEmacs"))) - (defgroup ldap nil "Lightweight Directory Access Protocol" :group 'comm) @@ -149,315 +145,14 @@ (integer :tag "(number of records)"))))) :group 'ldap) -(defcustom ldap-verbose nil - "*If non-nil, LDAP operations echo progress messages." - :type 'boolean - :group 'ldap) - -(defcustom ldap-ignore-attribute-codings nil - "*If non-nil, do not perform any encoding/decoding on 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. -Mule support is needed for this." - :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) - (if (fboundp 'decode-coding-string) - (decode-coding-string str ldap-coding-system))) - -(defun ldap-encode-string (str) - (if (fboundp 'encode-coding-string) - (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 (arg1 &rest args) - "Perform an LDAP search." - (apply (if (ldapp arg1) - 'ldap-search-basic - 'ldap-search-entries) arg1 args)) - -(make-obsolete 'ldap-search - "Use `ldap-search-entries' instead or -`ldap-search-basic' for the low-level search API.") - -(defun ldap-search-entries (filter &optional host attributes attrsonly withdn) +(defun ldap-search (filter &optional host attributes attrsonly withdn) "Perform an LDAP search. -FILTER is the search filter in RFC1558 syntax, i.e., something that +FILTER is the search filter in RFC1558 syntax, i.e. something that looks like \"(cn=John Smith)\". HOST is the LDAP host on which to perform the search. ATTRIBUTES is a list of attributes to retrieve; nil means retrieve all. @@ -472,142 +167,19 @@ entry according to the value of WITHDN." (interactive "sFilter:") (or host - (setq host ldap-default-host) - (error "No LDAP host specified")) - (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) - ldap - result) - (if ldap-verbose - (message "Opening LDAP connection to %s..." host)) - (setq ldap (ldap-open host host-plist)) - (if ldap-verbose - (message "Searching with LDAP on %s..." host)) - (setq result (ldap-search ldap filter - (plist-get host-plist 'base) - (plist-get host-plist 'scope) - attributes attrsonly withdn - ldap-verbose)) - (ldap-close ldap) - (if ldap-ignore-attribute-codings - result - (mapcar (function - (lambda (record) - (mapcar 'ldap-decode-attribute record))) - result)))) - -(defun ldap-add-entries (entries &optional host binddn passwd) - "Add entries to an LDAP directory. -ENTRIES is a list of entry specifications of -the form (DN (ATTR . VALUE) (ATTR . VALUE) ...) where -DN is the distinguished name of an entry to add, the following -are cons cells containing attribute/value string pairs. -HOST is the LDAP host, defaulting to `ldap-default-host' -BINDDN is the DN to bind as to the server -PASSWD is the corresponding password" + (setq host ldap-default-host)) (or host - (setq host ldap-default-host) - (error "No LDAP host specified")) - (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) - ldap - (i 1)) - (if (or binddn passwd) - (setq host-plist (copy-seq host-plist))) - (if binddn - (setq host-plist (plist-put host-plist 'binddn binddn))) - (if passwd - (setq host-plist (plist-put host-plist 'passwd passwd))) - (if ldap-verbose - (message "Opening LDAP connection to %s..." host)) - (setq ldap (ldap-open host host-plist)) - (if ldap-verbose - (message "Adding LDAP entries...")) - (mapcar (function - (lambda (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) - "Modify entries of an LDAP directory. -ENTRY_MODS is a list of entry modifications of the form - (DN MOD-SPEC1 MOD-SPEC2 ...) where DN is the distinguished name of -the entry to modify, the following are modification specifications. -A modification specification is itself a list of the form -(MOD-OP ATTR VALUE1 VALUE2 ...) MOD-OP and ATTR are mandatory, -VALUEs are optional depending on MOD-OP. -MOD-OP is the type of modification, one of the symbols `add', `delete' -or `replace'. ATTR is the LDAP attribute type to modify. -HOST is the LDAP host, defaulting to `ldap-default-host' -BINDDN is the DN to bind as to the server -PASSWD is the corresponding password" - (or host - (setq host ldap-default-host) - (error "No LDAP host specified")) - (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) - ldap - (i 1)) - (if (or binddn passwd) - (setq host-plist (copy-seq host-plist))) - (if binddn - (setq host-plist (plist-put host-plist 'binddn binddn))) - (if passwd - (setq host-plist (plist-put host-plist 'passwd passwd))) - (if ldap-verbose - (message "Opening LDAP connection to %s..." host)) - (setq ldap (ldap-open host host-plist)) - (if ldap-verbose - (message "Modifying LDAP entries...")) - (mapcar (function - (lambda (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) - "Delete an entry from an LDAP directory. -DN is the distinguished name of an entry to delete or -a list of those. -HOST is the LDAP host, defaulting to `ldap-default-host' -BINDDN is the DN to bind as to the server -PASSWD is the corresponding password." - (or host - (setq host ldap-default-host) (error "No LDAP host specified")) (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) ldap) - (if (or binddn passwd) - (setq host-plist (copy-seq host-plist))) - (if binddn - (setq host-plist (plist-put host-plist 'binddn binddn))) - (if passwd - (setq host-plist (plist-put host-plist 'passwd passwd))) - (if ldap-verbose - (message "Opening LDAP connection to %s..." host)) + (message "Opening LDAP connection to %s..." host) (setq ldap (ldap-open host host-plist)) - (if (consp dn) - (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)) - (if ldap-verbose - (message "Deleting LDAP entry...")) - (ldap-delete ldap dn)) - (ldap-close ldap))) - + (message "Searching with LDAP on %s..." host) + (prog1 (ldap-search-internal ldap filter + (plist-get host-plist 'base) + (plist-get host-plist 'scope) + attributes attrsonly withdn) + (ldap-close ldap)))) (provide 'ldap)