home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / DynaLoader / dl_dlopen.xs < prev    next >
Text File  |  2000-02-29  |  7KB  |  260 lines
  1. /* dl_dlopen.xs
  2.  * 
  3.  * Platform:    SunOS/Solaris, possibly others which use dlopen.
  4.  * Author:    Paul Marquess (Paul.Marquess@btinternet.com)
  5.  * Created:    10th July 1994
  6.  *
  7.  * Modified:
  8.  * 15th July 1994     - Added code to explicitly save any error messages.
  9.  * 3rd August 1994    - Upgraded to v3 spec.
  10.  * 9th August 1994    - Changed to use IV
  11.  * 10th August 1994   - Tim Bunce: Added RTLD_LAZY, switchable debugging,
  12.  *                      basic FreeBSD support, removed ClearError
  13.  * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd
  14.  *                      files when the interpreter exits
  15.  *
  16.  */
  17.  
  18. /* Porting notes:
  19.  
  20.  
  21.    Definition of Sunos dynamic Linking functions
  22.    =============================================
  23.    In order to make this implementation easier to understand here is a
  24.    quick definition of the SunOS Dynamic Linking functions which are
  25.    used here.
  26.  
  27.    dlopen
  28.    ------
  29.      void *
  30.      dlopen(path, mode)
  31.      char * path; 
  32.      int    mode;
  33.  
  34.      This function takes the name of a dynamic object file and returns
  35.      a descriptor which can be used by dlsym later. It returns NULL on
  36.      error.
  37.  
  38.      The mode parameter must be set to 1 for Solaris 1 and to
  39.      RTLD_LAZY (==2) on Solaris 2.
  40.  
  41.  
  42.    dlclose
  43.    -------
  44.      int
  45.      dlclose(handle)
  46.      void * handle;
  47.  
  48.      This function takes the handle returned by a previous invocation of
  49.      dlopen and closes the associated dynamic object file.  It returns zero
  50.      on success, and non-zero on failure.
  51.  
  52.  
  53.    dlsym
  54.    ------
  55.      void *
  56.      dlsym(handle, symbol)
  57.      void * handle; 
  58.      char * symbol;
  59.  
  60.      Takes the handle returned from dlopen and the name of a symbol to
  61.      get the address of. If the symbol was found a pointer is
  62.      returned.  It returns NULL on error. If DL_PREPEND_UNDERSCORE is
  63.      defined an underscore will be added to the start of symbol. This
  64.      is required on some platforms (freebsd).
  65.  
  66.    dlerror
  67.    ------
  68.      char * dlerror()
  69.  
  70.      Returns a null-terminated string which describes the last error
  71.      that occurred with either dlopen or dlsym. After each call to
  72.      dlerror the error message will be reset to a null pointer. The
  73.      SaveError function is used to save the error as soon as it happens.
  74.  
  75.  
  76.    Return Types
  77.    ============
  78.    In this implementation the two functions, dl_load_file &
  79.    dl_find_symbol, return void *. This is because the underlying SunOS
  80.    dynamic linker calls also return void *.  This is not necessarily
  81.    the case for all architectures. For example, some implementation
  82.    will want to return a char * for dl_load_file.
  83.  
  84.    If void * is not appropriate for your architecture, you will have to
  85.    change the void * to whatever you require. If you are not certain of
  86.    how Perl handles C data types, I suggest you start by consulting    
  87.    Dean Roerich's Perl 5 API document. Also, have a look in the typemap 
  88.    file (in the ext directory) for a fairly comprehensive list of types 
  89.    that are already supported. If you are completely stuck, I suggest you
  90.    post a message to perl5-porters, comp.lang.perl.misc or if you are really 
  91.    desperate to me.
  92.  
  93.    Remember when you are making any changes that the return value from 
  94.    dl_load_file is used as a parameter in the dl_find_symbol 
  95.    function. Also the return value from find_symbol is used as a parameter 
  96.    to install_xsub.
  97.  
  98.  
  99.    Dealing with Error Messages
  100.    ============================
  101.    In order to make the handling of dynamic linking errors as generic as
  102.    possible you should store any error messages associated with your
  103.    implementation with the StoreError function.
  104.  
  105.    In the case of SunOS the function dlerror returns the error message 
  106.    associated with the last dynamic link error. As the SunOS dynamic 
  107.    linker functions dlopen & dlsym both return NULL on error every call 
  108.    to a SunOS dynamic link routine is coded like this
  109.  
  110.     RETVAL = dlopen(filename, 1) ;
  111.     if (RETVAL == NULL)
  112.         SaveError("%s",dlerror()) ;
  113.  
  114.    Note that SaveError() takes a printf format string. Use a "%s" as
  115.    the first parameter if the error may contain and % characters.
  116.  
  117. */
  118.  
  119. #include "EXTERN.h"
  120. #include "perl.h"
  121. #include "XSUB.h"
  122.  
  123. #ifdef I_DLFCN
  124. #include <dlfcn.h>    /* the dynamic linker include file for Sunos/Solaris */
  125. #else
  126. #include <nlist.h>
  127. #include <link.h>
  128. #endif
  129.  
  130. #ifndef RTLD_LAZY
  131. # define RTLD_LAZY 1    /* Solaris 1 */
  132. #endif
  133.  
  134. #ifndef HAS_DLERROR
  135. # ifdef __NetBSD__
  136. #  define dlerror() strerror(errno)
  137. # else
  138. #  define dlerror() "Unknown error - dlerror() not implemented"
  139. # endif
  140. #endif
  141.  
  142.  
  143. #include "dlutils.c"    /* SaveError() etc    */
  144.  
  145.  
  146. static void
  147. dl_private_init(pTHX)
  148. {
  149.     (void)dl_generic_private_init(aTHX);
  150. }
  151.  
  152. MODULE = DynaLoader    PACKAGE = DynaLoader
  153.  
  154. BOOT:
  155.     (void)dl_private_init(aTHX);
  156.  
  157.  
  158. void *
  159. dl_load_file(filename, flags=0)
  160.     char *    filename
  161.     int        flags
  162.   PREINIT:
  163.     int mode = RTLD_LAZY;
  164.   CODE:
  165. {
  166. #if defined(DLOPEN_WONT_DO_RELATIVE_PATHS)
  167.     char pathbuf[PATH_MAX + 2];
  168.     if (*filename != '/' && strchr(filename, '/')) {
  169.     if (getcwd(pathbuf, PATH_MAX - strlen(filename))) {
  170.         strcat(pathbuf, "/");
  171.         strcat(pathbuf, filename);
  172.         filename = pathbuf;
  173.     }
  174.     }
  175. #endif
  176. #ifdef RTLD_NOW
  177.     if (dl_nonlazy)
  178.     mode = RTLD_NOW;
  179. #endif
  180.     if (flags & 0x01)
  181. #ifdef RTLD_GLOBAL
  182.     mode |= RTLD_GLOBAL;
  183. #else
  184.     Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
  185. #endif
  186.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
  187.     RETVAL = dlopen(filename, mode) ;
  188.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL));
  189.     ST(0) = sv_newmortal() ;
  190.     if (RETVAL == NULL)
  191.     SaveError(aTHX_ "%s",dlerror()) ;
  192.     else
  193.     sv_setiv( ST(0), PTR2IV(RETVAL));
  194. }
  195.  
  196.  
  197. int
  198. dl_unload_file(libref)
  199.     void *    libref
  200.   CODE:
  201.     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref));
  202.     RETVAL = (dlclose(libref) == 0 ? 1 : 0);
  203.     if (!RETVAL)
  204.         SaveError(aTHX_ "%s", dlerror()) ;
  205.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL));
  206.   OUTPUT:
  207.     RETVAL
  208.  
  209.  
  210. void *
  211. dl_find_symbol(libhandle, symbolname)
  212.     void *    libhandle
  213.     char *    symbolname
  214.     CODE:
  215. #ifdef DLSYM_NEEDS_UNDERSCORE
  216.     symbolname = Perl_form_nocontext("_%s", symbolname);
  217. #endif
  218.     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
  219.                  "dl_find_symbol(handle=%lx, symbol=%s)\n",
  220.                  (unsigned long) libhandle, symbolname));
  221.     RETVAL = dlsym(libhandle, symbolname);
  222.     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
  223.                  "  symbolref = %lx\n", (unsigned long) RETVAL));
  224.     ST(0) = sv_newmortal() ;
  225.     if (RETVAL == NULL)
  226.     SaveError(aTHX_ "%s",dlerror()) ;
  227.     else
  228.     sv_setiv( ST(0), PTR2IV(RETVAL));
  229.  
  230.  
  231. void
  232. dl_undef_symbols()
  233.     PPCODE:
  234.  
  235.  
  236.  
  237. # These functions should not need changing on any platform:
  238.  
  239. void
  240. dl_install_xsub(perl_name, symref, filename="$Package")
  241.     char *        perl_name
  242.     void *        symref 
  243.     char *        filename
  244.     CODE:
  245.     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
  246.         perl_name, (unsigned long) symref));
  247.     ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
  248.                     (void(*)(pTHX_ CV *))symref,
  249.                     filename)));
  250.  
  251.  
  252. char *
  253. dl_error()
  254.     CODE:
  255.     RETVAL = LastError ;
  256.     OUTPUT:
  257.     RETVAL
  258.  
  259. # end.
  260.