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 #include <string.h>
  30
  31 /* "dynl.c" dynamically link&load object files.
  32    Author: Aubrey Jaffer
  33    Modified for libguile by Marius Vollmer */
  34
  35 #if 0 /* Disabled until we know for sure that it isn't needed */
  36 /* XXX - This is only here to drag in a definition of __eprintf. This
  37    is needed for proper operation of dynamic linking. The real
  38    solution would probably be a shared libgcc. */
  39
  40 #undef NDEBUG
  41 #include <assert.h>
  42
  43 static void
  44 maybe_drag_in_eprintf ()
  45 {
  46   assert (!maybe_drag_in_eprintf);
  47 }
  48 #endif
  49
  50 #include <stdlib.h>
  51 #include <stdio.h>
  52 #include <string.h>
  53
  54 #include "libguile/_scm.h"
  55 #include "libguile/libpath.h"
  56 #include "libguile/dynl.h"
  57 #include "libguile/smob.h"
  58 #include "libguile/keywords.h"
  59 #include "libguile/ports.h"
  60 #include "libguile/strings.h"
  61 #include "libguile/deprecation.h"
  62 #include "libguile/validate.h"
  63 #include "libguile/dynwind.h"
  64 #include "libguile/foreign.h"
  65 #include "libguile/gc.h"
  66
  67 #include <ltdl.h>
  68
  69 /*
  70   From the libtool manual: "Note that libltdl is not threadsafe,
  71   i.e. a multithreaded application has to use a mutex for libltdl.".
  72
  73   Guile does not currently support pre-emptive threads, so there is no
  74   mutex.  Previously SCM_CRITICAL_SECTION_START and
  75   SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
  76   somebody is grepping for thread problems ;)
  77 */
  78 /* njrev: not threadsafe, protection needed as described above */
  79
  80
  81 /* LT_PATH_SEP-separated extension library search path, searched last */
  82 static char *system_extensions_path;
  83
  84 static void *
  85 sysdep_dynl_link (const char *fname, const char *subr)
  86 {
  87   lt_dlhandle handle;
  88
  89   if (fname == NULL)
  90     /* Return a handle for the program as a whole.  */
  91     handle = lt_dlopen (NULL);
  92   else
  93     {
  94       handle = lt_dlopenext (fname);
  95
  96       if (handle == NULL
  97 #ifdef LT_DIRSEP_CHAR
  98           && strchr (fname, LT_DIRSEP_CHAR) == NULL
  99 #endif
 100           && strchr (fname, '/') == NULL)
 101         {
 102           /* FNAME contains no directory separators and was not in the
 103              usual library search paths, so now we search for it in
 104              SYSTEM_EXTENSIONS_PATH. */
 105           char *fname_attempt
 106             = scm_gc_malloc_pointerless (strlen (system_extensions_path)
 107                                          + strlen (fname) + 2,
 108                                          "dynl fname_attempt");
 109           char *path;  /* remaining path to search */
 110           char *end;   /* end of current path component */
 111           char *s;
 112
 113           /* Iterate over the components of SYSTEM_EXTENSIONS_PATH */
 114           for (path = system_extensions_path;
 115                *path != '\0';
 116                path = (*end == '\0') ? end : (end + 1))
 117             {
 118               /* Find end of path component */
 119               end = strchr (path, LT_PATHSEP_CHAR);
 120               if (end == NULL)
 121                 end = strchr (path, '\0');
 122
 123               /* Skip empty path components */
 124               if (path == end)
 125                 continue;
 126
 127               /* Construct FNAME_ATTEMPT, starting with path component */
 128               s = fname_attempt;
 129               memcpy (s, path, end - path);
 130               s += end - path;
 131
 132               /* Append directory separator, but avoid duplicates */
 133               if (s[-1] != '/'
 134 #ifdef LT_DIRSEP_CHAR
 135                   && s[-1] != LT_DIRSEP_CHAR
 136 #endif
 137                   )
 138                 *s++ = '/';
 139
 140               /* Finally, append FNAME (including null terminator) */
 141               strcpy (s, fname);
 142
 143               /* Try to load it, and terminate the search if successful */
 144               handle = lt_dlopenext (fname_attempt);
 145               if (handle != NULL)
 146                 break;
 147             }
 148         }
 149     }
 150
 151   if (handle == NULL)
 152     {
 153       SCM fn;
 154       SCM msg;
 155
 156       fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
 157       msg = scm_from_locale_string (lt_dlerror ());
 158       scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
 159     }
 160
 161   return (void *) handle;
 162 }
 163
 164 static void
 165 sysdep_dynl_unlink (void *handle, const char *subr)
 166 {
 167   if (lt_dlclose ((lt_dlhandle) handle))
 168     {
 169       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 170     }
 171 }
 172
 173 static void *
 174 sysdep_dynl_value (const char *symb, void *handle, const char *subr)
 175 {
 176   void *fptr;
 177
 178   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 179   if (!fptr)
 180     scm_misc_error (subr, "Symbol not found: ~a",
 181                     scm_list_1 (scm_from_locale_string (symb)));
 182   return fptr;
 183 }
 184
 185 static void
 186 sysdep_dynl_init ()
 187 {
 188   char *env;
 189
 190   lt_dlinit ();
 191
 192   /* Initialize 'system_extensions_path' from
 193      $GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set:
 194      <SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>.
 195
 196      'lt_dladdsearchdir' can't be used because it is searched before
 197      the system-dependent search path, which is the one 'libtool
 198      --mode=execute -dlopen' fiddles with (info "(libtool) Libltdl
 199      Interface").  See
 200      <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>.
 201
 202      The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH
 203      can't be used because they would be propagated to subprocesses
 204      which may cause problems for other programs.  See
 205      <http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */
 206
 207   env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
 208   if (env)
 209     system_extensions_path = env;
 210   else
 211     {
 212       system_extensions_path
 213         = scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR)
 214                                      + strlen (SCM_EXTENSIONS_DIR) + 2,
 215                                      "system_extensions_path");
 216       sprintf (system_extensions_path, "%s%c%s",
 217                SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR);
 218     }
 219 }
 220
 221 scm_t_bits scm_tc16_dynamic_obj;
 222
 223 #define DYNL_FILENAME         SCM_SMOB_OBJECT
 224 #define DYNL_HANDLE(x)        ((void *) SCM_SMOB_DATA_2 (x))
 225 #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
 226
 227
 228
 229 static int
 230 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 231 {
 232   scm_puts_unlocked ("#<dynamic-object ", port);
 233   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 234   if (DYNL_HANDLE (exp) == NULL)
 235     scm_puts_unlocked (" (unlinked)", port);
 236   scm_putc_unlocked ('>', port);
 237   return 1;
 238 }
 239
 240
 241 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0,
 242             (SCM filename),
 243             "Find the shared object (shared library) denoted by\n"
 244             "@var{filename} and link it into the running Guile\n"
 245             "application.  The returned\n"
 246             "scheme object is a ``handle'' for the library which can\n"
 247             "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
 248             "Searching for object files is system dependent.  Normally,\n"
 249             "if @var{filename} does have an explicit directory it will\n"
 250             "be searched for in locations\n"
 251             "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
 252             "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
 253             "returned.  This handle provides access to the symbols\n"
 254             "available to the program at run-time, including those exported\n"
 255             "by the program itself and the shared libraries already loaded.\n")
 256 #define FUNC_NAME s_scm_dynamic_link
 257 {
 258   void *handle;
 259   char *file;
 260
 261   scm_dynwind_begin (0);
 262
 263   if (SCM_UNBNDP (filename))
 264     file = NULL;
 265   else
 266     {
 267       file = scm_to_locale_string (filename);
 268       scm_dynwind_free (file);
 269     }
 270
 271   handle = sysdep_dynl_link (file, FUNC_NAME);
 272   scm_dynwind_end ();
 273
 274   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
 275                        SCM_UNBNDP (filename)
 276                        ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
 277                        handle);
 278 }
 279 #undef FUNC_NAME
 280
 281
 282 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 283             (SCM obj),
 284             "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
 285             "or @code{#f} otherwise.")
 286 #define FUNC_NAME s_scm_dynamic_object_p
 287 {
 288   return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 289 }
 290 #undef FUNC_NAME
 291
 292
 293 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 294             (SCM dobj),
 295             "Unlink a dynamic object from the application, if possible.  The\n"
 296             "object must have been linked by @code{dynamic-link}, with \n"
 297             "@var{dobj} the corresponding handle.  After this procedure\n"
 298             "is called, the handle can no longer be used to access the\n"
 299             "object.")
 300 #define FUNC_NAME s_scm_dynamic_unlink
 301 {
 302   /*fixme* GC-problem */
 303   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 304   if (DYNL_HANDLE (dobj) == NULL) {
 305     SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
 306   } else {
 307     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 308     SET_DYNL_HANDLE (dobj, NULL);
 309     return SCM_UNSPECIFIED;
 310   }
 311 }
 312 #undef FUNC_NAME
 313
 314
 315 SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
 316             (SCM name, SCM dobj),
 317             "Return a ``wrapped pointer'' to the symbol @var{name}\n"
 318             "in the shared object referred to by @var{dobj}.  The returned\n"
 319             "pointer points to a C object.\n\n"
 320             "Regardless whether your C compiler prepends an underscore\n"
 321             "@samp{_} to the global names in a program, you should\n"
 322             "@strong{not} include this underscore in @var{name}\n"
 323             "since it will be added automatically when necessary.")
 324 #define FUNC_NAME s_scm_dynamic_pointer
 325 {
 326   void *val;
 327
 328   SCM_VALIDATE_STRING (1, name);
 329   SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
 330
 331   if (DYNL_HANDLE (dobj) == NULL)
 332     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 333   else
 334     {
 335       char *chars;
 336
 337       scm_dynwind_begin (0);
 338       chars = scm_to_locale_string (name);
 339       scm_dynwind_free (chars);
 340       val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
 341       scm_dynwind_end ();
 342
 343       return scm_from_pointer (val, NULL);
 344     }
 345 }
 346 #undef FUNC_NAME
 347
 348
 349 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 350             (SCM name, SCM dobj),
 351             "Return a ``handle'' for the function @var{name} in the\n"
 352             "shared object referred to by @var{dobj}.  The handle\n"
 353             "can be passed to @code{dynamic-call} to actually\n"
 354             "call the function.\n\n"
 355             "Regardless whether your C compiler prepends an underscore\n"
 356             "@samp{_} to the global names in a program, you should\n"
 357             "@strong{not} include this underscore in @var{name}\n"
 358             "since it will be added automatically when necessary.")
 359 #define FUNC_NAME s_scm_dynamic_func
 360 {
 361   return scm_dynamic_pointer (name, dobj);
 362 }
 363 #undef FUNC_NAME
 364
 365
 366 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 367             (SCM func, SCM dobj),
 368             "Call a C function in a dynamic object.  Two styles of\n"
 369             "invocation are supported:\n\n"
 370             "@itemize @bullet\n"
 371             "@item @var{func} can be a function handle returned by\n"
 372             "@code{dynamic-func}.  In this case @var{dobj} is\n"
 373             "ignored\n"
 374             "@item @var{func} can be a string with the name of the\n"
 375             "function to call, with @var{dobj} the handle of the\n"
 376             "dynamic object in which to find the function.\n"
 377             "This is equivalent to\n"
 378             "@smallexample\n\n"
 379             "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
 380             "@end smallexample\n"
 381             "@end itemize\n\n"
 382             "In either case, the function is passed no arguments\n"
 383             "and its return value is ignored.")
 384 #define FUNC_NAME s_scm_dynamic_call
 385 {
 386   void (*fptr) (void);
 387
 388   if (scm_is_string (func))
 389     func = scm_dynamic_func (func, dobj);
 390   SCM_VALIDATE_POINTER (SCM_ARG1, func);
 391
 392   fptr = SCM_POINTER_VALUE (func);
 393   fptr ();
 394   return SCM_UNSPECIFIED;
 395 }
 396 #undef FUNC_NAME
 397
 398 void
 399 scm_init_dynamic_linking ()
 400 {
 401   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 402   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 403   sysdep_dynl_init ();
 404 #include "libguile/dynl.x"
 405 }
 406
 407 /*
 408   Local Variables:
 409   c-file-style: "gnu"
 410   End:
 411 */