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