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