diff options
Diffstat (limited to 'libguile/dynl.c')
-rw-r--r-- | libguile/dynl.c | 397 |
1 files changed, 397 insertions, 0 deletions
diff --git a/libguile/dynl.c b/libguile/dynl.c new file mode 100644 index 000000000..bf7163c38 --- /dev/null +++ b/libguile/dynl.c @@ -0,0 +1,397 @@ +/* dynl.c - dynamic linking + + Copyright 1990-2003,2008-2011,2017-2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + +/* "dynl.c" dynamically link&load object files. + Author: Aubrey Jaffer + Modified for libguile by Marius Vollmer */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <alloca.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include <ltdl.h> + +#include "deprecation.h" +#include "dynwind.h" +#include "foreign.h" +#include "gc.h" +#include "gsubr.h" +#include "keywords.h" +#include "libpath.h" +#include "list.h" +#include "ports.h" +#include "smob.h" +#include "strings.h" +#include "threads.h" + +#include "dynl.h" + + +/* From the libtool manual: "Note that libltdl is not threadsafe, + i.e. a multithreaded application has to use a mutex for libltdl.". + Note: We initialize it as a recursive mutex below. */ +static scm_i_pthread_mutex_t ltdl_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; + +/* LT_PATH_SEP-separated extension library search path, searched last */ +static char *system_extensions_path; + +static void * +sysdep_dynl_link (const char *fname, const char *subr) +{ + lt_dlhandle handle; + + if (fname == NULL) + /* Return a handle for the program as a whole. */ + handle = lt_dlopen (NULL); + else + { + handle = lt_dlopenext (fname); + + if (handle == NULL +#ifdef LT_DIRSEP_CHAR + && strchr (fname, LT_DIRSEP_CHAR) == NULL +#endif + && strchr (fname, '/') == NULL) + { + /* FNAME contains no directory separators and was not in the + usual library search paths, so now we search for it in + SYSTEM_EXTENSIONS_PATH. */ + char *fname_attempt + = scm_gc_malloc_pointerless (strlen (system_extensions_path) + + strlen (fname) + 2, + "dynl fname_attempt"); + char *path; /* remaining path to search */ + char *end; /* end of current path component */ + char *s; + + /* Iterate over the components of SYSTEM_EXTENSIONS_PATH */ + for (path = system_extensions_path; + *path != '\0'; + path = (*end == '\0') ? end : (end + 1)) + { + /* Find end of path component */ + end = strchr (path, LT_PATHSEP_CHAR); + if (end == NULL) + end = strchr (path, '\0'); + + /* Skip empty path components */ + if (path == end) + continue; + + /* Construct FNAME_ATTEMPT, starting with path component */ + s = fname_attempt; + memcpy (s, path, end - path); + s += end - path; + + /* Append directory separator, but avoid duplicates */ + if (s[-1] != '/' +#ifdef LT_DIRSEP_CHAR + && s[-1] != LT_DIRSEP_CHAR +#endif + ) + *s++ = '/'; + + /* Finally, append FNAME (including null terminator) */ + strcpy (s, fname); + + /* Try to load it, and terminate the search if successful */ + handle = lt_dlopenext (fname_attempt); + if (handle != NULL) + break; + } + } + } + + if (handle == NULL) + { + SCM fn; + SCM msg; + + fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F; + msg = scm_from_locale_string (lt_dlerror ()); + scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg)); + } + + return (void *) handle; +} + +static void +sysdep_dynl_unlink (void *handle, const char *subr) +{ + if (lt_dlclose ((lt_dlhandle) handle)) + { + scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL); + } +} + +static void * +sysdep_dynl_value (const char *symb, void *handle, const char *subr) +{ + void *fptr; + + fptr = lt_dlsym ((lt_dlhandle) handle, symb); + if (!fptr) + scm_misc_error (subr, "Symbol not found: ~a", + scm_list_1 (scm_from_locale_string (symb))); + return fptr; +} + +static void +sysdep_dynl_init () +{ + char *env; + + lt_dlinit (); + + /* Initialize 'system_extensions_path' from + $GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set: + <SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>. + + 'lt_dladdsearchdir' can't be used because it is searched before + the system-dependent search path, which is the one 'libtool + --mode=execute -dlopen' fiddles with (info "(libtool) Libltdl + Interface"). See + <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>. + + The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH + can't be used because they would be propagated to subprocesses + which may cause problems for other programs. See + <http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */ + + env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH"); + if (env) + system_extensions_path = env; + else + { + system_extensions_path + = scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR) + + strlen (SCM_EXTENSIONS_DIR) + 2, + "system_extensions_path"); + sprintf (system_extensions_path, "%s%c%s", + SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR); + } +} + +scm_t_bits scm_tc16_dynamic_obj; + +#define DYNL_FILENAME SCM_SMOB_OBJECT +#define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x)) +#define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v))) + + + +static int +dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) +{ + scm_puts ("#<dynamic-object ", port); + scm_iprin1 (DYNL_FILENAME (exp), port, pstate); + if (DYNL_HANDLE (exp) == NULL) + scm_puts (" (unlinked)", port); + scm_putc ('>', port); + return 1; +} + + +SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0, + (SCM filename), + "Find the shared object (shared library) denoted by\n" + "@var{filename} and link it into the running Guile\n" + "application. The returned\n" + "scheme object is a ``handle'' for the library which can\n" + "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n" + "Searching for object files is system dependent. Normally,\n" + "if @var{filename} does have an explicit directory it will\n" + "be searched for in locations\n" + "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n" + "When @var{filename} is omitted, a @dfn{global symbol handle} is\n" + "returned. This handle provides access to the symbols\n" + "available to the program at run-time, including those exported\n" + "by the program itself and the shared libraries already loaded.\n") +#define FUNC_NAME s_scm_dynamic_link +{ + void *handle; + char *file; + + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (<dl_lock); + + if (SCM_UNBNDP (filename)) + file = NULL; + else + { + file = scm_to_locale_string (filename); + scm_dynwind_free (file); + } + + handle = sysdep_dynl_link (file, FUNC_NAME); + scm_dynwind_end (); + + SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, + SCM_UNBNDP (filename) + ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename), + handle); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a dynamic object handle,\n" + "or @code{#f} otherwise.") +#define FUNC_NAME s_scm_dynamic_object_p +{ + return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, + (SCM dobj), + "Unlink a dynamic object from the application, if possible. The\n" + "object must have been linked by @code{dynamic-link}, with \n" + "@var{dobj} the corresponding handle. After this procedure\n" + "is called, the handle can no longer be used to access the\n" + "object.") +#define FUNC_NAME s_scm_dynamic_unlink +{ + /*fixme* GC-problem */ + SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj); + + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (<dl_lock); + if (DYNL_HANDLE (dobj) == NULL) { + SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj)); + } else { + sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME); + SET_DYNL_HANDLE (dobj, NULL); + } + scm_dynwind_end (); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0, + (SCM name, SCM dobj), + "Return a ``wrapped pointer'' to the symbol @var{name}\n" + "in the shared object referred to by @var{dobj}. The returned\n" + "pointer points to a C object.\n\n" + "Regardless whether your C compiler prepends an underscore\n" + "@samp{_} to the global names in a program, you should\n" + "@strong{not} include this underscore in @var{name}\n" + "since it will be added automatically when necessary.") +#define FUNC_NAME s_scm_dynamic_pointer +{ + void *val; + + SCM_VALIDATE_STRING (1, name); + SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj); + + if (DYNL_HANDLE (dobj) == NULL) + SCM_MISC_ERROR ("Already unlinked: ~S", dobj); + else + { + char *chars; + + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (<dl_lock); + chars = scm_to_locale_string (name); + scm_dynwind_free (chars); + val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME); + scm_dynwind_end (); + + return scm_from_pointer (val, NULL); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, + (SCM name, SCM dobj), + "Return a ``handle'' for the function @var{name} in the\n" + "shared object referred to by @var{dobj}. The handle\n" + "can be passed to @code{dynamic-call} to actually\n" + "call the function.\n\n" + "Regardless whether your C compiler prepends an underscore\n" + "@samp{_} to the global names in a program, you should\n" + "@strong{not} include this underscore in @var{name}\n" + "since it will be added automatically when necessary.") +#define FUNC_NAME s_scm_dynamic_func +{ + return scm_dynamic_pointer (name, dobj); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, + (SCM func, SCM dobj), + "Call a C function in a dynamic object. Two styles of\n" + "invocation are supported:\n\n" + "@itemize @bullet\n" + "@item @var{func} can be a function handle returned by\n" + "@code{dynamic-func}. In this case @var{dobj} is\n" + "ignored\n" + "@item @var{func} can be a string with the name of the\n" + "function to call, with @var{dobj} the handle of the\n" + "dynamic object in which to find the function.\n" + "This is equivalent to\n" + "@smallexample\n\n" + "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n" + "@end smallexample\n" + "@end itemize\n\n" + "In either case, the function is passed no arguments\n" + "and its return value is ignored.") +#define FUNC_NAME s_scm_dynamic_call +{ + void (*fptr) (void); + + if (scm_is_string (func)) + func = scm_dynamic_func (func, dobj); + SCM_VALIDATE_POINTER (SCM_ARG1, func); + + fptr = SCM_POINTER_VALUE (func); + fptr (); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_init_dynamic_linking () +{ + scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0); + scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print); + + /* Make LTDL_LOCK recursive so that a pre-unwind handler can still use + 'dynamic-link', as is the case at the REPL. See + <https://bugs.gnu.org/29275>. */ + scm_i_pthread_mutex_init (<dl_lock, + scm_i_pthread_mutexattr_recursive); + + sysdep_dynl_init (); +#include "dynl.x" +} |