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 February 2000 - Alan Burlison: Added functionality to close dlopen'd
  14  *                      files when the interpreter exits
  15  * 2015-03-12         - rurban: Added optional 3rd dl_find_symbol argument
  16  *
  17  */
  18
  19 /* Porting notes:
  20
  21
  22    Definition of Sunos dynamic Linking functions
  23    =============================================
  24    In order to make this implementation easier to understand here is a
  25    quick definition of the SunOS Dynamic Linking functions which are
  26    used here.
  27
  28    dlopen
  29    ------
  30      void *
  31      dlopen(path, mode)
  32      char * path;
  33      int    mode;
  34
  35      This function takes the name of a dynamic object file and returns
  36      a descriptor which can be used by dlsym later. It returns NULL on
  37      error.
  38
  39      The mode parameter must be set to 1 for Solaris 1 and to
  40      RTLD_LAZY (==2) on Solaris 2.
  41
  42
  43    dlclose
  44    -------
  45      int
  46      dlclose(handle)
  47      void * handle;
  48
  49      This function takes the handle returned by a previous invocation of
  50      dlopen and closes the associated dynamic object file.  It returns zero
  51      on success, and non-zero on failure.
  52
  53
  54    dlsym
  55    ------
  56      void *
  57      dlsym(handle, symbol)
  58      void * handle;
  59      char * symbol;
  60
  61      Takes the handle returned from dlopen and the name of a symbol to
  62      get the address of. If the symbol was found a pointer is
  63      returned.  It returns NULL on error. If DL_PREPEND_UNDERSCORE is
  64      defined an underscore will be added to the start of symbol. This
  65      is required on some platforms (freebsd).
  66
  67    dlerror
  68    ------
  69      char * dlerror()
  70
  71      Returns a null-terminated string which describes the last error
  72      that occurred with either dlopen or dlsym. After each call to
  73      dlerror the error message will be reset to a null pointer. The
  74      SaveError function is used to save the error as soon as it happens.
  75
  76
  77    Return Types
  78    ============
  79    In this implementation the two functions, dl_load_file &
  80    dl_find_symbol, return void *. This is because the underlying SunOS
  81    dynamic linker calls also return void *.  This is not necessarily
  82    the case for all architectures. For example, some implementation
  83    will want to return a char * for dl_load_file.
  84
  85    If void * is not appropriate for your architecture, you will have to
  86    change the void * to whatever you require. If you are not certain of
  87    how Perl handles C data types, I suggest you start by consulting
  88    Dean Roerich's Perl 5 API document. Also, have a look in the typemap
  89    file (in the ext directory) for a fairly comprehensive list of types
  90    that are already supported. If you are completely stuck, I suggest you
  91    post a message to perl5-porters, comp.lang.perl.misc or if you are really
  92    desperate to me.
  93
  94    Remember when you are making any changes that the return value from
  95    dl_load_file is used as a parameter in the dl_find_symbol
  96    function. Also the return value from find_symbol is used as a parameter
  97    to install_xsub.
  98
  99
 100    Dealing with Error Messages
 101    ============================
 102    In order to make the handling of dynamic linking errors as generic as
 103    possible you should store any error messages associated with your
 104    implementation with the StoreError function.
 105
 106    In the case of SunOS the function dlerror returns the error message
 107    associated with the last dynamic link error. As the SunOS dynamic
 108    linker functions dlopen & dlsym both return NULL on error every call
 109    to a SunOS dynamic link routine is coded like this
 110
 111         RETVAL = dlopen(filename, 1) ;
 112         if (RETVAL == NULL)
 113             SaveError("%s",dlerror()) ;
 114
 115    Note that SaveError() takes a printf format string. Use a "%s" as
 116    the first parameter if the error may contain any % characters.
 117
 118 */
 119
 120 #define PERL_NO_GET_CONTEXT
 121 #define PERL_EXT
 122
 123 #include "EXTERN.h"
 124 #define PERL_IN_DL_DLOPEN_XS
 125 #include "perl.h"
 126 #include "XSUB.h"
 127
 128 #ifdef I_DLFCN
 129 #include <dlfcn.h>      /* the dynamic linker include file for Sunos/Solaris */
 130 #else
 131 #include <nlist.h>
 132 #include <link.h>
 133 #endif
 134
 135 #ifndef RTLD_LAZY
 136 # define RTLD_LAZY 1    /* Solaris 1 */
 137 #endif
 138
 139 #ifndef HAS_DLERROR
 140 # ifdef __NetBSD__
 141 #  define dlerror() strerror(errno)
 142 # else
 143 #  define dlerror() "Unknown error - dlerror() not implemented"
 144 # endif
 145 #endif
 146
 147
 148 #include "dlutils.c"    /* SaveError() etc      */
 149
 150
 151 static void
 152 dl_private_init(pTHX)
 153 {
 154     (void)dl_generic_private_init(aTHX);
 155 }
 156
 157 MODULE = DynaLoader     PACKAGE = DynaLoader
 158
 159 BOOT:
 160     (void)dl_private_init(aTHX);
 161
 162
 163 void
 164 dl_load_file(filename, flags=0)
 165     char *      filename
 166     int         flags
 167   PREINIT:
 168     int mode = RTLD_LAZY;
 169     void *handle;
 170   CODE:
 171 {
 172 #if defined(DLOPEN_WONT_DO_RELATIVE_PATHS)
 173     char pathbuf[PATH_MAX + 2];
 174     if (*filename != '/' && strchr(filename, '/')) {
 175         const size_t filename_len = strlen(filename);
 176         if (getcwd(pathbuf, PATH_MAX - filename_len)) {
 177             const size_t path_len = strlen(pathbuf);
 178             pathbuf[path_len] = '/';
 179             filename = (char *) memcpy(pathbuf + path_len + 1, filename, filename_len + 1);
 180         }
 181     }
 182 #endif
 183 #ifdef RTLD_NOW
 184     {
 185         dMY_CXT;
 186         if (dl_nonlazy)
 187             mode = RTLD_NOW;
 188     }
 189 #endif
 190     if (flags & 0x01)
 191 #ifdef RTLD_GLOBAL
 192         mode |= RTLD_GLOBAL;
 193 #else
 194         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 195 #endif
 196     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 197     handle = dlopen(filename, mode) ;
 198     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) handle));
 199     ST(0) = sv_newmortal() ;
 200     if (handle == NULL)
 201         SaveError(aTHX_ "%s",dlerror()) ;
 202     else
 203         sv_setiv( ST(0), PTR2IV(handle));
 204 }
 205
 206
 207 int
 208 dl_unload_file(libref)
 209     void *      libref
 210   CODE:
 211     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref)));
 212     RETVAL = (dlclose(libref) == 0 ? 1 : 0);
 213     if (!RETVAL)
 214         SaveError(aTHX_ "%s", dlerror()) ;
 215     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL));
 216   OUTPUT:
 217     RETVAL
 218
 219
 220 void
 221 dl_find_symbol(libhandle, symbolname, ign_err=0)
 222     void *      libhandle
 223     char *      symbolname
 224     int         ign_err
 225     PREINIT:
 226     void *sym;
 227     CODE:
 228 #ifdef DLSYM_NEEDS_UNDERSCORE
 229     symbolname = Perl_form_nocontext("_%s", symbolname);
 230 #endif
 231     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 232                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 233                              (unsigned long) libhandle, symbolname));
 234     sym = dlsym(libhandle, symbolname);
 235     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 236                              "  symbolref = %lx\n", (unsigned long) sym));
 237     ST(0) = sv_newmortal();
 238     if (sym == NULL) {
 239         if (!ign_err)
 240             SaveError(aTHX_ "%s", dlerror());
 241     } else
 242         sv_setiv( ST(0), PTR2IV(sym));
 243
 244
 245 void
 246 dl_undef_symbols()
 247     CODE:
 248
 249
 250
 251 # These functions should not need changing on any platform:
 252
 253 void
 254 dl_install_xsub(perl_name, symref, filename="$Package")
 255     char *              perl_name
 256     void *              symref
 257     const char *        filename
 258     CODE:
 259     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%"UVxf")\n",
 260                 perl_name, PTR2UV(symref)));
 261     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
 262                                               DPTR2FPTR(XSUBADDR_t, symref),
 263                                               filename, NULL,
 264                                               XS_DYNAMIC_FILENAME)));
 265
 266
 267 SV *
 268 dl_error()
 269     CODE:
 270     dMY_CXT;
 271     RETVAL = newSVsv(MY_CXT.x_dl_last_error);
 272     OUTPUT:
 273     RETVAL
 274
 275 #if defined(USE_ITHREADS)
 276
 277 void
 278 CLONE(...)
 279     CODE:
 280     MY_CXT_CLONE;
 281
 282     PERL_UNUSED_VAR(items);
 283
 284     /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
 285      * using Perl variables that belong to another thread, we create our
 286      * own for this thread.
 287      */
 288     MY_CXT.x_dl_last_error = newSVpvs("");
 289
 290 #endif
 291
 292 # end.