This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5ca213b985d72e29f4647370ffc6f68970998dc9
[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         /* 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
49 static void *
50 dlsym(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
66 static char *
67 dlerror(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
83 static void
84 dl_private_init()
85 {
86     (void)dl_generic_private_init();
87 }
88
89 static char *
90 mod2fname(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
114 MODULE = DynaLoader     PACKAGE = DynaLoader
115
116 BOOT:
117     (void)dl_private_init();
118
119
120 void *
121 dl_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
138 void *
139 dl_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
158 void
159 dl_undef_symbols()
160     PPCODE:
161
162 char *
163 mod2fname(sv)
164      SV   *sv;
165
166
167 # These functions should not need changing on any platform:
168
169 void
170 dl_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
180 char *
181 dl_error()
182     CODE:
183     RETVAL = LastError ;
184     OUTPUT:
185     RETVAL
186
187 # end.