This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.003_01: [changes beteween cumulative patches and tarball release]
[perl5.git] / ext / DynaLoader / dl_os2.xs
CommitLineData
4633a7c4
LW
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
17static ULONG retcode;
18
19static void *
20dlopen(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
28578fc3
PP
30 retcode = rc;
31
4633a7c4
LW
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
4633a7c4
LW
47 return NULL;
48}
49
50static void *
51dlsym(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
67static char *
68dlerror(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
84static void
85dl_private_init()
86{
87 (void)dl_generic_private_init();
88}
89
90static char *
91mod2fname(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
115MODULE = DynaLoader PACKAGE = DynaLoader
116
117BOOT:
118 (void)dl_private_init();
119
120
121void *
122dl_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,fprintf(stderr,"dl_load_file(%s):\n", filename));
130 RETVAL = dlopen(filename, mode) ;
131 DLDEBUG(2,fprintf(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
139void *
140dl_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,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
149 libhandle, symbolname));
150 RETVAL = dlsym(libhandle, symbolname);
151 DLDEBUG(2,fprintf(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
159void
160dl_undef_symbols()
161 PPCODE:
162
163char *
164mod2fname(sv)
165 SV *sv;
166
167
168# These functions should not need changing on any platform:
169
170void
171dl_install_xsub(perl_name, symref, filename="$Package")
172 char * perl_name
173 void * symref
174 char * filename
175 CODE:
176 DLDEBUG(2,fprintf(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
181char *
182dl_error()
183 CODE:
184 RETVAL = LastError ;
185 OUTPUT:
186 RETVAL
187
188# end.