ext/DynaLoader/dl_win32.xs

   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     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
 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 strcmp(ptr, *p)==0;
 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.