1 /* dl_win32.xs
2 *
3 * Platform: Win32 (Windows NT/Windows 95)
4 * Author: Wei-Yuen Tan (wyt@hip.com)
5 * Created: A warm day in June, 1995
6 *
7 * Modified:
8 * August 23rd 1995 - rewritten after losing everything when I
9 * wiped off my NT partition (eek!)
10 */
11
12 /* Porting notes:
13
14 I merely took Paul's dl_dlopen.xs, took out extraneous stuff and
15 replaced the appropriate SunOS calls with the corresponding Win32
16 calls.
17
18 */
19
20 #define WIN32_LEAN_AND_MEAN
21 #ifdef __GNUC__
22 #define Win32_Winsock
23 #endif
24 #include <windows.h>
25 #include <string.h>
26
27 #define PERL_NO_GET_CONTEXT
28 #define PERL_EXT
29 #define PERL_IN_DL_WIN32_XS
30
31 #include "EXTERN.h"
32 #include "perl.h"
33 #include "win32.h"
34
35 #include "XSUB.h"
36
37 typedef struct {
38 SV * x_error_sv;
39 } my_cxtx_t; /* this *must* be named my_cxtx_t */
40
41 #define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */
42 #include "dlutils.c" /* SaveError() etc */
43
44 #define dl_error_sv (dl_cxtx.x_error_sv)
45
46 static char *
OS_Error_String(pTHX)47 OS_Error_String(pTHX)
48 {
49 dMY_CXT;
50 DWORD err = GetLastError();
51 STRLEN len;
52 SV ** l_dl_error_svp = &dl_error_sv;
53 SV * l_dl_error_sv;
54 if (!*l_dl_error_svp)
55 *l_dl_error_svp = newSVpvs("");
56 l_dl_error_sv = *l_dl_error_svp;
57 PerlProc_GetOSError(l_dl_error_sv,err);
58 return SvPV(l_dl_error_sv,len);
59 }
60
61 static void
dl_private_init(pTHX)62 dl_private_init(pTHX)
63 {
64 (void)dl_generic_private_init(aTHX);
65 }
66
67 /*
68 This function assumes the list staticlinkmodules
69 will be formed from package names with '::' replaced
70 with '/'. Thus Win32::OLE is in the list as Win32/OLE
71 */
72 static int
dl_static_linked(char * filename)73 dl_static_linked(char *filename)
74 {
75 const char * const *p;
76 char *ptr, *hptr;
77 static const char subStr[] = "/auto/";
78 char szBuffer[MAX_PATH];
79
80 /* avoid buffer overflow when called with invalid filenames */
81 if (strlen(filename) >= sizeof(szBuffer))
82 return 0;
83
84 /* change all the '\\' to '/' */
85 my_strlcpy(szBuffer, filename, sizeof(szBuffer));
86 for(ptr = szBuffer; ptr = strchr(ptr, '\\'); ++ptr)
87 *ptr = '/';
88
89 /* delete the file name */
90 ptr = strrchr(szBuffer, '/');
91 if(ptr != NULL)
92 *ptr = '\0';
93
94 /* remove leading lib path */
95 ptr = strstr(szBuffer, subStr);
96 if(ptr != NULL)
97 ptr += sizeof(subStr)-1;
98 else
99 ptr = szBuffer;
100
101 for (p = staticlinkmodules; *p;p++) {
102 if (hptr = strstr(ptr, *p)) {
103 /* found substring, need more detailed check if module name match */
104 if (hptr==ptr) {
105 return strEQ(ptr, *p);
106 }
107 if (hptr[strlen(*p)] == 0)
108 return hptr[-1]=='/';
109 }
110 };
111 return 0;
112 }
113
114 MODULE = DynaLoader PACKAGE = DynaLoader
115
116 BOOT:
117 (void)dl_private_init(aTHX);
118
119 void
120 dl_load_file(filename,flags=0)
121 char * filename
122 #flags is unused
123 SV * flags = NO_INIT
124 PREINIT:
125 void *retv;
126 SV * retsv;
127 CODE:
128 {
129 PERL_UNUSED_VAR(flags);
130 DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
131 if (dl_static_linked(filename) == 0) {
132 retv = PerlProc_DynaLoad(filename);
133 }
134 else
135 retv = (void*) Win_GetModuleHandle(NULL);
136 DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", retv));
137
138 if (retv == NULL) {
139 SaveError(aTHX_ "load_file:%s",
140 OS_Error_String(aTHX)) ;
141 retsv = &PL_sv_undef;
142 }
143 else
144 retsv = sv_2mortal(newSViv((IV)retv));
145 ST(0) = retsv;
146 }
147
148 int
149 dl_unload_file(libref)
150 void * libref
151 CODE:
152 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref)));
153 RETVAL = FreeLibrary((HMODULE)libref);
154 if (!RETVAL)
155 SaveError(aTHX_ "unload_file:%s", OS_Error_String(aTHX)) ;
156 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL));
157 OUTPUT:
158 RETVAL
159
160 void
161 dl_find_symbol(libhandle, symbolname, ign_err=0)
162 void * libhandle
163 char * symbolname
164 int ign_err
165 PREINIT:
166 void *retv;
167 CODE:
168 DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
169 libhandle, symbolname));
170 retv = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
171 DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", retv));
172 ST(0) = sv_newmortal();
173 if (retv == NULL) {
174 if (!ign_err) SaveError(aTHX_ "find_symbol:%s", OS_Error_String(aTHX));
175 } else
176 sv_setiv( ST(0), (IV)retv);
177
178
179 void
180 dl_undef_symbols()
181 CODE:
182
183
184
185 # These functions should not need changing on any platform:
186
187 void
188 dl_install_xsub(perl_name, symref, filename="$Package")
189 char * perl_name
190 void * symref
191 const char * filename
192 CODE:
193 DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
194 perl_name, symref));
195 ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
196 (void(*)(pTHX_ CV *))symref,
197 filename)));
198
199
200 SV *
201 dl_error()
202 CODE:
203 dMY_CXT;
204 RETVAL = newSVsv(MY_CXT.x_dl_last_error);
205 OUTPUT:
206 RETVAL
207
208 #if defined(USE_ITHREADS)
209
210 void
211 CLONE(...)
212 CODE:
213 MY_CXT_CLONE;
214
215 PERL_UNUSED_VAR(items);
216
217 /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
218 * using Perl variables that belong to another thread, we create our
219 * own for this thread.
220 */
221 MY_CXT.x_dl_last_error = newSVpvs("");
222
223 #endif
224
225 # end.
226