ext/DynaLoader/dl_dlopen.xs

   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 any % 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", PTR2ul(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.