summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog9
-rw-r--r--doc/load.n9
-rw-r--r--doc/unload.n151
-rw-r--r--generic/tcl.h9
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclLoad.c505
-rw-r--r--tests/unload.test223
-rw-r--r--unix/Makefile.in5
-rw-r--r--unix/dltest/Makefile.in8
-rw-r--r--unix/dltest/README6
-rw-r--r--unix/dltest/pkgua.c336
12 files changed, 1242 insertions, 27 deletions
diff --git a/ChangeLog b/ChangeLog
index d0bcae7..b4e2f2c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
diff --git a/doc/load.n b/doc/load.n
index 5f404e1..cb125cc 100644
--- a/doc/load.n
+++ b/doc/load.n
@@ -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);
+}