diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | doc/load.n | 9 | ||||
| -rw-r--r-- | doc/unload.n | 151 | ||||
| -rw-r--r-- | generic/tcl.h | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 | ||||
| -rw-r--r-- | generic/tclLoad.c | 505 | ||||
| -rw-r--r-- | tests/unload.test | 223 | ||||
| -rw-r--r-- | unix/Makefile.in | 5 | ||||
| -rw-r--r-- | unix/dltest/Makefile.in | 8 | ||||
| -rw-r--r-- | unix/dltest/README | 6 | ||||
| -rw-r--r-- | unix/dltest/pkgua.c | 336 |
12 files changed, 1242 insertions, 27 deletions
@@ -1,3 +1,12 @@ +2004-02-24 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + IMPLEMENTATION OF TIP#100 FROM GEORGIOS PETASIS + * generic/tclLoad.c (Tcl_UnloadObjCmd): Implementation. + * tests/unload.test: Test suite. + * unix/dltest/pkgua.c: Helper for test suite. + * doc/unload.n: Documentation. + Also assorted changes (mostly small) to several other files. + 2004-02-23 Donal K. Fellows <donal.k.fellows@man.ac.uk> * generic/regc_locale.c (cclass): Buffer was having its size reset @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: load.n,v 1.7 2002/07/01 18:24:39 jenglish Exp $ +'\" RCS: @(#) $Id: load.n,v 1.8 2004/02/24 22:58:45 dkf Exp $ '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" @@ -73,7 +73,12 @@ in an application. If a given \fIfileName\fR is loaded into multiple interpreters, then the first \fBload\fR will load the code and call the initialization procedure; subsequent \fBload\fRs will call the initialization procedure without loading the code again. -It is not possible to unload or reload a package. +.VS 8.5 +For Tcl versions lower than 8.5, it is not possible to unload or reload a +package. From version 8.5 however, the \fBunload\fR command allows the unloading +of libraries loaded with \fBload\fR, for libraries that are aware of the +Tcl's unloading mechanism. +.VE 8.5 .PP The \fBload\fR command also supports packages that are statically linked with the application, if those packages have been registered diff --git a/doc/unload.n b/doc/unload.n new file mode 100644 index 0000000..4fc41dd --- /dev/null +++ b/doc/unload.n @@ -0,0 +1,151 @@ +'\" +'\" Copyright (c) 2003 George Petasis, petasis@iit.demokritos.gr. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: unload.n,v 1.1 2004/02/24 22:58:45 dkf Exp $ +'\" +.so man.macros +.TH unload n 8.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +unload \- Unload machine code. +.SH SYNOPSIS +\fBunload \fR?\fIswitches\fR? \fIfileName\fR +.br +\fBunload \fR?\fIswitches\fR? \fIfileName packageName\fR +.br +\fBunload \fR?\fIswitches\fR? \fIfileName packageName interp\fR +.BE + +.SH DESCRIPTION +.PP +This command tries to unload shared libraries previously loaded +with \fBload\fR from the application's address space. \fIfileName\fR +is the name of the file containing the library file to be unload; it +must be the same as the filename provided to \fBload\fR for +loading the library. +\fIpackageName\fR is the name of the package, and is used to +compute the name of the unload procedure. +\fIinterp\fR is the path name of the interpreter from which to unload +the package (see the \fBinterp\fR manual entry for details); +if \fIinterp\fR is omitted, it defaults to the +interpreter in which the \fBunload\fR command was invoked. +.LP +If the initial arguments to \fBunload\fR start with \fB\-\fR then +they are treated as switches. The following switches are +currently supported: +.TP +\fB\-nocomplain\fR +Supresses all error messages. If this switch is given \fBunload\fR will +never report an error. +.TP +\fB\-keeplibrary\fR +This switch will prevent \fBunload\fR from issuing the operating system call +that will unload the library from the process. +.TP +\fB\-\|\-\fR +Marks the end of switches. The argument following this one will +be treated as a \fIfileName\fR even if it starts with a \fB\-\fR. +.PP +When a file containing a shared library is loaded through the +\fBload\fR command, Tcl associates two reference counts to the library +file. The first counter shows how many times the library has been +loaded into normal (trusted) interpreters while the second describes how many +times the library has been loaded into safe interpreters. As a file containing +a shared library can be loaded only once by Tcl (with the first \fBload\fR +call on the file), these counters track how many interpreters use the library. +Each subsequent call to \fBload\fR after the first, simply increaments the +proper reference count. +.PP +\fBunload\fR works in the opposite direction. As a first step, \fBunload\fR +will check whether the library is unloadable: an unloadable library exports +a special unload procedure. The name of the unload procedure is determined by +\fIpackageName\fR and whether or not the target interpreter +is a safe one. For normal interpreters the name of the initialization +procedure will have the form \fIpkg\fB_Unload\fR, where \fIpkg\fR +is the same as \fIpackageName\fR except that the first letter is +converted to upper case and all other letters +are converted to lower case. For example, if \fIpackageName\fR is +\fBfoo\fR or \fBFOo\fR, the initialization procedure's name will +be \fBFoo_Unload\fR. +If the target interpreter is a safe interpreter, then the name +of the initialization procedure will be \fIpkg\fB_SafeUnload\fR +instead of \fIpkg\fB_Unload\fR. +.PP +If \fBunload\fR determines that a library is not unloadable (or unload +functionality has been disabled during compilation), an error will be returned. +If the library is unloadable, then \fBunload\fR will call the unload +procedure. If the unload procedure returns TCL_OK, \fBunload\fR will proceed +and decrease the proper reference count (depending on the target interpreter +type). When both reference counts have reached 0, the library will be +detached from the process. +.PP +The unload procedure must match the following prototype: +.CS +typedef int Tcl_PackageUnloadProc(Tcl_Interp *\fIinterp\fR, int \fIflags\fR); +.CE +The \fIinterp\fR argument identifies the interpreter from which the +library is to be unloaded. The unload procedure must return +\fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed +successfully; in the event of an error it should set the interpreter's result +to point to an error message. In this case, the result of the +\fBunload\fR command will be the result returned by the unload procedure. +.CE +The \fIflags\fR argument can be either \fBTCL_UNLOAD_DETACH_FROM_INTERPRETER\fR +or \fBTCL_UNLOAD_DETACH_FROM_PROCESS\fR. In case the library will remain +attached to the process after the unload procedure returns (i.e. because +the library is used by other interpreters), +\fBTCL_UNLOAD_DETACH_FROM_INTERPRETER\fR will be defined. However, if the +library is used only by the target interpreter and the library will be +detached from the application as soon as the unload procedure returns, +the \fIflags\fR argument will be set to \fBTCL_UNLOAD_DETACH_FROM_PROCESS\fR. +.PP +The \fBunload\fR command cannot unload libraries that are statically +linked with the application. +If \fIfileName\fR is an empty string, then \fIpackageName\fR must +be specified. +.PP +If \fIpackageName\fR is omitted or specified as an empty string, +Tcl tries to guess the name of the package. +This may be done differently on different platforms. +The default guess, which is used on most UNIX platforms, is to +take the last element of \fIfileName\fR, strip off the first +three characters if they are \fBlib\fR, and use any following +.VS +alphabetic and underline characters as the module name. +.VE +For example, the command \fBunload libxyz4.2.so\fR uses the module +name \fBxyz\fR and the command \fBunload bin/last.so {}\fR uses the +module name \fBlast\fR. + +.SH "PORTABILITY ISSUES" +.TP +\fBUnix\fR\0\0\0\0\0 +. +Not all unix operating systems support library unloading. Under such +an operating system \fBunload\fR returns an error (unless -nocomplain has +been specified). +.TP +\fBMacintosh\fR\0\0\0\0\0 +. +<Somebody to comment on this?> + +.SH BUGS +.PP +If the same file is \fBload\fRed by different \fIfileName\fRs, it will +be loaded into the process's address space multiple times. The +behavior of this varies from system to system (some systems may +detect the redundant loads, others may not). In case a library has been +silently detached by the operating system (and as a result Tcl thinks the +library is still loaded), it may be dangerous to use +\fBunload\fR on such a library (as the library will be completely detached +from the application while some interpreters will continue to use it). + +.SH "SEE ALSO" +info sharedlibextension, load, safe(n) + +.SH KEYWORDS +binary code, unloading, safe interpreter, shared library diff --git a/generic/tcl.h b/generic/tcl.h index 83ad1bd..e53fcf0 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.170 2004/01/09 20:55:26 davygrvy Exp $ + * RCS: @(#) $Id: tcl.h,v 1.171 2004/02/24 22:58:45 dkf Exp $ */ #ifndef _TCL @@ -697,6 +697,8 @@ typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp, + int flags)); typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format)); typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, Tcl_Channel chan, char *address, int port)); @@ -1627,6 +1629,11 @@ typedef struct Tcl_GlobTypeData { #define TCL_GLOB_PERM_W (1<<3) #define TCL_GLOB_PERM_X (1<<4) +/* + * Flags for the unload callback procedure + */ +#define TCL_UNLOAD_DETACH_FROM_INTERPRETER (1<<0) +#define TCL_UNLOAD_DETACH_FROM_PROCESS (1<<1) /* * Typedefs for the various filesystem operations: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2334d53..7c5e460 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.96 2004/01/18 16:19:04 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.97 2004/02/24 22:58:46 dkf Exp $ */ #include "tclInt.h" @@ -166,6 +166,8 @@ static CmdInfo builtInCmds[] = { TclCompileSwitchCmd, 1}, {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, (CompileProc *) NULL, 1}, + {"unload", (Tcl_CmdProc *) NULL, Tcl_UnloadObjCmd, + (CompileProc *) NULL, 1}, {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, (CompileProc *) NULL, 1}, {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd, diff --git a/generic/tclInt.h b/generic/tclInt.h index 6825d08..27dbc89 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.143 2004/01/21 19:59:33 vincentdarley Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.144 2004/02/24 22:58:46 dkf Exp $ */ #ifndef _TCLINT @@ -2005,6 +2005,8 @@ EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_UnloadObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData, diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 2227e6e..5be526c 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoad.c,v 1.10 2004/02/21 12:48:50 dkf Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.11 2004/02/24 22:58:48 dkf Exp $ */ #include "tclInt.h" @@ -47,6 +47,18 @@ typedef struct LoadedPackage { * untrusted scripts). NULL means the * package can't be used in unsafe * interpreters. */ + Tcl_PackageUnloadProc *unloadProc; + /* Finalisation procedure to unload a package + * from a trusted interpreter. NULL means + * that the package cannot be unloaded. */ + Tcl_PackageUnloadProc *safeUnloadProc; + /* Finalisation procedure to unload a package + * from a safe interpreter. NULL means + * that the package cannot be unloaded. */ + int interpRefCount; /* How many times the package has been loaded + in trusted interpreters. */ + int safeInterpRefCount; /* How many times the package has been loaded + in safe interpreters. */ Tcl_FSUnloadFileProc *unLoadProcPtr; /* Procedure to use to unload this package. * If NULL, then we do not attempt to unload @@ -119,10 +131,14 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName; - Tcl_PackageInitProc *initProc, *safeInitProc; + Tcl_DString pkgName, tmp, initName, safeInitName, + unloadName, safeUnloadName; + Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch; + CONST char *symbols[4]; + Tcl_PackageInitProc **procPtrs[4]; + ClientData clientData; char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; @@ -141,6 +157,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); + Tcl_DStringInit(&unloadName); + Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); packageName = NULL; @@ -332,21 +350,33 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DStringAppend(&initName, "_Init", 5); Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); + Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&unloadName, "_Unload", 7); + Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); /* * Call platform-specific code to load the package and find the * two initialization procedures. */ + symbols[0] = Tcl_DStringValue(&initName); + symbols[1] = Tcl_DStringValue(&safeInitName); + symbols[2] = Tcl_DStringValue(&unloadName); + symbols[3] = Tcl_DStringValue(&safeUnloadName); + procPtrs[0] = &initProc; + procPtrs[1] = &safeInitProc; + procPtrs[2] = &unloadProc; + procPtrs[3] = &safeUnloadProc; Tcl_MutexLock(&packageMutex); - code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName), - Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, - &loadHandle,&unLoadProcPtr); + code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, + &loadHandle, &clientData, &unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); + loadHandle = (Tcl_LoadHandle) clientData; if (code != TCL_OK) { goto done; } - if (initProc == NULL) { + if (procPtrs[0] /* initProc */ == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); if (unLoadProcPtr != NULL) { @@ -361,19 +391,23 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *) ckalloc((unsigned) + pkgPtr->fileName = (char *) ckalloc((unsigned) (strlen(fullFileName) + 1)); strcpy(pkgPtr->fileName, fullFileName); - pkgPtr->packageName = (char *) ckalloc((unsigned) + pkgPtr->packageName = (char *) ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); - pkgPtr->loadHandle = loadHandle; - pkgPtr->unLoadProcPtr = unLoadProcPtr; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; + pkgPtr->loadHandle = loadHandle; + pkgPtr->unLoadProcPtr = unLoadProcPtr; + pkgPtr->initProc = *procPtrs[0]; + pkgPtr->safeInitProc = *procPtrs[1]; + pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; + pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; + pkgPtr->interpRefCount = 0; + pkgPtr->safeInterpRefCount = 0; Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); } @@ -404,6 +438,16 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ if (code == TCL_OK) { + /* + * Update the proper reference count. + */ + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + ++pkgPtr->safeInterpRefCount; + } else { + ++pkgPtr->interpRefCount; + } + Tcl_MutexUnlock(&packageMutex); /* * Refetch ipFirstPtr: loading the package may have introduced * additional static packages at the head of the linked list! @@ -424,6 +468,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); + Tcl_DStringFree(&unloadName); + Tcl_DStringFree(&safeUnloadName); Tcl_DStringFree(&tmp); return code; } @@ -431,6 +477,435 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * Tcl_UnloadObjCmd -- + * + * This procedure is invoked to process the "unload" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnloadObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Interp *target; /* Which interpreter to unload from. */ + LoadedPackage *pkgPtr; + LoadedPackage *defaultPtr; + Tcl_DString pkgName; + Tcl_DString tmp; + Tcl_PackageUnloadProc *unloadProc; + InterpPackage *ipFirstPtr; + InterpPackage *ipPtr; + int i; + int index; + int code; + int complain = 1; + int keepLibrary = 0; + int trustedRefCount = -1; + int safeRefCount = -1; + char *fullFileName = ""; + char *packageName; + static CONST char *options[] = { + "-nocomplain", "-keeplibrary", "--", NULL + }; + enum options { + UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST + }; + + for (i = 1; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { + fullFileName = Tcl_GetString(objv[i]); + if (fullFileName[0] == '-') { + /* + * It looks like the command contains an option so signal + * an error + */ + + return TCL_ERROR; + } else { + /* + * This clearly isn't an option; assume it's the + * filename. We must clear the error. + */ + + Tcl_ResetResult(interp); + break; + } + } + switch (index) { + case UNLOAD_NOCOMPLAIN: /* -nocomplain */ + complain = 0; + break; + case UNLOAD_KEEPLIB: /* -keeplibrary */ + keepLibrary = 1; + break; + case UNLOAD_LAST: /* -- */ + i++; + goto endOfForLoop; + } + } + endOfForLoop: + if ((objc-i < 1) || (objc-i > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? fileName ?packageName? ?interp?"); + return TCL_ERROR; + } + if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { + return TCL_ERROR; + } + + fullFileName = Tcl_GetString(objv[i]); + Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&tmp); + + packageName = NULL; + if (objc - i >= 2) { + packageName = Tcl_GetString(objv[i+1]); + if (packageName[0] == '\0') { + packageName = NULL; + } + } + if ((fullFileName[0] == 0) && (packageName == NULL)) { + Tcl_SetResult(interp, + "must specify either file name or package name", + TCL_STATIC); + code = TCL_ERROR; + goto done; + } + + /* + * Figure out which interpreter we're going to load the package into. + */ + + target = interp; + if (objc - i == 3) { + char *slaveIntName; + slaveIntName = Tcl_GetString(objv[i+2]); + target = Tcl_GetSlave(interp, slaveIntName); + if (target == NULL) { + return TCL_ERROR; + } + } + + /* + * Scan through the packages that are currently loaded to see if the + * package we want is already loaded. We'll use a loaded package if + * it meets any of the following conditions: + * - Its name and file match the once we're looking for. + * - Its file matches, and we weren't given a name. + * - Its name matches, the file name was specified as empty, and there + * is only no statically loaded package with the same name. + */ + + Tcl_MutexLock(&packageMutex); + + defaultPtr = NULL; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + int namesMatch, filesMatch; + + if (packageName == NULL) { + namesMatch = 0; + } else { + Tcl_DStringSetLength(&pkgName, 0); + Tcl_DStringAppend(&pkgName, packageName, -1); + Tcl_DStringSetLength(&tmp, 0); + Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_UtfToLower(Tcl_DStringValue(&tmp)); + if (strcmp(Tcl_DStringValue(&tmp), + Tcl_DStringValue(&pkgName)) == 0) { + namesMatch = 1; + } else { + namesMatch = 0; + } + } + Tcl_DStringSetLength(&pkgName, 0); + + filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (packageName == NULL))) { + break; + } + if (namesMatch && (fullFileName[0] == 0)) { + defaultPtr = pkgPtr; + } + if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { + break; + } + } + Tcl_MutexUnlock(&packageMutex); + if (fullFileName[0] == 0) { + /* + * It's an error to try unload a static package. + */ + + Tcl_AppendResult(interp, "package \"", packageName, + "\" is loaded statically and cannot be unloaded", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + if (pkgPtr == NULL) { + /* + * The DLL pointed by the provided filename has never been + * loaded. + */ + + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" has never been loaded", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Scan through the list of packages already loaded in the target + * interpreter. If the package we want is already loaded there, + * then we should proceed with unloading. + */ + + code = TCL_ERROR; + if (pkgPtr != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->pkgPtr == pkgPtr) { + code = TCL_OK; + break; + } + } + } + if (code != TCL_OK) { + /* + * The package has not been loaded in this interpreter. + */ + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" has never been loaded in this interpreter", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Ensure that the DLL can be unloaded. If it is a trusted + * interpreter, pkgPtr->unloadProc must not be NULL for the DLL to + * be unloadable. If the interpreter is a safe one, + * pkgPtr->safeUnloadProc must be non-NULL. + */ + + if (Tcl_IsSafe(target)) { + if (pkgPtr->safeUnloadProc == NULL) { + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded under a safe interpreter", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + unloadProc = pkgPtr->safeUnloadProc; + } else { + if (pkgPtr->unloadProc == NULL) { + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded under a trusted interpreter", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + unloadProc = pkgPtr->unloadProc; + } + + /* + * We are ready to unload the package. First, evaluate the unload + * procedure. If this fails, we cannot proceed with unload. Also, + * we must specify the proper flag to pass to the unload callback. + * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback + * should only remove itself from the interpreter; the library + * will be unloaded in a future call of unload. In case the + * library will be unloaded just after the callback returns, + * TCL_UNLOAD_DETACH_FROM_PROCESS is passed. + */ + + code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; + if (!keepLibrary) { + Tcl_MutexLock(&packageMutex); + trustedRefCount = pkgPtr->interpRefCount; + safeRefCount = pkgPtr->safeInterpRefCount; + Tcl_MutexUnlock(&packageMutex); + + if (Tcl_IsSafe(target)) { + --safeRefCount; + } else { + --trustedRefCount; + } + + if (safeRefCount <= 0 && trustedRefCount <= 0) { + code = TCL_UNLOAD_DETACH_FROM_PROCESS; + } + } + code = (*unloadProc)(target, code); + if (code != TCL_OK) { + TclTransferResult(target, code, interp); + goto done; + } + + /* + * The unload procedure executed fine. Examine the reference + * count to see if we unload the DLL. + */ + + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + --pkgPtr->safeInterpRefCount; + /* + * Do not let counter get negative + */ + if (pkgPtr->safeInterpRefCount < 0) { + pkgPtr->safeInterpRefCount = 0; + } + } else { + --pkgPtr->interpRefCount; + /* + * Do not let counter get negative + */ + if (pkgPtr->interpRefCount < 0) { + pkgPtr->interpRefCount = 0; + } + } + trustedRefCount = pkgPtr->interpRefCount; + safeRefCount = pkgPtr->safeInterpRefCount; + Tcl_MutexUnlock(&packageMutex); + + code = TCL_OK; + if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0 + && !keepLibrary) { + /* + * Unload the shared library from the application memory... + */ + +#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) + /* + * Some Unix dlls are poorly behaved - registering things like + * atexit calls that can't be unregistered. If you unload + * such dlls, you get a core on exit because it wants to call + * a function in the dll after it's been unloaded. + */ + + if (pkgPtr->fileName[0] != '\0') { + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; + + if (unLoadProcPtr != NULL) { + Tcl_MutexLock(&packageMutex); + (*unLoadProcPtr)(pkgPtr->loadHandle); + + /* + * Remove this library from the loaded library cache. + */ + + defaultPtr = pkgPtr; + if (defaultPtr == firstPackagePtr) { + firstPackagePtr = pkgPtr->nextPtr; + } else { + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + if (pkgPtr->nextPtr == defaultPtr) { + pkgPtr->nextPtr = defaultPtr->nextPtr; + break; + } + } + } + + /* + * Remove this library from the interpreter's library + * cache. + */ + + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", (Tcl_InterpDeleteProc **) NULL); + ipPtr = ipFirstPtr; + if (ipPtr->pkgPtr == defaultPtr) { + ipFirstPtr = ipFirstPtr->nextPtr; + } else { + InterpPackage *ipPrevPtr; + + for (ipPrevPtr = ipPtr; ipPtr != NULL; + ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { + if (ipPtr->pkgPtr == pkgPtr) { + ipPrevPtr->nextPtr = ipPtr->nextPtr; + break; + } + } + } + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, + (ClientData) ipFirstPtr); + ckfree(defaultPtr->fileName); + ckfree(defaultPtr->packageName); + ckfree((char *) defaultPtr); + ckfree((char *) ipPtr); + Tcl_MutexUnlock(&packageMutex); + } else { + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded: filesystem does not support unloading", + (char *) NULL); + code = TCL_ERROR; + } + } +#else + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded: unloading disabled", (char *) NULL); + code = TCL_ERROR; +#endif + } + + done: + Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&tmp); + if (!complain && code!=TCL_OK) { + code = TCL_OK; + Tcl_ResetResult(interp); + } + if (code == TCL_OK) { +#if 0 + /* + * Result of [unload] was not documented in TIP#100, so force + * to be the empty string by commenting this out. DKF. + */ + + Tcl_Obj *resultObjPtr, *objPtr[2]; + + /* + * Our result is the two reference counts. + */ + + objPtr[0] = Tcl_NewIntObj(trustedRefCount); + objPtr[1] = Tcl_NewIntObj(safeRefCount); + if (objPtr[0] == NULL || objPtr[1] == NULL) { + if (objPtr[0]) { + Tcl_DecrRefCount(objPtr[0]); + } + if (objPtr[1]) { + Tcl_DecrRefCount(objPtr[1]); + } + } else { + resultObjPtr = Tcl_NewListObj(2, objPtr); + if (resultObjPtr != NULL) { + Tcl_SetObjResult(interp, resultObjPtr); + } + } +#endif + } + return code; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_StaticPackage -- * * This procedure is invoked to indicate that a particular diff --git a/tests/unload.test b/tests/unload.test new file mode 100644 index 0000000..00d6970 --- /dev/null +++ b/tests/unload.test @@ -0,0 +1,223 @@ +# Commands covered: unload +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2003-2004 by Georgios Petasis +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: unload.test,v 1.1 2004/02/24 22:58:48 dkf Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +# Figure out what extension is used for shared libraries on this +# platform. + +if {$tcl_platform(platform) == "macintosh"} { + puts "can't run dynamic library tests on macintosh machines" + ::tcltest::cleanupTests + return +} + +# Tests require the existence of one of the DLLs in the dltest directory. +set ext [info sharedlibextension] +set testDir [file join [file dirname [info nameofexecutable]] dltest] +set x [file join $testDir pkgua$ext] +set dll "[file tail $x]Required" +::tcltest::testConstraint $dll [file readable $x] + +# Tests also require that this DLL has not already been loaded. +set loaded "[file tail $x]Loaded" +set alreadyLoaded [info loaded] +::tcltest::testConstraint $loaded \ + [expr {![string match *pkgua* $alreadyLoaded]}] + +set alreadyTotalLoaded [info loaded] + +# Certain tests require the 'teststaticpkg' command from tcltest +::tcltest::testConstraint teststaticpkg \ + [string compare {} [info commands teststaticpkg]] + +# Basic tests: parameter testing... +test unload-1.1 {basic errors} {} { + list [catch {unload} msg] $msg +} "1 {wrong \# args: should be \"unload ?switches? fileName ?packageName? ?interp?\"}" +test unload-1.2 {basic errors} {} { + list [catch {unload a b c d} msg] $msg +} "1 {wrong \# args: should be \"unload ?switches? fileName ?packageName? ?interp?\"}" +test unload-1.3 {basic errors} {} { + list [catch {unload a b foobar} msg] $msg +} {1 {could not find interpreter "foobar"}} +test unload-1.4 {basic errors} {} { + list [catch {unload {}} msg] $msg +} {1 {must specify either file name or package name}} +test unload-1.5 {basic errors} {} { + list [catch {unload {} {}} msg] $msg +} {1 {must specify either file name or package name}} +test unload-1.6 {basic errors} {} { + list [catch {unload {} Unknown} msg] $msg +} {1 {package "Unknown" is loaded statically and cannot be unloaded}} +test unload-1.7 {-nocomplain switch} {} { + list [unload -nocomplain {} Unknown] +} {{}} + +set pkgua_loaded {} +set pkgua_detached {} +set pkgua_unloaded {} +# Tests for loading/unloading in trusted (non-safe) interpreters... +test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] { + load [file join $testDir pkga$ext] + list [pkga_eq abc def] [lsort [info commands pkga_*]] +} {0 {pkga_eq pkga_quote}} +test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] { + list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ + [load [file join $testDir pkgua$ext]] \ + [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ + $pkgua_loaded $pkgua_detached $pkgua_unloaded +} {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}} +test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} [list $dll $loaded] { + list [catch {unload [file join $testDir pkga$ext]} msg] \ + [string map [list [file join $testDir pkga$ext] file] $msg] +} {1 {file "file" cannot be unloaded under a trusted interpreter}} +test unload-2.4 {basic unloading of unloadable package, with guess for package name} [list $dll $loaded] { + list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ + [unload [file join $testDir pkgua$ext]] \ + [info commands pkgua_*] \ + $pkgua_loaded $pkgua_detached $pkgua_unloaded +} {. {} {} {} {} . . .} +test unload-2.5 {reloading of unloaded package, with guess for package name} [list $dll $loaded] { + list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ + [load [file join $testDir pkgua$ext]] \ + [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ + $pkgua_loaded $pkgua_detached $pkgua_unloaded +} {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} +test unload-2.6 {basic unloading of re-loaded package, with guess for package name} [list $dll $loaded] { + list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ + [unload [file join $testDir pkgua$ext]] \ + [info commands pkgua_*] \ + $pkgua_loaded $pkgua_detached $pkgua_unloaded +} {.. . . {} {} .. .. ..} + +# Tests for loading/unloading in safe interpreters... +interp create -safe child +child eval { + set pkgua_loaded {} + set pkgua_detached {} + set pkgua_unloaded {} +} +test unload-3.1 {basic loading of non-unloadable package in a safe interpreter, with package name conversion} \ + [list $dll $loaded] { + load [file join $testDir pkgb$ext] pKgB child + list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ + [catch {pkgb_sub 12 10} msg2] $msg2 +} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} +test unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ + [list $dll $loaded] { + list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [load [file join $testDir pkgua$ext] pKgUA child] \ + [child eval pkgua_eq abc def] \ + [lsort [child eval info commands pkgua_*]] \ + [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} +test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} \ + [list $dll $loaded] { + list [catch {unload [file join $testDir pkga$ext] {} child} msg] \ + [string map [list [file join $testDir pkga$ext] file] $msg] +} {1 {file "file" has never been loaded in this interpreter}} +test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} \ + [list $dll $loaded] { + list [catch {unload [file join $testDir pkgb$ext] {} child} msg] \ + [string map [list [file join $testDir pkgb$ext] file] $msg] +} {1 {file "file" cannot be unloaded under a safe interpreter}} +test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} \ + [list $dll $loaded] { + list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [unload [file join $testDir pkgua$ext] {} child] \ + [child eval info commands pkgua_*] \ + [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{. {} {}} {} {} {. . .}} +test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} \ + [list $dll $loaded] { + list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [load [file join $testDir pkgua$ext] {} child] \ + [child eval pkgua_eq abc def] \ + [lsort [child eval info commands pkgua_*]] \ + [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} +test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} \ + [list $dll $loaded] { + list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [unload [file join $testDir pkgua$ext] pKgUa child] \ + [child eval info commands pkgua_*] \ + [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{.. . .} {} {} {.. .. ..}} + +# Tests for loading/unloading of a package among multiple interpreters... +interp create child-trusted +child-trusted eval { + set pkgua_loaded {} + set pkgua_detached {} + set pkgua_unloaded {} +} +## Load package in main trusted interpreter... +test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} \ + [list $dll $loaded] { + list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ + [load [file join $testDir pkgua$ext]] \ + [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ + [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] +} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +## Load package in child-safe interpreter... +test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ + [list $dll $loaded] { + list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [load [file join $testDir pkgua$ext] pKgUA child] \ + [child eval pkgua_eq abc def] \ + [lsort [child eval info commands pkgua_*]] \ + [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +## Load package in child-trusted interpreter... +test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} \ + [list $dll $loaded] { + list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [load [file join $testDir pkgua$ext] pkguA child-trusted] \ + [child-trusted eval pkgua_eq abc def] \ + [lsort [child-trusted eval info commands pkgua_*]] \ + [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} +## Unload the package from the main trusted interpreter... +test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} \ + [list $dll $loaded] { + list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ + [unload [file join $testDir pkgua$ext]] \ + [info commands pkgua_*] \ + [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] +} {{... .. ..} {} {} {... ... ..}} +## Unload the package from the child safe interpreter... +test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ + [list $dll $loaded] { + list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [unload [file join $testDir pkgua$ext] {} child] \ + [child eval info commands pkgua_*] \ + [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{... .. ..} {} {} {... ... ..}} +## Unload the package from the child trusted interpreter... +test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ + [list $dll $loaded] { + list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ + [unload [file join $testDir pkgua$ext] {} child-trusted] \ + [child-trusted eval info commands pkgua_*] \ + [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] +} {{. {} {}} {} {} {. . .}} + +# cleanup +::tcltest::cleanupTests +return diff --git a/unix/Makefile.in b/unix/Makefile.in index 1de7db7..81d931f 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.133 2003/10/21 00:23:34 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.134 2004/02/24 22:58:48 dkf Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -90,7 +90,8 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DTCL_DBGX=$(TCL_DBGX) +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DTCL_DBGX=$(TCL_DBGX) \ + -DTCL_UNLOAD_DLLS=1 # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index bd30298..953ed18 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -1,7 +1,7 @@ # This Makefile is used to create several test cases for Tcl's load # command. It also illustrates how to take advantage of configuration # exported by Tcl to set up Makefiles for shared libraries. -# RCS: @(#) $Id: Makefile.in,v 1.12 2003/04/03 22:13:00 mdejong Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.13 2004/02/24 22:58:48 dkf Exp $ TCL_DBGX = @TCL_DBGX@ CC = @CC@ @@ -21,7 +21,7 @@ CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} +all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} @touch ../dltest.marker pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c @@ -44,6 +44,10 @@ pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c ${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS} +pkgua${SHLIB_SUFFIX}: $(SRC_DIR)/pkgua.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c + ${SHLIB_LD} -o pkgua${SHLIB_SUFFIX} pkgua.o ${SHLIB_LD_LIBS} + clean: rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status rm -f lib.exp ../dltest.marker diff --git a/unix/dltest/README b/unix/dltest/README index 12aa8be..3d85a9c 100644 --- a/unix/dltest/README +++ b/unix/dltest/README @@ -1,6 +1,6 @@ This directory contains several files for testing Tcl's dynamic -loading capabilities. If shared libraries are supported then -the build system in the parent directory will create +loading/unloading capabilities. If shared libraries are supported +then the build system in the parent directory will create the shared libs and load them into the tcltest executable. -RCS: @(#) $Id: README,v 1.3 2001/12/19 11:03:20 mdejong Exp $ +RCS: @(#) $Id: README,v 1.4 2004/02/24 22:58:48 dkf Exp $ diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c new file mode 100644 index 0000000..b4c9b6d --- /dev/null +++ b/unix/dltest/pkgua.c @@ -0,0 +1,336 @@ +/* + * pkgua.c -- + * + * This file contains a simple Tcl package "pkgua" that is intended + * for testing the Tcl dynamic unloading facilities. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright (c) 2004 Georgios Petasis + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: pkgua.c,v 1.1 2004/02/24 22:58:48 dkf Exp $ + */ + +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int PkguaEqObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); +static int PkguaQuoteObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); + +/* + * In the following hash table we are going to store a struct that + * holds all the command tokens created by Tcl_CreateObjCommand in an + * interpreter, indexed by the interpreter. In this way, we can find + * which command tokens we have registered in a specific interpreter, + * in order to unload them. We need to keep the various command tokens + * we have registered, as they are the only safe way to unregister our + * registered commands, even if they have been renamed. + * + * Note that this code is utterly single-threaded. + */ + +static Tcl_HashTable interpTokenMap; +static int interpTokenMapInitialised = 0; +#define MAX_REGISTERED_COMMANDS 2 + + +static int +PkguaInitTokensHashTable(void) +{ + if (interpTokenMapInitialised) { + return; + } + Tcl_InitHashTable(&interpTokenMap, TCL_ONE_WORD_KEYS); + interpTokenMapInitialised = 1; +}; + +static int +PkguaFreeTokensHashTable(void) +{ + Tcl_HashSearch search; + Tcl_HashEntry *entryPtr; + + for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search); + entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { + Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); + } + interpTokenMapInitialised = 0; +}; + +static Tcl_Command * +PkguaInterpToTokens(interp) + Tcl_Interp *interp; +{ + int newEntry; + Tcl_Command *cmdTokens; + Tcl_HashEntry *entryPtr = + Tcl_CreateHashEntry(&interpTokenMap, (char *) interp, &newEntry); + + if (newEntry) { + cmdTokens = (Tcl_Command *) + Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1)); + for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS+1 ; ++newEntry) { + cmdTokens[newEntry] = NULL; + } + Tcl_SetHashValue(entryPtr, (ClientData) cmdTokens); + } else { + cmdTokens = (Tcl_Command *) Tcl_GetHashValue(entryPtr); + } + return cmdTokens; +}; + +static void +PkguaDeleteTokens(interp) + Tcl_Interp *interp; +{ + Tcl_HashEntry *entryPtr = + Tcl_FindHashEntry(&interpTokenMap, (char *) interp); + + if (entryPtr) { + Tcl_Free((char *) Tcl_GetHashValue(entryPtr)); + Tcl_DeleteHashEntry(entryPtr); + } +}; + +/* + *---------------------------------------------------------------------- + * + * PkguaEqObjCmd -- + * + * This procedure is invoked to process the "pkgua_eq" Tcl command. + * It expects two arguments and returns 1 if they are the same, + * 0 if they are different. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +PkguaEqObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj * CONST objv[]; /* Argument objects. */ +{ + int result; + CONST char *str1, *str2; + int len1, len2, n; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string1 string2"); + return TCL_ERROR; + } + + str1 = Tcl_GetStringFromObj(objv[1], &len1); + str2 = Tcl_GetStringFromObj(objv[2], &len2); + if (len1 == len2) { + result = (Tcl_UtfNcmp(str1, str2, len1) == 0); + } else { + result = 0; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PkguaQuoteObjCmd -- + * + * This procedure is invoked to process the "pkgua_quote" Tcl command. + * It expects one argument, which it returns as result. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +PkguaQuoteObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj * CONST objv[]; /* Argument strings. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgua_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgua_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code, cmdIndex = 0; + Tcl_Command *cmdTokens; + + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + return TCL_ERROR; + } + + /* + * Initialise our Hash table, where we store the registered + * command tokens for each interpreter. + */ + + PkguaInitTokensHashTable(); + + code = Tcl_PkgProvide(interp, "Pkgua", "1.0"); + if (code != TCL_OK) { + return code; + } + + Tcl_SetVar(interp, "::pkgua_loaded", ".", TCL_APPEND_VALUE); + + cmdTokens = PkguaInterpToTokens(interp); + cmdTokens[cmdIndex++] = + Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + cmdTokens[cmdIndex++] = + Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgua_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgua_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + return Pkgua_Init(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Pkgua_Unload -- + * + * This is a package unloading initialization procedure, which is + * called by Tcl when this package is to be unloaded form an + * interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgua_Unload(interp, flags) + Tcl_Interp *interp; /* Interpreter from which the package is + * to be unloaded. */ + int flags; /* Flags passed by the unloading mechanism */ +{ + int code, cmdIndex; + Tcl_Command *cmdTokens = PkguaInterpToTokens(interp); + + for (cmdIndex=0 ; cmdIndex<MAX_REGISTERED_COMMANDS ; cmdIndex++) { + if (cmdTokens[cmdIndex] == NULL) { + continue; + } + code = Tcl_DeleteCommandFromToken(interp, cmdTokens[cmdIndex]); + if (code != TCL_OK) { + return code; + } + } + + PkguaDeleteTokens(interp); + + Tcl_SetVar(interp, "::pkgua_detached", ".", TCL_APPEND_VALUE); + + if (flags == TCL_UNLOAD_DETACH_FROM_PROCESS) { + /* + * Tcl is ready to detach this library from the running + * application. We should free all the memory that is not + * related to any interpreter. + */ + PkguaFreeTokensHashTable(); + + Tcl_SetVar(interp, "::pkgua_unloaded", ".", TCL_APPEND_VALUE); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgua_SafeUnload -- + * + * This is a package unloading initialization procedure, which is + * called by Tcl when this package is to be unloaded form an + * interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgua_SafeUnload(interp, flags) + Tcl_Interp *interp; /* Interpreter from which the package is + * to be unloaded. */ + int flags; /* Flags passed by the unloading mechanism */ +{ + return Pkgua_Unload(interp, flags); +} |