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  * $Id$
  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  * Current support is by Randy Kunkee.
  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
  61 /*
  62  * The following section defines some common macros used by the rest
  63  * of the code.  It's ugly, and can use some work.  This code was
  64  * originally developed to work with Umich-3.3 LDAP.  It was debugged
  65  * against the Netscape LDAP server and the much more reliable SDK,
  66  * and then again backported to the Umich-3.3 client code.
  67  */
  68 #define OPEN_LDAP 1
  69 #if defined(OPEN_LDAP)
  70        /* LDAP_API_VERSION must be defined per the current draft spec
  71        ** it's value will be assigned RFC number.  However, as
  72        ** no RFC is defined, it's value is currently implementation
  73        ** specific (though I would hope it's value is greater than 1823).
  74        ** In OpenLDAP 2.x-devel, its 2000 + the draft number, ie 2002.
  75        ** This section is for OPENLDAP.
  76        */
  77 #define ldap_attributefree(p) ldap_memfree(p)
  78 #define ldap_memfree(p) free(p)
  79 #define LDAP_ERR_STRING(ld)  \
  80         ldap_err2string(ldap->ld_errno)
  81 #elif defined( LDAP_OPT_SIZELIMIT )
  82        /*
  83        ** Netscape SDK w/ ldap_set_option, ldap_get_option
  84        */
  85 #define ldap_attributefree(p) ldap_memfree(p)
  86 #define LDAP_ERR_STRING(ld)  \
  87         ldap_err2string(ldap_get_lderrno(ldap))
  88 #else
  89        /* U-Mich/OpenLDAP 1.x API */
  90        /* RFC-1823 w/ changes */
  91 #define UMICH_LDAP 1
  92 #define ldap_memfree(p) free(p)
  93 #define ldap_ber_free(p, n) ber_free(p, n)
  94 #define ldap_value_free_len(bvals) ber_bvecfree(bvals)
  95 #define ldap_attributefree(p)
  96 #define LDAP_ERR_STRING(ld)  \
  97         ldap_err2string(ld->ld_errno)
  98 #endif
  99
 100
 101
 102 /*-----------------------------------------------------------------------------
 103  * LDAP_ProcessOneSearchResult --
 104  *
 105  *   Process one result return from an LDAP search.
 106  *
 107  * Paramaters:
 108  *   o interp -            Tcl interpreter; Errors are returned in result.
 109  *   o ldap -              LDAP structure pointer.
 110  *   o entry -             LDAP message pointer.
 111  *   o destArrayNameObj -  Name of Tcl array in which to store attributes.
 112  *   o evalCodeObj -       Tcl_Obj pointer to code to eval against this result.
 113  * Returns:
 114  *   o TCL_OK if processing succeeded..
 115  *   o TCL_ERROR if an error occured, with error message in interp.
 116  *-----------------------------------------------------------------------------
 117  */
 118 static int
 119 LDAP_ProcessOneSearchResult (interp, ldap, entry, destArrayNameObj, evalCodeObj)
 120     Tcl_Interp     *interp;
 121     LDAP           *ldap;
 122     LDAPMessage    *entry;
 123     Tcl_Obj        *destArrayNameObj;
 124     Tcl_Obj        *evalCodeObj;
 125 {
 126     char           *attributeName;
 127     Tcl_Obj        *attributeNameObj;
 128     Tcl_Obj        *attributeDataObj;
 129     int             i;
 130     BerElement     *ber;
 131     struct berval **bvals;
 132     char           *dn;
 133
 134     Tcl_UnsetVar (interp, Tcl_GetStringFromObj (destArrayNameObj, NULL), 0);
 135
 136     dn = ldap_get_dn(ldap, entry);
 137     if (dn != NULL) {
 138         if (Tcl_SetVar2(interp,         /* set dn */
 139                        Tcl_GetStringFromObj(destArrayNameObj, NULL),
 140                        "dn",
 141                        dn,
 142                        TCL_LEAVE_ERR_MSG) == NULL)
 143             return TCL_ERROR;
 144         ldap_memfree(dn);
 145     }
 146     for (attributeName = ldap_first_attribute (ldap, entry, &ber);
 147       attributeName != NULL;
 148       attributeName = ldap_next_attribute(ldap, entry, ber)) {
 149
 150         bvals = ldap_get_values_len(ldap, entry, attributeName);
 151
 152         if (bvals != NULL) {
 153             /* Note here that the U.of.M. ldap will return a null bvals
 154                when the last attribute value has been deleted, but still
 155                retains the attributeName.  Even though this is documented
 156                as an error, we ignore it to present a consistent interface
 157                with Netscape's server
 158             */
 159             attributeNameObj = Tcl_NewStringObj (attributeName, -1);
 160             Tcl_IncrRefCount (attributeNameObj);
 161             attributeDataObj = Tcl_NewObj();
 162             for (i = 0; bvals[i] != NULL; i++) {
 163                 Tcl_Obj *singleAttributeValueObj;
 164
 165                 singleAttributeValueObj = Tcl_NewStringObj (bvals[i]->bv_val, -1);
 166                 if (Tcl_ListObjAppendElement (interp,
 167                                               attributeDataObj,
 168                                               singleAttributeValueObj)
 169                   == TCL_ERROR) {
 170                     return TCL_ERROR;
 171                 }
 172             }
 173
 174             ldap_value_free_len(bvals);
 175
 176             if (Tcl_ObjSetVar2 (interp,
 177                                 destArrayNameObj,
 178                                 attributeNameObj,
 179                                 attributeDataObj,
 180                                 TCL_LEAVE_ERR_MSG) == NULL) {
 181                 return TCL_ERROR;
 182             }
 183             Tcl_DecrRefCount (attributeNameObj);
 184         }
 185         ldap_attributefree(attributeName);
 186     }
 187     return Tcl_EvalObj (interp, evalCodeObj);
 188 }
 189
 190 /*-----------------------------------------------------------------------------
 191  * LDAP_PerformSearch --
 192  *
 193  *   Perform an LDAP search.
 194  *
 195  * Paramaters:
 196  *   o interp -            Tcl interpreter; Errors are returned in result.
 197  *   o ldap -              LDAP structure pointer.
 198  *   o base -              Base DN from which to perform search.
 199  *   o scope -             LDAP search scope, must be one of LDAP_SCOPE_BASE,
 200  *                         LDAP_SCOPE_ONELEVEL, or LDAP_SCOPE_SUBTREE.
 201  *   o attrs -             Pointer to array of char * pointers of desired
 202  *                         attribute names, or NULL for all attributes.
 203  *   o filtpatt            LDAP filter pattern.
 204  *   o value               Value to get sprintf'ed into filter pattern.
 205  *   o destArrayNameObj -  Name of Tcl array in which to store attributes.
 206  *   o evalCodeObj -       Tcl_Obj pointer to code to eval against this result.
 207  * Returns:
 208  *   o TCL_OK if processing succeeded..
 209  *   o TCL_ERROR if an error occured, with error message in interp.
 210  *-----------------------------------------------------------------------------
 211  */
 212 static int
 213 LDAP_PerformSearch (interp, ldap, base, scope, attrs, filtpatt, value, destArrayNameObj, evalCodeObj, timeout_p)
 214     Tcl_Interp     *interp;
 215     LDAP           *ldap;
 216     char           *base;
 217     int             scope;
 218     char          **attrs;
 219     char           *filtpatt;
 220     char           *value;
 221     Tcl_Obj        *destArrayNameObj;
 222     Tcl_Obj        *evalCodeObj;
 223     struct timeval *timeout_p;
 224 {
 225     char          filter[BUFSIZ];
 226     int           resultCode;
 227     int           errorCode;
 228     int           abandon;
 229     int           tclResult = TCL_OK;
 230     int           msgid;
 231     LDAPMessage  *resultMessage;
 232     LDAPMessage  *entryMessage;
 233
 234     Tcl_Obj      *resultObj;
 235     int           lderr;
 236
 237     resultObj = Tcl_GetObjResult (interp);
 238
 239     sprintf(filter, filtpatt, value);
 240
 241     if ((msgid = ldap_search (ldap, base, scope, filter, attrs, 0)) == -1) {
 242         Tcl_AppendStringsToObj (resultObj,
 243                                 "LDAP start search error: ",
 244                                         LDAP_ERR_STRING(ldap),
 245                                 (char *)NULL);
 246         return TCL_ERROR;
 247     }
 248
 249     abandon = 0;
 250     while ((resultCode = ldap_result (ldap,
 251                               msgid,
 252                               0,
 253                               timeout_p,
 254                               &resultMessage)) == LDAP_RES_SEARCH_ENTRY) {
 255
 256         entryMessage = ldap_first_entry(ldap, resultMessage);
 257
 258         tclResult = LDAP_ProcessOneSearchResult  (interp,
 259                                 ldap,
 260                                 entryMessage,
 261                                 destArrayNameObj,
 262                                 evalCodeObj);
 263         ldap_msgfree(resultMessage);
 264         if (tclResult != TCL_OK) {
 265             if (tclResult == TCL_CONTINUE) {
 266                 tclResult = TCL_OK;
 267             } else if (tclResult == TCL_BREAK) {
 268                 tclResult = TCL_OK;
 269                 abandon = 1;
 270                 break;
 271             } else if (tclResult == TCL_ERROR) {
 272                 char msg[100];
 273                 sprintf(msg, "\n    (\"search\" body line %d)",
 274                         interp->errorLine);
 275                 Tcl_AddObjErrorInfo(interp, msg, -1);
 276                 abandon = 1;
 277                 break;
 278             } else {
 279                 abandon = 1;
 280                 break;
 281             }
 282         }
 283     }
 284     if (abandon || resultCode == 0) {
 285         ldap_abandon(ldap, msgid);
 286         if (resultCode == 0) {
 287             Tcl_SetErrorCode (interp, "TIMEOUT", (char*) NULL);
 288             Tcl_SetStringObj (resultObj, "LDAP timeout retrieving results", -1);
 289             return TCL_ERROR;
 290         }
 291     } else {
 292         if (resultCode == LDAP_RES_SEARCH_RESULT) {
 293             if ((errorCode = ldap_result2error (ldap, resultMessage, 0))
 294               != LDAP_SUCCESS) {
 295               Tcl_AppendStringsToObj (resultObj,
 296                                       "LDAP search error: ",
 297                                       ldap_err2string(errorCode),
 298                                       (char *)NULL);
 299               ldap_msgfree(resultMessage);
 300               return TCL_ERROR;
 301             }
 302         }
 303
 304
 305         if (resultCode == -1) {
 306             Tcl_AppendStringsToObj (resultObj,
 307                                     "LDAP result search error: ",
 308                                     LDAP_ERR_STRING(ldap),
 309                                     (char *)NULL);
 310             return TCL_ERROR;
 311         } else
 312             ldap_msgfree(resultMessage);
 313     }
 314
 315     return tclResult;
 316 }
 317
 318 /*-----------------------------------------------------------------------------
 319  * NeoX_LdapTargetObjCmd --
 320  *
 321  * Implements the body of commands created by Neo_LdapObjCmd.
 322  *
 323  * Results:
 324  *      A standard Tcl result.
 325  *
 326  * Side effects:
 327  *      See the user documentation.
 328  *-----------------------------------------------------------------------------
 329  */
 330 static int
 331 NeoX_LdapTargetObjCmd (clientData, interp, objc, objv)
 332     ClientData    clientData;
 333     Tcl_Interp   *interp;
 334     int           objc;
 335     Tcl_Obj      *CONST objv[];
 336 {
 337     char         *command;
 338     char         *subCommand;
 339     LDAP         *ldap = (LDAP *)clientData;
 340     char         *dn;
 341     int           is_add = 0;
 342     int           is_add_or_modify = 0;
 343     int           mod_op = 0;
 344     char         *m, *s, *errmsg;
 345     int          errcode;
 346
 347     Tcl_Obj      *resultObj = Tcl_GetObjResult (interp);
 348
 349     if (objc < 2)
 350        return TclX_WrongArgs (interp,
 351                               objv [0],
 352                               "subcommand [args...]");
 353
 354     command = Tcl_GetStringFromObj (objv[0], NULL);
 355     subCommand = Tcl_GetStringFromObj (objv[1], NULL);
 356
 357     /* object bind authtype name password */
 358     if (STREQU (subCommand, "bind")) {
 359         char     *binddn;
 360         char     *passwd;
 361         int       stringLength;
 362         char     *ldap_authString;
 363         int       ldap_authInt;
 364
 365         if (objc != 5)
 366             return TclX_WrongArgs (interp, objv [0], "bind authtype dn passwd");
 367
 368         ldap_authString = Tcl_GetStringFromObj (objv[2], NULL);
 369
 370         if (STREQU (ldap_authString, "simple")) {
 371             ldap_authInt = LDAP_AUTH_SIMPLE;
 372         }
 373 #ifdef UMICH_LDAP
 374         else if (STREQU (ldap_authString, "kerberos_ldap")) {
 375             ldap_authInt = LDAP_AUTH_KRBV41;
 376         } else if (STREQU (ldap_authString, "kerberos_dsa")) {
 377             ldap_authInt = LDAP_AUTH_KRBV42;
 378         } else if (STREQU (ldap_authString, "kerberos_both")) {
 379             ldap_authInt = LDAP_AUTH_KRBV4;
 380         }
 381 #endif
 382         else {
 383             Tcl_AppendStringsToObj (resultObj,
 384                                     "\"",
 385                                     command,
 386                                     " ",
 387                                     subCommand,
 388 #ifdef UMICH_LDAP
 389                                     "\" authtype must be one of \"simple\", ",
 390                                     "\"kerberos_ldap\", \"kerberos_dsa\" ",
 391                                     "or \"kerberos_both\"",
 392 #else
 393                                     "\" authtype must be \"simple\", ",
 394 #endif
 395                                     (char *)NULL);
 396             return TCL_ERROR;
 397         }
 398
 399         binddn = Tcl_GetStringFromObj (objv[3], &stringLength);
 400         if (stringLength == 0)
 401             binddn = NULL;
 402
 403         passwd = Tcl_GetStringFromObj (objv[4], &stringLength);
 404         if (stringLength == 0)
 405             passwd = NULL;
 406
 407 /*  ldap_bind_s(ldap, dn, pw, method) */
 408
 409 #ifdef UMICH_LDAP
 410 #define LDAP_BIND(ldap, dn, pw, method) \
 411   ldap_bind_s(ldap, dn, pw, method)
 412 #else
 413 #define LDAP_BIND(ldap, dn, pw, method) \
 414   ldap_simple_bind_s(ldap, dn, pw)
 415 #endif
 416         if ((errcode = LDAP_BIND (ldap,
 417                          binddn,
 418                          passwd,
 419                          ldap_authInt)) != LDAP_SUCCESS) {
 420
 421             Tcl_AppendStringsToObj (resultObj,
 422                                     "LDAP bind error: ",
 423                                     ldap_err2string(errcode),
 424                                     (char *)NULL);
 425             return TCL_ERROR;
 426         }
 427         return TCL_OK;
 428     }
 429
 430     if (STREQU (subCommand, "unbind")) {
 431         if (objc != 2)
 432             return TclX_WrongArgs (interp, objv [0], "unbind");
 433
 434        return Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], NULL));
 435     }
 436
 437     /* object delete dn */
 438     if (STREQU (subCommand, "delete")) {
 439         if (objc != 3)
 440             return TclX_WrongArgs (interp, objv [0], "delete dn");
 441
 442        dn = Tcl_GetStringFromObj (objv [2], NULL);
 443        if ((errcode = ldap_delete_s(ldap, dn)) != LDAP_SUCCESS) {
 444            Tcl_AppendStringsToObj (resultObj,
 445                                    "LDAP delete error: ",
 446                                    ldap_err2string(errcode),
 447                                    (char *)NULL);
 448            return TCL_ERROR;
 449        }
 450        return TCL_OK;
 451     }
 452
 453     /* object rename_rdn dn rdn */
 454     /* object modify_rdn dn rdn */
 455     if (STREQU (subCommand, "rename_rdn") || STREQU (subCommand, "modify_rdn")) {
 456         char    *rdn;
 457         int      deleteOldRdn;
 458
 459         if (objc != 4)
 460             return TclX_WrongArgs (interp,
 461                                    objv [0],
 462                                    "delete_rdn|modify_rdn dn rdn");
 463
 464         dn = Tcl_GetStringFromObj (objv [2], NULL);
 465         rdn = Tcl_GetStringFromObj (objv [3], NULL);
 466
 467         deleteOldRdn = (*subCommand == 'r');
 468
 469         if ((errcode = ldap_modrdn2_s (ldap, dn, rdn, deleteOldRdn)) != LDAP_SUCCESS) {
 470             Tcl_AppendStringsToObj (resultObj,
 471                                     "LDAP ",
 472                                     subCommand,
 473                                     " error: ",
 474                                     ldap_err2string(errcode),
 475                                     (char *)NULL);
 476             return TCL_ERROR;
 477         }
 478         return TCL_OK;
 479     }
 480
 481     /* object add dn attributePairList */
 482     /* object add_attributes dn attributePairList */
 483     /* object replace_attributes dn attributePairList */
 484     /* object delete_attributes dn attributePairList */
 485
 486     if (STREQU (subCommand, "add")) {
 487         is_add = 1;
 488         is_add_or_modify = 1;
 489     } else {
 490         is_add = 0;
 491         if (STREQU (subCommand, "add_attributes")) {
 492             is_add_or_modify = 1;
 493             mod_op = LDAP_MOD_ADD;
 494         } else if (STREQU (subCommand, "replace_attributes")) {
 495             is_add_or_modify = 1;
 496             mod_op = LDAP_MOD_REPLACE;
 497         } else if (STREQU (subCommand, "delete_attributes")) {
 498             is_add_or_modify = 1;
 499             mod_op = LDAP_MOD_DELETE;
 500         }
 501     }
 502
 503     if (is_add_or_modify) {
 504         int          result;
 505         LDAPMod    **modArray;
 506         LDAPMod     *mod;
 507         char       **valPtrs = NULL;
 508         int          attribObjc;
 509         Tcl_Obj    **attribObjv;
 510         int          valuesObjc;
 511         Tcl_Obj    **valuesObjv;
 512         int          nPairs;
 513         int          i;
 514         int          j;
 515
 516         Tcl_Obj      *resultObj = Tcl_GetObjResult (interp);
 517
 518         if (objc != 4) {
 519             Tcl_AppendStringsToObj (resultObj,
 520                                     "wrong # args: ",
 521                                     Tcl_GetStringFromObj (objv [0], NULL),
 522                                     " ",
 523                                     subCommand,
 524                                     " dn attributePairList",
 525                                     (char *)NULL);
 526             return TCL_ERROR;
 527         }
 528
 529         dn = Tcl_GetStringFromObj (objv [2], NULL);
 530
 531         if (Tcl_ListObjGetElements (interp, objv [3], &attribObjc, &attribObjv)
 532           == TCL_ERROR) {
 533            return TCL_ERROR;
 534         }
 535
 536         if (attribObjc & 1) {
 537             Tcl_AppendStringsToObj (resultObj,
 538                                     "attribute list does not contain an ",
 539                                     "even number of key-value elements",
 540                                     (char *)NULL);
 541             return TCL_ERROR;
 542         }
 543
 544         nPairs = attribObjc / 2;
 545
 546         modArray = (LDAPMod **)ckalloc (sizeof(LDAPMod *) * (nPairs + 1));
 547         modArray[nPairs] = (LDAPMod *) NULL;
 548
 549         for (i = 0; i < nPairs; i++) {
 550             mod = modArray[i] = (LDAPMod *) ckalloc (sizeof(LDAPMod));
 551             mod->mod_op = mod_op;
 552             mod->mod_type = Tcl_GetStringFromObj (attribObjv [i * 2], NULL);
 553
 554             if (Tcl_ListObjGetElements (interp, attribObjv [i * 2 + 1], &valuesObjc, &valuesObjv) == TCL_ERROR) {
 555                 /* FIX: cleanup memory here */
 556                 return TCL_ERROR;
 557             }
 558
 559             valPtrs = mod->mod_vals.modv_strvals = \
 560                 (char **)ckalloc (sizeof (char *) * (valuesObjc + 1));
 561             valPtrs[valuesObjc] = (char *)NULL;
 562
 563             for (j = 0; j < valuesObjc; j++) {
 564                 valPtrs [j] = Tcl_GetStringFromObj (valuesObjv[j], NULL);
 565
 566                 /* If it's "delete" and value is an empty string, make
 567                  * value be NULL to indicate entire attribute is to be
 568                  * deleted */
 569                 if ((*valPtrs [j] == '\0')
 570                     && (mod->mod_op == LDAP_MOD_DELETE)) {
 571                         valPtrs [j] = NULL;
 572                 }
 573             }
 574         }
 575
 576         if (is_add) {
 577             result = ldap_add_s (ldap, dn, modArray);
 578         } else {
 579             result = ldap_modify_s (ldap, dn, modArray);
 580         }
 581
 582         /* free the modArray elements, then the modArray itself. */
 583         for (i = 0; i < nPairs; i++) {
 584             ckfree ((char *) modArray[i]->mod_vals.modv_strvals);
 585             ckfree ((char *) modArray[i]);
 586         }
 587         ckfree ((char *) modArray);
 588
 589         /* FIX: memory cleanup required all over the place here */
 590         if (result != LDAP_SUCCESS) {
 591             Tcl_AppendStringsToObj (resultObj,
 592                                     "LDAP ",
 593                                     subCommand,
 594                                     " error: ",
 595                                     ldap_err2string(result),
 596                                     (char *)NULL);
 597             return TCL_ERROR;
 598         }
 599         return TCL_OK;
 600     }
 601
 602     /* object search controlArray dn pattern */
 603     if (STREQU (subCommand, "search")) {
 604         char        *controlArrayName;
 605         Tcl_Obj     *controlArrayNameObj;
 606
 607         char        *scopeString;
 608         int          scope;
 609
 610         char        *derefString;
 611         int          deref;
 612
 613         char        *baseString;
 614
 615         char       **attributesArray;
 616         char        *attributesString;
 617         int          attributesArgc;
 618
 619         char        *filterPatternString;
 620
 621         char        *timeoutString;
 622         double       timeoutTime;
 623         struct timeval timeout, *timeout_p;
 624
 625         Tcl_Obj     *destArrayNameObj;
 626         Tcl_Obj     *evalCodeObj;
 627
 628         if (objc != 5)
 629             return TclX_WrongArgs (interp,
 630                                    objv [0],
 631                                    "search controlArray destArray code");
 632
 633         controlArrayNameObj = objv [2];
 634         controlArrayName = Tcl_GetStringFromObj (controlArrayNameObj, NULL);
 635
 636         destArrayNameObj = objv [3];
 637
 638         evalCodeObj = objv [4];
 639
 640         baseString = Tcl_GetVar2 (interp,
 641                                   controlArrayName,
 642                                   "base",
 643                                   0);
 644
 645         if (baseString == (char *)NULL) {
 646             Tcl_AppendStringsToObj (resultObj,
 647                                     "required element \"base\" ",
 648                                     "is missing from ldap control array \"",
 649                                     controlArrayName,
 650                                     "\"",
 651                                     (char *)NULL);
 652             return TCL_ERROR;
 653         }
 654
 655         filterPatternString = Tcl_GetVar2 (interp,
 656                                            controlArrayName,
 657                                            "filter",
 658                                            0);
 659         if (filterPatternString == (char *)NULL) {
 660             Tcl_AppendStringsToObj (resultObj,
 661                                     "required element \"filter\" ",
 662                                     "is missing from ldap control array \"",
 663                                     controlArrayName,
 664                                     "\"",
 665                                     (char *)NULL);
 666
 667             return TCL_ERROR;
 668         }
 669
 670         /* Fetch scope setting from control array.
 671          * If it doesn't exist, default to subtree scoping.
 672          */
 673         scopeString = Tcl_GetVar2 (interp, controlArrayName, "scope", 0);
 674         if (scopeString == NULL) {
 675             scope = LDAP_SCOPE_SUBTREE;
 676         } else {
 677             if (STREQU(scopeString, "base"))
 678                 scope = LDAP_SCOPE_BASE;
 679             else if (STREQU(scopeString, "onelevel"))
 680                 scope = LDAP_SCOPE_ONELEVEL;
 681             else if (STREQU(scopeString, "subtree"))
 682                 scope = LDAP_SCOPE_SUBTREE;
 683             else {
 684                 Tcl_AppendStringsToObj (resultObj,
 685                                         "\"scope\" element of \"",
 686                                         controlArrayName,
 687                                         "\" array is not one of ",
 688                                         "\"base\", \"one_level\", ",
 689                                         "or \"subtree\"",
 690                                       (char *) NULL);
 691                 return TCL_ERROR;
 692             }
 693         }
 694
 695         /* Fetch dereference control setting from control array.
 696          * If it doesn't exist, default to never dereference. */
 697         derefString = Tcl_GetVar2 (interp,
 698                                    controlArrayName,
 699                                    "deref",
 700                                    0);
 701
 702         if (derefString == (char *)NULL) {
 703             deref = LDAP_DEREF_NEVER;
 704         } else {
 705             if (STREQU(derefString, "never"))
 706                 deref = LDAP_DEREF_NEVER;
 707             else if (STREQU(derefString, "search"))
 708                 deref = LDAP_DEREF_SEARCHING;
 709             else if (STREQU(derefString, "find") == 0)
 710                 deref = LDAP_DEREF_FINDING;
 711             else if (STREQU(derefString, "always"))
 712                 deref = LDAP_DEREF_ALWAYS;
 713             else {
 714                 Tcl_AppendStringsToObj (resultObj,
 715                                         "\"deref\" element of \"",
 716                                         controlArrayName,
 717                                         "\" array is not one of ",
 718                                         "\"never\", \"search\", \"find\", ",
 719                                         "or \"always\"",
 720                                         (char *) NULL);
 721                 return TCL_ERROR;
 722             }
 723         }
 724
 725         /* Fetch list of attribute names from control array.
 726          * If entry doesn't exist, default to NULL (all).
 727          */
 728         attributesString = Tcl_GetVar2 (interp,
 729                                         controlArrayName,
 730                                         "attributes",
 731                                         0);
 732         if (attributesString == (char *)NULL) {
 733             attributesArray = NULL;
 734         } else {
 735             if ((Tcl_SplitList (interp,
 736                                 attributesString,
 737                                 &attributesArgc,
 738                                 &attributesArray)) != TCL_OK) {
 739                 return TCL_ERROR;
 740             }
 741         }
 742
 743         /* Fetch timeout value if there is one
 744          */
 745         timeoutString = Tcl_GetVar2 (interp,
 746                                         controlArrayName,
 747                                         "timeout",
 748                                         0);
 749         timeout.tv_usec = 0;
 750         if (timeoutString == (char *)NULL) {
 751             timeout_p = NULL;
 752             timeout.tv_sec = 0;
 753         } else {
 754             if (Tcl_GetDouble(interp, timeoutString, &timeoutTime) != TCL_OK)
 755                 return TCL_ERROR;
 756             timeout.tv_sec = floor(timeoutTime);
 757             timeout.tv_usec = (timeoutTime-timeout.tv_sec) * 1000000;
 758             timeout_p = &timeout;
 759         }
 760
 761 #ifdef UMICH_LDAP
 762         ldap->ld_deref = deref;
 763         ldap->ld_timelimit = 0;
 764         ldap->ld_sizelimit = 0;
 765         ldap->ld_options = 0;
 766 #endif
 767
 768          return LDAP_PerformSearch (interp,
 769                                     ldap,
 770                                     baseString,
 771                                     scope,
 772                                     attributesArray,
 773                                     filterPatternString,
 774                                     "",
 775                                     destArrayNameObj,
 776                                     evalCodeObj,
 777                                     timeout_p);
 778     }
 779
 780 #if UMICH_LDAP
 781     if (STREQU (subCommand, "cache")) {
 782         char *cacheCommand;
 783
 784         if (objc < 3)
 785           badargs:
 786             return TclX_WrongArgs (interp,
 787                                    objv [0],
 788                                    "cache command [args...]");
 789
 790         cacheCommand = Tcl_GetStringFromObj (objv [2], NULL);
 791
 792         if (STREQU (cacheCommand, "uncache")) {
 793             char *dn;
 794
 795             if (objc != 4)
 796                 return TclX_WrongArgs (interp,
 797                                        objv [0],
 798                                        "cache uncache dn");
 799
 800             dn = Tcl_GetStringFromObj (objv [3], NULL);
 801             ldap_uncache_entry (ldap, dn);
 802             return TCL_OK;
 803         }
 804
 805         if (STREQU (cacheCommand, "enable")) {
 806             long   timeout;
 807             long   maxmem;
 808
 809             if (objc != 5)
 810                 return TclX_WrongArgs (interp,
 811                                        objv [0],
 812                                        "cache enable timeout maxmem");
 813
 814             if (Tcl_GetLongFromObj (interp, objv [3], &timeout) == TCL_ERROR)
 815                 return TCL_ERROR;
 816
 817             if (Tcl_GetLongFromObj (interp, objv [4], &maxmem) == TCL_ERROR)
 818                 return TCL_ERROR;
 819
 820             if (ldap_enable_cache (ldap, timeout, maxmem) == -1) {
 821                 Tcl_AppendStringsToObj (resultObj,
 822                                         "LDAP cache enable error: ",
 823                                         LDAP_ERR_STRING(ldap),
 824                                         (char *)NULL);
 825                 return TCL_ERROR;
 826             }
 827             return TCL_OK;
 828         }
 829
 830         if (objc != 3) goto badargs;
 831
 832         if (STREQU (cacheCommand, "disable")) {
 833             ldap_disable_cache (ldap);
 834             return TCL_OK;
 835         }
 836
 837         if (STREQU (cacheCommand, "destroy")) {
 838             ldap_destroy_cache (ldap);
 839             return TCL_OK;
 840         }
 841
 842         if (STREQU (cacheCommand, "flush")) {
 843             ldap_flush_cache (ldap);
 844             return TCL_OK;
 845         }
 846
 847         if (STREQU (cacheCommand, "no_errors")) {
 848             ldap_set_cache_options (ldap, LDAP_CACHE_OPT_CACHENOERRS);
 849             return TCL_OK;
 850         }
 851
 852         if (STREQU (cacheCommand, "all_errors")) {
 853             ldap_set_cache_options (ldap, LDAP_CACHE_OPT_CACHEALLERRS);
 854             return TCL_OK;
 855         }
 856
 857         if (STREQU (cacheCommand, "size_errors")) {
 858             ldap_set_cache_options (ldap, 0);
 859             return TCL_OK;
 860         }
 861         Tcl_AppendStringsToObj (resultObj,
 862                                 "\"",
 863                                 command,
 864                                 " ",
 865                                 subCommand,
 866                                 "\" subcommand",
 867                                 " must be one of \"enable\", ",
 868                                 "\"disable\", ",
 869                                 "\"destroy\", \"flush\", \"uncache\", ",
 870                                 "\"no_errors\", \"size_errors\",",
 871                                 " or \"all_errors\"",
 872                                 (char *)NULL);
 873         return TCL_ERROR;
 874     }
 875 #endif
 876 #ifdef LDAP_DEBUG
 877     if (STREQU (subCommand, "debug")) {
 878         if (objc != 3) {
 879             Tcl_AppendStringsToObj(resultObj, "Wrong # of arguments",
 880                 (char*)NULL);
 881             return TCL_ERROR;
 882         }
 883         return Tcl_GetIntFromObj(interp, objv[2], &ldap_debug);
 884     }
 885 #endif
 886
 887     /* FIX: this needs to enumerate all the possibilities */
 888     Tcl_AppendStringsToObj (resultObj,
 889                             "subcommand \"",
 890                             subCommand,
 891                             "\" must be one of \"add\", ",
 892                             "\"add_attributes\", ",
 893                             "\"bind\", \"cache\", \"delete\", ",
 894                             "\"delete_attributes\", \"modify\", ",
 895                             "\"modify_rdn\", \"rename_rdn\", ",
 896                             "\"replace_attributes\", ",
 897                             "\"search\" or \"unbind\".",
 898                             (char *)NULL);
 899     return TCL_ERROR;
 900 }
 901
 902 /*
 903  * Delete and LDAP command object
 904  *
 905  */
 906 static void
 907 NeoX_LdapObjDeleteCmd(clientData)
 908     ClientData    clientData;
 909 {
 910     LDAP         *ldap = (LDAP *)clientData;
 911
 912     ldap_unbind(ldap);
 913 }
 914
 915 /*-----------------------------------------------------------------------------
 916  * NeoX_LdapObjCmd --
 917  *
 918  * Implements the `ldap' command:
 919  *    ldap open newObjName host [port]
 920  *    ldap init newObjName host [port]
 921  *
 922  * Results:
 923  *      A standard Tcl result.
 924  *
 925  * Side effects:
 926  *      See the user documentation.
 927  *-----------------------------------------------------------------------------
 928  */
 929 static int
 930 NeoX_LdapObjCmd (clientData, interp, objc, objv)
 931     ClientData    clientData;
 932     Tcl_Interp   *interp;
 933     int           objc;
 934     Tcl_Obj      *CONST objv[];
 935 {
 936     extern int    errno;
 937     char         *subCommand;
 938     char         *newCommand;
 939     char         *ldapHost;
 940     int           ldapPort = 389;
 941     LDAP         *ldap;
 942
 943     Tcl_Obj      *resultObj = Tcl_GetObjResult (interp);
 944
 945     if (objc < 3 || objc > 5)
 946         return TclX_WrongArgs (interp, objv [0],
 947                                "(open|init) new_command host [port]|explode dn");
 948
 949     subCommand = Tcl_GetStringFromObj (objv[1], NULL);
 950
 951     if (STREQU(subCommand, "explode")) {
 952         char *param;
 953         int nonames = 0;
 954         int list = 0;
 955         char **exploded, **p;
 956
 957         param = Tcl_GetStringFromObj (objv[2], NULL);
 958         if (param[0] == '-') {
 959             if (STREQU(param, "-nonames")) {
 960                 nonames = 1;
 961             } else if (STREQU(param, "-list")) {
 962                 list = 1;
 963             } else {
 964                 return TclX_WrongArgs (interp, objv [0], "explode ?-nonames|-list? dn");
 965             }
 966         }
 967         if (nonames || list)
 968             param = Tcl_GetStringFromObj (objv[3], NULL);
 969         exploded = ldap_explode_dn(param, nonames);
 970         for (p = exploded; *p; p++) {
 971             if (list) {
 972                 char *q = strchr(*p, '=');
 973                 if (!q) {
 974                     Tcl_SetObjLength(resultObj, 0);
 975                     Tcl_AppendStringsToObj(resultObj, "rdn ", *p,
 976                         " missing '='", NULL);
 977                     ldap_value_free(exploded);
 978                     return TCL_ERROR;
 979                 }
 980                 *q = '\0';
 981                 if (Tcl_ListObjAppendElement(interp, resultObj,
 982                         Tcl_NewStringObj(*p, -1)) != TCL_OK ||
 983                         Tcl_ListObjAppendElement(interp, resultObj,
 984                         Tcl_NewStringObj(q+1, -1)) != TCL_OK) {
 985                     ldap_value_free(exploded);
 986                     return TCL_ERROR;
 987                 }
 988             } else {
 989                 if (Tcl_ListObjAppendElement(interp, resultObj,
 990                         Tcl_NewStringObj(*p, -1))) {
 991                     ldap_value_free(exploded);
 992                     return TCL_ERROR;
 993                 }
 994             }
 995         }
 996         ldap_value_free(exploded);
 997         return TCL_OK;
 998     }
 999
1000 #ifdef UMICH_LDAP
1001     if (STREQU(subCommand, "friendly")) {
1002         char *friendly = ldap_dn2ufn(Tcl_GetStringFromObj(objv[2], NULL));
1003         Tcl_SetStringObj(resultObj, friendly, -1);
1004         free(friendly);
1005         return TCL_OK;
1006     }
1007 #endif
1008
1009     newCommand = Tcl_GetStringFromObj (objv[2], NULL);
1010     ldapHost = Tcl_GetStringFromObj (objv[3], NULL);
1011
1012     if (objc == 5) {
1013         if (Tcl_GetIntFromObj (interp, objv [4], &ldapPort) == TCL_ERROR) {
1014             Tcl_AppendStringsToObj (resultObj,
1015                                     "LDAP port number is non-numeric",
1016                                     (char *)NULL);
1017             return TCL_ERROR;
1018         }
1019     }
1020
1021     if (STREQU (subCommand, "open")) {
1022         ldap = ldap_open (ldapHost, ldapPort);
1023     } else if (STREQU (subCommand, "init")) {
1024         ldap = ldap_init (ldapHost, ldapPort);
1025     } else {
1026         Tcl_AppendStringsToObj (resultObj,
1027                                 "option was not \"open\" or \"init\"");
1028         return TCL_ERROR;
1029     }
1030
1031     if (ldap == (LDAP *)NULL) {
1032         Tcl_SetErrno(errno);
1033         Tcl_AppendStringsToObj (resultObj,
1034                                 Tcl_PosixError (interp),
1035                                 (char *)NULL);
1036         return TCL_ERROR;
1037     }
1038
1039 #if UMICH_LDAP
1040     ldap->ld_deref = LDAP_DEREF_NEVER;  /* Turn off alias dereferencing */
1041 #endif
1042
1043     Tcl_CreateObjCommand (interp,
1044                           newCommand,
1045                           NeoX_LdapTargetObjCmd,
1046                           (ClientData) ldap,
1047                           NeoX_LdapObjDeleteCmd);
1048     return TCL_OK;
1049 }
1050
1051 /*-----------------------------------------------------------------------------
1052  * Neo_initLDAP --
1053  *     Initialize the LDAP interface.
1054  *-----------------------------------------------------------------------------
1055  */
1056 int
1057 Ldaptcl_Init (interp)
1058 Tcl_Interp   *interp;
1059 {
1060     Tcl_CreateObjCommand (interp,
1061                           "ldap",
1062                           NeoX_LdapObjCmd,
1063                           (ClientData) NULL,
1064                           (Tcl_CmdDeleteProc*) NULL);
1065     Tcl_PkgProvide(interp, "Ldaptcl", "1.1");
1066     return TCL_OK;
1067 }