home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / win32 / dl_win32.xs < prev    next >
Text File  |  1999-10-05  |  4KB  |  169 lines
  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.
  169.