2 * NeoSoft Tcl client extensions to Lightweight Directory Access Protocol.
4 * Copyright (c) 1998-1999 NeoSoft, Inc.
7 * This software may be used, modified, copied, distributed, and sold,
8 * in both source and binary form provided that these copyrights are
9 * retained and their terms are followed.
11 * Under no circumstances are the authors or NeoSoft Inc. responsible
12 * for the proper functioning of this software, nor do the authors
13 * assume any liability for damages incurred with its use.
15 * Redistribution and use in source and binary forms are permitted
16 * provided that this notice is preserved and that due credit is given
19 * NeoSoft, Inc. may not be used to endorse or promote products derived
20 * from this software without specific prior written permission. This
21 * software is provided ``as is'' without express or implied warranty.
23 * Requests for permission may be sent to NeoSoft Inc, 1770 St. James Place,
24 * Suite 500, Houston, TX, 77056.
31 * This code was originally developed by Karl Lehenbauer to work with
32 * Umich-3.3 LDAP. It was debugged against the Netscape LDAP server
33 * and their much more reliable SDK, and again backported to the
34 * Umich-3.3 client code. The UMICH_LDAP define is used to include
35 * code that will work with the Umich-3.3 LDAP, but not with Netscape's
36 * SDK. OpenLDAP may support some of these, but they have not been tested.
37 * Currently supported by Randy Kunkee (kunkee@OpenLDAP.org).
41 * Add timeout to controlArray to set timeout for ldap_result.
45 #include "tclExtend.h"
54 * Macros to do string compares. They pre-check the first character before
55 * checking of the strings are equal.
58 #define STREQU(str1, str2) \
59 (((str1) [0] == (str2) [0]) && (strcmp (str1, str2) == 0))
60 #define STRNEQU(str1, str2, n) \
61 (((str1) [0] == (str2) [0]) && (strncmp (str1, str2, n) == 0))
64 * The following section defines some common macros used by the rest
65 * of the code. It's ugly, and can use some work. This code was
66 * originally developed to work with Umich-3.3 LDAP. It was debugged
67 * against the Netscape LDAP server and the much more reliable SDK,
68 * and then again backported to the Umich-3.3 client code.
71 #if defined(OPEN_LDAP)
72 /* LDAP_API_VERSION must be defined per the current draft spec
73 ** it's value will be assigned RFC number. However, as
74 ** no RFC is defined, it's value is currently implementation
75 ** specific (though I would hope it's value is greater than 1823).
76 ** In OpenLDAP 2.x-devel, its 2000 + the draft number, ie 2002.
77 ** This section is for OPENLDAP.
79 #define ldap_memfree(p) free(p)
80 #ifdef LDAP_OPT_ERROR_NUMBER
81 #define ldap_get_lderrno(ld) (ldap_get_option(ld, LDAP_OPT_ERROR_NUMBER, &lderrno), lderrno)
83 #define ldap_get_lderrno(ld) (ld->ld_errno)
85 #define LDAP_ERR_STRING(ld) \
86 ldap_err2string(ldap_get_lderrno(ld))
87 #elif defined( LDAP_OPT_SIZELIMIT )
89 ** Netscape SDK w/ ldap_set_option, ldap_get_option
91 #define LDAP_ERR_STRING(ld) \
92 ldap_err2string(ldap_get_lderrno(ldap))
94 /* U-Mich/OpenLDAP 1.x API */
95 /* RFC-1823 w/ changes */
97 #define ldap_memfree(p) free(p)
98 #define ldap_ber_free(p, n) ber_free(p, n)
99 #define ldap_value_free_len(bvals) ber_bvecfree(bvals)
100 #define ldap_get_lderrno(ld) (ld->ld_errno)
101 #define LDAP_ERR_STRING(ld) \
102 ldap_err2string(ld->ld_errno)
105 typedef struct ldaptclobj {
107 int caching; /* flag 1/0 if caching is enabled */
108 long timeout; /* timeout from last cache enable */
109 long maxmem; /* maxmem from last cache enable */
110 Tcl_Obj *trapCmdObj; /* error handler */
111 int *traplist; /* list of errorCodes to trap */
116 #define LDAPTCL_INTERRCODES 0x001
118 #include "ldaptclerr.h"
121 LDAP_SetErrorCode(LDAPTCL *ldaptcl, int code, Tcl_Interp *interp)
128 code = ldap_get_lderrno(ldaptcl->ldap);
129 if ((ldaptcl->flags & LDAPTCL_INTERRCODES) || code > LDAPTCL_MAXERR ||
130 ldaptclerrorcode[code] == NULL) {
131 sprintf(shortbuf, "0x%03x", code);
134 errp = ldaptclerrorcode[code];
136 Tcl_SetErrorCode(interp, errp, NULL);
137 if (ldaptcl->trapCmdObj) {
140 if (ldaptcl->traplist != NULL) {
141 for (i = ldaptcl->traplist; *i && *i != code; i++)
145 (void) Tcl_EvalObj(interp, ldaptcl->trapCmdObj);
150 LDAP_ErrorStringToCode(Tcl_Interp *interp, char *s)
155 offset = (strncasecmp(s, "LDAP_", 5) == 0) ? 0 : 5;
156 for (code = 0; code < LDAPTCL_MAXERR; code++) {
157 if (!ldaptclerrorcode[code]) continue;
158 if (strcasecmp(s, ldaptclerrorcode[code]+offset) == 0)
161 Tcl_ResetResult(interp);
162 Tcl_AppendResult(interp, s, " is an invalid code", (char *) NULL);
166 /*-----------------------------------------------------------------------------
167 * LDAP_ProcessOneSearchResult --
169 * Process one result return from an LDAP search.
172 * o interp - Tcl interpreter; Errors are returned in result.
173 * o ldap - LDAP structure pointer.
174 * o entry - LDAP message pointer.
175 * o destArrayNameObj - Name of Tcl array in which to store attributes.
176 * o evalCodeObj - Tcl_Obj pointer to code to eval against this result.
178 * o TCL_OK if processing succeeded..
179 * o TCL_ERROR if an error occured, with error message in interp.
180 *-----------------------------------------------------------------------------
183 LDAP_ProcessOneSearchResult (interp, ldap, entry, destArrayNameObj, evalCodeObj)
187 Tcl_Obj *destArrayNameObj;
188 Tcl_Obj *evalCodeObj;
191 Tcl_Obj *attributeNameObj;
192 Tcl_Obj *attributeDataObj;
195 struct berval **bvals;
199 Tcl_UnsetVar (interp, Tcl_GetStringFromObj (destArrayNameObj, NULL), 0);
201 dn = ldap_get_dn(ldap, entry);
203 if (Tcl_SetVar2(interp, /* set dn */
204 Tcl_GetStringFromObj(destArrayNameObj, NULL),
207 TCL_LEAVE_ERR_MSG) == NULL)
211 attributeNameObj = Tcl_NewObj();
212 Tcl_IncrRefCount (attributeNameObj);
213 for (attributeName = ldap_first_attribute (ldap, entry, &ber);
214 attributeName != NULL;
215 attributeName = ldap_next_attribute(ldap, entry, ber)) {
217 bvals = ldap_get_values_len(ldap, entry, attributeName);
220 /* Note here that the U.of.M. ldap will return a null bvals
221 when the last attribute value has been deleted, but still
222 retains the attributeName. Even though this is documented
223 as an error, we ignore it to present a consistent interface
224 with Netscape's server
226 attributeDataObj = Tcl_NewObj();
227 Tcl_SetStringObj(attributeNameObj, attributeName, -1);
228 for (i = 0; bvals[i] != NULL; i++) {
229 Tcl_Obj *singleAttributeValueObj;
231 singleAttributeValueObj = Tcl_NewStringObj(bvals[i]->bv_val, bvals[i]->bv_len);
232 if (Tcl_ListObjAppendElement (interp,
234 singleAttributeValueObj)
241 ldap_value_free_len(bvals);
243 if (Tcl_ObjSetVar2 (interp,
247 TCL_LEAVE_ERR_MSG) == NULL) {
252 Tcl_DecrRefCount (attributeNameObj);
253 return Tcl_EvalObj (interp, evalCodeObj);
256 /*-----------------------------------------------------------------------------
257 * LDAP_PerformSearch --
259 * Perform an LDAP search.
262 * o interp - Tcl interpreter; Errors are returned in result.
263 * o ldap - LDAP structure pointer.
264 * o base - Base DN from which to perform search.
265 * o scope - LDAP search scope, must be one of LDAP_SCOPE_BASE,
266 * LDAP_SCOPE_ONELEVEL, or LDAP_SCOPE_SUBTREE.
267 * o attrs - Pointer to array of char * pointers of desired
268 * attribute names, or NULL for all attributes.
269 * o filtpatt LDAP filter pattern.
270 * o value Value to get sprintf'ed into filter pattern.
271 * o destArrayNameObj - Name of Tcl array in which to store attributes.
272 * o evalCodeObj - Tcl_Obj pointer to code to eval against this result.
274 * o TCL_OK if processing succeeded..
275 * o TCL_ERROR if an error occured, with error message in interp.
276 *-----------------------------------------------------------------------------
279 LDAP_PerformSearch (interp, ldaptcl, base, scope, attrs, filtpatt, value,
280 destArrayNameObj, evalCodeObj, timeout_p, all, sortattr)
288 Tcl_Obj *destArrayNameObj;
289 Tcl_Obj *evalCodeObj;
290 struct timeval *timeout_p;
294 LDAP *ldap = ldaptcl->ldap;
299 int tclResult = TCL_OK;
301 LDAPMessage *resultMessage = 0;
302 LDAPMessage *entryMessage = 0;
307 sprintf(filter, filtpatt, value);
310 if ((msgid = ldap_search (ldap, base, scope, filter, attrs, 0)) == -1) {
311 Tcl_AppendResult (interp,
312 "LDAP start search error: ",
313 LDAP_ERR_STRING(ldap),
315 LDAP_SetErrorCode(ldaptcl, -1, interp);
324 resultCode = ldap_result (ldap, msgid, all, timeout_p, &resultMessage);
325 if (resultCode != LDAP_RES_SEARCH_RESULT &&
326 resultCode != LDAP_RES_SEARCH_ENTRY)
330 sortKey = (strcasecmp(sortattr, "dn") == 0) ? NULL : sortattr;
331 ldap_sort_entries(ldap, &resultMessage, sortKey, strcasecmp);
333 entryMessage = ldap_first_entry(ldap, resultMessage);
335 while (entryMessage) {
336 tclResult = LDAP_ProcessOneSearchResult (interp,
341 if (tclResult != TCL_OK) {
342 if (tclResult == TCL_CONTINUE) {
344 } else if (tclResult == TCL_BREAK) {
348 } else if (tclResult == TCL_ERROR) {
350 sprintf(msg, "\n (\"search\" body line %d)",
352 Tcl_AddObjErrorInfo(interp, msg, -1);
360 entryMessage = ldap_next_entry(ldap, entryMessage);
362 if (resultCode == LDAP_RES_SEARCH_RESULT || all)
365 ldap_msgfree(resultMessage);
366 resultMessage = NULL;
370 ldap_msgfree(resultMessage);
371 if (resultCode == LDAP_RES_SEARCH_ENTRY)
372 ldap_abandon(ldap, msgid);
375 if (resultCode == -1) {
376 Tcl_ResetResult (interp);
377 Tcl_AppendResult (interp,
378 "LDAP result search error: ",
379 LDAP_ERR_STRING(ldap),
381 LDAP_SetErrorCode(ldaptcl, -1, interp);
385 if ((errorCode = ldap_result2error (ldap, resultMessage, 0))
387 Tcl_ResetResult (interp);
388 Tcl_AppendResult (interp,
389 "LDAP search error: ",
390 ldap_err2string(errorCode),
393 ldap_msgfree(resultMessage);
394 LDAP_SetErrorCode(ldaptcl, errorCode, interp);
398 ldap_msgfree(resultMessage);
402 /*-----------------------------------------------------------------------------
403 * NeoX_LdapTargetObjCmd --
405 * Implements the body of commands created by Neo_LdapObjCmd.
408 * A standard Tcl result.
411 * See the user documentation.
412 *-----------------------------------------------------------------------------
415 NeoX_LdapTargetObjCmd (clientData, interp, objc, objv)
416 ClientData clientData;
419 Tcl_Obj *CONST objv[];
423 LDAPTCL *ldaptcl = (LDAPTCL *)clientData;
424 LDAP *ldap = ldaptcl->ldap;
427 int is_add_or_modify = 0;
429 char *m, *s, *errmsg;
433 Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
436 return TclX_WrongArgs (interp,
438 "subcommand [args...]");
440 command = Tcl_GetStringFromObj (objv[0], NULL);
441 subCommand = Tcl_GetStringFromObj (objv[1], NULL);
443 /* object bind authtype name password */
444 if (STREQU (subCommand, "bind")) {
448 char *ldap_authString;
452 return TclX_WrongArgs (interp, objv [0], "bind authtype dn passwd");
454 ldap_authString = Tcl_GetStringFromObj (objv[2], NULL);
456 if (STREQU (ldap_authString, "simple")) {
457 ldap_authInt = LDAP_AUTH_SIMPLE;
460 else if (STREQU (ldap_authString, "kerberos_ldap")) {
461 ldap_authInt = LDAP_AUTH_KRBV41;
462 } else if (STREQU (ldap_authString, "kerberos_dsa")) {
463 ldap_authInt = LDAP_AUTH_KRBV42;
464 } else if (STREQU (ldap_authString, "kerberos_both")) {
465 ldap_authInt = LDAP_AUTH_KRBV4;
469 Tcl_AppendStringsToObj (resultObj,
475 "\" authtype must be one of \"simple\", ",
476 "\"kerberos_ldap\", \"kerberos_dsa\" ",
477 "or \"kerberos_both\"",
479 "\" authtype must be \"simple\", ",
485 binddn = Tcl_GetStringFromObj (objv[3], &stringLength);
486 if (stringLength == 0)
489 passwd = Tcl_GetStringFromObj (objv[4], &stringLength);
490 if (stringLength == 0)
493 /* ldap_bind_s(ldap, dn, pw, method) */
496 #define LDAP_BIND(ldap, dn, pw, method) \
497 ldap_bind_s(ldap, dn, pw, method)
499 #define LDAP_BIND(ldap, dn, pw, method) \
500 ldap_simple_bind_s(ldap, dn, pw)
502 if ((errcode = LDAP_BIND (ldap,
505 ldap_authInt)) != LDAP_SUCCESS) {
507 Tcl_AppendStringsToObj (resultObj,
509 ldap_err2string(errcode),
511 LDAP_SetErrorCode(ldaptcl, errcode, interp);
517 if (STREQU (subCommand, "unbind")) {
519 return TclX_WrongArgs (interp, objv [0], "unbind");
521 return Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], NULL));
524 /* object delete dn */
525 if (STREQU (subCommand, "delete")) {
527 return TclX_WrongArgs (interp, objv [0], "delete dn");
529 dn = Tcl_GetStringFromObj (objv [2], NULL);
530 if ((errcode = ldap_delete_s(ldap, dn)) != LDAP_SUCCESS) {
531 Tcl_AppendStringsToObj (resultObj,
532 "LDAP delete error: ",
533 ldap_err2string(errcode),
535 LDAP_SetErrorCode(ldaptcl, errcode, interp);
541 /* object rename_rdn dn rdn */
542 /* object modify_rdn dn rdn */
543 if (STREQU (subCommand, "rename_rdn") || STREQU (subCommand, "modify_rdn")) {
548 return TclX_WrongArgs (interp,
550 "delete_rdn|modify_rdn dn rdn");
552 dn = Tcl_GetStringFromObj (objv [2], NULL);
553 rdn = Tcl_GetStringFromObj (objv [3], NULL);
555 deleteOldRdn = (*subCommand == 'r');
557 if ((errcode = ldap_modrdn2_s (ldap, dn, rdn, deleteOldRdn)) != LDAP_SUCCESS) {
558 Tcl_AppendStringsToObj (resultObj,
562 ldap_err2string(errcode),
564 LDAP_SetErrorCode(ldaptcl, errcode, interp);
570 /* object add dn attributePairList */
571 /* object add_attributes dn attributePairList */
572 /* object replace_attributes dn attributePairList */
573 /* object delete_attributes dn attributePairList */
575 if (STREQU (subCommand, "add")) {
577 is_add_or_modify = 1;
580 if (STREQU (subCommand, "add_attributes")) {
581 is_add_or_modify = 1;
582 mod_op = LDAP_MOD_ADD;
583 } else if (STREQU (subCommand, "replace_attributes")) {
584 is_add_or_modify = 1;
585 mod_op = LDAP_MOD_REPLACE;
586 } else if (STREQU (subCommand, "delete_attributes")) {
587 is_add_or_modify = 1;
588 mod_op = LDAP_MOD_DELETE;
592 if (is_add_or_modify) {
596 char **valPtrs = NULL;
598 Tcl_Obj **attribObjv;
600 Tcl_Obj **valuesObjv;
605 Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
608 Tcl_AppendStringsToObj (resultObj,
610 Tcl_GetStringFromObj (objv [0], NULL),
613 " dn attributePairList",
618 dn = Tcl_GetStringFromObj (objv [2], NULL);
620 if (Tcl_ListObjGetElements (interp, objv [3], &attribObjc, &attribObjv)
625 if (attribObjc & 1) {
626 Tcl_AppendStringsToObj (resultObj,
627 "attribute list does not contain an ",
628 "even number of key-value elements",
633 nPairs = attribObjc / 2;
635 modArray = (LDAPMod **)malloc (sizeof(LDAPMod *) * (nPairs + 1));
636 modArray[nPairs] = (LDAPMod *) NULL;
638 for (i = 0; i < nPairs; i++) {
639 mod = modArray[i] = (LDAPMod *) malloc (sizeof(LDAPMod));
640 mod->mod_op = mod_op;
641 mod->mod_type = Tcl_GetStringFromObj (attribObjv [i * 2], NULL);
643 if (Tcl_ListObjGetElements (interp, attribObjv [i * 2 + 1], &valuesObjc, &valuesObjv) == TCL_ERROR) {
644 /* FIX: cleanup memory here */
648 valPtrs = mod->mod_vals.modv_strvals = \
649 (char **)malloc (sizeof (char *) * (valuesObjc + 1));
650 valPtrs[valuesObjc] = (char *)NULL;
652 for (j = 0; j < valuesObjc; j++) {
653 valPtrs [j] = Tcl_GetStringFromObj (valuesObjv[j], NULL);
655 /* If it's "delete" and value is an empty string, make
656 * value be NULL to indicate entire attribute is to be
658 if ((*valPtrs [j] == '\0')
659 && (mod->mod_op == LDAP_MOD_DELETE || mod->mod_op == LDAP_MOD_REPLACE)) {
666 result = ldap_add_s (ldap, dn, modArray);
668 result = ldap_modify_s (ldap, dn, modArray);
669 if (ldaptcl->caching)
670 ldap_uncache_entry (ldap, dn);
673 /* free the modArray elements, then the modArray itself. */
674 for (i = 0; i < nPairs; i++) {
675 free ((char *) modArray[i]->mod_vals.modv_strvals);
676 free ((char *) modArray[i]);
678 free ((char *) modArray);
680 /* FIX: memory cleanup required all over the place here */
681 if (result != LDAP_SUCCESS) {
682 Tcl_AppendStringsToObj (resultObj,
686 ldap_err2string(result),
688 LDAP_SetErrorCode(ldaptcl, result, interp);
694 /* object search controlArray dn pattern */
695 if (STREQU (subCommand, "search")) {
696 char *controlArrayName;
697 Tcl_Obj *controlArrayNameObj;
707 char **attributesArray;
708 char *attributesString;
711 char *filterPatternString;
715 struct timeval timeout, *timeout_p;
723 Tcl_Obj *destArrayNameObj;
724 Tcl_Obj *evalCodeObj;
727 return TclX_WrongArgs (interp,
729 "search controlArray destArray code");
731 controlArrayNameObj = objv [2];
732 controlArrayName = Tcl_GetStringFromObj (controlArrayNameObj, NULL);
734 destArrayNameObj = objv [3];
736 evalCodeObj = objv [4];
738 baseString = Tcl_GetVar2 (interp,
743 if (baseString == (char *)NULL) {
744 Tcl_AppendStringsToObj (resultObj,
745 "required element \"base\" ",
746 "is missing from ldap control array \"",
753 filterPatternString = Tcl_GetVar2 (interp,
757 if (filterPatternString == (char *)NULL) {
758 filterPatternString = "(objectclass=*)";
761 /* Fetch scope setting from control array.
762 * If it doesn't exist, default to subtree scoping.
764 scopeString = Tcl_GetVar2 (interp, controlArrayName, "scope", 0);
765 if (scopeString == NULL) {
766 scope = LDAP_SCOPE_SUBTREE;
768 if (STREQU(scopeString, "base"))
769 scope = LDAP_SCOPE_BASE;
770 else if (STRNEQU(scopeString, "one", 3))
771 scope = LDAP_SCOPE_ONELEVEL;
772 else if (STRNEQU(scopeString, "sub", 3))
773 scope = LDAP_SCOPE_SUBTREE;
775 Tcl_AppendStringsToObj (resultObj,
776 "\"scope\" element of \"",
778 "\" array is not one of ",
779 "\"base\", \"onelevel\", ",
786 /* Fetch dereference control setting from control array.
787 * If it doesn't exist, default to never dereference. */
788 derefString = Tcl_GetVar2 (interp,
793 if (derefString == (char *)NULL) {
794 deref = LDAP_DEREF_NEVER;
796 if (STREQU(derefString, "never"))
797 deref = LDAP_DEREF_NEVER;
798 else if (STREQU(derefString, "search"))
799 deref = LDAP_DEREF_SEARCHING;
800 else if (STREQU(derefString, "find"))
801 deref = LDAP_DEREF_FINDING;
802 else if (STREQU(derefString, "always"))
803 deref = LDAP_DEREF_ALWAYS;
805 Tcl_AppendStringsToObj (resultObj,
806 "\"deref\" element of \"",
808 "\" array is not one of ",
809 "\"never\", \"search\", \"find\", ",
816 /* Fetch list of attribute names from control array.
817 * If entry doesn't exist, default to NULL (all).
819 attributesString = Tcl_GetVar2 (interp,
823 if (attributesString == (char *)NULL) {
824 attributesArray = NULL;
826 if ((Tcl_SplitList (interp,
829 &attributesArray)) != TCL_OK) {
834 /* Fetch timeout value if there is one
836 timeoutString = Tcl_GetVar2 (interp,
841 if (timeoutString == (char *)NULL) {
845 if (Tcl_GetDouble(interp, timeoutString, &timeoutTime) != TCL_OK)
847 timeout.tv_sec = floor(timeoutTime);
848 timeout.tv_usec = (timeoutTime-timeout.tv_sec) * 1000000;
849 timeout_p = &timeout;
852 paramString = Tcl_GetVar2 (interp, controlArrayName, "cache", 0);
854 if (Tcl_GetInt(interp, paramString, &cacheThis) == TCL_ERROR)
858 paramString = Tcl_GetVar2 (interp, controlArrayName, "all", 0);
860 if (Tcl_GetInt(interp, paramString, &all) == TCL_ERROR)
864 sortattr = Tcl_GetVar2 (interp, controlArrayName, "sort", 0);
867 ldap->ld_deref = deref;
868 ldap->ld_timelimit = 0;
869 ldap->ld_sizelimit = 0;
870 ldap->ld_options = 0;
873 /* Caching control within the search: if the "cache" control array */
874 /* value is set, disable/enable caching accordingly */
877 if (cacheThis >= 0 && ldaptcl->caching != cacheThis) {
879 if (ldaptcl->timeout == 0) {
880 Tcl_SetStringObj(resultObj, "Caching never before enabled, I have no timeout value to use", -1);
883 ldap_enable_cache(ldap, ldaptcl->timeout, ldaptcl->maxmem);
886 ldap_disable_cache(ldap);
890 ldap_set_option(ldap, LDAP_OPT_DEREF, &deref);
892 tclResult = LDAP_PerformSearch (interp,
904 /* Following the search, if we changed the caching behavior, change */
907 if (cacheThis >= 0 && ldaptcl->caching != cacheThis) {
909 ldap_disable_cache(ldap);
911 ldap_enable_cache(ldap, ldaptcl->timeout, ldaptcl->maxmem);
913 deref = LDAP_DEREF_NEVER;
914 ldap_set_option(ldap, LDAP_OPT_DEREF, &deref);
919 /* object compare dn attr value */
920 if (STREQU (subCommand, "compare")) {
928 return TclX_WrongArgs (interp,
930 "compare dn attribute value");
932 dn = Tcl_GetStringFromObj (objv[2], NULL);
933 attr = Tcl_GetStringFromObj (objv[3], NULL);
934 value = Tcl_GetStringFromObj (objv[4], NULL);
936 result = ldap_compare_s (ldap, dn, attr, value);
937 if (result == LDAP_COMPARE_TRUE || result == LDAP_COMPARE_FALSE) {
938 Tcl_SetIntObj(resultObj, result == LDAP_COMPARE_TRUE);
941 LDAP_SetErrorCode(ldaptcl, result, interp);
942 Tcl_AppendStringsToObj (resultObj,
943 "LDAP compare error: ",
944 LDAP_ERR_STRING(ldap),
949 #if defined(UMICH_LDAP) || (defined(OPEN_LDAP) && !defined(LDAP_API_VERSION))
950 if (STREQU (subCommand, "cache")) {
955 return TclX_WrongArgs (interp,
957 "cache command [args...]");
959 cacheCommand = Tcl_GetStringFromObj (objv [2], NULL);
961 if (STREQU (cacheCommand, "uncache")) {
965 return TclX_WrongArgs (interp,
969 dn = Tcl_GetStringFromObj (objv [3], NULL);
970 ldap_uncache_entry (ldap, dn);
974 if (STREQU (cacheCommand, "enable")) {
975 long timeout = ldaptcl->timeout;
976 long maxmem = ldaptcl->maxmem;
979 return TclX_WrongArgs (interp,
981 "cache enable ?timeout? ?maxmem?");
984 if (Tcl_GetLongFromObj (interp, objv [3], &timeout) == TCL_ERROR)
988 Tcl_SetStringObj(resultObj,
989 objc > 3 ? "timeouts must be greater than 0" :
990 "no previous timeout to reference", -1);
995 if (Tcl_GetLongFromObj (interp, objv [4], &maxmem) == TCL_ERROR)
998 if (ldap_enable_cache (ldap, timeout, maxmem) == -1) {
999 Tcl_AppendStringsToObj (resultObj,
1000 "LDAP cache enable error: ",
1001 LDAP_ERR_STRING(ldap),
1003 LDAP_SetErrorCode(ldaptcl, -1, interp);
1006 ldaptcl->caching = 1;
1007 ldaptcl->timeout = timeout;
1008 ldaptcl->maxmem = maxmem;
1012 if (objc != 3) goto badargs;
1014 if (STREQU (cacheCommand, "disable")) {
1015 ldap_disable_cache (ldap);
1016 ldaptcl->caching = 0;
1020 if (STREQU (cacheCommand, "destroy")) {
1021 ldap_destroy_cache (ldap);
1022 ldaptcl->caching = 0;
1026 if (STREQU (cacheCommand, "flush")) {
1027 ldap_flush_cache (ldap);
1031 if (STREQU (cacheCommand, "no_errors")) {
1032 ldap_set_cache_options (ldap, LDAP_CACHE_OPT_CACHENOERRS);
1036 if (STREQU (cacheCommand, "all_errors")) {
1037 ldap_set_cache_options (ldap, LDAP_CACHE_OPT_CACHEALLERRS);
1041 if (STREQU (cacheCommand, "size_errors")) {
1042 ldap_set_cache_options (ldap, 0);
1045 Tcl_AppendStringsToObj (resultObj,
1051 " must be one of \"enable\", ",
1053 "\"destroy\", \"flush\", \"uncache\", ",
1054 "\"no_errors\", \"size_errors\",",
1055 " or \"all_errors\"",
1060 if (STREQU (subCommand, "trap")) {
1061 Tcl_Obj *listObj, *resultObj;
1065 return TclX_WrongArgs (interp, objv [0],
1066 "trap command ?errorCode-list?");
1068 if (!ldaptcl->trapCmdObj)
1070 resultObj = Tcl_NewListObj(0, NULL);
1071 Tcl_ListObjAppendElement(interp, resultObj, ldaptcl->trapCmdObj);
1072 if (ldaptcl->traplist) {
1073 listObj = Tcl_NewObj();
1074 for (p = ldaptcl->traplist; *p; p++) {
1075 Tcl_ListObjAppendElement(interp, listObj,
1076 Tcl_NewStringObj(ldaptclerrorcode[*p], -1));
1078 Tcl_ListObjAppendElement(interp, resultObj, listObj);
1080 Tcl_SetObjResult(interp, resultObj);
1083 if (ldaptcl->trapCmdObj) {
1084 Tcl_DecrRefCount (ldaptcl->trapCmdObj);
1085 ldaptcl->trapCmdObj = NULL;
1087 if (ldaptcl->traplist) {
1088 free(ldaptcl->traplist);
1089 ldaptcl->traplist = NULL;
1091 Tcl_GetStringFromObj(objv[2], &l);
1093 return TCL_OK; /* just turn off trap */
1094 ldaptcl->trapCmdObj = objv[2];
1095 Tcl_IncrRefCount (ldaptcl->trapCmdObj);
1097 return TCL_OK; /* no code list */
1098 if (Tcl_ListObjLength(interp, objv[3], &l) != TCL_OK)
1101 return TCL_OK; /* empty code list */
1102 ldaptcl->traplist = (int*)malloc(sizeof(int) * (l + 1));
1103 ldaptcl->traplist[l] = 0;
1104 for (i = 0; i < l; i++) {
1105 Tcl_ListObjIndex(interp, objv[3], i, &resultObj);
1106 code = LDAP_ErrorStringToCode(interp, Tcl_GetStringFromObj(resultObj, NULL));
1108 free(ldaptcl->traplist);
1109 ldaptcl->traplist = NULL;
1112 ldaptcl->traplist[i] = code;
1116 if (STREQU (subCommand, "trapcodes")) {
1120 resultObj = Tcl_GetObjResult(interp);
1122 for (code = 0; code < LDAPTCL_MAXERR; code++) {
1123 if (!ldaptclerrorcode[code]) continue;
1124 Tcl_ListObjAppendElement(interp, resultObj,
1125 Tcl_NewStringObj(ldaptclerrorcode[code], -1));
1130 if (STREQU (subCommand, "debug")) {
1132 Tcl_AppendStringsToObj(resultObj, "Wrong # of arguments",
1136 return Tcl_GetIntFromObj(interp, objv[2], &ldap_debug);
1140 /* FIX: this needs to enumerate all the possibilities */
1141 Tcl_AppendStringsToObj (resultObj,
1144 "\" must be one of \"add\", ",
1145 "\"add_attributes\", ",
1146 "\"bind\", \"cache\", \"delete\", ",
1147 "\"delete_attributes\", \"modify\", ",
1148 "\"modify_rdn\", \"rename_rdn\", ",
1149 "\"replace_attributes\", ",
1150 "\"search\" or \"unbind\".",
1156 * Delete and LDAP command object
1160 NeoX_LdapObjDeleteCmd(clientData)
1161 ClientData clientData;
1163 LDAPTCL *ldaptcl = (LDAPTCL *)clientData;
1164 LDAP *ldap = ldaptcl->ldap;
1166 if (ldaptcl->trapCmdObj)
1167 Tcl_DecrRefCount (ldaptcl->trapCmdObj);
1168 if (ldaptcl->traplist)
1169 free(ldaptcl->traplist);
1171 free((char*) ldaptcl);
1174 /*-----------------------------------------------------------------------------
1175 * NeoX_LdapObjCmd --
1177 * Implements the `ldap' command:
1178 * ldap open newObjName host [port]
1179 * ldap init newObjName host [port]
1182 * A standard Tcl result.
1185 * See the user documentation.
1186 *-----------------------------------------------------------------------------
1189 NeoX_LdapObjCmd (clientData, interp, objc, objv)
1190 ClientData clientData;
1193 Tcl_Obj *CONST objv[];
1203 Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
1205 if (objc < 3 || objc > 5)
1206 return TclX_WrongArgs (interp, objv [0],
1207 "(open|init) new_command host [port]|explode dn");
1209 subCommand = Tcl_GetStringFromObj (objv[1], NULL);
1211 if (STREQU(subCommand, "explode")) {
1215 char **exploded, **p;
1217 param = Tcl_GetStringFromObj (objv[2], NULL);
1218 if (param[0] == '-') {
1219 if (STREQU(param, "-nonames")) {
1221 } else if (STREQU(param, "-list")) {
1224 return TclX_WrongArgs (interp, objv [0], "explode ?-nonames|-list? dn");
1227 if (nonames || list)
1228 param = Tcl_GetStringFromObj (objv[3], NULL);
1229 exploded = ldap_explode_dn(param, nonames);
1230 for (p = exploded; *p; p++) {
1232 char *q = strchr(*p, '=');
1234 Tcl_SetObjLength(resultObj, 0);
1235 Tcl_AppendStringsToObj(resultObj, "rdn ", *p,
1236 " missing '='", NULL);
1237 ldap_value_free(exploded);
1241 if (Tcl_ListObjAppendElement(interp, resultObj,
1242 Tcl_NewStringObj(*p, -1)) != TCL_OK ||
1243 Tcl_ListObjAppendElement(interp, resultObj,
1244 Tcl_NewStringObj(q+1, -1)) != TCL_OK) {
1245 ldap_value_free(exploded);
1249 if (Tcl_ListObjAppendElement(interp, resultObj,
1250 Tcl_NewStringObj(*p, -1))) {
1251 ldap_value_free(exploded);
1256 ldap_value_free(exploded);
1261 if (STREQU(subCommand, "friendly")) {
1262 char *friendly = ldap_dn2ufn(Tcl_GetStringFromObj(objv[2], NULL));
1263 Tcl_SetStringObj(resultObj, friendly, -1);
1269 newCommand = Tcl_GetStringFromObj (objv[2], NULL);
1270 ldapHost = Tcl_GetStringFromObj (objv[3], NULL);
1273 if (Tcl_GetIntFromObj (interp, objv [4], &ldapPort) == TCL_ERROR) {
1274 Tcl_AppendStringsToObj (resultObj,
1275 "LDAP port number is non-numeric",
1281 if (STREQU (subCommand, "open")) {
1282 ldap = ldap_open (ldapHost, ldapPort);
1283 } else if (STREQU (subCommand, "init")) {
1284 ldap = ldap_init (ldapHost, ldapPort);
1286 Tcl_AppendStringsToObj (resultObj,
1287 "option was not \"open\" or \"init\"");
1291 if (ldap == (LDAP *)NULL) {
1292 Tcl_SetErrno(errno);
1293 Tcl_AppendStringsToObj (resultObj,
1294 Tcl_PosixError (interp),
1300 ldap->ld_deref = LDAP_DEREF_NEVER; /* Turn off alias dereferencing */
1303 ldaptcl = (LDAPTCL *) malloc(sizeof(LDAPTCL));
1304 ldaptcl->ldap = ldap;
1305 ldaptcl->caching = 0;
1306 ldaptcl->timeout = 0;
1307 ldaptcl->maxmem = 0;
1308 ldaptcl->trapCmdObj = NULL;
1309 ldaptcl->traplist = NULL;
1312 Tcl_CreateObjCommand (interp,
1314 NeoX_LdapTargetObjCmd,
1315 (ClientData) ldaptcl,
1316 NeoX_LdapObjDeleteCmd);
1320 /*-----------------------------------------------------------------------------
1322 * Initialize the LDAP interface.
1323 *-----------------------------------------------------------------------------
1326 Ldaptcl_Init (interp)
1329 Tcl_CreateObjCommand (interp,
1333 (Tcl_CmdDeleteProc*) NULL);
1334 Tcl_PkgProvide(interp, "Ldaptcl", VERSION);