git.sur5r.net Git - openldap/blob - contrib/ldaptcl/neoXldap.c

   1 /*
   2  * NeoSoft Tcl client extensions to Lightweight Directory Access Protocol.
   3  *
   4  * Copyright (c) 1998-1999 NeoSoft, Inc.
   5  * All Rights Reserved.
   6  *
   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.
  10  *
  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.
  14  *
  15  * Redistribution and use in source and binary forms are permitted
  16  * provided that this notice is preserved and that due credit is given
  17  * to NeoSoft, Inc.
  18  *
  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.
  22  *
  23  * Requests for permission may be sent to NeoSoft Inc, 1770 St. James Place,
  24  * Suite 500, Houston, TX, 77056.
  25  *
  26  * $OpenLDAP$
  27  *
  28  */
  29
  30 /*
  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).
  38  */
  39
  40 /*
  41  * Add timeout to controlArray to set timeout for ldap_result.
  42  * 4/14/99 - Randy
  43  */
  44
  45 #include "tclExtend.h"
  46
  47 #include <lber.h>
  48 #include <ldap.h>
  49 #include <string.h>
  50 #include <sys/time.h>
  51 #include <math.h>
  52
  53 /*
  54  * Macros to do string compares.  They pre-check the first character before
  55  * checking of the strings are equal.
  56  */
  57
  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))
  62
  63 /*
  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.
  69  */
  70 #define OPEN_LDAP 1
  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.
  78        */
  79 #ifndef LDAP_API_FEATURE_X_OPENLDAP
  80 #define ldap_memfree(p) free(p)
  81 #endif
  82 #ifdef LDAP_OPT_ERROR_NUMBER
  83 #define ldap_get_lderrno(ld)    (ldap_get_option(ld, LDAP_OPT_ERROR_NUMBER, &lderrno), lderrno)
  84 #else
  85 #define ldap_get_lderrno(ld) (ld->ld_errno)
  86 #endif
  87 #define LDAP_ERR_STRING(ld)  \
  88         ldap_err2string(ldap_get_lderrno(ld))
  89 #elif defined( LDAP_OPT_SIZELIMIT )
  90        /*
  91        ** Netscape SDK w/ ldap_set_option, ldap_get_option
  92        */
  93 #define LDAP_ERR_STRING(ld)  \
  94         ldap_err2string(ldap_get_lderrno(ldap))
  95 #else
  96        /* U-Mich/OpenLDAP 1.x API */
  97        /* RFC-1823 w/ changes */
  98 #define UMICH_LDAP 1
  99 #define ldap_memfree(p) free(p)
 100 #define ldap_ber_free(p, n) ber_free(p, n)
 101 #define ldap_value_free_len(bvals) ber_bvecfree(bvals)
 102 #define ldap_get_lderrno(ld) (ld->ld_errno)
 103 #define LDAP_ERR_STRING(ld)  \
 104         ldap_err2string(ld->ld_errno)
 105 #endif
 106
 107 typedef struct ldaptclobj {
 108     LDAP        *ldap;
 109     int         caching;        /* flag 1/0 if caching is enabled */
 110     long        timeout;        /* timeout from last cache enable */
 111     long        maxmem;         /* maxmem from last cache enable */
 112     Tcl_Obj     *trapCmdObj;    /* error handler */
 113     int         *traplist;      /* list of errorCodes to trap */
 114     int         flags;
 115 } LDAPTCL;
 116
 117
 118 #define LDAPTCL_INTERRCODES     0x001
 119
 120 #include "ldaptclerr.h"
 121
 122 static
 123 LDAP_SetErrorCode(LDAPTCL *ldaptcl, int code, Tcl_Interp *interp)
 124 {
 125     char shortbuf[16];
 126     char *errp;
 127     int   lderrno;
 128
 129     if (code == -1)
 130         code = ldap_get_lderrno(ldaptcl->ldap);
 131     if ((ldaptcl->flags & LDAPTCL_INTERRCODES) || code > LDAPTCL_MAXERR ||
 132       ldaptclerrorcode[code] == NULL) {
 133         sprintf(shortbuf, "0x%03x", code);
 134         errp = shortbuf;
 135     } else
 136         errp = ldaptclerrorcode[code];
 137
 138     Tcl_SetErrorCode(interp, errp, NULL);
 139     if (ldaptcl->trapCmdObj) {
 140         int *i;
 141         Tcl_Obj *cmdObj;
 142         if (ldaptcl->traplist != NULL) {
 143             for (i = ldaptcl->traplist; *i && *i != code; i++)
 144                 ;
 145             if (*i == 0) return;
 146         }
 147         (void) Tcl_EvalObj(interp, ldaptcl->trapCmdObj);
 148     }
 149 }
 150
 151 static
 152 LDAP_ErrorStringToCode(Tcl_Interp *interp, char *s)
 153 {
 154     int offset;
 155     int code;
 156
 157     offset = (strncasecmp(s, "LDAP_", 5) == 0) ? 0 : 5;
 158     for (code = 0; code < LDAPTCL_MAXERR; code++) {
 159         if (!ldaptclerrorcode[code]) continue;
 160         if (strcasecmp(s, ldaptclerrorcode[code]+offset) == 0)
 161             return code;
 162     }
 163     Tcl_ResetResult(interp);
 164     Tcl_AppendResult(interp, s, " is an invalid code", (char *) NULL);
 165     return -1;
 166 }
 167
 168 /*-----------------------------------------------------------------------------
 169  * LDAP_ProcessOneSearchResult --
 170  *
 171  *   Process one result return from an LDAP search.
 172  *
 173  * Parameters:
 174  *   o interp -            Tcl interpreter; Errors are returned in result.
 175  *   o ldap -              LDAP structure pointer.
 176  *   o entry -             LDAP message pointer.
 177  *   o destArrayNameObj -  Name of Tcl array in which to store attributes.
 178  *   o evalCodeObj -       Tcl_Obj pointer to code to eval against this result.
 179  * Returns:
 180  *   o TCL_OK if processing succeeded..
 181  *   o TCL_ERROR if an error occured, with error message in interp.
 182  *-----------------------------------------------------------------------------
 183  */
 184 int
 185 LDAP_ProcessOneSearchResult (interp, ldap, entry, destArrayNameObj, evalCodeObj)
 186     Tcl_Interp     *interp;
 187     LDAP           *ldap;
 188     LDAPMessage    *entry;
 189     Tcl_Obj        *destArrayNameObj;
 190     Tcl_Obj        *evalCodeObj;
 191 {
 192     char           *attributeName;
 193     Tcl_Obj        *attributeNameObj;
 194     Tcl_Obj        *attributeDataObj;
 195     int             i;
 196     BerElement     *ber;
 197     struct berval **bvals;
 198     char           *dn;
 199     int             lderrno;
 200
 201     Tcl_UnsetVar (interp, Tcl_GetStringFromObj (destArrayNameObj, NULL), 0);
 202
 203     dn = ldap_get_dn(ldap, entry);
 204     if (dn != NULL) {
 205         if (Tcl_SetVar2(interp,         /* set dn */
 206                        Tcl_GetStringFromObj(destArrayNameObj, NULL),
 207                        "dn",
 208                        dn,
 209                        TCL_LEAVE_ERR_MSG) == NULL)
 210             return TCL_ERROR;
 211         ldap_memfree(dn);
 212     }
 213     attributeNameObj = Tcl_NewObj();
 214     Tcl_IncrRefCount (attributeNameObj);
 215
 216     /* Note that attributeName below is allocated for OL2+ libldap, so it
 217        must be freed with ldap_memfree().  Test below is admittedly a hack.
 218     */
 219
 220     for (attributeName = ldap_first_attribute (ldap, entry, &ber);
 221       attributeName != NULL;
 222       attributeName = ldap_next_attribute(ldap, entry, ber)) {
 223
 224         bvals = ldap_get_values_len(ldap, entry, attributeName);
 225
 226         if (bvals != NULL) {
 227             /* Note here that the U.of.M. ldap will return a null bvals
 228                when the last attribute value has been deleted, but still
 229                retains the attributeName.  Even though this is documented
 230                as an error, we ignore it to present a consistent interface
 231                with Netscape's server
 232             */
 233             attributeDataObj = Tcl_NewObj();
 234             Tcl_SetStringObj(attributeNameObj, attributeName, -1);
 235 #if LDAP_API_VERSION >= 2004
 236             ldap_memfree(attributeName);        /* free if newer API */
 237 #endif
 238             for (i = 0; bvals[i] != NULL; i++) {
 239                 Tcl_Obj *singleAttributeValueObj;
 240
 241                 singleAttributeValueObj = Tcl_NewStringObj(bvals[i]->bv_val, bvals[i]->bv_len);
 242                 if (Tcl_ListObjAppendElement (interp,
 243                                               attributeDataObj,
 244                                               singleAttributeValueObj)
 245                   == TCL_ERROR) {
 246                     ber_free(ber, 0);
 247                     return TCL_ERROR;
 248                 }
 249             }
 250
 251             ldap_value_free_len(bvals);
 252
 253             if (Tcl_ObjSetVar2 (interp,
 254                                 destArrayNameObj,
 255                                 attributeNameObj,
 256                                 attributeDataObj,
 257                                 TCL_LEAVE_ERR_MSG) == NULL) {
 258                 return TCL_ERROR;
 259             }
 260         }
 261     }
 262     Tcl_DecrRefCount (attributeNameObj);
 263     return Tcl_EvalObj (interp, evalCodeObj);
 264 }
 265
 266 /*-----------------------------------------------------------------------------
 267  * LDAP_PerformSearch --
 268  *
 269  *   Perform an LDAP search.
 270  *
 271  * Parameters:
 272  *   o interp -            Tcl interpreter; Errors are returned in result.
 273  *   o ldap -              LDAP structure pointer.
 274  *   o base -              Base DN from which to perform search.
 275  *   o scope -             LDAP search scope, must be one of LDAP_SCOPE_BASE,
 276  *                         LDAP_SCOPE_ONELEVEL, or LDAP_SCOPE_SUBTREE.
 277  *   o attrs -             Pointer to array of char * pointers of desired
 278  *                         attribute names, or NULL for all attributes.
 279  *   o filtpatt            LDAP filter pattern.
 280  *   o value               Value to get sprintf'ed into filter pattern.
 281  *   o destArrayNameObj -  Name of Tcl array in which to store attributes.
 282  *   o evalCodeObj -       Tcl_Obj pointer to code to eval against this result.
 283  * Returns:
 284  *   o TCL_OK if processing succeeded..
 285  *   o TCL_ERROR if an error occured, with error message in interp.
 286  *-----------------------------------------------------------------------------
 287  */
 288 int
 289 LDAP_PerformSearch (interp, ldaptcl, base, scope, attrs, filtpatt, value,
 290         destArrayNameObj, evalCodeObj, timeout_p, all, sortattr)
 291     Tcl_Interp     *interp;
 292     LDAPTCL        *ldaptcl;
 293     char           *base;
 294     int             scope;
 295     char          **attrs;
 296     char           *filtpatt;
 297     char           *value;
 298     Tcl_Obj        *destArrayNameObj;
 299     Tcl_Obj        *evalCodeObj;
 300     struct timeval *timeout_p;
 301     int             all;
 302     char           *sortattr;
 303 {
 304     LDAP         *ldap = ldaptcl->ldap;
 305     char          filter[BUFSIZ];
 306     int           resultCode;
 307     int           errorCode;
 308     int           abandon;
 309     int           tclResult = TCL_OK;
 310     int           msgid;
 311     LDAPMessage  *resultMessage = 0;
 312     LDAPMessage  *entryMessage = 0;
 313     char          *sortKey;
 314
 315     int           lderrno;
 316
 317     sprintf(filter, filtpatt, value);
 318
 319     fflush(stderr);
 320     if ((msgid = ldap_search (ldap, base, scope, filter, attrs, 0)) == -1) {
 321         Tcl_AppendResult (interp,
 322                                 "LDAP start search error: ",
 323                                         LDAP_ERR_STRING(ldap),
 324                                 (char *)NULL);
 325         LDAP_SetErrorCode(ldaptcl, -1, interp);
 326         return TCL_ERROR;
 327     }
 328
 329     abandon = 0;
 330     if (sortattr)
 331         all = 1;
 332     tclResult = TCL_OK;
 333     while (!abandon) {
 334         resultCode = ldap_result (ldap, msgid, all, timeout_p, &resultMessage);
 335         if (resultCode != LDAP_RES_SEARCH_RESULT &&
 336             resultCode != LDAP_RES_SEARCH_ENTRY)
 337                 break;
 338
 339         if (sortattr) {
 340             sortKey = (strcasecmp(sortattr, "dn") == 0) ? NULL : sortattr;
 341             ldap_sort_entries(ldap, &resultMessage, sortKey, strcasecmp);
 342         }
 343         entryMessage = ldap_first_entry(ldap, resultMessage);
 344
 345         while (entryMessage) {
 346             tclResult = LDAP_ProcessOneSearchResult  (interp,
 347                                     ldap,
 348                                     entryMessage,
 349                                     destArrayNameObj,
 350                                     evalCodeObj);
 351             if (tclResult != TCL_OK) {
 352                 if (tclResult == TCL_CONTINUE) {
 353                     tclResult = TCL_OK;
 354                 } else if (tclResult == TCL_BREAK) {
 355                     tclResult = TCL_OK;
 356                     abandon = 1;
 357                     break;
 358                 } else if (tclResult == TCL_ERROR) {
 359                     char msg[100];
 360                     sprintf(msg, "\n    (\"search\" body line %d)",
 361                             interp->errorLine);
 362                     Tcl_AddObjErrorInfo(interp, msg, -1);
 363                     abandon = 1;
 364                     break;
 365                 } else {
 366                     abandon = 1;
 367                     break;
 368                 }
 369             }
 370             entryMessage = ldap_next_entry(ldap, entryMessage);
 371         }
 372         if (resultCode == LDAP_RES_SEARCH_RESULT || all)
 373             break;
 374         if (resultMessage)
 375         ldap_msgfree(resultMessage);
 376         resultMessage = NULL;
 377     }
 378     if (abandon) {
 379         if (resultMessage)
 380             ldap_msgfree(resultMessage);
 381         if (resultCode == LDAP_RES_SEARCH_ENTRY)
 382             ldap_abandon(ldap, msgid);
 383         return tclResult;
 384     }
 385     if (resultCode == -1) {
 386         Tcl_ResetResult (interp);
 387         Tcl_AppendResult (interp,
 388                                 "LDAP result search error: ",
 389                                 LDAP_ERR_STRING(ldap),
 390                                 (char *)NULL);
 391         LDAP_SetErrorCode(ldaptcl, -1, interp);
 392         return TCL_ERROR;
 393     }
 394
 395     if ((errorCode = ldap_result2error (ldap, resultMessage, 0))
 396       != LDAP_SUCCESS) {
 397       Tcl_ResetResult (interp);
 398       Tcl_AppendResult (interp,
 399                               "LDAP search error: ",
 400                               ldap_err2string(errorCode),
 401                               (char *)NULL);
 402       if (resultMessage)
 403           ldap_msgfree(resultMessage);
 404       LDAP_SetErrorCode(ldaptcl, errorCode, interp);
 405       return TCL_ERROR;
 406     }
 407     if (resultMessage)
 408         ldap_msgfree(resultMessage);
 409     return tclResult;
 410 }
 411
 412 /*-----------------------------------------------------------------------------
 413  * NeoX_LdapTargetObjCmd --
 414  *
 415  * Implements the body of commands created by Neo_LdapObjCmd.
 416  *
 417  * Results:
 418  *      A standard Tcl result.
 419  *
 420  * Side effects:
 421  *      See the user documentation.
 422  *-----------------------------------------------------------------------------
 423  */
 424 int
 425 NeoX_LdapTargetObjCmd (clientData, interp, objc, objv)
 426     ClientData    clientData;
 427     Tcl_Interp   *interp;
 428     int           objc;
 429     Tcl_Obj      *CONST objv[];
 430 {
 431     char         *command;
 432     char         *subCommand;
 433     LDAPTCL      *ldaptcl = (LDAPTCL *)clientData;
 434     LDAP         *ldap = ldaptcl->ldap;
 435     char         *dn;
 436     int           is_add = 0;
 437     int           is_add_or_modify = 0;
 438     int           mod_op = 0;
 439     char         *m, *s, *errmsg;
 440     int          errcode;
 441     int          tclResult;
 442     int          lderrno;       /* might be used by LDAP_ERR_STRING macro */
 443
 444     Tcl_Obj      *resultObj = Tcl_GetObjResult (interp);
 445
 446     if (objc < 2) {
 447         Tcl_WrongNumArgs (interp, 1, objv, "subcommand [args...]");
 448         return TCL_ERROR;
 449     }
 450
 451     command = Tcl_GetStringFromObj (objv[0], NULL);
 452     subCommand = Tcl_GetStringFromObj (objv[1], NULL);
 453
 454     /* object bind authtype name password */
 455     if (STREQU (subCommand, "bind")) {
 456         char     *binddn;
 457         char     *passwd;
 458         int       stringLength;
 459         char     *ldap_authString;
 460         int       ldap_authInt;
 461
 462         if (objc != 5) {
 463             Tcl_WrongNumArgs (interp, 2, objv, "authtype dn passwd");
 464             return TCL_ERROR;
 465         }
 466
 467         ldap_authString = Tcl_GetStringFromObj (objv[2], NULL);
 468
 469         if (STREQU (ldap_authString, "simple")) {
 470             ldap_authInt = LDAP_AUTH_SIMPLE;
 471         }
 472 #ifdef UMICH_LDAP
 473         else if (STREQU (ldap_authString, "kerberos_ldap")) {
 474             ldap_authInt = LDAP_AUTH_KRBV41;
 475         } else if (STREQU (ldap_authString, "kerberos_dsa")) {
 476             ldap_authInt = LDAP_AUTH_KRBV42;
 477         } else if (STREQU (ldap_authString, "kerberos_both")) {
 478             ldap_authInt = LDAP_AUTH_KRBV4;
 479         }
 480 #endif
 481         else {
 482             Tcl_AppendStringsToObj (resultObj,
 483                                     "\"",
 484                                     command,
 485                                     " ",
 486                                     subCommand,
 487 #ifdef UMICH_LDAP
 488                                     "\" authtype must be one of \"simple\", ",
 489                                     "\"kerberos_ldap\", \"kerberos_dsa\" ",
 490                                     "or \"kerberos_both\"",
 491 #else
 492                                     "\" authtype must be \"simple\", ",
 493 #endif
 494                                     (char *)NULL);
 495             return TCL_ERROR;
 496         }
 497
 498         binddn = Tcl_GetStringFromObj (objv[3], &stringLength);
 499         if (stringLength == 0)
 500             binddn = NULL;
 501
 502         passwd = Tcl_GetStringFromObj (objv[4], &stringLength);
 503         if (stringLength == 0)
 504             passwd = NULL;
 505
 506 /*  ldap_bind_s(ldap, dn, pw, method) */
 507
 508 #ifdef UMICH_LDAP
 509 #define LDAP_BIND(ldap, dn, pw, method) \
 510   ldap_bind_s(ldap, dn, pw, method)
 511 #else
 512 #define LDAP_BIND(ldap, dn, pw, method) \
 513   ldap_simple_bind_s(ldap, dn, pw)
 514 #endif
 515         if ((errcode = LDAP_BIND (ldap,
 516                          binddn,
 517                          passwd,
 518                          ldap_authInt)) != LDAP_SUCCESS) {
 519
 520             Tcl_AppendStringsToObj (resultObj,
 521                                     "LDAP bind error: ",
 522                                     ldap_err2string(errcode),
 523                                     (char *)NULL);
 524             LDAP_SetErrorCode(ldaptcl, errcode, interp);
 525             return TCL_ERROR;
 526         }
 527         return TCL_OK;
 528     }
 529
 530     if (STREQU (subCommand, "unbind")) {
 531         if (objc != 2) {
 532             Tcl_WrongNumArgs (interp, 2, objv, "");
 533             return TCL_ERROR;
 534         }
 535
 536        return Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], NULL));
 537     }
 538
 539     /* object delete dn */
 540     if (STREQU (subCommand, "delete")) {
 541         if (objc != 3) {
 542             Tcl_WrongNumArgs (interp, 2, objv, "dn");
 543             return TCL_ERROR;
 544         }
 545
 546        dn = Tcl_GetStringFromObj (objv [2], NULL);
 547        if ((errcode = ldap_delete_s(ldap, dn)) != LDAP_SUCCESS) {
 548            Tcl_AppendStringsToObj (resultObj,
 549                                    "LDAP delete error: ",
 550                                    ldap_err2string(errcode),
 551                                    (char *)NULL);
 552            LDAP_SetErrorCode(ldaptcl, errcode, interp);
 553            return TCL_ERROR;
 554        }
 555        return TCL_OK;
 556     }
 557
 558     /* object rename_rdn dn rdn */
 559     /* object modify_rdn dn rdn */
 560     if (STREQU (subCommand, "rename_rdn") || STREQU (subCommand, "modify_rdn")) {
 561         char    *rdn;
 562         int      deleteOldRdn;
 563
 564         if (objc != 4) {
 565             Tcl_WrongNumArgs (interp, 2, objv, "dn rdn");
 566             return TCL_ERROR;
 567         }
 568
 569         dn = Tcl_GetStringFromObj (objv [2], NULL);
 570         rdn = Tcl_GetStringFromObj (objv [3], NULL);
 571
 572         deleteOldRdn = (*subCommand == 'r');
 573
 574         if ((errcode = ldap_modrdn2_s (ldap, dn, rdn, deleteOldRdn)) != LDAP_SUCCESS) {
 575             Tcl_AppendStringsToObj (resultObj,
 576                                     "LDAP ",
 577                                     subCommand,
 578                                     " error: ",
 579                                     ldap_err2string(errcode),
 580                                     (char *)NULL);
 581             LDAP_SetErrorCode(ldaptcl, errcode, interp);
 582             return TCL_ERROR;
 583         }
 584         return TCL_OK;
 585     }
 586
 587     /* object add dn attributePairList */
 588     /* object add_attributes dn attributePairList */
 589     /* object replace_attributes dn attributePairList */
 590     /* object delete_attributes dn attributePairList */
 591
 592     if (STREQU (subCommand, "add")) {
 593         is_add = 1;
 594         is_add_or_modify = 1;
 595     } else {
 596         is_add = 0;
 597         if (STREQU (subCommand, "add_attributes")) {
 598             is_add_or_modify = 1;
 599             mod_op = LDAP_MOD_ADD;
 600         } else if (STREQU (subCommand, "replace_attributes")) {
 601             is_add_or_modify = 1;
 602             mod_op = LDAP_MOD_REPLACE;
 603         } else if (STREQU (subCommand, "delete_attributes")) {
 604             is_add_or_modify = 1;
 605             mod_op = LDAP_MOD_DELETE;
 606         }
 607     }
 608
 609     if (is_add_or_modify) {
 610         int          result;
 611         LDAPMod    **modArray;
 612         LDAPMod     *mod;
 613         char       **valPtrs = NULL;
 614         int          attribObjc;
 615         Tcl_Obj    **attribObjv;
 616         int          valuesObjc;
 617         Tcl_Obj    **valuesObjv;
 618         int          nPairs, allPairs;
 619         int          i;
 620         int          j;
 621         int          pairIndex;
 622         int          modIndex;
 623
 624         Tcl_Obj      *resultObj = Tcl_GetObjResult (interp);
 625
 626         if (objc < 4 || objc > 4 && is_add || is_add == 0 && objc&1) {
 627             Tcl_AppendStringsToObj (resultObj,
 628                                     "wrong # args: ",
 629                                     Tcl_GetStringFromObj (objv [0], NULL),
 630                                     " ",
 631                                     subCommand,
 632                                     " dn attributePairList",
 633                                     (char *)NULL);
 634             if (!is_add)
 635                 Tcl_AppendStringsToObj (resultObj,
 636                     " ?[add|delete|replace] attributePairList ...?", (char *)NULL);
 637             return TCL_ERROR;
 638         }
 639
 640         dn = Tcl_GetStringFromObj (objv [2], NULL);
 641
 642         allPairs = 0;
 643         for (i = 3; i < objc; i += 2) {
 644             if (Tcl_ListObjLength (interp, objv[i], &j) == TCL_ERROR)
 645                 return TCL_ERROR;
 646             if (j & 1) {
 647                 Tcl_AppendStringsToObj (resultObj,
 648                                         "attribute list does not contain an ",
 649                                         "even number of key-value elements",
 650                                         (char *)NULL);
 651                 return TCL_ERROR;
 652             }
 653             allPairs += j / 2;
 654         }
 655
 656         modArray = (LDAPMod **)malloc (sizeof(LDAPMod *) * (allPairs + 1));
 657
 658         pairIndex = 3;
 659         modIndex = 0;
 660
 661         do {
 662
 663         if (Tcl_ListObjGetElements (interp, objv [pairIndex], &attribObjc, &attribObjv)
 664           == TCL_ERROR) {
 665            mod_op = -1;
 666            goto badop;
 667         }
 668
 669         nPairs = attribObjc / 2;
 670
 671         for (i = 0; i < nPairs; i++) {
 672             mod = modArray[modIndex++] = (LDAPMod *) malloc (sizeof(LDAPMod));
 673             mod->mod_op = mod_op;
 674             mod->mod_type = Tcl_GetStringFromObj (attribObjv [i * 2], NULL);
 675
 676             if (Tcl_ListObjGetElements (interp, attribObjv [i * 2 + 1], &valuesObjc, &valuesObjv) == TCL_ERROR) {
 677                 /* FIX: cleanup memory here */
 678                 mod_op = -1;
 679                 goto badop;
 680             }
 681
 682             valPtrs = mod->mod_vals.modv_strvals = \
 683                 (char **)malloc (sizeof (char *) * (valuesObjc + 1));
 684             valPtrs[valuesObjc] = (char *)NULL;
 685
 686             for (j = 0; j < valuesObjc; j++) {
 687                 valPtrs [j] = Tcl_GetStringFromObj (valuesObjv[j], NULL);
 688
 689                 /* If it's "delete" and value is an empty string, make
 690                  * value be NULL to indicate entire attribute is to be
 691                  * deleted */
 692                 if ((*valPtrs [j] == '\0')
 693                     && (mod->mod_op == LDAP_MOD_DELETE || mod->mod_op == LDAP_MOD_REPLACE)) {
 694                         valPtrs [j] = NULL;
 695                 }
 696             }
 697         }
 698
 699         pairIndex += 2;
 700         if (mod_op != -1 && pairIndex < objc) {
 701             subCommand = Tcl_GetStringFromObj (objv[pairIndex - 1], NULL);
 702             mod_op = -1;
 703             if (STREQU (subCommand, "add")) {
 704                 mod_op = LDAP_MOD_ADD;
 705             } else if (STREQU (subCommand, "replace")) {
 706                 mod_op = LDAP_MOD_REPLACE;
 707             } else if (STREQU (subCommand, "delete")) {
 708                 mod_op = LDAP_MOD_DELETE;
 709             }
 710             if (mod_op == -1) {
 711                 Tcl_SetStringObj (resultObj,
 712                         "Additional operators must be one of"
 713                         " add, replace, or delete", -1);
 714                 mod_op = -1;
 715                 goto badop;
 716             }
 717         }
 718
 719         } while (mod_op != -1 && pairIndex < objc);
 720         modArray[modIndex] = (LDAPMod *) NULL;
 721
 722         if (is_add) {
 723             result = ldap_add_s (ldap, dn, modArray);
 724         } else {
 725             result = ldap_modify_s (ldap, dn, modArray);
 726             if (ldaptcl->caching)
 727                 ldap_uncache_entry (ldap, dn);
 728         }
 729
 730         /* free the modArray elements, then the modArray itself. */
 731 badop:
 732         for (i = 0; i < modIndex; i++) {
 733             free ((char *) modArray[i]->mod_vals.modv_strvals);
 734             free ((char *) modArray[i]);
 735         }
 736         free ((char *) modArray);
 737
 738         /* after modArray is allocated, mod_op = -1 upon error for cleanup */
 739         if (mod_op == -1)
 740             return TCL_ERROR;
 741
 742         /* FIX: memory cleanup required all over the place here */
 743         if (result != LDAP_SUCCESS) {
 744             Tcl_AppendStringsToObj (resultObj,
 745                                     "LDAP ",
 746                                     subCommand,
 747                                     " error: ",
 748                                     ldap_err2string(result),
 749                                     (char *)NULL);
 750             LDAP_SetErrorCode(ldaptcl, result, interp);
 751             return TCL_ERROR;
 752         }
 753         return TCL_OK;
 754     }
 755
 756     /* object search controlArray dn pattern */
 757     if (STREQU (subCommand, "search")) {
 758         char        *controlArrayName;
 759         Tcl_Obj     *controlArrayNameObj;
 760
 761         char        *scopeString;
 762         int          scope;
 763
 764         char        *derefString;
 765         int          deref;
 766
 767         char        *baseString;
 768
 769         char       **attributesArray;
 770         char        *attributesString;
 771         int          attributesArgc;
 772
 773         char        *filterPatternString;
 774
 775         char        *timeoutString;
 776         double       timeoutTime;
 777         struct timeval timeout, *timeout_p;
 778
 779         char        *paramString;
 780         int          cacheThis = -1;
 781         int          all = 0;
 782
 783         char        *sortattr;
 784
 785         Tcl_Obj     *destArrayNameObj;
 786         Tcl_Obj     *evalCodeObj;
 787
 788         if (objc != 5) {
 789             Tcl_WrongNumArgs (interp, 2, objv,
 790                                    "controlArray destArray code");
 791             return TCL_ERROR;
 792         }
 793
 794         controlArrayNameObj = objv [2];
 795         controlArrayName = Tcl_GetStringFromObj (controlArrayNameObj, NULL);
 796
 797         destArrayNameObj = objv [3];
 798
 799         evalCodeObj = objv [4];
 800
 801         baseString = Tcl_GetVar2 (interp,
 802                                   controlArrayName,
 803                                   "base",
 804                                   0);
 805
 806         if (baseString == (char *)NULL) {
 807             Tcl_AppendStringsToObj (resultObj,
 808                                     "required element \"base\" ",
 809                                     "is missing from ldap control array \"",
 810                                     controlArrayName,
 811                                     "\"",
 812                                     (char *)NULL);
 813             return TCL_ERROR;
 814         }
 815
 816         filterPatternString = Tcl_GetVar2 (interp,
 817                                            controlArrayName,
 818                                            "filter",
 819                                            0);
 820         if (filterPatternString == (char *)NULL) {
 821             filterPatternString = "(objectclass=*)";
 822         }
 823
 824         /* Fetch scope setting from control array.
 825          * If it doesn't exist, default to subtree scoping.
 826          */
 827         scopeString = Tcl_GetVar2 (interp, controlArrayName, "scope", 0);
 828         if (scopeString == NULL) {
 829             scope = LDAP_SCOPE_SUBTREE;
 830         } else {
 831             if (STREQU(scopeString, "base"))
 832                 scope = LDAP_SCOPE_BASE;
 833             else if (STRNEQU(scopeString, "one", 3))
 834                 scope = LDAP_SCOPE_ONELEVEL;
 835             else if (STRNEQU(scopeString, "sub", 3))
 836                 scope = LDAP_SCOPE_SUBTREE;
 837             else {
 838                 Tcl_AppendStringsToObj (resultObj,
 839                                         "\"scope\" element of \"",
 840                                         controlArrayName,
 841                                         "\" array is not one of ",
 842                                         "\"base\", \"onelevel\", ",
 843                                         "or \"subtree\"",
 844                                       (char *) NULL);
 845                 return TCL_ERROR;
 846             }
 847         }
 848
 849 #ifdef LDAP_OPT_DEREF
 850         /* Fetch dereference control setting from control array.
 851          * If it doesn't exist, default to never dereference. */
 852         derefString = Tcl_GetVar2 (interp,
 853                                    controlArrayName,
 854                                    "deref",
 855                                    0);
 856         if (derefString == (char *)NULL) {
 857             deref = LDAP_DEREF_NEVER;
 858         } else {
 859             if (STREQU(derefString, "never"))
 860                 deref = LDAP_DEREF_NEVER;
 861             else if (STREQU(derefString, "search"))
 862                 deref = LDAP_DEREF_SEARCHING;
 863             else if (STREQU(derefString, "find"))
 864                 deref = LDAP_DEREF_FINDING;
 865             else if (STREQU(derefString, "always"))
 866                 deref = LDAP_DEREF_ALWAYS;
 867             else {
 868                 Tcl_AppendStringsToObj (resultObj,
 869                                         "\"deref\" element of \"",
 870                                         controlArrayName,
 871                                         "\" array is not one of ",
 872                                         "\"never\", \"search\", \"find\", ",
 873                                         "or \"always\"",
 874                                         (char *) NULL);
 875                 return TCL_ERROR;
 876             }
 877         }
 878 #endif
 879
 880         /* Fetch list of attribute names from control array.
 881          * If entry doesn't exist, default to NULL (all).
 882          */
 883         attributesString = Tcl_GetVar2 (interp,
 884                                         controlArrayName,
 885                                         "attributes",
 886                                         0);
 887         if (attributesString == (char *)NULL) {
 888             attributesArray = NULL;
 889         } else {
 890             if ((Tcl_SplitList (interp,
 891                                 attributesString,
 892                                 &attributesArgc,
 893                                 &attributesArray)) != TCL_OK) {
 894                 return TCL_ERROR;
 895             }
 896         }
 897
 898         /* Fetch timeout value if there is one
 899          */
 900         timeoutString = Tcl_GetVar2 (interp,
 901                                         controlArrayName,
 902                                         "timeout",
 903                                         0);
 904         timeout.tv_usec = 0;
 905         if (timeoutString == (char *)NULL) {
 906             timeout_p = NULL;
 907             timeout.tv_sec = 0;
 908         } else {
 909             if (Tcl_GetDouble(interp, timeoutString, &timeoutTime) != TCL_OK)
 910                 return TCL_ERROR;
 911             timeout.tv_sec = floor(timeoutTime);
 912             timeout.tv_usec = (timeoutTime-timeout.tv_sec) * 1000000;
 913             timeout_p = &timeout;
 914         }
 915
 916         paramString = Tcl_GetVar2 (interp, controlArrayName, "cache", 0);
 917         if (paramString) {
 918             if (Tcl_GetInt(interp, paramString, &cacheThis) == TCL_ERROR)
 919                 return TCL_ERROR;
 920         }
 921
 922         paramString = Tcl_GetVar2 (interp, controlArrayName, "all", 0);
 923         if (paramString) {
 924             if (Tcl_GetInt(interp, paramString, &all) == TCL_ERROR)
 925                 return TCL_ERROR;
 926         }
 927
 928         sortattr = Tcl_GetVar2 (interp, controlArrayName, "sort", 0);
 929
 930 #ifdef UMICH_LDAP
 931         ldap->ld_deref = deref;
 932         ldap->ld_timelimit = 0;
 933         ldap->ld_sizelimit = 0;
 934         ldap->ld_options = 0;
 935 #endif
 936
 937         /* Caching control within the search: if the "cache" control array */
 938         /* value is set, disable/enable caching accordingly */
 939
 940 #if 0
 941         if (cacheThis >= 0 && ldaptcl->caching != cacheThis) {
 942             if (cacheThis) {
 943                 if (ldaptcl->timeout == 0) {
 944                     Tcl_SetStringObj(resultObj, "Caching never before enabled, I have no timeout value to use", -1);
 945                     return TCL_ERROR;
 946                 }
 947                 ldap_enable_cache(ldap, ldaptcl->timeout, ldaptcl->maxmem);
 948             }
 949             else
 950                 ldap_disable_cache(ldap);
 951         }
 952 #endif
 953
 954 #ifdef LDAP_OPT_DEREF
 955         ldap_set_option(ldap, LDAP_OPT_DEREF, &deref);
 956 #endif
 957
 958         tclResult = LDAP_PerformSearch (interp,
 959                                     ldaptcl,
 960                                     baseString,
 961                                     scope,
 962                                     attributesArray,
 963                                     filterPatternString,
 964                                     "",
 965                                     destArrayNameObj,
 966                                     evalCodeObj,
 967                                     timeout_p,
 968                                     all,
 969                                     sortattr);
 970         /* Following the search, if we changed the caching behavior, change */
 971         /* it back. */
 972 #if 0
 973         if (cacheThis >= 0 && ldaptcl->caching != cacheThis) {
 974             if (cacheThis)
 975                 ldap_disable_cache(ldap);
 976             else
 977                 ldap_enable_cache(ldap, ldaptcl->timeout, ldaptcl->maxmem);
 978         }
 979 #ifdef LDAP_OPT_DEREF
 980         deref = LDAP_DEREF_NEVER;
 981         ldap_set_option(ldap, LDAP_OPT_DEREF, &deref);
 982 #endif
 983 #endif
 984         return tclResult;
 985     }
 986
 987     /* object compare dn attr value */
 988     if (STREQU (subCommand, "compare")) {
 989         char        *dn;
 990         char        *attr;
 991         char        *value;
 992         int          result;
 993         int          lderrno;
 994
 995         if (objc != 5) {
 996             Tcl_WrongNumArgs (interp,
 997                                    2, objv,
 998                                    "dn attribute value");
 999             return TCL_ERROR;
1000         }
1001
1002         dn = Tcl_GetStringFromObj (objv[2], NULL);
1003         attr = Tcl_GetStringFromObj (objv[3], NULL);
1004         value = Tcl_GetStringFromObj (objv[4], NULL);
1005
1006         result = ldap_compare_s (ldap, dn, attr, value);
1007         if (result == LDAP_COMPARE_TRUE || result == LDAP_COMPARE_FALSE) {
1008             Tcl_SetBooleanObj(resultObj, result == LDAP_COMPARE_TRUE);
1009             return TCL_OK;
1010         }
1011         LDAP_SetErrorCode(ldaptcl, result, interp);
1012         Tcl_AppendStringsToObj (resultObj,
1013                                 "LDAP compare error: ",
1014                                 LDAP_ERR_STRING(ldap),
1015                                 (char *)NULL);
1016         return TCL_ERROR;
1017     }
1018
1019     if (STREQU (subCommand, "cache")) {
1020 #if defined(UMICH_LDAP) || (defined(OPEN_LDAP) && !defined(LDAP_API_VERSION))
1021         char *cacheCommand;
1022
1023         if (objc < 3) {
1024           badargs:
1025             Tcl_WrongNumArgs (interp, 2, objv [0], "command [args...]");
1026             return TCL_ERROR;
1027         }
1028
1029         cacheCommand = Tcl_GetStringFromObj (objv [2], NULL);
1030
1031         if (STREQU (cacheCommand, "uncache")) {
1032             char *dn;
1033
1034             if (objc != 4) {
1035                 Tcl_WrongNumArgs (interp,
1036                                        3, objv,
1037                                        "dn");
1038                 return TCL_ERROR;
1039             }
1040
1041             dn = Tcl_GetStringFromObj (objv [3], NULL);
1042             ldap_uncache_entry (ldap, dn);
1043             return TCL_OK;
1044         }
1045
1046         if (STREQU (cacheCommand, "enable")) {
1047             long   timeout = ldaptcl->timeout;
1048             long   maxmem = ldaptcl->maxmem;
1049
1050             if (objc > 5) {
1051                 Tcl_WrongNumArgs (interp, 3, objv, "?timeout? ?maxmem?");
1052                 return TCL_ERROR;
1053             }
1054
1055             if (objc > 3) {
1056                 if (Tcl_GetLongFromObj (interp, objv [3], &timeout) == TCL_ERROR)
1057                     return TCL_ERROR;
1058             }
1059             if (timeout == 0) {
1060                 Tcl_SetStringObj(resultObj,
1061                     objc > 3 ? "timeouts must be greater than 0" :
1062                     "no previous timeout to reference", -1);
1063                 return TCL_ERROR;
1064             }
1065
1066             if (objc > 4)
1067                 if (Tcl_GetLongFromObj (interp, objv [4], &maxmem) == TCL_ERROR)
1068                     return TCL_ERROR;
1069
1070             if (ldap_enable_cache (ldap, timeout, maxmem) == -1) {
1071                 Tcl_AppendStringsToObj (resultObj,
1072                                         "LDAP cache enable error: ",
1073                                         LDAP_ERR_STRING(ldap),
1074                                         (char *)NULL);
1075                 LDAP_SetErrorCode(ldaptcl, -1, interp);
1076                 return TCL_ERROR;
1077             }
1078             ldaptcl->caching = 1;
1079             ldaptcl->timeout = timeout;
1080             ldaptcl->maxmem = maxmem;
1081             return TCL_OK;
1082         }
1083
1084         if (objc != 3) goto badargs;
1085
1086         if (STREQU (cacheCommand, "disable")) {
1087             ldap_disable_cache (ldap);
1088             ldaptcl->caching = 0;
1089             return TCL_OK;
1090         }
1091
1092         if (STREQU (cacheCommand, "destroy")) {
1093             ldap_destroy_cache (ldap);
1094             ldaptcl->caching = 0;
1095             return TCL_OK;
1096         }
1097
1098         if (STREQU (cacheCommand, "flush")) {
1099             ldap_flush_cache (ldap);
1100             return TCL_OK;
1101         }
1102
1103         if (STREQU (cacheCommand, "no_errors")) {
1104             ldap_set_cache_options (ldap, LDAP_CACHE_OPT_CACHENOERRS);
1105             return TCL_OK;
1106         }
1107
1108         if (STREQU (cacheCommand, "all_errors")) {
1109             ldap_set_cache_options (ldap, LDAP_CACHE_OPT_CACHEALLERRS);
1110             return TCL_OK;
1111         }
1112
1113         if (STREQU (cacheCommand, "size_errors")) {
1114             ldap_set_cache_options (ldap, 0);
1115             return TCL_OK;
1116         }
1117         Tcl_AppendStringsToObj (resultObj,
1118                                 "\"",
1119                                 command,
1120                                 " ",
1121                                 subCommand,
1122                                 "\" subcommand",
1123                                 " must be one of \"enable\", ",
1124                                 "\"disable\", ",
1125                                 "\"destroy\", \"flush\", \"uncache\", ",
1126                                 "\"no_errors\", \"size_errors\",",
1127                                 " or \"all_errors\"",
1128                                 (char *)NULL);
1129         return TCL_ERROR;
1130 #else
1131         return TCL_OK;
1132 #endif
1133     }
1134     if (STREQU (subCommand, "trap")) {
1135         Tcl_Obj *listObj, *resultObj;
1136         int *p, l, i, code;
1137
1138         if (objc > 4) {
1139             Tcl_WrongNumArgs (interp, 2, objv,
1140                                    "command ?errorCode-list?");
1141             return TCL_ERROR;
1142         }
1143         if (objc == 2) {
1144             if (!ldaptcl->trapCmdObj)
1145                 return TCL_OK;
1146             resultObj = Tcl_NewListObj(0, NULL);
1147             Tcl_ListObjAppendElement(interp, resultObj, ldaptcl->trapCmdObj);
1148             if (ldaptcl->traplist) {
1149                 listObj = Tcl_NewObj();
1150                 for (p = ldaptcl->traplist; *p; p++) {
1151                     Tcl_ListObjAppendElement(interp, listObj,
1152                         Tcl_NewStringObj(ldaptclerrorcode[*p], -1));
1153                 }
1154                 Tcl_ListObjAppendElement(interp, resultObj, listObj);
1155             }
1156             Tcl_SetObjResult(interp, resultObj);
1157             return TCL_OK;
1158         }
1159         if (ldaptcl->trapCmdObj) {
1160             Tcl_DecrRefCount (ldaptcl->trapCmdObj);
1161             ldaptcl->trapCmdObj = NULL;
1162         }
1163         if (ldaptcl->traplist) {
1164             free(ldaptcl->traplist);
1165             ldaptcl->traplist = NULL;
1166         }
1167         Tcl_GetStringFromObj(objv[2], &l);
1168         if (l == 0)
1169             return TCL_OK;              /* just turn off trap */
1170         ldaptcl->trapCmdObj = objv[2];
1171         Tcl_IncrRefCount (ldaptcl->trapCmdObj);
1172         if (objc < 4)
1173             return TCL_OK;              /* no code list */
1174         if (Tcl_ListObjLength(interp, objv[3], &l) != TCL_OK)
1175             return TCL_ERROR;
1176         if (l == 0)
1177             return TCL_OK;              /* empty code list */
1178         ldaptcl->traplist = (int*)malloc(sizeof(int) * (l + 1));
1179         ldaptcl->traplist[l] = 0;
1180         for (i = 0; i < l; i++) {
1181             Tcl_ListObjIndex(interp, objv[3], i, &resultObj);
1182             code = LDAP_ErrorStringToCode(interp, Tcl_GetStringFromObj(resultObj, NULL));
1183             if (code == -1) {
1184                 free(ldaptcl->traplist);
1185                 ldaptcl->traplist = NULL;
1186                 return TCL_ERROR;
1187             }
1188             ldaptcl->traplist[i] = code;
1189         }
1190         return TCL_OK;
1191     }
1192     if (STREQU (subCommand, "trapcodes")) {
1193         int code;
1194         Tcl_Obj *resultObj;
1195         Tcl_Obj *stringObj;
1196         resultObj = Tcl_GetObjResult(interp);
1197
1198         for (code = 0; code < LDAPTCL_MAXERR; code++) {
1199             if (!ldaptclerrorcode[code]) continue;
1200             Tcl_ListObjAppendElement(interp, resultObj,
1201                         Tcl_NewStringObj(ldaptclerrorcode[code], -1));
1202         }
1203         return TCL_OK;
1204     }
1205 #ifdef LDAP_DEBUG
1206     if (STREQU (subCommand, "debug")) {
1207         if (objc != 3) {
1208             Tcl_AppendStringsToObj(resultObj, "Wrong # of arguments",
1209                 (char*)NULL);
1210             return TCL_ERROR;
1211         }
1212         return Tcl_GetIntFromObj(interp, objv[2], &ldap_debug);
1213     }
1214 #endif
1215
1216     /* FIX: this needs to enumerate all the possibilities */
1217     Tcl_AppendStringsToObj (resultObj,
1218                             "subcommand \"",
1219                             subCommand,
1220                             "\" must be one of \"add\", ",
1221                             "\"add_attributes\", ",
1222                             "\"bind\", \"cache\", \"delete\", ",
1223                             "\"delete_attributes\", \"modify\", ",
1224                             "\"modify_rdn\", \"rename_rdn\", ",
1225                             "\"replace_attributes\", ",
1226                             "\"search\" or \"unbind\".",
1227                             (char *)NULL);
1228     return TCL_ERROR;
1229 }
1230
1231 /*
1232  * Delete and LDAP command object
1233  *
1234  */
1235 static void
1236 NeoX_LdapObjDeleteCmd(clientData)
1237     ClientData    clientData;
1238 {
1239     LDAPTCL      *ldaptcl = (LDAPTCL *)clientData;
1240     LDAP         *ldap = ldaptcl->ldap;
1241
1242     if (ldaptcl->trapCmdObj)
1243         Tcl_DecrRefCount (ldaptcl->trapCmdObj);
1244     if (ldaptcl->traplist)
1245         free(ldaptcl->traplist);
1246     ldap_unbind(ldap);
1247     free((char*) ldaptcl);
1248 }
1249
1250 /*-----------------------------------------------------------------------------
1251  * NeoX_LdapObjCmd --
1252  *
1253  * Implements the `ldap' command:
1254  *    ldap open newObjName host [port]
1255  *    ldap init newObjName host [port]
1256  *
1257  * Results:
1258  *      A standard Tcl result.
1259  *
1260  * Side effects:
1261  *      See the user documentation.
1262  *-----------------------------------------------------------------------------
1263  */
1264 static int
1265 NeoX_LdapObjCmd (clientData, interp, objc, objv)
1266     ClientData    clientData;
1267     Tcl_Interp   *interp;
1268     int           objc;
1269     Tcl_Obj      *CONST objv[];
1270 {
1271     extern int    errno;
1272     char         *subCommand;
1273     char         *newCommand;
1274     char         *ldapHost;
1275     int           ldapPort = LDAP_PORT;
1276     LDAP         *ldap;
1277     LDAPTCL      *ldaptcl;
1278
1279     Tcl_Obj      *resultObj = Tcl_GetObjResult (interp);
1280
1281     if (objc < 3) {
1282         Tcl_WrongNumArgs (interp, 1, objv,
1283                                "(open|init) new_command host [port]|explode dn");
1284         return TCL_ERROR;
1285     }
1286
1287     subCommand = Tcl_GetStringFromObj (objv[1], NULL);
1288
1289     if (STREQU(subCommand, "explode")) {
1290         char *param;
1291         int nonames = 0;
1292         int list = 0;
1293         char **exploded, **p;
1294
1295         param = Tcl_GetStringFromObj (objv[2], NULL);
1296         if (param[0] == '-') {
1297             if (STREQU(param, "-nonames")) {
1298                 nonames = 1;
1299             } else if (STREQU(param, "-list")) {
1300                 list = 1;
1301             } else {
1302                 Tcl_WrongNumArgs (interp, 1, objv, "explode ?-nonames|-list? dn");
1303                 return TCL_ERROR;
1304             }
1305         }
1306         if (nonames || list)
1307             param = Tcl_GetStringFromObj (objv[3], NULL);
1308         exploded = ldap_explode_dn(param, nonames);
1309         for (p = exploded; *p; p++) {
1310             if (list) {
1311                 char *q = strchr(*p, '=');
1312                 if (!q) {
1313                     Tcl_SetObjLength(resultObj, 0);
1314                     Tcl_AppendStringsToObj(resultObj, "rdn ", *p,
1315                         " missing '='", NULL);
1316                     ldap_value_free(exploded);
1317                     return TCL_ERROR;
1318                 }
1319                 *q = '\0';
1320                 if (Tcl_ListObjAppendElement(interp, resultObj,
1321                         Tcl_NewStringObj(*p, -1)) != TCL_OK ||
1322                         Tcl_ListObjAppendElement(interp, resultObj,
1323                         Tcl_NewStringObj(q+1, -1)) != TCL_OK) {
1324                     ldap_value_free(exploded);
1325                     return TCL_ERROR;
1326                 }
1327             } else {
1328                 if (Tcl_ListObjAppendElement(interp, resultObj,
1329                         Tcl_NewStringObj(*p, -1))) {
1330                     ldap_value_free(exploded);
1331                     return TCL_ERROR;
1332                 }
1333             }
1334         }
1335         ldap_value_free(exploded);
1336         return TCL_OK;
1337     }
1338
1339 #ifdef UMICH_LDAP
1340     if (STREQU(subCommand, "friendly")) {
1341         char *friendly = ldap_dn2ufn(Tcl_GetStringFromObj(objv[2], NULL));
1342         Tcl_SetStringObj(resultObj, friendly, -1);
1343         free(friendly);
1344         return TCL_OK;
1345     }
1346 #endif
1347
1348     newCommand = Tcl_GetStringFromObj (objv[2], NULL);
1349     ldapHost = Tcl_GetStringFromObj (objv[3], NULL);
1350
1351     if (objc == 5) {
1352         if (Tcl_GetIntFromObj (interp, objv [4], &ldapPort) == TCL_ERROR) {
1353             Tcl_AppendStringsToObj (resultObj,
1354                                     "LDAP port number is non-numeric",
1355                                     (char *)NULL);
1356             return TCL_ERROR;
1357         }
1358     }
1359
1360     if (STREQU (subCommand, "open")) {
1361         ldap = ldap_open (ldapHost, ldapPort);
1362     } else if (STREQU (subCommand, "init")) {
1363         int version = -1;
1364         int i;
1365         int value;
1366         char *subOption;
1367         char *subValue;
1368
1369 #if LDAPTCL_PROTOCOL_VERSION_DEFAULT
1370         version = LDAPTCL_PROTOCOL_VERSION_DEFAULT;
1371 #endif
1372
1373         for (i = 6; i < objc; i += 2)  {
1374             subOption =  Tcl_GetStringFromObj(objv[i-1], NULL);
1375             if (STREQU (subOption, "protocol_version")) {
1376 #ifdef LDAP_OPT_PROTOCOL_VERSION
1377                 subValue = Tcl_GetStringFromObj(objv[i], NULL);
1378                 if (STREQU (subValue, "2")) {
1379                     version = LDAP_VERSION2;
1380                 }
1381                 else if (STREQU (subValue, "3")) {
1382 #ifdef LDAP_VERSION3
1383                     version = LDAP_VERSION3;
1384 #else
1385                     Tcl_SetStringObj (resultObj, "protocol_version 3 not supported", -1);
1386                     return TCL_ERROR;
1387 #endif
1388                 }
1389                 else {
1390                     Tcl_SetStringObj (resultObj, "protocol_version must be '2' or '3'", -1);
1391                     return TCL_ERROR;
1392                 }
1393 #else
1394                 Tcl_SetStringObj (resultObj, "protocol_version not supported", -1);
1395                 return TCL_ERROR;
1396 #endif
1397             } else if (STREQU (subOption, "port")) {
1398                 if (Tcl_GetIntFromObj (interp, objv [i], &ldapPort) == TCL_ERROR) {
1399                     Tcl_AppendStringsToObj (resultObj,
1400                                             "LDAP port number is non-numeric",
1401                                             (char *)NULL);
1402                     return TCL_ERROR;
1403                 }
1404             } else {
1405                 Tcl_SetStringObj (resultObj, "valid options: protocol_version, port", -1);
1406                 return TCL_ERROR;
1407             }
1408         }
1409         ldap = ldap_init (ldapHost, ldapPort);
1410
1411 #ifdef LDAP_OPT_PROTOCOL_VERSION
1412         if (version != -1)
1413             ldap_set_option(ldap, LDAP_OPT_PROTOCOL_VERSION, &version);
1414 #endif
1415     } else {
1416         Tcl_AppendStringsToObj (resultObj,
1417                                 "option was not \"open\" or \"init\"");
1418         return TCL_ERROR;
1419     }
1420
1421     if (ldap == (LDAP *)NULL) {
1422         Tcl_SetErrno(errno);
1423         Tcl_AppendStringsToObj (resultObj,
1424                                 Tcl_PosixError (interp),
1425                                 (char *)NULL);
1426         return TCL_ERROR;
1427     }
1428
1429 #ifdef UMICH_LDAP
1430     ldap->ld_deref = LDAP_DEREF_NEVER;  /* Turn off alias dereferencing */
1431 #endif
1432
1433     ldaptcl = (LDAPTCL *) malloc(sizeof(LDAPTCL));
1434     ldaptcl->ldap = ldap;
1435     ldaptcl->caching = 0;
1436     ldaptcl->timeout = 0;
1437     ldaptcl->maxmem = 0;
1438     ldaptcl->trapCmdObj = NULL;
1439     ldaptcl->traplist = NULL;
1440     ldaptcl->flags = 0;
1441
1442     Tcl_CreateObjCommand (interp,
1443                           newCommand,
1444                           NeoX_LdapTargetObjCmd,
1445                           (ClientData) ldaptcl,
1446                           NeoX_LdapObjDeleteCmd);
1447     return TCL_OK;
1448 }
1449
1450 /*-----------------------------------------------------------------------------
1451  * Neo_initLDAP --
1452  *     Initialize the LDAP interface.
1453  *-----------------------------------------------------------------------------
1454  */
1455 int
1456 Ldaptcl_Init (interp)
1457 Tcl_Interp   *interp;
1458 {
1459     Tcl_CreateObjCommand (interp,
1460                           "ldap",
1461                           NeoX_LdapObjCmd,
1462                           (ClientData) NULL,
1463                           (Tcl_CmdDeleteProc*) NULL);
1464     /*
1465     if (Neo_initLDAPX(interp) != TCL_OK)
1466         return TCL_ERROR;
1467     */
1468     Tcl_PkgProvide(interp, "Ldaptcl", VERSION);
1469     return TCL_OK;
1470 }