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 my_strlcat(pathbuf, "/", sizeof(pathbuf)); 174 my_strlcat(pathbuf, filename, sizeof(pathbuf)); 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 PERL_UNUSED_VAR(items); 277 278 /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid 279 * using Perl variables that belong to another thread, we create our 280 * own for this thread. 281 */ 282 MY_CXT.x_dl_last_error = newSVpvn("", 0); 283 284 #endif 285 286 # end. 287