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 GS |
27 | #define PERL_NO_GET_CONTEXT |
28 | ||
0a753a76 | 29 | #include "EXTERN.h" |
30 | #include "perl.h" | |
eda5ff31 | 31 | #include "win32.h" |
565764a8 | 32 | |
0a753a76 | 33 | #include "XSUB.h" |
34 | ||
cdc73a10 JH |
35 | typedef struct { |
36 | SV * x_error_sv; | |
37 | } my_cxtx_t; /* this *must* be named my_cxtx_t */ | |
38 | ||
39 | #define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */ | |
40 | #include "dlutils.c" /* SaveError() etc */ | |
41 | ||
42 | #define dl_error_sv (dl_cxtx.x_error_sv) | |
eda5ff31 GS |
43 | |
44 | static char * | |
acfe0abc | 45 | OS_Error_String(pTHX) |
eda5ff31 | 46 | { |
cdc73a10 JH |
47 | dMY_CXT; |
48 | DWORD err = GetLastError(); | |
49 | STRLEN len; | |
bb6a367a DD |
50 | SV ** l_dl_error_svp = &dl_error_sv; |
51 | SV * l_dl_error_sv; | |
52 | if (!*l_dl_error_svp) | |
53 | *l_dl_error_svp = newSVpvs(""); | |
54 | l_dl_error_sv = *l_dl_error_svp; | |
55 | PerlProc_GetOSError(l_dl_error_sv,err); | |
56 | return SvPV(l_dl_error_sv,len); | |
eda5ff31 GS |
57 | } |
58 | ||
0a753a76 | 59 | static void |
acfe0abc | 60 | dl_private_init(pTHX) |
0a753a76 | 61 | { |
acfe0abc | 62 | (void)dl_generic_private_init(aTHX); |
0a753a76 | 63 | } |
64 | ||
26b3385c DL |
65 | /* |
66 | This function assumes the list staticlinkmodules | |
67 | will be formed from package names with '::' replaced | |
68 | with '/'. Thus Win32::OLE is in the list as Win32/OLE | |
69 | */ | |
0a753a76 | 70 | static int |
71 | dl_static_linked(char *filename) | |
72 | { | |
6c6c7914 | 73 | const char * const *p; |
d2b25974 | 74 | char *ptr, *hptr; |
fe1c5936 | 75 | static const char subStr[] = "/auto/"; |
26b3385c DL |
76 | char szBuffer[MAX_PATH]; |
77 | ||
0e244b13 JD |
78 | /* avoid buffer overflow when called with invalid filenames */ |
79 | if (strlen(filename) >= sizeof(szBuffer)) | |
80 | return 0; | |
81 | ||
26b3385c DL |
82 | /* change all the '\\' to '/' */ |
83 | strcpy(szBuffer, filename); | |
84 | for(ptr = szBuffer; ptr = strchr(ptr, '\\'); ++ptr) | |
85 | *ptr = '/'; | |
86 | ||
87 | /* delete the file name */ | |
88 | ptr = strrchr(szBuffer, '/'); | |
89 | if(ptr != NULL) | |
90 | *ptr = '\0'; | |
91 | ||
92 | /* remove leading lib path */ | |
93 | ptr = strstr(szBuffer, subStr); | |
94 | if(ptr != NULL) | |
95 | ptr += sizeof(subStr)-1; | |
96 | else | |
97 | ptr = szBuffer; | |
98 | ||
6c6c7914 | 99 | for (p = staticlinkmodules; *p;p++) { |
d2b25974 VK |
100 | if (hptr = strstr(ptr, *p)) { |
101 | /* found substring, need more detailed check if module name match */ | |
102 | if (hptr==ptr) { | |
103 | return strcmp(ptr, *p)==0; | |
104 | } | |
105 | if (hptr[strlen(*p)] == 0) | |
106 | return hptr[-1]=='/'; | |
107 | } | |
68dc0745 | 108 | }; |
109 | return 0; | |
0a753a76 | 110 | } |
111 | ||
112 | MODULE = DynaLoader PACKAGE = DynaLoader | |
113 | ||
114 | BOOT: | |
acfe0abc | 115 | (void)dl_private_init(aTHX); |
0a753a76 | 116 | |
63d7ac5f | 117 | void |
0a753a76 | 118 | dl_load_file(filename,flags=0) |
119 | char * filename | |
bb6a367a DD |
120 | #flags is unused |
121 | SV * flags = NO_INIT | |
0a753a76 | 122 | PREINIT: |
63d7ac5f | 123 | void *retv; |
bb6a367a | 124 | SV * retsv; |
0a753a76 | 125 | CODE: |
b9010385 | 126 | { |
bb6a367a | 127 | PERL_UNUSED_VAR(flags); |
bf49b057 | 128 | DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename)); |
7fac1903 | 129 | if (dl_static_linked(filename) == 0) { |
63d7ac5f | 130 | retv = PerlProc_DynaLoad(filename); |
7fac1903 | 131 | } |
68dc0745 | 132 | else |
63d7ac5f S |
133 | retv = (void*) Win_GetModuleHandle(NULL); |
134 | DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", retv)); | |
bb6a367a DD |
135 | |
136 | if (retv == NULL) { | |
acfe0abc GS |
137 | SaveError(aTHX_ "load_file:%s", |
138 | OS_Error_String(aTHX)) ; | |
bb6a367a DD |
139 | retsv = &PL_sv_undef; |
140 | } | |
0a753a76 | 141 | else |
bb6a367a DD |
142 | retsv = sv_2mortal(newSViv((IV)retv)); |
143 | ST(0) = retsv; | |
b9010385 | 144 | } |
0a753a76 | 145 | |
6a57da86 D |
146 | int |
147 | dl_unload_file(libref) | |
148 | void * libref | |
149 | CODE: | |
150 | DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref))); | |
5c5f0d52 | 151 | RETVAL = FreeLibrary((HMODULE)libref); |
6a57da86 D |
152 | if (!RETVAL) |
153 | SaveError(aTHX_ "unload_file:%s", OS_Error_String(aTHX)) ; | |
154 | DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); | |
155 | OUTPUT: | |
156 | RETVAL | |
157 | ||
63d7ac5f | 158 | void |
0a753a76 | 159 | dl_find_symbol(libhandle, symbolname) |
160 | void * libhandle | |
161 | char * symbolname | |
63d7ac5f S |
162 | PREINIT: |
163 | void *retv; | |
0a753a76 | 164 | CODE: |
bf49b057 | 165 | DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n", |
68dc0745 | 166 | libhandle, symbolname)); |
63d7ac5f S |
167 | retv = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); |
168 | DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", retv)); | |
0a753a76 | 169 | ST(0) = sv_newmortal() ; |
63d7ac5f | 170 | if (retv == NULL) |
acfe0abc GS |
171 | SaveError(aTHX_ "find_symbol:%s", |
172 | OS_Error_String(aTHX)) ; | |
0a753a76 | 173 | else |
63d7ac5f | 174 | sv_setiv( ST(0), (IV)retv); |
0a753a76 | 175 | |
176 | ||
177 | void | |
178 | dl_undef_symbols() | |
63d7ac5f | 179 | CODE: |
0a753a76 | 180 | |
181 | ||
182 | ||
183 | # These functions should not need changing on any platform: | |
184 | ||
185 | void | |
186 | dl_install_xsub(perl_name, symref, filename="$Package") | |
187 | char * perl_name | |
188 | void * symref | |
189 | char * filename | |
190 | CODE: | |
bf49b057 | 191 | DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", |
68dc0745 | 192 | perl_name, symref)); |
4f63d024 | 193 | ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, |
acfe0abc | 194 | (void(*)(pTHX_ CV *))symref, |
4f63d024 | 195 | filename))); |
0a753a76 | 196 | |
197 | ||
bb6a367a | 198 | SV * |
0a753a76 | 199 | dl_error() |
200 | CODE: | |
cdc73a10 | 201 | dMY_CXT; |
bb6a367a | 202 | RETVAL = newSVsv(MY_CXT.x_dl_last_error); |
0a753a76 | 203 | OUTPUT: |
204 | RETVAL | |
205 | ||
8c472fc1 CB |
206 | #if defined(USE_ITHREADS) |
207 | ||
208 | void | |
209 | CLONE(...) | |
210 | CODE: | |
211 | MY_CXT_CLONE; | |
212 | ||
3bd46979 DM |
213 | PERL_UNUSED_VAR(items); |
214 | ||
8c472fc1 CB |
215 | /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid |
216 | * using Perl variables that belong to another thread, we create our | |
217 | * own for this thread. | |
218 | */ | |
c2b90b61 | 219 | MY_CXT.x_dl_last_error = newSVpvs(""); |
8c472fc1 CB |
220 | |
221 | #endif | |
222 | ||
0a753a76 | 223 | # end. |