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