OpenFPGA/libs/EXTERNAL/tcl8.6.12/win/tclWinLoad.c

435 lines
12 KiB
C
Raw Normal View History

2022-06-07 11:15:20 -05:00
/*
* 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 = NULL;
const WCHAR *nativeName;
Tcl_LoadHandle handlePtr;
DWORD firstError;
(void)flags;
/*
* 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 = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (nativeName != NULL) {
hInstance = LoadLibraryExW(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;
/*
* Remember the first error on load attempt to be used if the
* second load attempt below also fails.
*/
firstError = (nativeName == NULL) ?
ERROR_MOD_NOT_FOUND : GetLastError();
nativeName = (WCHAR *)Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds);
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
if (hInstance == NULL) {
DWORD lastError;
Tcl_Obj *errMsg;
/*
* We choose to only use the error from the second call if the first
* call failed due to the file not being found. Else stick to the
* first error for reporting purposes.
*/
if (firstError == ERROR_MOD_NOT_FOUND ||
firstError == ERROR_DLL_NOT_FOUND)
lastError = GetLastError();
else
lastError = firstError;
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;
case ERROR_BAD_EXE_FORMAT:
Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", NULL);
Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", -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 = (Tcl_LoadHandle)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;
void *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 = (void *)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. */
{
(void)fileName;
(void)bufPtr;
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 = (WCHAR *)ckalloc((nameLen+1) * sizeof(WCHAR));
wcscpy(dllDirectoryName, name);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/