This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
34dbb4ee1780b3dcf21dd4665ade9e5233d81f92
[perl5.git] / 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(PerlIO_stderr(),"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(PerlIO_stderr()," 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(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n",
129                       libhandle, symbolname));
130     RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
131     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"  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(PerlIO_stderr(),"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.