perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

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