home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / DynaLoader / dl_hpux.xs < prev    next >
Text File  |  2000-01-02  |  4KB  |  160 lines
  1. /*
  2.  * Author: Jeff Okamoto (okamoto@corp.hp.com)
  3.  * Version: 2.1, 1995/1/25
  4.  */
  5.  
  6. /* o Added BIND_VERBOSE to dl_nonlazy condition to add names of missing
  7.  *   symbols to stderr message on fatal error.
  8.  *
  9.  * o Added BIND_NONFATAL comment to default condition.
  10.  *
  11.  * Chuck Phillips (cdp@fc.hp.com)
  12.  * Version: 2.2, 1997/5/4 */
  13.  
  14. #ifdef __hp9000s300
  15. #define magic hpux_magic
  16. #define MAGIC HPUX_MAGIC
  17. #endif
  18.  
  19. #include <dl.h>
  20. #ifdef __hp9000s300
  21. #undef magic
  22. #undef MAGIC
  23. #endif
  24.  
  25. #include "EXTERN.h"
  26. #include "perl.h"
  27. #include "XSUB.h"
  28.  
  29.  
  30. #include "dlutils.c"    /* for SaveError() etc */
  31.  
  32. static AV *dl_resolve_using = Nullav;
  33.  
  34.  
  35. static void
  36. dl_private_init(pTHX)
  37. {
  38.     (void)dl_generic_private_init(aTHX);
  39.     dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
  40. }
  41.  
  42. MODULE = DynaLoader     PACKAGE = DynaLoader
  43.  
  44. BOOT:
  45.     (void)dl_private_init(aTHX);
  46.  
  47.  
  48. void *
  49. dl_load_file(filename, flags=0)
  50.     char *    filename
  51.     int        flags
  52.     PREINIT:
  53.     shl_t obj = NULL;
  54.     int    i, max, bind_type;
  55.     CODE:
  56.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
  57.     if (flags & 0x01)
  58.     Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
  59.     if (dl_nonlazy) {
  60.       bind_type = BIND_IMMEDIATE|BIND_VERBOSE;
  61.     } else {
  62.       bind_type = BIND_DEFERRED;
  63.       /* For certain libraries, like DCE, deferred binding often causes run
  64.        * time problems.  Adding BIND_NONFATAL to BIND_IMMEDIATE still allows
  65.        * unresolved references in situations like this.  */
  66.       /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */
  67.     }
  68.     /* BIND_NOSTART removed from bind_type because it causes the shared library's    */
  69.     /* initialisers not to be run.  This causes problems with all of the static objects */
  70.     /* in the library.       */
  71. #ifdef DEBUGGING
  72.     if (dl_debug)
  73.     bind_type |= BIND_VERBOSE;
  74. #endif /* DEBUGGING */
  75.  
  76.     max = AvFILL(dl_resolve_using);
  77.     for (i = 0; i <= max; i++) {
  78.     char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0));
  79.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s) (dependent)\n", sym));
  80.     obj = shl_load(sym, bind_type, 0L);
  81.     if (obj == NULL) {
  82.         goto end;
  83.     }
  84.     }
  85.  
  86.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s): ", filename));
  87.     obj = shl_load(filename, bind_type, 0L);
  88.  
  89.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", obj));
  90. end:
  91.     ST(0) = sv_newmortal() ;
  92.     if (obj == NULL)
  93.         SaveError(aTHX_ "%s",Strerror(errno));
  94.     else
  95.         sv_setiv( ST(0), PTR2IV(obj) );
  96.  
  97.  
  98. void *
  99. dl_find_symbol(libhandle, symbolname)
  100.     void *    libhandle
  101.     char *    symbolname
  102.     CODE:
  103.     shl_t obj = (shl_t) libhandle;
  104.     void *symaddr = NULL;
  105.     int status;
  106. #ifdef __hp9000s300
  107.     symbolname = Perl_form_nocontext("_%s", symbolname);
  108. #endif
  109.     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
  110.                  "dl_find_symbol(handle=%lx, symbol=%s)\n",
  111.                  (unsigned long) libhandle, symbolname));
  112.  
  113.     ST(0) = sv_newmortal() ;
  114.     errno = 0;
  115.  
  116.     status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr);
  117.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "  symbolref(PROCEDURE) = %x\n", symaddr));
  118.  
  119.     if (status == -1 && errno == 0) {    /* try TYPE_DATA instead */
  120.     status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr);
  121.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "  symbolref(DATA) = %x\n", symaddr));
  122.     }
  123.  
  124.     if (status == -1) {
  125.     SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ;
  126.     } else {
  127.     sv_setiv( ST(0), PTR2IV(symaddr) );
  128.     }
  129.  
  130.  
  131. void
  132. dl_undef_symbols()
  133.     PPCODE:
  134.  
  135.  
  136.  
  137. # These functions should not need changing on any platform:
  138.  
  139. void
  140. dl_install_xsub(perl_name, symref, filename="$Package")
  141.     char *    perl_name
  142.     void *    symref 
  143.     char *    filename
  144.     CODE:
  145.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
  146.         perl_name, symref));
  147.     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
  148.                     (void(*)(pTHX_ CV *))symref,
  149.                     filename)));
  150.  
  151.  
  152. char *
  153. dl_error()
  154.     CODE:
  155.     RETVAL = LastError ;
  156.     OUTPUT:
  157.     RETVAL
  158.  
  159. # end.
  160.