/* Part of SWI-Prolog Author: Jan Wielemaker E-mail: J.Wielemaker@vu.nl WWW: http://www.swi-prolog.org Copyright (c) 1985-2022, University of Amsterdam VU University Amsterdam SWI-Prolog Solutions b.v. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #define _GNU_SOURCE /* get dladdr() */ #include "pl-load.h" #include "pl-fli.h" /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SWI-Prolog interface for runtime loading of foreign code (plugins). Currently, this interface is implemented only for ELF systems (based on dlopen()) and HPUX (based on slh_load()). Despite, this covers a large number of modern Unix platforms. To name a few: Solaris, Linux, freeBSD, IRIX, HPUX, MacOS X. For some platforms we emulate the ELF interface and set the cpp symbol EMULATE_DLOPEN. You find examples in pl-nt.c (for Win32) and pl-beos.c (for BeOS). Basically, 3 operations are required: open_shared_object(+File, [+Options], -Handle) Load a shared object into the current image. call_shared_object_function(+Handle, +FunctionName) Call a named function without arguments. Return value is ignored too. close_shared_object(+Handle) Unload a shared object. Feel free to add this functionality for your favorite OS and mail me the contributions. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #ifndef O_STATIC_EXTENSIONS /******************************* * DLOPEN() AND FRIENDS * *******************************/ #ifndef EMULATE_DLOPEN #ifdef HAVE_DLOPEN /* sysvr4, elf binaries */ #ifdef HAVE_DLFCN_H #include #endif #else /*HAVE_DLOPEN*/ #ifdef HAVE_SHL_LOAD /* HPUX */ #include #define dlopen(path, flags) shl_load((path), (flags), 0L) #define dlclose(handle) shl_unload((handle)) #define dlerror() OsError() void * dlsym(void *handle, const char *name) { void *value; shl_t h = handle; if ( shl_findsym(&h, name, TYPE_PROCEDURE, &value) < 0 ) return NULL; return value; } #define RTLD_LAZY BIND_DEFERRED #ifdef BIND_IMMEDIATE #define RTLD_NOW BIND_IMMEDIATE #endif #endif /*HAVE_SHL_LOAD*/ #endif /*HAVE_DLOPEN*/ #endif /*EMULATE_DLOPEN*/ #if defined(HAVE_DLOPEN) || defined(HAVE_SHL_LOAD) || defined(EMULATE_DLOPEN) #define HAVE_SHARED_OBJECTS #ifndef RTLD_GLOBAL /* solaris defines this */ #define RTLD_GLOBAL 0 #endif #ifndef RTLD_NOW /* implicit on some versions */ #define RTLD_NOW 0 #endif #ifndef RTLD_LAZY /* freeBSD doesn't have this? */ #define RTLD_LAZY 0 #endif typedef int (*dl_funcptr)(); typedef struct dl_entry *DlEntry; struct dl_entry { int id; /* Prolog's identifier */ void *dlhandle; /* DL libraries identifier */ atom_t file; /* Loaded filed */ DlEntry next; /* Next in table */ }; int dl_plid; /* next id to give */ DlEntry dl_head; /* loaded DL's */ DlEntry dl_tail; /* end of this chain */ #define DL_NOW 0x1 #define DL_GLOBAL 0x2 #ifndef EMULATE_DLOPEN void * PL_dlopen(const char *file, int flags) { return dlopen(file, flags); } const char * PL_dlerror(void) { return dlerror(); } void * PL_dlsym(void *handle, char *symbol) { #ifdef RTLD_DEFAULT if ( !handle ) handle = RTLD_DEFAULT; #endif return dlsym(handle, symbol); } int PL_dlclose(void *handle) { return dlclose(handle); } #endif /*EMULATE_DLOPEN*/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - under_valgrind() True if we are running under valgrind. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #ifdef HAVE_VALGRIND_VALGRIND_H #include #endif #ifndef RUNNING_ON_VALGRIND #define RUNNING_ON_VALGRIND (getenv("VALGRIND_OPTS") != NULL) #endif static int under_valgrind(void) { static int vg = -1; if ( vg == -1 ) { #ifdef __SANITIZE_ADDRESS__ char *s; if ( (s=getenv("ASAN_OPTIONS")) && strstr(s,"detect_leaks=1") ) { vg = TRUE; return vg; } #endif if ( RUNNING_ON_VALGRIND ) { vg = TRUE; return vg; } vg = FALSE; } return vg; } static const PL_option_t open_shared_object_options[] = { { ATOM_now, OPT_BOOL }, { ATOM_global, OPT_BOOL }, { ATOM_delete, OPT_BOOL }, { ATOM_load, OPT_BOOL }, { ATOM_deepbind, OPT_BOOL }, { ATOM_resolve, OPT_ATOM }, { ATOM_visibility, OPT_ATOM }, { NULL_ATOM, 0 } }; #ifndef RTLD_NODELETE #define RTLD_NODELETE 0 #endif #ifndef RTLD_NOLOAD #define RTLD_NOLOAD 0 #endif #ifndef RTLD_DEEPBIND #define RTLD_DEEPBIND 0 #endif static int atom_domain_error(const char *domain, atom_t found) { term_t t; return ( (t=PL_new_term_ref()) && PL_put_atom(t, found) && PL_domain_error(domain, found) ); } #define open_shared_object(file, plhandle, options) \ LDFUNC(open_shared_object, file, plhandle, options) static foreign_t open_shared_object(DECL_LD term_t file, term_t plhandle, term_t options) { void *dlhandle; char *fn; atom_t afile; DlEntry e; int dlflags; int now = -1; int global = -1; int delete = TRUE; int load = TRUE; int deepbind = FALSE; atom_t resolve = 0; atom_t visibility = 0; if ( options && !PL_scan_options(options, 0, "open_shared_object_options", open_shared_object_options, &now, &global, &delete, &load, &deepbind, &resolve, &visibility) ) return FALSE; if ( resolve == ATOM_now ) now = TRUE; else if ( resolve == ATOM_lazy ) now = FALSE; else if ( resolve ) return atom_domain_error("resolve", resolve); else if ( now == -1 ) now = FALSE; if ( visibility == ATOM_global ) global = TRUE; else if ( visibility == ATOM_local ) global = FALSE; else if ( visibility ) return atom_domain_error("visibility", visibility); else if ( global == -1 ) global = FALSE; dlflags = now ? RTLD_NOW : RTLD_LAZY; if ( global ) dlflags |= RTLD_GLOBAL; if ( !delete ) dlflags |= RTLD_NODELETE; if ( !load ) dlflags |= RTLD_NOLOAD; if ( deepbind ) dlflags |= RTLD_DEEPBIND; if ( !PL_get_atom_ex(file, &afile) || !PL_get_file_name(file, &fn, 0) ) fail; if ( !(dlhandle = PL_dlopen(fn, dlflags)) ) { if ( !load ) return FALSE; return PL_error(NULL, 0, NULL, ERR_SHARED_OBJECT_OP, ATOM_open, PL_dlerror()); } e = allocHeapOrHalt(sizeof(struct dl_entry)); PL_LOCK(L_FOREIGN); e->id = ++dl_plid; e->dlhandle = dlhandle; e->file = afile; e->next = NULL; if ( !dl_tail ) { dl_tail = e; dl_head = e; } else { dl_tail->next = e; dl_tail = e; } PL_UNLOCK(L_FOREIGN); return PL_unify_integer(plhandle, e->id); } static PRED_IMPL("open_shared_object", 3, open_shared_object, 0) { PRED_LD return open_shared_object(A1, A2, A3); } static PRED_IMPL("open_shared_object", 2, open_shared_object, 0) { PRED_LD return open_shared_object(A1, A2, 0); } static DlEntry find_dl_entry(term_t h) { GET_LD DlEntry e; int id; if ( PL_get_integer(h, &id) ) { for(e = dl_head; e; e = e->next) { if ( e->id == id ) return e; } PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_shared_object_handle, h); return NULL; } PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_shared_object_handle, h); return NULL; } static PRED_IMPL("close_shared_object", 1, close_shared_object, 0) { DlEntry e = find_dl_entry(A1); if ( e && e->dlhandle) { if ( !under_valgrind() ) PL_dlclose(e->dlhandle); e->dlhandle = NULL; succeed; } fail; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Some systems (notably MacOS X) prefixes symbols with _. In some version of this OS, dlsym() adds an _, in others not. We'll try to work around this junk with a runtime test ... - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static PRED_IMPL("call_shared_object_function", 2, call_shared_object_function, PL_FA_TRANSPARENT) { DlEntry e = find_dl_entry(A1); char *fname; dl_funcptr ef; if ( !e || !e->dlhandle || !PL_get_chars(A2, &fname, CVT_ALL|CVT_EXCEPTION) ) fail; #ifdef LD_SYMBOL_PREFIX /* first try plain anyway */ if ( !(ef = (dl_funcptr) PL_dlsym(e->dlhandle, fname)) ) { char symname[MAXSYMBOLLEN+1]; if ( strlen(fname)+strlen(LD_SYMBOL_PREFIX) > MAXSYMBOLLEN ) return PL_error(NULL, 0, "Symbol too long", ERR_REPRESENTATION, PL_new_atom("symbol")); strcpy(symname, LD_SYMBOL_PREFIX); strcat(symname, fname); ef = (dl_funcptr)(intptr_t)dlsym(e->dlhandle, symname); } #else ef = (dl_funcptr)(intptr_t)PL_dlsym(e->dlhandle, fname); #endif if ( ef ) { (*ef)(); succeed; } else fail; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Unload all foreign libraries. As we are doing this at the very end of the cleanup, it should be safe now. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define CLEANUP_FOREIGN_DONE void cleanupForeign(void) { DlEntry e, next; for(e = dl_head; e; e = next) { next = e->next; if ( e->dlhandle ) { if ( !under_valgrind() ) PL_dlclose(e->dlhandle); } freeHeap(e, sizeof(*e)); } dl_plid = 0; dl_head = dl_tail = NULL; } #endif /*O_STATIC_EXTENSIONS*/ #endif /*HAVE_DLOPEN*/ #ifdef O_STATIC_EXTENSIONS #if USE_DLOPEN_SELF #include #include #endif static int activate_static_extension(const char *ename) { #if USE_DLOPEN_SELF static void *handle = NULL; char fname[256]; if ( !handle ) { handle = dlopen(NULL, 0); if ( !handle ) Sdprintf("Could not open dlopen() executable: %s\n", strerror(errno)); } strcpy(fname, "install_"); strcat(fname, ename); if ( handle ) { void *sym = dlsym(handle, fname); if ( sym ) { typedef void (*install_function)(void); install_function f = sym; (*f)(); return TRUE; } return FALSE; } #else typedef void (*install_func)(void); typedef struct static_extension { const char *name; const install_func func; } static_extension; #include for(const static_extension *ext = static_extensions; ext->name; ext++) { if ( strcmp(ename, ext->name) == 0 ) { (*ext->func)(); return TRUE; } } return FALSE; #endif } static PRED_IMPL("$activate_static_extension", 1, activate_static_extension, PL_FA_TRANSPARENT) { char *ename; if ( PL_get_chars(A1, &ename, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) ) { if ( activate_static_extension(ename) ) return TRUE; return PL_existence_error("foreign_extension", A1); } else return FALSE; } #endif /*O_STATIC_EXTENSIONS*/ #ifndef CLEANUP_FOREIGN_DONE /* No-op stub for pl-init.c to call. */ void cleanupForeign(void) {} #endif /******************************* * PUBLISH PREDICATES * *******************************/ BeginPredDefs(dlopen) #if defined(HAVE_SHARED_OBJECTS) && !defined(O_STATIC_EXTENSIONS) PRED_DEF("open_shared_object", 2, open_shared_object, 0) PRED_DEF("open_shared_object", 3, open_shared_object, 0) PRED_DEF("close_shared_object", 1, close_shared_object, 0) PRED_DEF("call_shared_object_function", 2, call_shared_object_function, PL_FA_TRANSPARENT) #endif #ifdef O_STATIC_EXTENSIONS PRED_DEF("$activate_static_extension", 1, activate_static_extension, PL_FA_TRANSPARENT) #endif EndPredDefs