This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate cfgperl contents into mainline; merge conflicts
[perl5.git] / win32 / dl_win32.xs
CommitLineData
0a753a76
PP
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
14I merely took Paul's dl_dlopen.xs, took out extraneous stuff and
15replaced the appropriate SunOS calls with the corresponding Win32
16calls.
17
18*/
19
20#define WIN32_LEAN_AND_MEAN
a835ef8a
NIS
21#ifdef __GNUC__
22#define Win32_Winsock
23#endif
0a753a76
PP
24#include <windows.h>
25#include <string.h>
26
c5be433b
GS
27#define PERL_NO_GET_CONTEXT
28
0a753a76
PP
29#include "EXTERN.h"
30#include "perl.h"
eda5ff31 31#include "win32.h"
565764a8
DL
32
33#ifdef PERL_OBJECT
34#define NO_XSLOCKS
35#endif /* PERL_OBJECT */
36
0a753a76
PP
37#include "XSUB.h"
38
eda5ff31
GS
39static SV *error_sv;
40
41static char *
0cb96387 42OS_Error_String(pTHXo)
eda5ff31
GS
43{
44 DWORD err = GetLastError();
45 STRLEN len;
46 if (!error_sv)
79cb57f6 47 error_sv = newSVpvn("",0);
0cb96387 48 PerlProc_GetOSError(error_sv,err);
eda5ff31
GS
49 return SvPV(error_sv,len);
50}
51
0a753a76
PP
52#include "dlutils.c" /* SaveError() etc */
53
54static void
0cb96387 55dl_private_init(pTHXo)
0a753a76 56{
0cb96387 57 (void)dl_generic_private_init(aTHXo);
0a753a76
PP
58}
59
26b3385c
DL
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*/
0a753a76
PP
65static int
66dl_static_linked(char *filename)
67{
68dc0745 68 char **p;
26b3385c
DL
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
0a753a76 90 for (p = staticlinkmodules; *p;p++) {
26b3385c 91 if (strstr(ptr, *p)) return 1;
68dc0745
PP
92 };
93 return 0;
0a753a76
PP
94}
95
96MODULE = DynaLoader PACKAGE = DynaLoader
97
98BOOT:
0cb96387 99 (void)dl_private_init(aTHXo);
0a753a76
PP
100
101void *
102dl_load_file(filename,flags=0)
103 char * filename
104 int flags
105 PREINIT:
106 CODE:
b9010385 107 {
bf49b057 108 DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
7fac1903 109 if (dl_static_linked(filename) == 0) {
0cb96387 110 RETVAL = PerlProc_DynaLoad(filename);
7fac1903 111 }
68dc0745
PP
112 else
113 RETVAL = (void*) GetModuleHandle(NULL);
bf49b057 114 DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", RETVAL));
0a753a76
PP
115 ST(0) = sv_newmortal() ;
116 if (RETVAL == NULL)
0cb96387
GS
117 SaveError(aTHXo_ "load_file:%s",
118 OS_Error_String(aTHXo)) ;
0a753a76
PP
119 else
120 sv_setiv( ST(0), (IV)RETVAL);
b9010385 121 }
0a753a76
PP
122
123void *
124dl_find_symbol(libhandle, symbolname)
125 void * libhandle
126 char * symbolname
127 CODE:
bf49b057 128 DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
68dc0745 129 libhandle, symbolname));
0a753a76 130 RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
bf49b057 131 DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL));
0a753a76
PP
132 ST(0) = sv_newmortal() ;
133 if (RETVAL == NULL)
0cb96387
GS
134 SaveError(aTHXo_ "find_symbol:%s",
135 OS_Error_String(aTHXo)) ;
0a753a76
PP
136 else
137 sv_setiv( ST(0), (IV)RETVAL);
138
139
140void
141dl_undef_symbols()
142 PPCODE:
143
144
145
146# These functions should not need changing on any platform:
147
148void
149dl_install_xsub(perl_name, symref, filename="$Package")
150 char * perl_name
151 void * symref
152 char * filename
153 CODE:
bf49b057 154 DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
68dc0745 155 perl_name, symref));
4f63d024 156 ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
0cb96387 157 (void(*)(pTHXo_ CV *))symref,
4f63d024 158 filename)));
0a753a76
PP
159
160
161char *
162dl_error()
163 CODE:
164 RETVAL = LastError ;
165 OUTPUT:
166 RETVAL
167
168# end.