diff options
Diffstat (limited to 'tcllib/modules/ldap')
| -rw-r--r-- | tcllib/modules/ldap/ChangeLog | 358 | ||||
| -rw-r--r-- | tcllib/modules/ldap/SASL.txt | 48 | ||||
| -rw-r--r-- | tcllib/modules/ldap/ldap.man | 525 | ||||
| -rw-r--r-- | tcllib/modules/ldap/ldap.tcl | 2144 | ||||
| -rw-r--r-- | tcllib/modules/ldap/ldap.test | 928 | ||||
| -rw-r--r-- | tcllib/modules/ldap/ldapx.man | 772 | ||||
| -rw-r--r-- | tcllib/modules/ldap/ldapx.tcl | 1794 | ||||
| -rw-r--r-- | tcllib/modules/ldap/ldapx.test | 375 | ||||
| -rw-r--r-- | tcllib/modules/ldap/pkgIndex.tcl | 7 |
9 files changed, 6951 insertions, 0 deletions
diff --git a/tcllib/modules/ldap/ChangeLog b/tcllib/modules/ldap/ChangeLog new file mode 100644 index 0000000..069f995 --- /dev/null +++ b/tcllib/modules/ldap/ChangeLog @@ -0,0 +1,358 @@ +2016-01-02 Michael Schlenker <mic42@users.sourceforge.net> + + * ldapx.man: Fix wrong example [Ticket: 2886893fff] + + +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-11-24 Andreas Kupries <andreask@activestate.com> + + * ldap.man: Fixed syntax error in unvalidated documentation of + last checkin. + +2008-11-22 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl: Added handling for search result references. + * ldap.man: Those are common for ActiveDirectory. + * pkgIndex.tcl: Bumped version to 1.8. + * ldap.test: + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-10-02 Andreas Kupries <andreask@activestate.com> + + * ldapx.man: Redirected the reference to non-existing subsection + 'Data' to 'Entry Instance Data'. Fixed [SF Bug 2124523]. + +2008-03-26 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl: Applied Tcllib patch #2018141 with some changes, + * ldap.man: This fixes and enhances the ldap search + * ldap.test: filter handling. Big thanks to Konstantin + * pkgIndex.tcl: Khomoutov for the patch and tests. + This fixes Tcllib bugs #1751871 and #1852718. + Additionally fixed the other ldap tests to use + a more concise style. + Bumped version to 1.7. + +2008-03-26 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * ldap.tcl (ldap::buildSASLBindRequest): Fixed a bad continuation + * ldap.man: line, i.e. whitespace between the backslash and the + * pkgIndex.tcl: end-of-line. Generally removed all trailing + whitespace from the whole file. Bumped version to 1.6.9. + +2008-02-07 Pierre David <pdav@users.sourceforge.net> + + * ldapx.tcl: Fixed a small bug when reading an LDIF modrdn. + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-08-xx Pierre David <pdav@users.sourceforge.net> + + * ldapx.tcl: Modified format for "change" entries + * ldapx.test: Adapted tests + * ldapx.man: Added a note about the format: for internal use only. + + ***POTENTIAL INCOMPATIBILITY*** + Format of ldapx::entry "change" data was not sufficient + to represent all modifications made on entries. So, the + format has been modified to include several invidual + changes. This should not be a problem since "change" + format is intended to be used only by ldapx methods. + +2007-08-06 Pierre David <pdav@users.sourceforge.net> + + * ldapx.tcl: Saved dn was not restored during swap method. + ldapx.test: Added test for backuped dn. + +2007-08-03 Andreas Kupries <andreask@activestate.com> + + * ldapx.man: Fix class command which was broken across lines. + +2007-08-03 Pierre David <pdav@users.sourceforge.net> + + * ldapx.tcl: Fixed reading of LDIF change entries. + Fixed modification of an entry by replacing + values instead of removing and adding the minimal + set of changes, since LDAP schemas don't necessarily + include equality operator for each attribute. + Introduced a "-utf8" option in the LDIF class. + Fixed indentation for LDIF continuation lines + for Base64 encoded values. + Fixed set1 when given an empty value: it deletes + the attribute (as with set). + * ldapx.test: Fixed test for the new replacement mode. + * ldapx.man: Added documentation for "-utf8" option. + + +2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * ldap.man: Fixed all warnings due to use of now deprecated + * ldapx.man: commands. Added a section about how to give feedback. + +2006-11-15 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl: Removed a leftover debug output.. + +2006-11-08 Michael Schlenker <mic42@users.sourceforge.net> + + * ldapx.tcl: Whitespace fixes. Tests for fixed bug + * ldapx.test: added. + +2006-11-04 Michael Schlenker <mic42@users.sourceforge.net> + + * ldapx.tcl: Fix for entry diff applied. + * ldap.man: Thanks to Pierre David for providing it. + * pkgIndex.tcl: + +2006-10-26 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.man: Some typo fixes, minor clarifications + and rewording. + +2006-10-09 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl: The abandon operation was incorrectly encoded. + This is now fixed and the operation works + as expected. + +2006-10-09 Michael Schlenker <mic42@users.sourceforge.net> + + * ldapx.tcl: Fixed incorrect utf-8 conversion and + broken ldif::write method. + Thanks to Pierre David for providing + the fix. + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-09-28 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl: Nasty bug in ReceiveBytes, not detecting + partial results correctly. + +2006-09-27 Michael Schlenker <mic42@users.sourceforge.net> + + * ldapx.test: New test file for the ldapx entry functions. + Thanks to Pierre David for providing it. + +2006-09-26 Andreas Kupries <andreask@activestate.com> + + * ldapx.man: Fixed ambigous subsection titles reported by Larry + Virden via [SF Tcllib Bug 1565836]. Additionally fixed a syntax + error (missing closed double-apostroph) in an example. + +2006-09-24 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl Fixed bug in secure_connect. The + channel wasn't fconfigured correctly and + the fileevent handler was not installed + in the correct way. + +2006-09-22 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.test Added some more smoketests for the public + API, so that at least some brokenness is + detected. + +2006-09-20 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl Completly redone broken error handling in + pkgIndex.tcl the fileevent handler, now it no + ldap.man longer calls bgerror but cleans up + the outstanding messages for the + connection and delivers the error + to those waiting handlers. More stupid + typo fixes. + + * ldapx.tcl Some bugfixes for error handling + ldap.tcl when searchInit is called with invalid + ldap.man arguments. Thanks to Pierre David + pkgIndex.tcl <pdav@users.sourceforge.net> for finding + them. + +2006-09-15 Michael Schlenker <mic42@users.sourceforge.net> + + * ldapx.tcl Some more fixes in the ldif part. + + * ldapx.tcl Imported some bug fixes from a new + ldapx.man version of ldapx by Pierre David. + pkgIndex.tcl Fixed bug in modifyDN, fixed wrong start + of SASL handshake, some mechanisms require + the client to send first. + + * ldap.tcl Fixed broken length calculation in message receiver. + pkgIndex.tcl This fixes bug [SF Tcllib Bug 1558564]. + Fixed various smaller bugs with upvaring handles + in info functions. + Fixed wrong debug setting. + +2006-09-11 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl Fixed missing tlsHandshakeInProgress variable when + ldap.man when using ldap::connect. + pkgIndex.tcl + +2006-09-08 Michael Schlenker <mic42@users.sourceforge.net> + + * ldapx.tcl New subpackage ldapx provides a snit + ldapx.man based OO wrapper around the ldap package. + pkgIndex.tcl Based on patch [SF Tcllib Patch 1545931] + by Pierre David <pdav@users.sourceforge.net>. + +2006-09-01 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl Major changes to the implementation. + ldap.man The package now uses a fileevent based + ldap.test protocol handler instead of the older blocking + pkgIndex.tcl calls. + SASL.txt + + ***POTENTIAL INCOMPATIBILITY*** + Connection failures are no longer handled in the blocking + ldap::* commands, instead they appear in the fileevent handler + and have to be handled with a bgerror procedure. + + I will add a per handle -errorcallback to the package soon, + which will allow user specified handlers, but those are not + yet done. + + Applied modified patches [SF Tcllib Patches 1542666, 1541828], + thanks to Pierre David for comments and code. + + In addition to this change experimental new (sub-)commands + were added: + + This change introduces new subcommands to ldap::info: + + saslmechanisms - show the supported SASL mechanisms + features - show the supported server features + control - show the supported server controls + extensions - show the supported server extensions + whoami - show the current authzId + + In addition it introduces a new ldap::starttls command, + which allows to upgrade an existing connection to TLS, + if the tls extension is present and the server supports it. + This may be part of a fix for [Tcllib Bug # 1403369]. + + There is also a new ldap::bindSASL command available, + which allows a SASL based bind with the help of the + tcllib SASL package. See the SASL.txt file for an example. + + The code has been tested a bit against OpenLDAP 2.3, but is + not entirely stable yet. + +2006-08-03 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl : Applied patch from [SF Tcllib Bug 1191326]. + * pkgIndex.tcl: Thanks to Pierre David for comments. + Version raised to 1.5 + Removed the duplicated asn code from the + module, it now package requires asn 0.6 and + namespace imports the appropriate code. + +2006-08-03 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl : Applied patch from [SF Tcllib Bug 1533868]. + * pkgIndex.tcl: Thanks to Pierre David for spotting this. + Version raised to 1.4.1 + +2006-06-20 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl : Applied patch from [SF Tcllib RFE 1082061]. + * ldap.man : ldap needs Tcl 8.4, raised the level + * pkgIndex.tcl: in the docs. Version now 1.4. + +2006-06-13 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl : Added ldap::info command for introspection. + * ldap.man : Added documentation. + * ldap.test : Testsuite for the new info command. + +2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-07-20 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl : + pkgIndex.tcl: Applied fix for [SF Tcllib Bug 1239915]. + Thanks to Pierre David for the patch. Version number now 1.2.1. + +2005-03-16 Andreas Kupries <andreask@activestate.com> + + * ldap.tcl (ldap::asnGetInteger): Fixed [SF Tcllib Bug 1164663], a + copy/paste bug in the definition of this procedure. It belongs + into the ldap namespace, not the asn namespace. + +2005-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * ldap.tcl: Reformatted to get clean indentation, also trimmed + trailing whitespace. + +2005-02-15 Michael Schlenker <mic42@users.sourceforge.net> + + * ldap.tcl: Fixed various issue with signed/unsigned integers in + length and integer encoding/decoding, by crossporting the 64-bit + aware integer and length code from the asn module. + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * ldap.tcl: Fixed expr'essions without braces. + +2004-04-27 Andreas Kupries <andreask@activestate.com> + + * ldap.man: small fixes in the docs, additional example for + searches and search result processing. + + * New module: Provided to us by Joechen Loewer <loewerj@web.de>. + * Added doctools documentation. diff --git a/tcllib/modules/ldap/SASL.txt b/tcllib/modules/ldap/SASL.txt new file mode 100644 index 0000000..8b7b3de --- /dev/null +++ b/tcllib/modules/ldap/SASL.txt @@ -0,0 +1,48 @@ +Using SASL with the tcllib ldap client + +The current SASL support for the ldap client has been tested with openLDAP 2.3 and CyrusSASL, +but is considered experimental. + +The OpenLDAP slapd.conf file used for testing had the following entries to map the +SASL auth information, the actual SASL passwords were stored in the sasldb with the help +of saslpasswd2: + + # SASL Mappings + # + + sasl-host localhost + sasl-realm ldap + authz-regexp + uid=([^,]+),(cn=[^,]+,)?cn=digest-md5,cn=auth + ldap:///ou=SomeOU,dc=tcllib,dc=tcltk??one?(uid=$i) + + authz-regexp + uid=([^,]+),(cn=[^,]+,)?cn=cram-md5,cn=auth + ldap:///ou=SomeOU,dc=tcllib,dc=tcltk??one?(uid=$i) + + +A rather typical user of that server would be for example: + + cn=James Bond,ou=SomeOU,dc=tcllib,dc=tcltk + objectClass inetOrgPerson + cn James Bond + sn Bond + uid u007 + +Now you can SASL auth with the tcllib ldap client with the following: + + package require ldap 1.6 + + set handle [ldap::connect localhost] + set auth [ldap::bindSASL u007 "mollypenny"] + if {$auth} { + puts "Succesfully bound with SASL" + } else { + puts "SASL bind failed" + } + +To find out your real authzId, you can then use the ldap::whoami command. + + puts "auhtzId: [ldap::whoami $handle]" + + diff --git a/tcllib/modules/ldap/ldap.man b/tcllib/modules/ldap/ldap.man new file mode 100644 index 0000000..1e6e9ed --- /dev/null +++ b/tcllib/modules/ldap/ldap.man @@ -0,0 +1,525 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin ldap n 1.6.9] +[keywords {directory access}] +[keywords internet] +[keywords ldap] +[keywords {ldap client}] +[keywords protocol] +[keywords {rfc 2251}] +[keywords {rfc 4511}] +[keywords x.500] +[copyright {2004 Andreas Kupries <andreas_kupries@users.sourceforge.net>}] +[copyright {2004 Jochen Loewer <loewerj@web.de>}] +[copyright {2006 Michael Schlenker <mic42@users.sourceforge.net>}] +[moddesc {LDAP client}] +[titledesc {LDAP client}] +[category Networking] +[require Tcl 8.4] +[require ldap [opt 1.8]] +[description] +[para] + +The [package ldap] package provides a Tcl-only client library +for the LDAPv3 protocol as specified in + +RFC 4511 ([uri http://www.rfc-editor.org/rfc/rfc4511.txt]). + +It works by opening the standard (or secure) LDAP socket on the +server, and then providing a Tcl API to access the LDAP protocol +commands. All server errors are returned as Tcl errors (thrown) which +must be caught with the Tcl [cmd catch] command. + +[include ../common-text/tls-security-notes.inc] + +[section COMMANDS] + +[list_begin definitions] + +[call [cmd ::ldap::connect] [arg host] [opt [arg port]]] + +Opens a LDAPv3 connection to the specified [arg host], at the given +[arg port], and returns a token for the connection. This token is the +[arg handle] argument for all other commands. If no [arg port] is +specified it will default to [const 389]. + +[para] + +The command blocks until the connection has been established, or +establishment definitely failed. + +[call [cmd ::ldap::secure_connect] [arg host] [opt [arg port]]] + +Like [cmd ::ldap::connect], except that the created connection is +secured by SSL. The port defaults to [const 636]. This command +depends on the availability of the package [package TLS], which is a +SSL binding for Tcl. If [package TLS] is not available, then this +command will fail. + +[para] + +The command blocks until the connection has been established, or +establishment definitely failed. + +[call [cmd ::ldap::disconnect] [arg handle]] + +Closes the ldap connection refered to by the token +[arg handle]. Returns the empty string as its result. + +[call [cmd ::ldap::starttls] [arg handle] [opt [arg cafile]] [opt [arg certfile]] [opt [arg keyfile]]] + +Start TLS negotiation on the connection denoted by [arg handle]. + +This is currently experimental and subject to change, more control over the TLS details +will probably be exposed later, to allow users to fine tune the negotiation according +to their security needs. + +[call [cmd ::ldap::bind] [arg handle] [opt [arg name]] [opt [arg password]]] + +This command authenticates the ldap connection refered to by the token +in [arg handle], with a user name and associated password. It blocks +until a response from the ldap server arrives. Its result is the empty +string. + +Both [arg name] and [arg passwd] default to the empty string if they +are not specified. + +By leaving out [arg name] and [arg passwd] you can make an anonymous bind to +the ldap server. + +You can issue [cmd ::ldap::bind] again to bind with different credentials. + +[call [cmd ::ldap::bindSASL] [arg handle] [opt [arg name]] [opt [arg password]]] + +This command uses SASL authentication mechanisms to do a multistage bind. + +Its otherwise identical to the standard [cmd ::ldap::bind]. + +This feature is currently experimental and subject to change. See the documentation +for the [package SASL] and the [file SASL.txt] in the tcllib CVS repository for +details how to setup and use SASL with openldap. + +[call [cmd ::ldap::unbind] [arg handle]] + +This command asks the ldap server to release the last bind done for +the connection refered to by the token in [arg handle]. + +The [arg handle] is invalid after the unbind, as the server closes the connection. +So this is effectivly just a more polite disconnect operation. + +[call [cmd ::ldap::search] [arg handle] [arg baseObject] [arg filterString] [arg attributes] [arg options]] + +This command performs a LDAP search below the [arg baseObject] tree +using a complex LDAP search expression [arg filterString] and returns +the specified [arg attributes] of all matching objects (DNs). If the +list of [arg attributes] was empty all attributes are returned. The +command blocks until it has received all results. + +The valid [arg options] are identical to the options listed for [cmd ::ldap::searchInit]. + +[para] +An example of a search expression is +[para] +[example { + set filterString "|(cn=Linus*)(sn=Torvalds*)" +}] +[para] + +The return value of the command is a list of nested dictionaries. The +first level keys are object identifiers (DNs), second levels keys are +attribute names. In other words, it is in the form + +[para] +[example { + {dn1 {attr1 {val11 val12 ...} attr2 {val21...} ...}} {dn2 {a1 {v11 ...} ...}} ... +}] +[para] + +[call [cmd ::ldap::searchInit] [arg handle] [arg baseObject] [arg filterString] [arg attributes] [arg options]] + +This command initiates a LDAP search below the [arg baseObject] tree +using a complex LDAP search expression [arg filterString]. +The search gets the specified [arg attributes] of all matching objects (DNs). + +The command itself just starts the search, to retrieve the actual results, use +[cmd ::ldap::searchNext]. +A search can be terminated at any time by +[cmd ::ldap::searchEnd]. This informs the server that no further results should be sent by sending and ABANDON message +and cleans up the internal state of the search. + +Only one [cmd ::ldap::search] can be active at a given time, this +includes the introspection commands [cmd {::ldap::info saslmechanisms}], [cmd {ldap::info control}] and +[cmd {ldap::info extensions}], which invoke a search internally. + +Error responses from the server due to wrong arguments or similar things are returned +with the first [cmd ::ldap::searchNext] call and should be checked and dealed with there. + +If the list of requested [arg attributes] is empty all attributes will be returned. +The parameter [arg options] specifies the options to be used in the search, +and has the following format: + +[para] +[example { + {-option1 value1 -option2 value2 ... } +}] +[para] + +Following options are available: + +[list_begin options] +[opt_def -scope {base one sub} ] + +Control the scope of the search to be one of [const base], [const one], or [const sub], to specify a base +object, one-level or subtree search. The default is [const sub]. + +[opt_def {-derefaliases} {never search find always}] + +Control how aliases dereferencing is done. Should be one of [const never], [const always], [const search], or [const find] to +specify that aliases are never dereferenced, always dereferenced, dereferenced when searching, or +dereferenced only when locating the base object for the search. +The default is to never dereference aliases. + +[opt_def {-sizelimit} num ] + +Determines the maximum number of entries to return in a search. If specified as +0 no limit is enforced. The server may enforce a configuration dependent sizelimit, +which may be lower than the one given by this option. The default is 0, no limit. + +[opt_def {-timelimit} seconds] + +Asks the server to use a timelimit of [arg seconds] for the search. Zero means no +limit. The default is 0, no limit. + +[opt_def {-attrsonly} boolean] + +If set to 1 only the attribute names but not the values will be present in the search result. +The default is to retrieve attribute names and values. + +[opt_def {-referencevar} varname] + +If set the search result reference LDAPURIs, if any, are returned in the given variable. +The caller can than decide to follow those references and query other LDAP servers for +further results. + +[list_end] +[para] + +[call [cmd ::ldap::searchNext] [arg handle]] + +This command returns the next entry from a LDAP search initiated +by [cmd ::ldap::searchInit]. It returns only after a new result is received +or when no further results are available, but takes care to keep +the event loop alive. + +The returned entry is a list with +two elements: the first is the DN of the entry, the second is the +list of attributes and values, under the format: + +[para] +[example { + dn {attr1 {val11 val12 ...} attr2 {val21...} ...} +}] +[para] + +The [cmd ::ldap::searchNext] command returns an empty list at the +end of the search. + +[para] + +[call [cmd ::ldap::searchEnd] [arg handle]] + +This command terminates a LDAP search initiated +by [cmd ::ldap::searchInit]. It also cleans up +the internal state so a new search can be initiated. + +If the client has not yet received all results, the client +sends an ABANDON message to inform the server that no +further results for the previous search should to be sent. + +[para] + +[call [cmd ::ldap::modify] [arg handle] [arg dn] \ + [arg attrValToReplace] \ + [opt [arg attrToDelete]] \ + [opt [arg attrValToAdd]]] + +This command modifies the object [arg dn] on the ldap server we are +connected to via [arg handle]. It replaces attributes with new values, +deletes attributes, and adds new attributes with new values. + +All arguments are dictionaries mapping attribute names to values. The +optional arguments default to the empty dictionary, which means that +no attributes will be deleted nor added. + +[list_begin arguments] +[arg_def dictionary attrValToReplace in] + +No attributes will be changed if this argument is empty. The +dictionary contains the new attributes and their values. They +[emph {replace all}] attributes known to the object. + +[arg_def dictionary attrToDelete in] + +No attributes will be deleted if this argument is empty. The +dictionary values are restrictions on the deletion. An attribute +listed here will be deleted if and only if its current value at the +server matches the value specified in the dictionary, or if the value +in the dictionary is the empty string. + +[arg_def dictionary attrValToAdd in] + +No attributes will be added if this argument is empty. The dictionary +values are the values for the new attributes. + +[list_end] +[para] + +The command blocks until all modifications have completed. Its result +is the empty string. + +[call [cmd ::ldap::modifyMulti] [arg handle] [arg dn] \ + [arg attrValToReplace] \ + [opt [arg attrValToDelete]] \ + [opt [arg attrValToAdd]]] + +This command modifies the object [arg dn] on the ldap server we are +connected to via [arg handle]. It replaces attributes with new values, +deletes attributes, and adds new attributes with new values. + +All arguments are lists with the format: +[para] +[example { + attr1 {val11 val12 ...} attr2 {val21...} ... +}] +[para] +where each value list may be empty for deleting all attributes. +The optional arguments default to empty lists of attributes to +delete and to add. + +[list_begin arguments] +[arg_def list attrValToReplace in] + +No attributes will be changed if this argument is empty. The +dictionary contains the new attributes and their values. They +[emph {replace all}] attributes known to the object. + +[arg_def list attrValToDelete in] + +No attributes will be deleted if this argument is empty. If no +value is specified, the whole set of values for an attribute +will be deleted. + +[arg_def list attrValToAdd in] + +No attributes will be added if this argument is empty. + +[list_end] +[para] + +The command blocks until all modifications have completed. Its result +is the empty string. + +[call [cmd ::ldap::add] [arg handle] [arg dn] [arg attrValueTuples]] + +This command creates a new object using the specified [arg dn]. The +attributes of the new object are set to the values in the list +[arg attrValueTuples]. +Multiple valuated attributes may be specified using multiple tuples. + +The command blocks until the operation has completed. Its result +is the empty string. + +[call [cmd ::ldap::addMulti] [arg handle] [arg dn] [arg attrValueTuples]] + +This command is the preferred one to create +a new object using the specified [arg dn]. The +attributes of the new object are set to the values in the dictionary +[arg attrValueTuples] (which is keyed by the attribute names). +Each tuple is a list containing multiple values. + +The command blocks until the operation has completed. Its result +is the empty string. + +[call [cmd ::ldap::delete] [arg handle] [arg dn]] + +This command removes the object specified by [arg dn], and all its +attributes from the server. + +The command blocks until the operation has completed. Its result +is the empty string. + +[call [cmd ::ldap::modifyDN] [arg handle] [arg dn] [arg newrdn] [opt [arg deleteOld]] [opt [arg newSuperior]]]] + +This command moves or copies the object specified by [arg dn] +to a new location in the tree of object. This location is +specified by [arg newrdn], a [emph relative] designation, +or by [arg newrdn] and [arg newSuperior], a [emph absolute] designation. + +The optional argument [arg deleteOld] defaults to [const true], +i.e. a move operation. If [arg deleteOld] is not set, then the +operation will create a copy of [arg dn] in the new location. + +The optional argument [arg newSuperior] defaults an empty string, +meaning that the object must not be relocated in another branch of +the tree. If this argument is given, the argument [arg deleteOld] +must be specified also. + +The command blocks until the operation has completed. Its result +is the empty string. + +[call [cmd ::ldap::info] [cmd ip] [arg handle]] + +This command returns the IP address of the remote LDAP server the handle is connected to. + +[call [cmd ::ldap::info] [cmd bound] [arg handle]] + +This command returns 1 if a handle has successfully completed a [cmd ::ldap::bind]. +If no bind was done or it failed, a 0 is returned. + +[call [cmd ::ldap::info] [cmd bounduser] [arg handle]] + +This command returns the username used in the bind operation if a handle has successfully completed a [cmd ::ldap::bind]. +If no bound was done or it failed, an empty string is returned. + +[call [cmd ::ldap::info] [cmd connections] ] + +This command returns all currently existing ldap connection handles. + +[call [cmd ::ldap::info] [cmd tls] [arg handle] ] + +This command returns 1 if the ldap connection [arg handle] used TLS/SSL for +connection via [cmd ldap::secure_connect] or completed [cmd ldap::starttls], 0 otherwise. + +[call [cmd ::ldap::info] [cmd saslmechanisms] [arg handle]] + +Return the supported SASL mechanisms advertised by the server. Only valid in a +bound state (anonymous or other). + +[call [cmd ::ldap::info] [cmd control] [arg handle] ] + +Return the supported controls advertised by the server as a list of OIDs. Only valid in a bound state. + +This is currently experimental and subject to change. + +[call [cmd ::ldap::info] [cmd extensions] [arg extensions] ] + +Returns the supported LDAP extensions as list of OIDs. Only valid in a bound state. + +This is currently experimental and subject to change. + +[call [cmd ::ldap::info] [cmd whoami] [arg handle]] + +Returns authzId for the current connection. This implements the RFC 4532 +protocol extension. + +[list_end] +[para] + +[section EXAMPLES] +[para] + +A small example, extracted from the test application coming with this +code. + +[para] +[example { + package require ldap + + # Connect, bind, add a new object, modify it in various ways + + set handle [ldap::connect localhost 9009] + + set dn "cn=Manager, o=University of Michigan, c=US" + set pw secret + + ldap::bind $handle $dn $pw + + set dn "cn=Test User,ou=People,o=University of Michigan,c=US" + + ldap::add $handle $dn { + objectClass OpenLDAPperson + cn {Test User} + mail test.user@google.com + uid testuid + sn User + telephoneNumber +31415926535 + telephoneNumber +27182818285 + } + + set dn "cn=Another User,ou=People,o=University of Michigan,c=US" + + ldap::addMulti $handle $dn { + objectClass {OpenLDAPperson} + cn {{Anotther User}} + mail {test.user@google.com} + uid {testuid} + sn {User} + telephoneNumber {+31415926535 +27182818285} + } + + # Replace all attributes + ldap::modify $handle $dn [list drink icetea uid JOLO] + + # Add some more + ldap::modify $handle $dn {} {} [list drink water \ + drink orangeJuice pager "+1 313 555 7671"] + + # Delete + ldap::modify $handle $dn {} [list drink water \ + pager ""] + + # Move + ldap::modifyDN $handle $dn "cn=Tester" + + # Kill the test object, and shut the connection down. + set dn "cn=Tester,ou=People,o=University of Michigan,c=US" + ldap::delete $handle $dn + + ldap::unbind $handle + ldap::disconnect $handle +}] +[para] + +And a another example, a simple query, and processing the +results. + +[para] +[example { + package require ldap + set handle [ldap::connect ldap.acme.com 389] + ldap::bind $handle + set results [ldap::search $handle "o=acme,dc=com" "(uid=jdoe)" {}] + foreach result $results { + foreach {object attributes} $result break + + # The processing here is similar to what 'parray' does. + # I.e. finding the longest attribute name and then + # generating properly aligned output listing all attributes + # and their values. + + set width 0 + set sortedAttribs {} + foreach {type values} $attributes { + if {[string length $type] > $width} { + set width [string length $type] + } + lappend sortedAttribs [list $type $values] + } + + puts "object='$object'" + + foreach sortedAttrib $sortedAttribs { + foreach {type values} $sortedAttrib break + foreach value $values { + regsub -all "\[\x01-\x1f\]" $value ? value + puts [format " %-${width}s %s" $type $value] + } + } + puts "" + } + ldap::unbind $handle + ldap::disconnect $handle +}] + +[vset CATEGORY ldap] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/ldap/ldap.tcl b/tcllib/modules/ldap/ldap.tcl new file mode 100644 index 0000000..eb82b6e --- /dev/null +++ b/tcllib/modules/ldap/ldap.tcl @@ -0,0 +1,2144 @@ +#----------------------------------------------------------------------------- +# Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de) +# Copyright (C) 2006 Michael Schlenker (mic42@users.sourceforge.net) +#----------------------------------------------------------------------------- +# +# A (partial) LDAPv3 protocol implementation in plain Tcl. +# +# See RFC 4510 and ASN.1 (X.680) and BER (X.690). +# +# +# This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The +# following terms apply to all files associated with the software unless +# explicitly disclaimed in individual files. +# +# The authors hereby grant permission to use, copy, modify, distribute, +# and license this software and its documentation for any purpose, provided +# that existing copyright notices are retained in all copies and that this +# notice is included verbatim in any distributions. No written agreement, +# license, or royalty fee is required for any of the authorized uses. +# Modifications to this software may be copyrighted by their authors +# and need not follow the licensing terms described here, provided that +# the new terms are clearly indicated on the first page of each file where +# they apply. +# +# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +# MODIFICATIONS. +# +# $Id: ldap.tcl,v 1.26 2008/11/22 12:25:27 mic42 Exp $ +# +# written by Jochen Loewer +# 3 June, 1999 +# +#----------------------------------------------------------------------------- + +package require Tcl 8.4 +package require asn 0.7 +package provide ldap 1.8 + +namespace eval ldap { + + namespace export connect secure_connect \ + disconnect \ + bind unbind \ + bindSASL \ + search \ + searchInit \ + searchNext \ + searchEnd \ + modify \ + modifyMulti \ + add \ + addMulti \ + delete \ + modifyDN \ + info + + namespace import ::asn::* + + variable SSLCertifiedAuthoritiesFile + variable doDebug + + set doDebug 0 + + # LDAP result codes from the RFC + variable resultCode2String + array set resultCode2String { + 0 success + 1 operationsError + 2 protocolError + 3 timeLimitExceeded + 4 sizeLimitExceeded + 5 compareFalse + 6 compareTrue + 7 authMethodNotSupported + 8 strongAuthRequired + 10 referral + 11 adminLimitExceeded + 12 unavailableCriticalExtension + 13 confidentialityRequired + 14 saslBindInProgress + 16 noSuchAttribute + 17 undefinedAttributeType + 18 inappropriateMatching + 19 constraintViolation + 20 attributeOrValueExists + 21 invalidAttributeSyntax + 32 noSuchObject + 33 aliasProblem + 34 invalidDNSyntax + 35 isLeaf + 36 aliasDereferencingProblem + 48 inappropriateAuthentication + 49 invalidCredentials + 50 insufficientAccessRights + 51 busy + 52 unavailable + 53 unwillingToPerform + 54 loopDetect + 64 namingViolation + 65 objectClassViolation + 66 notAllowedOnNonLeaf + 67 notAllowedOnRDN + 68 entryAlreadyExists + 69 objectClassModsProhibited + 80 other + } + +} + + +#----------------------------------------------------------------------------- +# Lookup an numerical ldap result code and return a string version +# +#----------------------------------------------------------------------------- +proc ::ldap::resultCode2String {code} { + variable resultCode2String + if {[::info exists resultCode2String($code)]} { + return $resultCode2String($code) + } else { + return "unknownError" + } +} + +#----------------------------------------------------------------------------- +# Basic sanity check for connection handles +# must be an array +#----------------------------------------------------------------------------- +proc ::ldap::CheckHandle {handle} { + if {![array exists $handle]} { + return -code error \ + [format "Not a valid LDAP connection handle: %s" $handle] + } +} + +#----------------------------------------------------------------------------- +# info +# +#----------------------------------------------------------------------------- + +proc ldap::info {args} { + set cmd [lindex $args 0] + set cmds {connections bound bounduser control extensions features ip saslmechanisms tls whoami} + if {[llength $args] == 0} { + return -code error \ + "Usage: \"info subcommand ?handle?\"" + } + if {[lsearch -exact $cmds $cmd] == -1} { + return -code error \ + "Invalid subcommand \"$cmd\", valid commands are\ + [join [lrange $cmds 0 end-1] ,] and [lindex $cmds end]" + } + eval [linsert [lrange $args 1 end] 0 ldap::info_$cmd] +} + +#----------------------------------------------------------------------------- +# get the ip address of the server we connected to +# +#----------------------------------------------------------------------------- +proc ldap::info_ip {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info ip handle" + } + CheckHandle [lindex $args 0] + upvar #0 [lindex $args 0] conn + if {![::info exists conn(sock)]} { + return -code error \ + "\"[lindex $args 0]\" is not a ldap connection handle" + } + return [lindex [fconfigure $conn(sock) -peername] 0] +} + +#----------------------------------------------------------------------------- +# get the list of open ldap connections +# +#----------------------------------------------------------------------------- +proc ldap::info_connections {args} { + if {[llength $args] != 0} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info connections" + } + return [::info vars ::ldap::ldap*] +} + +#----------------------------------------------------------------------------- +# check if the connection is bound +# +#----------------------------------------------------------------------------- +proc ldap::info_bound {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info bound handle" + } + CheckHandle [lindex $args 0] + upvar #0 [lindex $args 0] conn + if {![::info exists conn(bound)]} { + return -code error \ + "\"[lindex $args 0]\" is not a ldap connection handle" + } + + return $conn(bound) +} + +#----------------------------------------------------------------------------- +# check with which user the connection is bound +# +#----------------------------------------------------------------------------- +proc ldap::info_bounduser {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info bounduser handle" + } + CheckHandle [lindex $args 0] + upvar #0 [lindex $args 0] conn + if {![::info exists conn(bound)]} { + return -code error \ + "\"[lindex $args 0]\" is not a ldap connection handle" + } + + return $conn(bounduser) +} + +#----------------------------------------------------------------------------- +# check if the connection uses tls +# +#----------------------------------------------------------------------------- + +proc ldap::info_tls {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info tls handle" + } + CheckHandle [lindex $args 0] + upvar #0 [lindex $args 0] conn + if {![::info exists conn(tls)]} { + return -code error \ + "\"[lindex $args 0]\" is not a ldap connection handle" + } + return $conn(tls) +} + +proc ldap::info_saslmechanisms {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info saslmechanisms handle" + } + return [Saslmechanisms [lindex $args 0]] +} + +proc ldap::info_extensions {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info extensions handle" + } + return [Extensions [lindex $args 0]] +} + +proc ldap::info_control {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info control handle" + } + return [Control [lindex $args 0]] +} + +proc ldap::info_features {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info features handle" + } + return [Features [lindex $args 0]] +} + +proc ldap::info_whoami {args} { + if {[llength $args] != 1} { + return -code error \ + "Wrong # of arguments. Usage: ldap::info whoami handle" + } + return [Whoami [lindex $args 0]] +} + + +#----------------------------------------------------------------------------- +# Basic server introspection support +# +#----------------------------------------------------------------------------- +proc ldap::Saslmechanisms {conn} { + CheckHandle $conn + lindex [ldap::search $conn {} {(objectClass=*)} \ + {supportedSASLMechanisms} -scope base] 0 1 1 +} + +proc ldap::Extensions {conn} { + CheckHandle $conn + lindex [ldap::search $conn {} {(objectClass=*)} \ + {supportedExtension} -scope base] 0 1 1 +} + +proc ldap::Control {conn} { + CheckHandle $conn + lindex [ldap::search $conn {} {(objectClass=*)} \ + {supportedControl} -scope base] 0 1 1 +} + +proc ldap::Features {conn} { + CheckHandle $conn + lindex [ldap::search $conn {} {(objectClass=*)} \ + {supportedFeatures} -scope base] 0 1 1 +} + +#------------------------------------------------------------------------------- +# Implements the RFC 4532 extension "Who am I?" +# +#------------------------------------------------------------------------------- +proc ldap::Whoami {handle} { + CheckHandle $handle + if {[lsearch [ldap::Extensions $handle] 1.3.6.1.4.1.4203.1.11.3] == -1} { + return -code error \ + "Server does not support the \"Who am I?\" extension" + } + + set request [asnApplicationConstr 23 [asnOctetString 1.3.6.1.4.1.4203.1.11.3]] + set mid [SendMessage $handle $request] + set response [WaitForResponse $handle $mid] + + asnGetApplication response appNum + if {$appNum != 24} { + return -code error \ + "unexpected application number ($appNum != 24)" + } + + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + } + set whoami "" + if {[string length $response]} { + asnRetag response 0x04 + asnGetOctetString response whoami + } + return $whoami +} + +#----------------------------------------------------------------------------- +# connect +# +#----------------------------------------------------------------------------- +proc ldap::connect { host {port 389} } { + + #-------------------------------------- + # connect via TCP/IP + #-------------------------------------- + set sock [socket $host $port] + fconfigure $sock -blocking no -translation binary -buffering full + + #-------------------------------------- + # initialize connection array + #-------------------------------------- + upvar #0 ::ldap::ldap$sock conn + catch { unset conn } + + set conn(host) $host + set conn(sock) $sock + set conn(messageId) 0 + set conn(tls) 0 + set conn(bound) 0 + set conn(bounduser) "" + set conn(saslBindInProgress) 0 + set conn(tlsHandshakeInProgress) 0 + set conn(lastError) "" + set conn(referenceVar) [namespace current]::searchReferences + set conn(returnReferences) 0 + + fileevent $sock readable [list ::ldap::MessageReceiver ::ldap::ldap$sock] + return ::ldap::ldap$sock +} + +#----------------------------------------------------------------------------- +# secure_connect +# +#----------------------------------------------------------------------------- +proc ldap::secure_connect { host {port 636} } { + + variable SSLCertifiedAuthoritiesFile + + package require tls + + #------------------------------------------------------------------ + # connect via TCP/IP + #------------------------------------------------------------------ + set sock [socket $host $port] + fconfigure $sock -blocking no -translation binary -buffering full + + #------------------------------------------------------------------ + # make it a SSL connection + # + #------------------------------------------------------------------ + #tls::import $sock -cafile $SSLCertifiedAuthoritiesFile -ssl2 no -ssl3 yes -tls1 yes + tls::import $sock -cafile "" -certfile "" -keyfile "" \ + -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes + set retry 0 + while {1} { + if {$retry > 20} { + close $sock + return -code error "too long retry to setup SSL connection" + } + if {[catch { tls::handshake $sock } err]} { + if {[string match "*resource temporarily unavailable*" $err]} { + after 50 + incr retry + } else { + close $sock + return -code error $err + } + } else { + break + } + } + + #-------------------------------------- + # initialize connection array + #-------------------------------------- + upvar ::ldap::ldap$sock conn + catch { unset conn } + + set conn(host) $host + set conn(sock) $sock + set conn(messageId) 0 + set conn(tls) 1 + set conn(bound) 0 + set conn(bounduser) "" + set conn(saslBindInProgress) 0 + set conn(tlsHandshakeInProgress) 0 + set conn(lasterror) "" + set conn(referenceVar) [namespace current]::searchReferences + set conn(returnReferences) 0 + + fileevent $sock readable [list ::ldap::MessageReceiver ::ldap::ldap$sock] + return ::ldap::ldap$sock +} + + +#------------------------------------------------------------------------------ +# starttls - negotiate tls on an open ldap connection +# +#------------------------------------------------------------------------------ +proc ldap::starttls {handle {cafile ""} {certfile ""} {keyfile ""}} { + CheckHandle $handle + + upvar #0 $handle conn + + if {$conn(tls)} { + return -code error \ + "Cannot StartTLS on connection, TLS already running" + } + + if {[ldap::waitingForMessages $handle]} { + return -code error \ + "Cannot StartTLS while waiting for repsonses" + } + + if {$conn(saslBindInProgress)} { + return -code error \ + "Cannot StartTLS while SASL bind in progress" + } + + if {[lsearch -exact [ldap::Extensions $handle] 1.3.6.1.4.1.1466.20037] == -1} { + return -code error \ + "Server does not support the StartTLS extension" + } + package require tls + + + set request [asnApplicationConstr 23 [asnOctetString 1.3.6.1.4.1.1466.20037]] + set mid [SendMessage $handle $request] + set conn(tlsHandshakeInProgress) 1 + set response [WaitForResponse $handle $mid] + + asnGetApplication response appNum + if {$appNum != 24} { + set conn(tlsHandshakeInProgress) 0 + return -code error \ + "unexpected application number ($appNum != 24)" + } + + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {$resultCode != 0} { + set conn(tlsHandshakeInProgress) 0 + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + } + set oid "1.3.6.1.4.1.1466.20037" + if {[string length $response]} { + asnRetag response 0x04 + asnGetOctetString response oid + } + if {$oid ne "1.3.6.1.4.1.1466.20037"} { + set conn(tlsHandshakeInProgress) 0 + return -code error \ + "Unexpected LDAP response" + } + + tls::import $conn(sock) -cafile $cafile -certfile $certfile -keyfile $keyfile \ + -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes + set retry 0 + while {1} { + if {$retry > 20} { + close $sock + return -code error "too long retry to setup SSL connection" + } + if {[catch { tls::handshake $conn(sock) } err]} { + if {[string match "*resource temporarily unavailable*" $err]} { + after 50 + incr retry + } else { + close $conn(sock) + return -code error $err + } + } else { + break + } + } + set conn(tls) 1 + set conn(tlsHandshakeInProgress) 0 + return 1 +} + + + +#------------------------------------------------------------------------------ +# Create a new unique message and send it over the socket. +# +#------------------------------------------------------------------------------ + +proc ldap::CreateAndSendMessage {handle payload} { + upvar #0 $handle conn + + if {$conn(tlsHandshakeInProgress)} { + return -code error \ + "Cannot send other LDAP PDU while TLS handshake in progress" + } + + incr conn(messageId) + set message [asnSequence [asnInteger $conn(messageId)] $payload] + debugData "Message $conn(messageId) Sent" $message + puts -nonewline $conn(sock) $message + flush $conn(sock) + return $conn(messageId) +} + +#------------------------------------------------------------------------------ +# Send a message to the server which expects a response, +# returns the messageId which is to be used with FinalizeMessage +# and WaitForResponse +# +#------------------------------------------------------------------------------ +proc ldap::SendMessage {handle pdu} { + upvar #0 $handle conn + set mid [CreateAndSendMessage $handle $pdu] + + # safe the state to match responses + set conn(message,$mid) [list] + return $mid +} + +#------------------------------------------------------------------------------ +# Send a message to the server without expecting a response +# +#------------------------------------------------------------------------------ +proc ldap::SendMessageNoReply {handle pdu} { + upvar #0 $handle conn + return [CreateAndSendMessage $handle $pdu] +} + +#------------------------------------------------------------------------------ +# Cleanup the storage associated with a messageId +# +#------------------------------------------------------------------------------ +proc ldap::FinalizeMessage {handle messageId} { + upvar #0 $handle conn + trace "Message $messageId finalized" + unset -nocomplain conn(message,$messageId) +} + +#------------------------------------------------------------------------------ +# Wait for a response for the given messageId. +# +# This waits in a vwait if no message has yet been received or returns +# the oldest message at once, if it is queued. +# +#------------------------------------------------------------------------------ +proc ldap::WaitForResponse {handle messageId} { + upvar #0 $handle conn + + trace "Waiting for Message $messageId" + # check if the message waits for a reply + if {![::info exists conn(message,$messageId)]} { + return -code error \ + [format "Cannot wait for message %d." $messageId] + } + + # check if we have a received response in the buffer + if {[llength $conn(message,$messageId)] > 0} { + set response [lindex $conn(message,$messageId) 0] + set conn(message,$messageId) [lrange $conn(message,$messageId) 1 end] + return $response + } + + # wait for an incoming response + vwait [namespace which -variable $handle](message,$messageId) + if {[llength $conn(message,$messageId)] == 0} { + # We have waited and have been awakended but no message is there + if {[string length $conn(lastError)]} { + return -code error \ + [format "Protocol error: %s" $conn(lastError)] + } else { + return -code error \ + [format "Broken response for message %d" $messageId] + } + } + set response [lindex $conn(message,$messageId) 0] + set conn(message,$messageId) [lrange $conn(message,$messageId) 1 end] + return $response +} + +proc ldap::waitingForMessages {handle} { + upvar #0 $handle conn + return [llength [array names conn message,*]] +} + +#------------------------------------------------------------------------------ +# Process a single response PDU. Decodes the messageId and puts the +# message into the appropriate queue. +# +#------------------------------------------------------------------------------ + +proc ldap::ProcessMessage {handle response} { + upvar #0 $handle conn + + # decode the messageId + asnGetInteger response messageId + + # check if we wait for a response + if {[::info exists conn(message,$messageId)]} { + # append the new message, which triggers + # message handlers using vwait on the entry + lappend conn(message,$messageId) $response + return + } + + # handle unsolicited server responses + + if {0} { + asnGetApplication response appNum + #if { $appNum != 24 } { + # error "unexpected application number ($appNum != 24)" + #} + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {[string length $response]} { + asnGetOctetString response responseName + } + if {[string length $response]} { + asnGetOctetString response responseValue + } + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + } + } + #dumpASN1Parse $response + #error "Unsolicited message from server" + +} + +#------------------------------------------------------------------------------- +# Get the code out of waitForResponse in case of errors +# +#------------------------------------------------------------------------------- +proc ldap::CleanupWaitingMessages {handle} { + upvar #0 $handle conn + foreach message [array names conn message,*] { + set conn($message) [list] + } +} + +#------------------------------------------------------------------------------- +# The basic fileevent based message receiver. +# It reads PDU's from the network in a non-blocking fashion. +# +#------------------------------------------------------------------------------- +proc ldap::MessageReceiver {handle} { + upvar #0 $handle conn + + # We have to account for partial PDUs received, so + # we keep some state information. + # + # conn(pdu,partial) -- we are reading a partial pdu if non zero + # conn(pdu,length_bytes) -- the buffer for loading the length + # conn(pdu,length) -- we have decoded the length if >= 0, if <0 it contains + # the length of the length encoding in bytes + # conn(pdu,payload) -- the payload buffer + # conn(pdu,received) -- the data received + + # fetch the sequence byte + if {[::info exists conn(pdu,partial)] && $conn(pdu,partial) != 0} { + # we have decoded at least the type byte + } else { + foreach {code type} [ReceiveBytes $conn(sock) 1] {break} + switch -- $code { + ok { + binary scan $type c byte + set type [expr {($byte + 0x100) % 0x100}] + if {$type != 0x30} { + CleanupWaitingMessages $handle + set conn(lastError) [format "Expected SEQUENCE (0x30) but got %x" $type] + return + } else { + set conn(pdu,partial) 1 + append conn(pdu,received) $type + } + } + eof { + CleanupWaitingMessages $handle + set conn(lastError) "Server closed connection" + catch {close $conn(sock)} + return + } + default { + CleanupWaitingMessages $handle + set bytes $type[read $conn(sock)] + binary scan $bytes h* values + set conn(lastError) [format \ + "Error reading SEQUENCE response for handle %s : %s : %s" $handle $code $values] + return + } + } + } + + + # fetch the length + if {[::info exists conn(pdu,length)] && $conn(pdu,length) >= 0} { + # we already have a decoded length + } else { + if {[::info exists conn(pdu,length)] && $conn(pdu,length) < 0} { + # we already know the length, but have not received enough bytes to decode it + set missing [expr {1+abs($conn(pdu,length))-[string length $conn(pdu,length_bytes)]}] + if {$missing != 0} { + foreach {code bytes} [ReceiveBytes $conn(sock) $missing] {break} + switch -- $code { + "ok" { + append conn(pdu,length_bytes) $bytes + append conn(pdu,received) $bytes + asnGetLength conn(pdu,length_bytes) conn(pdu,length) + } + "partial" { + append conn(pdu,length_bytes) $bytes + append conn(pdu,received) $bytes + return + } + "eof" { + CleanupWaitingMessages $handle + catch {close $conn(sock)} + set conn(lastError) "Server closed connection" + return + } + default { + CleanupWaitingMessages $handle + set conn(lastError) [format \ + "Error reading LENGTH2 response for handle %s : %s" $handle $code] + return + } + } + } + } else { + # we know nothing, need to read the first length byte + foreach {code bytes} [ReceiveBytes $conn(sock) 1] {break} + switch -- $code { + "ok" { + set conn(pdu,length_bytes) $bytes + binary scan $bytes c byte + set size [expr {($byte + 0x100) % 0x100}] + if {$size > 0x080} { + set conn(pdu,length) [expr {-1* ($size & 0x7f)}] + # fetch the rest with the next fileevent + return + } else { + asnGetLength conn(pdu,length_bytes) conn(pdu,length) + } + } + "eof" { + CleanupWaitingMessages $handle + catch {close $conn(sock)} + set conn(lastError) "Server closed connection" + } + default { + CleanupWaitingMessages $handle + set conn(lastError) [format \ + "Error reading LENGTH1 response for handle %s : %s" $handle $code] + return + } + } + } + } + + if {[::info exists conn(pdu,payload)]} { + # length is decoded, we can read the rest + set missing [expr {$conn(pdu,length) - [string length $conn(pdu,payload)]}] + } else { + set missing $conn(pdu,length) + } + if {$missing > 0} { + foreach {code bytes} [ReceiveBytes $conn(sock) $missing] {break} + switch -- $code { + "ok" { + append conn(pdu,payload) $bytes + } + "partial" { + append conn(pdu,payload) $bytes + return + } + "eof" { + CleanupWaitingMessages $handle + catch {close $conn(sock)} + set conn(lastError) "Server closed connection" + } + default { + CleanupWaitingMessages $handle + set conn(lastError) [format \ + "Error reading DATA response for handle %s : %s" $handle $code] + return + } + } + } + + # we have a complete PDU, push it for processing + set pdu $conn(pdu,payload) + set conn(pdu,payload) "" + set conn(pdu,partial) 0 + unset -nocomplain set conn(pdu,length) + set conn(pdu,length_bytes) "" + + # reschedule message Processing + after 0 [list ::ldap::ProcessMessage $handle $pdu] +} + +#------------------------------------------------------------------------------- +# Receive the number of bytes from the socket and signal error conditions. +# +#------------------------------------------------------------------------------- +proc ldap::ReceiveBytes {sock bytes} { + set status [catch {read $sock $bytes} block] + if { $status != 0 } { + return [list error $block] + } elseif { [string length $block] == $bytes } { + # we have all bytes we wanted + return [list ok $block] + } elseif { [eof $sock] } { + return [list eof $block] + } elseif { [fblocked $sock] || ([string length $block] < $bytes)} { + return [list partial $block] + } else { + error "Socket state for socket $sock undefined!" + } +} + +#----------------------------------------------------------------------------- +# bindSASL - does a bind with SASL authentication +#----------------------------------------------------------------------------- + +proc ldap::bindSASL {handle {name ""} {password ""} } { + CheckHandle $handle + + package require SASL + + upvar #0 $handle conn + + set mechs [ldap::Saslmechanisms $handle] + + set conn(saslBindInProgress) 1 + set auth 0 + foreach mech [SASL::mechanisms] { + if {[lsearch -exact $mechs $mech] == -1} { continue } + trace "Using $mech for SASL Auth" + if {[catch { + SASLAuth $handle $mech $name $password + } msg]} { + trace [format "AUTH %s failed: %s" $mech $msg] + } else { + # AUTH was successful + if {$msg == 1} { + set auth 1 + break + } + } + } + + set conn(saslBindInProgress) 0 + return $auth +} + +#----------------------------------------------------------------------------- +# SASLCallback - Callback to use for SASL authentication +# +# More or less cut and copied from the smtp module. +# May need adjustments for ldap. +# +#----------------------------------------------------------------------------- +proc ::ldap::SASLCallback {handle context command args} { + upvar #0 $handle conn + upvar #0 $context ctx + array set options $conn(options) + trace "SASLCallback $command" + switch -exact -- $command { + login { return $options(-username) } + username { return $options(-username) } + password { return $options(-password) } + hostname { return [::info hostname] } + realm { + if {[string equal $ctx(mech) "NTLM"] \ + && [info exists ::env(USERDOMAIN)]} { + return $::env(USERDOMAIN) + } else { + return "" + } + } + default { + return -code error "error: unsupported SASL information requested" + } + } +} + +#----------------------------------------------------------------------------- +# SASLAuth - Handles the actual SASL message exchange +# +#----------------------------------------------------------------------------- + +proc ldap::SASLAuth {handle mech name password} { + upvar 1 $handle conn + + set conn(options) [list -password $password -username $name] + + # check for tcllib bug # 1545306 and reset the nonce-count if + # found, so a second call to this code does not fail + # + if {[::info exists ::SASL::digest_md5_noncecount]} { + set ::SASL::digest_md5_noncecount 0 + } + + set ctx [SASL::new -mechanism $mech \ + -service ldap \ + -callback [list ::ldap::SASLCallback $handle]] + + set msg(serverSASLCreds) "" + # Do the SASL Message exchanges + while {[SASL::step $ctx $msg(serverSASLCreds)]} { + # Create and send the BindRequest + set request [buildSASLBindRequest "" $mech [SASL::response $ctx]] + set messageId [SendMessage $handle $request] + debugData bindRequest $request + + set response [WaitForResponse $handle $messageId] + FinalizeMessage $handle $messageId + debugData bindResponse $response + + array set msg [decodeSASLBindResponse $handle $response] + + # Check for Bind success + if {$msg(resultCode) == 0} { + set conn(bound) 1 + set conn(bounduser) $name + SASL::cleanup $ctx + break + } + + # Check if next SASL step is requested + if {$msg(resultCode) == 14} { + continue + } + + SASL::cleanup $ctx + # Something went wrong + return -code error \ + -errorcode [list LDAP [resultCode2String $msg(resultCode)] \ + $msg(matchedDN) $msg(errorMessage)] \ + "LDAP error [resultCode2String $msg(resultCode)] '$msg(matchedDN)': $msg(errorMessage)" + } + + return 1 +} + +#---------------------------------------------------------------------------- +# +# Create a LDAP BindRequest using SASL +# +#---------------------------------------------------------------------------- + +proc ldap::buildSASLBindRequest {name mech {credentials {}}} { + if {$credentials ne {}} { + set request [ asnApplicationConstr 0 \ + [asnInteger 3] \ + [asnOctetString $name] \ + [asnChoiceConstr 3 \ + [asnOctetString $mech] \ + [asnOctetString $credentials] \ + ] \ + ] + } else { + set request [ asnApplicationConstr 0 \ + [asnInteger 3] \ + [asnOctetString $name] \ + [asnChoiceConstr 3 \ + [asnOctetString $mech] \ + ] \ + ] + } + return $request +} + +#------------------------------------------------------------------------------- +# +# Decode an LDAP BindResponse +# +#------------------------------------------------------------------------------- +proc ldap::decodeSASLBindResponse {handle response} { + upvar #0 $handle conn + + asnGetApplication response appNum + if { $appNum != 1 } { + error "unexpected application number ($appNum != 1)" + } + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + + # Check if we have a serverSASLCreds field left, + # or if this is a simple response without it + # probably an error message then. + if {[string length $response]} { + asnRetag response 0x04 + asnGetOctetString response serverSASLCreds + } else { + set serverSASLCreds "" + } + return [list appNum $appNum \ + resultCode $resultCode matchedDN $matchedDN \ + errorMessage $errorMessage serverSASLCreds $serverSASLCreds] +} + + +#----------------------------------------------------------------------------- +# bind - does a bind with simple authentication +# +#----------------------------------------------------------------------------- +proc ldap::bind { handle {name ""} {password ""} } { + CheckHandle $handle + + upvar #0 $handle conn + + #----------------------------------------------------------------- + # marshal bind request packet and send it + # + #----------------------------------------------------------------- + set request [asnApplicationConstr 0 \ + [asnInteger 3] \ + [asnOctetString $name] \ + [asnChoice 0 $password] \ + ] + set messageId [SendMessage $handle $request] + debugData bindRequest $request + + set response [WaitForResponse $handle $messageId] + FinalizeMessage $handle $messageId + debugData bindResponse $response + + asnGetApplication response appNum + if { $appNum != 1 } { + error "unexpected application number ($appNum != 1)" + } + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + } + set conn(bound) 1 + set conn(bounduser) $name +} + + +#----------------------------------------------------------------------------- +# unbind +# +#----------------------------------------------------------------------------- +proc ldap::unbind { handle } { + CheckHandle $handle + + upvar #0 $handle conn + + #------------------------------------------------ + # marshal unbind request packet and send it + #------------------------------------------------ + set request [asnApplication 2 ""] + SendMessageNoReply $handle $request + + set conn(bounduser) "" + set conn(bound) 0 + close $conn(sock) + set conn(sock) "" +} + + +#----------------------------------------------------------------------------- +# search - performs a LDAP search below the baseObject tree using a +# complex LDAP search expression (like "|(cn=Linus*)(sn=Torvalds*)" +# and returns all matching objects (DNs) with given attributes +# (or all attributes if empty list is given) as list: +# +# {dn1 { attr1 {val11 val12 ...} attr2 {val21 val22 ... } ... }} {dn2 { ... }} ... +# +#----------------------------------------------------------------------------- +proc ldap::search { handle baseObject filterString attributes args} { + CheckHandle $handle + + upvar #0 $handle conn + + searchInit $handle $baseObject $filterString $attributes $args + + set results {} + set lastPacket 0 + while { !$lastPacket } { + + set r [searchNext $handle] + if {[llength $r] > 0} then { + lappend results $r + } else { + set lastPacket 1 + } + } + searchEnd $handle + + return $results +} +#----------------------------------------------------------------------------- +# searchInProgress - checks if a search is in progress +# +#----------------------------------------------------------------------------- + +proc ldap::searchInProgress {handle} { + CheckHandle $handle + upvar #0 $handle conn + if {[::info exists conn(searchInProgress)]} { + return $conn(searchInProgress) + } else { + return 0 + } +} + +#----------------------------------------------------------------------------- +# searchInit - initiates an LDAP search +# +#----------------------------------------------------------------------------- +proc ldap::searchInit { handle baseObject filterString attributes opt} { + CheckHandle $handle + + upvar #0 $handle conn + + if {[searchInProgress $handle]} { + return -code error \ + "Cannot start search. Already a search in progress for this handle." + } + + set scope 2 + set derefAliases 0 + set sizeLimit 0 + set timeLimit 0 + set attrsOnly 0 + + foreach {key value} $opt { + switch -- [string tolower $key] { + -scope { + switch -- $value { + base { set scope 0 } + one - onelevel { set scope 1 } + sub - subtree { set scope 2 } + default { } + } + } + -derefaliases { + switch -- $value { + never { set derefAliases 0 } + search { set derefAliases 1 } + find { set derefAliases 2 } + always { set derefAliases 3 } + default { } + } + } + -sizelimit { + set sizeLimit $value + } + -timelimit { + set timeLimit $value + } + -attrsonly { + set attrsOnly $value + } + -referencevar { + set referenceVar $value + } + default { + return -code error \ + "Invalid search option '$key'" + } + } + } + + set request [buildSearchRequest $baseObject $scope \ + $derefAliases $sizeLimit $timeLimit $attrsOnly $filterString \ + $attributes] + set messageId [SendMessage $handle $request] + debugData searchRequest $request + + # Keep the message Id, so we know about the search + set conn(searchInProgress) $messageId + if {[::info exists referenceVar]} { + set conn(referenceVar) $referenceVar + set $referenceVar [list] + } + + return $conn(searchInProgress) +} + +proc ldap::buildSearchRequest {baseObject scope derefAliases + sizeLimit timeLimit attrsOnly filterString + attributes} { + #---------------------------------------------------------- + # marshal filter and attributes parameter + #---------------------------------------------------------- + set berFilter [filter::encode $filterString] + + set berAttributes "" + foreach attribute $attributes { + append berAttributes [asnOctetString $attribute] + } + + #---------------------------------------------------------- + # marshal search request packet and send it + #---------------------------------------------------------- + set request [asnApplicationConstr 3 \ + [asnOctetString $baseObject] \ + [asnEnumeration $scope] \ + [asnEnumeration $derefAliases] \ + [asnInteger $sizeLimit] \ + [asnInteger $timeLimit] \ + [asnBoolean $attrsOnly] \ + $berFilter \ + [asnSequence $berAttributes] \ + ] + +} +#----------------------------------------------------------------------------- +# searchNext - returns the next result of an LDAP search +# +#----------------------------------------------------------------------------- +proc ldap::searchNext { handle } { + CheckHandle $handle + + upvar #0 $handle conn + + if {! [::info exists conn(searchInProgress)]} then { + return -code error \ + "No search in progress" + } + + set result {} + set lastPacket 0 + + #---------------------------------------------------------- + # Wait for a search response packet + #---------------------------------------------------------- + + set response [WaitForResponse $handle $conn(searchInProgress)] + debugData searchResponse $response + + asnGetApplication response appNum + + if {$appNum == 4} { + trace "Search Response Continue" + #---------------------------------------------------------- + # unmarshal search data packet + #---------------------------------------------------------- + asnGetOctetString response objectName + asnGetSequence response attributes + set result_attributes {} + while { [string length $attributes] != 0 } { + asnGetSequence attributes attribute + asnGetOctetString attribute attrType + asnGetSet attribute attrValues + set result_attrValues {} + while { [string length $attrValues] != 0 } { + asnGetOctetString attrValues attrValue + lappend result_attrValues $attrValue + } + lappend result_attributes $attrType $result_attrValues + } + set result [list $objectName $result_attributes] + } elseif {$appNum == 5} { + trace "Search Response Done" + #---------------------------------------------------------- + # unmarshal search final response packet + #---------------------------------------------------------- + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + set result {} + FinalizeMessage $handle $conn(searchInProgress) + unset conn(searchInProgress) + + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] : $errorMessage" + } + } elseif {$appNum == 19} { + trace "Search Result Reference" + #--------------------------------------------------------- + # unmarshall search result reference packet + #--------------------------------------------------------- + + # This should be a sequence but Microsoft AD sends just + # a URI encoded as an OctetString, so have a peek at the tag + # and go on. + + asnPeekTag response tag type constr + if {$tag == 0x04} { + set references $response + } elseif {$tag == 0x030} { + asnGetSequence response references + } + + set urls {} + while {[string length $references]} { + asnGetOctetString references url + lappend urls $url + } + if {[::info exists conn(referenceVar)]} { + upvar 0 conn(referenceVar) refs + if {[llength $refs]} { + set refs [concat [set $refs $urls]] + } else { + set refs $urls + } + } + + # Get the next search result instead + set result [searchNext $handle] + } + + # Unknown application type of result set. + # We should just ignore it since the only PDU the server + # MUST return if it understood our request is the "search response + # done" (apptype 5) which we know how to process. + + return $result +} + +#----------------------------------------------------------------------------- +# searchEnd - end an LDAP search +# +#----------------------------------------------------------------------------- +proc ldap::searchEnd { handle } { + CheckHandle $handle + + upvar #0 $handle conn + + if {! [::info exists conn(searchInProgress)]} then { + # no harm done, just do nothing + return + } + abandon $handle $conn(searchInProgress) + FinalizeMessage $handle $conn(searchInProgress) + + unset conn(searchInProgress) + unset -nocomplain conn(referenceVar) + return +} + +#----------------------------------------------------------------------------- +# +# Send an LDAP abandon message +# +#----------------------------------------------------------------------------- +proc ldap::abandon {handle messageId} { + CheckHandle $handle + + upvar #0 $handle conn + trace "MessagesPending: [string length $conn(messageId)]" + set request [asnApplication 16 \ + [asnInteger $messageId] \ + ] + SendMessageNoReply $handle $request +} + +#----------------------------------------------------------------------------- +# modify - provides attribute modifications on one single object (DN): +# o replace attributes with new values +# o delete attributes (having certain values) +# o add attributes with new values +# +#----------------------------------------------------------------------------- +proc ldap::modify { handle dn + attrValToReplace { attrToDelete {} } { attrValToAdd {} } } { + + CheckHandle $handle + + upvar #0 $handle conn + + set lrep {} + foreach {attr value} $attrValToReplace { + lappend lrep $attr [list $value] + } + + set ldel {} + foreach {attr value} $attrToDelete { + if {[string equal $value ""]} then { + lappend ldel $attr {} + } else { + lappend ldel $attr [list $value] + } + } + + set ladd {} + foreach {attr value} $attrValToAdd { + lappend ladd $attr [list $value] + } + + modifyMulti $handle $dn $lrep $ldel $ladd +} + + +#----------------------------------------------------------------------------- +# modify - provides attribute modifications on one single object (DN): +# o replace attributes with new values +# o delete attributes (having certain values) +# o add attributes with new values +# +#----------------------------------------------------------------------------- +proc ldap::modifyMulti {handle dn + attrValToReplace {attrValToDelete {}} {attrValToAdd {}}} { + + CheckHandle $handle + upvar #0 $handle conn + + set operationAdd 0 + set operationDelete 1 + set operationReplace 2 + + set modifications "" + + #------------------------------------------------------------------ + # marshal attribute modify operations + # - always mode 'replace' ! see rfc2251: + # + # replace: replace all existing values of the given attribute + # with the new values listed, creating the attribute if it + # did not already exist. A replace with no value will delete + # the entire attribute if it exists, and is ignored if the + # attribute does not exist. + # + #------------------------------------------------------------------ + append modifications [ldap::packOpAttrVal $operationReplace \ + $attrValToReplace] + + #------------------------------------------------------------------ + # marshal attribute add operations + # + #------------------------------------------------------------------ + append modifications [ldap::packOpAttrVal $operationAdd \ + $attrValToAdd] + + #------------------------------------------------------------------ + # marshal attribute delete operations + # + # - a non-empty value will trigger to delete only those + # attributes which have the same value as the given one + # + # - an empty value will trigger to delete the attribute + # in all cases + # + #------------------------------------------------------------------ + append modifications [ldap::packOpAttrVal $operationDelete \ + $attrValToDelete] + + #---------------------------------------------------------- + # marshal 'modify' request packet and send it + #---------------------------------------------------------- + set request [asnApplicationConstr 6 \ + [asnOctetString $dn ] \ + [asnSequence $modifications ] \ + ] + set messageId [SendMessage $handle $request] + debugData modifyRequest $request + set response [WaitForResponse $handle $messageId] + FinalizeMessage $handle $messageId + debugData bindResponse $response + + asnGetApplication response appNum + if { $appNum != 7 } { + error "unexpected application number ($appNum != 7)" + } + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + } +} + +proc ldap::packOpAttrVal {op attrValueTuples} { + set p "" + foreach {attrName attrValues} $attrValueTuples { + set l {} + foreach v $attrValues { + lappend l [asnOctetString $v] + } + append p [asnSequence \ + [asnEnumeration $op ] \ + [asnSequence \ + [asnOctetString $attrName ] \ + [asnSetFromList $l] \ + ] \ + ] + } + return $p +} + + +#----------------------------------------------------------------------------- +# add - will create a new object using given DN and sets the given +# attributes. Multiple value attributes may be used, provided +# that each attr-val pair be listed. +# +#----------------------------------------------------------------------------- +proc ldap::add { handle dn attrValueTuples } { + + CheckHandle $handle + + # + # In order to handle multi-valuated attributes (see bug 1191326 on + # sourceforge), we walk through tuples to collect all values for + # an attribute. + # http://core.tcl.tk/tcllib/tktview?name=1191326fff + # + + foreach { attrName attrValue } $attrValueTuples { + lappend avpairs($attrName) $attrValue + } + + return [addMulti $handle $dn [array get avpairs]] +} + +#----------------------------------------------------------------------------- +# addMulti - will create a new object using given DN and sets the given +# attributes. Argument is a list of attr-listOfVals pair. +# +#----------------------------------------------------------------------------- +proc ldap::addMulti { handle dn attrValueTuples } { + + CheckHandle $handle + + upvar #0 $handle conn + + #------------------------------------------------------------------ + # marshal attribute list + # + #------------------------------------------------------------------ + set attrList "" + + foreach { attrName attrValues } $attrValueTuples { + set valList {} + foreach val $attrValues { + lappend valList [asnOctetString $val] + } + append attrList [asnSequence \ + [asnOctetString $attrName ] \ + [asnSetFromList $valList] \ + ] + } + + #---------------------------------------------------------- + # marshal search 'add' request packet and send it + #---------------------------------------------------------- + set request [asnApplicationConstr 8 \ + [asnOctetString $dn ] \ + [asnSequence $attrList ] \ + ] + + set messageId [SendMessage $handle $request] + debugData addRequest $request + set response [WaitForResponse $handle $messageId] + FinalizeMessage $handle $messageId + debugData bindResponse $response + + asnGetApplication response appNum + if { $appNum != 9 } { + error "unexpected application number ($appNum != 9)" + } + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + } +} + +#----------------------------------------------------------------------------- +# delete - removes the whole object (DN) inclusive all attributes +# +#----------------------------------------------------------------------------- +proc ldap::delete { handle dn } { + + CheckHandle $handle + + upvar #0 $handle conn + + #---------------------------------------------------------- + # marshal 'delete' request packet and send it + #---------------------------------------------------------- + set request [asnApplication 10 $dn ] + set messageId [SendMessage $handle $request] + debugData deleteRequest $request + set response [WaitForResponse $handle $messageId] + FinalizeMessage $handle $messageId + + debugData deleteResponse $response + + asnGetApplication response appNum + if { $appNum != 11 } { + error "unexpected application number ($appNum != 11)" + } + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + } +} + + +#----------------------------------------------------------------------------- +# modifyDN - moves an object (DN) to another (relative) place +# +#----------------------------------------------------------------------------- +proc ldap::modifyDN { handle dn newrdn { deleteOld 1 } {newSuperior ! } } { + + CheckHandle $handle + + upvar #0 $handle conn + + #---------------------------------------------------------- + # marshal 'modifyDN' request packet and send it + #---------------------------------------------------------- + + if {[string equal $newSuperior "!"]} then { + set request [asnApplicationConstr 12 \ + [asnOctetString $dn ] \ + [asnOctetString $newrdn ] \ + [asnBoolean $deleteOld ] \ + ] + + } else { + set request [asnApplicationConstr 12 \ + [asnOctetString $dn ] \ + [asnOctetString $newrdn ] \ + [asnBoolean $deleteOld ] \ + [asnContext 0 $newSuperior] \ + ] + } + set messageId [SendMessage $handle $request] + debugData modifyRequest $request + set response [WaitForResponse $handle $messageId] + + asnGetApplication response appNum + if { $appNum != 13 } { + error "unexpected application number ($appNum != 13)" + } + asnGetEnumeration response resultCode + asnGetOctetString response matchedDN + asnGetOctetString response errorMessage + if {$resultCode != 0} { + return -code error \ + -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \ + "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage" + + } +} + +#----------------------------------------------------------------------------- +# disconnect +# +#----------------------------------------------------------------------------- +proc ldap::disconnect { handle } { + + CheckHandle $handle + + upvar #0 $handle conn + + # should we sent an 'unbind' ? + catch {close $conn(sock)} + unset conn + + return +} + + + +#----------------------------------------------------------------------------- +# trace +# +#----------------------------------------------------------------------------- +proc ldap::trace { message } { + + variable doDebug + + if {!$doDebug} return + + puts stderr $message +} + + +#----------------------------------------------------------------------------- +# debugData +# +#----------------------------------------------------------------------------- +proc ldap::debugData { info data } { + + variable doDebug + + if {!$doDebug} return + + set len [string length $data] + trace "$info ($len bytes):" + set address "" + set hexnums "" + set ascii "" + for {set i 0} {$i < $len} {incr i} { + set v [string index $data $i] + binary scan $v H2 hex + binary scan $v c num + set num [expr {( $num + 0x100 ) % 0x100}] + set text . + if {$num > 31} { + set text $v + } + if { ($i % 16) == 0 } { + if {$address != ""} { + trace [format "%4s %-48s |%s|" $address $hexnums $ascii ] + set address "" + set hexnums "" + set ascii "" + } + append address [format "%04d" $i] + } + append hexnums "$hex " + append ascii $text + #trace [format "%3d %2s %s" $i $hex $text] + } + if {$address != ""} { + trace [format "%4s %-48s |%s|" $address $hexnums $ascii ] + } + trace "" +} + +#----------------------------------------------------------------------------- +# ldap::filter -- set of procedures for construction of BER-encoded +# data defined by ASN.1 type Filter described in RFC 4511 +# from string representations of search filters +# defined in RFC 4515. +#----------------------------------------------------------------------------- +namespace eval ldap::filter { + # Regexp which matches strings of type AttribyteType: + variable reatype {[A-Za-z][A-Za-z0-9-]*|\d+(?:\.\d+)+} + + # Regexp which matches attribute options in strings + # of type AttributeDescription: + variable reaopts {(?:;[A-Za-z0-9-]+)*} + + # Regexp which matches strings of type AttributeDescription. + # Note that this regexp captures attribute options, + # with leading ";", if any. + variable readesc (?:$reatype)($reaopts) + + # Two regexps to match strings representing "left hand side" (LHS) + # in extensible match assertion. + # In fact there could be one regexp with two alterations, + # but this would complicate capturing of regexp parts. + # The first regexp captures, in this order: + # 1. Attribute description. + # 2. Attribute options. + # 3. ":dn" string, indicating "Use DN attribute types" flag. + # 4. Matching rule ID. + # The second regexp captures, in this order: + # 1. ":dn" string. + # 2. Matching rule ID. + variable reaextmatch1 ^($readesc)(:dn)?(?::($reatype))?\$ + variable reaextmatch2 ^(:dn)?:($reatype)\$ + + # The only validation proc using this regexp requires it to be + # anchored to the boundaries of a string being validated, + # so we change it here to allow this regexp to be compiled: + set readesc ^$readesc\$ + + unset reatype reaopts + + namespace import ::asn::* +} + +# "Public API" function. +# Parses the string represntation of an LDAP search filter expression +# and returns its BER-encoded form. +# NOTE While RFC 4515 strictly defines that any filter expression must +# be surrounded by parentheses it is customary for LDAP client software +# to allow specification of simple (i.e. non-compound) filter expressions +# without enclosing parentheses, so we also do this (in fact, we allow +# omission of outermost parentheses in any filter expression). +proc ldap::filter::encode s { + if {[string match (*) $s]} { + ProcessFilter $s + } else { + ProcessFilterComp $s + } +} + +# Parses the string represntation of an LDAP search filter expression +# and returns its BER-encoded form. +proc ldap::filter::ProcessFilter s { + if {![string match (*) $s]} { + return -code error "Invalid filter: filter expression must be\ + surrounded by parentheses" + } + ProcessFilterComp [string range $s 1 end-1] +} + +# Parses "internals" of a filter expression, i.e. what's contained +# between its enclosing parentheses. +# It classifies the type of filter expression (compound, negated or +# simple) and invokes its corresponding handler. +# Returns a BER-encoded form of the filter expression. +proc ldap::filter::ProcessFilterComp s { + switch -- [string index $s 0] { + & { + ProcessFilterList 0 [string range $s 1 end] + } + | { + ProcessFilterList 1 [string range $s 1 end] + } + ! { + ProcessNegatedFilter [string range $s 1 end] + } + default { + ProcessMatch $s + } + } +} + +# Parses string $s containing a chain of one or more filter +# expressions (as found in compound filter expressions), +# processes each filter in such chain and returns +# a BER-encoded form of this chain tagged with specified +# application type given as $apptype. +proc ldap::filter::ProcessFilterList {apptype s} { + set data "" + set rest $s + while 1 { + foreach {filter rest} [ExtractFilter $rest] break + append data [ProcessFilter $filter] + if {$rest == ""} break + } + # TODO looks like it's impossible to hit this condition + if {[string length $data] == 0} { + return -code error "Invalid filter: filter composition must\ + consist of at least one element" + } + asnChoiceConstr $apptype $data +} + +# Parses a string $s representing a filter expression +# and returns a BER construction representing negation +# of that filter expression. +proc ldap::filter::ProcessNegatedFilter s { + asnChoiceConstr 2 [ProcessFilter $s] +} + +# Parses a string $s representing an "attribute matching rule" +# (i.e. the contents of a non-compound filter expression) +# and returns its BER-encoded form. +proc ldap::filter::ProcessMatch s { + if {![regexp -indices {(=|~=|>=|<=|:=)} $s range]} { + return -code error "Invalid filter: no match operator in item" + } + foreach {a z} $range break + set lhs [string range $s 0 [expr {$a - 1}]] + set match [string range $s $a $z] + set val [string range $s [expr {$z + 1}] end] + + switch -- $match { + = { + if {$val eq "*"} { + ProcessPresenceMatch $lhs + } else { + if {[regexp {^([^*]*)(\*(?:[^*]*\*)*)([^*]*)$} $val \ + -> initial any final]} { + ProcessSubstringMatch $lhs $initial $any $final + } else { + ProcessSimpleMatch 3 $lhs $val + } + } + } + >= { + ProcessSimpleMatch 5 $lhs $val + } + <= { + ProcessSimpleMatch 6 $lhs $val + } + ~= { + ProcessSimpleMatch 8 $lhs $val + } + := { + ProcessExtensibleMatch $lhs $val + } + } +} + +# From a string $s, containing a chain of filter +# expressions (as found in compound filter expressions) +# extracts the first filter expression and returns +# a two element list composed of the extracted filter +# expression and the remainder of the source string. +proc ldap::filter::ExtractFilter s { + if {[string index $s 0] ne "("} { + return -code error "Invalid filter: malformed compound filter expression" + } + set pos 1 + set nopen 1 + while 1 { + if {![regexp -indices -start $pos {\)|\(} $s match]} { + return -code error "Invalid filter: unbalanced parenthesis" + } + set pos [lindex $match 0] + if {[string index $s $pos] eq "("} { + incr nopen + } else { + incr nopen -1 + } + if {$nopen == 0} { + return [list [string range $s 0 $pos] \ + [string range $s [incr pos] end]] + } + incr pos + } +} + +# Constructs a BER-encoded form of a "presence" match +# involving an attribute description string passed in $attrdesc. +proc ldap::filter::ProcessPresenceMatch attrdesc { + ValidateAttributeDescription $attrdesc options + asnChoice 7 [LDAPString $attrdesc] +} + +# Constructs a BER-encoded form of a simple match designated +# by application type $apptype and involving an attribute +# description $attrdesc and attribute value $val. +# "Simple" match is one of: equal, less or equal, greater +# or equal, approximate. +proc ldap::filter::ProcessSimpleMatch {apptype attrdesc val} { + ValidateAttributeDescription $attrdesc options + append data [asnOctetString [LDAPString $attrdesc]] \ + [asnOctetString [AssertionValue $val]] + asnChoiceConstr $apptype $data +} + +# Constructs a BER-encoded form of a substrings match +# involving an attribute description $attrdesc and parts of attribute +# value -- $initial, $any and $final. +# A string contained in any may be compound -- several strings +# concatenated by asterisks ("*"), they are extracted and used as +# multiple attribute value parts of type "any". +proc ldap::filter::ProcessSubstringMatch {attrdesc initial any final} { + ValidateAttributeDescription $attrdesc options + + set data [asnOctetString [LDAPString $attrdesc]] + + set seq [list] + set parts 0 + if {$initial != ""} { + lappend seq [asnChoice 0 [AssertionValue $initial]] + incr parts + } + + foreach v [split [string trim $any *] *] { + if {$v != ""} { + lappend seq [asnChoice 1 [AssertionValue $v]] + incr parts + } + } + + if {$final != ""} { + lappend seq [asnChoice 2 [AssertionValue $final]] + incr parts + } + + if {$parts == 0} { + return -code error "Invalid filter: substrings match parses to zero parts" + } + + append data [asnSequenceFromList $seq] + + asnChoiceConstr 4 $data +} + +# Constructs a BER-encoded form of an extensible match +# involving an attribute value given in $value and a string +# containing the matching rule OID, if present a "Use DN attribute +# types" flag, if present, and an atttibute description, if present, +# given in $lhs (stands for "Left Hand Side"). +proc ldap::filter::ProcessExtensibleMatch {lhs value} { + ParseExtMatchLHS $lhs attrdesc options dn ruleid + set data "" + foreach {apptype val} [list 1 $ruleid 2 $attrdesc] { + if {$val != ""} { + append data [asnChoice $apptype [LDAPString $val]] + } + } + append data [asnChoice 3 [AssertionValue $value]] + if {$dn} { + # [asnRetag] is broken in asn, so we use the trick + # to simulate "boolean true" BER-encoding which + # is octet 1 of length 1: + append data [asnChoice 4 [binary format cc 1 1]] + } + asnChoiceConstr 9 $data +} + +# Parses a string $s, representing a "left hand side" of an extensible match +# expression, into several parts: attribute desctiption, options, +# "Use DN attribute types" flag and rule OID. These parts are +# assigned to corresponding variables in the caller's scope. +proc ldap::filter::ParseExtMatchLHS {s attrdescVar optionsVar dnVar ruleidVar} { + upvar 1 $attrdescVar attrdesc $optionsVar options $dnVar dn $ruleidVar ruleid + variable reaextmatch1 + variable reaextmatch2 + if {[regexp $reaextmatch1 $s -> attrdesc opts dnstr ruleid]} { + set options [ProcessAttrTypeOptions $opts] + set dn [expr {$dnstr != ""}] + } elseif {[regexp $reaextmatch2 $s -> dnstr ruleid]} { + set attrdesc "" + set options [list] + set dn [expr {$dnstr != ""}] + } else { + return -code error "Invalid filter: malformed attribute description" + } +} + +# Validates an attribute description passed as $attrdesc. +# Raises an error if it's ill-formed. +# Variable in the caller's scope whose name is passed in optionsVar +# is set to a list of attribute options (which may be empty if +# there's no options in the attribute type). +proc ldap::filter::ValidateAttributeDescription {attrdesc optionsVar} { + variable readesc + if {![regexp $readesc $attrdesc -> opts]} { + return -code error "Invalid filter: malformed attribute description" + } + upvar 1 $optionsVar options + set options [ProcessAttrTypeOptions $opts] + return +} + +# Parses a string $s containing one or more attribute +# options, delimited by seimcolons, with the leading semicolon, +# if non-empty. +# Returns a list of distinct options, lowercased for normalization +# purposes. +proc ldap::filter::ProcessAttrTypeOptions s { + set opts [list] + foreach opt [split [string trimleft $s \;] \;] { + lappend opts [string tolower $opt] + } + set opts +} + +# Checks an assertion value $s for validity and substitutes +# any backslash escapes in it with their respective values. +# Returns canonical form of the attribute value +# ready to be packed into a BER-encoded stream. +proc ldap::filter::AssertionValue s { + set v [encoding convertto utf-8 $s] + if {[regexp {\\(?:[[:xdigit:]])?(?![[:xdigit:]])|[()*\0]} $v]} { + return -code error "Invalid filter: malformed assertion value" + } + + variable escmap + if {![info exists escmap]} { + for {set i 0} {$i <= 0xff} {incr i} { + lappend escmap [format {\%02x} $i] [format %c $i] + } + } + string map -nocase $escmap $v +} + +# Turns a given Tcl string $s into a binary blob ready to be packed +# into a BER-encoded stream. +proc ldap::filter::LDAPString s { + encoding convertto utf-8 $s +} + +# vim:ts=8:sw=4:sts=4:noet diff --git a/tcllib/modules/ldap/ldap.test b/tcllib/modules/ldap/ldap.test new file mode 100644 index 0000000..34c713c --- /dev/null +++ b/tcllib/modules/ldap/ldap.test @@ -0,0 +1,928 @@ +# ldap.test - Copyright (C) 2006 Michael Schlenker <mic42@user.sourceforge.net> +# +# Tests for the Tcllib ldap package +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- +# RCS: @(#) $Id: ldap.test,v 1.5 2008/07/20 19:50:55 mic42 Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 2.0 + +testing { + useLocal ldap.tcl ldap + useLocal ../asn/asn.tcl asn +} + + +namespace import ::asn::* + +# ------------------------------------------------------------------------- +# Tests +# ------------------------------------------------------------------------- + +test ldap-2.0 {check info ip subcommand error handling +} -body { + ldap::info ip +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info ip handle} + +test ldap-2.1 {check info ip subcommand error handling +} -body { + ldap::info ip foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-3.0 {check info connections subcommand error handling +} -body { + ldap::info connections foo +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info connections} + +test ldap-4.0 {check info bound subcommand error handling +} -body { + ldap::info bound +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info bound handle} + +test ldap-4.1 {check info bound subcommand error handling +} -body { + ldap::info bound foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-5.0 {check info tls subcommand error handling +} -body { + ldap::info tls +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info tls handle} + +test ldap-5.1 {check info tls subcommand error handling +} -body { + ldap::info tls foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-6.0 {check info bounduser subcommand error handling +} -body { + ldap::info bounduser +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info bounduser handle} + +test ldap-6.1 {check info bounduser subcommand error handling +} -body { + ldap::info bounduser foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-7.0 {check info saslmechanisms subcommand error handling +} -body { + ldap::info saslmechanisms +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info saslmechanisms handle} + +test ldap-7.1 {check info saslmechanisms subcommand error handling +} -body { + ldap::info saslmechanisms foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-8.0 {check info extensions subcommand error handling +} -body { + ldap::info extensions +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info extensions handle} + +test ldap-8.1 {check info extensions subcommand error handling +} -body { + ldap::info extensions foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-9.0 {check info control subcommand error handling +} -body { + ldap::info control +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info control handle} + +test ldap-9.1 {check info control subcommand error handling +} -body { + ldap::info control foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-10.0 {check info features subcommand error handling +} -body { + ldap::info features +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info features handle} + +test ldap-10.1 {check info features subcommand error handling +} -body { + ldap::info features foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-11.0 {check info whoami subcommand error handling +} -body { + ldap::info whoami +} -returnCodes {error} \ + -result {Wrong # of arguments. Usage: ldap::info whoami handle} + +test ldap-11.1 {check info whoami subcommand error handling +} -body { + ldap::info whoami foobar +} -returnCodes {error} \ + -result {Not a valid LDAP connection handle: foobar} + +test ldap-12.0 {check wrong num args for ldap::connect +} -body { + ldap::connect +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs \ + {ldap::connect} {host ?port?} 0] + +test ldap-13.0 {check wrong num args for ldap::secure_connect +} -body { + ldap::secure_connect +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs \ + {ldap::secure_connect} {host ?port?} 0] + +test ldap-14.0 {check wrong num args for ldap::starttls +} -body { + ldap::starttls +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::starttls} \ + {handle ?cafile? ?certfile? ?keyfile?} 0] + +test ldap-15.0 {check wrong num args for ldap::bindSASL +} -body { + ldap::bindSASL +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::bindSASL} {handle ?name? ?password?} 0] + +test ldap-16.0 {check wrong num args for ldap::bind +} -body { + ldap::bind +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::bind} {handle ?name? ?password?} 0] + +test ldap-17.0 {check wrong num args for ldap::unbind +} -body { + ldap::unbind +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::unbind} {handle} 1 ] + +test ldap-18.0 {check wrong num args for ldap::search +} -body { + ldap::search +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::search} \ + {handle baseObject filterString attributes args} 0] + +test ldap-19.0 {check wrong num args for ldap::searchInit +} -body { + ldap::searchInit +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::searchInit} \ + {handle baseObject filterString attributes opt} 0] + +test ldap-20.0 {check wrong num args for ldap::searchNext +} -body { + ldap::searchNext +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::searchNext} {handle} 0 ] + +test ldap-21.0 {check wrong num args for ldap::searchEnd +} -body { + ldap::searchEnd +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::searchEnd} {handle} 0 ] + +test ldap-22.0 {check wrong num args for ldap::modify +} -body { + ldap::modify +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::modify} \ + {handle dn attrValToReplace ?attrToDelete? ?attrValToAdd?} 0 ] + +test ldap-23.0 {check wrong num args for ldap::modifyMulti +} -body { + ldap::modifyMulti +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::modifyMulti} \ + {handle dn attrValToReplace ?attrValToDelete? ?attrValToAdd?} 0 ] + +test ldap-24.0 {check wrong num args for ldap::add +} -body { + ldap::add +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::add} \ + {handle dn attrValueTuples} 0 ] + +test ldap-25.0 {check wrong num args for ldap::addMulti +} -body { + ldap::addMulti +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::addMulti} \ + {handle dn attrValueTuples} 0 ] + +test ldap-26.0 {check wrong num args for ldap::delete +} -body { + ldap::delete +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::delete} \ + {handle dn} 0 ] + +test ldap-27.0 {check wrong num args for ldap::modifyDN +} -body { + ldap::modifyDN +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::modifyDN} \ + {handle dn newrdn ?deleteOld? ?newSuperior?} 0 ] + +test ldap-28.0 {check wrong num args for ldap::disconnect +} -body { + ldap::disconnect +} -returnCodes {error} \ + -result [tcltest::wrongNumArgs {ldap::disconnect} \ + {handle} 0 ] +# ------------------------------------------------------------------------- +# Handling of string representation of filters (RFC 4515): +# ------------------------------------------------------------------------- + +proc glue args { + join $args "" +} + +test filter-0.0 {[glue] should concatenate its string arguments} -body { + glue a b c d \0 foo +} -result abcd\0foo + +test filter-1.0 {LDAPString produces packed UTF-8} -body { + binary scan [ldap::filter::LDAPString \u043a\u0430\u0448\u0430] H* foo + set foo +} -result d0bad0b0d188d0b0 -cleanup { unset foo } + +test filter-1.1 {AssertionValue produces packed UTF-8} -body { + binary scan [ldap::filter::AssertionValue \u043a\u0430\u0448\u0430] H* foo + set foo +} -result d0bad0b0d188d0b0 -cleanup { unset foo } + +test filter-1.2 {AssertionValue produces packed UTF-8 + but allows embedding of arbitrary bytes via escaping} -body { + binary scan [ldap::filter::AssertionValue \u043a\\FF\u0430\\ab\u0448\\de\u0430\\Fe] H* foo + set foo +} -result d0baffd0b0abd188ded0b0fe -cleanup { unset foo } + +test filter-1.3 {LDAPString produces packed UTF-8, all characters pass as is} -body { + binary scan [ldap::filter::LDAPString \u043a\\FF\u0430\\ab\u0448\\de\u0430\\Fe] H* foo + set foo +} -result d0ba5c4646d0b05c6162d1885c6465d0b05c4665 -cleanup { unset foo } + +test filter-2.0 {Backslash escaping in assertion values} -body { + set a "" + set b "" + for {set i 0} {$i <= 255} {incr i} { + append a [format \\%02x $i] ;# lowercase hex + append b [format %c $i] + } + string equal [ldap::filter::AssertionValue $a] $b +} -result 1 -cleanup { unset a b i } + +test filter-2.1 {Backslash escaping in assertion values} -body { + set a "" + set b "" + for {set i 0} {$i <= 255} {incr i} { + append a [format \\%02X $i] ;# uppercase hex + append b [format %c $i] + } + string equal [ldap::filter::AssertionValue $a] $b +} -result 1 -cleanup { unset a b i } + +test filter-3.1 {Malformed backslash escaping in assertion values} -body { + ldap::filter::AssertionValue foo\\0 +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-3.2 {Malformed backslash escaping in assertion values} -body { + ldap::filter::AssertionValue \\foo +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-3.3 {Malformed backslash escaping in assertion values} -body { + ldap::filter::AssertionValue hA\\1x0rz +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-3.4 {Malformed backslash escaping in assertion values} -body { + ldap::filter::AssertionValue \\value +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-3.5 {Malformed backslash escaping in assertion values} -body { + ldap::filter::AssertionValue end\\ +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-4.0 {Presence match} -body { + ldap::filter::encode (Certificates=*) +} -result [asnChoice 7 [ldap::filter::LDAPString Certificates]] + +test filter-4.1 {Presence match + attribute options} -body { + ldap::filter::encode (Certificates\;binary\;X-FooBar=*) +} -result [asnChoice 7 [ldap::filter::LDAPString Certificates\;binary\;X-FooBar]] + +test filter-5.0 {Equality match} -body { + ldap::filter::encode (foo=bar) +} -result [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString foo]] \ + [asnOctetString [ldap::filter::AssertionValue bar]]]] + +test filter-5.1 {Equality match with empty assertion value} -body { + ldap::filter::encode (seeAlso=) +} -result [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString seeAlso]] \ + [asnOctetString [ldap::filter::AssertionValue ""]]]] + +test filter-5.2 {Equality match + attribute options} -body { + ldap::filter::encode (foo\;X-option=bar) +} -result [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString foo\;X-option]] \ + [asnOctetString [ldap::filter::AssertionValue bar]]]] + +test filter-5.3 {Equality match, spaces in assertion value} -body { + ldap::filter::encode {(personName=Jane W. Random)} +} -result [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString personName]] \ + [asnOctetString [ldap::filter::AssertionValue "Jane W. Random"]]]] + +test filter-6.0 {Approx match} -body { + ldap::filter::encode (descr~=val) +} -result [asnChoiceConstr 8 [glue \ + [asnOctetString [ldap::filter::LDAPString descr]] \ + [asnOctetString [ldap::filter::AssertionValue val]]]] + +test filter-6.1 {Approx match with empty assertion value} -body { + ldap::filter::encode (cn~=) +} -result [asnChoiceConstr 8 [glue \ + [asnOctetString [ldap::filter::LDAPString cn]] \ + [asnOctetString [ldap::filter::AssertionValue ""]]]] + +test filter-6.2 {Approx match + attribute options} -body { + ldap::filter::encode (binaryCert\;binary~=0000) +} -result [asnChoiceConstr 8 [glue \ + [asnOctetString [ldap::filter::LDAPString binaryCert\;binary]] \ + [asnOctetString [ldap::filter::AssertionValue 0000]]]] + +test filter-7.0 {Less or equal match} -body { + ldap::filter::encode (attr<=string) +} -result [asnChoiceConstr 6 [glue \ + [asnOctetString [ldap::filter::LDAPString attr]] \ + [asnOctetString [ldap::filter::AssertionValue string]]]] + +test filter-7.1 {Less or equal match with empty assertion value} -body { + ldap::filter::encode (attr<=) +} -result [asnChoiceConstr 6 [glue \ + [asnOctetString [ldap::filter::LDAPString attr]] \ + [asnOctetString [ldap::filter::AssertionValue ""]]]] + +test filter-7.2 {Less or equal match + attribute options} -body { + ldap::filter::encode (binaryCert\;binary<=01234) +} -result [asnChoiceConstr 6 [glue \ + [asnOctetString [ldap::filter::LDAPString binaryCert\;binary]] \ + [asnOctetString [ldap::filter::AssertionValue 01234]]]] + +test filter-8.0 {Greater or equal match} -body { + ldap::filter::encode (one>=two) +} -result [asnChoiceConstr 5 [glue \ + [asnOctetString [ldap::filter::LDAPString one]] \ + [asnOctetString [ldap::filter::AssertionValue two]]]] + +test filter-8.1 {Greater or equal match with empty attribute} -body { + ldap::filter::encode (one>=) +} -result [asnChoiceConstr 5 [glue \ + [asnOctetString [ldap::filter::LDAPString one]] \ + [asnOctetString [ldap::filter::AssertionValue ""]]]] + +test filter-8.2 {Greater or equal match + attribute options} -body { + ldap::filter::encode (exampleAttr\;X-experimental>=value) +} -result [asnChoiceConstr 5 [glue \ + [asnOctetString [ldap::filter::LDAPString exampleAttr\;X-experimental]] \ + [asnOctetString [ldap::filter::AssertionValue value]]]] + +test filter-9.0 {Substrings match: only initial string} -body { + ldap::filter::encode (sAMAccountName=management-*) +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString sAMAccountName]] \ + [asnSequence [asnChoice 0 [ldap::filter::AssertionValue management-]]]]] + +test filter-9.1 {Substrings match: only final string} -body { + ldap::filter::encode (User=*ish) +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString User]] \ + [asnSequence [asnChoice 2 [ldap::filter::AssertionValue ish]]]]] + +test filter-9.2 {Substrings match: initial and final strings} -body { + ldap::filter::encode (OU=F*off) +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString OU]] \ + [asnSequence \ + [asnChoice 0 [ldap::filter::AssertionValue F]] \ + [asnChoice 2 [ldap::filter::AssertionValue off]]]]] + +test filter-9.3 {Substrings match: initial, any and final strings} -body { + ldap::filter::encode (mail=Schlenk*@uni-*.de) +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString mail]] \ + [asnSequence \ + [asnChoice 0 [ldap::filter::AssertionValue Schlenk]] \ + [asnChoice 1 [ldap::filter::AssertionValue @uni-]] \ + [asnChoice 2 [ldap::filter::AssertionValue .de]]]]] + +test filter-9.4 {Substrings match: multiple any strings} -body { + ldap::filter::encode (Something=a*b*c*d*e) +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString Something]] \ + [asnSequence \ + [asnChoice 0 [ldap::filter::AssertionValue a]] \ + [asnChoice 1 [ldap::filter::AssertionValue b]] \ + [asnChoice 1 [ldap::filter::AssertionValue c]] \ + [asnChoice 1 [ldap::filter::AssertionValue d]] \ + [asnChoice 2 [ldap::filter::AssertionValue e]]]]] + +test filter-9.5 {Substrings match: no initial and final strings} -body { + ldap::filter::encode (Whatever=*foo*) +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString Whatever]] \ + [asnSequence \ + [asnChoice 1 [ldap::filter::AssertionValue foo]]]]] + +test filter-9.6 {Substrings match: empty any string prevention} -body { + ldap::filter::encode {(Person=J.Ra***m Hacker)} +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString Person]] \ + [asnSequence \ + [asnChoice 0 [ldap::filter::AssertionValue J.Ra]] \ + [asnChoice 2 [ldap::filter::AssertionValue {m Hacker}]]]]] + +test filter-9.7 {Substrings match: empty any string prevention} -body { + ldap::filter::encode (SomeType=***foo***bar***baz**********) +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString SomeType]] \ + [asnSequence \ + [asnChoice 1 [ldap::filter::AssertionValue foo]] \ + [asnChoice 1 [ldap::filter::AssertionValue bar]] \ + [asnChoice 1 [ldap::filter::AssertionValue baz]]]]] + +test filter-9.8 {Substrings match: parsing to zero parts} -body { + ldap::filter::encode (SomeType=**) +} -returnCodes error -result {Invalid filter: substrings match parses to zero parts} + +test filter-9.10 {Substrings match: parsing to zero parts} -body { + ldap::filter::encode (SomeOtherType=*****) +} -returnCodes error -result {Invalid filter: substrings match parses to zero parts} + +test filter-9.11 {Substrings match: spaces in assertion value} -body { + ldap::filter::encode {(Something=Jane Random*and*J. Random Hacker)} +} -result [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString Something]] \ + [asnSequence \ + [asnChoice 0 [ldap::filter::AssertionValue "Jane Random"]] \ + [asnChoice 1 [ldap::filter::AssertionValue and]] \ + [asnChoice 2 [ldap::filter::AssertionValue "J. Random Hacker"]]]]] + +test filter-10.0 {Extensible match: only attribute description} -body { + ldap::filter::encode (AttrDesc:=10) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \ + [asnChoice 3 [ldap::filter::AssertionValue 10]]]] + +test filter-10.1 {Extensible match: attribute description + matching rule} -body { + ldap::filter::encode (personKind:caseIgnoreMatch:=bad) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString caseIgnoreMatch]] \ + [asnChoice 2 [ldap::filter::LDAPString personKind]] \ + [asnChoice 3 [ldap::filter::AssertionValue bad]]]] + +test filter-10.2 {Extensible match: attribute description + + matching rule in form of numericoid} -body { + ldap::filter::encode (personKind:1.3.6.1.4.1.1466.115.121.1.15:=good) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString 1.3.6.1.4.1.1466.115.121.1.15]] \ + [asnChoice 2 [ldap::filter::LDAPString personKind]] \ + [asnChoice 3 [ldap::filter::AssertionValue good]]]] + +test filter-10.3 {Extensible match: attribute description + DN flag} -body { + ldap::filter::encode (Foobar:dn:=345) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 2 [ldap::filter::LDAPString Foobar]] \ + [asnChoice 3 [ldap::filter::AssertionValue 345]] \ + [asnChoice 4 [binary format cc 1 1]]]] + +test filter-10.4 {Extensible match: attribute description + DN flag + matching rule} -body { + ldap::filter::encode (NamelessOne:dn:caseIgnoreIA5Match:=who) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \ + [asnChoice 2 [ldap::filter::LDAPString NamelessOne]] \ + [asnChoice 3 [ldap::filter::AssertionValue who]] \ + [asnChoice 4 [binary format cc 1 1]]]] + +test filter-10.5 {Extensible match: attribute description + DN flag + + matching rule numericoid} -body { + ldap::filter::encode (OU:dn:111.222.333.444:=test) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString 111.222.333.444]] \ + [asnChoice 2 [ldap::filter::LDAPString OU]] \ + [asnChoice 3 [ldap::filter::AssertionValue test]] \ + [asnChoice 4 [binary format cc 1 1]]]] + +test filter-10.6 {Extensible match: matching rule alone} -body { + ldap::filter::encode (:caseIgnoreIA5Match:=they) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \ + [asnChoice 3 [ldap::filter::AssertionValue they]]]] + +test filter-10.7 {Extensible match: matching rule alone, in form of numericoid} -body { + ldap::filter::encode (:874.274.378.432:=value) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString 874.274.378.432]] \ + [asnChoice 3 [ldap::filter::AssertionValue value]]]] + +test filter-10.8 {Extensible match: matching rule + DN flag} -body { + ldap::filter::encode (:dn:caseIgnoreIA5Match:=they) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \ + [asnChoice 3 [ldap::filter::AssertionValue they]] \ + [asnChoice 4 [binary format cc 1 1]]]] + +test filter-10.9 {Extensible match: matching rule (numericoid) + DN flag} -body { + ldap::filter::encode (:dn:111.222.333.444:=value) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString 111.222.333.444]] \ + [asnChoice 3 [ldap::filter::AssertionValue value]] \ + [asnChoice 4 [binary format cc 1 1]]]] + +test filter-10.10 {Extensible match: empty assertion value} -body { + ldap::filter::encode (AttrDesc:=) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \ + [asnChoice 3 [ldap::filter::AssertionValue ""]]]] + +test filter-10.11 {Extensible match: empty assertion value, DN flag} -body { + ldap::filter::encode (AttrDesc:dn:=) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \ + [asnChoice 3 [ldap::filter::AssertionValue ""]] \ + [asnChoice 4 [binary format cc 1 1]]]] + +test filter-10.11 {Extensible match: matching rule with empty assertion value} -body { + ldap::filter::encode (:caseIgnoreIA5Match:=) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \ + [asnChoice 3 [ldap::filter::AssertionValue ""]]]] + +test filter-10.12 {Extensible match: empty LHS} -body { + ldap::filter::encode (:=foo) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.12 {Extensible match: empty DN flag or matching rule OID} -body { + ldap::filter::encode (attrDesc::=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.12 {Extensible match: empty matching rule OID} -body { + ldap::filter::encode (attrDesc:dn::=baz) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.13 {Extensible match: empty DN flag} -body { + ldap::filter::encode (attrDesc::caseIgnoreMatch:=quux) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.14 {Extensible match: empty DN flag} -body { + ldap::filter::encode (::caseIgnoreMatch:=foo) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.15 {Extensible match: empty matching rule OID} -body { + ldap::filter::encode (::=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.16 {Extensible match: malformed matching rule numericoid} -body { + ldap::filter::encode (:111.222.333.xxx:=baz) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.17 {Extensible match: malformed matching rule numericoid} -body { + ldap::filter::encode (userCategory:111.222.333.444\;binary:=baz) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.18 {Extensible match: malformed matching rule numericoid} -body { + ldap::filter::encode (userCategory:dn:111.222.333.444\;x-bar:=foo) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.19 {Extensible match: malformed matching rule numericoid} -body { + ldap::filter::encode (:caseIgnoreIA5Match\;lang-ru:=quux) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.20 {Extensible match: camel-cased DN flag} -body { + ldap::filter::encode (attrDesc:Dn:caseIgnoreMatch:=quux) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.21 {Extensible match: prohibited character in attribute description} -body { + ldap::filter::encode (4cast:=foo) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.22 {Extensible match: gibberish in place of DN flag} -body { + ldap::filter::encode (OU:gibberish:caseIgnoreIA5Match:=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-10.23 {Extensible match: options in attribute description} -body { + ldap::filter::encode (personAge\;lang-ru\;x-foo:numericMatch:=99) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString numericMatch]] \ + [asnChoice 2 [ldap::filter::LDAPString personAge\;lang-ru\;x-foo]] \ + [asnChoice 3 [ldap::filter::AssertionValue 99]]]] + +test filter-10.24 {Extensible match: options in attribute description} -body { + ldap::filter::encode (111.222.333.444\;x-bar:dn:555.666.777.888:=foo) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString 555.666.777.888]] \ + [asnChoice 2 [ldap::filter::LDAPString 111.222.333.444\;x-bar]] \ + [asnChoice 3 [ldap::filter::AssertionValue foo]] \ + [asnChoice 4 [binary format cc 1 1]]]] + +test filter-11.1 {Prohibited characters in argument value} -body { + ldap::filter::encode (foo=bar(and)baz) +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-11.2 {Prohibited characters in argument value} -body { + ldap::filter::encode (zero=lurks\0here) +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-11.3 {Prohibited characters in argument value} -body { + ldap::filter::encode (extensible:=asterisk*) +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-12.0 {Malformed attribute description: empty} -body { + ldap::filter::encode (=foo) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.1 {Malformed attribute description: doesn't start with a letter} -body { + ldap::filter::encode (2forTheRoad=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.2 {Malformed attribute description: mix of descr and numericoid} -body { + ldap::filter::encode (foo.12.13=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.3 {Malformed attribute description: bad numericoid} -body { + ldap::filter::encode (.11.12.13=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.4 {Malformed attribute description: bad numericoid} -body { + ldap::filter::encode (11.12.13.=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.5 {Malformed attribute description: prohibited character in descr} -body { + ldap::filter::encode (cn_2=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.6 {Malformed attribute description: prohibited character in option} -body { + ldap::filter::encode (OU\;lang_en=bar) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.7 {Malformed attribute description: + colon in an LHS part of a rule which doesn't represent an extensible match} -body { + ldap::filter::encode (phoneNumber:dn=value) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-12.8 {Malformed attribute description: empty option} -body { + ldap::filter::encode (CN\;\;lang-ru=?) +} -returnCodes error -result {Invalid filter: malformed attribute description} + +test filter-13.1 {Malformed assertion value: prohibited characters} -body { + ldap::filter::encode (foo<=*) +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-13.2 {Malformed assertion value: prohibited characters} -body { + ldap::filter::encode (foo=() +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-13.3 {Malformed assertion value: prohibited characters} -body { + ldap::filter::encode (foo=)) +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-13.4 {Malformed assertion value: prohibited characters} -body { + ldap::filter::encode (foo=\\) +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-13.5 {Malformed assertion value: prohibited characters} -body { + ldap::filter::encode (foo=\0) +} -returnCodes error -result {Invalid filter: malformed assertion value} + +test filter-15.0 {No match rule operator} -body { + ldap::filter::encode () +} -returnCodes error -result {Invalid filter: no match operator in item} + +test filter-15.1 {No match rule operator} -body { + ldap::filter::encode (11.12.14~value) +} -returnCodes error -result {Invalid filter: no match operator in item} + +test filter-16.0 {Duplicated match rule operator} -body { + ldap::filter::encode (attrDesc=foo=bar) +} -result [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString attrDesc]] \ + [asnOctetString [ldap::filter::AssertionValue foo=bar]]]] + +test filter-16.1 {Duplicated match rule operator} -body { + ldap::filter::encode (attrDesc~=foo~=) +} -result [asnChoiceConstr 8 [glue \ + [asnOctetString [ldap::filter::LDAPString attrDesc]] \ + [asnOctetString [ldap::filter::AssertionValue foo~=]]]] + +test filter-16.2 {Duplicated match rule operator} -body { + ldap::filter::encode (attrDesc<=<=bar) +} -result [asnChoiceConstr 6 [glue \ + [asnOctetString [ldap::filter::LDAPString attrDesc]] \ + [asnOctetString [ldap::filter::AssertionValue <=bar]]]] + +test filter-16.3 {Duplicated match rule operator} -body { + ldap::filter::encode (attrDesc>=>=>=) +} -result [asnChoiceConstr 5 [glue \ + [asnOctetString [ldap::filter::LDAPString attrDesc]] \ + [asnOctetString [ldap::filter::AssertionValue >=>=]]]] + +test filter-16.4 {Duplicated match rule operator} -body { + ldap::filter::encode (AttrDesc:=:=what?:=) +} -result [asnChoiceConstr 9 [glue \ + [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \ + [asnChoice 3 [ldap::filter::AssertionValue :=what?:=]]]] + +test filter-17.0 {Compound filters: negation} -body { + ldap::filter::encode (!(foo=bar)) +} -result [asnChoiceConstr 2 [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString foo]] \ + [asnOctetString [ldap::filter::AssertionValue bar]]]]] + +test filter-17.1 {Compound filters: AND} -body { + ldap::filter::encode (&(one=two)(three<=four)(five>=six)) +} -result [asnChoiceConstr 0 [glue \ + [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString one]] \ + [asnOctetString [ldap::filter::AssertionValue two]]]] \ + [asnChoiceConstr 6 [glue \ + [asnOctetString [ldap::filter::LDAPString three]] \ + [asnOctetString [ldap::filter::AssertionValue four]]]] \ + [asnChoiceConstr 5 [glue \ + [asnOctetString [ldap::filter::LDAPString five]] \ + [asnOctetString [ldap::filter::AssertionValue six]]]]]] + +test filter-17.2 {Compound filters: OR} -body { + ldap::filter::encode (|(foo=bar)(baz:fuzzyMatch:=quux)(key~=value)) +} -result [asnChoiceConstr 1 [glue \ + [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString foo]] \ + [asnOctetString [ldap::filter::AssertionValue bar]]]] \ + [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString fuzzyMatch]] \ + [asnChoice 2 [ldap::filter::LDAPString baz]] \ + [asnChoice 3 [ldap::filter::AssertionValue quux]]]] \ + [asnChoiceConstr 8 [glue \ + [asnOctetString [ldap::filter::LDAPString key]] \ + [asnOctetString [ldap::filter::AssertionValue value]]]]]] + +test filter-17.3 {Compound filters: AND, spaces in assertion values} -body { + ldap::filter::encode {(&(OU=Research & Development)(DN=Rube Goldberg))} +} -result [asnChoiceConstr 0 [glue \ + [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString OU]] \ + [asnOctetString [ldap::filter::AssertionValue "Research & Development"]]]] \ + [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString DN]] \ + [asnOctetString [ldap::filter::AssertionValue "Rube Goldberg"]]]]]] + +test filter-18.1 {Compound filters: unbalanced parenthesis} -body { + ldap::filter::encode (&(foo=bar)(baz=quux) +} -returnCodes error -result {Invalid filter: unbalanced parenthesis} + +test filter-18.2 {Compound filters: unbalanced parenthesis} -body { + ldap::filter::encode (!(&(a=b)c=d)) +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-18.2 {Compound filters: unbalanced parenthesis} -body { + ldap::filter::encode (!(&(a=b)))c=d)) +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-18.3 {Compound filters: unbalanced parenthesis} -body { + ldap::filter::encode (!() +} -returnCodes error -result {Invalid filter:\ + filter expression must be surrounded by parentheses} + +test filter-19.1 {Compound filters: junk in expression} -body { + ldap::filter::encode {(& (foo=bar)(baz=quux))} +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-19.2 {Compound filters: junk in expression} -body { + ldap::filter::encode {(&(foo=bar) (baz=quux))} +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-19.3 {Compound filters: junk in expression} -body { + ldap::filter::encode {(|(foo=bar)(baz=quux) )} +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-19.3 {Compound filters: junk in expression} -body { + ldap::filter::encode {(&&(foo=bar)(baz=quux))} +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-19.4 {Compound filters: junk in expression} -body { + ldap::filter::encode {((foo=bar)&(baz=quux))} +} -returnCodes error -match glob -result {Invalid filter: malformed attribute *} + +test filter-20.0 {Missing elements in filter composition} -body { + ldap::filter::encode (!) +} -returnCodes error -result {Invalid filter:\ + filter expression must be surrounded by parentheses} + +test filter-20.1 {Missing elements in filter composition} -body { + ldap::filter::encode (&) +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-20.2 {Missing elements in filter composition} -body { + ldap::filter::encode (|) +} -returnCodes error -result {Invalid filter: malformed compound filter expression} + +test filter-21.0 {Torture test} -body { + ldap::filter::encode [regsub -all \\s+ { + (| + (& + (userName=Jane\20Random\00) + (userCategory;x-lang-ru~=human) + ) + (! + (| + (! + (salary=*) + ) + (& + (personAge>=80) + (yearsEmployed<=70) + (employeeName=Joe*a**nd**Hacker) + ) + ) + ) + (| + (11.22.33.44;x-files:dn:=value) + (:567.34.56:=\28\2a\29) + ) + (foo=bar) + ) + } ""] +} -result [asnChoiceConstr 1 [glue \ + [asnChoiceConstr 0 [glue \ + [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString userName]] \ + [asnOctetString [encoding convertto utf-8 "Jane Random\0"]]]] \ + [asnChoiceConstr 8 [glue \ + [asnOctetString [ldap::filter::LDAPString userCategory\;x-lang-ru]] \ + [asnOctetString [ldap::filter::AssertionValue human]]]]]] \ + [asnChoiceConstr 2 \ + [asnChoiceConstr 1 [glue \ + [asnChoiceConstr 2 \ + [asnChoice 7 [ldap::filter::LDAPString salary]]] \ + [asnChoiceConstr 0 [glue \ + [asnChoiceConstr 5 [glue \ + [asnOctetString [ldap::filter::LDAPString personAge]] \ + [asnOctetString [ldap::filter::AssertionValue 80]]]] \ + [asnChoiceConstr 6 [glue \ + [asnOctetString [ldap::filter::LDAPString yearsEmployed]] \ + [asnOctetString [ldap::filter::AssertionValue 70]]]] \ + [asnChoiceConstr 4 [glue \ + [asnOctetString [ldap::filter::LDAPString employeeName]] \ + [asnSequence [glue \ + [asnChoice 0 [ldap::filter::AssertionValue Joe]] \ + [asnChoice 1 [ldap::filter::AssertionValue a]] \ + [asnChoice 1 [ldap::filter::AssertionValue nd]] \ + [asnChoice 2 [ldap::filter::AssertionValue Hacker]]]]]]]]]]] \ + [asnChoiceConstr 1 [glue \ + [asnChoiceConstr 9 [glue \ + [asnChoice 2 [ldap::filter::LDAPString 11.22.33.44\;x-files]] \ + [asnChoice 3 [ldap::filter::AssertionValue value]] \ + [asnChoice 4 [binary format cc 1 1]]]] \ + [asnChoiceConstr 9 [glue \ + [asnChoice 1 [ldap::filter::LDAPString 567.34.56]] \ + [asnChoice 3 [encoding convertto utf-8 (*)]]]]]] \ + [asnChoiceConstr 3 [glue \ + [asnOctetString [ldap::filter::LDAPString foo]] \ + [asnOctetString [ldap::filter::AssertionValue bar]]]] \ + ]] + +# ------------------------------------------------------------------------- +testsuiteCleanup + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: +# vim:ts=8:sw=4:sts=4:noet:syntax=tcl diff --git a/tcllib/modules/ldap/ldapx.man b/tcllib/modules/ldap/ldapx.man new file mode 100644 index 0000000..6234d2b --- /dev/null +++ b/tcllib/modules/ldap/ldapx.man @@ -0,0 +1,772 @@ +[comment {-*- tcl -*- doctools manpage}] +[comment {$Id: ldapx.man,v 1.14 2009/01/29 06:16:19 andreas_kupries Exp $}] +[manpage_begin ldapx n 0.2.5] +[keywords {directory access}] +[keywords internet] +[keywords ldap] +[keywords {ldap client}] +[keywords ldif] +[keywords protocol] +[keywords {rfc 2251}] +[keywords {rfc 2849}] +[copyright {2006 Pierre David <pdav@users.sourceforge.net>}] +[moddesc {LDAP extended object interface}] +[titledesc {LDAP extended object interface}] +[category Networking] +[require Tcl 8.4] +[require ldapx [opt 1.0]] +[description] +[para] + +The [package ldapx] package provides an extended Tcl interface to +LDAP directores and LDIF files. The [package ldapx] package is built +upon the [package ldap] package in order to get low level LDAP access. + +[para] + +LDAP access is compatible with RFC 2251 +([uri http://www.rfc-editor.org/rfc/rfc2251.txt]). +LDIF access is compatible with RFC 2849 +([uri http://www.rfc-editor.org/rfc/rfc2849.txt]). + +[section OVERVIEW] + +The [package ldapx] package provides objects to interact with LDAP +directories and LDIF files with an easy to use programming interface. +It implements three [package snit]::type classes. + +[para] + +The first class, [class entry], is used to store individual entries. +Two different formats are available: the first one is the +[emph standard] format, which represents an entry as read from the +directory. The second format is the [emph change] format, which +stores differences between two standard entries. + +[para] + +With these entries, an application which wants to modify an entry +in a directory needs to read a (standard) entry from the directory, +create a fresh copy into a new (standard) entry, modify the new +copy, and then compute the differences between the two entries into +a new (change) entry, which may be commited to the directory. + +[para] + +Such kinds of modifications are so heavily used that standard entries +may contain their own copy of the original data. With such a copy, +the application described above reads a (standard) entry from the +directory, backs-up the original data, modifies the entry, and +computes the differences between the entry and its backup. These +differences are then commited to the directory. + +[para] + +Methods are provided to compute differences between two entries, +to apply differences to an entry in order to get a new entry, and +to get or set attributes in standard entries. + +[para] + +The second class is the [class ldap] class. It provides a method +to [method connect] and bind to the directory with a uniform access +to LDAP and LDAPS through an URL (ldap:// or ldaps://). The +[method traverse] control structure executes a body for each entry +found in the directory. The [method commit] method applies some +changes (represented as [class entry] objects) to the directory. +Since some attributes are represented as UTF-8 strings, the option +[option -utf8] controls which attributes must be converted and +which attributes must not be converted. + +[para] + +The last class is the [class ldif] class. It provides a method to +associate a standard Tcl [emph channel] to an LDIF object. Then, +methods [method read] and [method write] read or write entries from +or to this channel. This class can make use of standard or change +entries, according to the type of the LDIF file which may contain +either standard entries or change entries (but not both at the same +time). The option [option -utf8] works exactly as with the +[class ldap] class. + +[section {ENTRY CLASS}] + +[subsection {Entry Instance Data}] + +An instance of the [class entry] class keeps the following data: + +[list_begin definitions] + + [def dn] + + This is the DN of the entry, which includes (in LDAP + terminology) the RDN (relative DN) and the Superior parts. + + [def format] + + The format may be [emph uninitialized] (entry not yet used), + [emph standard] or [emph change]. Most methods check the + format of the entry, which can be reset with the + [method reset] method. + + [def attrvals] + + In a [emph standard] entry, this is where the attributes + and associated values are stored. Many methods provide + access to these informations. Attribute names are always + converted into lower case. + + [def backup] + + In a [emph standard] entry, the backup may contain a copy + of the dn and all attributes and values. Methods + [method backup] and [method restore] manipulate these data, + and method [method diff] may use this backup. + + [def change] + + In a [emph change] entry, these data represent the + modifications. Such modifications are handled by specialized + methods such as [method apply] or [method commit]. + Detailed format should not be used directly by programs. + [para] + Internally, modifications are represented as a list of + elements, each element has one of the following formats + (which match the corresponding LDAP operations): + + [list_begin enumerated] + + [enum] + {[const add] {attr1 {val1...valn} attr2 {...} ...}} + [para] + Addition of a new entry. + + [enum] + {[const mod] {modop {attr1 [opt val1...valn]} attr2 ...} {modop ...} ...} + [para] + Modification of one or more attributes and/or values, + where <modop> can be [const modadd], [const moddel] + or [const modrepl] (see the LDAP modify operation). + + [enum] + {[const del]} + [para] + Deletion of an old entry. + + [enum] + {[const modrdn] newrdn deleteoldrdn [opt newsuperior]} + [para] + Renaming of an entry. + + [list_end] + +[list_end] + +[subsection {Entry Options}] + +No option is defined by this class. + +[subsection {Methods for all kinds of entries}] + +[list_begin definitions] + [call [arg e] [method reset]] + + This method resets the entry to an uninitialized state. + + [call [arg e] [method dn] [opt [arg newdn]]] + + This method returns the current DN of the entry. If the + optional [arg newdn] is specified, it replaces the current + DN of the entry. + + [call [arg e] [method rdn]] + + This method returns the RDN part of the DN of the entry. + + [call [arg e] [method superior]] + + This method returns the superior part of the DN of the entry. + + [call [arg e] [method print]] + + This method returns the entry as a string ready to be printed. + +[list_end] + +[para] + +[subsection {Methods for standard entries only}] + +In all methods, attribute names are converted in lower case. + +[list_begin definitions] + [call [arg se] [method isempty]] + + This method returns 1 if the entry is empty (i.e. without + any attribute). + + [call [arg se] [method get] [arg attr]] + + This method returns all values of the attribute [arg attr], + or the empty list if the attribute is not fond. + + [call [arg se] [method get1] [arg attr]] + + This method returns the first value of the attribute. + + [call [arg se] [method set] [arg attr] [arg values]] + + This method sets the values (list [arg values]) of the + attribute [arg attr]. If the list is empty, this method + deletes all + + [call [arg se] [method set1] [arg attr] [arg value]] + + This method sets the values of the attribute [arg attr] to + be an unique value [arg value]. Previous values, if any, + are replaced by the new value. + + [call [arg se] [method add] [arg attr] [arg values]] + + This method adds all elements the list [arg values] to the + values of the attribute [arg attr]. + + [call [arg se] [method add1] [arg attr] [arg value]] + + This method adds a single value given by the parameter + [arg value] to the attribute [arg attr]. + + [call [arg se] [method del] [arg attr] [opt [arg values]]] + + If the optional list [arg values] is specified, this method + deletes all specified values from the attribute [arg attr]. + If the argument [arg values] is not specified, this method + deletes all values. + + [call [arg se] [method del1] [arg attr] [arg value]] + + This method deletes a unique [arg value] from the attribute + [arg attr]. + + [call [arg se] [method getattr]] + + This method returns all attributes names. + + [call [arg se] [method getall]] + + This method returns all attributes and values from the + entry, packed in a list of pairs <attribute, list of values>. + + [call [arg se] [method setall] [arg avpairs]] + + This method sets at once all attributes and values. The + format of the [arg avpairs] argument is the same as the one + returned by method [method getall]. + + [call [arg se] [method backup] [opt [arg other]]] + + This method stores in an [arg other] standard entry object + a copy of the current DN and attributes/values. If the + optional [arg other] argument is not specified, copy is + done in the current entry (in a specific place, see section + [sectref OVERVIEW]). + + [call [arg se] [method swap]] + + This method swaps the current and backup contexts of the + entry. + + [call [arg se] [method restore] [opt [arg other]]] + + If the optional argument [arg other] is given, which must + then be a [emph standard] entry, this method restores the + current entry into the [arg other] entry. If the argument + [arg other] argument is not specified, this methods restores + the current entry from its internal backup (see section + [sectref OVERVIEW]). + + [call [arg se] [method apply] [arg centry]] + + This method applies changes defined in the [arg centry] + argument, which must be a [emph change] entry. + +[list_end] + +[subsection {Methods for change entries only}] + +[list_begin definitions] + [call [arg ce] [method change] [opt [arg new]]] + + If the optional argument [arg new] is specified, this method + modifies the change list (see subsection [sectref {Entry Instance Data}] for + the exact format). In both cases, current change list is + returned. + Warning: values returned by this method should only be used + by specialized methods such as [method apply] or + [method commit]. + + [call [arg ce] [method diff] [arg new] [opt [arg old]]] + + This method computes the differences between the [arg new] + and [arg old] entries under the form of a change list, and + stores this list into the current [emph change] entry. If + the optional argument [arg old] is not specified, difference + is computed from the entry and its internal backup (see + section [sectref OVERVIEW]). Return value is the computed + change list. + +[list_end] + +[subsection {Entry Example}] + +[example { + package require ldapx + + # + # Create an entry and fill it as a standard entry with + # attributes and values + # + ::ldapx::entry create e + e dn "uid=joe,ou=people,o=mycomp" + e set1 "uid" "joe" + e set "objectClass" {person anotherObjectClass} + e set1 "givenName" "Joe" + e set1 "sn" "User" + e set "telephoneNumber" {+31415926535 +2182818} + e set1 "anotherAttr" "This is a beautiful day, isn't it?" + + puts stdout "e\n[e print]" + + # + # Create a second entry as a backup of the first, and + # make some changes on it. + # Entry is named automatically by snit. + # + + set b [::ldapx::entry create %AUTO%] + e backup $b + + puts stdout "$b\n[$b print]" + + $b del "anotherAttr" + $b del1 "objectClass" "anotherObjectClass" + + # + # Create a change entry, a compute differences between first + # and second entry. + # + + ::ldapx::entry create c + c diff e $b + + puts stdout "$c\n[$c print]" + + # + # Apply changes to first entry. It should be the same as the + # second entry, now. + # + + e apply c + + ::ldapx::entry create nc + nc diff e $b + + puts stdout "nc\n[nc print]" + + # + # Clean-up + # + + e destroy + $b destroy + c destroy + nc destroy +}] + +[section {LDAP CLASS}] + +[subsection {Ldap Instance Data}] + +An instance of the [class ldap] class keeps the following data: + +[list_begin definitions] + + [def channel] + + This is the channel used by the [package ldap] package for + communication with the LDAP server. + + [def lastError] + + This variable contains the error message which appeared in + the last method of the [class ldap] class (this string is + modified in nearly all methods). The [method error] method + may be used to fetch this message. + +[list_end] + +[subsection {Ldap Options}] + +A first set of options of the [class ldap] class is used during +search operations (methods [method traverse], [method search] and +[method read], see below). + +[list_begin options] + + [opt_def -scope [const base]|[const one]|[const sub]] + + Specify the scope of the LDAP search to be one of + [const base], [const one] or [const sub] to specify + a base object, one-level or subtree search. + [para] + The default is [const sub]. + + [opt_def -derefaliases [const never]|[const seach]|[const find]|[const always]] + + Specify how aliases dereferencing is handled: + [const never] is used to specify that aliases are never derefenced, + [const always] that aliases are always derefenced, + [const search] that aliases are dereferenced when searching, + or [const find] that aliases are dereferenced only when + locating the base object for the search. + [para] + The default is [const never]. + + [opt_def -sizelimit integer] + + Specify the maximum number of entries to be retreived + during a search. A value of [const 0] means no limit. + [para] + Default is [const 0]. + + [opt_def -timelimit integer] + + Specify the time limit for a search to complete. + A value of [const 0] means no limit. + [para] + Default is [const 0]. + + [opt_def -attrsonly [const 0]|[const 1]] + + Specify if only attribute names are to be retrieved (value + [const 1]). Normally (value [const 0]), attribute values + are also retrieved. + [para] + Default is [const 0]. + +[list_end] + +[para] + +The last option is used when getting entries or committing changes +in the directory: + +[list_begin options] + + [opt_def -utf8 {pattern-yes pattern-no}] + + Specify which attribute values are encoded in UTF-8. This + information is specific to the LDAP schema in use by the + application, since some attributes such as jpegPhoto, for + example, are not encoded in UTF-8. This option takes the + form of a list with two regular expressions suitable for + the [cmd regexp] command (anchored by ^ and $). + The first specifies which attribute names are to be UTF-8 + encoded, and the second selects, among those, the attribute + names which will not be UTF-8 encoded. It is thus possible + to say: convert all attributes, except jpegPhoto. + + [para] + + Default is {{.*} {}}, meaning: all attributes are converted, + without exception. + +[list_end] + +[subsection {Ldap Methods}] + +[list_begin definitions] + [call [arg la] [method error] [opt [arg newmsg]]] + + This method returns the error message that occurred in the + last call to a [class ldap] class method. If the optional + argument [arg newmsg] is supplied, it becomes the last + error message. + + [call [arg la] [method connect] [arg url] [opt [arg binddn]] [opt [arg bindpw]]] + + This method connects to the LDAP server using given URL + (which can be of the form [uri ldap://host:port] or + [uri ldaps://host:port]). If an optional [arg binddn] + argument is given together with the [arg bindpw] argument, + the [method connect] binds to the LDAP server using the + specified DN and password. + + [call [arg la] [method disconnect]] + + This method disconnects (and unbinds, if necessary) from + the LDAP server. + + [call [arg la] [method traverse] [arg base] [arg filter] [arg attrs] [arg entry] [arg body]] + + This method is a new control structure. It searches the + LDAP directory from the specified base DN (given by the + [arg base] argument) and selects entries based on the + argument [arg filter]. For each entry found, this method + fetches attributes specified by the [arg attrs] argument + (or all attributes if it is an empty list), stores them in + the [arg entry] instance of class [class entry] and executes + the script defined by the argument [arg body]. Options are + used to refine the search. + + [para] + + Caution: when this method is used, the script [arg body] + cannot perform another LDAP search (methods [method traverse], + [method search] or [method read]). + + [call [arg la] [method search] [arg base] [arg filter] [arg attrs]] + + This method searches the directory using the same way as + method [method traverse]. All found entries are stored in + newly created instances of class [class entry], which are + returned in a list. The newly created instances should be + destroyed when they are no longer used. + + [call [arg la] [method read] [arg base] [arg filter] [arg entry] ... [arg entry]] + + This method reads one or more entries, using the same search + criteria as methods [method traverse] and [method search]. + All attributes are stored in the entries. This method + provides a quick way to read some entries. It returns the + number of entries found in the directory (which may be more + than the number of read entries). If called without any + [arg entry] argument, this method just returns the number + of entries found, without returning any data. + + [call [arg la] [method commit] [arg entry] ... [arg entry]] + + This method commits the changes stored in the [arg entry] + arguments. Each [arg entry] may be either a [emph change] + entry, or a [emph standard] entry with a backup. + [para] + Note: in the future, this method should use the LDAP + transaction extension provided by OpenLDAP 2.3 and later. + +[list_end] + +[subsection {Ldap Example}] + +[example { + package require ldapx + + # + # Connects to the LDAP directory + # + + ::ldapx::ldap create l + set url "ldap://server.mycomp.com" + if {! [l connect $url "cn=admin,o=mycomp" "mypasswd"]} then { + puts stderr "error: [l error]" + exit 1 + } + + # + # Search all entries matching some criterion + # + + l configure -scope one + ::ldapx::entry create e + set n 0 + l traverse "ou=people,o=mycomp" "(sn=Joe*)" {sn givenName} e { + puts "dn: [e dn]" + puts " sn: [e get1 sn]" + puts " givenName: [e get1 givenName]" + incr n + } + puts "$n entries found" + e destroy + + # + # Add a telephone number to some entries + # Note this modification cannot be done in the "traverse" operation. + # + + set lent [l search "ou=people,o=mycomp" "(sn=Joe*)" {}] + ::ldapx::entry create c + foreach e $lent { + $e backup + $e add1 "telephoneNumber" "+31415926535" + c diff $e + if {! [l commit c]} then { + puts stderr "error: [l error]" + exit 1 + } + $e destroy + } + + l disconnect + l destroy +}] + +[section {LDIF CLASS}] + +[subsection {Ldif Instance Data}] + +An instance of the [class ldif] class keeps the following data: + +[list_begin definitions] + + [def channel] + + This is the Tcl channel used to retrieve or store LDIF file + contents. The association between an instance and a channel + is made by the method [method channel]. There is no need + to disrupt this association when the LDIF file operation + has ended. + + [def format] + + LDIF files may contain [emph standard] entries or + [emph change] entries, but not both. This variable contains + the detected format of the file (when reading) or the format + of entries written to the file (when writing). + + [def lastError] + + This variable contains the error message which appeared in + the last method of the [class ldif] class (this string is + modified in nearly all methods). The [method error] method + may be used to fetch this message. + + [def version] + + This is the version of the LDIF file. Only version 1 is + supported: the method [method read] can only read from + version 1 files, and method [method write] only creates + version 1 files. + +[list_end] + +[subsection {Ldif Options}] + +This class defines two options: + +[list_begin options] + + [opt_def -ignore {list-of-attributes}] + + This option is used to ignore certain attribute names on + reading. For example, to read OpenLDAP replica files (replog), + one must ignore [const replica] and [const time] attributes + since they do not conform to the RFC 2849 standard for LDIF + files. + [para] + Default is empty list: no attribute is ignored. + + [opt_def -utf8 {pattern-yes pattern-no}] + + Specify which attribute values are encoded in UTF-8. This + information is specific to the LDAP schema in use by the + application, since some attributes such as jpegPhoto, for + example, are not encoded in UTF-8. This option takes the + form of a list with two regular expressions suitable for + the [cmd regexp] command (anchored by ^ and $). + The first specifies which attribute names are to be UTF-8 + encoded, and the second selects, among those, the attribute + names which will not be UTF-8 encoded. It is thus possible + to say: convert all attributes, except jpegPhoto. + + [para] + + Default is {{.*} {}}, meaning: all attributes are converted, + without exception. + +[list_end] + +[subsection {Ldif Methods}] + +[list_begin definitions] + + [call [arg li] [method channel] [arg chan]] + + This method associates the Tcl channel named [arg chan] + with the LDIF instance. It resets the type of LDIF object + to [emph uninitialized]. + + [call [arg li] [method error] [opt [arg newmsg]]] + + This method returns the error message that occurred in the + last call to a [class ldif] class method. If the optional + argument [arg newmsg] is supplied, it becomes the last + error message. + + [call [arg li] [method read] [arg entry]] + + This method reads the next entry from the LDIF file and + stores it in the [arg entry] object of class [class entry]. + The entry may be a [emph standard] or [emph change] entry. + + [call [arg li] [method write] [arg entry]] + + This method writes the entry given in the argument + [arg entry] to the LDIF file. + +[list_end] + +[subsection {Ldif Example}] + +[example { + package require ldapx + + # This examples reads a LDIF file containing entries, + # compare them to a LDAP directory, and writes on standard + # output an LDIF file containing changes to apply to the + # LDAP directory to match exactly the LDIF file. + + ::ldapx::ldif create liin + liin channel stdin + + ::ldapx::ldif create liout + liout channel stdout + + ::ldapx::ldap create la + if {! [la connect "ldap://server.mycomp.com"]} then { + puts stderr "error: [la error]" + exit 1 + } + la configure -scope one + + # Reads LDIF file + + ::ldapx::entry create e1 + ::ldapx::entry create e2 + ::ldapx::entry create c + + while {[liin read e1] != 0} { + set base [e1 superior] + set id [e1 rdn] + if {[la read $base "($id)" e2] == 0} then { + e2 reset + } + + c diff e1 e2 + if {[llength [c change]] != 0} then { + liout write c + } + } + + la disconnect + la destroy + e1 destroy + e2 destroy + c destroy + liout destroy + liin destroy +}] + +[section References] + +[vset CATEGORY ldap] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/ldap/ldapx.tcl b/tcllib/modules/ldap/ldapx.tcl new file mode 100644 index 0000000..aca3650 --- /dev/null +++ b/tcllib/modules/ldap/ldapx.tcl @@ -0,0 +1,1794 @@ +# +# Extended object interface to entries in LDAP directories or LDIF files. +# +# (c) 2006 Pierre David (pdav@users.sourceforge.net) +# +# $Id: ldapx.tcl,v 1.12 2008/02/07 21:19:39 pdav Exp $ +# +# History: +# 2006/08/08 : pda : design +# + +package require Tcl 8.4 +package require snit ;# tcllib +package require uri 1.1.5 ;# tcllib +package require base64 ;# tcllib +package require ldap 1.6 ;# tcllib, low level code for LDAP directories + +package provide ldapx 1.0 + +############################################################################## +# LDAPENTRY object type +############################################################################## + +snit::type ::ldapx::entry { + ######################################################################### + # Variables + ######################################################################### + + # + # Format of an individual entry + # May be "standard" (standard LDAP entry, read from an LDAP directory + # or from a LDIF channel) or "change" (LDIF change, or result of the + # comparison of two standard entries). + # Special : "uninitialized" means that this entry has not been used, + # and the first use will initialize it. + # + + variable format "uninitialized" + + # + # DN + # + + variable dn "" + + # + # Standard entry + # + # Syntax: + # - array indexed by attribute names (lower case) + # - each value is the list of attributes + # + # The current state may be backed up in an internal state. + # (see backup and restore methods) + # + + variable attrvals -array {} + + variable backup 0 + variable bckav -array {} + variable bckdn "" + + # + # Change entry + # + # Syntax: + # {{<op> <parameters>} ... } + # if <op> = mod + # {mod {{<modop> <attr> [ {<val1> ... <valn>} ]} ...} } + # where <modop> = modrepl, modadd, moddel + # if <op> = add + # {add {<attr> {<val1> ... <valn>} ...}} + # if <op> = del + # {del} + # if <op> = modrdn + # {modrdn <newrdn> <deleteoldrdn> [ <newsuperior> ]} + # + + variable change "" + + ######################################################################### + # Generic methods (for both standard and change entries) + ######################################################################### + + # Resets the entry to an empty state + + method reset {} { + + set format "uninitialized" + set dn "" + array unset attrvals + set backup 0 + array unset bckav + set bckdn "" + set change "" + } + + # Returns current format + + method format {} { + + return $format + } + + # Checks if entry is compatible with a certain format + # errors out if not + + method compatible {ref} { + + if {$format eq "uninitialized"} then { + set format $ref + } elseif {$format ne $ref} then { + return -code error \ + "Invalid operation on format $format (should be $ref)" + } + } + + # Get or set the current dn + + method dn {{newdn {-}}} { + + if {$newdn ne "-"} then { + set dn $newdn + } + return $dn + } + + # Get the "superior" (LDAP slang word) part of current dn + + method superior {} { + + set pos [string first "," $dn] + if {$pos == -1} then { + set r "" + } else { + set r [string range $dn [expr {$pos+1}] end] + } + return $r + } + + # Get the "rdn" part of current dn + + method rdn {} { + + set pos [string first "," $dn] + if {$pos == -1} then { + set r "" + } else { + set r [string range $dn 0 [expr {$pos-1}]] + } + return $r + } + + # Get a printable form of the contents + + method print {} { + + set r "dn: $dn" + switch -- $format { + uninitialized { + # nothing + } + standard { + foreach a [lsort [array names attrvals]] { + append r "\n$a: $attrvals($a)" + } + } + change { + if {[llength $change]} then { + append r "\n$change" + } + } + default { + append r " (inconsistent value)" + } + } + return $r + } + + # Prints the whole state of an entry + + method debug {} { + + set r "dn = <$dn>\nformat = $format" + switch -- $format { + uninitialized { + # nothing + } + standard { + foreach a [lsort [array names attrvals]] { + append r "\n\t$a: $attrvals($a)" + } + if {$backup} then { + append r "\nbackup dn = $bckdn" + foreach a [lsort [array names bckav]] { + append r "\n\t$a: $bckav($a)" + } + } else { + append r "\nno backup" + } + } + change { + if {[llength $change]} then { + append r "\n$change" + } else { + append r "\nno change" + } + } + default { + append r " (inconsistent value)" + } + } + return $r + } + + + ######################################################################### + # Methods for standard entries + ######################################################################### + + # Tells if the current entry is empty + + method isempty {} { + + $self compatible "standard" + + return [expr {[array size attrvals] == 0}] + } + + # Get all values for an attribute + + method get {attr} { + + $self compatible "standard" + + set a [string tolower $attr] + if {[info exists attrvals($a)]} then { + set r $attrvals($a) + } else { + set r {} + } + return $r + } + + # Get only the first value for an attribute + + method get1 {attr} { + + return [lindex [$self get $attr] 0] + } + + + # Set all values for an attribute + + method set {attr vals} { + + $self compatible "standard" + + set a [string tolower $attr] + if {[llength $vals]} then { + set attrvals($a) $vals + } else { + unset -nocomplain attrvals($a) + } + return $vals + } + + # Set only one value for an attribute + + method set1 {attr val} { + + if {$val eq ""} then { + set l {} + } else { + set l [list $val] + } + + return [$self set $attr $l] + } + + # Add some values to an attribute + + method add {attr vals} { + + $self compatible "standard" + + set a [string tolower $attr] + foreach v $vals { + lappend attrvals($a) $v + } + return $attrvals($a) + } + + # Add only one value to an attribute + + method add1 {attr val} { + + return [$self add $attr [list $val]] + } + + # Delete all values (or some values only) for an attribute + + method del {attr {vals {}}} { + + $self compatible "standard" + + set a [string tolower $attr] + if {[llength $vals]} then { + set l [$self get $attr] + foreach v $vals { + while {[set pos [lsearch -exact $l $v]] != -1} { + set l [lreplace $l $pos $pos] + } + } + } else { + set l {} + } + + if {[llength $l]} then { + $self set $attr $l + } else { + unset -nocomplain attrvals($a) + } + return + } + + # Delete only one value from an attribute + + method del1 {attr val} { + + $self del $attr [list $val] + } + + # Get all attribute names + + method getattr {} { + + $self compatible "standard" + + return [array names attrvals] + } + + # Get all attribute names and values + + method getall {} { + + $self compatible "standard" + + return [array get attrvals] + } + + # Reset all attribute names and values at once + + method setall {lst} { + + $self compatible "standard" + + array unset attrvals + foreach {attr vals} $lst { + set a [string tolower $attr] + set attrvals($a) $vals + } + } + + # Back up current entry into a new one or into the internal backup state + + method backup {{other {}}} { + + $self compatible "standard" + + if {$other eq ""} then { + # + # Back-up entry in $self->$oldav and $self->$dn + # + set backup 1 + set bckdn $dn + + array unset bckav + array set bckav [array get attrvals] + } else { + # + # Back-up entry in $other + # + $other compatible "standard" + $other dn $dn + $other setall [array get attrvals] + } + } + + # Restore current entry from an old one or from the internal backup state + + method restore {{other {}}} { + + $self compatible "standard" + + if {$backup} then { + if {$other eq ""} then { + # + # Restore in current context + # + set dn $bckdn + array unset attrvals + array set attrvals [array get bckav] + } else { + # + # Restore in another object + # + $other compatible "standard" + $other dn $bckdn + $other setall [array get bckav] + } + } else { + return -code error \ + "Cannot restore a non backuped object" + } + } + + # Swap current and backup data, if they reside in the same entry + + method swap {} { + + $self compatible "standard" + + if {$backup} then { + # + # Swap current and backup contexts + # + set swdn $dn + set dn $bckdn + set bckdn $swdn + + set swav [array get attrvals] + array unset attrvals + array set attrvals [array get bckav] + array unset bckav + array set bckav $swav + } else { + return -code error \ + "Cannot swap a non backuped object" + } + } + + # Apply some modifications (given by a change entry) to current entry + + method apply {chg} { + + $self compatible "standard" + $chg compatible "change" + + # + # Apply $chg modifications to $self + # + + foreach mod [$chg change] { + set op [lindex $mod 0] + switch -- $op { + add { + if {! [$self isempty]} then { + return -code error \ + "Cannot add an entry to a non-empty entry" + } + $self setall [lindex $mod 1] + if {[string equal [$self dn] ""]} then { + $self dn [$chg dn] + } + } + mod { + foreach submod [lindex $mod 1] { + set subop [lindex $submod 0] + set attr [lindex $submod 1] + set vals [lindex $submod 2] + switch -- $subop { + modadd { + $self add $attr $vals + } + moddel { + $self del $attr $vals + } + modrepl { + $self del $attr + $self add $attr $vals + } + default { + return -code error \ + "Invalid submod operation '$subop'" + } + } + } + } + del { + array unset attrvals + } + modrdn { + set newrdn [lindex $mod 1] + set delold [lindex $mod 2] + set newsup [lindex $mod 3] + + if {! [regexp {^([^=]+)=([^,]+)$} $newrdn m nattr nval]} then { + return -code "Invalid new RDN '$newrdn'" + } + + set olddn [$self dn] + if {! [regexp {^([^=]+)=([^,]+),(.*)} $olddn m oattr oval osup]} then { + return -code "Invalid old DN '$olddn'" + } + + if {$newsup eq ""} then { + set dn "$newrdn,$osup" + } else { + set dn "$newrdn,$newsup" + } + $self dn $dn + + if {$delold} then { + $self del1 $oattr $oval + } + + # XXX should we ignore case ? + if {[lsearch -exact [$self get $nattr] $nval] == -1} then { + $self add1 $nattr $nval + } + } + default { + return -code error \ + "Invalid change operation '$op'" + } + } + } + } + + ######################################################################### + # Methods for change entries + ######################################################################### + + # Get or set all modifications + + method change {{newchg {-}}} { + + $self compatible "change" + + if {$newchg ne "-"} then { + set change $newchg + } + return $change + } + + # Compute the difference between two entries (or between an entry + # and the backed-up internal state) into the current change entry + # e1 : new, e2 : old + # if e2 is not given, it defaults to backup in e1 + + method diff {new {old {}}} { + + $self compatible "change" + + # + # Select where backup is. If internal, creates a temporary + # standard entry. + # + + if {$old eq ""} then { + set destroy_old 1 + set old [::ldapx::entry create %AUTO%] + $new restore $old + } else { + set destroy_old 0 + } + + # + # Computes differences between values in the two entries + # + + if {[$old dn] ne ""} then { + $self dn [$old dn] + } elseif {[$new dn] ne ""} then { + $self dn [$new dn] + } else { + $self dn "" + } + + switch -- "[$new isempty][$old isempty]" { + 00 { + # They may differ + set change [DiffEntries $new $old] + } + 01 { + # new has been added + set change [list [list "add" [$new getall]]] + } + 10 { + # new has been deleted + set change [list [list "del"]] + } + 11 { + # they are both empty: no change + set change {} + } + } + + # + # Remove temporary standard entry (backup was internal) + # + + if {$destroy_old} then { + $old destroy + } + + return $change + } + + # local procedure to compute differences between two non empty entries + + proc DiffEntries {new old} { + array set tnew [$new getall] + array set told [$old getall] + + set lmod {} + + # + # First step : is there a DN change? + # + + set moddn [DiffDn [$new dn] [$old dn] tnew told] + + # + # Second step : pick up changes in attributes and/or values + # + + foreach a [array names tnew] { + if {[info exists told($a)]} then { + # + # They are new and old values for this attribute. + # We cannot use individual delete or add (rfc 4512, + # paragraph 2.5.1) for attributes which do not have an + # equality operator, so we use "replace" everywhere. + # + + set lnew [lsort $tnew($a)] + set lold [lsort $told($a)] + if {$lold ne $lnew} then { + lappend lmod [list "modrepl" $a $tnew($a)] + } + + unset tnew($a) + unset told($a) + } else { + lappend lmod [list "modadd" $a $tnew($a)] + unset tnew($a) + } + } + + foreach a [array names told] { + lappend lmod [list "moddel" $a] + } + + set lchg {} + + if {[llength $lmod]} then { + lappend lchg [list "mod" $lmod] + } + + # + # Third step : insert modDN changes + # + + if {[llength $moddn]} then { + set newrdn [lindex $moddn 0] + set deleteoldrdn [lindex $moddn 1] + set newsuperior [lindex $moddn 2] + + set lmod [list "modrdn" $newrdn $deleteoldrdn] + if {! [string equal $newsuperior ""]} then { + lappend lmod $newsuperior + } + lappend lchg $lmod + } + + return $lchg + } + + proc DiffDn {newdn olddn _tnew _told} { + upvar $_tnew tnew + upvar $_told told + + # + # If DNs are the same, exit + # + + if {[string equal -nocase $newdn $olddn]} then { + return {} + } + + # + # Split components of both DNs : attribute, value, superior + # + + if {! [regexp {^([^=]+)=([^,]+),(.*)} $olddn m oattr oval osup]} then { + return -code "Invalid old DN '$olddn'" + } + set oattr [string tolower $oattr] + set ordn "$oattr=$oval" + + if {! [regexp {^([^=]+)=([^,]+),(.*)} $newdn m nattr nval nsup]} then { + return -code "Invalid new DN '$newdn'" + } + set nattr [string tolower $nattr] + set nrdn "$nattr=$nval" + + # + # Checks if superior has changed + # + + if {! [string equal -nocase $osup $nsup]} then { + set newsuperior $nsup + } else { + set newsuperior "" + } + + # + # Checks if rdn has changed + # + + if {! [string equal -nocase $ordn $nrdn]} then { + # + # Checks if old rdn must be deleted + # + + set deleteoldrdn 1 + if {[info exists tnew($oattr)]} then { + set pos [lsearch -exact [string tolower $tnew($oattr)] \ + [string tolower $oval]] + if {$pos != -1} then { + set deleteoldrdn 0 + } + } + + # + # Remove old and new rdn such as DiffEntries doesn't + # detect any modification. + # + + foreach t {tnew told} { + foreach {a v} [list $oattr $oval $nattr $nval] { + if {[info exists ${t}($a)]} then { + set l [set ${t}($a)] + set pos [lsearch -exact [string tolower $l] \ + [string tolower $v] ] + if {$pos != -1} then { + set l [lreplace $l $pos $pos] + if {[llength $l]} then { + set ${t}($a) $l + } else { + unset -nocomplain ${t}($a) + } + } + } + } + } + } else { + set deleteoldrdn 0 + } + + return [list $nrdn $deleteoldrdn $newsuperior] + } + + + ######################################################################### + # End of ldapentry + ######################################################################### +} + +############################################################################## +# UTF8 translator, component used to manage the -utf8 option +############################################################################## + +snit::type ::ldapx::utf8trans { + + ######################################################################### + # Option + ######################################################################### + + option -utf8 -default {{.*} {}} + + ######################################################################### + # Methods + ######################################################################### + + method must {attr} { + set utf8yes [lindex $options(-utf8) 0] + set utf8no [lindex $options(-utf8) 1] + set r 0 + if {[regexp -expanded -nocase "^$utf8yes$" $attr]} then { + set r 1 + if {[regexp -expanded -nocase "^$utf8no$" $attr]} then { + set r 0 + } + } + return $r + } + + method encode {attr val} { + if {[$self must $attr]} then { + set val [encoding convertto utf-8 $val] + } + return $val + } + + method decode {attr val} { + if {[$self must $attr]} then { + set val [encoding convertfrom utf-8 $val] + } + return $val + } + + method encodepairs {avpairs} { + set r {} + foreach {attr vals} $avpairs { + if {[llength $vals]} then { + lappend r $attr [$self encode $attr $vals] + } else { + lappend r $attr + } + } + return $r + } + + method decodepairs {avpairs} { + set r {} + foreach {attr vals} $avpairs { + set vals [$self decode $attr $vals] + lappend r $attr $vals + } + return $r + } +} + +############################################################################## +# LDAP object type +############################################################################## + +snit::type ::ldapx::ldap { + ######################################################################### + # Options + # + # note : options are lowercase + ######################################################################### + + option -scope -default "sub" + option -derefaliases -default "never" + option -sizelimit -default 0 + option -timelimit -default 0 + option -attrsonly -default 0 + + component translator + delegate option -utf8 to translator + + # + # Channel descriptor + # + + variable channel "" + variable bind 0 + + # + # Last error + # + + variable lastError "" + + # + # Defaults connection modes + # + + variable connect_defaults -array { + ldap {389 ::ldap::connect} + ldaps {636 ::ldap::secure_connect} + } + + + ######################################################################### + # Constructor + ######################################################################### + + constructor {args} { + install translator using ::ldapx::utf8trans create %AUTO% + $self configurelist $args + } + + destructor { + catch {$translator destroy} + } + + ######################################################################### + # Methods + ######################################################################### + + # Get or set the last error message + + method error {{le {-}}} { + + if {! [string equal $le "-"]} then { + set lastError $le + } + return $lastError + } + + # Connect to the LDAP directory, and binds to it if needed + + method connect {url {binddn {}} {bindpw {}}} { + + array set comp [::uri::split $url "ldap"] + + if {! [::info exists comp(host)]} then { + $self error "Invalid host in URL '$url'" + return 0 + } + + set scheme $comp(scheme) + if {! [::info exists connect_defaults($scheme)]} then { + $self error "Unrecognized URL '$url'" + return 0 + } + + set defport [lindex $connect_defaults($scheme) 0] + set fct [lindex $connect_defaults($scheme) 1] + + if {[string equal $comp(port) ""]} then { + set comp(port) $defport + } + + if {[Check $selfns {set channel [$fct $comp(host) $comp(port)]}]} then { + return 0 + } + + if {$binddn eq ""} then { + set bind 0 + } else { + set bind 1 + if {[Check $selfns {::ldap::bind $channel $binddn $bindpw}]} then { + return 0 + } + } + return 1 + } + + # Disconnect from the LDAP directory + + method disconnect {} { + + Connected $selfns + + if {$bind} { + if {[Check $selfns {::ldap::unbind $channel}]} then { + return 0 + } + } + if {[Check $selfns {::ldap::disconnect $channel}]} then { + return 0 + } + set channel "" + return 1 + } + + # New control structure : traverse the DIT and execute the body + # for each found entry. + + method traverse {base filter attrs entry body} { + + Connected $selfns + + global errorInfo errorCode + + set lastError "" + + # + # Initiate search + # + + set opt [list \ + -scope $options(-scope) \ + -derefaliases $options(-derefaliases) \ + -sizelimit $options(-sizelimit) \ + -timelimit $options(-timelimit) \ + -attrsonly $options(-attrsonly) \ + ] + + ::ldap::searchInit $channel $base $filter $attrs $opt + + # + # Execute the specific body for each result found + # + + while {1} { + # + # The first call to searchNext may fail when searchInit + # is given some invalid parameters. + # We must terminate the current search in order to allow + # future searches. + # + + set err [catch {::ldap::searchNext $channel} r] + + if {$err} then { + set ei $errorInfo + set ec $errorCode + ::ldap::searchEnd $channel + return -code error -errorinfo $ei -errorcode $ec $r + } + + # + # End of result messages + # + + if {[llength $r] == 0} then { + break + } + + # + # Set DN and attributes-values (converted from utf8 if needed) + # for the entry + # + + $entry reset + + $entry dn [lindex $r 0] + $entry setall [$translator decodepairs [lindex $r 1]] + + # + # Execute body with the entry + # + # http://wiki.tcl.tk/685 + # + + set code [catch {uplevel 1 $body} msg] + switch -- $code { + 0 { + # ok + } + 1 { + # error + set ei $errorInfo + set ec $errorCode + ::ldap::searchEnd $channel + return -code error -errorinfo $ei -errorcode $ec $msg + } + 2 { + # return + ::ldap::searchEnd $channel + return -code return $msg + } + 3 { + # break + ::ldap::searchEnd $channel + return {} + } + 4 { + # continue + } + default { + # user defined + ::ldap::searchEnd $channel + return -code $code $msg + } + } + } + + # + # Terminate search + # + + ::ldap::searchEnd $channel + } + + # Returns a list of newly created objects which match + + method search {base filter attrs} { + + Connected $selfns + + set e [::ldapx::entry create %AUTO%] + set r {} + $self traverse $base $filter $attrs $e { + set new [::ldapx::entry create %AUTO%] + $e backup $new + lappend r $new + } + $e destroy + return $r + } + + # Read one or more entries, and returns the number of entries found. + # Useful to easily read one or more entries. + + method read {base filter args} { + + set n 0 + set max [llength $args] + set e [::ldapx::entry create %AUTO%] + $self traverse $base $filter {} $e { + if {$n < $max} then { + $e backup [lindex $args $n] + } + incr n + } + return $n + } + + # Commit a list of changes (or standard, backuped entries) + + method commit {args} { + + Connected $selfns + + foreach entry $args { + switch -- [$entry format] { + uninitialized { + return -code error \ + "Uninitialized entry" + } + standard { + set echg [::ldapx::entry create %AUTO%] + set lchg [$echg diff $entry] + set dn [$echg dn] + $echg destroy + } + change { + set dn [$entry dn] + set lchg [$entry change] + } + } + + foreach chg $lchg { + set op [lindex $chg 0] + + switch -- $op { + {} { + # nothing to do + } + add { + set av [$translator encodepairs [lindex $chg 1]] + if {[Check $selfns {::ldap::addMulti $channel $dn $av}]} then { + return 0 + } + } + del { + if {[Check $selfns {::ldap::delete $channel $dn}]} then { + return 0 + } + } + mod { + set lrep {} + set ldel {} + set ladd {} + + foreach submod [lindex $chg 1] { + set subop [lindex $submod 0] + set attr [lindex $submod 1] + set vals [lindex $submod 2] + + set vals [$translator encode $attr $vals] + switch -- $subop { + modadd { + lappend ladd $attr $vals + } + moddel { + lappend ldel $attr $vals + } + modrepl { + lappend lrep $attr $vals + } + } + } + + if {[Check $selfns {::ldap::modifyMulti $channel $dn \ + $lrep $ldel $ladd}]} then { + return 0 + } + } + modrdn { + set newrdn [lindex $chg 1] + set delOld [lindex $chg 2] + set newSup [lindex $chg 3] + if {[string equal $newSup ""]} then { + if {[Check $selfns {::ldap::modifyDN $channel $dn \ + $newrdn $delOld}]} then { + return 0 + } + } else { + if {[Check $selfns {::ldap::modifyDN $channel $dn \ + $newrdn $delOld $newSup}]} then { + return 0 + } + } + } + } + } + } + + return 1 + } + + ######################################################################### + # Local procedures + ######################################################################### + + proc Connected {selfns} { + if {$channel eq ""} then { + return -code error \ + "Object not connected" + } + } + + proc Check {selfns script} { + return [catch {uplevel 1 $script} lastError] + } + + ######################################################################### + # End of LDAP object type + ######################################################################### +} + +############################################################################## +# LDIF object type +############################################################################## + +snit::type ::ldapx::ldif { + + ######################################################################### + # Options + ######################################################################### + + # + # Fields to ignore when reading change file + # + + option -ignore {} + + component translator + delegate option -utf8 to translator + + + ######################################################################### + # Variables + ######################################################################### + + # + # Version of LDIF file (0 means : uninitialized) + # + + variable version 0 + + # + # Channel descriptor + # + + variable channel "" + + # + # Line number + # + + variable lineno 0 + + # + # Last error message + # + + variable lastError "" + + # + # Number of entries read or written + # + + variable nentries 0 + + # + # Type of LDIF file + # + + variable format "uninitialized" + + ######################################################################### + # Constructor + ######################################################################### + + constructor {args} { + install translator using ::ldapx::utf8trans create %AUTO% + $self configurelist $args + } + + destructor { + catch {$translator destroy} + } + + ######################################################################### + # Methods + ######################################################################### + + # Initialize a channel + + method channel {newchan} { + + set channel $newchan + set version 0 + set nentries 0 + set format "uninitialized" + set lineno 0 + return + } + + # Get or set the last error message + + method error {{le {-}}} { + + if {$le ne "-"} then { + set lastError $le + } + return $lastError + } + + # An LDIF file cannot include both changes and standard entries + # (see RFC 2849, page 2). Check this. + + method compatible {ref} { + + if {$format eq "uninitialized"} then { + set format $ref + } elseif {$format ne $ref} then { + return -code error \ + "Invalid entry ($ref) type for LDIF $format file" + } + } + + # Reads an LDIF entry (standard or change) from the channel + # returns 1 if ok, 0 if error or EOF + + # XXX this method is just coded for tests at this time + + method debugread {entry} { + + $entry compatible "standard" + $entry dn "uid=joe,ou=org,o=com" + $entry setall {uid {joe} sn {User} givenName {Joe} cn {{Joe User}} + telephoneNumber {+31415926535 +27182818285} objectClass {person} + } + return 1 + } + + # Read an LDIF entry (standard or change) from the channel + # returns 1 if ok, 0 if error or EOF + + method read {entry} { + if {$channel eq ""} then { + return -code error \ + "Channel not initialized" + } + + set r [Lexical $selfns] + if {[lindex $r 0] ne "err"} then { + set r [Syntaxic $selfns [lindex $r 1]] + } + + if {[lindex $r 0] eq "err"} then { + set lastError [lindex $r 1] + return 0 + } + + switch -- [lindex $r 0] { + uninitialized { + $entry reset + set lastError "" + set r 0 + } + standard { + if {[catch {$self compatible "change"}]} then { + set lastError "Standard entry not allowed in LDIF change file" + set r 0 + } else { + $entry reset + $entry dn [lindex $r 1] + $entry setall [lindex $r 2] + set r 1 + } + } + change { + if {[catch {$self compatible "change"}]} then { + set lastError "Change entry not allowed in LDIF standard file" + set r 0 + } else { + $entry reset + $entry dn [lindex $r 1] + $entry change [list [lindex $r 2]] + set r 1 + } + } + default { + return -code error \ + "Internal error (invalid returned entry format)" + } + } + + return $r + } + + # Write an LDIF entry to the channel + + method write {entry} { + + if {$channel eq ""} then { + return -code error \ + "Channel not initialized" + } + + switch -- [$entry format] { + uninitialized { + # nothing + } + standard { + if {[llength [$entry getall]]} then { + $self compatible "standard" + + if {$nentries == 0} then { + if {$version == 0} then { + set version 1 + } + WriteLine $selfns "version" "$version" + puts $channel "" + } + + WriteLine $selfns "dn" [$entry dn] + + foreach a [$entry getattr] { + foreach v [$entry get $a] { + WriteLine $selfns $a $v + } + } + puts $channel "" + } + } + change { + $self compatible "change" + + set lchg [$entry change] + foreach chg $lchg { + if {$nentries == 0} then { + if {$version == 0} then { + set version 1 + } + WriteLine $selfns "version" "$version" + puts $channel "" + } + + WriteLine $selfns "dn" [$entry dn] + + set op [lindex $chg 0] + switch -- $op { + add { + WriteLine $selfns "changetype" "add" + foreach {attr vals} [lindex $chg 1] { + foreach v $vals { + WriteLine $selfns $attr $v + } + } + } + del { + WriteLine $selfns "changetype" "delete" + } + mod { + WriteLine $selfns "changetype" "modify" + foreach submod [lindex $chg 1] { + set subop [lindex $submod 0] + set attr [lindex $submod 1] + set vals [lindex $submod 2] + + switch -- $subop { + modadd { + WriteLine $selfns "add" $attr + } + moddel { + WriteLine $selfns "delete" $attr + } + modrepl { + WriteLine $selfns "replace" $attr + } + } + foreach v $vals { + WriteLine $selfns $attr $v + } + puts $channel "-" + } + } + modrdn { + WriteLine $selfns "changetype" "modrdn" + set newrdn [lindex $chg 1] + set delold [lindex $chg 2] + set newsup [lindex $chg 3] + WriteLine $selfns "newrdn" $newrdn + WriteLine $selfns "deleteOldRDN" $delold + if {$newsup ne ""} then { + WriteLine $selfns "newSuperior" $newsup + } + } + } + puts $channel "" + incr nentries + } + } + default { + return -code error \ + "Invalid entry format" + } + } + return 1 + } + + ######################################################################### + # Local procedures to read an entry + ######################################################################### + + # + # Lexical analysis of an entry + # Special case for "version:" entry. + # Returns a list of lines {ok {{<attr1> <val1>} {<attr2> <val2>} ...}} + # or a list {err <message>} + # + + proc Lexical {selfns} { + set result {} + set prev "" + + while {[gets $channel line] > -1} { + incr lineno + + if {$line eq ""} then { + # + # Empty line: we are either before the beginning + # of the entry or at the empty line after the + # entry. + # We don't give up before getting something. + # + + if {! [FlushLine $selfns "" result prev msg]} then { + return [list "err" $msg] + } + + if {[llength $result]} then { + break + } + + } elseif {[regexp {^[ \t]} $line]} then { + # + # Continuation line + # + + append prev [string trim $line] + + } elseif {[regexp {^-$} $line]} then { + # + # Separation between individual modifications + # + + if {! [FlushLine $selfns "" result prev msg]} then { + return [list "err" $msg] + } + lappend result [list "-" {}] + + } else { + # + # Should be a normal line (key: val) + # + + if {! [FlushLine $selfns $line result prev msg]} then { + return [list "err" $msg] + } + + } + } + + # + # End of file, or end of entry. Flush buffered data from $prev + # for EOF case. + # + + if {! [FlushLine $selfns "" result prev msg]} then { + return [list "err" $msg] + } + + return [list "ok" $result] + } + + proc FlushLine {selfns line _result _prev _msg} { + upvar $_result result $_prev prev $_msg msg + + if {$prev ne ""} then { + set r [DecodeLine $selfns $prev] + if {[llength $r] != 2} then { + set msg "$lineno: invalid syntax" + return 0 + } + + # + # Special case for "version: 1". This code should not + # be in lexical analysis, but this would be too disruptive + # in syntaxic analysis + # + + if {[string equal -nocase [lindex $r 0] "version"]} then { + if {$version != 0} then { + set msg "version attribute allowed only at the beginning of the LDIF file" + return 0 + } + set val [lindex $r 1] + if {[catch {set val [expr {$val+0}]}]} then { + set msg "invalid version value" + return 0 + } + if {$val != 1} then { + set msg "unrecognized version '$val'" + return 0 + } + set version 1 + } else { + lappend result $r + } + } + set prev $line + + return 1 + } + + proc DecodeLine {selfns str} { + if {[regexp {^([^:]*)::[ \t]*(.*)} $str d key val]} then { + set key [string tolower $key] + set val [::base64::decode $val] + set val [$translator decode $key $val] + set r [list $key $val] + } elseif {[regexp {^([^:]*):[ \t]*(.*)} $str d key val]} then { + set key [string tolower $key] + set val [$translator decode $key $val] + set r [list $key $val] + } else { + # syntax error + set r {} + } + return $r + } + + # + # Array indexed by current state of the LDIF automaton + # Each element is a list of actions, each with the format: + # pattern on on "attribute:value" + # next state + # script (to be evaled in Syntaxic local procedure) + # + + variable ldifautomaton -array { + begin { + {dn:* dn {set dn $val}} + {EOF:* end {set r [list "empty"]}} + } + dn { + {changetype:modify mod {set t "change" ; set r {mod}}} + {changetype:modrdn modrdn {set t "change" ; set newsup {}}} + {changetype:add add {set t "change"}} + {changetype:delete del {set t "change"}} + {*:* standard {set t "standard" ; lappend tab($key) $val}} + } + standard { + {EOF:* end {set r [array get tab]}} + {*:* standard {lappend tab($key) $val}} + } + mod { + {add:* mod-add {set attr [string tolower $val] ; set vals {}}} + {delete:* mod-del {set attr [string tolower $val] ; set vals {}}} + {replace:* mod-repl {set attr [string tolower $val] ; set vals {}}} + {EOF:* end {}} + } + mod-add { + {*:* mod-add-attr {lappend vals $val}} + } + mod-add-attr { + {-:* mod {lappend r [list "modadd" $attr $vals]}} + {*:* mod-add-attr {lappend vals $val}} + } + mod-del { + {-:* mod {lappend r [list "moddel" $attr $vals]}} + {*:* mod-del {lappend vals $val}} + } + mod-repl { + {-:* mod {lappend r [list "modrepl" $attr $vals]}} + {*:* mod-repl {lappend vals $val}} + } + modrdn { + {newrdn:* modrdn-new {set newrdn $val}} + } + modrdn-new { + {deleteoldrdn:0 modrdn-del {set delold 0}} + {deleteoldrdn:1 modrdn-del {set delold 1}} + } + modrdn-del { + {newsuperior:* modrdn-end {set newsup $val}} + {EOF:* end {set r [list modrdn $newrdn $delold] }} + } + modrdn-end { + {EOF:* end {set r [list modrdn $newrdn $delold $newsup]}} + } + add { + {EOF:* end {set r [list add [array get tab]]}} + {*:* add {lappend tab($key) $val}} + } + del { + {EOF:* end {set r [list del]}} + } + } + + proc Syntaxic {selfns lcouples} { + set state "begin" + set newsup {} + set t "uninitialized" + foreach c $lcouples { + set key [lindex $c 0] + if {[lsearch [string tolower $options(-ignore)] $key] == -1} then { + set val [lindex $c 1] + set a [Automaton $selfns $state $key $val] + if {$a eq ""} then { + return [list "err" "Syntax error before line $lineno"] + } + set state [lindex $a 0] + set script [lindex $a 1] + eval $script + } + } + + set a [Automaton $selfns $state "EOF" "EOF"] + if {$a eq ""} then { + return [list "err" "Premature EOF"] + } + set script [lindex $a 1] + eval $script + + set result [list $t] + switch $t { + uninitialized { + # nothing + } + standard { + lappend result $dn $r + } + change { + lappend result $dn $r + } + } + + return $result + } + + proc Automaton {selfns state key val} { + set r {} + if {[info exists ldifautomaton($state)]} then { + foreach a $ldifautomaton($state) { + if {[string match [lindex $a 0] "$key:$val"]} then { + set r [lreplace $a 0 0] + break + } + } + } + return $r + } + + ######################################################################### + # Local procedures to write an entry + ######################################################################### + + proc WriteLine {selfns attr val} { + + if {[string is ascii $val] && [string is print $val]} then { + set sep ":" + } else { + set sep "::" + set val [$translator encode $attr $val] + set val [::base64::encode $val] + } + + set first 1 + foreach line [split $val "\n"] { + if {$first} then { + puts $channel "$attr$sep $line" + set first 0 + } else { + puts $channel " $line" + } + } + } +} diff --git a/tcllib/modules/ldap/ldapx.test b/tcllib/modules/ldap/ldapx.test new file mode 100644 index 0000000..cfdfd30 --- /dev/null +++ b/tcllib/modules/ldap/ldapx.test @@ -0,0 +1,375 @@ +# -*- tcl -*- +# ldapx.test: tests for the ldapx module. +# +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2006 by Pierre David <pdav@users.sourceforge.net> +# All rights reserved. +# +# $Id: ldapx.test,v 1.6 2007/08/19 20:20:43 pdav Exp $ + +# ------------------------------------------------------------------------- + + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 1.0 + +testing { + useLocal ldapx.tcl ldapx +} + +# ------------------------------------------------------------------------- + +set rdn1 "uid=test" +set rdn2 "uid=test2" +set sup1 "ou=mydept,o=myorg" +set sup2 "ou=x,$sup1" + +set entry {a1 {v11 v12} a2 {v21} a3 {v31 v32 v33}} + +# ------------------------------------------------------------------------- + +test ldapx-1.0 {ldapx::entry - creation} { + ::ldapx::entry create t1 +} {::t1} + +test ldapx-1.1 {ldapx::entry - reset} { + t1 reset + t1 format +} {uninitialized} + +test ldapx-1.2 {ldapx::entry - dn} { + t1 dn "$rdn1,$sup1" + t1 dn +} "$rdn1,$sup1" + +test ldapx-1.3 {ldapx::entry - superior} { + t1 dn "$rdn1,$sup1" + t1 superior +} $sup1 + +test ldapx-1.4 {ldapx::entry - rdn} { + t1 rdn +} $rdn1 + +test ldapx-1.5 {ldapx::entry - print uninitialized} { + t1 print +} "dn: $rdn1,$sup1" + +test ldapx-2.1 {ldapx::entry - standard} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + lsort [t1 getall] +} [lsort $entry] + +test ldapx-2.2 {ldapx::entry - isempty} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + set e1 [t1 isempty] + ::ldapx::entry create t2 + set e2 [t2 isempty] + t2 destroy + list $e1 $e2 +} {0 1} + +test ldapx-2.3 {ldapx::entry - set1/get1} { + t1 set1 A4 v41 + t1 get1 A4 +} {v41} + +test ldapx-2.4 {ldapx::entry - add1} { + t1 add1 a4 {v 42} + t1 get A4 +} {v41 {v 42}} + +test ldapx-2.5 {ldapx::entry - set/add/get} { + t1 set a5 {v51} + t1 add a5 {{v 52} {v 53}} + t1 get a5 +} {v51 {v 52} {v 53}} + +test ldapx-2.6 {ldapx::entry - del1/del} { + t1 del1 A5 {v 52} + t1 del a5 {{v 53}} + t1 get a5 +} {v51} + +test ldapx-2.7 {ldapx::entry - del} { + t1 del A5 + t1 get a5 +} {} + +test ldapx-2.8 {ldapx::entry - getattr} { + lsort [t1 getattr] +} {a1 a2 a3 a4} + + +test ldapx-3.1 {ldapx::entry - backup toanother} { + ::ldapx::entry create t2 + ::ldapx::entry create t3 + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t1 backup t2 + t3 diff t1 t2 + t3 change +} {} + +test ldapx-3.2 {ldapx::entry - diff toanother modrdn uid deleteoldrdn} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t1 set1 "uid" "test" + t1 backup t2 + t1 dn "$rdn2,$sup1" + t1 set1 "uid" "test2" + t3 diff t1 t2 + t3 change +} [list [list modrdn $rdn2 1]] + +test ldapx-3.3 {ldapx::entry - diff toanother modrdn uid keepoldrdn} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t1 set1 "uid" "test" + t1 backup t2 + t1 dn "$rdn2,$sup1" + t1 add1 "uid" "test2" + t3 diff t1 t2 + t3 change +} [list [list modrdn $rdn2 0]] + +test ldapx-3.4 {ldapx::entry - diff toanother modrdn superior} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t1 backup t2 + t1 dn "$rdn1,$sup2" + t3 diff t1 t2 + t3 change +} [list [list modrdn $rdn1 0 $sup2]] + +test ldapx-3.5 {ldapx::entry - diff toanother add attr} { + t1 reset + t1 setall $entry + t1 backup t2 + t1 set anotherAttribute {v1 v2} + t3 diff t1 t2 + t3 change +} {{mod {{modadd anotherattribute {v1 v2}}}}} + +test ldapx-3.6 {ldapx::entry - diff toanother repl attr} { + t1 reset + t1 setall $entry + t1 backup t2 + t1 del1 a3 v32 + t3 diff t1 t2 + t3 change +} {{mod {{modrepl a3 {v31 v33}}}}} + +test ldapx-3.7 {ldapx::entry - diff toanother add value} { + t1 reset + t1 setall $entry + t1 backup t2 + t1 add1 a3 v34 + t3 diff t1 t2 + t3 change +} {{mod {{modrepl a3 {v31 v32 v33 v34}}}}} + +test ldapx-3.8 {ldapx::entry - diff toanother del attr} { + t1 reset + t1 setall $entry + t1 backup t2 + t1 del A3 + t3 diff t1 t2 + t3 change +} {{mod {{moddel a3}}}} + +test ldapx-3.9 {ldapx::entry - diff toanother del entry 1} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t1 backup t2 + t1 setall {} + t3 diff t1 t2 + list [t3 dn] [lindex [t3 change] 0 0] +} [list "$rdn1,$sup1" del] + +test ldapx-3.10 {ldapx::entry - diff toanother del entry 2} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t1 backup t2 + t1 dn "" + t1 setall {} + t3 diff t1 t2 + list [t3 dn] [lindex [t3 change] 0 0] +} [list "$rdn1,$sup1" del] + +test ldapx-3.11 {ldapx::entry - diff toanother add entry} { + t1 reset + t1 setall {} + t1 backup t2 + t1 setall $entry + t3 diff t1 t2 + lsort [list [lindex [t3 change] 0 0] \ + [lsort [lindex [t3 change] 0 1]]] +} [lsort [list add [lsort [string tolower $entry]]]] + +test ldapx-3.12 {ldapx::entry - diff toanother add entry dn 1} { + t1 reset + t1 backup t2 + t1 dn "$rdn1,$sup1" + t1 setall $entry + t3 diff t1 t2 + list [t3 dn] [lindex [t3 change] 0 0] +} [list "$rdn1,$sup1" add] + +test ldapx-3.13 {ldapx::entry - diff toanother add entry dn 2} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 backup t2 + t1 setall $entry + t3 diff t1 t2 + list [t3 dn] [lindex [t3 change] 0 0] +} [list "$rdn1,$sup1" add] + + +test ldapx-3.14 {ldapx::entry - diff tothesame} { + t1 reset + t1 setall $entry + t1 backup + t1 set1 A3 v34 + t3 diff t1 + t3 change +} {{mod {{modrepl a3 v34}}}} + +test ldapx-3.15 {ldapx::entry - restore toanother} { + t1 reset + t1 setall {a v} + t1 backup + t1 restore t2 + t2 getall +} {a v} + +test ldapx-3.16 {ldapx::entry - restore tothesame} { + t1 reset + t1 setall {a v} + t1 backup + t1 setall $entry + t1 restore + t1 getall +} {a v} + +test ldapx-3.17 {ldapx::entry - swap} { + t1 reset + t1 setall {a v} + t1 dn d1 + t1 backup + t1 setall {b w} + t1 dn d2 + t1 swap + set l1 [list [t1 dn] [t1 getall]] + t1 swap + set l2 [list [t1 dn] [t1 getall]] + list $l1 $l2 +} {{d1 {a v}} {d2 {b w}}} + +test ldapx-3.18 {ldapx::entry - apply modrdn rdn} { + t1 reset + t1 dn "$rdn1,$sup1" + t2 reset + t2 dn "$rdn1,$sup1" + t2 change [list [list modrdn $rdn2 0]] + t1 apply t2 + t1 dn +} "$rdn2,$sup1" + +test ldapx-3.19 {ldapx::entry - apply modrdn superior} { + t1 reset + t1 dn "$rdn1,$sup1" + t2 reset + t2 dn "$rdn1,$sup1" + t2 change [list [list modrdn $rdn1 0 $sup2]] + t1 apply t2 + t1 dn +} "$rdn1,$sup2" + +test ldapx-3.20 {ldapx::entry - apply modrdn rdn+superior} { + t1 reset + t1 dn "$rdn1,$sup1" + t2 reset + t2 dn "$rdn1,$sup1" + t2 change [list [list modrdn $rdn2 0 $sup2]] + t1 apply t2 + t1 dn +} "$rdn2,$sup2" + +test ldapx-3.21 {ldapx::entry - apply add} { + t1 reset + t2 reset + t2 dn "$rdn1,$sup1" + t2 change [list [list add $entry]] + t1 apply t2 + lsort [t1 getall] +} [lsort $entry] + +test ldapx-3.22 {ldapx::entry - apply del} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t2 reset + t2 dn "$rdn1,$sup1" + t2 change {{del}} + t1 apply t2 + lsort [t1 getall] +} {} + +test ldapx-3.23 {ldapx::entry - apply mod add} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t2 reset + t2 dn "$rdn1,$sup1" + t2 change {{mod {{modadd A4 {v41 v42}}}}} + t1 apply t2 + t1 get a4 +} {v41 v42} + +test ldapx-3.24 {ldapx::entry - apply mod del} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t2 reset + t2 dn "$rdn1,$sup1" + t2 change {{mod {{moddel A3}}}} + t1 apply t2 + t1 get a3 +} {} + +test ldapx-3.25 {ldapx::entry - apply mod repl} { + t1 reset + t1 dn "$rdn1,$sup1" + t1 setall $entry + t2 reset + t2 dn "$rdn1,$sup1" + t2 change {{mod {{modrepl A3 {v34 v35}}}}} + t1 apply t2 + t1 get a3 +} {v34 v35} + +test ldapx-4.1 {ldapx::entry - deletion} { + t1 destroy + t2 destroy + t3 destroy +} {} + + +testsuiteCleanup diff --git a/tcllib/modules/ldap/pkgIndex.tcl b/tcllib/modules/ldap/pkgIndex.tcl new file mode 100644 index 0000000..29c1b46 --- /dev/null +++ b/tcllib/modules/ldap/pkgIndex.tcl @@ -0,0 +1,7 @@ +# Tcl package index file, version 1.1 + +if {![package vsatisfies [package provide Tcl] 8.4]} {return} +package ifneeded ldap 1.8 [list source [file join $dir ldap.tcl]] + +# the OO level wrapper for ldap +package ifneeded ldapx 1.0 [list source [file join $dir ldapx.tcl]] |