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 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 /* "dynl.c" dynamically link&load object files.
  29    Author: Aubrey Jaffer
  30    Modified for libguile by Marius Vollmer */
  31
  32 #if 0 /* Disabled until we know for sure that it isn't needed */
  33 /* XXX - This is only here to drag in a definition of __eprintf. This
  34    is needed for proper operation of dynamic linking. The real
  35    solution would probably be a shared libgcc. */
  36
  37 #undef NDEBUG
  38 #include <assert.h>
  39
  40 static void
  41 maybe_drag_in_eprintf ()
  42 {
  43   assert (!maybe_drag_in_eprintf);
  44 }
  45 #endif
  46
  47 #include <stdio.h>
  48 #include <string.h>
  49
  50 #include "libguile/_scm.h"
  51 #include "libguile/libpath.h"
  52 #include "libguile/dynl.h"
  53 #include "libguile/smob.h"
  54 #include "libguile/keywords.h"
  55 #include "libguile/ports.h"
  56 #include "libguile/strings.h"
  57 #include "libguile/deprecation.h"
  58 #include "libguile/validate.h"
  59 #include "libguile/dynwind.h"
  60 #include "libguile/foreign.h"
  61
  62 #include <ltdl.h>
  63
  64 /*
  65   From the libtool manual: "Note that libltdl is not threadsafe,
  66   i.e. a multithreaded application has to use a mutex for libltdl.".
  67
  68   Guile does not currently support pre-emptive threads, so there is no
  69   mutex.  Previously SCM_CRITICAL_SECTION_START and
  70   SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
  71   somebody is grepping for thread problems ;)
  72 */
  73 /* njrev: not threadsafe, protection needed as described above */
  74
  75 static void *
  76 sysdep_dynl_link (const char *fname, const char *subr)
  77 {
  78   lt_dlhandle handle;
  79
  80   if (fname != NULL)
  81     handle = lt_dlopenext (fname);
  82   else
  83     /* Return a handle for the program as a whole.  */
  84     handle = lt_dlopen (NULL);
  85
  86   if (NULL == handle)
  87     {
  88       SCM fn;
  89       SCM msg;
  90
  91       fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
  92       msg = scm_from_locale_string (lt_dlerror ());
  93       scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
  94     }
  95
  96   return (void *) handle;
  97 }
  98
  99 static void
 100 sysdep_dynl_unlink (void *handle, const char *subr)
 101 {
 102   if (lt_dlclose ((lt_dlhandle) handle))
 103     {
 104       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 105     }
 106 }
 107
 108 static void *
 109 sysdep_dynl_value (const char *symb, void *handle, const char *subr)
 110 {
 111   void *fptr;
 112
 113   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
 114   if (!fptr)
 115     {
 116       scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
 117     }
 118   return fptr;
 119 }
 120
 121 static void
 122 sysdep_dynl_init ()
 123 {
 124   char *env;
 125
 126   lt_dlinit ();
 127
 128   env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
 129   if (env && strcmp (env, "") == 0)
 130     /* special-case interpret system-ltdl-path=="" as meaning no system path,
 131        which is the case during the build */
 132     ;
 133   else if (env)
 134     /* FIXME: should this be a colon-separated path? Or is the only point to
 135        allow the build system to turn off the installed extensions path? */
 136     lt_dladdsearchdir (env);
 137   else
 138     {
 139       lt_dladdsearchdir (SCM_LIB_DIR);
 140       lt_dladdsearchdir (SCM_EXTENSIONS_DIR);
 141     }
 142 }
 143
 144 scm_t_bits scm_tc16_dynamic_obj;
 145
 146 #define DYNL_FILENAME         SCM_SMOB_OBJECT
 147 #define DYNL_HANDLE(x)        ((void *) SCM_SMOB_DATA_2 (x))
 148 #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
 149
 150
 151
 152 static int
 153 dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
 154 {
 155   scm_puts ("#<dynamic-object ", port);
 156   scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
 157   if (DYNL_HANDLE (exp) == NULL)
 158     scm_puts (" (unlinked)", port);
 159   scm_putc ('>', port);
 160   return 1;
 161 }
 162
 163
 164 SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0,
 165             (SCM filename),
 166             "Find the shared object (shared library) denoted by\n"
 167             "@var{filename} and link it into the running Guile\n"
 168             "application.  The returned\n"
 169             "scheme object is a ``handle'' for the library which can\n"
 170             "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
 171             "Searching for object files is system dependent.  Normally,\n"
 172             "if @var{filename} does have an explicit directory it will\n"
 173             "be searched for in locations\n"
 174             "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
 175             "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
 176             "returned.  This handle provides access to the symbols\n"
 177             "available to the program at run-time, including those exported\n"
 178             "by the program itself and the shared libraries already loaded.\n")
 179 #define FUNC_NAME s_scm_dynamic_link
 180 {
 181   void *handle;
 182   char *file;
 183
 184   scm_dynwind_begin (0);
 185
 186   if (SCM_UNBNDP (filename))
 187     file = NULL;
 188   else
 189     {
 190       file = scm_to_locale_string (filename);
 191       scm_dynwind_free (file);
 192     }
 193
 194   handle = sysdep_dynl_link (file, FUNC_NAME);
 195   scm_dynwind_end ();
 196
 197   SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
 198                        SCM_UNBNDP (filename)
 199                        ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
 200                        handle);
 201 }
 202 #undef FUNC_NAME
 203
 204
 205 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
 206             (SCM obj),
 207             "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
 208             "or @code{#f} otherwise.")
 209 #define FUNC_NAME s_scm_dynamic_object_p
 210 {
 211   return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
 212 }
 213 #undef FUNC_NAME
 214
 215
 216 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
 217             (SCM dobj),
 218             "Unlink a dynamic object from the application, if possible.  The\n"
 219             "object must have been linked by @code{dynamic-link}, with \n"
 220             "@var{dobj} the corresponding handle.  After this procedure\n"
 221             "is called, the handle can no longer be used to access the\n"
 222             "object.")
 223 #define FUNC_NAME s_scm_dynamic_unlink
 224 {
 225   /*fixme* GC-problem */
 226   SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
 227   if (DYNL_HANDLE (dobj) == NULL) {
 228     SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
 229   } else {
 230     sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
 231     SET_DYNL_HANDLE (dobj, NULL);
 232     return SCM_UNSPECIFIED;
 233   }
 234 }
 235 #undef FUNC_NAME
 236
 237
 238 SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
 239             (SCM name, SCM type, SCM dobj, SCM len),
 240             "Return a ``handle'' for the pointer @var{name} in the\n"
 241             "shared object referred to by @var{dobj}.  The handle\n"
 242             "aliases a C value, and is declared to be of type\n"
 243             "@var{type}. Valid types are defined in the\n"
 244             "@code{(system foreign)} module.\n\n"
 245             "This facility works by asking the dynamic linker for\n"
 246             "the address of a symbol, then assuming that it aliases a\n"
 247             "value of a given type. Obviously, the user must be very\n"
 248             "careful to ensure that the value actually is of the\n"
 249             "declared type, or bad things will happen.\n\n"
 250             "Regardless whether your C compiler prepends an underscore\n"
 251             "@samp{_} to the global names in a program, you should\n"
 252             "@strong{not} include this underscore in @var{name}\n"
 253             "since it will be added automatically when necessary.")
 254 #define FUNC_NAME s_scm_dynamic_pointer
 255 {
 256   void *val;
 257   scm_t_foreign_type t;
 258
 259   SCM_VALIDATE_STRING (1, name);
 260   t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
 261   SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
 262
 263   if (DYNL_HANDLE (dobj) == NULL)
 264     SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
 265   else
 266     {
 267       char *chars;
 268
 269       scm_dynwind_begin (0);
 270       chars = scm_to_locale_string (name);
 271       scm_dynwind_free (chars);
 272       val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
 273       scm_dynwind_end ();
 274
 275       return scm_take_foreign_pointer (t, val,
 276                                        SCM_UNBNDP (len) ? 0 : scm_to_size_t (len),
 277                                        NULL);
 278     }
 279 }
 280 #undef FUNC_NAME
 281
 282
 283 SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
 284             (SCM name, SCM dobj),
 285             "Return a ``handle'' for the function @var{name} in the\n"
 286             "shared object referred to by @var{dobj}.  The handle\n"
 287             "can be passed to @code{dynamic-call} to actually\n"
 288             "call the function.\n\n"
 289             "Regardless whether your C compiler prepends an underscore\n"
 290             "@samp{_} to the global names in a program, you should\n"
 291             "@strong{not} include this underscore in @var{name}\n"
 292             "since it will be added automatically when necessary.")
 293 #define FUNC_NAME s_scm_dynamic_func
 294 {
 295   return scm_dynamic_pointer (name,
 296                               scm_from_uint (SCM_FOREIGN_TYPE_VOID),
 297                               dobj,
 298                               SCM_UNDEFINED);
 299 }
 300 #undef FUNC_NAME
 301
 302
 303 SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
 304             (SCM func, SCM dobj),
 305             "Call a C function in a dynamic object.  Two styles of\n"
 306             "invocation are supported:\n\n"
 307             "@itemize @bullet\n"
 308             "@item @var{func} can be a function handle returned by\n"
 309             "@code{dynamic-func}.  In this case @var{dobj} is\n"
 310             "ignored\n"
 311             "@item @var{func} can be a string with the name of the\n"
 312             "function to call, with @var{dobj} the handle of the\n"
 313             "dynamic object in which to find the function.\n"
 314             "This is equivalent to\n"
 315             "@smallexample\n\n"
 316             "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
 317             "@end smallexample\n"
 318             "@end itemize\n\n"
 319             "In either case, the function is passed no arguments\n"
 320             "and its return value is ignored.")
 321 #define FUNC_NAME s_scm_dynamic_call
 322 {
 323   void (*fptr) ();
 324
 325   if (scm_is_string (func))
 326     func = scm_dynamic_func (func, dobj);
 327   SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
 328
 329   fptr = SCM_FOREIGN_POINTER (func, void);
 330   fptr ();
 331   return SCM_UNSPECIFIED;
 332 }
 333 #undef FUNC_NAME
 334
 335 void
 336 scm_init_dynamic_linking ()
 337 {
 338   scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
 339   scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
 340   sysdep_dynl_init ();
 341 #include "libguile/dynl.x"
 342 }
 343
 344 /*
 345   Local Variables:
 346   c-file-style: "gnu"
 347   End:
 348 */