Commit | Line | Data |
---|---|---|
e1caacb4 JH |
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 | ||
29 | #include "EXTERN.h" | |
30 | #include "perl.h" | |
31 | #include "win32.h" | |
32 | ||
e1caacb4 JH |
33 | #include "XSUB.h" |
34 | ||
c8c3aaef JH |
35 | typedef struct { |
36 | SV * x_error_sv; | |
37 | } my_cxtx_t; /* this *must* be named my_cxtx_t */ | |
e1caacb4 | 38 | |
c8c3aaef JH |
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) | |
43 | ||
e1caacb4 | 44 | static char * |
acfe0abc | 45 | OS_Error_String(pTHX) |
e1caacb4 | 46 | { |
c8c3aaef JH |
47 | dMY_CXT; |
48 | DWORD err = GetLastError(); | |
49 | STRLEN len; | |
50 | if (!dl_error_sv) | |
51 | dl_error_sv = newSVpvn("",0); | |
52 | PerlProc_GetOSError(dl_error_sv,err); | |
53 | return SvPV(dl_error_sv,len); | |
e1caacb4 JH |
54 | } |
55 | ||
e1caacb4 | 56 | static void |
acfe0abc | 57 | dl_private_init(pTHX) |
e1caacb4 | 58 | { |
acfe0abc | 59 | (void)dl_generic_private_init(aTHX); |
e1caacb4 JH |
60 | } |
61 | ||
62 | /* | |
63 | This function assumes the list staticlinkmodules | |
64 | will be formed from package names with '::' replaced | |
65 | with '/'. Thus Win32::OLE is in the list as Win32/OLE | |
66 | */ | |
67 | static int | |
68 | dl_static_linked(char *filename) | |
69 | { | |
70 | char **p; | |
71 | char* ptr; | |
72 | static char subStr[] = "/auto/"; | |
73 | char szBuffer[MAX_PATH]; | |
74 | ||
75 | /* change all the '\\' to '/' */ | |
76 | strcpy(szBuffer, filename); | |
77 | for(ptr = szBuffer; ptr = strchr(ptr, '\\'); ++ptr) | |
78 | *ptr = '/'; | |
79 | ||
80 | /* delete the file name */ | |
81 | ptr = strrchr(szBuffer, '/'); | |
82 | if(ptr != NULL) | |
83 | *ptr = '\0'; | |
84 | ||
85 | /* remove leading lib path */ | |
86 | ptr = strstr(szBuffer, subStr); | |
87 | if(ptr != NULL) | |
88 | ptr += sizeof(subStr)-1; | |
89 | else | |
90 | ptr = szBuffer; | |
91 | ||
92 | for (p = staticlinkmodules; *p;p++) { | |
93 | if (strstr(ptr, *p)) return 1; | |
94 | }; | |
95 | return 0; | |
96 | } | |
97 | ||
98 | MODULE = DynaLoader PACKAGE = DynaLoader | |
99 | ||
100 | BOOT: | |
acfe0abc | 101 | (void)dl_private_init(aTHX); |
e1caacb4 JH |
102 | |
103 | void * | |
104 | dl_load_file(filename,flags=0) | |
105 | char * filename | |
106 | int flags | |
107 | PREINIT: | |
108 | CODE: | |
109 | { | |
110 | DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename)); | |
111 | if (dl_static_linked(filename) == 0) { | |
112 | RETVAL = PerlProc_DynaLoad(filename); | |
113 | } | |
114 | else | |
115 | RETVAL = (void*) XCEGetModuleHandleA(NULL); | |
116 | DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", RETVAL)); | |
117 | ST(0) = sv_newmortal() ; | |
118 | if (RETVAL == NULL) | |
acfe0abc GS |
119 | SaveError(aTHX_ "load_file:%s", |
120 | OS_Error_String(aTHX)) ; | |
e1caacb4 JH |
121 | else |
122 | sv_setiv( ST(0), (IV)RETVAL); | |
123 | } | |
124 | ||
125 | void * | |
126 | dl_find_symbol(libhandle, symbolname) | |
127 | void * libhandle | |
128 | char * symbolname | |
129 | CODE: | |
130 | DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n", | |
131 | libhandle, symbolname)); | |
132 | RETVAL = (void*) XCEGetProcAddressA((HINSTANCE) libhandle, symbolname); | |
133 | DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL)); | |
134 | ST(0) = sv_newmortal() ; | |
135 | if (RETVAL == NULL) | |
acfe0abc GS |
136 | SaveError(aTHX_ "find_symbol:%s", |
137 | OS_Error_String(aTHX)) ; | |
e1caacb4 JH |
138 | else |
139 | sv_setiv( ST(0), (IV)RETVAL); | |
140 | ||
141 | ||
142 | void | |
143 | dl_undef_symbols() | |
144 | PPCODE: | |
145 | ||
146 | ||
147 | ||
148 | # These functions should not need changing on any platform: | |
149 | ||
150 | void | |
151 | dl_install_xsub(perl_name, symref, filename="$Package") | |
152 | char * perl_name | |
153 | void * symref | |
154 | char * filename | |
155 | CODE: | |
156 | DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", | |
157 | perl_name, symref)); | |
158 | ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, | |
acfe0abc | 159 | (void(*)(pTHX_ CV *))symref, |
e1caacb4 JH |
160 | filename))); |
161 | ||
162 | ||
163 | char * | |
164 | dl_error() | |
165 | CODE: | |
c8c3aaef JH |
166 | dMY_CXT; |
167 | RETVAL = dl_last_error; | |
e1caacb4 JH |
168 | OUTPUT: |
169 | RETVAL | |
170 | ||
171 | # end. |