win32/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 #include "EXTERN.h"
  28 #include "perl.h"
  29
  30 #ifdef PERL_OBJECT
  31 #define NO_XSLOCKS
  32 #endif  /* PERL_OBJECT */
  33
  34 #include "XSUB.h"
  35
  36 #include "dlutils.c"    /* SaveError() etc      */
  37
  38 static void
  39 dl_private_init(CPERLarg)
  40 {
  41     (void)dl_generic_private_init(PERL_OBJECT_THIS);
  42 }
  43
  44 /*
  45     This function assumes the list staticlinkmodules
  46     will be formed from package names with '::' replaced
  47     with '/'. Thus Win32::OLE is in the list as Win32/OLE
  48 */
  49 static int
  50 dl_static_linked(char *filename)
  51 {
  52     char **p;
  53     char* ptr;
  54     static char subStr[] = "/auto/";
  55     char szBuffer[MAX_PATH];
  56
  57     /* change all the '\\' to '/' */
  58     strcpy(szBuffer, filename);
  59     for(ptr = szBuffer; ptr = strchr(ptr, '\\'); ++ptr)
  60         *ptr = '/';
  61
  62     /* delete the file name */
  63     ptr = strrchr(szBuffer, '/');
  64     if(ptr != NULL)
  65         *ptr = '\0';
  66
  67     /* remove leading lib path */
  68     ptr = strstr(szBuffer, subStr);
  69     if(ptr != NULL)
  70         ptr += sizeof(subStr)-1;
  71     else
  72         ptr = szBuffer;
  73
  74     for (p = staticlinkmodules; *p;p++) {
  75         if (strstr(ptr, *p)) return 1;
  76     };
  77     return 0;
  78 }
  79
  80 MODULE = DynaLoader     PACKAGE = DynaLoader
  81
  82 BOOT:
  83     (void)dl_private_init(PERL_OBJECT_THIS);
  84
  85 void *
  86 dl_load_file(filename,flags=0)
  87     char *              filename
  88     int                 flags
  89     PREINIT:
  90     CODE:
  91     DLDEBUG(1,PerlIO_printf(PerlIO_stderr(),"dl_load_file(%s):\n", filename));
  92     if (dl_static_linked(filename) == 0)
  93         RETVAL = (void*) LoadLibraryEx(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
  94     else
  95         RETVAL = (void*) GetModuleHandle(NULL);
  96     DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", RETVAL));
  97     ST(0) = sv_newmortal() ;
  98     if (RETVAL == NULL)
  99         SaveError(PERL_OBJECT_THIS_ "%d",GetLastError()) ;
 100     else
 101         sv_setiv( ST(0), (IV)RETVAL);
 102
 103
 104 void *
 105 dl_find_symbol(libhandle, symbolname)
 106     void *      libhandle
 107     char *      symbolname
 108     CODE:
 109     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n",
 110                       libhandle, symbolname));
 111     RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
 112     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"  symbolref = %x\n", RETVAL));
 113     ST(0) = sv_newmortal() ;
 114     if (RETVAL == NULL)
 115         SaveError(PERL_OBJECT_THIS_ "%d",GetLastError()) ;
 116     else
 117         sv_setiv( ST(0), (IV)RETVAL);
 118
 119
 120 void
 121 dl_undef_symbols()
 122     PPCODE:
 123
 124
 125
 126 # These functions should not need changing on any platform:
 127
 128 void
 129 dl_install_xsub(perl_name, symref, filename="$Package")
 130     char *              perl_name
 131     void *              symref
 132     char *              filename
 133     CODE:
 134     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n",
 135                       perl_name, symref));
 136     ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CV* _CPERLarg))symref, filename)));
 137
 138
 139 char *
 140 dl_error()
 141     CODE:
 142     RETVAL = LastError ;
 143     OUTPUT:
 144     RETVAL
 145
 146 # end.