diff options
Diffstat (limited to 'tcl8.6/win/tclWinLoad.c')
| -rw-r--r-- | tcl8.6/win/tclWinLoad.c | 402 |
1 files changed, 0 insertions, 402 deletions
diff --git a/tcl8.6/win/tclWinLoad.c b/tcl8.6/win/tclWinLoad.c deleted file mode 100644 index 26512b1..0000000 --- a/tcl8.6/win/tclWinLoad.c +++ /dev/null @@ -1,402 +0,0 @@ -/* - * tclWinLoad.c -- - * - * This function provides a version of the TclLoadFile that works with - * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic - * loading. - * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclWinInt.h" - -/* - * Native name of the directory in the native filesystem where DLLs used in - * this process are copied prior to loading, and mutex used to protect its - * allocation. - */ - -static WCHAR *dllDirectoryName = NULL; -static Tcl_Mutex dllDirectoryNameMutex; - -/* - * Static functions defined within this file. - */ - -static void * FindSymbol(Tcl_Interp *interp, - Tcl_LoadHandle loadHandle, const char *symbol); -static int InitDLLDirectoryName(void); -static void UnloadFile(Tcl_LoadHandle loadHandle); - -/* - *---------------------------------------------------------------------- - * - * TclpDlopen -- - * - * Dynamically loads a binary code file into memory and returns a handle - * to the new code. - * - * 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. - * - *---------------------------------------------------------------------- - */ - -int -TclpDlopen( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Obj *pathPtr, /* Name of the file containing the desired - * code (UTF-8). */ - Tcl_LoadHandle *loadHandle, /* 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. */ - int flags) -{ - HINSTANCE hInstance; - const TCHAR *nativeName; - Tcl_LoadHandle handlePtr; - - /* - * First try the full path the user gave us. This is particularly - * important if the cwd is inside a vfs, and we are trying to load using a - * relative path. - */ - - nativeName = Tcl_FSGetNativePath(pathPtr); - hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH); - 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 - * binary path. - */ - - Tcl_DString ds; - - nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); - hInstance = LoadLibraryEx(nativeName, NULL, - LOAD_WITH_ALTERED_SEARCH_PATH); - Tcl_DStringFree(&ds); - } - - if (hInstance == NULL) { - DWORD lastError = GetLastError(); - Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", - Tcl_GetString(pathPtr)); - - /* - * Check for possible DLL errors. This doesn't work quite right, - * because Windows seems to only return ERROR_MOD_NOT_FOUND for just - * about any problem, but it's better than nothing. It'd be even - * better if there was a way to get what DLLs - */ - - if (interp) { - switch (lastError) { - case ERROR_MOD_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL); - goto notFoundMsg; - case ERROR_DLL_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); - notFoundMsg: - Tcl_AppendToObj(errMsg, "this library or a dependent library" - " could not be found in library path", -1); - break; - case ERROR_PROC_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); - Tcl_AppendToObj(errMsg, "A function specified in the import" - " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", -1); - break; - case ERROR_INVALID_DLL: - Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); - Tcl_AppendToObj(errMsg, "this library or a dependent library" - " is damaged", -1); - break; - case ERROR_DLL_INIT_FAILED: - Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); - Tcl_AppendToObj(errMsg, "the library initialization" - " routine failed", -1); - break; - default: - TclWinConvertError(lastError); - Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); - } - Tcl_SetObjResult(interp, errMsg); - } - return TCL_ERROR; - } - - /* - * Succeded; package everything up for Tcl. - */ - - handlePtr = ckalloc(sizeof(struct Tcl_LoadHandle_)); - handlePtr->clientData = (ClientData) hInstance; - handlePtr->findSymbolProcPtr = &FindSymbol; - handlePtr->unloadFileProcPtr = &UnloadFile; - *loadHandle = handlePtr; - *unloadProcPtr = &UnloadFile; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FindSymbol -- - * - * Looks up a symbol, by name, through a handle associated with a - * previously loaded piece of code (shared library). - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static void * -FindSymbol( - Tcl_Interp *interp, - Tcl_LoadHandle loadHandle, - const char *symbol) -{ - HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; - Tcl_PackageInitProc *proc = NULL; - - /* - * For each symbol, check for both Symbol and _Symbol, since Borland - * generates C symbols with a leading '_' by default. - */ - - proc = (void *) GetProcAddress(hInstance, symbol); - if (proc == NULL) { - Tcl_DString ds; - const char *sym2; - - Tcl_DStringInit(&ds); - TclDStringAppendLiteral(&ds, "_"); - sym2 = Tcl_DStringAppend(&ds, symbol, -1); - proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2); - Tcl_DStringFree(&ds); - } - if (proc == NULL && interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot find symbol \"%s\"", symbol)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); - } - return proc; -} - -/* - *---------------------------------------------------------------------- - * - * UnloadFile -- - * - * Unloads a dynamically loaded binary code file from memory. Code - * pointers in the formerly loaded file are no longer valid after calling - * this function. - * - * Results: - * None. - * - * Side effects: - * Code removed from memory. - * - *---------------------------------------------------------------------- - */ - -static void -UnloadFile( - Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to - * TclpDlopen(). The loadHandle is a token - * that represents the loaded file. */ -{ - HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; - - FreeLibrary(hInstance); - ckfree(loadHandle); -} - -/* - *---------------------------------------------------------------------- - * - * TclGuessPackageName -- - * - * If the "load" command is invoked without providing a package name, - * this function is invoked to try to figure it out. - * - * Results: - * Always returns 0 to indicate that we couldn't figure out a package - * name; generic code will then try to guess the package from the file - * name. A return value of 1 would have meant that we figured out the - * package name and put it in bufPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGuessPackageName( - const char *fileName, /* Name of file containing package (already - * translated to local form if needed). */ - Tcl_DString *bufPtr) /* Initialized empty dstring. Append package - * name to this if possible. */ -{ - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * 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. */ -{ - Tcl_Obj *fileName; /* Name of the temp file. */ - Tcl_Obj *tail; /* Tail of the source path. */ - - Tcl_MutexLock(&dllDirectoryNameMutex); - if (dllDirectoryName == NULL) { - if (InitDLLDirectoryName() == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't create temporary directory: %s", - Tcl_PosixError(interp))); - Tcl_MutexUnlock(&dllDirectoryNameMutex); - return NULL; - } - } - Tcl_MutexUnlock(&dllDirectoryNameMutex); - - /* - * Now we know where to put temporary DLLs, construct the name. - */ - - fileName = TclpNativeToNormalized(dllDirectoryName); - tail = TclPathPart(interp, path, TCL_PATH_TAIL); - if (tail == NULL) { - Tcl_DecrRefCount(fileName); - return NULL; - } - Tcl_AppendToObj(fileName, "/", 1); - Tcl_AppendObjToObj(fileName, tail); - return fileName; -} - -/* - *---------------------------------------------------------------------- - * - * InitDLLDirectoryName -- - * - * Helper for TclpTempFileNameForLibrary; builds a temporary directory - * that is specific to the current process. Should only be called once - * per process start. Caller must hold dllDirectoryNameMutex. - * - * Results: - * Tcl result code. - * - * Side-effects: - * Creates temp directory. - * Allocates memory pointed to by dllDirectoryName. - * - *---------------------------------------------------------------------- - * [Candidate for process global?] - */ - -static int -InitDLLDirectoryName(void) -{ - size_t nameLen; /* Length of the temp folder name. */ - WCHAR name[MAX_PATH]; /* Path name of the temp folder. */ - DWORD id; /* The process id. */ - DWORD lastError; /* Last error to happen in Win API. */ - int i; - - /* - * 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 = GetTempPathW(MAX_PATH, name); - if (nameLen >= MAX_PATH-12) { - Tcl_SetErrno(ENAMETOOLONG); - return TCL_ERROR; - } - - wcscpy(name+nameLen, L"TCLXXXXXXXX"); - nameLen += 11; - - id = GetCurrentProcessId(); - lastError = ERROR_ALREADY_EXISTS; - - for (i=0 ; i<256 ; i++) { - wsprintfW(name+nameLen-8, L"%08x", id); - if (CreateDirectoryW(name, NULL)) { - /* - * Issue: we don't schedule this directory for deletion by anyone. - * Can we ask the OS to do this for us? There appears to be - * potential for using CreateFile (with the flag - * FILE_FLAG_BACKUP_SEMANTICS) and RemoveDirectory to do this... - */ - - goto copyToGlobalBuffer; - } - lastError = GetLastError(); - if (lastError != ERROR_ALREADY_EXISTS) { - break; - } - id *= 16777619; - } - - TclWinConvertError(lastError); - return TCL_ERROR; - - /* - * Store our computed value in the global. - */ - - copyToGlobalBuffer: - dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR)); - wcscpy(dllDirectoryName, name); - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |