Commit | Line | Data |
---|---|---|
0a753a76 | 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 | |
a835ef8a NIS |
21 | #ifdef __GNUC__ |
22 | #define Win32_Winsock | |
23 | #endif | |
0a753a76 | 24 | #include <windows.h> |
25 | #include <string.h> | |
26 | ||
c5be433b | 27 | #define PERL_NO_GET_CONTEXT |
73e43954 | 28 | #define PERL_EXT |
d96ba2c4 | 29 | #define PERL_IN_DL_WIN32_XS |
c5be433b | 30 | |
0a753a76 | 31 | #include "EXTERN.h" |
32 | #include "perl.h" | |
eda5ff31 | 33 | #include "win32.h" |
565764a8 | 34 | |
0a753a76 | 35 | #include "XSUB.h" |
36 | ||
cdc73a10 JH |
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) | |
eda5ff31 GS |
45 | |
46 | static char * | |
acfe0abc | 47 | OS_Error_String(pTHX) |
eda5ff31 | 48 | { |
cdc73a10 JH |
49 | dMY_CXT; |
50 | DWORD err = GetLastError(); | |
51 | STRLEN len; | |
bb6a367a DD |
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); | |
eda5ff31 GS |
59 | } |
60 | ||
0a753a76 | 61 | static void |
acfe0abc | 62 | dl_private_init(pTHX) |
0a753a76 | 63 | { |
acfe0abc | 64 | (void)dl_generic_private_init(aTHX); |
0a753a76 | 65 | } |
66 | ||
26b3385c DL |
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 | */ | |
0a753a76 | 72 | static int |
73 | dl_static_linked(char *filename) | |
74 | { | |
6c6c7914 | 75 | const char * const *p; |
d2b25974 | 76 | char *ptr, *hptr; |
fe1c5936 | 77 | static const char subStr[] = "/auto/"; |
26b3385c DL |
78 | char szBuffer[MAX_PATH]; |
79 | ||
0e244b13 JD |
80 | /* avoid buffer overflow when called with invalid filenames */ |
81 | if (strlen(filename) >= sizeof(szBuffer)) | |
82 | return 0; | |
83 | ||
26b3385c DL |
84 | /* change all the '\\' to '/' */ |
85 | strcpy(szBuffer, filename); | |
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 | ||
6c6c7914 | 101 | for (p = staticlinkmodules; *p;p++) { |
d2b25974 VK |
102 | if (hptr = strstr(ptr, *p)) { |
103 | /* found substring, need more detailed check if module name match */ | |
104 | if (hptr==ptr) { | |
105 | return strcmp(ptr, *p)==0; | |
106 | } | |
107 | if (hptr[strlen(*p)] == 0) | |
108 | return hptr[-1]=='/'; | |
109 | } | |
68dc0745 | 110 | }; |
111 | return 0; | |
0a753a76 | 112 | } |
113 | ||
114 | MODULE = DynaLoader PACKAGE = DynaLoader | |
115 | ||
116 | BOOT: | |
acfe0abc | 117 | (void)dl_private_init(aTHX); |
0a753a76 | 118 | |
63d7ac5f | 119 | void |
0a753a76 | 120 | dl_load_file(filename,flags=0) |
121 | char * filename | |
bb6a367a DD |
122 | #flags is unused |
123 | SV * flags = NO_INIT | |
0a753a76 | 124 | PREINIT: |
63d7ac5f | 125 | void *retv; |
bb6a367a | 126 | SV * retsv; |
0a753a76 | 127 | CODE: |
b9010385 | 128 | { |
bb6a367a | 129 | PERL_UNUSED_VAR(flags); |
bf49b057 | 130 | DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename)); |
7fac1903 | 131 | if (dl_static_linked(filename) == 0) { |
63d7ac5f | 132 | retv = PerlProc_DynaLoad(filename); |
7fac1903 | 133 | } |
68dc0745 | 134 | else |
63d7ac5f S |
135 | retv = (void*) Win_GetModuleHandle(NULL); |
136 | DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", retv)); | |
bb6a367a DD |
137 | |
138 | if (retv == NULL) { | |
acfe0abc GS |
139 | SaveError(aTHX_ "load_file:%s", |
140 | OS_Error_String(aTHX)) ; | |
bb6a367a DD |
141 | retsv = &PL_sv_undef; |
142 | } | |
0a753a76 | 143 | else |
bb6a367a DD |
144 | retsv = sv_2mortal(newSViv((IV)retv)); |
145 | ST(0) = retsv; | |
b9010385 | 146 | } |
0a753a76 | 147 | |
6a57da86 D |
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))); | |
5c5f0d52 | 153 | RETVAL = FreeLibrary((HMODULE)libref); |
6a57da86 D |
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 | ||
63d7ac5f | 160 | void |
fd46a708 | 161 | dl_find_symbol(libhandle, symbolname, ign_err=0) |
0a753a76 | 162 | void * libhandle |
163 | char * symbolname | |
fd46a708 | 164 | int ign_err |
63d7ac5f S |
165 | PREINIT: |
166 | void *retv; | |
0a753a76 | 167 | CODE: |
bf49b057 | 168 | DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n", |
68dc0745 | 169 | libhandle, symbolname)); |
63d7ac5f S |
170 | retv = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); |
171 | DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", retv)); | |
fd46a708 RU |
172 | ST(0) = sv_newmortal(); |
173 | if (retv == NULL) { | |
174 | if (!ign_err) SaveError(aTHX_ "find_symbol:%s", OS_Error_String(aTHX)); | |
175 | } else | |
63d7ac5f | 176 | sv_setiv( ST(0), (IV)retv); |
0a753a76 | 177 | |
178 | ||
179 | void | |
180 | dl_undef_symbols() | |
63d7ac5f | 181 | CODE: |
0a753a76 | 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 | char * filename | |
192 | CODE: | |
bf49b057 | 193 | DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", |
68dc0745 | 194 | perl_name, symref)); |
4f63d024 | 195 | ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, |
acfe0abc | 196 | (void(*)(pTHX_ CV *))symref, |
4f63d024 | 197 | filename))); |
0a753a76 | 198 | |
199 | ||
bb6a367a | 200 | SV * |
0a753a76 | 201 | dl_error() |
202 | CODE: | |
cdc73a10 | 203 | dMY_CXT; |
bb6a367a | 204 | RETVAL = newSVsv(MY_CXT.x_dl_last_error); |
0a753a76 | 205 | OUTPUT: |
206 | RETVAL | |
207 | ||
8c472fc1 CB |
208 | #if defined(USE_ITHREADS) |
209 | ||
210 | void | |
211 | CLONE(...) | |
212 | CODE: | |
213 | MY_CXT_CLONE; | |
214 | ||
3bd46979 DM |
215 | PERL_UNUSED_VAR(items); |
216 | ||
8c472fc1 CB |
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 | */ | |
c2b90b61 | 221 | MY_CXT.x_dl_last_error = newSVpvs(""); |
8c472fc1 CB |
222 | |
223 | #endif | |
224 | ||
0a753a76 | 225 | # end. |