diff options
author | Kevin B Kenny <kennykb@acm.org> | 2010-04-02 21:21:04 (GMT) |
---|---|---|
committer | Kevin B Kenny <kennykb@acm.org> | 2010-04-02 21:21:04 (GMT) |
commit | bd2c56d7039122dcb51ef36f39766e245c84d821 (patch) | |
tree | fe391271cb3355eb790c38ed7e17ab484df92009 | |
parent | 859e9838d18c82b7c6fbcc1c9af736f6be73aecb (diff) | |
download | tcl-bd2c56d7039122dcb51ef36f39766e245c84d821.zip tcl-bd2c56d7039122dcb51ef36f39766e245c84d821.tar.gz tcl-bd2c56d7039122dcb51ef36f39766e245c84d821.tar.bz2 |
* generic/tcl.decls: [TIP #357]: First round of changes
* generic/tclDecls.h: to export Tcl_LoadFile, Tcl_FindSymbol,
* generic/tclIOUtil.c: and Tcl_FSUnloadFile to the public API.
* generic/tclInt.h:
* generic/tclLoad.c:
* generic/tclLoadNone.c:
* generic/tclStubInit.c:
* tests/fileSystem.test:
* tests/load.test:
* tests/unload.test:
* unix/tclLoadDl.c:
* unix/tclLoadDyld.c:
* unix/tclLoadNext.c:
* unix/tclLoadOSF.c:
* unix/tclLoadShl.c:
* unix/tclUnixPipe.c:
* win/Makefile.in:
* win/tclWinLoad.c:
-rw-r--r-- | generic/tcl.decls | 16 | ||||
-rw-r--r-- | generic/tclDecls.h | 36 | ||||
-rw-r--r-- | generic/tclIOUtil.c | 310 | ||||
-rw-r--r-- | generic/tclInt.h | 31 | ||||
-rw-r--r-- | generic/tclLoad.c | 71 | ||||
-rw-r--r-- | generic/tclLoadNone.c | 57 | ||||
-rw-r--r-- | generic/tclStubInit.c | 5 | ||||
-rw-r--r-- | tests/fileSystem.test | 18 | ||||
-rw-r--r-- | tests/load.test | 8 | ||||
-rw-r--r-- | tests/unload.test | 25 | ||||
-rw-r--r-- | unix/tclLoadDl.c | 42 | ||||
-rw-r--r-- | unix/tclLoadDyld.c | 50 | ||||
-rw-r--r-- | unix/tclLoadNext.c | 35 | ||||
-rw-r--r-- | unix/tclLoadOSF.c | 38 | ||||
-rw-r--r-- | unix/tclLoadShl.c | 40 | ||||
-rw-r--r-- | unix/tclUnixPipe.c | 36 | ||||
-rw-r--r-- | win/Makefile.in | 4 | ||||
-rw-r--r-- | win/tclWinLoad.c | 168 |
18 files changed, 714 insertions, 276 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index e9843a8..0e59216 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.172 2010/01/29 16:17:20 nijtmans Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.173 2010/04/02 21:21:04 kennykb Exp $ library tcl @@ -2305,6 +2305,20 @@ declare 626 generic { int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } +# TIP #357 (Export TclLoadFile and TclpFindSymbol) kbk +declare 627 generic { + int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + const char *symv[], int flags, void* procPtrs, + Tcl_LoadHandle* handlePtr) +} +declare 628 generic { + void* Tcl_FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle handle, + const char* symbol) +} +declare 629 generic { + int Tcl_FSUnloadFile(Tcl_Interp* interp, Tcl_LoadHandle handlePtr) +} + # ----- BASELINE -- FOR -- 8.6.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 2508da9..8c2db65 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.174 2010/02/05 10:03:23 nijtmans Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.175 2010/04/02 21:21:05 kennykb Exp $ */ #ifndef _TCLDECLS @@ -3684,6 +3684,25 @@ EXTERN int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, EXTERN int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); #endif +#ifndef Tcl_LoadFile_TCL_DECLARED +#define Tcl_LoadFile_TCL_DECLARED +/* 627 */ +EXTERN int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, + const char *symv[], int flags, void*procPtrs, + Tcl_LoadHandle*handlePtr); +#endif +#ifndef Tcl_FindSymbol_TCL_DECLARED +#define Tcl_FindSymbol_TCL_DECLARED +/* 628 */ +EXTERN void* Tcl_FindSymbol(Tcl_Interp*interp, + Tcl_LoadHandle handle, const char*symbol); +#endif +#ifndef Tcl_FSUnloadFile_TCL_DECLARED +#define Tcl_FSUnloadFile_TCL_DECLARED +/* 629 */ +EXTERN int Tcl_FSUnloadFile(Tcl_Interp*interp, + Tcl_LoadHandle handlePtr); +#endif typedef struct TclStubHooks { const struct TclPlatStubs *tclPlatStubs; @@ -4346,6 +4365,9 @@ typedef struct TclStubs { int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */ int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ + int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *symv[], int flags, void*procPtrs, Tcl_LoadHandle*handlePtr); /* 627 */ + void* (*tcl_FindSymbol) (Tcl_Interp*interp, Tcl_LoadHandle handle, const char*symbol); /* 628 */ + int (*tcl_FSUnloadFile) (Tcl_Interp*interp, Tcl_LoadHandle handlePtr); /* 629 */ } TclStubs; #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) @@ -6884,6 +6906,18 @@ extern const TclStubs *tclStubsPtr; #define Tcl_NRSubstObj \ (tclStubsPtr->tcl_NRSubstObj) /* 626 */ #endif +#ifndef Tcl_LoadFile +#define Tcl_LoadFile \ + (tclStubsPtr->tcl_LoadFile) /* 627 */ +#endif +#ifndef Tcl_FindSymbol +#define Tcl_FindSymbol \ + (tclStubsPtr->tcl_FindSymbol) /* 628 */ +#endif +#ifndef Tcl_FSUnloadFile +#define Tcl_FSUnloadFile \ + (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index a838df6..c1e9430 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.170 2010/03/11 13:35:24 nijtmans Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.171 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -42,6 +42,10 @@ static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData); #ifdef TCL_THREADS static void FsRecacheFilesystemList(void); #endif +static void* DivertFindSymbol(Tcl_Interp* interp, + Tcl_LoadHandle loadHandle, + const char* symbol); +static void DivertUnloadFile(Tcl_LoadHandle loadHandle); /* * These form part of the native filesystem support. They are needed here @@ -2967,9 +2971,8 @@ Tcl_FSLoadFile( * function which should be used for this * file. */ { - const char *symbols[2]; - Tcl_PackageInitProc **procPtrs[2]; - ClientData clientData; + const char *symbols[3]; + void *procPtrs[2]; int res; /* @@ -2978,35 +2981,27 @@ Tcl_FSLoadFile( symbols[0] = sym1; symbols[1] = sym2; - procPtrs[0] = proc1Ptr; - procPtrs[1] = proc2Ptr; + symbols[2] = NULL; /* * Perform the load. */ - res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr, - &clientData, unloadProcPtr); - - /* - * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared - * library, we don't keep the loadHandle (for TclpFindSymbol) and the - * clientData (for the unloadProc) separately. In fact we effectively - * throw away the loadHandle and only use the clientData. It just so - * happens, for the native filesystem only, that these two are identical. - * - * This also means that the signatures Tcl_FSUnloadFileProc and - * Tcl_FSLoadFileProc are both misleading. - */ + res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr); + if (res == TCL_OK) { + *proc1Ptr = (Tcl_PackageInitProc*) procPtrs[0]; + *proc2Ptr = (Tcl_PackageInitProc*) procPtrs[1]; + } else { + *proc1Ptr = *proc2Ptr = NULL; + } - *handlePtr = clientData; return res; } /* *---------------------------------------------------------------------- * - * TclLoadFile -- + * Tcl_LoadFile -- * * Dynamically loads a binary code file into memory and returns the * addresses of a number of given functions within that file, if they are @@ -3020,54 +3015,42 @@ Tcl_FSLoadFile( * filesystems (and has other problems documented in the load man-page), * so it is advised that full paths are always used. * - * This function is currently private to Tcl. It may be exported in the - * future and its interface fixed (but we should clean up the - * loadHandle/clientData confusion at that time -- see the above comments - * in Tcl_FSLoadFile for details). For a public function, see - * Tcl_FSLoadFile. - * * Results: * A standard Tcl completion code. If an error occurs, an error message * is left in the interp's result. * * Side effects: * New code suddenly appears in memory. This may later be unloaded by - * passing the clientData to the unloadProc. + * calling TclFS_UnloadFile. * *---------------------------------------------------------------------- */ int -TclLoadFile( +Tcl_LoadFile( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Obj *pathPtr, /* Name of the file containing the desired * code. */ - int symc, /* Number of symbols/procPtrs in the next two - * arrays. */ const char *symbols[], /* Names of functions to look up in the file's * symbol table. */ - Tcl_PackageInitProc **procPtrs[], - /* Where to return the addresses corresponding + int flags, /* Flags (unused) */ + void *procVPtrs, /* Where to return the addresses corresponding * to symbols[]. */ - Tcl_LoadHandle *handlePtr, /* Filled with token for shared library + Tcl_LoadHandle *handlePtr) /* Filled with token for shared library * information which can be used in * TclpFindSymbol. */ - ClientData *clientDataPtr, /* Filled with token for dynamically loaded - * file which will be passed back to - * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr) - /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for this - * file. */ { + void** procPtrs = (void**) procVPtrs; const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); const Tcl_Filesystem *copyFsPtr; + Tcl_FSUnloadFileProc* unloadProcPtr; Tcl_Obj *copyToPtr; Tcl_LoadHandle newLoadHandle = NULL; - ClientData newClientData = NULL; + Tcl_LoadHandle divertedLoadHandle = NULL; Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; FsDivertLoad *tvdlPtr; int retVal; + int i; if (fsPtr == NULL) { Tcl_SetErrno(ENOENT); @@ -3076,18 +3059,12 @@ TclLoadFile( if (fsPtr->loadFileProc != NULL) { int retVal = fsPtr->loadFileProc(interp, pathPtr, handlePtr, - unloadProcPtr); + &unloadProcPtr); if (retVal == TCL_OK) { if (*handlePtr == NULL) { return TCL_ERROR; } - - /* - * Copy this across, since both are equal for the native fs. - */ - - *clientDataPtr = *handlePtr; Tcl_ResetResult(interp); goto resolveSymbols; } @@ -3147,7 +3124,7 @@ TclLoadFile( ret = Tcl_Read(data, buffer, size); Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, - unloadProcPtr); + &unloadProcPtr); if (ret == TCL_OK && *handlePtr != NULL) { *clientDataPtr = *handlePtr; goto resolveSymbols; @@ -3163,12 +3140,7 @@ TclLoadFile( * to load. */ - copyToPtr = TclpTempFileName(); - if (copyToPtr == NULL) { - Tcl_AppendResult(interp, "couldn't create temporary file: ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } + copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr); Tcl_IncrRefCount(copyToPtr); copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); @@ -3223,8 +3195,8 @@ TclLoadFile( Tcl_ResetResult(interp); - retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, - &newLoadHandle, &newClientData, &newUnloadProcPtr); + retVal = Tcl_LoadFile(interp, copyToPtr, symbols, 0, procPtrs, + &newLoadHandle); if (retVal != TCL_OK) { /* * The file didn't load successfully. @@ -3251,8 +3223,6 @@ TclLoadFile( */ *handlePtr = newLoadHandle; - *clientDataPtr = newClientData; - *unloadProcPtr = newUnloadProcPtr; Tcl_ResetResult(interp); return TCL_OK; } @@ -3307,20 +3277,36 @@ TclLoadFile( } copyToPtr = NULL; - *handlePtr = newLoadHandle; - *clientDataPtr = tvdlPtr; - *unloadProcPtr = TclFSUnloadTempFile; + + + divertedLoadHandle = (Tcl_LoadHandle) + ckalloc(sizeof (struct Tcl_LoadHandle_)); + divertedLoadHandle->clientData = (ClientData) tvdlPtr; + divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; + divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; + *handlePtr = divertedLoadHandle; Tcl_ResetResult(interp); return retVal; resolveSymbols: - { - int i; - - for (i=0 ; i<symc ; i++) { - if (symbols[i] != NULL) { - *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]); + /* + * At this point, *handlePtr is already set up to the handle for the + * loaded library. We now try to resolve the symbols. + */ + if (symbols != NULL) { + for (i=0 ; symbols[i] != NULL; i++) { + procPtrs[i] = Tcl_FindSymbol(interp, *handlePtr, symbols[i]); + if (procPtrs[i] == NULL) { + /* + * At least one symbol in the list was not found. + * Unload the file, and report the problem back to the + * caller. (Tcl_FindSymbol should already have left an + * appropriate error message.) + */ + (*handlePtr)->unloadFileProcPtr(*handlePtr); + *handlePtr = NULL; + return TCL_ERROR; } } } @@ -3328,6 +3314,113 @@ TclLoadFile( } /* + *----------------------------------------------------------------------------- + * + * DivertFindSymbol -- + * + * Find a symbol in a shared library loaded by copy-from-VFS. + * + *----------------------------------------------------------------------------- + */ + +static void* +DivertFindSymbol(Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_LoadHandle loadHandle, /* Handle to the diverted module */ + const char* symbol) /* Symbol to resolve */ +{ + FsDivertLoad* tvdlPtr = (FsDivertLoad*) (loadHandle->clientData); + Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle; + return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol); +} + +/* + *----------------------------------------------------------------------------- + * + * DivertUnloadFile -- + * + * Unloads a file that has been loaded by copying from VFS to the + * native filesystem. + * + * Parameters: + * loadHandle -- Handle of the file to unload + * + *----------------------------------------------------------------------------- + */ + +static void +DivertUnloadFile(Tcl_LoadHandle loadHandle) +{ + FsDivertLoad* tvdlPtr = (FsDivertLoad*) (loadHandle->clientData); + Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle; + + /* + * This test should never trigger, since we give the client data in the + * function above. + */ + + if (tvdlPtr == NULL) { + return; + } + + /* + * Call the real 'unloadfile' proc we actually used. It is very important + * that we call this first, so that the shared library is actually + * unloaded by the OS. Otherwise, the following 'delete' may well fail + * because the shared library is still in use. + */ + + originalHandle->unloadFileProcPtr(originalHandle); + + /* What filesystem contains the temp copy of the library? */ + + if (tvdlPtr->divertedFilesystem == NULL) { + /* + * It was the native filesystem, and we have a special function + * available just for this purpose, which we know works even at this + * late stage. + */ + + TclpDeleteFile(tvdlPtr->divertedFileNativeRep); + NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); + } else { + /* + * Remove the temporary file we created. Note, we may crash here + * because encodings have been taken down already. + */ + + if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) + != TCL_OK) { + /* + * The above may have failed because the filesystem, or something + * it depends upon (e.g. encodings) have been taken down because + * Tcl is exiting. + * + * We may need to work out how to delete this file more robustly + * (or give the filesystem the information it needs to delete the + * file more robustly). + * + * In particular, one problem might be that the filesystem cannot + * extract the information it needs from the above path object + * because Tcl's entire filesystem apparatus (the code in this + * file) has been finalized, and it refuses to pass the internal + * representation to the filesystem. + */ + } + + /* + * And free up the allocations. This will also of course remove a + * refCount from the Tcl_Filesystem to which this file belongs, which + * could then free up the filesystem if we are exiting. + */ + + Tcl_DecrRefCount(tvdlPtr->divertedFile); + } + + ckfree((void*)tvdlPtr); + ckfree((void*)loadHandle); +} + +/* * This function used to be in the platform specific directories, but it has * now been made to work cross-platform. */ @@ -3366,9 +3459,84 @@ TclpLoadFile( *clientDataPtr = handle; - *proc1Ptr = TclpFindSymbol(interp, handle, sym1); - *proc2Ptr = TclpFindSymbol(interp, handle, sym2); + *proc1Ptr = Tcl_FindSymbol(interp, handle, sym1); + *proc2Ptr = Tcl_FindSymbol(interp, handle, sym2); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * Tcl_FindSymbol -- + * + * Find a symbol in a loaded library + * + * Results: + * Returns a pointer to the symbol if found. If not found, returns + * NULL and leaves an error message in the interpreter result. + * + * This function was once filesystem-specific, but has been made portable + * by having TclpDlopen return a structure that includes procedure pointers. + * + *----------------------------------------------------------------------------- + */ + +void* +Tcl_FindSymbol(Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_LoadHandle loadHandle, /* Handle to the loaded library */ + const char* symbol) /* Name of the symbol to resolve */ +{ + return (*(loadHandle->findSymbolProcPtr))(interp, loadHandle, symbol); +} + +/* + *----------------------------------------------------------------------------- + * + * Tcl_FSUnloadFile -- + * + * Unloads a library given its handle. Checks first that the library + * supports unloading. + * + *----------------------------------------------------------------------------- + */ + +int +Tcl_FSUnloadFile(Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_LoadHandle handle) /* Handle of the file to unload */ +{ + if (handle->unloadFileProcPtr == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot unload: filesystem " + "does not support unloading", + -1)); + } + return TCL_ERROR; + } else { + TclpUnloadFile(handle); return TCL_OK; + } +} + +/* + *----------------------------------------------------------------------------- + * + * TclpUnloadFile -- + * + * Unloads a library given its handle + * + * This function was once filesystem-specific, but has been made portable + * by having TclpDlopen return a structure that includes procedure pointers. + * + *----------------------------------------------------------------------------- + */ + +void +TclpUnloadFile(Tcl_LoadHandle handle) +{ + if (handle->unloadFileProcPtr != NULL) { + (*(handle->unloadFileProcPtr))(handle); + } } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 422e203..6c70fd2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,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.466 2010/03/27 22:40:14 nijtmans Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.467 2010/04/02 21:21:06 kennykb Exp $ */ #ifndef _TCLINT @@ -2772,6 +2772,25 @@ typedef struct ForIterData { int word; /* Index of the body script in the command */ } ForIterData; +/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile + * and Tcl_FindSymbol. This structure corresponds to an opaque + * typedef in tcl.h */ + +typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +struct Tcl_LoadHandle_ { + ClientData clientData; /* Client data is the load handle in the + * native filesystem if a module was loaded + * there, or an opaque pointer to a structure + * for further bookkeeping on load-from-VFS + * and load-from-memory */ + TclFindSymbolProc* findSymbolProcPtr; + /* Procedure that resolves symbols in a + * loaded module */ + Tcl_FSUnloadFileProc* unloadFileProcPtr; + /* Procedure that unloads a loaded module */ +}; + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: @@ -2922,12 +2941,6 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); -MODULE_SCOPE int TclLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, - int symc, const char *symbols[], - Tcl_PackageInitProc **procPtrs[], - Tcl_LoadHandle *handlePtr, - ClientData *clientDataPtr, - Tcl_FSUnloadFileProc **unloadProcPtr); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, @@ -2965,6 +2978,7 @@ MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); +MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, int len); MODULE_SCOPE int TclpDeleteFile(const char *path); @@ -3017,7 +3031,6 @@ MODULE_SCOPE char * TclpReadlink(const char *fileName, Tcl_DString *linkPtr); MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); -MODULE_SCOPE void TclpUnloadFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, void *data); @@ -3058,8 +3071,6 @@ MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); -MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp, - Tcl_LoadHandle loadHandle, const char *symbol); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index e6e2ba5..8ba90ed 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.24 2010/03/05 14:34:04 dkf Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.25 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -57,11 +57,6 @@ typedef struct LoadedPackage { * in trusted interpreters. */ int safeInterpRefCount; /* How many times the package has been loaded * in safe interpreters. */ - Tcl_FSUnloadFileProc *unLoadProcPtr; - /* Function to use to unload this package. If - * NULL, then we do not attempt to unload the - * package. If fileName is NULL, then this - * field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means end of @@ -131,15 +126,12 @@ Tcl_LoadObjCmd( LoadedPackage *pkgPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; - Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; - const char *symbols[4]; - Tcl_PackageInitProc **procPtrs[4]; - ClientData clientData; + const char *symbols[2]; + void* procPtrs[1]; const char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; - Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; if ((objc < 2) || (objc > 4)) { @@ -359,33 +351,15 @@ Tcl_LoadObjCmd( */ 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; + symbols[1] = NULL; Tcl_MutexLock(&packageMutex); - code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, - &loadHandle, &clientData, &unLoadProcPtr); + code = Tcl_LoadFile(interp, objv[1], symbols, 0, procPtrs, &loadHandle); Tcl_MutexUnlock(&packageMutex); - loadHandle = clientData; if (code != TCL_OK) { goto done; } - if (*procPtrs[0] /* initProc */ == NULL) { - Tcl_AppendResult(interp, "couldn't find procedure ", - Tcl_DStringValue(&initName), NULL); - if (unLoadProcPtr != NULL) { - unLoadProcPtr(loadHandle); - } - code = TCL_ERROR; - goto done; - } - /* * Create a new record to describe this package. */ @@ -398,11 +372,14 @@ Tcl_LoadObjCmd( ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); 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->initProc = (Tcl_PackageInitProc*) procPtrs[0]; + pkgPtr->safeInitProc = (Tcl_PackageInitProc*) + Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); + pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) + Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&unloadName)); + pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) + Tcl_FindSymbol(interp, loadHandle, + Tcl_DStringValue(&safeUnloadName)); pkgPtr->interpRefCount = 0; pkgPtr->safeInterpRefCount = 0; @@ -410,6 +387,11 @@ Tcl_LoadObjCmd( pkgPtr->nextPtr = firstPackagePtr; firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); + /* + * The Tcl_FindSymbol calls may have left a spurious error message + * in the interpreter result. + */ + Tcl_ResetResult(interp); } /* @@ -787,14 +769,9 @@ Tcl_UnloadObjCmd( */ if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; - if (unLoadProcPtr != NULL) { Tcl_MutexLock(&packageMutex); - if ((pkgPtr->unloadProc != NULL) || (unLoadProcPtr == TclFSUnloadTempFile)) { - unLoadProcPtr(pkgPtr->loadHandle); - } - + if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. */ @@ -839,9 +816,6 @@ Tcl_UnloadObjCmd( ckfree((char *) ipPtr); Tcl_MutexUnlock(&packageMutex); } else { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded: filesystem does not support unloading", - NULL); code = TCL_ERROR; } } @@ -1146,12 +1120,7 @@ TclFinalizeLoad(void) */ if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; - if ((unLoadProcPtr != NULL) - && ((pkgPtr->unloadProc != NULL) - || (unLoadProcPtr == TclFSUnloadTempFile))) { - unLoadProcPtr(pkgPtr->loadHandle); - } + Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); } #endif diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index 27484ca..dbb0a25 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -1,7 +1,7 @@ /* * tclLoadNone.c -- * - * This procedure provides a version of the TclLoadFile for use in + * This procedure provides a version of the TclpDlopen for use in * systems that don't support dynamic loading; it just returns an error. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. @@ -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: tclLoadNone.c,v 1.13 2008/04/27 22:21:31 dkf Exp $ + * RCS: @(#) $Id: tclLoadNone.c,v 1.14 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -55,33 +55,6 @@ TclpDlopen( /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- - * - * Looks up a symbol, by name, through a handle associated with a - * previously loaded piece of code (shared library). This version of this - * routine should never be called because the associated TclpDlopen() - * function always returns an error. - * - * Results: - * Returns a pointer to the function associated with 'symbol' if it is - * found. Otherwise returns NULL and may leave an error message in the - * interp's result. - * - *---------------------------------------------------------------------- - */ - -Tcl_PackageInitProc * -TclpFindSymbol( - Tcl_Interp *interp, - Tcl_LoadHandle loadHandle, - const char *symbol) -{ - return NULL; -} - -/* - *---------------------------------------------------------------------- - * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package name, @@ -110,32 +83,6 @@ TclGuessPackageName( } /* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * This procedure is called to carry out dynamic unloading of binary code; - * it is intended for use only on systems that don't support dynamic - * loading (it does nothing). - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile( - Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to - * TclpDlopen(). The loadHandle is a token - * that represents the loaded file. */ -{ -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b7e4b9a..7cfa58a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.189 2010/03/20 15:40:14 dkf Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.190 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -1115,6 +1115,9 @@ const TclStubs tclStubs = { Tcl_CloseEx, /* 624 */ Tcl_NRExprObj, /* 625 */ Tcl_NRSubstObj, /* 626 */ + Tcl_LoadFile, /* 627 */ + Tcl_FindSymbol, /* 628 */ + Tcl_FSUnloadFile, /* 629 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 9937618..071b63f 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -619,7 +619,7 @@ if {[testConstraint testfilesystem]} { while {![catch {testfilesystem 0}]} {} } -test filesystem-7.1 {load from vfs} -setup { +test filesystem-7.1.1 {load from vfs} -setup { set dir [pwd] } -constraints {win testsimplefilesystem} -body { # This may cause a crash on exit @@ -634,6 +634,22 @@ test filesystem-7.1 {load from vfs} -setup { } -cleanup { cd $dir } -result ok +test filesystem-7.1.2 {load from vfs, and then unload again} -setup { + set dir [pwd] +} -constraints {win testsimplefilesystem} -body { + # This may cause a crash on exit + cd [file dirname [info nameof]] + set reg [lindex [glob tclreg*[info sharedlib]] 0] + testsimplefilesystem 1 + # This loads reg via a complex copy-to-temp operation + load simplefs:/$reg Registry + unload simplefs:/$reg + testsimplefilesystem 0 + return ok + # The real result of this test is what happens when Tcl exits. +} -cleanup { + cd $dir +} -result ok test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] diff --git a/tests/load.test b/tests/load.test index 8ecdaf5..711b919 100644 --- a/tests/load.test +++ b/tests/load.test @@ -10,7 +10,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.test,v 1.20 2010/02/07 08:03:11 dkf Exp $ +# RCS: @(#) $Id: load.test,v 1.21 2010/04/02 21:21:06 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -77,8 +77,10 @@ test load-2.2 {loading into a safe interpreter, with package name conversion} \ } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ -body { - list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg -} -match glob -result {1 {*couldn't find procedure Foo_Init}} + list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode +} -match glob \ + -result [list 1 {cannot find symbol "Foo_Init"*} \ + {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg } {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} diff --git a/tests/unload.test b/tests/unload.test index b61e4cc..bf704c7 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -11,7 +11,7 @@ # 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.8 2008/07/21 21:25:22 nijtmans Exp $ +# RCS: @(#) $Id: unload.test,v 1.9 2010/04/02 21:21:06 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -40,6 +40,10 @@ set alreadyTotalLoaded [info loaded] # Certain tests require the 'teststaticpkg' command from tcltest testConstraint teststaticpkg [llength [info commands teststaticpkg]] +# Certain tests need the 'testsimplefilsystem' in tcltest +testConstraint testsimplefilesystem \ + [llength [info commands testsimplefilesystem]] + # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload @@ -213,9 +217,28 @@ test unload-4.6 {basic unloading of unloadable package from a safe interpreter, [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } {{. {} {}} {} {} {. . .}} +test unload-5.1 {unload a module loaded from vfs} \ + -constraints [list $dll $loaded testsimplefilesystem] \ + -setup { + set dir [pwd] + cd $testDir + testsimplefilesystem 1 + load simplefs:/pkgua$ext pkgua + } \ + -body { + list [catch {unload simplefs:/pkgua$ext} msg] $msg + } \ + -result {0 {}} + + + # cleanup interp delete child interp delete child-trusted unset ext ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c index 282d5bb..802e0dd 100644 --- a/unix/tclLoadDl.c +++ b/unix/tclLoadDl.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: tclLoadDl.c,v 1.19 2010/03/11 15:02:33 nijtmans Exp $ + * RCS: @(#) $Id: tclLoadDl.c,v 1.20 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -34,6 +34,12 @@ # define RTLD_GLOBAL 0 #endif +/* Static procedures defined within this file */ + +static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +static void UnloadFile(Tcl_LoadHandle loadHandle); + /* *--------------------------------------------------------------------------- * @@ -66,6 +72,7 @@ TclpDlopen( * file. */ { void *handle; + Tcl_LoadHandle newHandle; const char *native; /* @@ -103,16 +110,20 @@ TclpDlopen( Tcl_GetString(pathPtr), "\": ", errorStr, NULL); return TCL_ERROR; } + newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle)); + newHandle->clientData = (ClientData) handle; + newHandle->findSymbolProcPtr = &FindSymbol; + newHandle->unloadFileProcPtr = &UnloadFile; + *unloadProcPtr = &UnloadFile; + *loadHandle = newHandle; - *unloadProcPtr = &TclpUnloadFile; - *loadHandle = (Tcl_LoadHandle) handle; return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- + * FindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -125,15 +136,15 @@ TclpDlopen( *---------------------------------------------------------------------- */ -Tcl_PackageInitProc * -TclpFindSymbol( +static void * +FindSymbol( Tcl_Interp *interp, /* Place to put error messages. */ Tcl_LoadHandle loadHandle, /* Value from TcpDlopen(). */ const char *symbol) /* Symbol to look up. */ { const char *native; Tcl_DString newName, ds; - void *handle = (void *) loadHandle; + void *handle = (void *)(loadHandle->clientData); Tcl_PackageInitProc *proc; /* @@ -154,14 +165,20 @@ TclpFindSymbol( Tcl_DStringFree(&newName); } Tcl_DStringFree(&ds); - + if (proc == NULL && interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\": ", + dlerror(), NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, + NULL); + } return proc; } /* *---------------------------------------------------------------------- * - * TclpUnloadFile -- + * UnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -176,16 +193,17 @@ TclpFindSymbol( *---------------------------------------------------------------------- */ -void -TclpUnloadFile( +static void +UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { void *handle; - handle = (void *) loadHandle; + handle = (void *)(loadHandle->clientData); dlclose(handle); + ckfree((char*)loadHandle); } /* diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index 4b64032..2f833cd 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -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: tclLoadDyld.c,v 1.34 2010/03/11 15:02:33 nijtmans Exp $ + * RCS: @(#) $Id: tclLoadDyld.c,v 1.35 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -94,6 +94,14 @@ MODULE_SCOPE long tclMacOSXDarwinRelease; #define TclLoadDbgMsg(m, ...) #endif +/* Static functions defined in this file */ + +static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +static void UnloadFile(Tcl_LoadHandle handle); + + + #if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY) /* *---------------------------------------------------------------------- @@ -167,6 +175,7 @@ TclpDlopen( * file. */ { Tcl_DyldLoadHandle *dyldLoadHandle; + Tcl_LoadHandle* newHandle; #if TCL_DYLD_USE_DLFCN void *dlHandle = NULL; #endif @@ -307,8 +316,12 @@ TclpDlopen( dyldLoadHandle->dyldLibHeader = dyldLibHeader; dyldLoadHandle->modulePtr = modulePtr; #endif - *loadHandle = (Tcl_LoadHandle) dyldLoadHandle; - *unloadProcPtr = &TclpUnloadFile; + newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle)); + newHandle->clientData = dyldLoadHandle; + newHandle->findSymbolProcPtr = &FindSymbol; + newHandle->unloadProcPtr = &UnloadFile; + *unloadProcPtr = &UnloadFile; + *loadHandle = newHandle; result = TCL_OK; } else { Tcl_AppendResult(interp, errMsg, NULL); @@ -329,7 +342,7 @@ TclpDlopen( /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- + * FindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -342,13 +355,14 @@ TclpDlopen( *---------------------------------------------------------------------- */ -MODULE_SCOPE Tcl_PackageInitProc * -TclpFindSymbol( +static void* +FindSymbol( Tcl_Interp *interp, /* For error reporting. */ Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */ const char *symbol) /* Symbol name to look up. */ { - Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle; + Tcl_DyldLoadHandle *dyldLoadHandle = + (Tcl_DyldLoadHandle *) (loadHandle->clientData); Tcl_PackageInitProc *proc = NULL; const char *errMsg = NULL; Tcl_DString ds; @@ -436,8 +450,9 @@ TclpFindSymbol( #endif /* TCL_DYLD_USE_NSMODULE */ } Tcl_DStringFree(&ds); - if (errMsg) { + if (errMsg && (interp != NULL)) { Tcl_AppendResult(interp, errMsg, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return proc; } @@ -445,7 +460,7 @@ TclpFindSymbol( /* *---------------------------------------------------------------------- * - * TclpUnloadFile -- + * UnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -462,13 +477,14 @@ TclpFindSymbol( *---------------------------------------------------------------------- */ -MODULE_SCOPE void -TclpUnloadFile( +static void +UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle; + Tcl_DyldLoadHandle *dyldLoadHandle = + (Tcl_DyldLoadHandle *) (loadHandle->clientData); #if TCL_DYLD_USE_DLFCN if (dyldLoadHandle->dlHandle) { @@ -504,6 +520,7 @@ TclpUnloadFile( #endif /* TCL_DYLD_USE_NSMODULE */ } ckfree((char*) dyldLoadHandle); + ckfree((char*) loadHandle); } /* @@ -613,6 +630,7 @@ TclpLoadMemory( * function which should be used for this * file. */ { + Tcl_LoadHandle newHandle; Tcl_DyldLoadHandle *dyldLoadHandle; NSObjectFileImage dyldObjFileImage = NULL; Tcl_DyldModuleHandle *modulePtr; @@ -757,8 +775,12 @@ TclpLoadMemory( #endif dyldLoadHandle->dyldLibHeader = NULL; dyldLoadHandle->modulePtr = modulePtr; - *loadHandle = (Tcl_LoadHandle) dyldLoadHandle; - *unloadProcPtr = &TclpUnloadFile; + newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle)); + newHandle->clientData = dyldLoadHandle; + newHandle->findSymbolProcPtr = &FindSymbol; + newHandle->unloadFileProcPtr = &UnloadFile; + *loadHandle = newHandle; + *unloadProcPtr = &UnloadFile; return TCL_OK; } #endif /* TCL_LOAD_FROM_MEMORY */ diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c index 0f82593..35aeba4 100644 --- a/unix/tclLoadNext.c +++ b/unix/tclLoadNext.c @@ -9,12 +9,19 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadNext.c,v 1.16 2010/03/11 15:02:33 nijtmans Exp $ + * RCS: @(#) $Id: tclLoadNext.c,v 1.17 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" #include <mach-o/rld.h> #include <streams/streams.h> + +/* Static procedures defined within this file */ + +static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +static void UnloadFile(Tcl_LoadHandle loadHandle); + /* *---------------------------------------------------------------------- @@ -47,6 +54,7 @@ TclpDlopen( * function which should be used for this * file. */ { + Tcl_LoadHandle newHandle; struct mach_header *header; char *fileName; char *files[2]; @@ -95,8 +103,12 @@ TclpDlopen( } NXCloseMemory(errorStream, NX_FREEBUFFER); - *loadHandle = (Tcl_LoadHandle)1; /* A dummy non-NULL value */ - *unloadProcPtr = &TclpUnloadFile; + newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle)); + newHandle->clientData = (ClientData) 1; + newHandle->findSymbolProcPtr = &FindSymbol; + newHandle->unloadFileProcPtr = &UnloadFile; + *loadHandle = newHandle; + *unloadProcPtr = &UnloadFile; return TCL_OK; } @@ -104,7 +116,7 @@ TclpDlopen( /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- + * FindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -117,8 +129,8 @@ TclpDlopen( *---------------------------------------------------------------------- */ -Tcl_PackageInitProc * -TclpFindSymbol( +static void* +FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) @@ -132,13 +144,19 @@ TclpFindSymbol( strcat(sym, symbol); rld_lookup(NULL, sym, (unsigned long *)&proc); } + if (proc == NULL && interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "cannot find symbol \"", symbol, + "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + } return proc; } /* *---------------------------------------------------------------------- * - * TclpUnloadFile -- + * UnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -154,11 +172,12 @@ TclpFindSymbol( */ void -TclpUnloadFile( +UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { + ckfree((char*) loadHandle); } /* diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c index 136fad9..2810a7c 100644 --- a/unix/tclLoadOSF.c +++ b/unix/tclLoadOSF.c @@ -31,13 +31,19 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadOSF.c,v 1.16 2010/03/11 15:02:33 nijtmans Exp $ + * RCS: @(#) $Id: tclLoadOSF.c,v 1.17 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" #include <sys/types.h> #include <loader.h> +/* Static functions defined within this file */ + +static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +static void UnloadFile(Tcl_LoadHandle handle); + /* *---------------------------------------------------------------------- * @@ -69,6 +75,7 @@ TclpDlopen( * function which should be used for this * file. */ { + Tcl_LoadHandle newHandle; ldr_module_t lm; char *pkg; char *fileName = Tcl_GetString(pathPtr); @@ -119,15 +126,19 @@ TclpDlopen( } else { pkg++; } - *loadHandle = pkg; - *unloadProcPtr = &TclpUnloadFile; + newHandle = (Tcl_LoadHandle*) ckalloc(sizeof(*newHandle)); + newHandle->clientData = pkg; + newHandle->findSymbolProcPtr = &FindSymbol; + newHandle->unloadFileProcPtr = &UnloadFile; + *loadHandle = newHandle; + *unloadProcPtr = &UnloadFile; return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- + * FindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -140,19 +151,25 @@ TclpDlopen( *---------------------------------------------------------------------- */ -Tcl_PackageInitProc * -TclpFindSymbol( +static void * +FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) { - return ldr_lookup_package((char *)loadHandle, symbol); + void* retval = ldr_lookup_package((char *)loadHandle, symbol); + if (retval == NULL && interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + } + return retval; } /* *---------------------------------------------------------------------- * - * TclpUnloadFile -- + * UnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -167,12 +184,13 @@ TclpFindSymbol( *---------------------------------------------------------------------- */ -void -TclpUnloadFile( +static void +UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { + ckfree((char*) loadHandle); } /* diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c index bf46cf5..a690dac 100644 --- a/unix/tclLoadShl.c +++ b/unix/tclLoadShl.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadShl.c,v 1.19 2010/03/11 15:02:33 nijtmans Exp $ + * RCS: @(#) $Id: tclLoadShl.c,v 1.20 2010/04/02 21:21:06 kennykb Exp $ */ #include <dl.h> @@ -25,6 +25,14 @@ #include "tclInt.h" +/* Static functions defined within this file */ + +static void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +static void +UnloadFile(Tcl_LoadHandle handle); + + /* *---------------------------------------------------------------------- * @@ -57,6 +65,7 @@ TclpDlopen( * file. */ { shl_t handle; + Tcl_LoadHandle newHandle; const char *native; char *fileName = Tcl_GetString(pathPtr); @@ -97,15 +106,18 @@ TclpDlopen( Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - *loadHandle = (Tcl_LoadHandle) handle; - *unloadProcPtr = &TclpUnloadFile; + newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle)); + newHandle->clientData = handle; + newHandle->findSymbolProcPtr = &FindSymbol; + newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile; + *loadHandle = newHandle; return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- + * Tcl_FindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -118,15 +130,15 @@ TclpDlopen( *---------------------------------------------------------------------- */ -Tcl_PackageInitProc * -TclpFindSymbol( +static void* +FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) { Tcl_DString newName; Tcl_PackageInitProc *proc = NULL; - shl_t handle = (shl_t)loadHandle; + shl_t handle = (shl_t)(loadHandle->clientData); /* * Some versions of the HP system software still use "_" at the beginning @@ -144,13 +156,18 @@ TclpFindSymbol( } Tcl_DStringFree(&newName); } + if (proc == NULL && interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "cannot find symbol\"", symbol, + "\": ", Tcl_PosixError(interp), NULL); + } return proc; } /* *---------------------------------------------------------------------- * - * TclpUnloadFile -- + * UnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -165,16 +182,17 @@ TclpFindSymbol( *---------------------------------------------------------------------- */ -void -TclpUnloadFile( +static void +UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { shl_t handle; - handle = (shl_t) loadHandle; + handle = (shl_t) (loadHandle -> clientData); shl_unload(handle); + ckfree((char*) loadHandle); } /* diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 21a0153..ccb97c2 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPipe.c,v 1.51 2010/01/10 22:58:41 nijtmans Exp $ + * RCS: @(#) $Id: tclUnixPipe.c,v 1.52 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclInt.h" @@ -269,6 +269,40 @@ TclpTempFileName(void) } /* + *----------------------------------------------------------------------------- + * + * TclpTempFileNameForLibrary -- + * + * Constructs a file name in the native file system where a + * dynamically loaded library may be placed. + * + * Results: + * Returns the constructed file name. If an error occurs, + * returns NULL and leaves an error message in the interpreter + * result. + * + * On Unix, it works to load a shared object from a file of any + * name, so this function is merely a thin wrapper around + * TclpTempFileName(). + * + *----------------------------------------------------------------------------- + */ + +Tcl_Obj* +TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Obj* path) /* Path name of the library + * in the VFS */ +{ + Tcl_Obj* retval; + retval = TclpTempFileName(); + if (retval == NULL) { + Tcl_AppendResult(interp, "couldn't create temporary file: ", + Tcl_PosixError(interp), NULL); + } + return retval; +} + +/* *---------------------------------------------------------------------- * * TclpCreatePipe -- diff --git a/win/Makefile.in b/win/Makefile.in index 5c6e085..0a5956a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.174 2010/03/30 14:05:53 dgp Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.175 2010/04/02 21:21:06 kennykb Exp $ VERSION = @TCL_VERSION@ @@ -585,7 +585,7 @@ install-binaries: binaries else true; \ fi; \ done; - @for i in dde1.3 reg1.2; \ + @for i in dde${DDEDOTVER} reg${REGDOTVER}; \ do \ if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index bdc62ae..606171d 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -10,11 +10,30 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinLoad.c,v 1.26 2010/03/11 15:02:33 nijtmans Exp $ + * RCS: @(#) $Id: tclWinLoad.c,v 1.27 2010/04/02 21:21:06 kennykb Exp $ */ #include "tclWinInt.h" +/* + * Mutex protecting static data in this file; + */ + +static Tcl_Mutex loadMutex; + +/* + * Name of the directory in the native filesystem where DLLs used in this + * process are copied prior to loading. + */ + +static WCHAR* dllDirectoryName = NULL; + +/* Static functions defined within this file */ + +void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, + const char* symbol); +void UnloadFile(Tcl_LoadHandle loadHandle); + /* *---------------------------------------------------------------------- @@ -47,8 +66,9 @@ TclpDlopen( * function which should be used for this * file. */ { - HINSTANCE handle; + HINSTANCE hInstance; const TCHAR *nativeName; + Tcl_LoadHandle handlePtr; /* * First try the full path the user gave us. This is particularly @@ -57,8 +77,8 @@ TclpDlopen( */ nativeName = Tcl_FSGetNativePath(pathPtr); - handle = tclWinProcs->loadLibraryProc(nativeName); - if (handle == NULL) { + hInstance = tclWinProcs->loadLibraryProc(nativeName); + if (hInstance == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the @@ -69,13 +89,11 @@ TclpDlopen( const char *fileName = Tcl_GetString(pathPtr); nativeName = tclWinProcs->utf2tchar(fileName, -1, &ds); - handle = tclWinProcs->loadLibraryProc(nativeName); + hInstance = tclWinProcs->loadLibraryProc(nativeName); Tcl_DStringFree(&ds); } - *loadHandle = (Tcl_LoadHandle) handle; - - if (handle == NULL) { + if (hInstance == NULL) { DWORD lastError = GetLastError(); #if 0 @@ -130,7 +148,13 @@ TclpDlopen( } return TCL_ERROR; } else { - *unloadProcPtr = &TclpUnloadFile; + handlePtr = + (Tcl_LoadHandle) ckalloc(sizeof(struct Tcl_LoadHandle_)); + handlePtr->clientData = (ClientData) hInstance; + handlePtr->findSymbolProcPtr = &FindSymbol; + handlePtr->unloadFileProcPtr = &UnloadFile; + *loadHandle = (Tcl_LoadHandle) handlePtr; + *unloadProcPtr = &UnloadFile; } return TCL_OK; } @@ -138,7 +162,7 @@ TclpDlopen( /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- + * FindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -151,37 +175,41 @@ TclpDlopen( *---------------------------------------------------------------------- */ -Tcl_PackageInitProc * -TclpFindSymbol( +void * +FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol) { Tcl_PackageInitProc *proc = NULL; - HINSTANCE handle = (HINSTANCE)loadHandle; + HINSTANCE hInstance = (HINSTANCE)(loadHandle->clientData); /* * For each symbol, check for both Symbol and _Symbol, since Borland * generates C symbols with a leading '_' by default. */ - proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); + proc = (void*) GetProcAddress(hInstance, symbol); if (proc == NULL) { Tcl_DString ds; - + const char* sym2; Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, "_", 1); - symbol = Tcl_DStringAppend(&ds, symbol, -1); - proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); + sym2 = Tcl_DStringAppend(&ds, symbol, -1); + proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2); Tcl_DStringFree(&ds); } + if (proc == NULL && interp != NULL) { + Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + } return proc; } /* *---------------------------------------------------------------------- * - * TclpUnloadFile -- + * UnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -197,15 +225,14 @@ TclpFindSymbol( */ void -TclpUnloadFile( +UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - HINSTANCE handle; - - handle = (HINSTANCE) loadHandle; - FreeLibrary(handle); + HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; + FreeLibrary(hInstance); + ckfree((char*) loadHandle); } /* @@ -239,6 +266,101 @@ TclGuessPackageName( } /* + *----------------------------------------------------------------------------- + * + * TclpTempFileNameForLibrary -- + * + * Constructs a temporary file name for loading a shared object (DLL). + * + * Results: + * Returns the constructed file name. + * + * On Windows, a DLL is identified by the final component of its path name. + * Cross linking among DLL's (and hence, preloading) will not work unless + * this name is preserved when copying a DLL from a VFS to a temp file for + * preloading. For this reason, all DLLs in a given process are copied + * to a temp directory, and their names are preserved. + * + *----------------------------------------------------------------------------- + */ + +Tcl_Obj* +TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Obj* path) /* Path name of the DLL in + * the VFS */ +{ + size_t nameLen; /* Length of the temp folder name */ + WCHAR name[MAX_PATH]; /* Path name of the temp folder */ + BOOL status; /* Status from Win32 API calls */ + Tcl_Obj* fileName; /* Name of the temp file */ + Tcl_Obj* tail; /* Tail of the source path */ + + /* + * Determine the name of the directory to use, and create it. + * (Keep trying with new names until an attempt to create the directory + * succeeds) + */ + + nameLen = 0; + if (dllDirectoryName == NULL) { + Tcl_MutexLock(&loadMutex); + if (dllDirectoryName == NULL) { + if ((nameLen = GetTempPathW(MAX_PATH, name)) >= 0) { + if (nameLen >= MAX_PATH-12) { + Tcl_SetErrno(ENAMETOOLONG); + nameLen = 0; + } else { + wcscpy(name+nameLen, L"TCLXXXXXXXX"); + nameLen += 11; + } + } + status = 1; + if (nameLen != 0) { + DWORD id; + int i = 0; + id = GetCurrentProcessId(); + for (;;) { + DWORD lastError; + wsprintfW(name+nameLen-8, L"%08x", id); + status = CreateDirectoryW(name, NULL); + if (status) { + break; + } + if ((lastError = GetLastError()) != ERROR_ALREADY_EXISTS) { + TclWinConvertError(lastError); + break; + } else if (++i > 256) { + TclWinConvertError(lastError); + break; + } + id *= 16777619; + } + } + if (status != 0) { + dllDirectoryName = (WCHAR*) + ckalloc((nameLen+1) * sizeof(WCHAR)); + wcscpy(dllDirectoryName, name); + } + } + Tcl_MutexUnlock(&loadMutex); + } + if (dllDirectoryName == NULL) { + Tcl_AppendResult(interp, "couldn't create temporary directory: ", + Tcl_PosixError(interp), NULL); + } + fileName = TclpNativeToNormalized((ClientData) dllDirectoryName); + tail = TclPathPart(interp, path, TCL_PATH_TAIL); + if (tail == NULL) { + Tcl_DecrRefCount(fileName); + return NULL; + } else { + Tcl_AppendToObj(fileName, "/", 1); + Tcl_AppendObjToObj(fileName, tail); + return fileName; + } +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |