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