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