1 /*
2 * tclLoadNext.c --
3 *
4 * This procedure provides a version of the TclLoadFile that works with
5 * NeXTs rld_* dynamic loading. This file provided by Pedja Bogdanovich.
6 *
7 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
8 *
9 * See the file "license.terms" for information on usage and redistribution
10 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 */
12
13 #include "tclInt.h"
14 #include <mach-o/rld.h>
15 #include <streams/streams.h>
16
17 /* Static procedures defined within this file */
18
19 static void * FindSymbol(Tcl_Interp *interp,
20 Tcl_LoadHandle loadHandle, const char* symbol);
21 static void UnloadFile(Tcl_LoadHandle loadHandle);
22
23 /*
24 *----------------------------------------------------------------------
25 *
26 * TclpDlopen --
27 *
28 * Dynamically loads a binary code file into memory and returns a handle
29 * to the new code.
30 *
31 * Results:
32 * A standard Tcl completion code. If an error occurs, an error message
33 * is left in the interp's result.
34 *
35 * Side effects:
36 * New code suddenly appears in memory.
37 *
38 *----------------------------------------------------------------------
39 */
40
41 int
TclpDlopen(Tcl_Interp * interp,Tcl_Obj * pathPtr,Tcl_LoadHandle * loadHandle,Tcl_FSUnloadFileProc ** unloadProcPtr,int flags)42 TclpDlopen(
43 Tcl_Interp *interp, /* Used for error reporting. */
44 Tcl_Obj *pathPtr, /* Name of the file containing the desired
45 * code (UTF-8). */
46 Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
47 * file which will be passed back to
48 * (*unloadProcPtr)() to unload the file. */
49 Tcl_FSUnloadFileProc **unloadProcPtr,
50 /* Filled with address of Tcl_FSUnloadFileProc
51 * function which should be used for this
52 * file. */
53 int flags)
54 {
55 Tcl_LoadHandle newHandle;
56 struct mach_header *header;
57 char *fileName;
58 char *files[2];
59 const char *native;
60 int result = 1;
61
62 NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);
63
64 fileName = Tcl_GetString(pathPtr);
65
66 /*
67 * First try the full path the user gave us. This is particularly
68 * important if the cwd is inside a vfs, and we are trying to load using a
69 * relative path.
70 */
71
72 native = Tcl_FSGetNativePath(pathPtr);
73 files = {native,NULL};
74
75 result = rld_load(errorStream, &header, files, NULL);
76
77 if (!result) {
78 /*
79 * Let the OS loader examine the binary search path for whatever
80 * string the user gave us which hopefully refers to a file on the
81 * binary path
82 */
83
84 Tcl_DString ds;
85
86 native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
87 files = {native,NULL};
88 result = rld_load(errorStream, &header, files, NULL);
89 Tcl_DStringFree(&ds);
90 }
91
92 if (!result) {
93 char *data;
94 int len, maxlen;
95
96 NXGetMemoryBuffer(errorStream, &data, &len, &maxlen);
97 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
98 "couldn't load file \"%s\": %s", fileName, data));
99 NXCloseMemory(errorStream, NX_FREEBUFFER);
100 return TCL_ERROR;
101 }
102 NXCloseMemory(errorStream, NX_FREEBUFFER);
103
104 newHandle = ckalloc(sizeof(Tcl_LoadHandle));
105 newHandle->clientData = INT2PTR(1);
106 newHandle->findSymbolProcPtr = &FindSymbol;
107 newHandle->unloadFileProcPtr = &UnloadFile;
108 *loadHandle = newHandle;
109 *unloadProcPtr = &UnloadFile;
110
111 return TCL_OK;
112 }
113
114 /*
115 *----------------------------------------------------------------------
116 *
117 * FindSymbol --
118 *
119 * Looks up a symbol, by name, through a handle associated with a
120 * previously loaded piece of code (shared library).
121 *
122 * Results:
123 * Returns a pointer to the function associated with 'symbol' if it is
124 * found. Otherwise returns NULL and may leave an error message in the
125 * interp's result.
126 *
127 *----------------------------------------------------------------------
128 */
129
130 static void *
FindSymbol(Tcl_Interp * interp,Tcl_LoadHandle loadHandle,const char * symbol)131 FindSymbol(
132 Tcl_Interp *interp,
133 Tcl_LoadHandle loadHandle,
134 const char *symbol)
135 {
136 Tcl_PackageInitProc *proc = NULL;
137
138 if (symbol) {
139 char sym[strlen(symbol) + 2];
140
141 sym[0] = '_';
142 sym[1] = 0;
143 strcat(sym, symbol);
144 rld_lookup(NULL, sym, (unsigned long *) &proc);
145 }
146 if (proc == NULL && interp != NULL) {
147 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
148 "cannot find symbol \"%s\"", symbol));
149 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
150 }
151 return proc;
152 }
153
154 /*
155 *----------------------------------------------------------------------
156 *
157 * UnloadFile --
158 *
159 * Unloads a dynamically loaded binary code file from memory. Code
160 * pointers in the formerly loaded file are no longer valid after calling
161 * this function.
162 *
163 * Results:
164 * None.
165 *
166 * Side effects:
167 * Does nothing. Can anything be done?
168 *
169 *----------------------------------------------------------------------
170 */
171
172 void
UnloadFile(Tcl_LoadHandle loadHandle)173 UnloadFile(
174 Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
175 * TclpDlopen(). The loadHandle is a token
176 * that represents the loaded file. */
177 {
178 ckfree(loadHandle);
179 }
180
181 /*
182 *----------------------------------------------------------------------
183 *
184 * TclGuessPackageName --
185 *
186 * If the "load" command is invoked without providing a package name,
187 * this procedure is invoked to try to figure it out.
188 *
189 * Results:
190 * Always returns 0 to indicate that we couldn't figure out a package
191 * name; generic code will then try to guess the package from the file
192 * name. A return value of 1 would have meant that we figured out the
193 * package name and put it in bufPtr.
194 *
195 * Side effects:
196 * None.
197 *
198 *----------------------------------------------------------------------
199 */
200
201 int
TclGuessPackageName(const char * fileName,Tcl_DString * bufPtr)202 TclGuessPackageName(
203 const char *fileName, /* Name of file containing package (already
204 * translated to local form if needed). */
205 Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
206 * name to this if possible. */
207 {
208 return 0;
209 }
210
211 /*
212 * Local Variables:
213 * mode: c
214 * c-basic-offset: 4
215 * fill-column: 78
216 * End:
217 */
218