Mercurial > hg > xemacs-beta
diff lisp/ldap.el @ 414:da8ed4261e83 r21-2-15
Import from CVS: tag r21-2-15
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 11:21:38 +0200 |
| parents | 697ef44129c6 |
| children | 11054d720c21 |
line wrap: on
line diff
--- a/lisp/ldap.el Mon Aug 13 11:20:44 2007 +0200 +++ b/lisp/ldap.el Mon Aug 13 11:21:38 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.4 $ +;; Version: $Revision: 1.7.2.5 $ ;; Keywords: help comm ;; This file is part of XEmacs @@ -145,14 +145,301 @@ (integer :tag "(number of records)"))))) :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 (if (featurep 'mule) + 'utf-8 + 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) + (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, 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. @@ -167,19 +454,25 @@ entry according to the value of WITHDN." (interactive "sFilter:") (or host - (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) + ldap + result) (message "Opening LDAP connection to %s..." host) (setq ldap (ldap-open host host-plist)) (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)))) + (setq result (ldap-search-internal ldap filter + (plist-get host-plist 'base) + (plist-get host-plist 'scope) + attributes attrsonly withdn)) + (ldap-close ldap) + (if ldap-ignore-attribute-codings + result + (mapcar (function + (lambda (record) + (mapcar 'ldap-decode-attribute record))) + result)))) (provide 'ldap)