/[dtapublic]/projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c
ViewVC logotype

Diff of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c revision 64 by dashley, Sun Oct 30 04:21:11 2016 UTC projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclload.c revision 98 by dashley, Sun Dec 18 00:57:31 2016 UTC
# Line 1  Line 1 
1  /*$Header$ */  /* $Header$ */
2  /*  /*
3   * tclLoad.c --   * tclLoad.c --
4   *   *
5   *      This file provides the generic portion (those that are the same   *      This file provides the generic portion (those that are the same
6   *      on all platforms) of Tcl's dynamic loading facilities.   *      on all platforms) of Tcl's dynamic loading facilities.
7   *   *
8   * Copyright (c) 1995-1997 Sun Microsystems, Inc.   * Copyright (c) 1995-1997 Sun Microsystems, Inc.
9   *   *
10   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
11   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12   *   *
13   * RCS: @(#) $Id: tclload.c,v 1.1.1.1 2001/06/13 04:42:55 dtashley Exp $   * RCS: @(#) $Id: tclload.c,v 1.1.1.1 2001/06/13 04:42:55 dtashley Exp $
14   */   */
15    
16  #include "tclInt.h"  #include "tclInt.h"
17    
18  /*  /*
19   * The following structure describes a package that has been loaded   * The following structure describes a package that has been loaded
20   * either dynamically (with the "load" command) or statically (as   * either dynamically (with the "load" command) or statically (as
21   * indicated by a call to TclGetLoadedPackages).  All such packages   * indicated by a call to TclGetLoadedPackages).  All such packages
22   * are linked together into a single list for the process.  Packages   * are linked together into a single list for the process.  Packages
23   * are never unloaded, so these structures are never freed.   * are never unloaded, so these structures are never freed.
24   */   */
25    
26  typedef struct LoadedPackage {  typedef struct LoadedPackage {
27      char *fileName;             /* Name of the file from which the      char *fileName;             /* Name of the file from which the
28                                   * package was loaded.  An empty string                                   * package was loaded.  An empty string
29                                   * means the package is loaded statically.                                   * means the package is loaded statically.
30                                   * Malloc-ed. */                                   * Malloc-ed. */
31      char *packageName;          /* Name of package prefix for the package,      char *packageName;          /* Name of package prefix for the package,
32                                   * properly capitalized (first letter UC,                                   * properly capitalized (first letter UC,
33                                   * others LC), no "_", as in "Net".                                   * others LC), no "_", as in "Net".
34                                   * Malloc-ed. */                                   * Malloc-ed. */
35      ClientData clientData;      /* Token for the loaded file which should be      ClientData clientData;      /* Token for the loaded file which should be
36                                   * passed to TclpUnloadFile() when the file                                   * passed to TclpUnloadFile() when the file
37                                   * is no longer needed.  If fileName is NULL,                                   * is no longer needed.  If fileName is NULL,
38                                   * then this field is irrelevant. */                                   * then this field is irrelevant. */
39      Tcl_PackageInitProc *initProc;      Tcl_PackageInitProc *initProc;
40                                  /* Initialization procedure to call to                                  /* Initialization procedure to call to
41                                   * incorporate this package into a trusted                                   * incorporate this package into a trusted
42                                   * interpreter. */                                   * interpreter. */
43      Tcl_PackageInitProc *safeInitProc;      Tcl_PackageInitProc *safeInitProc;
44                                  /* Initialization procedure to call to                                  /* Initialization procedure to call to
45                                   * incorporate this package into a safe                                   * incorporate this package into a safe
46                                   * interpreter (one that will execute                                   * interpreter (one that will execute
47                                   * untrusted scripts).   NULL means the                                   * untrusted scripts).   NULL means the
48                                   * package can't be used in unsafe                                   * package can't be used in unsafe
49                                   * interpreters. */                                   * interpreters. */
50      struct LoadedPackage *nextPtr;      struct LoadedPackage *nextPtr;
51                                  /* Next in list of all packages loaded into                                  /* Next in list of all packages loaded into
52                                   * this application process.  NULL means                                   * this application process.  NULL means
53                                   * end of list. */                                   * end of list. */
54  } LoadedPackage;  } LoadedPackage;
55    
56  /*  /*
57   * TCL_THREADS   * TCL_THREADS
58   * There is a global list of packages that is anchored at firstPackagePtr.   * There is a global list of packages that is anchored at firstPackagePtr.
59   * Access to this list is governed by a mutex.   * Access to this list is governed by a mutex.
60   */   */
61    
62  static LoadedPackage *firstPackagePtr = NULL;  static LoadedPackage *firstPackagePtr = NULL;
63                                  /* First in list of all packages loaded into                                  /* First in list of all packages loaded into
64                                   * this process. */                                   * this process. */
65    
66  TCL_DECLARE_MUTEX(packageMutex)  TCL_DECLARE_MUTEX(packageMutex)
67    
68  /*  /*
69   * The following structure represents a particular package that has   * The following structure represents a particular package that has
70   * been incorporated into a particular interpreter (by calling its   * been incorporated into a particular interpreter (by calling its
71   * initialization procedure).  There is a list of these structures for   * initialization procedure).  There is a list of these structures for
72   * each interpreter, with an AssocData value (key "load") for the   * each interpreter, with an AssocData value (key "load") for the
73   * interpreter that points to the first package (if any).   * interpreter that points to the first package (if any).
74   */   */
75    
76  typedef struct InterpPackage {  typedef struct InterpPackage {
77      LoadedPackage *pkgPtr;      /* Points to detailed information about      LoadedPackage *pkgPtr;      /* Points to detailed information about
78                                   * package. */                                   * package. */
79      struct InterpPackage *nextPtr;      struct InterpPackage *nextPtr;
80                                  /* Next package in this interpreter, or                                  /* Next package in this interpreter, or
81                                   * NULL for end of list. */                                   * NULL for end of list. */
82  } InterpPackage;  } InterpPackage;
83    
84  /*  /*
85   * Prototypes for procedures that are private to this file:   * Prototypes for procedures that are private to this file:
86   */   */
87    
88  static void             LoadCleanupProc _ANSI_ARGS_((ClientData clientData,  static void             LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
89                              Tcl_Interp *interp));                              Tcl_Interp *interp));
90    
91  /*  /*
92   *----------------------------------------------------------------------   *----------------------------------------------------------------------
93   *   *
94   * Tcl_LoadObjCmd --   * Tcl_LoadObjCmd --
95   *   *
96   *      This procedure is invoked to process the "load" Tcl command.   *      This procedure is invoked to process the "load" Tcl command.
97   *      See the user documentation for details on what it does.   *      See the user documentation for details on what it does.
98   *   *
99   * Results:   * Results:
100   *      A standard Tcl result.   *      A standard Tcl result.
101   *   *
102   * Side effects:   * Side effects:
103   *      See the user documentation.   *      See the user documentation.
104   *   *
105   *----------------------------------------------------------------------   *----------------------------------------------------------------------
106   */   */
107    
108  int  int
109  Tcl_LoadObjCmd(dummy, interp, objc, objv)  Tcl_LoadObjCmd(dummy, interp, objc, objv)
110      ClientData dummy;           /* Not used. */      ClientData dummy;           /* Not used. */
111      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
112      int objc;                   /* Number of arguments. */      int objc;                   /* Number of arguments. */
113      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
114  {  {
115      Tcl_Interp *target;      Tcl_Interp *target;
116      LoadedPackage *pkgPtr, *defaultPtr;      LoadedPackage *pkgPtr, *defaultPtr;
117      Tcl_DString pkgName, tmp, initName, safeInitName, fileName;      Tcl_DString pkgName, tmp, initName, safeInitName, fileName;
118      Tcl_PackageInitProc *initProc, *safeInitProc;      Tcl_PackageInitProc *initProc, *safeInitProc;
119      InterpPackage *ipFirstPtr, *ipPtr;      InterpPackage *ipFirstPtr, *ipPtr;
120      int code, namesMatch, filesMatch;      int code, namesMatch, filesMatch;
121      char *p, *tempString, *fullFileName, *packageName;      char *p, *tempString, *fullFileName, *packageName;
122      ClientData clientData;      ClientData clientData;
123      Tcl_UniChar ch;      Tcl_UniChar ch;
124      int offset;      int offset;
125    
126      if ((objc < 2) || (objc > 4)) {      if ((objc < 2) || (objc > 4)) {
127          Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");          Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
128          return TCL_ERROR;          return TCL_ERROR;
129      }      }
130      tempString = Tcl_GetString(objv[1]);      tempString = Tcl_GetString(objv[1]);
131      fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);      fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);
132      if (fullFileName == NULL) {      if (fullFileName == NULL) {
133          return TCL_ERROR;          return TCL_ERROR;
134      }      }
135      Tcl_DStringInit(&pkgName);      Tcl_DStringInit(&pkgName);
136      Tcl_DStringInit(&initName);      Tcl_DStringInit(&initName);
137      Tcl_DStringInit(&safeInitName);      Tcl_DStringInit(&safeInitName);
138      Tcl_DStringInit(&tmp);      Tcl_DStringInit(&tmp);
139    
140      packageName = NULL;      packageName = NULL;
141      if (objc >= 3) {      if (objc >= 3) {
142          packageName = Tcl_GetString(objv[2]);          packageName = Tcl_GetString(objv[2]);
143          if (packageName[0] == '\0') {          if (packageName[0] == '\0') {
144              packageName = NULL;              packageName = NULL;
145          }          }
146      }      }
147      if ((fullFileName[0] == 0) && (packageName == NULL)) {      if ((fullFileName[0] == 0) && (packageName == NULL)) {
148          Tcl_SetResult(interp,          Tcl_SetResult(interp,
149                  "must specify either file name or package name",                  "must specify either file name or package name",
150                  TCL_STATIC);                  TCL_STATIC);
151          code = TCL_ERROR;          code = TCL_ERROR;
152          goto done;          goto done;
153      }      }
154    
155      /*      /*
156       * Figure out which interpreter we're going to load the package into.       * Figure out which interpreter we're going to load the package into.
157       */       */
158    
159      target = interp;      target = interp;
160      if (objc == 4) {      if (objc == 4) {
161          char *slaveIntName;          char *slaveIntName;
162          slaveIntName = Tcl_GetString(objv[3]);          slaveIntName = Tcl_GetString(objv[3]);
163          target = Tcl_GetSlave(interp, slaveIntName);          target = Tcl_GetSlave(interp, slaveIntName);
164          if (target == NULL) {          if (target == NULL) {
165              return TCL_ERROR;              return TCL_ERROR;
166          }          }
167      }      }
168    
169      /*      /*
170       * Scan through the packages that are currently loaded to see if the       * Scan through the packages that are currently loaded to see if the
171       * package we want is already loaded.  We'll use a loaded package if       * package we want is already loaded.  We'll use a loaded package if
172       * it meets any of the following conditions:       * it meets any of the following conditions:
173       *  - Its name and file match the once we're looking for.       *  - Its name and file match the once we're looking for.
174       *  - Its file matches, and we weren't given a name.       *  - Its file matches, and we weren't given a name.
175       *  - Its name matches, the file name was specified as empty, and there       *  - Its name matches, the file name was specified as empty, and there
176       *    is only no statically loaded package with the same name.       *    is only no statically loaded package with the same name.
177       */       */
178      Tcl_MutexLock(&packageMutex);      Tcl_MutexLock(&packageMutex);
179    
180      defaultPtr = NULL;      defaultPtr = NULL;
181      for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {      for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
182          if (packageName == NULL) {          if (packageName == NULL) {
183              namesMatch = 0;              namesMatch = 0;
184          } else {          } else {
185              Tcl_DStringSetLength(&pkgName, 0);              Tcl_DStringSetLength(&pkgName, 0);
186              Tcl_DStringAppend(&pkgName, packageName, -1);              Tcl_DStringAppend(&pkgName, packageName, -1);
187              Tcl_DStringSetLength(&tmp, 0);              Tcl_DStringSetLength(&tmp, 0);
188              Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);              Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
189              Tcl_UtfToLower(Tcl_DStringValue(&pkgName));              Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
190              Tcl_UtfToLower(Tcl_DStringValue(&tmp));              Tcl_UtfToLower(Tcl_DStringValue(&tmp));
191              if (strcmp(Tcl_DStringValue(&tmp),              if (strcmp(Tcl_DStringValue(&tmp),
192                      Tcl_DStringValue(&pkgName)) == 0) {                      Tcl_DStringValue(&pkgName)) == 0) {
193                  namesMatch = 1;                  namesMatch = 1;
194              } else {              } else {
195                  namesMatch = 0;                  namesMatch = 0;
196              }              }
197          }          }
198          Tcl_DStringSetLength(&pkgName, 0);          Tcl_DStringSetLength(&pkgName, 0);
199    
200          filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);          filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
201          if (filesMatch && (namesMatch || (packageName == NULL))) {          if (filesMatch && (namesMatch || (packageName == NULL))) {
202              break;              break;
203          }          }
204          if (namesMatch && (fullFileName[0] == 0)) {          if (namesMatch && (fullFileName[0] == 0)) {
205              defaultPtr = pkgPtr;              defaultPtr = pkgPtr;
206          }          }
207          if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {          if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
208              /*              /*
209               * Can't have two different packages loaded from the same               * Can't have two different packages loaded from the same
210               * file.               * file.
211               */               */
212    
213              Tcl_AppendResult(interp, "file \"", fullFileName,              Tcl_AppendResult(interp, "file \"", fullFileName,
214                      "\" is already loaded for package \"",                      "\" is already loaded for package \"",
215                      pkgPtr->packageName, "\"", (char *) NULL);                      pkgPtr->packageName, "\"", (char *) NULL);
216              code = TCL_ERROR;              code = TCL_ERROR;
217              Tcl_MutexUnlock(&packageMutex);              Tcl_MutexUnlock(&packageMutex);
218              goto done;              goto done;
219          }          }
220      }      }
221      Tcl_MutexUnlock(&packageMutex);      Tcl_MutexUnlock(&packageMutex);
222      if (pkgPtr == NULL) {      if (pkgPtr == NULL) {
223          pkgPtr = defaultPtr;          pkgPtr = defaultPtr;
224      }      }
225    
226      /*      /*
227       * Scan through the list of packages already loaded in the target       * Scan through the list of packages already loaded in the target
228       * interpreter.  If the package we want is already loaded there,       * interpreter.  If the package we want is already loaded there,
229       * then there's nothing for us to to.       * then there's nothing for us to to.
230       */       */
231    
232      if (pkgPtr != NULL) {      if (pkgPtr != NULL) {
233          ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",          ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
234                  (Tcl_InterpDeleteProc **) NULL);                  (Tcl_InterpDeleteProc **) NULL);
235          for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {          for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
236              if (ipPtr->pkgPtr == pkgPtr) {              if (ipPtr->pkgPtr == pkgPtr) {
237                  code = TCL_OK;                  code = TCL_OK;
238                  goto done;                  goto done;
239              }              }
240          }          }
241      }      }
242    
243      if (pkgPtr == NULL) {      if (pkgPtr == NULL) {
244          /*          /*
245           * The desired file isn't currently loaded, so load it.  It's an           * The desired file isn't currently loaded, so load it.  It's an
246           * error if the desired package is a static one.           * error if the desired package is a static one.
247           */           */
248    
249          if (fullFileName[0] == 0) {          if (fullFileName[0] == 0) {
250              Tcl_AppendResult(interp, "package \"", packageName,              Tcl_AppendResult(interp, "package \"", packageName,
251                      "\" isn't loaded statically", (char *) NULL);                      "\" isn't loaded statically", (char *) NULL);
252              code = TCL_ERROR;              code = TCL_ERROR;
253              goto done;              goto done;
254          }          }
255    
256          /*          /*
257           * Figure out the module name if it wasn't provided explicitly.           * Figure out the module name if it wasn't provided explicitly.
258           */           */
259    
260          if (packageName != NULL) {          if (packageName != NULL) {
261              Tcl_DStringAppend(&pkgName, packageName, -1);              Tcl_DStringAppend(&pkgName, packageName, -1);
262          } else {          } else {
263              int retc;              int retc;
264              /*              /*
265               * Threading note - this call used to be protected by a mutex.               * Threading note - this call used to be protected by a mutex.
266               */               */
267              retc = TclGuessPackageName(fullFileName, &pkgName);              retc = TclGuessPackageName(fullFileName, &pkgName);
268              if (!retc) {              if (!retc) {
269                  int pargc;                  int pargc;
270                  char **pargv, *pkgGuess;                  char **pargv, *pkgGuess;
271    
272                  /*                  /*
273                   * The platform-specific code couldn't figure out the                   * The platform-specific code couldn't figure out the
274                   * module name.  Make a guess by taking the last element                   * module name.  Make a guess by taking the last element
275                   * of the file name, stripping off any leading "lib",                   * of the file name, stripping off any leading "lib",
276                   * and then using all of the alphabetic and underline                   * and then using all of the alphabetic and underline
277                   * characters that follow that.                   * characters that follow that.
278                   */                   */
279    
280                  Tcl_SplitPath(fullFileName, &pargc, &pargv);                  Tcl_SplitPath(fullFileName, &pargc, &pargv);
281                  pkgGuess = pargv[pargc-1];                  pkgGuess = pargv[pargc-1];
282                  if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')                  if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
283                          && (pkgGuess[2] == 'b')) {                          && (pkgGuess[2] == 'b')) {
284                      pkgGuess += 3;                      pkgGuess += 3;
285                  }                  }
286                  for (p = pkgGuess; *p != 0; p += offset) {                  for (p = pkgGuess; *p != 0; p += offset) {
287                      offset = Tcl_UtfToUniChar(p, &ch);                      offset = Tcl_UtfToUniChar(p, &ch);
288                      if ((ch > 0x100)                      if ((ch > 0x100)
289                              || !(isalpha(UCHAR(ch)) /* INTL: ISO only */                              || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
290                                      || (UCHAR(ch) == '_'))) {                                      || (UCHAR(ch) == '_'))) {
291                          break;                          break;
292                      }                      }
293                  }                  }
294                  if (p == pkgGuess) {                  if (p == pkgGuess) {
295                      ckfree((char *)pargv);                      ckfree((char *)pargv);
296                      Tcl_AppendResult(interp,                      Tcl_AppendResult(interp,
297                              "couldn't figure out package name for ",                              "couldn't figure out package name for ",
298                              fullFileName, (char *) NULL);                              fullFileName, (char *) NULL);
299                      code = TCL_ERROR;                      code = TCL_ERROR;
300                      goto done;                      goto done;
301                  }                  }
302                  Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));                  Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
303                  ckfree((char *)pargv);                  ckfree((char *)pargv);
304              }              }
305          }          }
306    
307          /*          /*
308           * Fix the capitalization in the package name so that the first           * Fix the capitalization in the package name so that the first
309           * character is in caps (or title case) but the others are all           * character is in caps (or title case) but the others are all
310           * lower-case.           * lower-case.
311           */           */
312            
313          Tcl_DStringSetLength(&pkgName,          Tcl_DStringSetLength(&pkgName,
314                  Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));                  Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
315    
316          /*          /*
317           * Compute the names of the two initialization procedures,           * Compute the names of the two initialization procedures,
318           * based on the package name.           * based on the package name.
319           */           */
320            
321          Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);          Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
322          Tcl_DStringAppend(&initName, "_Init", 5);          Tcl_DStringAppend(&initName, "_Init", 5);
323          Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);          Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
324          Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);          Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
325    
326          /*          /*
327           * Call platform-specific code to load the package and find the           * Call platform-specific code to load the package and find the
328           * two initialization procedures.           * two initialization procedures.
329           */           */
330    
331          Tcl_MutexLock(&packageMutex);          Tcl_MutexLock(&packageMutex);
332          code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),          code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
333                  Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,                  Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
334                  &clientData);                  &clientData);
335          Tcl_MutexUnlock(&packageMutex);          Tcl_MutexUnlock(&packageMutex);
336          if (code != TCL_OK) {          if (code != TCL_OK) {
337              goto done;              goto done;
338          }          }
339          if (initProc == NULL) {          if (initProc == NULL) {
340              Tcl_AppendResult(interp, "couldn't find procedure ",              Tcl_AppendResult(interp, "couldn't find procedure ",
341                      Tcl_DStringValue(&initName), (char *) NULL);                      Tcl_DStringValue(&initName), (char *) NULL);
342              TclpUnloadFile(clientData);              TclpUnloadFile(clientData);
343              code = TCL_ERROR;              code = TCL_ERROR;
344              goto done;              goto done;
345          }          }
346    
347          /*          /*
348           * Create a new record to describe this package.           * Create a new record to describe this package.
349           */           */
350    
351          pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));          pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
352          pkgPtr->fileName        = (char *) ckalloc((unsigned)          pkgPtr->fileName        = (char *) ckalloc((unsigned)
353                  (strlen(fullFileName) + 1));                  (strlen(fullFileName) + 1));
354          strcpy(pkgPtr->fileName, fullFileName);          strcpy(pkgPtr->fileName, fullFileName);
355          pkgPtr->packageName     = (char *) ckalloc((unsigned)          pkgPtr->packageName     = (char *) ckalloc((unsigned)
356                  (Tcl_DStringLength(&pkgName) + 1));                  (Tcl_DStringLength(&pkgName) + 1));
357          strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));          strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
358          pkgPtr->clientData      = clientData;          pkgPtr->clientData      = clientData;
359          pkgPtr->initProc        = initProc;          pkgPtr->initProc        = initProc;
360          pkgPtr->safeInitProc    = safeInitProc;          pkgPtr->safeInitProc    = safeInitProc;
361          Tcl_MutexLock(&packageMutex);          Tcl_MutexLock(&packageMutex);
362          pkgPtr->nextPtr         = firstPackagePtr;          pkgPtr->nextPtr         = firstPackagePtr;
363          firstPackagePtr         = pkgPtr;          firstPackagePtr         = pkgPtr;
364          Tcl_MutexUnlock(&packageMutex);          Tcl_MutexUnlock(&packageMutex);
365      }      }
366    
367      /*      /*
368       * Invoke the package's initialization procedure (either the       * Invoke the package's initialization procedure (either the
369       * normal one or the safe one, depending on whether or not the       * normal one or the safe one, depending on whether or not the
370       * interpreter is safe).       * interpreter is safe).
371       */       */
372    
373      if (Tcl_IsSafe(target)) {      if (Tcl_IsSafe(target)) {
374          if (pkgPtr->safeInitProc != NULL) {          if (pkgPtr->safeInitProc != NULL) {
375              code = (*pkgPtr->safeInitProc)(target);              code = (*pkgPtr->safeInitProc)(target);
376          } else {          } else {
377              Tcl_AppendResult(interp,              Tcl_AppendResult(interp,
378                      "can't use package in a safe interpreter: ",                      "can't use package in a safe interpreter: ",
379                      "no ", pkgPtr->packageName, "_SafeInit procedure",                      "no ", pkgPtr->packageName, "_SafeInit procedure",
380                      (char *) NULL);                      (char *) NULL);
381              code = TCL_ERROR;              code = TCL_ERROR;
382              goto done;              goto done;
383          }          }
384      } else {      } else {
385          code = (*pkgPtr->initProc)(target);          code = (*pkgPtr->initProc)(target);
386      }      }
387    
388      /*      /*
389       * Record the fact that the package has been loaded in the       * Record the fact that the package has been loaded in the
390       * target interpreter.       * target interpreter.
391       */       */
392    
393      if (code == TCL_OK) {      if (code == TCL_OK) {
394          /*          /*
395           * Refetch ipFirstPtr: loading the package may have introduced           * Refetch ipFirstPtr: loading the package may have introduced
396           * additional static packages at the head of the linked list!           * additional static packages at the head of the linked list!
397           */           */
398    
399          ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",          ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
400                  (Tcl_InterpDeleteProc **) NULL);                  (Tcl_InterpDeleteProc **) NULL);
401          ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));          ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
402          ipPtr->pkgPtr = pkgPtr;          ipPtr->pkgPtr = pkgPtr;
403          ipPtr->nextPtr = ipFirstPtr;          ipPtr->nextPtr = ipFirstPtr;
404          Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,          Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
405                  (ClientData) ipPtr);                  (ClientData) ipPtr);
406      } else {      } else {
407          TclTransferResult(target, code, interp);          TclTransferResult(target, code, interp);
408      }      }
409    
410      done:      done:
411      Tcl_DStringFree(&pkgName);      Tcl_DStringFree(&pkgName);
412      Tcl_DStringFree(&initName);      Tcl_DStringFree(&initName);
413      Tcl_DStringFree(&safeInitName);      Tcl_DStringFree(&safeInitName);
414      Tcl_DStringFree(&fileName);      Tcl_DStringFree(&fileName);
415      Tcl_DStringFree(&tmp);      Tcl_DStringFree(&tmp);
416      return code;      return code;
417  }  }
418    
419  /*  /*
420   *----------------------------------------------------------------------   *----------------------------------------------------------------------
421   *   *
422   * Tcl_StaticPackage --   * Tcl_StaticPackage --
423   *   *
424   *      This procedure is invoked to indicate that a particular   *      This procedure is invoked to indicate that a particular
425   *      package has been linked statically with an application.   *      package has been linked statically with an application.
426   *   *
427   * Results:   * Results:
428   *      None.   *      None.
429   *   *
430   * Side effects:   * Side effects:
431   *      Once this procedure completes, the package becomes loadable   *      Once this procedure completes, the package becomes loadable
432   *      via the "load" command with an empty file name.   *      via the "load" command with an empty file name.
433   *   *
434   *----------------------------------------------------------------------   *----------------------------------------------------------------------
435   */   */
436    
437  void  void
438  Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)  Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
439      Tcl_Interp *interp;                 /* If not NULL, it means that the      Tcl_Interp *interp;                 /* If not NULL, it means that the
440                                           * package has already been loaded                                           * package has already been loaded
441                                           * into the given interpreter by                                           * into the given interpreter by
442                                           * calling the appropriate init proc. */                                           * calling the appropriate init proc. */
443      char *pkgName;                      /* Name of package (must be properly      char *pkgName;                      /* Name of package (must be properly
444                                           * capitalized: first letter upper                                           * capitalized: first letter upper
445                                           * case, others lower case). */                                           * case, others lower case). */
446      Tcl_PackageInitProc *initProc;      /* Procedure to call to incorporate      Tcl_PackageInitProc *initProc;      /* Procedure to call to incorporate
447                                           * this package into a trusted                                           * this package into a trusted
448                                           * interpreter. */                                           * interpreter. */
449      Tcl_PackageInitProc *safeInitProc;  /* Procedure to call to incorporate      Tcl_PackageInitProc *safeInitProc;  /* Procedure to call to incorporate
450                                           * this package into a safe interpreter                                           * this package into a safe interpreter
451                                           * (one that will execute untrusted                                           * (one that will execute untrusted
452                                           * scripts).   NULL means the package                                           * scripts).   NULL means the package
453                                           * can't be used in safe                                           * can't be used in safe
454                                           * interpreters. */                                           * interpreters. */
455  {  {
456      LoadedPackage *pkgPtr;      LoadedPackage *pkgPtr;
457      InterpPackage *ipPtr, *ipFirstPtr;      InterpPackage *ipPtr, *ipFirstPtr;
458    
459      /*      /*
460       * Check to see if someone else has already reported this package as       * Check to see if someone else has already reported this package as
461       * statically loaded.  If this call is redundant then just return.       * statically loaded.  If this call is redundant then just return.
462       */       */
463    
464      Tcl_MutexLock(&packageMutex);      Tcl_MutexLock(&packageMutex);
465      for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {      for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
466          if ((pkgPtr->initProc == initProc)          if ((pkgPtr->initProc == initProc)
467                  && (pkgPtr->safeInitProc == safeInitProc)                  && (pkgPtr->safeInitProc == safeInitProc)
468                  && (strcmp(pkgPtr->packageName, pkgName) == 0)) {                  && (strcmp(pkgPtr->packageName, pkgName) == 0)) {
469              Tcl_MutexUnlock(&packageMutex);              Tcl_MutexUnlock(&packageMutex);
470              return;              return;
471          }          }
472      }      }
473    
474      Tcl_MutexUnlock(&packageMutex);      Tcl_MutexUnlock(&packageMutex);
475    
476      pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));      pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
477      pkgPtr->fileName            = (char *) ckalloc((unsigned) 1);      pkgPtr->fileName            = (char *) ckalloc((unsigned) 1);
478      pkgPtr->fileName[0]         = 0;      pkgPtr->fileName[0]         = 0;
479      pkgPtr->packageName         = (char *) ckalloc((unsigned)      pkgPtr->packageName         = (char *) ckalloc((unsigned)
480              (strlen(pkgName) + 1));              (strlen(pkgName) + 1));
481      strcpy(pkgPtr->packageName, pkgName);      strcpy(pkgPtr->packageName, pkgName);
482      pkgPtr->clientData          = NULL;      pkgPtr->clientData          = NULL;
483      pkgPtr->initProc            = initProc;      pkgPtr->initProc            = initProc;
484      pkgPtr->safeInitProc        = safeInitProc;      pkgPtr->safeInitProc        = safeInitProc;
485      Tcl_MutexLock(&packageMutex);      Tcl_MutexLock(&packageMutex);
486      pkgPtr->nextPtr             = firstPackagePtr;      pkgPtr->nextPtr             = firstPackagePtr;
487      firstPackagePtr             = pkgPtr;      firstPackagePtr             = pkgPtr;
488      Tcl_MutexUnlock(&packageMutex);      Tcl_MutexUnlock(&packageMutex);
489    
490      if (interp != NULL) {      if (interp != NULL) {
491          ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",          ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
492                  (Tcl_InterpDeleteProc **) NULL);                  (Tcl_InterpDeleteProc **) NULL);
493          ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));          ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
494          ipPtr->pkgPtr = pkgPtr;          ipPtr->pkgPtr = pkgPtr;
495          ipPtr->nextPtr = ipFirstPtr;          ipPtr->nextPtr = ipFirstPtr;
496          Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,          Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc,
497                  (ClientData) ipPtr);                  (ClientData) ipPtr);
498      }      }
499  }  }
500    
501  /*  /*
502   *----------------------------------------------------------------------   *----------------------------------------------------------------------
503   *   *
504   * TclGetLoadedPackages --   * TclGetLoadedPackages --
505   *   *
506   *      This procedure returns information about all of the files   *      This procedure returns information about all of the files
507   *      that are loaded (either in a particular intepreter, or   *      that are loaded (either in a particular intepreter, or
508   *      for all interpreters).   *      for all interpreters).
509   *   *
510   * Results:   * Results:
511   *      The return value is a standard Tcl completion code.  If   *      The return value is a standard Tcl completion code.  If
512   *      successful, a list of lists is placed in the interp's result.   *      successful, a list of lists is placed in the interp's result.
513   *      Each sublist corresponds to one loaded file;  its first   *      Each sublist corresponds to one loaded file;  its first
514   *      element is the name of the file (or an empty string for   *      element is the name of the file (or an empty string for
515   *      something that's statically loaded) and the second element   *      something that's statically loaded) and the second element
516   *      is the name of the package in that file.   *      is the name of the package in that file.
517   *   *
518   * Side effects:   * Side effects:
519   *      None.   *      None.
520   *   *
521   *----------------------------------------------------------------------   *----------------------------------------------------------------------
522   */   */
523    
524  int  int
525  TclGetLoadedPackages(interp, targetName)  TclGetLoadedPackages(interp, targetName)
526      Tcl_Interp *interp;         /* Interpreter in which to return      Tcl_Interp *interp;         /* Interpreter in which to return
527                                   * information or error message. */                                   * information or error message. */
528      char *targetName;           /* Name of target interpreter or NULL.      char *targetName;           /* Name of target interpreter or NULL.
529                                   * If NULL, return info about all interps;                                   * If NULL, return info about all interps;
530                                   * otherwise, just return info about this                                   * otherwise, just return info about this
531                                   * interpreter. */                                   * interpreter. */
532  {  {
533      Tcl_Interp *target;      Tcl_Interp *target;
534      LoadedPackage *pkgPtr;      LoadedPackage *pkgPtr;
535      InterpPackage *ipPtr;      InterpPackage *ipPtr;
536      char *prefix;      char *prefix;
537    
538      if (targetName == NULL) {      if (targetName == NULL) {
539          /*          /*
540           * Return information about all of the available packages.           * Return information about all of the available packages.
541           */           */
542    
543          prefix = "{";          prefix = "{";
544          Tcl_MutexLock(&packageMutex);          Tcl_MutexLock(&packageMutex);
545          for (pkgPtr = firstPackagePtr; pkgPtr != NULL;          for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
546                  pkgPtr = pkgPtr->nextPtr) {                  pkgPtr = pkgPtr->nextPtr) {
547              Tcl_AppendResult(interp, prefix, (char *) NULL);              Tcl_AppendResult(interp, prefix, (char *) NULL);
548              Tcl_AppendElement(interp, pkgPtr->fileName);              Tcl_AppendElement(interp, pkgPtr->fileName);
549              Tcl_AppendElement(interp, pkgPtr->packageName);              Tcl_AppendElement(interp, pkgPtr->packageName);
550              Tcl_AppendResult(interp, "}", (char *) NULL);              Tcl_AppendResult(interp, "}", (char *) NULL);
551              prefix = " {";              prefix = " {";
552          }          }
553          Tcl_MutexUnlock(&packageMutex);          Tcl_MutexUnlock(&packageMutex);
554          return TCL_OK;          return TCL_OK;
555      }      }
556    
557      /*      /*
558       * Return information about only the packages that are loaded in       * Return information about only the packages that are loaded in
559       * a given interpreter.       * a given interpreter.
560       */       */
561    
562      target = Tcl_GetSlave(interp, targetName);      target = Tcl_GetSlave(interp, targetName);
563      if (target == NULL) {      if (target == NULL) {
564          return TCL_ERROR;          return TCL_ERROR;
565      }      }
566      ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",      ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
567              (Tcl_InterpDeleteProc **) NULL);              (Tcl_InterpDeleteProc **) NULL);
568      prefix = "{";      prefix = "{";
569      for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {      for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
570          pkgPtr = ipPtr->pkgPtr;          pkgPtr = ipPtr->pkgPtr;
571          Tcl_AppendResult(interp, prefix, (char *) NULL);          Tcl_AppendResult(interp, prefix, (char *) NULL);
572          Tcl_AppendElement(interp, pkgPtr->fileName);          Tcl_AppendElement(interp, pkgPtr->fileName);
573          Tcl_AppendElement(interp, pkgPtr->packageName);          Tcl_AppendElement(interp, pkgPtr->packageName);
574          Tcl_AppendResult(interp, "}", (char *) NULL);          Tcl_AppendResult(interp, "}", (char *) NULL);
575          prefix = " {";          prefix = " {";
576      }      }
577      return TCL_OK;      return TCL_OK;
578  }  }
579    
580  /*  /*
581   *----------------------------------------------------------------------   *----------------------------------------------------------------------
582   *   *
583   * LoadCleanupProc --   * LoadCleanupProc --
584   *   *
585   *      This procedure is called to delete all of the InterpPackage   *      This procedure is called to delete all of the InterpPackage
586   *      structures for an interpreter when the interpreter is deleted.   *      structures for an interpreter when the interpreter is deleted.
587   *      It gets invoked via the Tcl AssocData mechanism.   *      It gets invoked via the Tcl AssocData mechanism.
588   *   *
589   * Results:   * Results:
590   *      None.   *      None.
591   *   *
592   * Side effects:   * Side effects:
593   *      Storage for all of the InterpPackage procedures for interp   *      Storage for all of the InterpPackage procedures for interp
594   *      get deleted.   *      get deleted.
595   *   *
596   *----------------------------------------------------------------------   *----------------------------------------------------------------------
597   */   */
598    
599  static void  static void
600  LoadCleanupProc(clientData, interp)  LoadCleanupProc(clientData, interp)
601      ClientData clientData;      /* Pointer to first InterpPackage structure      ClientData clientData;      /* Pointer to first InterpPackage structure
602                                   * for interp. */                                   * for interp. */
603      Tcl_Interp *interp;         /* Interpreter that is being deleted. */      Tcl_Interp *interp;         /* Interpreter that is being deleted. */
604  {  {
605      InterpPackage *ipPtr, *nextPtr;      InterpPackage *ipPtr, *nextPtr;
606    
607      ipPtr = (InterpPackage *) clientData;      ipPtr = (InterpPackage *) clientData;
608      while (ipPtr != NULL) {      while (ipPtr != NULL) {
609          nextPtr = ipPtr->nextPtr;          nextPtr = ipPtr->nextPtr;
610          ckfree((char *) ipPtr);          ckfree((char *) ipPtr);
611          ipPtr = nextPtr;          ipPtr = nextPtr;
612      }      }
613  }  }
614    
615  /*  /*
616   *----------------------------------------------------------------------   *----------------------------------------------------------------------
617   *   *
618   * TclFinalizeLoad --   * TclFinalizeLoad --
619   *   *
620   *      This procedure is invoked just before the application exits.   *      This procedure is invoked just before the application exits.
621   *      It frees all of the LoadedPackage structures.   *      It frees all of the LoadedPackage structures.
622   *   *
623   * Results:   * Results:
624   *      None.   *      None.
625   *   *
626   * Side effects:   * Side effects:
627   *      Memory is freed.   *      Memory is freed.
628   *   *
629   *----------------------------------------------------------------------   *----------------------------------------------------------------------
630   */   */
631    
632  void  void
633  TclFinalizeLoad()  TclFinalizeLoad()
634  {  {
635      LoadedPackage *pkgPtr;      LoadedPackage *pkgPtr;
636    
637      /*      /*
638       * No synchronization here because there should just be       * No synchronization here because there should just be
639       * one thread alive at this point.  Logically,       * one thread alive at this point.  Logically,
640       * packageMutex should be grabbed at this point, but       * packageMutex should be grabbed at this point, but
641       * the Mutexes get finalized before the call to this routine.       * the Mutexes get finalized before the call to this routine.
642       * The only subsystem left alive at this point is the       * The only subsystem left alive at this point is the
643       * memory allocator.       * memory allocator.
644       */       */
645    
646      while (firstPackagePtr != NULL) {      while (firstPackagePtr != NULL) {
647          pkgPtr = firstPackagePtr;          pkgPtr = firstPackagePtr;
648          firstPackagePtr = pkgPtr->nextPtr;          firstPackagePtr = pkgPtr->nextPtr;
649  #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)  #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
650          /*          /*
651           * Some Unix dlls are poorly behaved - registering things like           * Some Unix dlls are poorly behaved - registering things like
652           * atexit calls that can't be unregistered.  If you unload           * atexit calls that can't be unregistered.  If you unload
653           * such dlls, you get a core on exit because it wants to           * such dlls, you get a core on exit because it wants to
654           * call a function in the dll after it's been unloaded.           * call a function in the dll after it's been unloaded.
655           */           */
656          if (pkgPtr->fileName[0] != '\0') {          if (pkgPtr->fileName[0] != '\0') {
657              TclpUnloadFile(pkgPtr->clientData);              TclpUnloadFile(pkgPtr->clientData);
658          }          }
659  #endif  #endif
660          ckfree(pkgPtr->fileName);          ckfree(pkgPtr->fileName);
661          ckfree(pkgPtr->packageName);          ckfree(pkgPtr->packageName);
662          ckfree((char *) pkgPtr);          ckfree((char *) pkgPtr);
663      }      }
664  }  }
665    
666  /* End of tclload.c */  /* End of tclload.c */

Legend:
Removed from v.64  
changed lines
  Added in v.98

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25