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