Tcl Source Code

Check-in [6325d5dbea]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:more result generation conversion
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 6325d5dbeac6f91d28d61ac23d02a58d5c182d0f
User & Date: dkf 2012-08-04 13:04:41
References
2012-08-27
17:12
Followup to [6325d5dbeac6f91d28d6]. dlerror() may return NULL. Fixed the code which wasn't prepared ... check-in: d17e59a33e user: andreask tags: trunk
Context
2012-08-04
18:54
Unbreak. check-in: 5047d34050 user: stwo tags: trunk
13:04
more result generation conversion check-in: 6325d5dbea user: dkf tags: trunk
12:09
Reduce the amount of ifdeffery somewhat by requiring at least OSX Tiger. That's now everyone we care... check-in: 1a67b9c45a user: dkf tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to unix/tclLoadDl.c.

108
109
110
111
112
113
114

115
116
117
118
119
120
121
122
123
	/*
	 * Write the string to a variable first to work around a compiler bug
	 * in the Sun Forte 6 compiler. [Bug 1503729]
	 */

	const char *errorStr = dlerror();


	Tcl_AppendResult(interp, "couldn't load file \"",
		Tcl_GetString(pathPtr), "\": ", errorStr, NULL);
	return TCL_ERROR;
    }
    newHandle = ckalloc(sizeof(*newHandle));
    newHandle->clientData = handle;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *unloadProcPtr = &UnloadFile;







>
|
|







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
	/*
	 * Write the string to a variable first to work around a compiler bug
	 * in the Sun Forte 6 compiler. [Bug 1503729]
	 */

	const char *errorStr = dlerror();

	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't load file \"%s\": %s",
		Tcl_GetString(pathPtr), errorStr));
	return TCL_ERROR;
    }
    newHandle = ckalloc(sizeof(*newHandle));
    newHandle->clientData = handle;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *unloadProcPtr = &UnloadFile;
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
	TclDStringAppendLiteral(&newName, "_");
	native = Tcl_DStringAppend(&newName, native, -1);
	proc = dlsym(handle, native);	/* INTL: Native. */
	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;
}

/*







|
|
<







172
173
174
175
176
177
178
179
180

181
182
183
184
185
186
187
	TclDStringAppendLiteral(&newName, "_");
	native = Tcl_DStringAppend(&newName, native, -1);
	proc = dlsym(handle, native);	/* INTL: Native. */
	Tcl_DStringFree(&newName);
    }
    Tcl_DStringFree(&ds);
    if (proc == NULL && interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"cannot find symbol \"%s\": %s", symbol, dlerror());

	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
		NULL);
    }
    return proc;
}

