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 * 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 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 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 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