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