This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
18003b22d2f0436ac8a4c4664516dce50bf23f81
[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 /*
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
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
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
59 typedef 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  */
67 typedef 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  */
80 static ModulePtr modList;               /* XXX threaded */
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  */
86 static char errbuf[BUFSIZ];             /* XXX threaded */
87 static int errvalid;                    /* XXX threaded */
88
89 static void caterr(char *);
90 static int readExports(ModulePtr);
91 static void terminate(void);
92
93 static char *strerror_failed   = "(strerror failed)";
94 static char *strerror_r_failed = "(strerror_r failed)";
95
96 char *strerrorcat(char *str, int err) {
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;
106     if (strerror_r(err, buf, BUFSIZ) == 0)
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
122     return str;
123 }
124
125 char *strerrorcpy(char *str, int err) {
126     int msgsiz;
127     char *msg;
128
129 #ifdef USE_THREADS
130     char *buf = malloc(BUFSIZ);
131
132     if (buf == 0)
133       return 0;
134     if (strerror_r(err, buf, BUFSIZ) == 0)
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
150     return str;
151 }
152   
153 /* ARGSUSED */
154 void *dlopen(char *path, int mode)
155 {
156         dTHX;
157         register ModulePtr mp;
158         static int inited;                      /* XXX threaded */
159
160         /*
161          * Upon the first call register a terminate handler that will
162          * close all libraries.
163          */
164         if (!inited) {
165                 inited++;
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: ");
180                 strerrorcat(errbuf, errno);
181                 return NULL;
182         }
183         
184         if ((mp->name = savepv(path)) == NULL) {
185                 errvalid++;
186                 strcpy(errbuf, "savepv: ");
187                 strerrorcat(errbuf, errno);
188                 safefree(mp);
189                 return NULL;
190         }
191
192         /*
193          * load should be declared load(const char *...). Thus we
194          * cast the path to a normal char *. Ugly.
195          */
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                 
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                  */
215                 if (saverrno == ENOEXEC) {
216                         char *moreinfo[BUFSIZ/sizeof(char *)];
217                         if (loadquery(L_GETMESSAGES, moreinfo, sizeof(moreinfo)) == -1)
218                                 strerrorcpy(errbuf, saverrno);
219                         else {
220                                 char **p;
221                                 for (p = moreinfo; *p; p++)
222                                         caterr(*p);
223                         }
224                 } else
225                         strerrorcat(errbuf, saverrno);
226                 return NULL;
227         }
228         mp->refCnt = 1;
229         mp->next = modList;
230         modList = mp;
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) {
237                 int saverrno = errno;
238
239                 dlclose(mp);
240                 errvalid++;
241                 strcpy(errbuf, "loadbind: ");
242                 strerrorcat(errbuf, saverrno);
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  */
256 static 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:
283                 strerrorcat(errbuf, atoi(++p));
284                 break;
285         default:
286                 strcat(errbuf, s);
287                 break;
288         }
289 }
290
291 void *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
310 char *dlerror(void)
311 {
312         if (errvalid) {
313                 errvalid = 0;
314                 return errbuf;
315         }
316         return NULL;
317 }
318
319 int 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++;
330                 strerrorcpy(errbuf, errno);
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
354 static 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  */
366 void *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  */
378 static int readExports(ModulePtr mp)
379 {
380         dTHX;
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: ");
396                         strerrorcat(errbuf, errno);
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: ");
407                         strerrorcat(errbuf, errno);
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: ");
416                                 strerrorcat(errbuf, errno);
417                                 return -1;
418                         }
419                 }
420                 if (i == -1) {
421                         errvalid++;
422                         strcpy(errbuf, "readExports: ");
423                         strerrorcat(errbuf, errno);
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: ");
447                         strerrorcat(errbuf, errno);
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: ");
472                 strerrorcat(errbuf, errno);
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         }
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
490         if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) {
491 #endif
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: ");
513                 strerrorcat(errbuf, errno);
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
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
567 static void
568 dl_private_init(pTHX)
569 {
570     (void)dl_generic_private_init(aTHX);
571 }
572  
573 MODULE = DynaLoader     PACKAGE = DynaLoader
574
575 BOOT:
576     (void)dl_private_init(aTHX);
577
578
579 void *
580 dl_load_file(filename, flags=0)
581         char *  filename
582         int     flags
583         CODE:
584         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
585         if (flags & 0x01)
586             Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
587         RETVAL = dlopen(filename, 1) ;
588         DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
589         ST(0) = sv_newmortal() ;
590         if (RETVAL == NULL)
591             SaveError(aTHX_ "%s",dlerror()) ;
592         else
593             sv_setiv( ST(0), PTR2IV(RETVAL) );
594
595
596 void *
597 dl_find_symbol(libhandle, symbolname)
598         void *          libhandle
599         char *          symbolname
600         CODE:
601         DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n",
602                 libhandle, symbolname));
603         RETVAL = dlsym(libhandle, symbolname);
604         DLDEBUG(2,PerlIO_printf(Perl_debug_log, "  symbolref = %x\n", RETVAL));
605         ST(0) = sv_newmortal() ;
606         if (RETVAL == NULL)
607             SaveError(aTHX_ "%s",dlerror()) ;
608         else
609             sv_setiv( ST(0), PTR2IV(RETVAL));
610
611
612 void
613 dl_undef_symbols()
614         PPCODE:
615
616
617
618 # These functions should not need changing on any platform:
619
620 void
621 dl_install_xsub(perl_name, symref, filename="$Package")
622     char *      perl_name
623     void *      symref 
624     char *      filename
625     CODE:
626     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
627         perl_name, symref));
628     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
629                                         (void(*)(pTHX_ CV *))symref,
630                                         filename)));
631
632
633 char *
634 dl_error()
635     CODE:
636     RETVAL = LastError ;
637     OUTPUT:
638     RETVAL
639
640 # end.