home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tclX6.5c / src / tclXlib.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-12-19  |  46.2 KB  |  1,538 lines
  1. /*
  2.  * tclXlib.c --
  3.  *
  4.  * Tcl commands to load libraries of Tcl code.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1992 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 2.1 1992/11/19 06:01:41 markd Exp $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. /*-----------------------------------------------------------------------------
  20.  *
  21.  * The following data structures are used by the Tcl library code. All
  22.  * structures are kept in the global array TCLENV, so that Tcl procs may be
  23.  * written to access them.
  24.  *
  25.  *  o fileId - This is a small string used to uniquely identify a file, it is
  26.  *    in the form "@$dev:$inode", where dev and inode are the values obtained
  27.  *    from stat.
  28.  *
  29.  *  o TCLENV(fileId} filePath - This entry translates a file id to an
  30.  *    file name, which may be an absolute path to a file or the name of 
  31.  *    a file to find by searching a path.
  32.  *
  33.  *  o TCLENV(PKG:$packageName) {$fileId $offset $length} - This entry
  34.  *    translates a package name into a fileId of the file containing the
  35.  *    package and the byte and offset length of the package within the file.
  36.  *    
  37.  *  o TCLENV(PROC:$proc) {P $packageName} - This form of a procedure entry
  38.  *    translates a procedure into a package name.
  39.  *
  40.  *  o TCLENV(PROC:$proc) {F $fileName} 0 - This form of a procedure entry
  41.  *    translates a procedure into a file name.  The file name may be an
  42.  *    absolute path to the file or a file to be found by searching TCLPATH
  43.  *    or auto_path.
  44.  *-----------------------------------------------------------------------------
  45.  */
  46. #include "tclExtdInt.h"
  47.  
  48. typedef char fileId_t [64];
  49.  
  50. /*
  51.  * Prototypes of internal functions.
  52.  */
  53. static int
  54. GlobalEvalFile _ANSI_ARGS_((Tcl_Interp *interp,
  55.                             char       *file));
  56.  
  57. static int
  58. EvalFilePart _ANSI_ARGS_((Tcl_Interp  *interp,
  59.                           char        *fileName,
  60.                           long         offset,
  61.                           unsigned     length));
  62.  
  63. static char *
  64. MakeAbsFile _ANSI_ARGS_((Tcl_Interp  *interp,
  65.                          char        *fileName,
  66.                          char        *buffer,
  67.                          int          bufferSize));
  68.  
  69. static int
  70. GenerateFileId _ANSI_ARGS_((Tcl_Interp *interp,
  71.                             char       *filePath,
  72.                             fileId_t    fileId));
  73.  
  74. static int
  75. SetTCLENVFileIdEntry _ANSI_ARGS_((Tcl_Interp *interp,
  76.                                   fileId_t    fileId,
  77.                                   char       *filePath));
  78.  
  79. static int
  80. CheckTCLENVFileIdEntry _ANSI_ARGS_((Tcl_Interp *interp,
  81.                                     char       *filePath));
  82.      
  83. static char *
  84. GetTCLENVFileIdEntry  _ANSI_ARGS_((Tcl_Interp  *interp,
  85.                                    fileId_t     fileId));
  86.  
  87. static int
  88. SetTCLENVPkgEntry _ANSI_ARGS_((Tcl_Interp *interp,
  89.                                char       *packageName,
  90.                                fileId_t    fileId,
  91.                                char       *offset,
  92.                                char       *length));
  93.  
  94. static int
  95. GetTCLENVPkgEntry _ANSI_ARGS_((Tcl_Interp *interp,
  96.                                char       *packageName,
  97.                                char       *fileId,
  98.                                long       *offsetPtr,
  99.                                unsigned   *lengthPtr));
  100.  
  101. static int
  102. SetTCLENVProcEntry _ANSI_ARGS_((Tcl_Interp *interp,
  103.                                 char       *procName,
  104.                                 char       *type,
  105.                                 char       *location));
  106.  
  107. static int
  108. GetTCLENVProcEntry  _ANSI_ARGS_((Tcl_Interp *interp,
  109.                                  char       *procName,
  110.                                  char       *typePtr,
  111.                                  char      **locationPtr));
  112.  
  113. static int
  114. ProcessIndexFile _ANSI_ARGS_((Tcl_Interp *interp,
  115.                               char       *tlibFilePath,
  116.                               char       *tndxFilePath));
  117.  
  118. static int
  119. BuildPackageIndex  _ANSI_ARGS_((Tcl_Interp *interp,
  120.                                 char       *tlibFilePath));
  121.  
  122. static int
  123. LoadPackageIndex _ANSI_ARGS_((Tcl_Interp *interp,
  124.                               char       *tlibFilePath,
  125.                               int         pathLen,
  126.                               int         dirLen));
  127.  
  128. static int
  129. LoadOusterIndex _ANSI_ARGS_((Tcl_Interp *interp,
  130.                              char       *indexFilePath,
  131.                              int         dirLen));
  132.  
  133. static int
  134. LoadDirIndexes _ANSI_ARGS_((Tcl_Interp  *interp,
  135.                             char        *dirName));
  136.  
  137. static int
  138. LoadPackageIndexes _ANSI_ARGS_((Tcl_Interp  *interp,
  139.                                 char        *path));
  140.  
  141. static int
  142. LoadProc _ANSI_ARGS_((Tcl_Interp  *interp,
  143.                       char        *procName,
  144.                       int         *foundPtr));
  145.  
  146.  
  147. /*
  148.  *-----------------------------------------------------------------------------
  149.  *
  150.  * GlobalEvalFile --
  151.  *
  152.  *    Evaluate a file  at global level in an interpreter.
  153.  *
  154.  * Results:
  155.  *    A standard Tcl result is returned, and interp->result is
  156.  *    modified accordingly.
  157.  *-----------------------------------------------------------------------------
  158.  */
  159. static int
  160. GlobalEvalFile(interp, file)
  161.     Tcl_Interp *interp;
  162.     char       *file;
  163. {
  164.     register Interp *iPtr = (Interp *) interp;
  165.     int result;
  166.     CallFrame *savedVarFramePtr;
  167.  
  168.     savedVarFramePtr = iPtr->varFramePtr;
  169.     iPtr->varFramePtr = NULL;
  170.     result = Tcl_EvalFile (interp, file);
  171.     iPtr->varFramePtr = savedVarFramePtr;
  172.     return result;
  173. }
  174.  
  175. /*
  176.  *-----------------------------------------------------------------------------
  177.  *
  178.  * EvalFilePart --
  179.  *
  180.  *   Read in a byte range of a file and evaulate it.
  181.  *
  182.  * Parameters:
  183.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  184.  *   o fileName (I) - The file to evaulate.
  185.  *   o offset (I) - Byte offset into the file of the area to evaluate
  186.  *   o length (I) - Number of bytes to evaulate..
  187.  *
  188.  * Results:
  189.  *   A standard Tcl result.
  190.  *-----------------------------------------------------------------------------
  191.  */
  192. static int
  193. EvalFilePart (interp, fileName, offset, length)
  194.     Tcl_Interp  *interp;
  195.     char        *fileName;
  196.     long         offset;
  197.     unsigned     length;
  198. {
  199.     Interp       *iPtr = (Interp *) interp;
  200.     int           fileNum, result;
  201.     struct stat   statBuf;
  202.     char         *oldScriptFile, *cmdBuffer;
  203.  
  204.  
  205.     if (fileName [0] == '~')
  206.         if ((fileName = Tcl_TildeSubst (interp, fileName)) == NULL)
  207.             return TCL_ERROR;
  208.  
  209.     fileNum = open (fileName, O_RDONLY, 0);
  210.     if (fileNum < 0) {
  211.         Tcl_AppendResult (interp, "open failed on: ", fileName, ": ",
  212.                           Tcl_UnixError (interp), (char *) NULL);
  213.         return TCL_ERROR;
  214.     }
  215.     if (fstat (fileNum, &statBuf) == -1)
  216.         goto accessError;
  217.  
  218.     if ((statBuf.st_size < offset + length) || (offset < 0)) {
  219.         Tcl_AppendResult (interp, "range to eval outside of file bounds \"",
  220.                           fileName, "\"", (char *) NULL);
  221.         close (fileNum);
  222.         return TCL_ERROR;
  223.     }
  224.     if (lseek (fileNum, offset, 0) < 0)
  225.         goto accessError;
  226.  
  227.     cmdBuffer = ckalloc (length + 1);
  228.     if (read (fileNum, cmdBuffer, length) != length)
  229.         goto accessError;
  230.  
  231.     cmdBuffer [length] = '\0';
  232.  
  233.     if (close (fileNum) != 0)
  234.         goto accessError;
  235.  
  236.     oldScriptFile = iPtr->scriptFile;
  237.     iPtr->scriptFile = fileName;
  238.  
  239.     result = Tcl_GlobalEval (interp, cmdBuffer);
  240.  
  241.     iPtr->scriptFile = oldScriptFile;
  242.     ckfree (cmdBuffer);
  243.                          
  244.     if (result != TCL_ERROR)
  245.         return TCL_OK;
  246.  
  247.     /*
  248.      * An error occured. Record information telling where it came from.
  249.      */
  250.     {
  251.         char buf [100];
  252.         sprintf (buf, "\n    (file \"%.50s\" line %d)", fileName,
  253.                  interp->errorLine);
  254.         Tcl_AddErrorInfo(interp, buf);
  255.     }
  256.     return TCL_ERROR;
  257.  
  258.     /*
  259.      * Errors accessing the file once its opened are handled here.
  260.      */
  261.   accessError:
  262.     Tcl_AppendResult (interp, "error accessing: ", fileName, ": ",
  263.                       Tcl_UnixError (interp), (char *) NULL);
  264.  
  265.     close (fileNum);
  266.     return TCL_ERROR;
  267. }
  268.  
  269. /*
  270.  *-----------------------------------------------------------------------------
  271.  *
  272.  * MakeAbsFile --
  273.  *
  274.  * Convert a file name to an absolute path.  This handles tilde substitution
  275.  * and preappend the current directory name if the path is relative.
  276.  *
  277.  * Parameters
  278.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  279.  *   o fileName (I) - File name (should not start with a "/").
  280.  *   o buffer (O) - Buffer to store string in, if it will fit.
  281.  *   o bufferSize (I) - Size of buffer.
  282.  * Returns:
  283.  *   A pointer to the file name.  If the string would fit in buffer, then
  284.  * a pointer to buffer is returned, otherwise a dynamicaly allocated file
  285.  * name.   NULL is returned if an error occured.
  286.  *-----------------------------------------------------------------------------
  287.  */
  288. static char *
  289. MakeAbsFile (interp, fileName, buffer, bufferSize)
  290.     Tcl_Interp  *interp;
  291.     char        *fileName;
  292.     char        *buffer;
  293.     int          bufferSize;
  294. {
  295.     char   curDir [MAXPATHLEN+1];
  296.     char  *pathName;
  297.     int    pathLen;
  298.  
  299.     if (fileName [0] == '~') {
  300.         fileName = Tcl_TildeSubst (interp, fileName);
  301.         if (fileName == NULL)
  302.             return NULL;
  303.         pathLen = strlen (fileName);
  304.         if (pathLen < bufferSize)
  305.             pathName = buffer;
  306.         else
  307.             pathName = ckalloc (pathLen + 1);
  308.         strcpy (pathName, fileName);
  309.         return pathName;
  310.     }
  311.  
  312. #if TCL_GETWD
  313.     if (getwd (curDir) == NULL) {
  314.         Tcl_AppendResult (interp, "error getting working directory name: ",
  315.                           curDir, (char *) NULL);
  316.     }
  317. #else
  318.     if (getcwd (curDir, MAXPATHLEN) == NULL) {
  319.         Tcl_AppendResult (interp, "error getting working directory name: ",
  320.                           Tcl_UnixError (interp), (char *) NULL);
  321.     }
  322. #endif
  323.     pathLen = strlen (curDir) + strlen (fileName) + 1;  /* For `/' */
  324.     if (pathLen < bufferSize)
  325.         pathName = buffer;
  326.     else
  327.         pathName = ckalloc (pathLen + 1);
  328.     strcpy (pathName, curDir);
  329.     strcat (pathName, "/");
  330.     strcat (pathName, fileName);
  331.  
  332.     return pathName;
  333. }
  334.  
  335. /*
  336.  *-----------------------------------------------------------------------------
  337.  *
  338.  * GenerateFileId --
  339.  *
  340.  * Given a path to a file, generate its file Id, in the form:
  341.  *
  342.  *     "@dev:inode"
  343.  *
  344.  * Parameters
  345.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  346.  *   o filepath (I) - Absolute path to the file.
  347.  *   o fileId (O) - File id is returned here.
  348.  * Returns:
  349.  *   TCL_OK or TCL_ERROR.
  350.  *-----------------------------------------------------------------------------
  351.  */
  352. static int
  353. GenerateFileId (interp, filePath, fileId)
  354.      Tcl_Interp *interp;
  355.      char       *filePath;
  356.      fileId_t    fileId;
  357. {
  358.     struct stat  statInfo;
  359.  
  360.     if (stat (filePath, &statInfo) < 0) {
  361.         Tcl_AppendResult (interp, "stat of \"", filePath, "\" failed: ",
  362.                           Tcl_UnixError (interp), (char *) NULL);
  363.         return TCL_ERROR;
  364.     }
  365.  
  366.     sprintf (fileId, "@%d:%d", statInfo.st_dev, statInfo.st_ino);
  367.  
  368.     return TCL_OK;
  369. }
  370.  
  371. /*
  372.  *-----------------------------------------------------------------------------
  373.  *
  374.  * SetTCLENVFileIdEntry --
  375.  *
  376.  * Set a file entry in the TCLENV array for a file path in the form:
  377.  *
  378.  *     TCLENV(@dev:inode) filepath
  379.  *
  380.  * This entry translates a dev:info into a full file path.
  381.  *
  382.  * Parameters
  383.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  384.  *   o fileId (I) -  The file Id for the file.
  385.  *   o filepath (I) - Absolute path to the file.
  386.  * Returns:
  387.  *   TCL_OK or TCL_ERROR.
  388.  *-----------------------------------------------------------------------------
  389.  */
  390. static int
  391. SetTCLENVFileIdEntry (interp, fileId, filePath)
  392.      Tcl_Interp *interp;
  393.      fileId_t    fileId;
  394.      char       *filePath;
  395. {
  396.  
  397.     if (Tcl_SetVar2 (interp, "TCLENV", fileId, filePath,
  398.                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  399.         return TCL_ERROR;
  400.  
  401.     return TCL_OK;
  402. }
  403.  
  404. /*
  405.  *-----------------------------------------------------------------------------
  406.  *
  407.  * CheckTCLENVFileIdEntry --
  408.  *
  409.  * Check if there is a file entry in for the specified file.
  410.  *
  411.  * Parameters
  412.  *   o interp (I) - A pointer to the interpreter.
  413.  *   o filePath (I) - Absolute path to the library file.
  414.  * Returns:
  415.  *   TRUE is returned if the entry exists, FALSE if it doesn't.
  416.  *-----------------------------------------------------------------------------
  417.  */
  418. static int
  419. CheckTCLENVFileIdEntry (interp, filePath)
  420.     Tcl_Interp *interp;
  421.     char       *filePath;
  422. {
  423.     fileId_t fileId;
  424.  
  425.     /*
  426.      * If we can't generate the Id (stat failed), then just say it doesn't
  427.      * exists, other, complain later when an attempt is made to process it.
  428.      */
  429.     if (GenerateFileId (interp, filePath, fileId) != TCL_OK) {
  430.         Tcl_ResetResult (interp);
  431.         return FALSE;
  432.     }
  433.  
  434.     if (Tcl_GetVar2 (interp, "TCLENV", fileId, TCL_GLOBAL_ONLY) == NULL)
  435.         return FALSE;
  436.  
  437.     return TRUE;
  438. }
  439.  
  440. /*
  441.  *-----------------------------------------------------------------------------
  442.  *
  443.  * GetTCLENVFileIdEntry --
  444.  *
  445.  * Translate a file id into a file path.
  446.  *
  447.  * Parameters
  448.  *   o interp (I) - A pointer to the interpreter.
  449.  *   o fileId (I) - The file identifier, in the form: "@$dev:$inode"
  450.  * Returns:
  451.  *   A pointer to the absolute path to the library file is returned
  452.  *     here.  This pointer remains valid until the TCLENV entry is changed,
  453.  *     do not free.
  454.  *-----------------------------------------------------------------------------
  455.  */
  456. static char *
  457. GetTCLENVFileIdEntry (interp, fileId)
  458.     Tcl_Interp  *interp;
  459.     fileId_t     fileId;
  460. {
  461.     char *filePath;
  462.  
  463.     filePath = Tcl_GetVar2 (interp, "TCLENV", fileId, TCL_GLOBAL_ONLY);
  464.     if (filePath == NULL) {
  465.         Tcl_AppendResult (interp, "TCLENV file id entry not found for: \"",
  466.                           fileId, "\"", (char *) NULL);
  467.         return NULL;
  468.     }
  469.     
  470.     return filePath;
  471. }
  472.  
  473. /*
  474.  *-----------------------------------------------------------------------------
  475.  *
  476.  * SetTCLENVPkgEntry --
  477.  *
  478.  * Set the package entry in the TCLENV array for a package in the form:
  479.  *
  480.  *     TCLENV(PKG:$packageName) [list $fileId $offset $length]
  481.  *
  482.  * Duplicate package names are rejected.
  483.  *
  484.  * Parameters
  485.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  486.  *   o packageName (I) - Package name.
  487.  *   o fileId (I) - File id for the file.
  488.  *   o offset (I) - String containing the numeric start of the package.
  489.  *   o length (I) - Strign containing the numeric length of the package.
  490.  * Returns:
  491.  *   TCL_OK,r TCL_ERROR of TCL_CONTINUE if the package name is already defined
  492.  * and should be skipped.
  493.  *-----------------------------------------------------------------------------
  494.  */
  495. static int
  496. SetTCLENVPkgEntry (interp, packageName, fileId, offset, length)
  497.      Tcl_Interp *interp;
  498.      char       *packageName;
  499.      fileId_t    fileId;
  500.      char       *offset;
  501.      char       *length;
  502. {
  503.     int   nameLen;
  504.     char  indexBuffer [64], *indexPtr;
  505.     char *pkgDataArgv [3], *dataStr, *setResult;
  506.  
  507.     nameLen = strlen (packageName) + 5;  /* includes "PKG:" and '\0' */
  508.     if (nameLen <= sizeof (indexBuffer))
  509.         indexPtr = indexBuffer;
  510.     else
  511.         indexPtr = ckalloc (nameLen);
  512.  
  513.     strcpy (indexPtr,     "PKG:");
  514.     strcpy (indexPtr + 4, packageName);
  515.  
  516.     /*
  517.      * Check for duplicate package name.
  518.      */
  519.     if (Tcl_GetVar2 (interp, "TCLENV", indexPtr, TCL_GLOBAL_ONLY) != NULL) {
  520.         if (indexPtr != indexBuffer)
  521.             ckfree (indexPtr);
  522.         return TCL_CONTINUE;
  523.     }
  524.  
  525.     pkgDataArgv [0] = fileId;
  526.     pkgDataArgv [1] = offset;
  527.     pkgDataArgv [2] = length;
  528.     dataStr = Tcl_Merge (3, pkgDataArgv);
  529.  
  530.     setResult = Tcl_SetVar2 (interp, "TCLENV", indexPtr, dataStr,
  531.                              TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
  532.     ckfree (dataStr);
  533.     if (indexPtr != indexBuffer)
  534.         ckfree (indexPtr);
  535.  
  536.     return (setResult == NULL) ? TCL_ERROR : TCL_OK;
  537. }
  538.  
  539. /*
  540.  *-----------------------------------------------------------------------------
  541.  *
  542.  * GetTCLENVPkgEntry --
  543.  *
  544.  * Get the package entry in the TCLENV array for a package.
  545.  *
  546.  * Parameters
  547.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  548.  *   o packageName (I) - Package name to find.
  549.  *   o fileId (O) - The fileId for the library file is returned here.
  550.  *   o offsetPtr (O) - Start of the package in the library.
  551.  *   o lengthPtr (O) - Length of the package in the library.
  552.  * Returns:
  553.  *   TCL_OK or TCL_ERROR.
  554.  *-----------------------------------------------------------------------------
  555.  */
  556. static int
  557. GetTCLENVPkgEntry (interp, packageName, fileId, offsetPtr, lengthPtr)
  558.      Tcl_Interp *interp;
  559.      char       *packageName;
  560.      fileId_t    fileId;
  561.      long       *offsetPtr;
  562.      unsigned   *lengthPtr;
  563. {
  564.     int            nameLen, pkgDataArgc;
  565.     char           indexBuffer [64], *indexPtr;
  566.     char          *dataStr, **pkgDataArgv = NULL;
  567.     register char *srcPtr, *destPtr;    
  568.  
  569.     nameLen = strlen (packageName) + 5;  /* includes "PKG:" and '\0' */
  570.     if (nameLen <= sizeof (indexBuffer))
  571.         indexPtr = indexBuffer;
  572.     else
  573.         indexPtr = ckalloc (nameLen);
  574.  
  575.     strcpy (indexPtr,     "PKG:");
  576.     strcpy (indexPtr + 4, packageName);
  577.  
  578.     dataStr = Tcl_GetVar2 (interp, "TCLENV", indexPtr, TCL_GLOBAL_ONLY);
  579.     if (dataStr == NULL) {
  580.         Tcl_AppendResult (interp, "entry not found in TCLENV for package \"",
  581.                           packageName, "\"", (char *) NULL);
  582.         if (indexPtr != indexBuffer)
  583.             ckfree (indexPtr);
  584.         return TCL_ERROR;
  585.     }
  586.  
  587.     /*
  588.      * Extract the data from the array entry.
  589.      */
  590.  
  591.     if (Tcl_SplitList (interp, dataStr, &pkgDataArgc,
  592.                        &pkgDataArgv) != TCL_OK)
  593.         goto invalidEntry;
  594.     if (pkgDataArgc != 3)
  595.         goto invalidEntry;
  596.     if (strlen (pkgDataArgv [0]) >= sizeof (fileId_t))
  597.         goto invalidEntry;
  598.     strcpy (fileId, pkgDataArgv [0]);
  599.     if (!Tcl_StrToLong (pkgDataArgv [1], 0, offsetPtr))
  600.         goto invalidEntry;
  601.     if (!Tcl_StrToUnsigned (pkgDataArgv [2], 0, lengthPtr))
  602.         goto invalidEntry;
  603.  
  604.     ckfree (pkgDataArgv);
  605.     if (indexPtr != indexBuffer)
  606.         ckfree (indexPtr);
  607.     return TCL_OK;
  608.     
  609.     /*
  610.      * Exit point when an invalid entry is found.
  611.      */
  612.   invalidEntry:
  613.     if (pkgDataArgv != NULL)
  614.         ckfree (pkgDataArgv);
  615.     Tcl_ResetResult (interp);
  616.     Tcl_AppendResult (interp, "invalid entry for package library: TCLENV(",
  617.                       indexPtr,") is \"", dataStr, "\"", (char *) NULL);
  618.     if (indexPtr != indexBuffer)
  619.         ckfree (indexPtr);
  620.     return TCL_ERROR;
  621. }
  622.  
  623. /*
  624.  *-----------------------------------------------------------------------------
  625.  *
  626.  * SetTCLENVProcEntry --
  627.  *
  628.  * Set the proc entry in the TCLENV array for a package in the form:
  629.  *
  630.  *     TCLENV(PROC:$proc) [list P $packageName]
  631.  * or
  632.  *     TCLENV(PROC:$proc) [list F $fileId]
  633.  *
  634.  * Parameters
  635.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  636.  *   o procName (I) - The Tcl proc name.
  637.  *   o type (I) - "P" for a package entry or "F" for a file entry.
  638.  *   o location (I) - Either the package name or file name containing the
  639.  *                    procedure.
  640.  * Returns:
  641.  *   TCL_OK or TCL_ERROR.
  642.  *-----------------------------------------------------------------------------
  643.  */
  644. static int
  645. SetTCLENVProcEntry (interp, procName, type, location)
  646.     Tcl_Interp *interp;
  647.     char       *procName;
  648.     char       *type;
  649.     char       *location;
  650. {
  651.     int   nameLen;
  652.     char  indexBuffer [64], *indexPtr;
  653.     char *procDataArgv [2], *dataStr, *setResult;
  654.  
  655.     nameLen = strlen (procName) + 6;  /* includes "PROC:" and '\0' */
  656.     if (nameLen <= sizeof (indexBuffer))
  657.         indexPtr = indexBuffer;
  658.     else
  659.         indexPtr = ckalloc (nameLen);
  660.  
  661.     strcpy (indexPtr,     "PROC:");
  662.     strcpy (indexPtr + 5, procName);
  663.  
  664.     procDataArgv [0] = type;
  665.     procDataArgv [1] = location;
  666.     dataStr = Tcl_Merge (2, procDataArgv);
  667.  
  668.     setResult = Tcl_SetVar2 (interp, "TCLENV", indexPtr, dataStr,
  669.                              TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
  670.     ckfree (dataStr);
  671.     if (indexPtr != indexBuffer)
  672.         ckfree (indexPtr);
  673.  
  674.     return (setResult == NULL) ? TCL_ERROR : TCL_OK;
  675. }
  676.  
  677. /*
  678.  *-----------------------------------------------------------------------------
  679.  *
  680.  * GetTCLENVProcEntry --
  681.  *
  682.  * Get the proc entry in the TCLENV array for a package.
  683.  *
  684.  * Parameters
  685.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  686.  *   o procName (I) - The Tcl proc name.
  687.  *   o typePtr (O) - 'P' for a package entry or 'F' for a file entry.  This
  688.  *     is a single character result.
  689.  *   o location (O) - Either the package name or the file name.  It is
  690.  *     dynamically allocated and must be freed when finished.  NULL is
  691.  *     return if the procedure is not found.
  692.  * Returns:
  693.  *   TCL_OK or TCL_ERROR.
  694.  *-----------------------------------------------------------------------------
  695.  */
  696. static int
  697. GetTCLENVProcEntry (interp, procName, typePtr, locationPtr)
  698.     Tcl_Interp *interp;
  699.     char       *procName;
  700.     char       *typePtr;
  701.     char      **locationPtr;
  702. {
  703.     int            nameLen, procDataArgc;
  704.     char           indexBuffer [64], *indexPtr;
  705.     char          *dataStr, *setResult, **procDataArgv;
  706.     register char *srcPtr, *destPtr;    
  707.  
  708.     nameLen = strlen (procName) + 6;  /* includes "PROC:" and '\0' */
  709.     if (nameLen <= sizeof (indexBuffer))
  710.         indexPtr = indexBuffer;
  711.     else
  712.         indexPtr = ckalloc (nameLen);
  713.  
  714.     strcpy (indexPtr,     "PROC:");
  715.     strcpy (indexPtr + 5, procName);
  716.  
  717.     dataStr = Tcl_GetVar2 (interp, "TCLENV", indexPtr, TCL_GLOBAL_ONLY);
  718.     if (dataStr == NULL) {
  719.         if (indexPtr != indexBuffer)
  720.             ckfree (indexPtr);
  721.         *locationPtr = NULL;
  722.         return TCL_OK;
  723.     }
  724.  
  725.     /*
  726.      * Extract the data from the array entry.
  727.      */
  728.  
  729.     if (Tcl_SplitList (interp, dataStr, &procDataArgc,
  730.                        &procDataArgv) != TCL_OK)
  731.         goto invalidEntry;
  732.     if ((procDataArgc != 2) || (procDataArgv [0][1] != '\0'))
  733.         goto invalidEntry;
  734.     if (!((procDataArgv [0][0] == 'F') || (procDataArgv [0][0] == 'P')))
  735.         goto invalidEntry;
  736.     *typePtr = procDataArgv [0][0];
  737.  
  738.     /*
  739.      * Now do a nasty trick to save a malloc.  Since procDataArgv contains
  740.      * the string, just move the string to the top and type cast.
  741.      */
  742.     destPtr = (char *) procDataArgv;
  743.     srcPtr  = procDataArgv [1];
  744.     while (*srcPtr != '\0')
  745.         *(destPtr++) = *(srcPtr++);
  746.     *destPtr = '\0';
  747.     *locationPtr = (char *) procDataArgv;
  748.  
  749.     if (indexPtr != indexBuffer)
  750.         ckfree (indexPtr);
  751.     return TCL_OK;
  752.  
  753.     /*
  754.      * Exit point when an invalid entry is found.
  755.      */
  756.   invalidEntry:
  757.     if (procDataArgv != NULL)
  758.         ckfree (procDataArgv);
  759.     Tcl_ResetResult (interp);
  760.     Tcl_AppendResult (interp, "invalid entry for procedure: TCLENV(",
  761.                       indexPtr,") is \"", dataStr, "\"", (char *) NULL);
  762.     if (indexPtr != indexBuffer)
  763.         ckfree (indexPtr);
  764.     return TCL_ERROR;
  765. }
  766.  
  767. /*
  768.  *-----------------------------------------------------------------------------
  769.  *
  770.  * ProcessIndexFile --
  771.  *
  772.  * Open and process a package library index file (.tndx).  Creates an
  773.  * entry in the form:
  774.  *
  775.  *     TCLENV(PKG:$packageName) [list $fileId $start $len]
  776.  *
  777.  * for each package and a entry in the from
  778.  *
  779.  *     TCLENV(PROC:$proc) [list P $packageName]
  780.  *
  781.  * for each entry procedure in a package.   If the package is already defined,
  782.  * it it skipped.
  783.  *
  784.  * Parameters
  785.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  786.  *   o tlibFilePath (I) - Absolute path name to the library file.
  787.  *   o tndxFilePath (I) - Absolute path name to the library file index.
  788.  * Returns:
  789.  *   TCL_OK or TCL_ERROR.
  790.  *-----------------------------------------------------------------------------
  791.  */
  792. static int
  793. ProcessIndexFile (interp, tlibFilePath, tndxFilePath)
  794.      Tcl_Interp *interp;
  795.      char       *tlibFilePath;
  796.      char       *tndxFilePath;
  797. {
  798.     fileId_t      fileId;
  799.     FILE         *indexFilePtr;
  800.     dynamicBuf_t  lineBuffer;
  801.     int           lineArgc, idx, result;
  802.     char        **lineArgv = NULL;
  803.  
  804.     if (GenerateFileId (interp, tlibFilePath, fileId) != TCL_OK)
  805.         return TCL_ERROR;
  806.  
  807.     indexFilePtr = fopen (tndxFilePath, "r");
  808.     if (indexFilePtr == NULL) {
  809.         Tcl_AppendResult (interp, "open failed on: ", tndxFilePath, ": ",
  810.                           Tcl_UnixError (interp), (char *) NULL);
  811.         return TCL_ERROR;           
  812.     }
  813.     
  814.     Tcl_DynBufInit (&lineBuffer);
  815.  
  816.     while (TRUE) {
  817.         switch (Tcl_DynamicFgets (&lineBuffer, indexFilePtr, FALSE)) {
  818.           case 0:  /* EOF */
  819.             goto reachedEOF;
  820.           case -1: /* Error */
  821.             Tcl_AppendResult (Tcl_UnixError (interp), (char *) NULL);
  822.             goto errorExit;
  823.         }
  824.         if ((Tcl_SplitList (interp, lineBuffer.ptr, &lineArgc,
  825.                             &lineArgv) != TCL_OK) || (lineArgc < 4))
  826.             goto formatError;
  827.         
  828.         /*
  829.          * lineArgv [0] is the package name.
  830.          * lineArgv [1] is the package offset in the library.
  831.          * lineArgv [2] is the package length in the library.
  832.          * lineArgv [3-n] are the entry procedures for the package.
  833.          */
  834.         result = SetTCLENVPkgEntry (interp, lineArgv [0], fileId, lineArgv [1],
  835.                                     lineArgv [2]);
  836.         if (result == TCL_ERROR)
  837.             goto errorExit;
  838.  
  839.         /*
  840.          * If the package is not duplicated, add the procedures.
  841.          */
  842.         if (result != TCL_CONTINUE) {
  843.             for (idx = 3; idx < lineArgc; idx++) {
  844.                 if (SetTCLENVProcEntry (interp, lineArgv [idx], "P",
  845.                                         lineArgv [0]) != TCL_OK)
  846.                     goto errorExit;
  847.             }
  848.         }
  849.         ckfree (lineArgv);
  850.         lineArgv = NULL;
  851.     }
  852.  
  853.   reachedEOF:
  854.     fclose (indexFilePtr);
  855.     Tcl_DynBufFree (&lineBuffer);
  856.  
  857.     if (SetTCLENVFileIdEntry (interp, fileId, tlibFilePath) != TCL_OK)
  858.         return TCL_ERROR;
  859.  
  860.     return TCL_OK;
  861.  
  862.     /*
  863.      * Handle format error in library input line.
  864.      */
  865.   formatError:
  866.     Tcl_ResetResult (interp);
  867.     Tcl_AppendResult (interp, "format error in library index \"",
  868.                       tndxFilePath, "\" (", lineBuffer.ptr, ")",
  869.                       (char *) NULL);
  870.     goto errorExit;
  871.  
  872.     /*
  873.      * Error exit here, releasing resources and closing the file.
  874.      */
  875.   errorExit:
  876.     if (lineArgv != NULL)
  877.         ckfree (lineArgv);
  878.     Tcl_DynBufFree (&lineBuffer);
  879.     fclose (indexFilePtr);
  880.     return TCL_ERROR;
  881. }
  882.  
  883. /*
  884.  *-----------------------------------------------------------------------------
  885.  *
  886.  * BuildPackageIndex --
  887.  *
  888.  * Call the "buildpackageindex" Tcl procedure to rebuild a package index.
  889.  * If the procedure has not been loaded, then load it.  It MUST have an
  890.  * proc record setup by autoload.
  891.  *
  892.  * Parameters
  893.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  894.  *   o tlibFilePath (I) - Absolute path name to the library file.
  895.  * Returns:
  896.  *   TCL_OK or TCL_ERROR.
  897.  *-----------------------------------------------------------------------------
  898.  */
  899. static int
  900. BuildPackageIndex (interp, tlibFilePath)
  901.      Tcl_Interp *interp;
  902.      char       *tlibFilePath;
  903. {
  904.     char *cmdPtr, *initCmd;
  905.  
  906.     /*
  907.      * Load buildpackageindex if it is not loaded
  908.      */
  909.     if (TclFindProc ((Interp *) interp, "buildpackageindex") == NULL) {
  910.  
  911.         cmdPtr = "demand_load buildpackageindex";
  912.  
  913.         if (Tcl_GlobalEval (interp, cmdPtr) != TCL_OK)
  914.             return TCL_ERROR;
  915.  
  916.         if (!STREQU (interp->result, "1")) {
  917.             Tcl_ResetResult (interp);
  918.             interp->result =
  919.                 "can not find \"buildpackageindex\" on \"TCLPATH\"";
  920.             return TCL_ERROR;
  921.         }
  922.         Tcl_ResetResult (interp);
  923.     }
  924.  
  925.     /*
  926.      * Build the package index.
  927.      */
  928.     initCmd = "buildpackageindex ";
  929.  
  930.     cmdPtr = ckalloc (strlen (initCmd) + strlen (tlibFilePath) + 1);
  931.     strcpy (cmdPtr, initCmd);
  932.     strcat (cmdPtr, tlibFilePath);
  933.  
  934.     if (Tcl_GlobalEval (interp, cmdPtr) != TCL_OK) {
  935.         ckfree (cmdPtr);
  936.         return TCL_ERROR;
  937.     }
  938.     ckfree (cmdPtr);
  939.     Tcl_ResetResult (interp);
  940.     return TCL_OK;
  941. }
  942.  
  943. /*
  944.  *-----------------------------------------------------------------------------
  945.  *
  946.  * LoadPackageIndex --
  947.  *
  948.  * Load a package .tndx file.  Rebuild .tlib if non-existant or out of
  949.  * date.  An entry is made in the TCLENV array indicating that this file
  950.  * has been loaded.
  951.  *
  952.  * Parameters
  953.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  954.  *   o tlibFilePath (I) - Absolute path name to the library file.
  955.  *   o pathLen (I) - Length of tlibFilePath.
  956.  *   o dirLen (I) - The length of the leading directory path in the name.
  957.  * Returns:
  958.  *   TCL_OK or TCL_ERROR.
  959.  *-----------------------------------------------------------------------------
  960.  */
  961. static int
  962. LoadPackageIndex (interp, tlibFilePath, pathLen, dirLen)
  963.      Tcl_Interp *interp;
  964.      char       *tlibFilePath;
  965.      int         pathLen;
  966.      int         dirLen;
  967. {
  968.     char        *tndxFilePath, tndxPathBuf [64], *msg;
  969.     struct stat  tlibStat;
  970.     struct stat  tndxStat;
  971.  
  972.     if (pathLen < sizeof (tndxPathBuf))
  973.         tndxFilePath = tndxPathBuf;
  974.     else
  975.         tndxFilePath = ckalloc (pathLen + 1);
  976.     strcpy (tndxFilePath, tlibFilePath);
  977.     tndxFilePath [pathLen - 3] = 'n';
  978.     tndxFilePath [pathLen - 2] = 'd';
  979.     tndxFilePath [pathLen - 1] = 'x';
  980.  
  981.     /*
  982.      * Get library's modification time.  If the file can't be accessed, set
  983.      * time so the library does not get built.  Other code will report the
  984.      * error.
  985.      */
  986.     if (stat (tlibFilePath, &tlibStat) < 0)
  987.         tlibStat.st_mtime = MAXINT;
  988.  
  989.     /*
  990.      * Get the time for the index.  If the file does not exists or is
  991.      * out of date, rebuild it.
  992.      */
  993.  
  994.     if ((stat (tndxFilePath, &tndxStat) < 0) ||
  995.         (tndxStat.st_mtime < tlibStat.st_mtime)) {
  996.         if (BuildPackageIndex (interp, tlibFilePath) != TCL_OK)
  997.             goto errorExit;
  998.     }
  999.  
  1000.     if (ProcessIndexFile (interp, tlibFilePath, tndxFilePath) != TCL_OK)
  1001.         goto errorExit;
  1002.     if (tndxFilePath != tndxPathBuf)
  1003.         ckfree (tndxFilePath);
  1004.     return TCL_OK;
  1005.  
  1006.   errorExit:
  1007.     if (tndxFilePath != tndxPathBuf)
  1008.         ckfree (tndxFilePath);
  1009.     msg = ckalloc (strlen (tlibFilePath) + 60);
  1010.     strcpy (msg, "\n    while loading Tcl package library index \"");
  1011.     strcat (msg, tlibFilePath);
  1012.     strcat (msg, "\"");
  1013.     Tcl_AddErrorInfo (interp, msg);
  1014.     ckfree (msg);
  1015.     return TCL_ERROR;
  1016. }
  1017.  
  1018. /*
  1019.  *-----------------------------------------------------------------------------
  1020.  *
  1021.  * LoadOusterIndex --
  1022.  *
  1023.  * Load a standard Tcl index (tclIndex).  An entry is made in the TCLENV
  1024.  * array indicating that this file has been loaded.
  1025.  *
  1026.  * Parameters
  1027.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  1028.  *   o indexFilePath (I) - Absolute path name to the tclIndex file.
  1029.  *   o dirLen (I) - The length of the directory component of indexFilePath.
  1030.  * Returns:
  1031.  *   TCL_OK or TCL_ERROR.
  1032.  *-----------------------------------------------------------------------------
  1033.  */
  1034. static int
  1035. LoadOusterIndex (interp, indexFilePath, dirLen)
  1036.      Tcl_Interp *interp;
  1037.      char       *indexFilePath;
  1038.      int         dirLen;
  1039. {
  1040.     FILE         *indexFilePtr;
  1041.     fileId_t      fileId;
  1042.     dynamicBuf_t  lineBuffer;
  1043.     int           lineArgc, result, filePathLen;
  1044.     char        **lineArgv = NULL, *filePath, filePathBuf [64], *msg;
  1045.  
  1046.     indexFilePtr = fopen (indexFilePath, "r");
  1047.     if (indexFilePtr == NULL) {
  1048.         Tcl_AppendResult (interp, "open failed on: ", indexFilePath, ": ",
  1049.                           Tcl_UnixError (interp), (char *) NULL);
  1050.         return TCL_ERROR;           
  1051.     }
  1052.     
  1053.     Tcl_DynBufInit (&lineBuffer);
  1054.  
  1055.     while (TRUE) {
  1056.         switch (Tcl_DynamicFgets (&lineBuffer, indexFilePtr, FALSE)) {
  1057.           case 0:  /* EOF */
  1058.             goto reachedEOF;
  1059.           case -1: /* Error */
  1060.             Tcl_AppendResult (interp, "read filed on: ", indexFilePath, ": ",
  1061.                               Tcl_UnixError (interp), (char *) NULL);
  1062.             goto errorExit;
  1063.         }
  1064.         if ((lineBuffer.ptr [0] == '\0') || (lineBuffer.ptr [0] == '#'))
  1065.             continue;
  1066.  
  1067.         if (Tcl_SplitList (interp, lineBuffer.ptr, &lineArgc,
  1068.                            &lineArgv) != TCL_OK)
  1069.             goto formatError;
  1070.         if (! ((lineArgc == 0) || (lineArgc == 2)))
  1071.             goto formatError;
  1072.  
  1073.         if (lineArgc != 0) {
  1074.             filePathLen = strlen (lineArgv [1]) + dirLen + 1;
  1075.             if (filePathLen < sizeof (filePathBuf))
  1076.                 filePath = filePathBuf;
  1077.             else
  1078.                 filePath = ckalloc (filePathLen + 1);
  1079.             strncpy (filePath, indexFilePath, dirLen + 1);
  1080.             strcpy (filePath + dirLen + 1, lineArgv [1]);
  1081.  
  1082.             result = SetTCLENVProcEntry (interp, lineArgv [0], "F", filePath);
  1083.  
  1084.             if (filePath != filePathBuf)
  1085.                 ckfree (filePath);
  1086.             if (result != TCL_OK)
  1087.                 goto errorExit;
  1088.         }
  1089.         ckfree (lineArgv);
  1090.         lineArgv = NULL;
  1091.     }
  1092.  
  1093.   reachedEOF:
  1094.     Tcl_DynBufFree (&lineBuffer);
  1095.     fclose (indexFilePtr);
  1096.  
  1097.     if (GenerateFileId (interp, indexFilePath, fileId) != TCL_OK)
  1098.         return TCL_ERROR;
  1099.     if (SetTCLENVFileIdEntry (interp, fileId, indexFilePath) != TCL_OK)
  1100.         return TCL_ERROR;
  1101.  
  1102.     return TCL_OK;
  1103.  
  1104.     /*
  1105.      * Handle format error in library input line. If data is already in the
  1106.      * result, its assumed to be the error that brought us here.
  1107.      */
  1108.   formatError:
  1109.     if (interp->result [0] != '\0')
  1110.         Tcl_AppendResult (interp, "\n",  (char *) NULL);
  1111.     Tcl_AppendResult (interp, "format error in library index \"",
  1112.                       indexFilePath, "\" (", lineBuffer.ptr, ")",
  1113.                       (char *) NULL);
  1114.  
  1115.     /*
  1116.      * Error exit here, releasing resources and closing the file.
  1117.      */
  1118.   errorExit:
  1119.     if (lineArgv != NULL)
  1120.         ckfree (lineArgv);
  1121.     Tcl_DynBufFree (&lineBuffer);
  1122.     fclose (indexFilePtr);
  1123.  
  1124.     msg = ckalloc (strlen (indexFilePath) + 45);
  1125.     strcpy (msg, "\n    while loading Tcl procedure index \"");
  1126.     strcat (msg, indexFilePath);
  1127.     strcat (msg, "\"");
  1128.     Tcl_AddErrorInfo (interp, msg);
  1129.     ckfree (msg);
  1130.     return TCL_ERROR;
  1131. }
  1132.  
  1133. /*
  1134.  *-----------------------------------------------------------------------------
  1135.  *
  1136.  * LoadDirIndexes --
  1137.  *
  1138.  *     Load the indexes for all package library (.tlib) or a Ousterhout
  1139.  *  "tclIndex" file in a directory.  Nonexistent or unreadable directories
  1140.  *  are skipped.
  1141.  *
  1142.  * Parameters
  1143.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  1144.  *   o dirName (I) - The absolute path name of the directory to search for
  1145.  *     libraries.
  1146.  * Results:
  1147.  *   A standard Tcl result.
  1148.  *-----------------------------------------------------------------------------
  1149.  */
  1150. static int
  1151. LoadDirIndexes (interp, dirName)
  1152.     Tcl_Interp  *interp;
  1153.     char        *dirName;
  1154. {
  1155.     DIR           *dirPtr;
  1156.     struct dirent *entryPtr;
  1157.     int            dirLen, nameLen;
  1158.     char          *filePath = NULL;
  1159.     int            filePathSize = 0;
  1160.  
  1161.     dirLen = strlen (dirName);
  1162.  
  1163.     dirPtr = opendir (dirName);
  1164.     if (dirPtr == NULL)
  1165.         return TCL_OK;   /* Skip directory */
  1166.  
  1167.     while (TRUE) {
  1168.         entryPtr = readdir (dirPtr);
  1169.         if (entryPtr == NULL)
  1170.             break;
  1171.         nameLen = strlen (entryPtr->d_name);
  1172.  
  1173.         if ((nameLen > 5) && 
  1174.             ((STREQU (entryPtr->d_name + nameLen - 5, ".tlib")) ||
  1175.              (STREQU (entryPtr->d_name, "tclIndex")))) {
  1176.  
  1177.             /*
  1178.              * Expand the filePath buffer if necessary (always allow extra).
  1179.              */
  1180.             if ((nameLen + dirLen + 2) > filePathSize) {
  1181.                 if (filePath != NULL)
  1182.                     ckfree (filePath);
  1183.                 filePathSize = nameLen + dirLen + 2 + 16;
  1184.                 filePath = ckalloc (filePathSize);
  1185.                 strcpy (filePath, dirName);
  1186.                 filePath [dirLen] = '/';
  1187.             }
  1188.             strcpy (filePath + dirLen + 1, entryPtr->d_name);
  1189.  
  1190.             /*
  1191.              * Skip index if it has been loaded before or if it can't be
  1192.              * accessed.
  1193.              */
  1194.             if (CheckTCLENVFileIdEntry (interp, filePath) ||
  1195.                 (access (filePath, R_OK) < 0))
  1196.                 continue;
  1197.  
  1198.             if (entryPtr->d_name [nameLen - 5] == '.') {
  1199.                 if (LoadPackageIndex (interp, filePath, dirLen + nameLen + 1,
  1200.                                       dirLen) != TCL_OK)
  1201.                     goto errorExit;
  1202.             } else {
  1203.                 if (LoadOusterIndex (interp, filePath, dirLen) != TCL_OK)
  1204.                     goto errorExit;
  1205.             }
  1206.         }
  1207.     }
  1208.  
  1209.     if (filePath != NULL)
  1210.         ckfree (filePath);
  1211.     closedir (dirPtr);
  1212.     return TCL_OK;
  1213.  
  1214.   errorExit:
  1215.     if (filePath != NULL)
  1216.         ckfree (filePath);
  1217.     closedir (dirPtr);
  1218.     return TCL_ERROR;
  1219.  
  1220. }
  1221.  
  1222. /*
  1223.  *-----------------------------------------------------------------------------
  1224.  *
  1225.  * LoadPackageIndexes --
  1226.  *
  1227.  * Loads the all indexes for all package libraries (.tlib)* or a
  1228.  * Ousterhout "tclIndex" files found in all directories in the path.
  1229.  * If an index has already been loaded, it will not be reloaded.
  1230.  * Non-existent or unreadable directories are skipped.
  1231.  *
  1232.  * Results:
  1233.  *   A standard Tcl result.  Tcl array variable TCLENV is updated to
  1234.  * indicate the procedures that were defined in the library.
  1235.  *
  1236.  *-----------------------------------------------------------------------------
  1237.  */
  1238. static int
  1239. LoadPackageIndexes (interp, path)
  1240.     Tcl_Interp  *interp;
  1241.     char        *path;
  1242. {
  1243.     char  *dirName, dirNameBuf [64];
  1244.     int    idx, dirLen, pathArgc, status;
  1245.     char **pathArgv;
  1246.  
  1247.     if (Tcl_SplitList (interp, path, &pathArgc, &pathArgv) != TCL_OK)
  1248.         return TCL_OK;
  1249.  
  1250.     for (idx = 0; idx < pathArgc; idx++) {
  1251.         /*
  1252.          * Get the absolute dir name.  if the conversion fails (most likely
  1253.          * invalid "~") or thje directory cann't be read, skip it.
  1254.          */
  1255.         dirName = pathArgv [idx];
  1256.         if (dirName [0] != '/') {
  1257.             dirName = MakeAbsFile (interp, dirName, dirNameBuf, 
  1258.                                    sizeof (dirNameBuf));
  1259.             if (dirName == NULL)
  1260.                 continue;
  1261.         }
  1262.         if (access (dirName, X_OK) == 0)
  1263.             status = LoadDirIndexes (interp, dirName);
  1264.         else
  1265.             status = TCL_OK;
  1266.  
  1267.         if ((dirName != pathArgv [idx]) && (dirName != dirNameBuf))
  1268.             ckfree (dirName);
  1269.         if (status != TCL_OK)
  1270.             goto errorExit;
  1271.     }
  1272.     ckfree (pathArgv);
  1273.     return TCL_OK;
  1274.  
  1275.   errorExit:
  1276.     ckfree (pathArgv);
  1277.     return TCL_ERROR;
  1278.  
  1279. }
  1280.  
  1281. /*
  1282.  *-----------------------------------------------------------------------------
  1283.  *
  1284.  * LoadProc --
  1285.  *
  1286.  *    Attempt to load a procedure (or command) by checking the TCLENV 
  1287.  * array for its location (either in a file or package library).
  1288.  *
  1289.  * Parameters
  1290.  *   o interp (I) - A pointer to the interpreter, error returned in result.
  1291.  *   o procName (I) - The name of the procedure (or command) to load
  1292.  *     libraries.
  1293.  *   o foundPtr (O) - TRUE is returned if the procedure or command was
  1294.  *     loaded, FALSE if it was not.
  1295.  * Results:
  1296.  *   A standard Tcl result.
  1297.  *
  1298.  *-----------------------------------------------------------------------------
  1299.  */
  1300. static int
  1301. LoadProc (interp, procName, foundPtr)
  1302.     Tcl_Interp  *interp;
  1303.     char        *procName;
  1304.     int         *foundPtr;
  1305. {
  1306.     Interp        *iPtr = (Interp *) interp;
  1307.     char           type, *location, *filePath, *cmdPtr, cmdBuf [80];
  1308.     int            cmdLen, result;
  1309.     long           offset;
  1310.     unsigned       length;
  1311.     fileId_t       fileId;
  1312.     Tcl_HashEntry *cmdEntryPtr;
  1313.  
  1314.     if (GetTCLENVProcEntry (interp, procName, &type, &location) != TCL_OK)
  1315.         return TCL_ERROR;
  1316.     if (location == NULL) {
  1317.         *foundPtr = FALSE;
  1318.         return TCL_OK;
  1319.     }
  1320.  
  1321.     /*
  1322.      * If this is a file entry (type = 'F'), location is a file name or
  1323.      * absolute file path.  If it's an absolute path, just eval it, otherwise
  1324.      * load the source using the "load" procdure (still in Tcl). If this is a
  1325.      * package entry, location is a package name. Source part of the package
  1326.      * library (Must look up the file, offset and length in the package entry
  1327.      * in TCLENV).
  1328.      */
  1329.     if (type == 'F') {
  1330.         if (location [0] == '/') {
  1331.             result = GlobalEvalFile (interp, location);
  1332.         } else {
  1333.             cmdLen = strlen (location) + 5;
  1334.             if (cmdLen < sizeof (cmdBuf))
  1335.                 cmdPtr = cmdBuf;
  1336.             else
  1337.                 cmdPtr = ckalloc (cmdLen + 1);
  1338.             strcpy (cmdPtr, "load ");
  1339.             strcat (cmdPtr, location);
  1340.  
  1341.             result = Tcl_GlobalEval (interp, cmdPtr);
  1342.             if (cmdPtr != cmdBuf)
  1343.                 ckfree (cmdPtr);
  1344.         }
  1345.     } else {
  1346.         result = GetTCLENVPkgEntry (interp, location, fileId, &offset,
  1347.                                     &length);
  1348.         if (result == TCL_OK) {
  1349.             filePath = GetTCLENVFileIdEntry (interp, fileId);
  1350.             if (filePath == NULL)
  1351.                 result = TCL_ERROR;
  1352.         }
  1353.         
  1354.         if (result == TCL_OK)
  1355.             result = EvalFilePart (interp, filePath, offset, length);
  1356.  
  1357.     }
  1358.  
  1359.     ckfree (location);
  1360.     
  1361.     /*
  1362.      * If we are ok to this point, make sure that the procedure or command is
  1363.      * actually loaded.
  1364.      */
  1365.     if (result == TCL_OK) {
  1366.         cmdEntryPtr = Tcl_FindHashEntry (&iPtr->commandTable, procName);
  1367.         *foundPtr = (cmdEntryPtr != NULL);
  1368.     }
  1369.  
  1370.     return result;
  1371. }
  1372.  
  1373. /*
  1374.  *-----------------------------------------------------------------------------
  1375.  *
  1376.  * Tcl_LoadlibindexCmd --
  1377.  *
  1378.  *   This procedure is invoked to process the "Loadlibindex" Tcl command:
  1379.  *
  1380.  *      loadlibindex libfile
  1381.  *
  1382.  * which loads the index for a package library (.tlib) or a Ousterhout
  1383.  * "tclIndex" file.
  1384.  *
  1385.  * Results:
  1386.  *    A standard Tcl result.  Tcl array variable TCLENV is updated to
  1387.  * indicate the procedures that were defined in the library.
  1388.  *
  1389.  *-----------------------------------------------------------------------------
  1390.  */
  1391. int
  1392. Tcl_LoadlibindexCmd (dummy, interp, argc, argv)
  1393.     ClientData   dummy;
  1394.     Tcl_Interp  *interp;
  1395.     int          argc;
  1396.     char       **argv;
  1397. {
  1398.     char *pathName, pathNameBuf [64];
  1399.     int   pathLen, dirLen;
  1400.  
  1401.     if (argc != 2) {
  1402.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " libFile",
  1403.                           (char *) NULL);
  1404.         return TCL_ERROR;
  1405.     }
  1406.  
  1407.     pathName = argv [1];
  1408.     if (pathName [0] != '/') {
  1409.         pathName = MakeAbsFile (interp, pathName, pathNameBuf, 
  1410.                                 sizeof (pathNameBuf));
  1411.         if (pathName == NULL)
  1412.             return TCL_ERROR;
  1413.     }
  1414.  
  1415.     /*
  1416.      * Find the length of the directory name. Validate that we have a .tlib
  1417.      * extension or file name is "tclIndex" and call the routine to process
  1418.      * the specific type of index.
  1419.      */
  1420.     pathLen = strlen (pathName);
  1421.     for (dirLen = pathLen - 1; pathName [dirLen] != '/'; dirLen--)
  1422.         continue;
  1423.  
  1424.     if ((pathLen > 5) && (pathName [pathLen - 5] == '.')) {
  1425.         if (!STREQU (pathName + pathLen - 5, ".tlib"))
  1426.             goto invalidName;
  1427.         if (LoadPackageIndex (interp, pathName, pathLen, dirLen) != TCL_OK)
  1428.             goto errorExit;
  1429.     } else {
  1430.         if (!STREQU (pathName + dirLen, "/tclIndex"))
  1431.             goto invalidName;
  1432.         if (LoadOusterIndex (interp, pathName, dirLen) != TCL_OK)
  1433.             goto errorExit;
  1434.     }
  1435.     if ((pathName != argv [1]) && (pathName != pathNameBuf))
  1436.         ckfree (pathName);
  1437.     return TCL_OK;
  1438.  
  1439.   invalidName:
  1440.     Tcl_AppendResult (interp, "invalid library name, must have an extension ",
  1441.                       "of \".tlib\" or the name \"tclIndex\", got \"",
  1442.                       argv [1], "\"", (char *) NULL);
  1443.  
  1444.   errorExit:
  1445.     if ((pathName != argv [1]) && (pathName != pathNameBuf))
  1446.         ckfree (pathName);
  1447.     return TCL_ERROR;;
  1448. }
  1449.  
  1450. /*
  1451.  *-----------------------------------------------------------------------------
  1452.  *
  1453.  * Tcl_Demand_loadCmd --
  1454.  *
  1455.  *   This procedure is invoked to process the "demand_load" Tcl command:
  1456.  *
  1457.  *         demand_load proc
  1458.  *
  1459.  * which searchs the TCLENV tables for the specified procedure.  If it
  1460.  * is not found, an attempt is made to load unloaded libraries, first
  1461.  * the variable "TCLPATH" is searched.  If the procedure is not defined
  1462.  * after that, then "auto_path" is searched.
  1463.  *
  1464.  * Results:
  1465.  *   A standard Tcl result.
  1466.  *
  1467.  *-----------------------------------------------------------------------------
  1468.  */
  1469. int
  1470. Tcl_Demand_loadCmd (dummy, interp, argc, argv)
  1471.     ClientData   dummy;
  1472.     Tcl_Interp  *interp;
  1473.     int          argc;
  1474.     char       **argv;
  1475. {
  1476.     int   found;
  1477.     char *path, *msg;
  1478.  
  1479.     if (argc != 2) {
  1480.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " procedure",
  1481.                           (char *) NULL);
  1482.         return TCL_ERROR;
  1483.     }
  1484.  
  1485.     if (LoadProc (interp, argv [1], &found) != TCL_OK)
  1486.         goto errorExit;
  1487.     if (found) {
  1488.         interp->result = "1";
  1489.         return TCL_OK;
  1490.     }
  1491.  
  1492.     /*
  1493.      * Slow path, load the libraries indices on "TCLPATH".
  1494.      */
  1495.     path = Tcl_GetVar (interp, "TCLPATH", TCL_GLOBAL_ONLY);
  1496.     if (path != NULL) {
  1497.         if (LoadPackageIndexes (interp, path) != TCL_OK)
  1498.             goto errorExit;
  1499.         if (LoadProc (interp, argv [1], &found) != TCL_OK)
  1500.             goto errorExit;
  1501.         if (found) {
  1502.             interp->result = "1";
  1503.             return TCL_OK;
  1504.         }
  1505.     }
  1506.  
  1507.     /*
  1508.      * Final gasp, check the "auto_path"
  1509.      */
  1510.     path = Tcl_GetVar (interp, "auto_path", TCL_GLOBAL_ONLY);
  1511.     if (path != NULL) {
  1512.         if (LoadPackageIndexes (interp, path) != TCL_OK)
  1513.             goto errorExit;
  1514.         if (LoadProc (interp, argv [1], &found) != TCL_OK)
  1515.             goto errorExit;
  1516.         if (found) {
  1517.             interp->result = "1";
  1518.             return TCL_OK;
  1519.         }
  1520.     }
  1521.  
  1522.     /*
  1523.      * Procedure or command was not found.
  1524.      */
  1525.     interp->result = "0";
  1526.     return TCL_OK;
  1527.  
  1528.   errorExit:
  1529.     msg = ckalloc (strlen (argv [1]) + 35);
  1530.     strcpy (msg, "\n    while demand loading \"");
  1531.     strcat (msg, argv [1]);
  1532.     strcat (msg, "\"");
  1533.     Tcl_AddErrorInfo (interp, msg);
  1534.     ckfree (msg);
  1535.     return TCL_ERROR;
  1536. }
  1537.  
  1538.