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  *
  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 #define PERL_NO_GET_CONTEXT
 120
 121 #include "EXTERN.h"
 122 #include "perl.h"
 123 #include "XSUB.h"
 124
 125 #ifdef I_DLFCN
 126 #include <dlfcn.h>      /* the dynamic linker include file for Sunos/Solaris */
 127 #else
 128 #include <nlist.h>
 129 #include <link.h>
 130 #endif
 131
 132 #ifndef RTLD_LAZY
 133 # define RTLD_LAZY 1    /* Solaris 1 */
 134 #endif
 135
 136 #ifndef HAS_DLERROR
 137 # ifdef __NetBSD__
 138 #  define dlerror() strerror(errno)
 139 # else
 140 #  define dlerror() "Unknown error - dlerror() not implemented"
 141 # endif
 142 #endif
 143
 144
 145 #include "dlutils.c"    /* SaveError() etc      */
 146
 147
 148 static void
 149 dl_private_init(pTHX)
 150 {
 151     (void)dl_generic_private_init(aTHX);
 152 }
 153
 154 MODULE = DynaLoader     PACKAGE = DynaLoader
 155
 156 BOOT:
 157     (void)dl_private_init(aTHX);
 158
 159
 160 void
 161 dl_load_file(filename, flags=0)
 162     char *      filename
 163     int         flags
 164   PREINIT:
 165     int mode = RTLD_LAZY;
 166     void *handle;
 167   CODE:
 168 {
 169 #if defined(DLOPEN_WONT_DO_RELATIVE_PATHS)
 170     char pathbuf[PATH_MAX + 2];
 171     if (*filename != '/' && strchr(filename, '/')) {
 172         if (getcwd(pathbuf, PATH_MAX - strlen(filename))) {
 173             strcat(pathbuf, "/");
 174             strcat(pathbuf, filename);
 175             filename = pathbuf;
 176         }
 177     }
 178 #endif
 179 #ifdef RTLD_NOW
 180     {
 181         dMY_CXT;
 182         if (dl_nonlazy)
 183             mode = RTLD_NOW;
 184     }
 185 #endif
 186     if (flags & 0x01)
 187 #ifdef RTLD_GLOBAL
 188         mode |= RTLD_GLOBAL;
 189 #else
 190         Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
 191 #endif
 192     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
 193     handle = dlopen(filename, mode) ;
 194     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) handle));
 195     ST(0) = sv_newmortal() ;
 196     if (handle == NULL)
 197         SaveError(aTHX_ "%s",dlerror()) ;
 198     else
 199         sv_setiv( ST(0), PTR2IV(handle));
 200 }
 201
 202
 203 int
 204 dl_unload_file(libref)
 205     void *      libref
 206   CODE:
 207     DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref)));
 208     RETVAL = (dlclose(libref) == 0 ? 1 : 0);
 209     if (!RETVAL)
 210         SaveError(aTHX_ "%s", dlerror()) ;
 211     DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL));
 212   OUTPUT:
 213     RETVAL
 214
 215
 216 void
 217 dl_find_symbol(libhandle, symbolname)
 218     void *      libhandle
 219     char *      symbolname
 220     PREINIT:
 221     void *sym;
 222     CODE:
 223 #ifdef DLSYM_NEEDS_UNDERSCORE
 224     symbolname = Perl_form_nocontext("_%s", symbolname);
 225 #endif
 226     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 227                              "dl_find_symbol(handle=%lx, symbol=%s)\n",
 228                              (unsigned long) libhandle, symbolname));
 229     sym = dlsym(libhandle, symbolname);
 230     DLDEBUG(2, PerlIO_printf(Perl_debug_log,
 231                              "  symbolref = %lx\n", (unsigned long) sym));
 232     ST(0) = sv_newmortal() ;
 233     if (sym == NULL)
 234         SaveError(aTHX_ "%s",dlerror()) ;
 235     else
 236         sv_setiv( ST(0), PTR2IV(sym));
 237
 238
 239 void
 240 dl_undef_symbols()
 241     CODE:
 242
 243
 244
 245 # These functions should not need changing on any platform:
 246
 247 void
 248 dl_install_xsub(perl_name, symref, filename="$Package")
 249     char *              perl_name
 250     void *              symref
 251     const char *        filename
 252     CODE:
 253     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%"UVxf")\n",
 254                 perl_name, PTR2UV(symref)));
 255     ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
 256                                               DPTR2FPTR(XSUBADDR_t, symref),
 257                                               filename, NULL,
 258                                               XS_DYNAMIC_FILENAME)));
 259
 260
 261 char *
 262 dl_error()
 263     CODE:
 264     dMY_CXT;
 265     RETVAL = dl_last_error ;
 266     OUTPUT:
 267     RETVAL
 268
 269 #if defined(USE_ITHREADS)
 270
 271 void
 272 CLONE(...)
 273     CODE:
 274     MY_CXT_CLONE;
 275
 276     /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
 277      * using Perl variables that belong to another thread, we create our
 278      * own for this thread.
 279      */
 280     MY_CXT.x_dl_last_error = newSVpvn("", 0);
 281
 282 #endif
 283
 284 # end.