1/* 2 * tclXlib.c -- 3 * 4 * Tcl commands to load libraries of Tcl code. 5 *----------------------------------------------------------------------------- 6 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. 7 * 8 * Permission to use, copy, modify, and distribute this software and its 9 * documentation for any purpose and without fee is hereby granted, provided 10 * that the above copyright notice appear in all copies. Karl Lehenbauer and 11 * Mark Diekhans make no representations about the suitability of this 12 * software for any purpose. It is provided "as is" without express or 13 * implied warranty. 14 *----------------------------------------------------------------------------- 15 * $Id: tclXlib.c,v 1.5 2008/12/15 20:00:27 andreas_kupries Exp $ 16 *----------------------------------------------------------------------------- 17 */ 18 19/*----------------------------------------------------------------------------- 20 * The Extended Tcl library code is integrated with Tcl's by providing a 21 * modified version of the Tcl auto_load proc that calls tclx_load_tndxs. 22 * 23 * The following data structures are kept as Tcl variables so they can be 24 * accessed from Tcl: 25 * 26 * o auto_index - An array indexed by command name and contains code to 27 * execute to make the command available. Normally contains either: 28 * "source file" 29 * "auto_pkg_load package" 30 * o auto_pkg_index - Indexed by package name. 31 *----------------------------------------------------------------------------- 32 */ 33#include "tclExtdInt.h" 34 35/* 36 * Names of Tcl variables that are used. 37 */ 38static char *AUTO_INDEX = "auto_index"; 39static char *AUTO_PKG_INDEX = "auto_pkg_index"; 40 41/* 42 * Command to pass to Tcl_GlobalEval to load the file autoload.tcl. 43 * This is a global rather than a local so it will work with K&R compilers. 44 * Its writable so it works with gcc. 45 */ 46#ifdef HAVE_TCL_STANDALONE 47static char autoloadCmd [] = 48"if [catch {source -rsrc autoload}] {\n\ 49 source [file join $tclx_library autoload.tcl]\n\ 50}"; 51#else 52static char autoloadCmd [] = 53 "source [file join $tclx_library autoload.tcl]"; 54#endif 55 56/* 57 * Indicates the type of library index. 58 */ 59typedef enum { 60 TCLLIB_TNDX, /* *.tndx */ 61 TCLLIB_TND /* *.tnd (.tndx in 8.3 land) */ 62} indexNameClass_t; 63 64/* 65 * Prototypes of internal functions. 66 */ 67static int 68EvalFilePart _ANSI_ARGS_((Tcl_Interp *interp, 69 char *fileName, 70 off_t offset, 71 off_t length)); 72 73static char * 74MakeAbsFile _ANSI_ARGS_((Tcl_Interp *interp, 75 char *fileName, 76 Tcl_DString *absNamePtr)); 77 78static int 79SetPackageIndexEntry _ANSI_ARGS_((Tcl_Interp *interp, 80 CONST84 char *packageName, 81 CONST84 char *fileName, 82 off_t offset, 83 unsigned length)); 84 85static int 86GetPackageIndexEntry _ANSI_ARGS_((Tcl_Interp *interp, 87 char *packageName, 88 char **fileNamePtr, 89 off_t *offsetPtr, 90 unsigned *lengthPtr)); 91 92static int 93SetProcIndexEntry _ANSI_ARGS_((Tcl_Interp *interp, 94 CONST84 char *procName, 95 CONST84 char *package)); 96 97static void 98AddLibIndexErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, 99 char *indexName)); 100 101static int 102ProcessIndexFile _ANSI_ARGS_((Tcl_Interp *interp, 103 char *tlibFilePath, 104 char *tndxFilePath)); 105 106static int 107BuildPackageIndex _ANSI_ARGS_((Tcl_Interp *interp, 108 char *tlibFilePath)); 109 110static int 111LoadPackageIndex _ANSI_ARGS_((Tcl_Interp *interp, 112 char *tlibFilePath, 113 indexNameClass_t indexNameClass)); 114 115static int 116LoadDirIndexCallback _ANSI_ARGS_((Tcl_Interp *interp, 117 char *dirPath, 118 char *fileName, 119 int caseSensitive, 120 ClientData clientData)); 121 122static int 123LoadDirIndexes _ANSI_ARGS_((Tcl_Interp *interp, 124 char *dirName)); 125 126static int 127TclX_load_tndxsObjCmd _ANSI_ARGS_((ClientData clientData, 128 Tcl_Interp *interp, 129 int objc, 130 Tcl_Obj *CONST objv[])); 131 132static int 133TclX_Auto_load_pkgObjCmd _ANSI_ARGS_((ClientData clientData, 134 Tcl_Interp *interp, 135 int objc, 136 Tcl_Obj *CONST objv[])); 137 138static int 139TclX_LoadlibindexObjCmd _ANSI_ARGS_((ClientData clientData, 140 Tcl_Interp *interp, 141 int objc, 142 Tcl_Obj *CONST objv[])); 143 144 145/*----------------------------------------------------------------------------- 146 * EvalFilePart -- 147 * 148 * Read in a byte range of a file and evaulate it. 149 * 150 * Parameters: 151 * o interp - A pointer to the interpreter, error returned in result. 152 * o fileName - The file to evaulate. 153 * o offset - Byte offset into the file of the area to evaluate 154 * o length - Number of bytes to evaulate. 155 *----------------------------------------------------------------------------- 156 */ 157static int 158EvalFilePart (interp, fileName, offset, length) 159 Tcl_Interp *interp; 160 char *fileName; 161 off_t offset; 162 off_t length; 163{ 164 Interp *iPtr = (Interp *) interp; 165 int result, major, minor; 166 off_t fileSize; 167 Tcl_DString pathBuf, cmdBuf; 168 char *buf; 169 Tcl_Channel channel = NULL; 170 171 Tcl_ResetResult (interp); 172 Tcl_DStringInit (&pathBuf); 173 Tcl_DStringInit (&cmdBuf); 174 175 fileName = Tcl_TranslateFileName (interp, fileName, &pathBuf); 176 if (fileName == NULL) 177 goto errorExit; 178 179 channel = Tcl_OpenFileChannel (interp, fileName, "r", 0); 180 if (channel == NULL) 181 goto errorExit; 182 183 if (TclXOSGetFileSize (channel, &fileSize) == TCL_ERROR) 184 goto posixError; 185 186 if ((fileSize < offset + length) || (offset < 0)) { 187 TclX_AppendObjResult (interp, 188 "range to eval outside of file bounds in \"", 189 fileName, "\", index file probably corrupt", 190 (char *) NULL); 191 goto errorExit; 192 } 193 194 if (Tcl_Seek (channel, offset, SEEK_SET) < 0) 195 goto posixError; 196 197 Tcl_DStringSetLength (&cmdBuf, length + 1); 198 if (Tcl_Read (channel, cmdBuf.string, length) != length) { 199 if (Tcl_Eof (channel)) 200 goto prematureEof; 201 else 202 goto posixError; 203 } 204 cmdBuf.string [length] = '\0'; 205 206 if (Tcl_Close (NULL, channel) != 0) 207 goto posixError; 208 channel = NULL; 209 210 /* 211 * The internal scriptFile element changed from char* to Tcl_Obj* in 8.4. 212 */ 213 Tcl_GetVersion(&major, &minor, NULL, NULL); 214 if ((major > 8) || (minor > 3)) { 215 Tcl_Obj *oldScriptFile = (Tcl_Obj *) iPtr->scriptFile; 216 Tcl_Obj *newobj = Tcl_NewStringObj(fileName, -1); 217 Tcl_IncrRefCount(newobj); 218 iPtr->scriptFile = (void *) newobj; 219 result = Tcl_GlobalEval (interp, cmdBuf.string); 220 iPtr->scriptFile = (void *) oldScriptFile; 221 Tcl_DecrRefCount(newobj); 222 } else { 223 char *oldScriptFile = (char *) iPtr->scriptFile; 224 iPtr->scriptFile = (void *) fileName; 225 result = Tcl_GlobalEval (interp, cmdBuf.string); 226 iPtr->scriptFile = (void *) oldScriptFile; 227 } 228 229 Tcl_DStringFree (&pathBuf); 230 Tcl_DStringFree (&cmdBuf); 231 232 if (result != TCL_ERROR) { 233 return TCL_OK; 234 } 235 236 /* 237 * An error occured in the command, record information telling where it 238 * came from. 239 */ 240 buf = ckalloc (strlen (fileName) + 64); 241 sprintf (buf, "\n (file \"%s\" line %d)", fileName, 242 ERRORLINE(interp)); 243 Tcl_AddErrorInfo (interp, buf); 244 ckfree (buf); 245 goto errorExit; 246 247 /* 248 * Errors accessing the file once its opened are handled here. 249 */ 250 posixError: 251 TclX_AppendObjResult (interp, "error accessing: ", fileName, ": ", 252 Tcl_PosixError (interp), (char *) NULL); 253 goto errorExit; 254 255 prematureEof: 256 TclX_AppendObjResult (interp, "premature EOF on: ", fileName, 257 (char *) NULL); 258 goto errorExit; 259 260 errorExit: 261 if (channel != NULL) 262 Tcl_Close (NULL, channel); 263 Tcl_DStringFree (&pathBuf); 264 Tcl_DStringFree (&cmdBuf); 265 return TCL_ERROR; 266} 267 268/*----------------------------------------------------------------------------- 269 * MakeAbsFile -- 270 * 271 * Convert a file name to an absolute path. This handles file name translation 272 * and preappend the current directory name if the path is relative. 273 * 274 * Parameters 275 * o interp - A pointer to the interpreter, error returned in result. 276 * o fileName - File name (should not start with a "/"). 277 * o absNamePtr - The name is returned in this dynamic string. It 278 * should be initialized. 279 * Returns: 280 * A pointer to the file name in the dynamic string or NULL if an error 281 * occured. 282 *----------------------------------------------------------------------------- 283 */ 284static char * 285MakeAbsFile (interp, fileName, absNamePtr) 286 Tcl_Interp *interp; 287 char *fileName; 288 Tcl_DString *absNamePtr; 289{ 290 char *curDir; 291 Tcl_DString joinBuf, cwdBuffer; 292 293 Tcl_DStringSetLength (absNamePtr, 1); 294 Tcl_DStringInit (&cwdBuffer); 295 296 fileName = Tcl_TranslateFileName (interp, fileName, absNamePtr); 297 if (fileName == NULL) 298 goto errorExit; 299 300 /* 301 * If its already absolute. If name translation didn't actually 302 * copy the name to the buffer, we must do it now. 303 */ 304 if (Tcl_GetPathType (fileName) == TCL_PATH_ABSOLUTE) { 305 if (fileName != absNamePtr->string) { 306 Tcl_DStringAppend (absNamePtr, fileName, -1); 307 } 308 return Tcl_DStringValue (absNamePtr); 309 } 310 311 /* 312 * Otherwise its relative to the current directory, get the directory 313 * and join into a path. 314 */ 315 curDir = Tcl_GetCwd (interp, &cwdBuffer); 316 if (curDir == NULL) 317 goto errorExit; 318 319 Tcl_DStringInit (&joinBuf); 320 TclX_JoinPath (curDir, fileName, &joinBuf); 321 Tcl_DStringSetLength (absNamePtr, 0); 322 Tcl_DStringAppend (absNamePtr, joinBuf.string, -1); 323 Tcl_DStringFree (&joinBuf); 324 325 Tcl_DStringFree (&cwdBuffer); 326 return Tcl_DStringValue (absNamePtr); 327 328 errorExit: 329 Tcl_DStringFree (&cwdBuffer); 330 return NULL; 331} 332 333/*----------------------------------------------------------------------------- 334 * SetPackageIndexEntry -- 335 * 336 * Set a package entry in the auto_pkg_index array in the form: 337 * 338 * auto_pkg_index($packageName) [list $filename $offset $length] 339 * 340 * Duplicate package entries are overwritten. 341 * 342 * Parameters 343 * o interp - A pointer to the interpreter, error returned in result. 344 * o packageName - Package name. 345 * o fileName - Absolute file name of the file containing the package. 346 * o offset - String containing the numeric start of the package. 347 * o length - String containing the numeric length of the package. 348 * Returns: 349 * TCL_OK or TCL_ERROR. 350 *----------------------------------------------------------------------------- 351 */ 352static int 353SetPackageIndexEntry (interp, packageName, fileName, offset, length) 354 Tcl_Interp *interp; 355 CONST84 char *packageName; 356 CONST84 char *fileName; 357 off_t offset; 358 unsigned length; 359{ 360 Tcl_Obj *pkgDataObjv [3], *pkgDataPtr; 361 362 /* 363 * Build up the list of values to save. 364 */ 365 pkgDataObjv [0] = Tcl_NewStringObj (fileName, -1); 366 pkgDataObjv [1] = Tcl_NewIntObj ((int) offset); 367 pkgDataObjv [2] = Tcl_NewIntObj ((int) length); 368 pkgDataPtr = Tcl_NewListObj (3, pkgDataObjv); 369 370 if (Tcl_SetVar2Ex(interp, AUTO_PKG_INDEX, packageName, pkgDataPtr, 371 TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { 372 Tcl_DecrRefCount (pkgDataPtr); 373 return TCL_ERROR; 374 } 375 376 return TCL_OK; 377} 378 379/*----------------------------------------------------------------------------- 380 * GetPackageIndexEntry -- 381 * 382 * Get a package entry from the auto_pkg_index array. 383 * 384 * Parameters 385 * o interp - A pointer to the interpreter, error returned in result. 386 * o packageName - Package name to find. 387 * o fileNamePtr - The file name for the library file is returned here. 388 * This should be freed by the caller. 389 * o offsetPtr - Start of the package in the library. 390 * o lengthPtr - Length of the package in the library. 391 * Returns: 392 * TCL_OK or TCL_ERROR. 393 *----------------------------------------------------------------------------- 394 */ 395static int 396GetPackageIndexEntry (interp, packageName, fileNamePtr, offsetPtr, lengthPtr) 397 Tcl_Interp *interp; 398 char *packageName; 399 char **fileNamePtr; 400 off_t *offsetPtr; 401 unsigned *lengthPtr; 402{ 403 int pkgDataObjc; 404 Tcl_Obj **pkgDataObjv, *pkgDataPtr; 405 406 /* 407 * Look up the package entry in the array. 408 */ 409 pkgDataPtr = Tcl_GetVar2Ex(interp, AUTO_PKG_INDEX, packageName, 410 TCL_GLOBAL_ONLY); 411 if (pkgDataPtr == NULL) { 412 TclX_AppendObjResult (interp, "entry not found in \"auto_pkg_index\"", 413 " for package \"", packageName, "\"", 414 (char *) NULL); 415 goto errorExit; 416 } 417 418 /* 419 * Extract the data from the array entry. 420 */ 421 if (Tcl_ListObjGetElements (interp, pkgDataPtr, 422 &pkgDataObjc, &pkgDataObjv) != TCL_OK) 423 goto invalidEntry; 424 if (pkgDataObjc != 3) 425 goto invalidEntry; 426 427 if (TclX_GetOffsetFromObj (interp, pkgDataObjv [1], offsetPtr) != TCL_OK) 428 goto invalidEntry; 429 if (TclX_GetUnsignedFromObj (interp, pkgDataObjv [2], lengthPtr) != TCL_OK) 430 goto invalidEntry; 431 432 *fileNamePtr = Tcl_GetStringFromObj (pkgDataObjv [0], NULL); 433 *fileNamePtr = ckstrdup (*fileNamePtr); 434 435 return TCL_OK; 436 437 /* 438 * Exit point when an invalid entry is found. 439 */ 440 invalidEntry: 441 Tcl_ResetResult (interp); 442 TclX_AppendObjResult (interp, "invalid entry in \"auto_pkg_index\"", 443 " for package \"", packageName, "\"", 444 (char *) NULL); 445 errorExit: 446 return TCL_ERROR; 447} 448 449/*----------------------------------------------------------------------------- 450 * SetProcIndexEntry -- 451 * 452 * Set the proc entry in the auto_index array. These entry contains a command 453 * to make the proc available from a package. 454 * 455 * Parameters 456 * o interp - A pointer to the interpreter, error returned in result. 457 * o procName - The Tcl proc name. 458 * o package - Pacakge containing the proc. 459 * Returns: 460 * TCL_OK or TCL_ERROR. 461 *----------------------------------------------------------------------------- 462 */ 463static int 464SetProcIndexEntry (interp, procName, package) 465 Tcl_Interp *interp; 466 CONST84 char *procName; 467 CONST84 char *package; 468{ 469 Tcl_DString command; 470 CONST84 char *result; 471 472 Tcl_DStringInit (&command); 473 Tcl_DStringAppendElement (&command, "auto_load_pkg"); 474 Tcl_DStringAppendElement (&command, package); 475 476 result = Tcl_SetVar2 (interp, AUTO_INDEX, procName, command.string, 477 TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG); 478 479 Tcl_DStringFree (&command); 480 481 return (result == NULL) ? TCL_ERROR : TCL_OK; 482} 483 484/*----------------------------------------------------------------------------- 485 * AddLibIndexErrorInfo -- 486 * 487 * Add information to the error info stack about index that just failed. 488 * This is generic for both tclIndex and .tlib indexs 489 * 490 * Parameters 491 * o interp - A pointer to the interpreter, error returned in result. 492 * o indexName - The name of the index. 493 *----------------------------------------------------------------------------- 494 */ 495static void 496AddLibIndexErrorInfo (interp, indexName) 497 Tcl_Interp *interp; 498 char *indexName; 499{ 500 char *msg; 501 502 msg = ckalloc (strlen (indexName) + 60); 503 strcpy (msg, "\n while loading Tcl library index \""); 504 strcat (msg, indexName); 505 strcat (msg, "\""); 506 Tcl_AddObjErrorInfo (interp, msg, -1); 507 ckfree (msg); 508} 509 510 511/*----------------------------------------------------------------------------- 512 * ProcessIndexFile -- 513 * 514 * Open and process a package library index file (.tndx). Creates entries 515 * in the auto_index and auto_pkg_index arrays. Existing entries are over 516 * written. 517 * 518 * Parameters 519 * o interp - A pointer to the interpreter, error returned in result. 520 * o tlibFilePath - Absolute path name to the library file. 521 * o tndxFilePath - Absolute path name to the library file index. 522 * Returns: 523 * TCL_OK or TCL_ERROR. 524 *----------------------------------------------------------------------------- 525 */ 526static int 527ProcessIndexFile (interp, tlibFilePath, tndxFilePath) 528 Tcl_Interp *interp; 529 char *tlibFilePath; 530 char *tndxFilePath; 531{ 532 Tcl_Channel indexChannel = NULL; 533 Tcl_DString lineBuffer; 534 int lineArgc, idx, result, tmpNum; 535 CONST84 char **lineArgv = NULL; 536 off_t offset; 537 unsigned length; 538 539 Tcl_DStringInit (&lineBuffer); 540 541 indexChannel = Tcl_OpenFileChannel (interp, tndxFilePath, "r", 0); 542 if (indexChannel == NULL) 543 return TCL_ERROR; 544 545 while (TRUE) { 546 Tcl_DStringSetLength (&lineBuffer, 0); 547 if (Tcl_Gets (indexChannel, &lineBuffer) < 0) { 548 if (Tcl_Eof (indexChannel)) 549 goto reachedEOF; 550 else 551 goto fileError; 552 } 553 554 if ((Tcl_SplitList (interp, lineBuffer.string, &lineArgc, 555 &lineArgv) != TCL_OK) || (lineArgc < 4)) 556 goto formatError; 557 558 /* 559 * lineArgv [0] is the package name. 560 * lineArgv [1] is the package offset in the library. 561 * lineArgv [2] is the package length in the library. 562 * lineArgv [3-n] are the entry procedures for the package. 563 */ 564 if (Tcl_GetInt (interp, lineArgv [1], &tmpNum) != TCL_OK) 565 goto errorExit; 566 if (tmpNum < 0) 567 goto formatError; 568 offset = (off_t) tmpNum; 569 570 if (Tcl_GetInt (interp, lineArgv [2], &tmpNum) != TCL_OK) 571 goto errorExit; 572 if (tmpNum < 0) 573 goto formatError; 574 length = (unsigned) tmpNum; 575 576 result = SetPackageIndexEntry (interp, lineArgv [0], tlibFilePath, 577 offset, length); 578 if (result == TCL_ERROR) 579 goto errorExit; 580 581 /* 582 * If the package is not duplicated, add the commands to load 583 * the procedures. 584 */ 585 if (result != TCL_CONTINUE) { 586 for (idx = 3; idx < lineArgc; idx++) { 587 if (SetProcIndexEntry (interp, lineArgv [idx], 588 lineArgv [0]) != TCL_OK) 589 goto errorExit; 590 } 591 } 592 ckfree ((char *) lineArgv); 593 lineArgv = NULL; 594 } 595 596 reachedEOF: 597 Tcl_DStringFree (&lineBuffer); 598 if (Tcl_Close (NULL, indexChannel) != TCL_OK) 599 goto fileError; 600 601 return TCL_OK; 602 603 /* 604 * Handle format error in library input line. 605 */ 606 formatError: 607 Tcl_ResetResult (interp); 608 TclX_AppendObjResult (interp, "format error in library index \"", 609 tndxFilePath, "\" (", lineBuffer.string, ")", 610 (char *) NULL); 611 goto errorExit; 612 613 fileError: 614 TclX_AppendObjResult (interp, "error accessing package index file \"", 615 tndxFilePath, "\": ", Tcl_PosixError (interp), 616 (char *) NULL); 617 goto errorExit; 618 619 /* 620 * Error exit here, releasing resources and closing the file. 621 */ 622 errorExit: 623 if (lineArgv != NULL) 624 ckfree ((char *) lineArgv); 625 Tcl_DStringFree (&lineBuffer); 626 if (indexChannel != NULL) 627 Tcl_Close (NULL, indexChannel); 628 return TCL_ERROR; 629} 630 631/*----------------------------------------------------------------------------- 632 * BuildPackageIndex -- 633 * 634 * Call the "buildpackageindex" Tcl procedure to rebuild a package index. 635 * This is found in the directory pointed to by the $tclx_library variable. 636 * 637 * Parameters 638 * o interp - A pointer to the interpreter, error returned in result. 639 * o tlibFilePath - Absolute path name to the library file. 640 * Returns: 641 * TCL_OK or TCL_ERROR. 642 *----------------------------------------------------------------------------- 643 */ 644static int 645BuildPackageIndex (interp, tlibFilePath) 646 Tcl_Interp *interp; 647 char *tlibFilePath; 648{ 649 Tcl_DString command; 650 int result; 651 652 Tcl_DStringInit (&command); 653 654 Tcl_DStringAppend (&command, 655 "if [catch {source -rsrc buildidx}] {source [file join $tclx_library buildidx.tcl]};", -1); 656 Tcl_DStringAppend (&command, "buildpackageindex ", -1); 657 Tcl_DStringAppend (&command, tlibFilePath, -1); 658 659 result = Tcl_GlobalEval (interp, command.string); 660 661 Tcl_DStringFree (&command); 662 663 if (result == TCL_ERROR) 664 return TCL_ERROR; 665 Tcl_ResetResult (interp); 666 return result; 667} 668 669/*----------------------------------------------------------------------------- 670 * LoadPackageIndex -- 671 * 672 * Load a package .tndx file. Rebuild .tndx if non-existant or out of 673 * date. 674 * 675 * Parameters 676 * o interp - A pointer to the interpreter, error returned in result. 677 * o tlibFilePath - Absolute path name to the library file. 678 * o indexNameClass - TCLLIB_TNDX if the index file should the suffix 679 * ".tndx" or TCLLIB_TND if it should have ".tnd". 680 * Returns: 681 * TCL_OK or TCL_ERROR. 682 *----------------------------------------------------------------------------- 683 */ 684static int 685LoadPackageIndex (interp, tlibFilePath, indexNameClass) 686 Tcl_Interp *interp; 687 char *tlibFilePath; 688 indexNameClass_t indexNameClass; 689{ 690 Tcl_DString tndxFilePath; 691 692 struct stat tlibStat; 693 struct stat tndxStat; 694 695 Tcl_DStringInit (&tndxFilePath); 696 697 /* 698 * Modify library file path to be the index file path. 699 */ 700 Tcl_DStringAppend (&tndxFilePath, tlibFilePath, -1); 701 tndxFilePath.string [tndxFilePath.length - 3] = 'n'; 702 tndxFilePath.string [tndxFilePath.length - 2] = 'd'; 703 if (indexNameClass == TCLLIB_TNDX) 704 tndxFilePath.string [tndxFilePath.length - 1] = 'x'; 705 706 /* 707 * Get library's modification time. If the file can't be accessed, set 708 * time so the library does not get built. Other code will report the 709 * error. 710 */ 711 if (stat (tlibFilePath, &tlibStat) < 0) 712 tlibStat.st_mtime = MAXINT; 713 714 /* 715 * Get the time for the index. If the file does not exists or is 716 * out of date, rebuild it. 717 */ 718 if ((stat (tndxFilePath.string, &tndxStat) < 0) || 719 (tndxStat.st_mtime < tlibStat.st_mtime)) { 720 if (BuildPackageIndex (interp, tlibFilePath) != TCL_OK) 721 goto errorExit; 722 } 723 724 if (ProcessIndexFile (interp, tlibFilePath, tndxFilePath.string) != TCL_OK) 725 goto errorExit; 726 Tcl_DStringFree (&tndxFilePath); 727 return TCL_OK; 728 729 errorExit: 730 AddLibIndexErrorInfo (interp, tndxFilePath.string); 731 Tcl_DStringFree (&tndxFilePath); 732 733 return TCL_ERROR; 734} 735 736/*----------------------------------------------------------------------------- 737 * LoadDirIndexCallback -- 738 * 739 * Function called for every directory entry for LoadDirIndexes. 740 * 741 * Parameters 742 * o interp - Interp is passed though. 743 * o dirPath - Normalized path to directory. 744 * o fileName - Tcl normalized file name in directory. 745 * o caseSensitive - Are the file names case sensitive? Always 746 * TRUE on Unix. 747 * o clientData - Pointer to a boolean that is set to TRUE if an error 748 * occures while porocessing the index file. 749 * Returns: 750 * TCL_OK or TCL_ERROR. 751 *----------------------------------------------------------------------------- 752 */ 753static int 754LoadDirIndexCallback (interp, dirPath, fileName, caseSensitive, clientData) 755 Tcl_Interp *interp; 756 char *dirPath; 757 char *fileName; 758 int caseSensitive; 759 ClientData clientData; 760{ 761 int *indexErrorPtr = (int *) clientData; 762 int nameLen; 763 char *chkName; 764 indexNameClass_t indexNameClass; 765 Tcl_DString chkNameBuf, filePath; 766 767 /* 768 * If the volume not case sensitive, convert the name to lower case. 769 */ 770 Tcl_DStringInit (&chkNameBuf); 771 chkName = fileName; 772 if (!caseSensitive) { 773 chkName = Tcl_DStringAppend (&chkNameBuf, fileName, -1); 774 TclX_DownShift (chkName, chkName); 775 } 776 777 /* 778 * Figure out if its an index file. 779 */ 780 nameLen = strlen (chkName); 781 if ((nameLen > 5) && STREQU (chkName + nameLen - 5, ".tlib")) { 782 indexNameClass = TCLLIB_TNDX; 783 } else if ((nameLen > 4) && STREQU (chkName + nameLen - 4, ".tli")) { 784 indexNameClass = TCLLIB_TND; 785 } else { 786 Tcl_DStringFree (&chkNameBuf); 787 return TCL_OK; /* Not an index, skip */ 788 } 789 Tcl_DStringFree (&chkNameBuf); 790 791 /* 792 * Assemble full path to library file. 793 */ 794 Tcl_DStringInit (&filePath); 795 TclX_JoinPath (dirPath, fileName, &filePath); 796 797 /* 798 * Skip index it can't be accessed. 799 */ 800 if (access (filePath.string, R_OK) < 0) 801 goto exitPoint; 802 803 /* 804 * Process the index according to its type. 805 */ 806 if (LoadPackageIndex (interp, filePath.string, 807 indexNameClass) != TCL_OK) 808 goto errorExit; 809 810 exitPoint: 811 Tcl_DStringFree (&filePath); 812 return TCL_OK; 813 814 errorExit: 815 Tcl_DStringFree (&filePath); 816 *indexErrorPtr = TRUE; 817 return TCL_ERROR; 818} 819 820/*----------------------------------------------------------------------------- 821 * LoadDirIndexes -- 822 * 823 * Load the indexes for all package library (.tlib) or a Ousterhout 824 * "tclIndex" file in a directory. Nonexistent or unreadable directories 825 * are skipped. 826 * 827 * Parameters 828 * o interp - A pointer to the interpreter, error returned in result. 829 * o dirName - The absolute path name of the directory to search for 830 * libraries. 831 *----------------------------------------------------------------------------- 832 */ 833static int 834LoadDirIndexes (interp, dirName) 835 Tcl_Interp *interp; 836 char *dirName; 837{ 838 int indexError = FALSE; 839 840 /* 841 * This is a little tricky. We want to skip directories we can't read, 842 * read, but if we get an error processing an index, we want 843 * to report it. A boolean is passed in to indicate if the error 844 * returned involved parsing the file. 845 */ 846 if (TclXOSWalkDir (interp, dirName, FALSE, /* hidden */ 847 LoadDirIndexCallback, 848 (ClientData) &indexError) == TCL_ERROR) { 849 if (!indexError) { 850 Tcl_ResetResult (interp); 851 return TCL_OK; 852 } 853 return TCL_ERROR; 854 } 855 return TCL_OK; 856} 857 858/*----------------------------------------------------------------------------- 859 * TclX_load_tndxsObjCmd -- 860 * 861 * Implements the command: 862 * tclx_load_tndxs dir 863 * 864 * Which is called from auto_load to load a .tndx files in a directory. 865 *----------------------------------------------------------------------------- 866 */ 867static int 868TclX_load_tndxsObjCmd (clientData, interp, objc, objv) 869 ClientData clientData; 870 Tcl_Interp *interp; 871 int objc; 872 Tcl_Obj *CONST objv[]; 873{ 874 char *dirname; 875 876 if (objc != 2) { 877 return TclX_WrongArgs (interp, objv [0], "dir"); 878 } 879 dirname = Tcl_GetStringFromObj (objv[1], NULL); 880 return LoadDirIndexes (interp, dirname); 881} 882 883/*----------------------------------------------------------------------------- 884 * TclX_Auto_load_pkgObjCmd -- 885 * 886 * Implements the command: 887 * auto_load_pkg package 888 * 889 * Which is called to load a .tlib package who's index has already been loaded. 890 *----------------------------------------------------------------------------- 891 */ 892static int 893TclX_Auto_load_pkgObjCmd (clientData, interp, objc, objv) 894 ClientData clientData; 895 Tcl_Interp *interp; 896 int objc; 897 Tcl_Obj *CONST objv[]; 898{ 899 char *fileName; 900 off_t offset; 901 unsigned length; 902 int result; 903 904 if (objc != 2) { 905 return TclX_WrongArgs (interp, objv [0], "package"); 906 } 907 908 if (GetPackageIndexEntry (interp, Tcl_GetStringFromObj (objv [1], NULL), 909 &fileName, &offset, &length) != TCL_OK) 910 return TCL_ERROR; 911 912 result = EvalFilePart (interp, fileName, offset, length); 913 ckfree (fileName); 914 915 return result; 916} 917 918/*----------------------------------------------------------------------------- 919 * TclX_LoadlibindexObjCmd -- 920 * 921 * This procedure is invoked to process the "Loadlibindex" Tcl command: 922 * 923 * loadlibindex libfile 924 * 925 * which loads the index for a package library (.tlib) or a Ousterhout 926 * "tclIndex" file. New package definitions will override existing ones. 927 *----------------------------------------------------------------------------- 928 */ 929static int 930TclX_LoadlibindexObjCmd (clientData, interp, objc, objv) 931 ClientData clientData; 932 Tcl_Interp *interp; 933 int objc; 934 Tcl_Obj *CONST objv[]; 935{ 936 char *pathName; 937 Tcl_DString pathNameBuf; 938 int pathLen; 939 940 Tcl_DStringInit (&pathNameBuf); 941 942 if (objc != 2) { 943 return TclX_WrongArgs (interp, objv [0], "libFile"); 944 } 945 946 pathName = MakeAbsFile (interp, 947 Tcl_GetStringFromObj (objv [1], NULL), 948 &pathNameBuf); 949 if (pathName == NULL) 950 return TCL_ERROR; 951 952 /* 953 * Find the length of the directory name. Validate that we have a .tlib 954 * extension or file name is "tclIndex" and call the routine to process 955 * the specific type of index. 956 */ 957 pathLen = strlen (pathName); 958 959 if ((pathLen > 5) && STREQU (pathName + pathLen - 5, ".tlib")) { 960 if (LoadPackageIndex (interp, pathName, TCLLIB_TNDX) != TCL_OK) 961 goto errorExit; 962 } else if ((pathLen > 4) && STREQU (pathName + pathLen - 4, ".tli")) { 963 if (LoadPackageIndex (interp, pathName, TCLLIB_TND) != TCL_OK) 964 goto errorExit; 965 } else { 966 TclX_AppendObjResult (interp, "invalid library name, must have ", 967 "an extension of \".tlib\", or \".tli\", got \"", 968 Tcl_GetStringFromObj (objv [1], NULL), "\"", 969 (char *) NULL); 970 goto errorExit; 971 } 972 973 Tcl_DStringFree (&pathNameBuf); 974 return TCL_OK; 975 976 errorExit: 977 Tcl_DStringFree (&pathNameBuf); 978 return TCL_ERROR;; 979} 980 981/*----------------------------------------------------------------------------- 982 * TclX_LibraryInit -- 983 * 984 * Initialize the Extended Tcl library facility commands. 985 *----------------------------------------------------------------------------- 986 */ 987int 988TclX_LibraryInit (interp) 989 Tcl_Interp *interp; 990{ 991 int result; 992 993 /* Hack in our own auto-loading */ 994 result = Tcl_EvalEx(interp, autoloadCmd, -1, TCL_EVAL_GLOBAL); 995 if (result == TCL_ERROR) { 996 return TCL_ERROR; 997 } 998 999 Tcl_CreateObjCommand (interp, "tclx_load_tndxs", 1000 TclX_load_tndxsObjCmd, 1001 (ClientData) NULL, 1002 (Tcl_CmdDeleteProc*) NULL); 1003 Tcl_CreateObjCommand (interp, "auto_load_pkg", 1004 TclX_Auto_load_pkgObjCmd, 1005 (ClientData) NULL, 1006 (Tcl_CmdDeleteProc*) NULL); 1007 Tcl_CreateObjCommand (interp, "loadlibindex", 1008 TclX_LoadlibindexObjCmd, 1009 (ClientData) NULL, 1010 (Tcl_CmdDeleteProc*) NULL); 1011 1012 Tcl_ResetResult (interp); 1013 return TCL_OK; 1014} 1015