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