summaryrefslogtreecommitdiff
path: root/libguile/dynl.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/dynl.c')
-rw-r--r--libguile/dynl.c397
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 (&ltdl_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 (&ltdl_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 (&ltdl_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 (&ltdl_lock,
+ scm_i_pthread_mutexattr_recursive);
+
+ sysdep_dynl_init ();
+#include "dynl.x"
+}