home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / DynaLoader / dl_dyld.xs < prev    next >
Text File  |  2000-02-25  |  5KB  |  227 lines
  1. /* dl_dyld.xs
  2.  *
  3.  * Platform:    Darwin (Mac OS)
  4.  * Author:    Wilfredo Sanchez <wsanchez@apple.com>
  5.  * Based on:    dl_next.xs by Paul Marquess
  6.  * Based on:    dl_dlopen.xs by Anno Siegel
  7.  * Created:    Aug 15th, 1994
  8.  *
  9.  */
  10.  
  11. /*
  12.     And Gandalf said: 'Many folk like to know beforehand what is to
  13.     be set on the table; but those who have laboured to prepare the
  14.     feast like to keep their secret; for wonder makes the words of
  15.     praise louder.'
  16. */
  17.  
  18. /* Porting notes:
  19.  
  20. dl_dyld.xs is based on dl_next.xs by Anno Siegel.
  21.  
  22. dl_next.xs is in turn a port from dl_dlopen.xs by Paul Marquess.  It
  23. should not be used as a base for further ports though it may be used
  24. as an example for how dl_dlopen.xs can be ported to other platforms.
  25.  
  26. The method used here is just to supply the sun style dlopen etc.
  27. functions in terms of NeXT's/Apple's dyld.  The xs code proper is
  28. unchanged from Paul's original.
  29.  
  30. The port could use some streamlining.  For one, error handling could
  31. be simplified.
  32.  
  33. This should be useable as a replacement for dl_next.xs, but it has not
  34. been tested on NeXT platforms.
  35.  
  36.   Wilfredo Sanchez
  37.  
  38. */
  39.  
  40. #include "EXTERN.h"
  41. #include "perl.h"
  42. #include "XSUB.h"
  43.  
  44. #define DL_LOADONCEONLY
  45.  
  46. #include "dlutils.c"    /* SaveError() etc    */
  47.  
  48. #undef environ
  49. #undef bool
  50. #import <mach-o/dyld.h>
  51.  
  52. static char * dl_last_error = (char *) 0;
  53. static AV *dl_resolve_using = Nullav;
  54.  
  55. static char *dlerror()
  56. {
  57.     return dl_last_error;
  58. }
  59.  
  60. int dlclose(handle) /* stub only */
  61. void *handle;
  62. {
  63.     return 0;
  64. }
  65.  
  66. enum dyldErrorSource
  67. {
  68.     OFImage,
  69. };
  70.  
  71. static void TranslateError
  72.     (const char *path, enum dyldErrorSource type, int number)
  73. {
  74.     dTHX;
  75.     char *error;
  76.     unsigned int index;
  77.     static char *OFIErrorStrings[] =
  78.     {
  79.     "%s(%d): Object Image Load Failure\n",
  80.     "%s(%d): Object Image Load Success\n",
  81.     "%s(%d): Not an recognisable object file\n",
  82.     "%s(%d): No valid architecture\n",
  83.     "%s(%d): Object image has an invalid format\n",
  84.     "%s(%d): Invalid access (permissions?)\n",
  85.     "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
  86.     };
  87. #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
  88.  
  89.     switch (type)
  90.     {
  91.     case OFImage:
  92.     index = number;
  93.     if (index > NUM_OFI_ERRORS - 1)
  94.         index = NUM_OFI_ERRORS - 1;
  95.     error = Perl_form_nocontext(OFIErrorStrings[index], path, number);
  96.     break;
  97.  
  98.     default:
  99.     error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n",
  100.              path, number, type);
  101.     break;
  102.     }
  103.     safefree(dl_last_error);
  104.     dl_last_error = savepv(error);
  105. }
  106.  
  107. static char *dlopen(char *path, int mode /* mode is ignored */)
  108. {
  109.     int dyld_result;
  110.     NSObjectFileImage ofile;
  111.     NSModule handle = NULL;
  112.  
  113.     dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
  114.     if (dyld_result != NSObjectFileImageSuccess)
  115.     TranslateError(path, OFImage, dyld_result);
  116.     else
  117.     {
  118.         // NSLinkModule will cause the run to abort on any link error's
  119.     // not very friendly but the error recovery functionality is limited.
  120.     handle = NSLinkModule(ofile, path, TRUE);
  121.     }
  122.  
  123.     return handle;
  124. }
  125.  
  126. void *
  127. dlsym(handle, symbol)
  128. void *handle;
  129. char *symbol;
  130. {
  131.     void *addr;
  132.  
  133.     if (NSIsSymbolNameDefined(symbol))
  134.     addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
  135.     else
  136.         addr = NULL;
  137.  
  138.     return addr;
  139. }
  140.  
  141.  
  142.  
  143. /* ----- code from dl_dlopen.xs below here ----- */
  144.  
  145.  
  146. static void
  147. dl_private_init(pTHX)
  148. {
  149.     (void)dl_generic_private_init(aTHX);
  150.     dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI);
  151. }
  152.  
  153. MODULE = DynaLoader     PACKAGE = DynaLoader
  154.  
  155. BOOT:
  156.     (void)dl_private_init(aTHX);
  157.  
  158.  
  159.  
  160. void *
  161. dl_load_file(filename, flags=0)
  162.     char *    filename
  163.     int        flags
  164.     PREINIT:
  165.     int mode = 1;
  166.     CODE:
  167.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
  168.     if (flags & 0x01)
  169.     Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
  170.     RETVAL = dlopen(filename, mode) ;
  171.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL));
  172.     ST(0) = sv_newmortal() ;
  173.     if (RETVAL == NULL)
  174.     SaveError(aTHX_ "%s",dlerror()) ;
  175.     else
  176.     sv_setiv( ST(0), PTR2IV(RETVAL) );
  177.  
  178.  
  179. void *
  180. dl_find_symbol(libhandle, symbolname)
  181.     void *        libhandle
  182.     char *        symbolname
  183.     CODE:
  184.     symbolname = Perl_form_nocontext("_%s", symbolname);
  185.     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
  186.                  "dl_find_symbol(handle=%lx, symbol=%s)\n",
  187.                  (unsigned long) libhandle, symbolname));
  188.     RETVAL = dlsym(libhandle, symbolname);
  189.     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
  190.                  "  symbolref = %lx\n", (unsigned long) RETVAL));
  191.     ST(0) = sv_newmortal() ;
  192.     if (RETVAL == NULL)
  193.     SaveError(aTHX_ "%s",dlerror()) ;
  194.     else
  195.     sv_setiv( ST(0), PTR2IV(RETVAL) );
  196.  
  197.  
  198. void
  199. dl_undef_symbols()
  200.     PPCODE:
  201.  
  202.  
  203.  
  204. # These functions should not need changing on any platform:
  205.  
  206. void
  207. dl_install_xsub(perl_name, symref, filename="$Package")
  208.     char *    perl_name
  209.     void *    symref
  210.     char *    filename
  211.     CODE:
  212.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
  213.         perl_name, symref));
  214.     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
  215.                     (void(*)(pTHX_ CV *))symref,
  216.                     filename)));
  217.  
  218.  
  219. char *
  220. dl_error()
  221.     CODE:
  222.     RETVAL = LastError ;
  223.     OUTPUT:
  224.     RETVAL
  225.  
  226. # end.
  227.