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