This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[differences between cumulative patch application and perl5.003_19]
[perl5.git] / ext / DynaLoader / dl_os2.xs
1 /* dl_os2.xs
2  * 
3  * Platform:    OS/2.
4  * Author:      Andreas Kaiser (ak@ananke.s.bawue.de)
5  * Created:     08th December 1994
6  */
7
8 #include "EXTERN.h"
9 #include "perl.h"
10 #include "XSUB.h"
11
12 #define INCL_BASE
13 #include <os2.h>
14
15 #include "dlutils.c"    /* SaveError() etc      */
16
17 static ULONG retcode;
18
19 static void *
20 dlopen(char *path, int mode)
21 {
22         HMODULE handle;
23         char tmp[260], *beg, *dot;
24         char fail[300];
25         ULONG rc;
26
27         if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
28                 return (void *)handle;
29
30         retcode = rc;
31
32         /* Not found. Check for non-FAT name and try truncated name. */
33         /* Don't know if this helps though... */
34         for (beg = dot = path + strlen(path);
35              beg > path && !strchr(":/\\", *(beg-1));
36              beg--)
37                 if (*beg == '.')
38                         dot = beg;
39         if (dot - beg > 8) {
40                 int n = beg+8-path;
41                 memmove(tmp, path, n);
42                 memmove(tmp+n, dot, strlen(dot)+1);
43                 if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
44                         return (void *)handle;
45         }
46
47         return NULL;
48 }
49
50 static void *
51 dlsym(void *handle, char *symbol)
52 {
53         ULONG rc, type;
54         PFN addr;
55
56         rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
57         if (rc == 0) {
58                 rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
59                 if (rc == 0 && type == PT_32BIT)
60                         return (void *)addr;
61                 rc = ERROR_CALL_NOT_IMPLEMENTED;
62         }
63         retcode = rc;
64         return NULL;
65 }
66
67 static char *
68 dlerror(void)
69 {
70         static char buf[300];
71         ULONG len;
72
73         if (retcode == 0)
74                 return NULL;
75         if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
76                 sprintf(buf, "OS/2 system error code %d", retcode);
77         else
78                 buf[len] = '\0';
79         retcode = 0;
80         return buf;
81 }
82
83
84 static void
85 dl_private_init()
86 {
87     (void)dl_generic_private_init();
88 }
89
90 static char *
91 mod2fname(sv)
92      SV   *sv;
93 {
94     static char fname[9];
95     int pos = 7;
96     int len;
97     AV  *av;
98     SV  *svp;
99     char *s;
100
101     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
102     sv = SvRV(sv);
103     if (SvTYPE(sv) != SVt_PVAV) 
104       croak("Not array reference given to mod2fname");
105     if (av_len((AV*)sv) < 0) 
106       croak("Empty array reference given to mod2fname");
107     s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
108     strncpy(fname, s, 8);
109     if ((len=strlen(s)) < 7) pos = len;
110     fname[pos] = '_';
111     fname[pos + 1] = '\0';
112     return (char *)fname;
113 }
114
115 MODULE = DynaLoader     PACKAGE = DynaLoader
116
117 BOOT:
118     (void)dl_private_init();
119
120
121 void *
122 dl_load_file(filename)
123     char *              filename
124     CODE:
125     int mode = 1;     /* Solaris 1 */
126 #ifdef RTLD_LAZY
127     mode = RTLD_LAZY; /* Solaris 2 */
128 #endif
129     DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename));
130     RETVAL = dlopen(filename, mode) ;
131     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
132     ST(0) = sv_newmortal() ;
133     if (RETVAL == NULL)
134         SaveError("%s",dlerror()) ;
135     else
136         sv_setiv( ST(0), (IV)RETVAL);
137
138
139 void *
140 dl_find_symbol(libhandle, symbolname)
141     void *      libhandle
142     char *      symbolname
143     CODE:
144 #ifdef DLSYM_NEEDS_UNDERSCORE
145     char symbolname_buf[1024];
146     symbolname = dl_add_underscore(symbolname, symbolname_buf);
147 #endif
148     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
149         libhandle, symbolname));
150     RETVAL = dlsym(libhandle, symbolname);
151     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "  symbolref = %x\n", RETVAL));
152     ST(0) = sv_newmortal() ;
153     if (RETVAL == NULL)
154         SaveError("%s",dlerror()) ;
155     else
156         sv_setiv( ST(0), (IV)RETVAL);
157
158
159 void
160 dl_undef_symbols()
161     PPCODE:
162
163 char *
164 mod2fname(sv)
165      SV   *sv;
166
167
168 # These functions should not need changing on any platform:
169
170 void
171 dl_install_xsub(perl_name, symref, filename="$Package")
172     char *              perl_name
173     void *              symref 
174     char *              filename
175     CODE:
176     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
177                 perl_name, symref));
178     ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
179
180
181 char *
182 dl_error()
183     CODE:
184     RETVAL = LastError ;
185     OUTPUT:
186     RETVAL
187
188 # end.