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