libguile/dynl.c

   1 /* dynl.c - dynamic linking
   2  *
   3  * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
   4  * 2003, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   5  *
   6  * This library is free software; you can redistribute it and/or
   7  * modify it under the terms of the GNU Lesser General Public License
   8  * as published by the Free Software Foundation; either version 3 of
   9  * the License, or (at your option) any later version.
  10  *
  11  * This library is distributed in the hope that it will be useful, but
  12  * WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14  * Lesser General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU Lesser General Public
  17  * License along with this library; if not, write to the Free Software
  18  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  19  * 02110-1301 USA
  20  */
  21
  22
  23
  24 #ifdef HAVE_CONFIG_H
  25 # include <config.h>
  26 #endif
  27
  28 #include <alloca.h>
  29
  30 /* "dynl.c" dynamically link&load object files.
  31    Author: Aubrey Jaffer
  32    Modified for libguile by Marius Vollmer */
  33
  34 #if 0 /* Disabled until we know for sure that it isn't needed */
  35 /* XXX - This is only here to drag in a definition of __eprintf. This
  36    is needed for proper operation of dynamic linking. The real
  37    solution would probably be a shared libgcc. */
  38
  39 #undef NDEBUG
  40 #include <assert.h>
  41
  42 static void
  43 maybe_drag_in_eprintf ()
  44 {
  45   assert (!maybe_drag_in_eprintf);
  46 }
  47 #endif
  48
  49 #include <stdlib.h>
  50 #include <stdio.h>
  51 #include <string.h>
  52
  53 #include "libguile/_scm.h"
  54 #include "libguile/libpath.h"
  55 #include "libguile/dynl.h"
  56 #include "libguile/smob.h"
  57 #include "libguile/keywords.h"
  58 #include "libguile/ports.h"
  59 #include "libguile/strings.h"
  60 #include "libguile/deprecation.h"
  61 #include "libguile/validate.h"
  62 #include "libguile/dynwind.h"
  63 #include "libguile/foreign.h"
  64
  65 #include <ltdl.h>
  66
  67 /*
  68   From the libtool manual: "Note that libltdl is not threadsafe,
  69   i.e. a multithreaded application has to use a mutex for libltdl.".
  70
  71   Guile does not currently support pre-emptive threads, so there is no
  72   mutex.  Previously SCM_CRITICAL_SECTION_START and
  73   SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
  74   somebody is grepping for thread problems ;)
  75 */
  76 /* njrev: not threadsafe, protection needed as described above */
  77
  78 static void *
  79 sysdep_dynl_link (const char *fname, const char *subr)
  80 {
  81   lt_dlhandle handle;
  82
  83   if (fname != NULL)
  84     handle = lt_dlopenext (fname);
  85   else
  86     /* Return a handle for the program as a whole.  */
  87     handle = lt_dlopen (NULL);
  88
  89   if (NULL == handle)
  90     {
  91       SCM fn;
  92       SCM msg;
  93
  94       fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
  95       msg = scm_from_locale_string (lt_dlerror ());
  96       scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
  97     }
  98
  99   return (void *) handle;
 100 }
 101
 102 static void
 103 sysdep_dynl_unlink (void *handle, const char *subr)
 104 {
 105   if (lt_dlclose ((lt_dlhandle) handle))
 106     {
 107       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 108     }
 109 }
 110
 111 static void *
 112 sysdep_dynl_value (const char *symb, void *handle, const char *subr)
 113 {
 114   void *fptr;
 115
 116   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 117   if (!fptr)
 118     scm_misc_error (subr, "Symbol not found: ~a",
 119                     scm_list_1 (scm_from_locale_string (symb)));
 120   return fptr;
 121 }
 122
 123 /* Augment environment variable VARIABLE with VALUE, assuming VARIABLE
 124    is a path kind of variable.  */
 125 static void
 126 augment_env (const char *variable, const char *value)
 127 {
 128   const char *env;
 129
 130   env = getenv (variable);
 131   if (env != NULL)
 132     {
 133       char *new_value;
 134       static const char path_sep[] = { LT_PATHSEP_CHAR, 0 };
 135
 136       new_value = alloca (strlen (env) + strlen (value) + 2);
 137       strcpy (new_value, env);
 138       strcat (new_value, path_sep);
 139       strcat (new_value, value);
 140
 141       setenv (variable, new_value, 1);
 142     }
 143   else
 144     setenv (variable, value, 1);
 145 }
 146
 147 static void
 148 sysdep_dynl_init ()
 149 {
 150   char *env;
 151
 152   lt_dlinit ();
 153
 154   env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
 155   if (env && strcmp (env, "") == 0)
 156     /* special-case interpret system-ltdl-path=="" as meaning no system path,
 157        which is the case during the build */
 158     ;
 159   else if (env)
 160     /* FIXME: should this be a colon-separated path? Or is the only point to
 161        allow the build system to turn off the installed extensions path? */
 162     lt_dladdsearchdir (env);
 163   else
 164     {
 165       /* Add SCM_LIB_DIR and SCM_EXTENSIONS_DIR to the loader's search
 166          path.  `lt_dladdsearchdir' and $LTDL_LIBRARY_PATH can't be used
 167          for that because they are searched before the system-dependent
 168          search path, which is the one `libtool --mode=execute -dlopen'
 169          fiddles with (info "(libtool) Libltdl Interface").  See
 170          <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>
 171          for details.  */
 172       augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_LIB_DIR);
 173       augment_env (SHARED_LIBRARY_PATH_VARIABLE, SCM_EXTENSIONS_DIR);
 174     }
 175 }
 176
 177 scm_t_bits scm_tc16_dynamic_obj;
 178
 179 #define DYNL_FILENAME         SCM_SMOB_OBJECT
 180 #define DYNL_HANDLE(x)        ((void *) SCM_SMOB_DATA_2 (x))
 181 #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
 182
 183
 184
 185 static int
 186 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 187 {
 188   scm_puts_unlocked ("#<dynamic-object ", port);
 189   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 190   if (DYNL_HANDLE (exp) == NULL)
 191     scm_puts_unlocked (" (unlinked)", port);
 192   scm_putc_unlocked ('>', port);
 193   return 1;
 194 }
 195
 196
 197 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0,
 198             (SCM filename),
 199             "Find the shared object (shared library) denoted by\n"
 200             "@var{filename} and link it into the running Guile\n"
 201             "application.  The returned\n"
 202             "scheme object is a ``handle'' for the library which can\n"
 203             "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
 204             "Searching for object files is system dependent.  Normally,\n"
 205             "if @var{filename} does have an explicit directory it will\n"
 206             "be searched for in locations\n"
 207             "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
 208             "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
 209             "returned.  This handle provides access to the symbols\n"
 210             "available to the program at run-time, including those exported\n"
 211             "by the program itself and the shared libraries already loaded.\n")
 212 #define FUNC_NAME s_scm_dynamic_link
 213 {
 214   void *handle;
 215   char *file;
 216
 217   scm_dynwind_begin (0);
 218
 219   if (SCM_UNBNDP (filename))
 220     file = NULL;
 221   else
 222     {
 223       file = scm_to_locale_string (filename);
 224       scm_dynwind_free (file);
 225     }
 226
 227   handle = sysdep_dynl_link (file, FUNC_NAME);
 228   scm_dynwind_end ();
 229
 230   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
 231                        SCM_UNBNDP (filename)
 232                        ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
 233                        handle);
 234 }
 235 #undef FUNC_NAME
 236
 237
 238 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 239             (SCM obj),
 240             "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
 241             "or @code{#f} otherwise.")
 242 #define FUNC_NAME s_scm_dynamic_object_p
 243 {
 244   return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 245 }
 246 #undef FUNC_NAME
 247
 248
 249 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 250             (SCM dobj),
 251             "Unlink a dynamic object from the application, if possible.  The\n"
 252             "object must have been linked by @code{dynamic-link}, with \n"
 253             "@var{dobj} the corresponding handle.  After this procedure\n"
 254             "is called, the handle can no longer be used to access the\n"
 255             "object.")
 256 #define FUNC_NAME s_scm_dynamic_unlink
 257 {
 258   /*fixme* GC-problem */
 259   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 260   if (DYNL_HANDLE (dobj) == NULL) {
 261     SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
 262   } else {
 263     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 264     SET_DYNL_HANDLE (dobj, NULL);
 265     return SCM_UNSPECIFIED;
 266   }
 267 }
 268 #undef FUNC_NAME
 269
 270
 271 SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
 272             (SCM name, SCM dobj),
 273             "Return a ``wrapped pointer'' to the symbol @var{name}\n"
 274             "in the shared object referred to by @var{dobj}.  The returned\n"
 275             "pointer points to a C object.\n\n"
 276             "Regardless whether your C compiler prepends an underscore\n"
 277             "@samp{_} to the global names in a program, you should\n"
 278             "@strong{not} include this underscore in @var{name}\n"
 279             "since it will be added automatically when necessary.")
 280 #define FUNC_NAME s_scm_dynamic_pointer
 281 {
 282   void *val;
 283
 284   SCM_VALIDATE_STRING (1, name);
 285   SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
 286
 287   if (DYNL_HANDLE (dobj) == NULL)
 288     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 289   else
 290     {
 291       char *chars;
 292
 293       scm_dynwind_begin (0);
 294       chars = scm_to_locale_string (name);
 295       scm_dynwind_free (chars);
 296       val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
 297       scm_dynwind_end ();
 298
 299       return scm_from_pointer (val, NULL);
 300     }
 301 }
 302 #undef FUNC_NAME
 303
 304
 305 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 306             (SCM name, SCM dobj),
 307             "Return a ``handle'' for the function @var{name} in the\n"
 308             "shared object referred to by @var{dobj}.  The handle\n"
 309             "can be passed to @code{dynamic-call} to actually\n"
 310             "call the function.\n\n"
 311             "Regardless whether your C compiler prepends an underscore\n"
 312             "@samp{_} to the global names in a program, you should\n"
 313             "@strong{not} include this underscore in @var{name}\n"
 314             "since it will be added automatically when necessary.")
 315 #define FUNC_NAME s_scm_dynamic_func
 316 {
 317   return scm_dynamic_pointer (name, dobj);
 318 }
 319 #undef FUNC_NAME
 320
 321
 322 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 323             (SCM func, SCM dobj),
 324             "Call a C function in a dynamic object.  Two styles of\n"
 325             "invocation are supported:\n\n"
 326             "@itemize @bullet\n"
 327             "@item @var{func} can be a function handle returned by\n"
 328             "@code{dynamic-func}.  In this case @var{dobj} is\n"
 329             "ignored\n"
 330             "@item @var{func} can be a string with the name of the\n"
 331             "function to call, with @var{dobj} the handle of the\n"
 332             "dynamic object in which to find the function.\n"
 333             "This is equivalent to\n"
 334             "@smallexample\n\n"
 335             "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
 336             "@end smallexample\n"
 337             "@end itemize\n\n"
 338             "In either case, the function is passed no arguments\n"
 339             "and its return value is ignored.")
 340 #define FUNC_NAME s_scm_dynamic_call
 341 {
 342   void (*fptr) (void);
 343
 344   if (scm_is_string (func))
 345     func = scm_dynamic_func (func, dobj);
 346   SCM_VALIDATE_POINTER (SCM_ARG1, func);
 347
 348   fptr = SCM_POINTER_VALUE (func);
 349   fptr ();
 350   return SCM_UNSPECIFIED;
 351 }
 352 #undef FUNC_NAME
 353
 354 void
 355 scm_init_dynamic_linking ()
 356 {
 357   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 358   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 359   sysdep_dynl_init ();
 360 #include "libguile/dynl.x"
 361 }
 362
 363 /*
 364   Local Variables:
 365   c-file-style: "gnu"
 366   End:
 367 */