]>
git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxlib.c
61d0a83f266c91ba4ce1e6f91f91dcec74804eda
4 * Tcl commands to load libraries of Tcl code.
5 *-----------------------------------------------------------------------------
6 * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
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
14 *-----------------------------------------------------------------------------
15 * $Id: tclXlib.c,v 2.0 1992/10/16 04:50:55 markd Rel $
16 *-----------------------------------------------------------------------------
19 /*-----------------------------------------------------------------------------
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.
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
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.
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.
37 * o TCLENV(PROC:$proc) {P $packageName} - This form of a procedure entry
38 * translates a procedure into a package name.
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
44 *-----------------------------------------------------------------------------
48 typedef char fileId_t
[64];
51 * Prototypes of internal functions.
54 EvalFilePart
_ANSI_ARGS_((Tcl_Interp
*interp
,
60 MakeAbsFile
_ANSI_ARGS_((Tcl_Interp
*interp
,
66 GenerateFileId
_ANSI_ARGS_((Tcl_Interp
*interp
,
71 SetTCLENVFileIdEntry
_ANSI_ARGS_((Tcl_Interp
*interp
,
76 CheckTCLENVFileIdEntry
_ANSI_ARGS_((Tcl_Interp
*interp
,
80 GetTCLENVFileIdEntry
_ANSI_ARGS_((Tcl_Interp
*interp
,
84 SetTCLENVPkgEntry
_ANSI_ARGS_((Tcl_Interp
*interp
,
91 GetTCLENVPkgEntry
_ANSI_ARGS_((Tcl_Interp
*interp
,
95 unsigned *lengthPtr
));
98 SetTCLENVProcEntry
_ANSI_ARGS_((Tcl_Interp
*interp
,
104 GetTCLENVProcEntry
_ANSI_ARGS_((Tcl_Interp
*interp
,
107 char **locationPtr
));
110 ProcessIndexFile
_ANSI_ARGS_((Tcl_Interp
*interp
,
112 char *tndxFilePath
));
115 BuildPackageIndex
_ANSI_ARGS_((Tcl_Interp
*interp
,
116 char *tlibFilePath
));
119 LoadPackageIndex
_ANSI_ARGS_((Tcl_Interp
*interp
,
125 LoadOusterIndex
_ANSI_ARGS_((Tcl_Interp
*interp
,
130 LoadDirIndexes
_ANSI_ARGS_((Tcl_Interp
*interp
,
134 LoadPackageIndexes
_ANSI_ARGS_((Tcl_Interp
*interp
,
138 LoadProc
_ANSI_ARGS_((Tcl_Interp
*interp
,
144 *-----------------------------------------------------------------------------
148 * Read in a byte range of a file and evaulate it.
151 * o interp (I) - A pointer to the interpreter, error returned in result.
152 * o fileName (I) - The file to evaulate.
153 * o offset (I) - Byte offset into the file of the area to evaluate
154 * o length (I) - Number of bytes to evaulate..
157 * A standard Tcl result.
158 *-----------------------------------------------------------------------------
161 EvalFilePart (interp
, fileName
, offset
, length
)
167 Interp
*iPtr
= (Interp
*) interp
;
170 char *oldScriptFile
, *cmdBuffer
;
173 if (fileName
[0] == '~')
174 if ((fileName
= Tcl_TildeSubst (interp
, fileName
)) == NULL
)
177 fileNum
= open (fileName
, O_RDONLY
, 0);
179 Tcl_AppendResult (interp
, "open failed on: ", fileName
, ": ",
180 Tcl_UnixError (interp
), (char *) NULL
);
183 if (fstat (fileNum
, &statBuf
) == -1)
186 if ((statBuf
.st_size
< offset
+ length
) || (offset
< 0)) {
187 Tcl_AppendResult (interp
, "range to eval outside of file bounds \"",
188 fileName
, "\"", (char *) NULL
);
192 if (lseek (fileNum
, offset
, 0) < 0)
195 cmdBuffer
= ckalloc (length
+ 1);
196 if (read (fileNum
, cmdBuffer
, length
) != length
)
199 cmdBuffer
[length
] = '\0';
201 if (close (fileNum
) != 0)
204 oldScriptFile
= iPtr
->scriptFile
;
205 iPtr
->scriptFile
= fileName
;
207 result
= Tcl_Eval (interp
, cmdBuffer
, 0, (char **) NULL
);
209 iPtr
->scriptFile
= oldScriptFile
;
212 if (result
!= TCL_ERROR
)
216 * An error occured. Record information telling where it came from.
220 sprintf (buf
, "\n (file \"%.50s\" line %d)", fileName
,
222 Tcl_AddErrorInfo(interp
, buf
);
227 * Errors accessing the file once its opened are handled here.
230 Tcl_AppendResult (interp
, "error accessing: ", fileName
, ": ",
231 Tcl_UnixError (interp
), (char *) NULL
);
238 *-----------------------------------------------------------------------------
242 * Convert a file name to an absolute path. This handles tilde substitution
243 * and preappend the current directory name if the path is relative.
246 * o interp (I) - A pointer to the interpreter, error returned in result.
247 * o fileName (I) - File name (should not start with a "/").
248 * o buffer (O) - Buffer to store string in, if it will fit.
249 * o bufferSize (I) - Size of buffer.
251 * A pointer to the file name. If the string would fit in buffer, then
252 * a pointer to buffer is returned, otherwise a dynamicaly allocated file
253 * name. NULL is returned if an error occured.
254 *-----------------------------------------------------------------------------
257 MakeAbsFile (interp
, fileName
, buffer
, bufferSize
)
263 char curDir
[MAXPATHLEN
+1];
267 if (fileName
[0] == '~') {
268 fileName
= Tcl_TildeSubst (interp
, fileName
);
269 if (fileName
== NULL
)
271 pathLen
= strlen (fileName
);
272 if (pathLen
< bufferSize
)
275 pathName
= ckalloc (pathLen
+ 1);
276 strcpy (pathName
, fileName
);
281 if (getwd (curDir
) == NULL
) {
282 Tcl_AppendResult (interp
, "error getting working directory name: ",
283 curDir
, (char *) NULL
);
286 if (getcwd (curDir
, MAXPATHLEN
) == 0) {
287 Tcl_AppendResult (interp
, "error getting working directory name: ",
288 Tcl_UnixError (interp
), (char *) NULL
);
291 pathLen
= strlen (curDir
) + strlen (fileName
) + 1; /* For `/' */
292 if (pathLen
< bufferSize
)
295 pathName
= ckalloc (pathLen
+ 1);
296 strcpy (pathName
, curDir
);
297 strcat (pathName
, "/");
298 strcat (pathName
, fileName
);
304 *-----------------------------------------------------------------------------
308 * Given a path to a file, generate its file Id, in the form:
313 * o interp (I) - A pointer to the interpreter, error returned in result.
314 * o filepath (I) - Absolute path to the file.
315 * o fileId (O) - File id is returned here.
317 * TCL_OK or TCL_ERROR.
318 *-----------------------------------------------------------------------------
321 GenerateFileId (interp
, filePath
, fileId
)
326 struct stat statInfo
;
328 if (stat (filePath
, &statInfo
) < 0) {
329 Tcl_AppendResult (interp
, "stat of \"", filePath
, "\" failed: ",
330 Tcl_UnixError (interp
), (char *) NULL
);
334 sprintf (fileId
, "@%d:%d", statInfo
.st_dev
, statInfo
.st_ino
);
340 *-----------------------------------------------------------------------------
342 * SetTCLENVFileIdEntry --
344 * Set a file entry in the TCLENV array for a file path in the form:
346 * TCLENV(@dev:inode) filepath
348 * This entry translates a dev:info into a full file path.
351 * o interp (I) - A pointer to the interpreter, error returned in result.
352 * o fileId (I) - The file Id for the file.
353 * o filepath (I) - Absolute path to the file.
355 * TCL_OK or TCL_ERROR.
356 *-----------------------------------------------------------------------------
359 SetTCLENVFileIdEntry (interp
, fileId
, filePath
)
365 if (Tcl_SetVar2 (interp
, "TCLENV", fileId
, filePath
,
366 TCL_GLOBAL_ONLY
| TCL_LEAVE_ERR_MSG
) == NULL
)
373 *-----------------------------------------------------------------------------
375 * CheckTCLENVFileIdEntry --
377 * Check if there is a file entry in for the specified file.
380 * o interp (I) - A pointer to the interpreter.
381 * o filePath (I) - Absolute path to the library file.
383 * TRUE is returned if the entry exists, FALSE if it doesn't.
384 *-----------------------------------------------------------------------------
387 CheckTCLENVFileIdEntry (interp
, filePath
)
394 * If we can't generate the Id (stat failed), then just say it doesn't
395 * exists, other, complain later when an attempt is made to process it.
397 if (GenerateFileId (interp
, filePath
, fileId
) != TCL_OK
) {
398 Tcl_ResetResult (interp
);
402 if (Tcl_GetVar2 (interp
, "TCLENV", fileId
, TCL_GLOBAL_ONLY
) == NULL
)
409 *-----------------------------------------------------------------------------
411 * GetTCLENVFileIdEntry --
413 * Translate a file id into a file path.
416 * o interp (I) - A pointer to the interpreter.
417 * o fileId (I) - The file identifier, in the form: "@$dev:$inode"
419 * A pointer to the absolute path to the library file is returned
420 * here. This pointer remains valid until the TCLENV entry is changed,
422 *-----------------------------------------------------------------------------
425 GetTCLENVFileIdEntry (interp
, fileId
)
431 filePath
= Tcl_GetVar2 (interp
, "TCLENV", fileId
, TCL_GLOBAL_ONLY
);
432 if (filePath
== NULL
) {
433 Tcl_AppendResult (interp
, "TCLENV file id entry not found for: \"",
434 fileId
, "\"", (char *) NULL
);
442 *-----------------------------------------------------------------------------
444 * SetTCLENVPkgEntry --
446 * Set the package entry in the TCLENV array for a package in the form:
448 * TCLENV(PKG:$packageName) [list $fileId $offset $length]
450 * Duplicate package names are rejected.
453 * o interp (I) - A pointer to the interpreter, error returned in result.
454 * o packageName (I) - Package name.
455 * o fileId (I) - File id for the file.
456 * o offset (I) - String containing the numeric start of the package.
457 * o length (I) - Strign containing the numeric length of the package.
459 * TCL_OK,r TCL_ERROR of TCL_CONTINUE if the package name is already defined
460 * and should be skipped.
461 *-----------------------------------------------------------------------------
464 SetTCLENVPkgEntry (interp
, packageName
, fileId
, offset
, length
)
472 char indexBuffer
[64], *indexPtr
;
473 char *pkgDataArgv
[3], *dataStr
, *setResult
;
475 nameLen
= strlen (packageName
) + 5; /* includes "PKG:" and '\0' */
476 if (nameLen
<= sizeof (indexBuffer
))
477 indexPtr
= indexBuffer
;
479 indexPtr
= ckalloc (nameLen
);
481 strcpy (indexPtr
, "PKG:");
482 strcpy (indexPtr
+ 4, packageName
);
485 * Check for duplicate package name.
487 if (Tcl_GetVar2 (interp
, "TCLENV", indexPtr
, TCL_GLOBAL_ONLY
) != NULL
) {
488 if (indexPtr
!= indexBuffer
)
493 pkgDataArgv
[0] = fileId
;
494 pkgDataArgv
[1] = offset
;
495 pkgDataArgv
[2] = length
;
496 dataStr
= Tcl_Merge (3, pkgDataArgv
);
498 setResult
= Tcl_SetVar2 (interp
, "TCLENV", indexPtr
, dataStr
,
499 TCL_GLOBAL_ONLY
| TCL_LEAVE_ERR_MSG
);
501 if (indexPtr
!= indexBuffer
)
504 return (setResult
== NULL
) ? TCL_ERROR
: TCL_OK
;
508 *-----------------------------------------------------------------------------
510 * GetTCLENVPkgEntry --
512 * Get the package entry in the TCLENV array for a package.
515 * o interp (I) - A pointer to the interpreter, error returned in result.
516 * o packageName (I) - Package name to find.
517 * o fileId (O) - The fileId for the library file is returned here.
518 * o offsetPtr (O) - Start of the package in the library.
519 * o lengthPtr (O) - Length of the package in the library.
521 * TCL_OK or TCL_ERROR.
522 *-----------------------------------------------------------------------------
525 GetTCLENVPkgEntry (interp
, packageName
, fileId
, offsetPtr
, lengthPtr
)
532 int nameLen
, pkgDataArgc
;
533 char indexBuffer
[64], *indexPtr
;
534 char *dataStr
, **pkgDataArgv
= NULL
;
535 register char *srcPtr
, *destPtr
;
537 nameLen
= strlen (packageName
) + 5; /* includes "PKG:" and '\0' */
538 if (nameLen
<= sizeof (indexBuffer
))
539 indexPtr
= indexBuffer
;
541 indexPtr
= ckalloc (nameLen
);
543 strcpy (indexPtr
, "PKG:");
544 strcpy (indexPtr
+ 4, packageName
);
546 dataStr
= Tcl_GetVar2 (interp
, "TCLENV", indexPtr
, TCL_GLOBAL_ONLY
);
547 if (dataStr
== NULL
) {
548 Tcl_AppendResult (interp
, "entry not found in TCLENV for package \"",
549 packageName
, "\"", (char *) NULL
);
550 if (indexPtr
!= indexBuffer
)
556 * Extract the data from the array entry.
559 if (Tcl_SplitList (interp
, dataStr
, &pkgDataArgc
,
560 &pkgDataArgv
) != TCL_OK
)
562 if (pkgDataArgc
!= 3)
564 if (strlen (pkgDataArgv
[0]) >= sizeof (fileId_t
))
566 strcpy (fileId
, pkgDataArgv
[0]);
567 if (!Tcl_StrToLong (pkgDataArgv
[1], 0, offsetPtr
))
569 if (!Tcl_StrToUnsigned (pkgDataArgv
[2], 0, lengthPtr
))
572 ckfree (pkgDataArgv
);
573 if (indexPtr
!= indexBuffer
)
578 * Exit point when an invalid entry is found.
581 if (pkgDataArgv
!= NULL
)
582 ckfree (pkgDataArgv
);
583 Tcl_ResetResult (interp
);
584 Tcl_AppendResult (interp
, "invalid entry for package library: TCLENV(",
585 indexPtr
,") is \"", dataStr
, "\"", (char *) NULL
);
586 if (indexPtr
!= indexBuffer
)
592 *-----------------------------------------------------------------------------
594 * SetTCLENVProcEntry --
596 * Set the proc entry in the TCLENV array for a package in the form:
598 * TCLENV(PROC:$proc) [list P $packageName]
600 * TCLENV(PROC:$proc) [list F $fileId]
603 * o interp (I) - A pointer to the interpreter, error returned in result.
604 * o procName (I) - The Tcl proc name.
605 * o type (I) - "P" for a package entry or "F" for a file entry.
606 * o location (I) - Either the package name or file name containing the
609 * TCL_OK or TCL_ERROR.
610 *-----------------------------------------------------------------------------
613 SetTCLENVProcEntry (interp
, procName
, type
, location
)
620 char indexBuffer
[64], *indexPtr
;
621 char *procDataArgv
[2], *dataStr
, *setResult
;
623 nameLen
= strlen (procName
) + 6; /* includes "PROC:" and '\0' */
624 if (nameLen
<= sizeof (indexBuffer
))
625 indexPtr
= indexBuffer
;
627 indexPtr
= ckalloc (nameLen
);
629 strcpy (indexPtr
, "PROC:");
630 strcpy (indexPtr
+ 5, procName
);
632 procDataArgv
[0] = type
;
633 procDataArgv
[1] = location
;
634 dataStr
= Tcl_Merge (2, procDataArgv
);
636 setResult
= Tcl_SetVar2 (interp
, "TCLENV", indexPtr
, dataStr
,
637 TCL_GLOBAL_ONLY
| TCL_LEAVE_ERR_MSG
);
639 if (indexPtr
!= indexBuffer
)
642 return (setResult
== NULL
) ? TCL_ERROR
: TCL_OK
;
646 *-----------------------------------------------------------------------------
648 * GetTCLENVProcEntry --
650 * Get the proc entry in the TCLENV array for a package.
653 * o interp (I) - A pointer to the interpreter, error returned in result.
654 * o procName (I) - The Tcl proc name.
655 * o typePtr (O) - 'P' for a package entry or 'F' for a file entry. This
656 * is a single character result.
657 * o location (O) - Either the package name or the file name. It is
658 * dynamically allocated and must be freed when finished. NULL is
659 * return if the procedure is not found.
661 * TCL_OK or TCL_ERROR.
662 *-----------------------------------------------------------------------------
665 GetTCLENVProcEntry (interp
, procName
, typePtr
, locationPtr
)
671 int nameLen
, procDataArgc
;
672 char indexBuffer
[64], *indexPtr
;
673 char *dataStr
, *setResult
, **procDataArgv
;
674 register char *srcPtr
, *destPtr
;
676 nameLen
= strlen (procName
) + 6; /* includes "PROC:" and '\0' */
677 if (nameLen
<= sizeof (indexBuffer
))
678 indexPtr
= indexBuffer
;
680 indexPtr
= ckalloc (nameLen
);
682 strcpy (indexPtr
, "PROC:");
683 strcpy (indexPtr
+ 5, procName
);
685 dataStr
= Tcl_GetVar2 (interp
, "TCLENV", indexPtr
, TCL_GLOBAL_ONLY
);
686 if (dataStr
== NULL
) {
687 if (indexPtr
!= indexBuffer
)
694 * Extract the data from the array entry.
697 if (Tcl_SplitList (interp
, dataStr
, &procDataArgc
,
698 &procDataArgv
) != TCL_OK
)
700 if ((procDataArgc
!= 2) || (procDataArgv
[0][1] != '\0'))
702 if (!((procDataArgv
[0][0] == 'F') || (procDataArgv
[0][0] == 'P')))
704 *typePtr
= procDataArgv
[0][0];
707 * Now do a nasty trick to save a malloc. Since procDataArgv contains
708 * the string, just move the string to the top and type cast.
710 destPtr
= (char *) procDataArgv
;
711 srcPtr
= procDataArgv
[1];
712 while (*srcPtr
!= '\0')
713 *(destPtr
++) = *(srcPtr
++);
715 *locationPtr
= (char *) procDataArgv
;
717 if (indexPtr
!= indexBuffer
)
722 * Exit point when an invalid entry is found.
725 if (procDataArgv
!= NULL
)
726 ckfree (procDataArgv
);
727 Tcl_ResetResult (interp
);
728 Tcl_AppendResult (interp
, "invalid entry for procedure: TCLENV(",
729 indexPtr
,") is \"", dataStr
, "\"", (char *) NULL
);
730 if (indexPtr
!= indexBuffer
)
736 *-----------------------------------------------------------------------------
738 * ProcessIndexFile --
740 * Open and process a package library index file (.tndx). Creates an
743 * TCLENV(PKG:$packageName) [list $fileId $start $len]
745 * for each package and a entry in the from
747 * TCLENV(PROC:$proc) [list P $packageName]
749 * for each entry procedure in a package. If the package is already defined,
753 * o interp (I) - A pointer to the interpreter, error returned in result.
754 * o tlibFilePath (I) - Absolute path name to the library file.
755 * o tndxFilePath (I) - Absolute path name to the library file index.
757 * TCL_OK or TCL_ERROR.
758 *-----------------------------------------------------------------------------
761 ProcessIndexFile (interp
, tlibFilePath
, tndxFilePath
)
768 dynamicBuf_t lineBuffer
;
769 int lineArgc
, idx
, result
;
770 char **lineArgv
= NULL
;
772 if (GenerateFileId (interp
, tlibFilePath
, fileId
) != TCL_OK
)
775 indexFilePtr
= fopen (tndxFilePath
, "r");
776 if (indexFilePtr
== NULL
) {
777 Tcl_AppendResult (interp
, "open failed on: ", tndxFilePath
, ": ",
778 Tcl_UnixError (interp
), (char *) NULL
);
782 Tcl_DynBufInit (&lineBuffer
);
785 switch (Tcl_DynamicFgets (&lineBuffer
, indexFilePtr
, FALSE
)) {
789 Tcl_AppendResult (interp
, Tcl_UnixError (interp
), (char *) NULL
);
792 if ((Tcl_SplitList (interp
, lineBuffer
.ptr
, &lineArgc
,
793 &lineArgv
) != TCL_OK
) || (lineArgc
< 4))
797 * lineArgv [0] is the package name.
798 * lineArgv [1] is the package offset in the library.
799 * lineArgv [2] is the package length in the library.
800 * lineArgv [3-n] are the entry procedures for the package.
802 result
= SetTCLENVPkgEntry (interp
, lineArgv
[0], fileId
, lineArgv
[1],
804 if (result
== TCL_ERROR
)
808 * If the package is not duplicated, add the procedures.
810 if (result
!= TCL_CONTINUE
) {
811 for (idx
= 3; idx
< lineArgc
; idx
++) {
812 if (SetTCLENVProcEntry (interp
, lineArgv
[idx
], "P",
813 lineArgv
[0]) != TCL_OK
)
822 fclose (indexFilePtr
);
823 Tcl_DynBufFree (&lineBuffer
);
825 if (SetTCLENVFileIdEntry (interp
, fileId
, tlibFilePath
) != TCL_OK
)
831 * Handle format error in library input line.
834 Tcl_ResetResult (interp
);
835 Tcl_AppendResult (interp
, "format error in library index \"",
836 tndxFilePath
, "\" (", lineBuffer
.ptr
, ")",
841 * Error exit here, releasing resources and closing the file.
844 if (lineArgv
!= NULL
)
846 Tcl_DynBufFree (&lineBuffer
);
847 fclose (indexFilePtr
);
852 *-----------------------------------------------------------------------------
854 * BuildPackageIndex --
856 * Call the "buildpackageindex" Tcl procedure to rebuild a package index.
857 * If the procedure has not been loaded, then load it. It MUST have an
858 * proc record setup by autoload.
861 * o interp (I) - A pointer to the interpreter, error returned in result.
862 * o tlibFilePath (I) - Absolute path name to the library file.
864 * TCL_OK or TCL_ERROR.
865 *-----------------------------------------------------------------------------
868 BuildPackageIndex (interp
, tlibFilePath
)
872 char *cmdPtr
, *initCmd
;
875 * Load buildpackageindex if it is not loaded
877 if (TclFindProc ((Interp
*) interp
, "buildpackageindex") == NULL
) {
879 cmdPtr
= "demand_load buildpackageindex";
881 if (Tcl_Eval (interp
, cmdPtr
, 0, (char **) NULL
) != TCL_OK
)
884 if (!STREQU (interp
->result
, "1")) {
885 Tcl_ResetResult (interp
);
887 "can not find \"buildpackageindex\" on \"TCLPATH\"";
890 Tcl_ResetResult (interp
);
894 * Build the package index.
896 initCmd
= "buildpackageindex ";
898 cmdPtr
= ckalloc (strlen (initCmd
) + strlen (tlibFilePath
) + 1);
899 strcpy (cmdPtr
, initCmd
);
900 strcat (cmdPtr
, tlibFilePath
);
902 if (Tcl_Eval (interp
, cmdPtr
, 0, (char **) NULL
) != TCL_OK
) {
907 Tcl_ResetResult (interp
);
912 *-----------------------------------------------------------------------------
914 * LoadPackageIndex --
916 * Load a package .tndx file. Rebuild .tlib if non-existant or out of
917 * date. An entry is made in the TCLENV array indicating that this file
921 * o interp (I) - A pointer to the interpreter, error returned in result.
922 * o tlibFilePath (I) - Absolute path name to the library file.
923 * o pathLen (I) - Length of tlibFilePath.
924 * o dirLen (I) - The length of the leading directory path in the name.
926 * TCL_OK or TCL_ERROR.
927 *-----------------------------------------------------------------------------
930 LoadPackageIndex (interp
, tlibFilePath
, pathLen
, dirLen
)
936 char *tndxFilePath
, tndxPathBuf
[64], *msg
;
937 struct stat tlibStat
;
938 struct stat tndxStat
;
940 if (pathLen
< sizeof (tndxPathBuf
))
941 tndxFilePath
= tndxPathBuf
;
943 tndxFilePath
= ckalloc (pathLen
+ 1);
944 strcpy (tndxFilePath
, tlibFilePath
);
945 tndxFilePath
[pathLen
- 3] = 'n';
946 tndxFilePath
[pathLen
- 2] = 'd';
947 tndxFilePath
[pathLen
- 1] = 'x';
950 * Get library's modification time. If the file can't be accessed, set
951 * time so the library does not get built. Other code will report the
954 if (stat (tlibFilePath
, &tlibStat
) < 0)
955 tlibStat
.st_mtime
= MAXINT
;
958 * Get the time for the index. If the file does not exists or is
959 * out of date, rebuild it.
962 if ((stat (tndxFilePath
, &tndxStat
) < 0) ||
963 (tndxStat
.st_mtime
< tlibStat
.st_mtime
)) {
964 if (BuildPackageIndex (interp
, tlibFilePath
) != TCL_OK
)
968 if (ProcessIndexFile (interp
, tlibFilePath
, tndxFilePath
) != TCL_OK
)
970 if (tndxFilePath
!= tndxPathBuf
)
971 ckfree (tndxFilePath
);
975 if (tndxFilePath
!= tndxPathBuf
)
976 ckfree (tndxFilePath
);
977 msg
= ckalloc (strlen (tlibFilePath
) + 60);
978 strcpy (msg
, "\n while loading Tcl package library index \"");
979 strcat (msg
, tlibFilePath
);
981 Tcl_AddErrorInfo (interp
, msg
);
987 *-----------------------------------------------------------------------------
991 * Load a standard Tcl index (tclIndex). An entry is made in the TCLENV
992 * array indicating that this file has been loaded.
995 * o interp (I) - A pointer to the interpreter, error returned in result.
996 * o indexFilePath (I) - Absolute path name to the tclIndex file.
997 * o dirLen (I) - The length of the directory component of indexFilePath.
999 * TCL_OK or TCL_ERROR.
1000 *-----------------------------------------------------------------------------
1003 LoadOusterIndex (interp
, indexFilePath
, dirLen
)
1005 char *indexFilePath
;
1010 dynamicBuf_t lineBuffer
;
1011 int lineArgc
, result
, filePathLen
;
1012 char **lineArgv
= NULL
, *filePath
, filePathBuf
[64], *msg
;
1014 indexFilePtr
= fopen (indexFilePath
, "r");
1015 if (indexFilePtr
== NULL
) {
1016 Tcl_AppendResult (interp
, "open failed on: ", indexFilePath
, ": ",
1017 Tcl_UnixError (interp
), (char *) NULL
);
1021 Tcl_DynBufInit (&lineBuffer
);
1024 switch (Tcl_DynamicFgets (&lineBuffer
, indexFilePtr
, FALSE
)) {
1027 case -1: /* Error */
1028 Tcl_AppendResult (interp
, "read filed on: ", indexFilePath
, ": ",
1029 Tcl_UnixError (interp
), (char *) NULL
);
1032 if ((lineBuffer
.ptr
[0] == '\0') || (lineBuffer
.ptr
[0] == '#'))
1035 if (Tcl_SplitList (interp
, lineBuffer
.ptr
, &lineArgc
,
1036 &lineArgv
) != TCL_OK
)
1038 if (! ((lineArgc
== 0) || (lineArgc
== 2)))
1041 if (lineArgc
!= 0) {
1042 filePathLen
= strlen (lineArgv
[1]) + dirLen
+ 1;
1043 if (filePathLen
< sizeof (filePathBuf
))
1044 filePath
= filePathBuf
;
1046 filePath
= ckalloc (filePathLen
+ 1);
1047 strncpy (filePath
, indexFilePath
, dirLen
+ 1);
1048 strcpy (filePath
+ dirLen
+ 1, lineArgv
[1]);
1050 result
= SetTCLENVProcEntry (interp
, lineArgv
[0], "F", filePath
);
1052 if (filePath
!= filePathBuf
)
1054 if (result
!= TCL_OK
)
1062 Tcl_DynBufFree (&lineBuffer
);
1063 fclose (indexFilePtr
);
1065 if (GenerateFileId (interp
, indexFilePath
, fileId
) != TCL_OK
)
1067 if (SetTCLENVFileIdEntry (interp
, fileId
, indexFilePath
) != TCL_OK
)
1073 * Handle format error in library input line. If data is already in the
1074 * result, its assumed to be the error that brought us here.
1077 if (interp
->result
[0] != '\0')
1078 Tcl_AppendResult (interp
, "\n", (char *) NULL
);
1079 Tcl_AppendResult (interp
, "format error in library index \"",
1080 indexFilePath
, "\" (", lineBuffer
.ptr
, ")",
1084 * Error exit here, releasing resources and closing the file.
1087 if (lineArgv
!= NULL
)
1089 Tcl_DynBufFree (&lineBuffer
);
1090 fclose (indexFilePtr
);
1092 msg
= ckalloc (strlen (indexFilePath
) + 45);
1093 strcpy (msg
, "\n while loading Tcl procedure index \"");
1094 strcat (msg
, indexFilePath
);
1096 Tcl_AddErrorInfo (interp
, msg
);
1102 *-----------------------------------------------------------------------------
1106 * Load the indexes for all package library (.tlib) or a Ousterhout
1107 * "tclIndex" file in a directory. Nonexistent or unreadable directories
1111 * o interp (I) - A pointer to the interpreter, error returned in result.
1112 * o dirName (I) - The absolute path name of the directory to search for
1115 * A standard Tcl result.
1116 *-----------------------------------------------------------------------------
1119 LoadDirIndexes (interp
, dirName
)
1124 struct dirent
*entryPtr
;
1125 int dirLen
, nameLen
;
1126 char *filePath
= NULL
;
1127 int filePathSize
= 0;
1129 dirLen
= strlen (dirName
);
1131 dirPtr
= opendir (dirName
);
1133 return TCL_OK
; /* Skip directory */
1136 entryPtr
= readdir (dirPtr
);
1137 if (entryPtr
== NULL
)
1139 nameLen
= strlen (entryPtr
->d_name
);
1141 if ((nameLen
> 5) &&
1142 ((STREQU (entryPtr
->d_name
+ nameLen
- 5, ".tlib")) ||
1143 (STREQU (entryPtr
->d_name
, "tclIndex")))) {
1146 * Expand the filePath buffer if necessary (always allow extra).
1148 if ((nameLen
+ dirLen
+ 2) > filePathSize
) {
1149 if (filePath
!= NULL
)
1151 filePathSize
= nameLen
+ dirLen
+ 2 + 16;
1152 filePath
= ckalloc (filePathSize
);
1153 strcpy (filePath
, dirName
);
1154 filePath
[dirLen
] = '/';
1156 strcpy (filePath
+ dirLen
+ 1, entryPtr
->d_name
);
1159 * Skip index if it has been loaded before or if it can't be
1162 if (CheckTCLENVFileIdEntry (interp
, filePath
) ||
1163 (access (filePath
, R_OK
) < 0))
1166 if (entryPtr
->d_name
[nameLen
- 5] == '.') {
1167 if (LoadPackageIndex (interp
, filePath
, dirLen
+ nameLen
+ 1,
1171 if (LoadOusterIndex (interp
, filePath
, dirLen
) != TCL_OK
)
1177 if (filePath
!= NULL
)
1183 if (filePath
!= NULL
)
1191 *-----------------------------------------------------------------------------
1193 * LoadPackageIndexes --
1195 * Loads the all indexes for all package libraries (.tlib)* or a
1196 * Ousterhout "tclIndex" files found in all directories in the path.
1197 * If an index has already been loaded, it will not be reloaded.
1198 * Non-existent or unreadable directories are skipped.
1201 * A standard Tcl result. Tcl array variable TCLENV is updated to
1202 * indicate the procedures that were defined in the library.
1204 *-----------------------------------------------------------------------------
1207 LoadPackageIndexes (interp
, path
)
1211 char *dirName
, dirNameBuf
[64];
1212 int idx
, dirLen
, pathArgc
, status
;
1215 if (Tcl_SplitList (interp
, path
, &pathArgc
, &pathArgv
) != TCL_OK
)
1218 for (idx
= 0; idx
< pathArgc
; idx
++) {
1220 * Get the absolute dir name. if the conversion fails (most likely
1221 * invalid "~") or thje directory cann't be read, skip it.
1223 dirName
= pathArgv
[idx
];
1224 if (dirName
[0] != '/') {
1225 dirName
= MakeAbsFile (interp
, dirName
, dirNameBuf
,
1226 sizeof (dirNameBuf
));
1227 if (dirName
== NULL
)
1230 if (access (dirName
, X_OK
) == 0)
1231 status
= LoadDirIndexes (interp
, dirName
);
1235 if ((dirName
!= pathArgv
[idx
]) && (dirName
!= dirNameBuf
))
1237 if (status
!= TCL_OK
)
1250 *-----------------------------------------------------------------------------
1254 * Attempt to load a procedure (or command) by checking the TCLENV
1255 * array for its location (either in a file or package library).
1258 * o interp (I) - A pointer to the interpreter, error returned in result.
1259 * o procName (I) - The name of the procedure (or command) to load
1261 * o foundPtr (O) - TRUE is returned if the procedure or command was
1262 * loaded, FALSE if it was not.
1264 * A standard Tcl result.
1266 *-----------------------------------------------------------------------------
1269 LoadProc (interp
, procName
, foundPtr
)
1274 Interp
*iPtr
= (Interp
*) interp
;
1275 char type
, *location
, *filePath
, *cmdPtr
, cmdBuf
[80];
1280 Tcl_HashEntry
*cmdEntryPtr
;
1282 if (GetTCLENVProcEntry (interp
, procName
, &type
, &location
) != TCL_OK
)
1284 if (location
== NULL
) {
1290 * If this is a file entry (type = 'F'), location is a file name or
1291 * absolute file path. If it's an absolute path, just eval it, otherwise
1292 * load the source using the "load" procdure (still in Tcl). If this is a
1293 * package entry, location is a package name. Source part of the package
1294 * library (Must look up the file, offset and length in the package entry
1298 if (location
[0] == '/') {
1299 result
= Tcl_EvalFile (interp
, location
);
1301 cmdLen
= strlen (location
) + 5;
1302 if (cmdLen
< sizeof (cmdBuf
))
1305 cmdPtr
= ckalloc (cmdLen
+ 1);
1306 strcpy (cmdPtr
, "load ");
1307 strcat (cmdPtr
, location
);
1309 result
= Tcl_Eval (interp
, cmdPtr
, 0, NULL
);
1310 if (cmdPtr
!= cmdBuf
)
1314 result
= GetTCLENVPkgEntry (interp
, location
, fileId
, &offset
,
1316 if (result
== TCL_OK
) {
1317 filePath
= GetTCLENVFileIdEntry (interp
, fileId
);
1318 if (filePath
== NULL
)
1322 if (result
== TCL_OK
)
1323 result
= EvalFilePart (interp
, filePath
, offset
, length
);
1330 * If we are ok to this point, make sure that the procedure or command is
1333 if (result
== TCL_OK
) {
1334 cmdEntryPtr
= Tcl_FindHashEntry (&iPtr
->commandTable
, procName
);
1335 *foundPtr
= (cmdEntryPtr
!= NULL
);
1342 *-----------------------------------------------------------------------------
1344 * Tcl_LoadlibindexCmd --
1346 * This procedure is invoked to process the "Loadlibindex" Tcl command:
1348 * loadlibindex libfile
1350 * which loads the index for a package library (.tlib) or a Ousterhout
1354 * A standard Tcl result. Tcl array variable TCLENV is updated to
1355 * indicate the procedures that were defined in the library.
1357 *-----------------------------------------------------------------------------
1360 Tcl_LoadlibindexCmd (dummy
, interp
, argc
, argv
)
1366 char *pathName
, pathNameBuf
[64];
1367 int pathLen
, dirLen
;
1370 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " libFile",
1375 pathName
= argv
[1];
1376 if (pathName
[0] != '/') {
1377 pathName
= MakeAbsFile (interp
, pathName
, pathNameBuf
,
1378 sizeof (pathNameBuf
));
1379 if (pathName
== NULL
)
1384 * Find the length of the directory name. Validate that we have a .tlib
1385 * extension or file name is "tclIndex" and call the routine to process
1386 * the specific type of index.
1388 pathLen
= strlen (pathName
);
1389 for (dirLen
= pathLen
- 1; pathName
[dirLen
] != '/'; dirLen
--)
1392 if ((pathLen
> 5) && (pathName
[pathLen
- 5] == '.')) {
1393 if (!STREQU (pathName
+ pathLen
- 5, ".tlib"))
1395 if (LoadPackageIndex (interp
, pathName
, pathLen
, dirLen
) != TCL_OK
)
1398 if (!STREQU (pathName
+ dirLen
, "/tclIndex"))
1400 if (LoadOusterIndex (interp
, pathName
, dirLen
) != TCL_OK
)
1403 if ((pathName
!= argv
[1]) && (pathName
!= pathNameBuf
))
1408 Tcl_AppendResult (interp
, "invalid library name, must have an extension ",
1409 "of \".tlib\" or the name \"tclIndex\", got \"",
1410 argv
[1], "\"", (char *) NULL
);
1413 if ((pathName
!= argv
[1]) && (pathName
!= pathNameBuf
))
1419 *-----------------------------------------------------------------------------
1421 * Tcl_Demand_loadCmd --
1423 * This procedure is invoked to process the "demand_load" Tcl command:
1427 * which searchs the TCLENV tables for the specified procedure. If it
1428 * is not found, an attempt is made to load unloaded libraries, first
1429 * the variable "TCLPATH" is searched. If the procedure is not defined
1430 * after that, then "auto_path" is searched.
1433 * A standard Tcl result.
1435 *-----------------------------------------------------------------------------
1438 Tcl_Demand_loadCmd (dummy
, interp
, argc
, argv
)
1448 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " procedure",
1453 if (LoadProc (interp
, argv
[1], &found
) != TCL_OK
)
1456 interp
->result
= "1";
1461 * Slow path, load the libraries indices on "TCLPATH".
1463 path
= Tcl_GetVar (interp
, "TCLPATH", TCL_GLOBAL_ONLY
);
1465 if (LoadPackageIndexes (interp
, path
) != TCL_OK
)
1467 if (LoadProc (interp
, argv
[1], &found
) != TCL_OK
)
1470 interp
->result
= "1";
1476 * Final gasp, check the "auto_path"
1478 path
= Tcl_GetVar (interp
, "auto_path", TCL_GLOBAL_ONLY
);
1480 if (LoadPackageIndexes (interp
, path
) != TCL_OK
)
1482 if (LoadProc (interp
, argv
[1], &found
) != TCL_OK
)
1485 interp
->result
= "1";
1491 * Procedure or command was not found.
1493 interp
->result
= "0";
1497 msg
= ckalloc (strlen (argv
[1]) + 35);
1498 strcpy (msg
, "\n while demand loading \"");
1499 strcat (msg
, argv
[1]);
1501 Tcl_AddErrorInfo (interp
, msg
);