This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make die/warn and other diagnostics go to wherever STDERR happens
[perl5.git] / ext / DynaLoader / dl_cygwin.xs
1 /* dl_cygwin.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 /* Modified from the original dl_win32.xs to work with cygwin
12    -John Cerney 3/26/97
13 */
14 /* Porting notes:
15
16 I merely took Paul's dl_dlopen.xs, took out extraneous stuff and
17 replaced the appropriate SunOS calls with the corresponding Win32
18 calls.
19
20 */
21
22 #define WIN32_LEAN_AND_MEAN
23 // Defines from windows needed for this function only. Can't include full
24 //  Cygwin windows headers because of problems with CONTEXT redefinition
25 //  Removed logic to tell not dynamically load static modules. It is assumed that all
26 //   modules are dynamically built. This should be similar to the behavoir on sunOS.
27 //   Leaving in the logic would have required changes to the standard perlmain.c code
28 //
29 #include <stdio.h>
30
31 //#include <windows.h>
32 #define LOAD_WITH_ALTERED_SEARCH_PATH   (8)
33 typedef void *HANDLE;
34 typedef HANDLE HINSTANCE;
35 #define STDCALL     __attribute__ ((stdcall))
36 typedef int STDCALL (*FARPROC)();
37 #define MAX_PATH        260
38
39 HINSTANCE
40 STDCALL
41 LoadLibraryExA(
42                char* lpLibFileName,
43                HANDLE hFile,
44                unsigned int dwFlags
45                );
46 unsigned int
47 STDCALL
48 GetLastError(
49              void
50              );
51 FARPROC
52 STDCALL
53 GetProcAddress(
54                HINSTANCE hModule,
55                char* lpProcName
56                );
57
58 #include <string.h>
59
60 #include "EXTERN.h"
61 #include "perl.h"
62 #include "XSUB.h"
63
64 #include "dlutils.c"    /* SaveError() etc      */
65
66 static void
67 dl_private_init(pTHX)
68 {
69     (void)dl_generic_private_init(aTHX);
70 }
71
72
73 MODULE = DynaLoader     PACKAGE = DynaLoader
74
75 BOOT:
76     (void)dl_private_init(aTHX);
77
78 void *
79 dl_load_file(filename,flags=0)
80     char *              filename
81     int                 flags
82     PREINIT:
83     CODE:
84     {
85     char        win32_path[MAX_PATH];
86     cygwin_conv_to_full_win32_path(filename, win32_path);
87     filename = win32_path;
88
89     DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
90
91     RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
92
93     DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", RETVAL));
94     ST(0) = sv_newmortal() ;
95     if (RETVAL == NULL){
96         SaveError(aTHX_ "%d",GetLastError()) ;
97     } else {
98         sv_setiv( ST(0), PTR2IV(RETVAL) );
99     }
100    }
101         
102
103
104 void *
105 dl_find_symbol(libhandle, symbolname)
106     void *      libhandle
107     char *      symbolname
108     CODE:
109     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
110         libhandle, symbolname));
111     RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
112     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"  symbolref = %x\n", RETVAL));
113     ST(0) = sv_newmortal() ;
114     if (RETVAL == NULL)
115         SaveError(aTHX_ "%d",GetLastError()) ;
116     else
117         sv_setiv( ST(0), PTR2IV(RETVAL));
118
119
120 void
121 dl_undef_symbols()
122     PPCODE:
123
124
125
126 # These functions should not need changing on any platform:
127
128 void
129 dl_install_xsub(perl_name, symref, filename="$Package")
130     char *              perl_name
131     void *              symref 
132     char *              filename
133     CODE:
134     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
135                 perl_name, symref));
136     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
137                                         (void(*)(pTHX_ CV *))symref,
138                                         filename)));
139
140
141 char *
142 dl_error()
143     CODE:
144     RETVAL = LastError ;
145     OUTPUT:
146     RETVAL
147
148 # end.