X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fdl_win32.xs;h=3473520372dd3bc0dea06eda04f897b3509c63e6;hb=79cb57f6e01f91d8fff40d69caa187aaa669671b;hp=47d06c080e36548b1d7a11bc314886c2d783ea4f;hpb=0a753a764065f2260004b6e6975085378b850346;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/win32/dl_win32.xs b/win32/dl_win32.xs
index 47d06c0..3473520 100644
--- a/win32/dl_win32.xs
+++ b/win32/dl_win32.xs
@@ -18,35 +18,83 @@ calls.
 */
 
 #define WIN32_LEAN_AND_MEAN
+#ifdef __GNUC__
+#define Win32_Winsock
+#endif
 #include <windows.h>
 #include <string.h>
 
 #include "EXTERN.h"
 #include "perl.h"
+#include "win32.h"
+
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif  /* PERL_OBJECT */
+
 #include "XSUB.h"
 
+static SV *error_sv;
+
+static char *
+OS_Error_String(CPERLarg)
+{
+ DWORD err = GetLastError();
+ STRLEN len;
+ if (!error_sv)
+  error_sv = newSVpvn("",0);
+ win32_str_os_error(error_sv,err);
+ return SvPV(error_sv,len);
+}
+
 #include "dlutils.c"	/* SaveError() etc	*/
 
 static void
-dl_private_init()
+dl_private_init(CPERLarg)
 {
-    (void)dl_generic_private_init();
+    (void)dl_generic_private_init(PERL_OBJECT_THIS);
 }
 
+/* 
+    This function assumes the list staticlinkmodules
+    will be formed from package names with '::' replaced
+    with '/'. Thus Win32::OLE is in the list as Win32/OLE
+*/
 static int
 dl_static_linked(char *filename)
 {
-	char **p;
+    char **p;
+    char* ptr;
+    static char subStr[] = "/auto/";
+    char szBuffer[MAX_PATH];
+
+    /* change all the '\\' to '/' */
+    strcpy(szBuffer, filename);
+    for(ptr = szBuffer; ptr = strchr(ptr, '\\'); ++ptr)
+	*ptr = '/';
+
+    /* delete the file name */
+    ptr = strrchr(szBuffer, '/');
+    if(ptr != NULL)
+	*ptr = '\0';
+
+    /* remove leading lib path */
+    ptr = strstr(szBuffer, subStr);
+    if(ptr != NULL)
+	ptr += sizeof(subStr)-1;
+    else
+	ptr = szBuffer;
+
     for (p = staticlinkmodules; *p;p++) {
-		if (strstr(filename, *p)) return 1;
-		};
-	return 0;
+	if (strstr(ptr, *p)) return 1;
+    };
+    return 0;
 }
 
 MODULE = DynaLoader	PACKAGE = DynaLoader
 
 BOOT:
-    (void)dl_private_init();
+    (void)dl_private_init(PERL_OBJECT_THIS);
 
 void *
 dl_load_file(filename,flags=0)
@@ -54,15 +102,16 @@ dl_load_file(filename,flags=0)
     int			flags
     PREINIT:
     CODE:
-    DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
-	if (dl_static_linked(filename) == 0)
-    	RETVAL = (void*) LoadLibraryEx(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
-	else
-		RETVAL = (void*) GetModuleHandle(NULL);
-    DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL));
+    DLDEBUG(1,PerlIO_printf(PerlIO_stderr(),"dl_load_file(%s):\n", filename));
+    if (dl_static_linked(filename) == 0)
+	RETVAL = (void*) LoadLibraryEx(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
+    else
+	RETVAL = (void*) GetModuleHandle(NULL);
+    DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", RETVAL));
     ST(0) = sv_newmortal() ;
     if (RETVAL == NULL)
-	SaveError("%d",GetLastError()) ;
+	SaveError(PERL_OBJECT_THIS_ "load_file:%s",
+		  OS_Error_String(PERL_OBJECT_THIS)) ;
     else
 	sv_setiv( ST(0), (IV)RETVAL);
 
@@ -72,13 +121,14 @@ dl_find_symbol(libhandle, symbolname)
     void *	libhandle
     char *	symbolname
     CODE:
-    DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
-	libhandle, symbolname));
+    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n",
+		      libhandle, symbolname));
     RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
-    DLDEBUG(2,fprintf(stderr,"  symbolref = %x\n", RETVAL));
+    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"  symbolref = %x\n", RETVAL));
     ST(0) = sv_newmortal() ;
     if (RETVAL == NULL)
-	SaveError("%d",GetLastError()) ;
+	SaveError(PERL_OBJECT_THIS_ "find_symbol:%s",
+		  OS_Error_String(PERL_OBJECT_THIS)) ;
     else
 	sv_setiv( ST(0), (IV)RETVAL);
 
@@ -97,9 +147,9 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     void *		symref 
     char *		filename
     CODE:
-    DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
-		perl_name, symref));
-    ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n",
+		      perl_name, symref));
+    ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)(CV* _CPERLarg))symref, filename)));
 
 
 char *