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_aix.xs
CommitLineData
a0d0e21e
LW
1/* dl_aix.xs
2 *
3 * Written: 8/31/94 by Wayne Scott (wscott@ichips.intel.com)
4 *
5 * All I did was take Jens-Uwe Mager's libdl emulation library for
6 * AIX and merged it with the dl_dlopen.xs file to create a dynamic library
7 * package that works for AIX.
8 *
9 * I did change all malloc's, free's, strdup's, calloc's to use the perl
10 * equilvant. I also removed some stuff we will not need. Call fini()
11 * on statup... It can probably be trimmed more.
12 */
13
14/*
15 * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17
16 * This is an unpublished work copyright (c) 1992 Helios Software GmbH
17 * 3000 Hannover 1, Germany
18 */
19#include "EXTERN.h"
20#include "perl.h"
21#include "XSUB.h"
22
23#include <stdio.h>
24#include <errno.h>
25#include <string.h>
26#include <stdlib.h>
27#include <sys/types.h>
28#include <sys/ldr.h>
29#include <a.out.h>
30#include <ldfcn.h>
31
ee580363
GS
32/*
33 * AIX 4.3 does remove some useful definitions from ldfcn.h. Define
34 * these here to compensate for that lossage.
35 */
36#ifndef BEGINNING
37# define BEGINNING SEEK_SET
38#endif
39#ifndef FSEEK
40# define FSEEK(ldptr,o,p) fseek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr) +o):o,p)
41#endif
42#ifndef FREAD
43# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr))
44#endif
45
1553ab04
TB
46/* If using PerlIO, redefine these macros from <ldfcn.h> */
47#ifdef USE_PERLIO
48#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p)
49#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n)
50#endif
51
a0d0e21e
LW
52/*
53 * We simulate dlopen() et al. through a call to load. Because AIX has
54 * no call to find an exported symbol we read the loader section of the
55 * loaded module and build a list of exported symbols and their virtual
56 * address.
57 */
58
59typedef struct {
60 char *name; /* the symbols's name */
61 void *addr; /* its relocated virtual address */
62} Export, *ExportPtr;
63
64/*
65 * The void * handle returned from dlopen is actually a ModulePtr.
66 */
67typedef struct Module {
68 struct Module *next;
69 char *name; /* module name for refcounting */
70 int refCnt; /* the number of references */
71 void *entry; /* entry point from load */
72 int nExports; /* the number of exports found */
73 ExportPtr exports; /* the array of exports */
74} Module, *ModulePtr;
75
76/*
77 * We keep a list of all loaded modules to be able to call the fini
78 * handlers at atexit() time.
79 */
549a6b10 80static ModulePtr modList; /* XXX threaded */
a0d0e21e
LW
81
82/*
83 * The last error from one of the dl* routines is kept in static
84 * variables here. Each error is returned only once to the caller.
85 */
549a6b10
JH
86static char errbuf[BUFSIZ]; /* XXX threaded */
87static int errvalid; /* XXX threaded */
a0d0e21e
LW
88
89static void caterr(char *);
90static int readExports(ModulePtr);
91static void terminate(void);
a0d0e21e 92
ce637636
JH
93static char *strerror_failed = "(strerror failed)";
94static char *strerror_r_failed = "(strerror_r failed)";
95
fd206186 96char *strerrorcat(char *str, int err) {
ce637636
JH
97 int strsiz = strlen(str);
98 int msgsiz;
99 char *msg;
100
101#ifdef USE_THREADS
102 char *buf = malloc(BUFSIZ);
103
104 if (buf == 0)
105 return 0;
549a6b10 106 if (strerror_r(err, buf, BUFSIZ) == 0)
ce637636
JH
107 msg = buf;
108 else
109 msg = strerror_r_failed;
110 msgsiz = strlen(msg);
111 if (strsiz + msgsiz < BUFSIZ)
112 strcat(str, msg);
113 free(buf);
114#else
115 if ((msg = strerror(err)) == 0)
116 msg = strerror_failed;
117 msgsiz = strlen(msg); /* Note msg = buf and free() above. */
118 if (strsiz + msgsiz < BUFSIZ) /* Do not move this after #endif. */
119 strcat(str, msg);
120#endif
121
fd206186
JH
122 return str;
123}
ce637636 124
fd206186 125char *strerrorcpy(char *str, int err) {
ce637636
JH
126 int msgsiz;
127 char *msg;
128
129#ifdef USE_THREADS
130 char *buf = malloc(BUFSIZ);
131
132 if (buf == 0)
133 return 0;
549a6b10 134 if (strerror_r(err, buf, BUFSIZ) == 0)
ce637636
JH
135 msg = buf;
136 else
137 msg = strerror_r_failed;
138 msgsiz = strlen(msg);
139 if (msgsiz < BUFSIZ)
140 strcpy(str, msg);
141 free(buf);
142#else
143 if ((msg = strerror(err)) == 0)
144 msg = strerror_failed;
145 msgsiz = strlen(msg); /* Note msg = buf and free() above. */
146 if (msgsiz < BUFSIZ) /* Do not move this after #endif. */
147 strcpy(str, msg);
148#endif
149
fd206186
JH
150 return str;
151}
a0d0e21e
LW
152
153/* ARGSUSED */
154void *dlopen(char *path, int mode)
155{
5b877257 156 dTHX;
a0d0e21e 157 register ModulePtr mp;
549a6b10 158 static int inited; /* XXX threaded */
a0d0e21e
LW
159
160 /*
161 * Upon the first call register a terminate handler that will
f6b3007c 162 * close all libraries.
a0d0e21e 163 */
f6b3007c
JH
164 if (!inited) {
165 inited++;
a0d0e21e
LW
166 atexit(terminate);
167 }
168 /*
169 * Scan the list of modules if have the module already loaded.
170 */
171 for (mp = modList; mp; mp = mp->next)
172 if (strcmp(mp->name, path) == 0) {
173 mp->refCnt++;
174 return mp;
175 }
176 Newz(1000,mp,1,Module);
177 if (mp == NULL) {
178 errvalid++;
179 strcpy(errbuf, "Newz: ");
fd206186 180 strerrorcat(errbuf, errno);
a0d0e21e
LW
181 return NULL;
182 }
183
184 if ((mp->name = savepv(path)) == NULL) {
185 errvalid++;
186 strcpy(errbuf, "savepv: ");
fd206186 187 strerrorcat(errbuf, errno);
a0d0e21e
LW
188 safefree(mp);
189 return NULL;
190 }
549a6b10 191
a0d0e21e
LW
192 /*
193 * load should be declared load(const char *...). Thus we
194 * cast the path to a normal char *. Ugly.
195 */
549a6b10
JH
196 if ((mp->entry = (void *)load((char *)path,
197#ifdef L_LIBPATH_EXEC
198 L_LIBPATH_EXEC |
199#endif
200 L_NOAUTODEFER,
201 NULL)) == NULL) {
202 int saverrno = errno;
203
a0d0e21e
LW
204 safefree(mp->name);
205 safefree(mp);
206 errvalid++;
207 strcpy(errbuf, "dlopen: ");
208 strcat(errbuf, path);
209 strcat(errbuf, ": ");
210 /*
211 * If AIX says the file is not executable, the error
212 * can be further described by querying the loader about
213 * the last error.
214 */
549a6b10
JH
215 if (saverrno == ENOEXEC) {
216 char *moreinfo[BUFSIZ/sizeof(char *)];
217 if (loadquery(L_GETMESSAGES, moreinfo, sizeof(moreinfo)) == -1)
218 strerrorcpy(errbuf, saverrno);
a0d0e21e
LW
219 else {
220 char **p;
549a6b10 221 for (p = moreinfo; *p; p++)
a0d0e21e
LW
222 caterr(*p);
223 }
224 } else
549a6b10 225 strerrorcat(errbuf, saverrno);
a0d0e21e
LW
226 return NULL;
227 }
228 mp->refCnt = 1;
229 mp->next = modList;
230 modList = mp;
f6b3007c
JH
231 /*
232 * Assume anonymous exports come from the module this dlopen
233 * is linked into, that holds true as long as dlopen and all
234 * of the perl core are in the same shared object.
235 */
236 if (loadbind(0, (void *)dlopen, mp->entry) == -1) {
549a6b10
JH
237 int saverrno = errno;
238
a0d0e21e
LW
239 dlclose(mp);
240 errvalid++;
241 strcpy(errbuf, "loadbind: ");
549a6b10 242 strerrorcat(errbuf, saverrno);
a0d0e21e
LW
243 return NULL;
244 }
245 if (readExports(mp) == -1) {
246 dlclose(mp);
247 return NULL;
248 }
249 return mp;
250}
251
252/*
253 * Attempt to decipher an AIX loader error message and append it
254 * to our static error message buffer.
255 */
256static void caterr(char *s)
257{
258 register char *p = s;
259
260 while (*p >= '0' && *p <= '9')
261 p++;
262 switch(atoi(s)) {
263 case L_ERROR_TOOMANY:
264 strcat(errbuf, "to many errors");
265 break;
266 case L_ERROR_NOLIB:
267 strcat(errbuf, "can't load library");
268 strcat(errbuf, p);
269 break;
270 case L_ERROR_UNDEF:
271 strcat(errbuf, "can't find symbol");
272 strcat(errbuf, p);
273 break;
274 case L_ERROR_RLDBAD:
275 strcat(errbuf, "bad RLD");
276 strcat(errbuf, p);
277 break;
278 case L_ERROR_FORMAT:
279 strcat(errbuf, "bad exec format in");
280 strcat(errbuf, p);
281 break;
282 case L_ERROR_ERRNO:
fd206186 283 strerrorcat(errbuf, atoi(++p));
a0d0e21e
LW
284 break;
285 default:
286 strcat(errbuf, s);
287 break;
288 }
289}
290
291void *dlsym(void *handle, const char *symbol)
292{
293 register ModulePtr mp = (ModulePtr)handle;
294 register ExportPtr ep;
295 register int i;
296
297 /*
298 * Could speed up search, but I assume that one assigns
299 * the result to function pointers anyways.
300 */
301 for (ep = mp->exports, i = mp->nExports; i; i--, ep++)
302 if (strcmp(ep->name, symbol) == 0)
303 return ep->addr;
304 errvalid++;
305 strcpy(errbuf, "dlsym: undefined symbol ");
306 strcat(errbuf, symbol);
307 return NULL;
308}
309
310char *dlerror(void)
311{
312 if (errvalid) {
313 errvalid = 0;
314 return errbuf;
315 }
316 return NULL;
317}
318
319int dlclose(void *handle)
320{
321 register ModulePtr mp = (ModulePtr)handle;
322 int result;
323 register ModulePtr mp1;
324
325 if (--mp->refCnt > 0)
326 return 0;
327 result = unload(mp->entry);
328 if (result == -1) {
329 errvalid++;
fd206186 330 strerrorcpy(errbuf, errno);
a0d0e21e
LW
331 }
332 if (mp->exports) {
333 register ExportPtr ep;
334 register int i;
335 for (ep = mp->exports, i = mp->nExports; i; i--, ep++)
336 if (ep->name)
337 safefree(ep->name);
338 safefree(mp->exports);
339 }
340 if (mp == modList)
341 modList = mp->next;
342 else {
343 for (mp1 = modList; mp1; mp1 = mp1->next)
344 if (mp1->next == mp) {
345 mp1->next = mp->next;
346 break;
347 }
348 }
349 safefree(mp->name);
350 safefree(mp);
351 return result;
352}
353
354static void terminate(void)
355{
356 while (modList)
357 dlclose(modList);
358}
359
360/* Added by Wayne Scott
361 * This is needed because the ldopen system call calls
362 * calloc to allocated a block of date. The ldclose call calls free.
363 * Without this we get this system calloc and perl's free, resulting
364 * in a "Bad free" message. This way we always use perl's malloc.
365 */
366void *calloc(size_t ne, size_t sz)
367{
368 void *out;
369
370 out = (void *) safemalloc(ne*sz);
371 memzero(out, ne*sz);
372 return(out);
373}
374
375/*
376 * Build the export table from the XCOFF .loader section.
377 */
378static int readExports(ModulePtr mp)
379{
5b877257 380 dTHX;
a0d0e21e
LW
381 LDFILE *ldp = NULL;
382 SCNHDR sh;
383 LDHDR *lhp;
384 char *ldbuf;
385 LDSYM *ls;
386 int i;
387 ExportPtr ep;
388
389 if ((ldp = ldopen(mp->name, ldp)) == NULL) {
390 struct ld_info *lp;
391 char *buf;
392 int size = 4*1024;
393 if (errno != ENOENT) {
394 errvalid++;
395 strcpy(errbuf, "readExports: ");
fd206186 396 strerrorcat(errbuf, errno);
a0d0e21e
LW
397 return -1;
398 }
399 /*
400 * The module might be loaded due to the LIBPATH
401 * environment variable. Search for the loaded
402 * module using L_GETINFO.
403 */
404 if ((buf = safemalloc(size)) == NULL) {
405 errvalid++;
406 strcpy(errbuf, "readExports: ");
fd206186 407 strerrorcat(errbuf, errno);
a0d0e21e
LW
408 return -1;
409 }
410 while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) {
411 safefree(buf);
412 size += 4*1024;
413 if ((buf = safemalloc(size)) == NULL) {
414 errvalid++;
415 strcpy(errbuf, "readExports: ");
fd206186 416 strerrorcat(errbuf, errno);
a0d0e21e
LW
417 return -1;
418 }
419 }
420 if (i == -1) {
421 errvalid++;
422 strcpy(errbuf, "readExports: ");
fd206186 423 strerrorcat(errbuf, errno);
a0d0e21e
LW
424 safefree(buf);
425 return -1;
426 }
427 /*
428 * Traverse the list of loaded modules. The entry point
429 * returned by load() does actually point to the data
430 * segment origin.
431 */
432 lp = (struct ld_info *)buf;
433 while (lp) {
434 if (lp->ldinfo_dataorg == mp->entry) {
435 ldp = ldopen(lp->ldinfo_filename, ldp);
436 break;
437 }
438 if (lp->ldinfo_next == 0)
439 lp = NULL;
440 else
441 lp = (struct ld_info *)((char *)lp + lp->ldinfo_next);
442 }
443 safefree(buf);
444 if (!ldp) {
445 errvalid++;
446 strcpy(errbuf, "readExports: ");
fd206186 447 strerrorcat(errbuf, errno);
a0d0e21e
LW
448 return -1;
449 }
450 }
451 if (TYPE(ldp) != U802TOCMAGIC) {
452 errvalid++;
453 strcpy(errbuf, "readExports: bad magic");
454 while(ldclose(ldp) == FAILURE)
455 ;
456 return -1;
457 }
458 if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) {
459 errvalid++;
460 strcpy(errbuf, "readExports: cannot read loader section header");
461 while(ldclose(ldp) == FAILURE)
462 ;
463 return -1;
464 }
465 /*
466 * We read the complete loader section in one chunk, this makes
467 * finding long symbol names residing in the string table easier.
468 */
469 if ((ldbuf = (char *)safemalloc(sh.s_size)) == NULL) {
470 errvalid++;
471 strcpy(errbuf, "readExports: ");
fd206186 472 strerrorcat(errbuf, errno);
a0d0e21e
LW
473 while(ldclose(ldp) == FAILURE)
474 ;
475 return -1;
476 }
477 if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) {
478 errvalid++;
479 strcpy(errbuf, "readExports: cannot seek to loader section");
480 safefree(ldbuf);
481 while(ldclose(ldp) == FAILURE)
482 ;
483 return -1;
484 }
1553ab04
TB
485/* This first case is a hack, since it assumes that the 3rd parameter to
486 FREAD is 1. See the redefinition of FREAD above to see how this works. */
487#ifdef USE_PERLIO
488 if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) {
489#else
a0d0e21e 490 if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) {
1553ab04 491#endif
a0d0e21e
LW
492 errvalid++;
493 strcpy(errbuf, "readExports: cannot read loader section");
494 safefree(ldbuf);
495 while(ldclose(ldp) == FAILURE)
496 ;
497 return -1;
498 }
499 lhp = (LDHDR *)ldbuf;
500 ls = (LDSYM *)(ldbuf+LDHDRSZ);
501 /*
502 * Count the number of exports to include in our export table.
503 */
504 for (i = lhp->l_nsyms; i; i--, ls++) {
505 if (!LDR_EXPORT(*ls))
506 continue;
507 mp->nExports++;
508 }
509 Newz(1001, mp->exports, mp->nExports, Export);
510 if (mp->exports == NULL) {
511 errvalid++;
512 strcpy(errbuf, "readExports: ");
fd206186 513 strerrorcat(errbuf, errno);
a0d0e21e
LW
514 safefree(ldbuf);
515 while(ldclose(ldp) == FAILURE)
516 ;
517 return -1;
518 }
519 /*
520 * Fill in the export table. All entries are relative to
521 * the entry point we got from load.
522 */
523 ep = mp->exports;
524 ls = (LDSYM *)(ldbuf+LDHDRSZ);
525 for (i = lhp->l_nsyms; i; i--, ls++) {
526 char *symname;
527 if (!LDR_EXPORT(*ls))
528 continue;
529 if (ls->l_zeroes == 0)
530 symname = ls->l_offset+lhp->l_stoff+ldbuf;
531 else
532 symname = ls->l_name;
533 ep->name = savepv(symname);
534 ep->addr = (void *)((unsigned long)mp->entry + ls->l_value);
535 ep++;
536 }
537 safefree(ldbuf);
538 while(ldclose(ldp) == FAILURE)
539 ;
540 return 0;
541}
542
a0d0e21e
LW
543/* dl_dlopen.xs
544 *
545 * Platform: SunOS/Solaris, possibly others which use dlopen.
546 * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk)
547 * Created: 10th July 1994
548 *
549 * Modified:
550 * 15th July 1994 - Added code to explicitly save any error messages.
551 * 3rd August 1994 - Upgraded to v3 spec.
552 * 9th August 1994 - Changed to use IV
553 * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging,
554 * basic FreeBSD support, removed ClearError
555 *
556 */
557
558/* Porting notes:
559
560 see dl_dlopen.xs
561
562*/
563
564#include "dlutils.c" /* SaveError() etc */
565
566
567static void
cea2e8a9 568dl_private_init(pTHX)
a0d0e21e 569{
cea2e8a9 570 (void)dl_generic_private_init(aTHX);
a0d0e21e
LW
571}
572
573MODULE = DynaLoader PACKAGE = DynaLoader
574
575BOOT:
cea2e8a9 576 (void)dl_private_init(aTHX);
a0d0e21e
LW
577
578
579void *
ff7f3c60
NIS
580dl_load_file(filename, flags=0)
581 char * filename
582 int flags
a0d0e21e 583 CODE:
bf49b057 584 DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
ff7f3c60 585 if (flags & 0x01)
cea2e8a9 586 Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
a0d0e21e 587 RETVAL = dlopen(filename, 1) ;
bf49b057 588 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
a0d0e21e
LW
589 ST(0) = sv_newmortal() ;
590 if (RETVAL == NULL)
cea2e8a9 591 SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e 592 else
3175b8cd 593 sv_setiv( ST(0), PTR2IV(RETVAL) );
a0d0e21e
LW
594
595
596void *
597dl_find_symbol(libhandle, symbolname)
598 void * libhandle
599 char * symbolname
600 CODE:
bf49b057 601 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n",
a0d0e21e
LW
602 libhandle, symbolname));
603 RETVAL = dlsym(libhandle, symbolname);
bf49b057 604 DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL));
a0d0e21e
LW
605 ST(0) = sv_newmortal() ;
606 if (RETVAL == NULL)
cea2e8a9 607 SaveError(aTHX_ "%s",dlerror()) ;
a0d0e21e 608 else
f66f545a 609 sv_setiv( ST(0), PTR2IV(RETVAL));
a0d0e21e
LW
610
611
612void
613dl_undef_symbols()
614 PPCODE:
615
616
617
618# These functions should not need changing on any platform:
619
620void
621dl_install_xsub(perl_name, symref, filename="$Package")
622 char * perl_name
623 void * symref
624 char * filename
625 CODE:
bf49b057 626 DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
a0d0e21e 627 perl_name, symref));
cea2e8a9
GS
628 ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
629 (void(*)(pTHX_ CV *))symref,
630 filename)));
a0d0e21e
LW
631
632
633char *
634dl_error()
635 CODE:
636 RETVAL = LastError ;
637 OUTPUT:
638 RETVAL
639
640# end.