guile/libguile/dynl.c

/* 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"
}