/*

Changes to unix/tclLoadNext.c.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

#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);


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle







|
|
|
<







12
13
14
15
16
17
18
19
20
21

22
23
24
25
26
27
28

#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);


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns a handle
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
	Tcl_DStringFree(&ds);
    }

    if (!result) {
	char *data;
	int len, maxlen;

	NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		data, NULL);
	NXCloseMemory(errorStream, NX_FREEBUFFER);
	return TCL_ERROR;
    }
    NXCloseMemory(errorStream, NX_FREEBUFFER);

    newHandle = ckalloc(sizeof(*newHandle));
    newHandle->clientData = INT2PTR(1);
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *loadHandle = newHandle;
    *unloadProcPtr = &UnloadFile;

    return TCL_OK;







|
|
|





|







88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
	Tcl_DStringFree(&ds);
    }

    if (!result) {
	char *data;
	int len, maxlen;

	NXGetMemoryBuffer(errorStream, &data, &len, &maxlen);
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't load file \"%s\": %s", fileName, data));
	NXCloseMemory(errorStream, NX_FREEBUFFER);
	return TCL_ERROR;
    }
    NXCloseMemory(errorStream, NX_FREEBUFFER);

    newHandle = ckalloc(sizeof(Tcl_LoadHandle));
    newHandle->clientData = INT2PTR(1);
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = &UnloadFile;
    *loadHandle = newHandle;
    *unloadProcPtr = &UnloadFile;

    return TCL_OK;
123
124
125
126
127
128
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
 *	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)
{
    Tcl_PackageInitProc *proc = NULL;

    if (symbol) {
	char sym[strlen(symbol) + 2];

	sym[0] = '_';
	sym[1] = 0;
	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;
}

/*
 *----------------------------------------------------------------------







|






>
|





|


|
|
<







122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147

148
149
150
151
152
153
154
 *	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)
{
    Tcl_PackageInitProc *proc = NULL;
 
   if (symbol) {
	char sym[strlen(symbol) + 2];

	sym[0] = '_';
	sym[1] = 0;
	strcat(sym, symbol);
	rld_lookup(NULL, sym, (unsigned long *) &proc);
    }
    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;
}

/*
 *----------------------------------------------------------------------

Changes to unix/tclLoadOSF.c.

99
100
101
102
103
104
105

106
107
108
109
110
111
112
113
114

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
	Tcl_DStringFree(&ds);
    }

    if (lm == LDR_NULL_MODULE) {

	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		Tcl_PosixError(interp), NULL);
	return TCL_ERROR;
    }

    *clientDataPtr = NULL;

    /*
     * My convention is to use a [OSF loader] package name the same as shlib,







>
|
|







99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
	Tcl_DStringFree(&ds);
    }

    if (lm == LDR_NULL_MODULE) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't load file \"%s\": %s",
		fileName, Tcl_PosixError(interp));
	return TCL_ERROR;
    }

    *clientDataPtr = NULL;

    /*
     * My convention is to use a [OSF loader] package name the same as shlib,
151
152
153
154
155
156
157
158

159
160
161
162
163
164
165
166
167
168

static void *
FindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    const char *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;
}

/*
 *----------------------------------------------------------------------







|
>

|
|







152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170

static void *
FindSymbol(
    Tcl_Interp *interp,
    Tcl_LoadHandle loadHandle,
    const char *symbol)
{
    void *retval = ldr_lookup_package((char *) loadHandle, symbol);

    if (retval == NULL && interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"cannot find symbol \"%s\"", symbol));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
    }
    return retval;
}

/*
 *----------------------------------------------------------------------

Changes to unix/tclLoadShl.c.

96
97
98
99
100
101
102

103
104
105
106
107
108
109
110
111

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
	Tcl_DStringFree(&ds);
    }

    if (handle == NULL) {

	Tcl_AppendResult(interp, "couldn't load file \"", fileName, "\": ",
		Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }
    newHandle = ckalloc(sizeof(*newHandle));
    newHandle->clientData = handle;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
    *loadHandle = newHandle;







>
|
|







96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112

	native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
	handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
	Tcl_DStringFree(&ds);
    }

    if (handle == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"couldn't load file \"%s\": %s",
		fileName, Tcl_PosixError(interp)));
	return TCL_ERROR;
    }
    newHandle = ckalloc(sizeof(*newHandle));
    newHandle->clientData = handle;
    newHandle->findSymbolProcPtr = &FindSymbol;
    newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
    *loadHandle = newHandle;
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
	    proc = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    if (proc == NULL && interp != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "cannot find symbol\"", symbol, "\": ",
		Tcl_PosixError(interp), NULL);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *







|
|
|







152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
	    proc = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    if (proc == NULL && interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"cannot find symbol \"%s\": %s",
		symbol, Tcl_PosixError(interp)));
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *

Changes to win/tclWinLoad.c.

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

135
136
137
138
139
140
141
	hInstance = LoadLibraryEx(nativeName, NULL,
		LOAD_WITH_ALTERED_SEARCH_PATH);
	Tcl_DStringFree(&ds);
    }

    if (hInstance == NULL) {
	DWORD lastError = GetLastError();

	Tcl_AppendResult(interp, "couldn't load library \"",
		Tcl_GetString(pathPtr), "\": ", NULL);

	/*
	 * 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
	 */

	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_AppendResult(interp, "this library or a dependent library"
		    " could not be found in library path", NULL);
	    break;
	case ERROR_PROC_NOT_FOUND:
	    Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL);
	    Tcl_AppendResult(interp, "A function specified in the import"
		    " table could not be resolved by the system.  Windows"
		    " is not telling which one, I'm sorry.", NULL);
	    break;
	case ERROR_INVALID_DLL:
	    Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL);
	    Tcl_AppendResult(interp, "this library or a dependent library"
		    " is damaged", NULL);
	    break;
	case ERROR_DLL_INIT_FAILED:
	    Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL);
	    Tcl_AppendResult(interp, "the library initialization"
		    " routine failed", NULL);
	    break;
	default:
	    TclWinConvertError(lastError);
	    Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL);
	}

	return TCL_ERROR;
    }

    /*
     * Succeded; package everything up for Tcl.
     */








<
|
|















|
|



|
|
|



|
|



|
|



|

>







87
88
89
90
91
92
93

94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
	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
	 */

	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.
     */

186
187
188
189
190
191
192

193
194
195
196
197
198
199
200
	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_AppendResult(interp, "cannot find symbol \"", symbol, "\"", NULL);
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------







>
|







186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
	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;
}

/*
 *----------------------------------------------------------------------
282
283
284
285
286
287
288

289
290
291
292
293
294
295
296
297
{
    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_AppendResult(interp, "couldn't create temporary directory: ",
		    Tcl_PosixError(interp), NULL);
	    Tcl_MutexUnlock(&dllDirectoryNameMutex);
	    return NULL;
	}
    }
    Tcl_MutexUnlock(&dllDirectoryNameMutex);

    /*







>
|
|







283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
{
    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);

    /*