/* dynl.c - dynamic linking
*
* Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
- * 2003, 2008, 2009, 2010 Free Software Foundation, Inc.
+ * 2003, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
# include <config.h>
#endif
+#include <alloca.h>
+#include <string.h>
+
/* "dynl.c" dynamically link&load object files.
Author: Aubrey Jaffer
Modified for libguile by Marius Vollmer */
}
#endif
+#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/deprecation.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
#include "libguile/foreign.h"
+#include "libguile/gc.h"
#include <ltdl.h>
*/
/* njrev: not threadsafe, protection needed as described above */
+
+/* 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)
- handle = lt_dlopenext (fname);
- else
+ 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 (NULL == handle)
+ if (handle == NULL)
{
SCM fn;
SCM msg;
fptr = lt_dlsym ((lt_dlhandle) handle, symb);
if (!fptr)
- {
- scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
- }
+ scm_misc_error (subr, "Symbol not found: ~a",
+ scm_list_1 (scm_from_locale_string (symb)));
return fptr;
}
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 && strcmp (env, "") == 0)
- /* special-case interpret system-ltdl-path=="" as meaning no system path,
- which is the case during the build */
- ;
- else if (env)
- /* FIXME: should this be a colon-separated path? Or is the only point to
- allow the build system to turn off the installed extensions path? */
- lt_dladdsearchdir (env);
+ if (env)
+ system_extensions_path = env;
else
{
- lt_dladdsearchdir (SCM_LIB_DIR);
- lt_dladdsearchdir (SCM_EXTENSIONS_DIR);
+ 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);
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
- (SCM name, SCM type, SCM dobj, SCM len),
- "Return a ``handle'' for the pointer @var{name} in the\n"
- "shared object referred to by @var{dobj}. The handle\n"
- "aliases a C value, and is declared to be of type\n"
- "@var{type}. Valid types are defined in the\n"
- "@code{(system foreign)} module.\n\n"
- "This facility works by asking the dynamic linker for\n"
- "the address of a symbol, then assuming that it aliases a\n"
- "value of a given type. Obviously, the user must be very\n"
- "careful to ensure that the value actually is of the\n"
- "declared type, or bad things will happen.\n\n"
+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"
#define FUNC_NAME s_scm_dynamic_pointer
{
void *val;
- scm_t_foreign_type t;
SCM_VALIDATE_STRING (1, name);
- t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
- SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
+ SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL)
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
scm_dynwind_end ();
- return scm_take_foreign_pointer (t, val,
- SCM_UNBNDP (len) ? 0 : scm_to_size_t (len),
- NULL);
+ return scm_from_pointer (val, NULL);
}
}
#undef FUNC_NAME
"since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func
{
- return scm_dynamic_pointer (name,
- scm_from_uint (SCM_FOREIGN_TYPE_VOID),
- dobj,
- SCM_UNDEFINED);
+ return scm_dynamic_pointer (name, dobj);
}
#undef FUNC_NAME
"and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call
{
- void (*fptr) ();
-
+ void (*fptr) (void);
+
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
+ SCM_VALIDATE_POINTER (SCM_ARG1, func);
- fptr = SCM_FOREIGN_POINTER (func, void);
+ fptr = SCM_POINTER_VALUE (func);
fptr ();
return SCM_UNSPECIFIED;
}
HCoop / bpt / guile.git / blobdiff