#line 1 "/build/ecl/src/ecl-26.3.27/src/c/ffi/libraries.d"
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * libraries.d - shared library and bundle opening / copying / closing
 *
 * Copyright (c) 1990 Giuseppe Attardi
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#include <ecl/ecl.h>
/*
 * Choosing the interface for loading binary files. Currently we recognize
 * three different methods:
 *      - Windows API, provided by ECL_MS_WINDOWS_HOST
 *      - dlopen, provided HAVE_DLFCN_H is defined
 *      - NSLinkModule, provided HAVE_MACH_O_DYLD_H is defined
 * They are chosen in this precise order. In order to make the code for these
 * methods mutually exclusive, when one method is present, the other macros
 * get undefined. Handling of dynamically loaded libraries is constrained to
 * this file and thus the changes can be limited to this file.
 */
#ifdef ECL_MS_WINDOWS_HOST
# ifdef HAVE_DLFCN_H
#  undef HAVE_DLFCN_H
# endif
# ifdef HAVE_MACH_O_DYLD_H
#  undef HAVE_MACH_O_DYLD_H
# endif
#endif
#ifdef HAVE_DLFCN_H
# ifdef HAVE_MACH_O_DYLD_H
#  undef HAVE_MACH_O_DYLD_H
# endif
#endif
#ifdef ENABLE_DLOPEN
# ifdef cygwin
#  include <w32api/windows.h>
#  include <sys/stat.h>
# endif
# ifdef HAVE_DLFCN_H
#  include <dlfcn.h>
#  define INIT_PREFIX "init_fas_"
# endif
# ifdef HAVE_MACH_O_DYLD_H
#  include <mach-o/dyld.h>
#  define INIT_PREFIX "_init_fas_"
# endif
# ifdef HAVE_LINK_H
#  include <link.h>
# endif
# if defined(ECL_MS_WINDOWS_HOST)
#  include <windows.h>
#  include <windef.h>
#  include <winbase.h>
#  include <tlhelp32.h>
#  define INIT_PREFIX "init_fas_"
# else
#  include <unistd.h>
# endif
#endif /* ENABLE_DLOPEN */
#include <ecl/ecl-inl.h>
#include <ecl/internal.h>

#define GC_call_with_alloc_lock(f,arg) f(arg)

cl_object
ecl_make_codeblock()
{
  cl_object block = ecl_alloc_object(t_codeblock);
  block->cblock.self_destruct = 0;
  block->cblock.locked = 0;
  block->cblock.handle = NULL;
  block->cblock.data = NULL;
  block->cblock.data_size = 0;
  block->cblock.temp_data = NULL;
  block->cblock.temp_data_size = 0;
  block->cblock.data_text = NULL;
  block->cblock.next = ECL_NIL;
  block->cblock.name = ECL_NIL;
  block->cblock.links = ECL_NIL;
  block->cblock.cfuns_size = 0;
  block->cblock.cfuns = NULL;
  block->cblock.source = ECL_NIL;
  block->cblock.error = ECL_NIL;
  block->cblock.refs = ecl_make_fixnum(0);
  si_set_finalizer(block, ECL_T);
  return block;
}

static cl_object
copy_object_file(cl_object original)
{
  int err;
  cl_object copy = ecl_make_constant_base_string("TMP:ECL", -1);
  copy = si_coerce_to_filename(si_mkstemp(copy));
  /*
   * We either have to make a full copy to convince the loader to load this object
   * file again, or we want to retain the possibility of overwriting the object
   * file we load later on (case of Windows, which locks files that are loaded).
   * The symlinks do not seem to work in latest versions of Linux.
   */
#if defined(ECL_MS_WINDOWS_HOST)
  ecl_disable_interrupts();
  err = !ecl_CopyFile(ecl_filename_self(original), ecl_filename_self(copy), 0);
  ecl_enable_interrupts();
  if (err) {
    FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A",
                  2, original, copy);
  }
#else
  err = Null(si_copy_file(ecl_decode_filename(original,ECL_NIL), copy));
  if (err) {
    FEerror("Error when copying file from~&~3T~A~&to~&~3T~A",
            2, original, copy);
  }
#endif
#ifdef cygwin
  {
    cl_object new_copy = ecl_make_constant_base_string(".dll", -1);
    new_copy = ecl_concatenate_filename(copy, new_copy);
    cl_rename_file(2, ecl_decode_filename(copy,ECL_NIL), ecl_decode_filename(new_copy,ECL_NIL));
    copy = new_copy;
  }
  ecl_disable_interrupts();
  err = ecl_chmod(ecl_filename_self(copy), S_IRWXU) < 0;
  ecl_enable_interrupts();
  if (err) {
    FElibc_error("Unable to give executable permissions to ~A",
                 1, copy);
  }
#endif
  return copy;
}

#ifdef ENABLE_DLOPEN

static void
set_library_error(cl_object block) {
  cl_object output;
  ecl_disable_interrupts();
#ifdef HAVE_DLFCN_H
  output = ecl_cstring_to_base_string_or_nil(dlerror());
#endif
#ifdef HAVE_MACH_O_DYLD_H
  {
    NSLinkEditErrors c;
    int number;
    const char *filename;
    NSLinkEditError(&c, &number, &filename, &message);
    output = ecl_make_simple_base_string(message,-1);
  }
#endif
#if defined(ECL_MS_WINDOWS_HOST)
  {
    const char *message;
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
                  FORMAT_MESSAGE_ALLOCATE_BUFFER,
                  0, GetLastError(), 0, (void*)&message, 0, NULL);
    output = ecl_make_simple_base_string(message,-1);
    LocalFree(message);
  }
#endif
  ecl_enable_interrupts();
  block->cblock.error = output;
}

static void
dlopen_wrapper(cl_object block)
{
  cl_object filename = block->cblock.name;
  ecl_filename_char *filename_string = ecl_filename_self(filename);
#ifdef HAVE_DLFCN_H
  block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL);
#endif
#ifdef HAVE_MACH_O_DYLD_H
  {
    NSObjectFileImage file;
    static NSObjectFileImageReturnCode code;
    code = NSCreateObjectFileImageFromFile(filename_string, &file);
    if (code != NSObjectFileImageSuccess) {
      block->cblock.handle = NULL;
    } else {
      NSModule out = NSLinkModule(file, filename_string,
                                  NSLINKMODULE_OPTION_PRIVATE|
                                  NSLINKMODULE_OPTION_BINDNOW|
                                  NSLINKMODULE_OPTION_RETURN_ON_ERROR);
      block->cblock.handle = out;
    }}
#endif
#if defined(ECL_MS_WINDOWS_HOST)
  block->cblock.handle = ecl_LoadLibrary(filename_string);
#endif
  if (block->cblock.handle == NULL)
    set_library_error(block);
}

static int
dlclose_wrapper(cl_object block)
{
  if (block->cblock.handle != NULL) {
#ifdef HAVE_DLFCN_H
    dlclose(block->cblock.handle);
#endif
#ifdef HAVE_MACH_O_DYLD_H
    NSUnLinkModule(block->cblock.handle, NSUNLINKMODULE_OPTION_NONE);
#endif
#if defined(ECL_MS_WINDOWS_HOST)
    FreeLibrary(block->cblock.handle);
#endif
    block->cblock.handle = NULL;
    return TRUE;
  }
  return FALSE;
}

static cl_object
ecl_library_find_by_name(cl_object filename)
{
  cl_object l;
  for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
    cl_object other = ECL_CONS_CAR(l);
    cl_object name = other->cblock.name;
    if (!Null(name) && ecl_string_eq(name, filename)) {
      return other;
    }
  }
  return ECL_NIL;
}

static cl_object
ecl_library_find_by_handle(void *handle)
{
  cl_object l;
  for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
    cl_object other = ECL_CONS_CAR(l);
    if (handle == other->cblock.handle) {
      return other;
    }
  }
  return ECL_NIL;
}

static cl_object
ecl_library_open_inner(cl_object filename, bool self_destruct)
{
  const cl_env_ptr the_env = ecl_process_env();
  cl_object block = ecl_make_codeblock();
  block->cblock.self_destruct = self_destruct;
  block->cblock.name = filename;
  block->cblock.refs = ecl_make_fixnum(1);

  ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) {
    ecl_disable_interrupts();
    GC_call_with_alloc_lock(dlopen_wrapper, block);
    if (block->cblock.handle != NULL) {
      /* Have we already loaded this library? If so, then unload this
       * copy and increase the reference counter so that we can keep
       * track (in lisp) of how many copies we use.
       */
      cl_object other = ecl_library_find_by_handle(block->cblock.handle);
      if (other != ECL_NIL) {
        GC_call_with_alloc_lock(dlclose_wrapper, block);
        block = other;
        block->cblock.refs = ecl_one_plus(block->cblock.refs);
      } else {
        si_set_finalizer(block, ECL_T);
        cl_core.libraries = CONS(block, cl_core.libraries);
      }
    }
    ecl_enable_interrupts();
  } ECL_WITH_GLOBAL_LOCK_END;
  return block;
}

cl_object
ecl_library_open(cl_object filename, bool force_reload) {
  cl_object block;
  bool self_destruct = 0;

  /* Coerces to a file name but does not merge with cwd */
  filename = si_coerce_to_physical_pathname(filename);
  filename = ecl_namestring(filename,
                            ECL_NAMESTRING_TRUNCATE_IF_ERROR |
                            ECL_NAMESTRING_FORCE_BASE_STRING);

  if (!force_reload) {
    /* When loading a foreign library, such as a dll or a
     * so, it cannot contain any executable top level
     * code. In that case force_reload=0 and there is no
     * need to reload it if it has already been loaded. */
    block = ecl_library_find_by_name(filename);
    if (!Null(block)) {
      return block;
    }
  } else {
    /* We are using shared libraries as modules and
     * force_reload=1.  Here we have to face the problem
     * that many operating systems do not allow to load a
     * shared library twice, even if it has changed. Hence
     * we have to make a unique copy to be able to load
     * the same FASL twice. In Windows this copy is
     * _always_ made because otherwise it cannot be
     * overwritten. In Unix we need only do that when the
     * file has been previously loaded. */
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
    filename = copy_object_file(filename);
    self_destruct = 1;
#else
    block = ecl_library_find_by_name(filename);
    if (!Null(block)) {
      filename = copy_object_file(filename);
      self_destruct = 1;
    }
#endif
  }
 DO_LOAD:
  block = ecl_library_open_inner(filename, self_destruct);
  /*
   * A second pass to ensure that the dlopen routine has not
   * returned a library that we had already loaded. If this is
   * the case, we close the new copy to ensure we do refcounting
   * right.
   */
  if (block->cblock.refs != ecl_make_fixnum(1)) {
    if (force_reload) {
      ecl_library_close(block);
      filename = copy_object_file(filename);
      self_destruct = 1;
      goto DO_LOAD;
    }
  }
  return block;
}

void *
ecl_library_symbol(cl_object block, const char *symbol, bool lock) {
  void *p;
  if (block == ECL_SYM(":DEFAULT",1246)) {
    cl_object l;
    for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
      cl_object block = ECL_CONS_CAR(l);
      p = ecl_library_symbol(block, symbol, lock);
      if (p) return p;
    }
    ecl_disable_interrupts();
#if defined(ECL_MS_WINDOWS_HOST)
    {
      HANDLE hndSnap = NULL;
      HANDLE hnd = NULL;
      hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId());
      if (hndSnap != INVALID_HANDLE_VALUE)
        {
          MODULEENTRY32 me32;
          me32.dwSize = sizeof(MODULEENTRY32);
          if (Module32First(hndSnap, &me32))
            {
              do
                hnd = GetProcAddress(me32.hModule, symbol);
              while (hnd == NULL && Module32Next(hndSnap, &me32));
            }
          CloseHandle(hndSnap);
        }
      p = (void*)hnd;
    }
#endif
#ifdef HAVE_DLFCN_H
    p = dlsym(0, symbol);
#endif
#if !defined(ECL_MS_WINDOWS_HOST) && !defined(HAVE_DLFCN_H)
    p = 0;
#endif
    ecl_enable_interrupts();
  } else {
    ecl_disable_interrupts();
#ifdef HAVE_DLFCN_H
    p = dlsym(block->cblock.handle, symbol);
#endif
#if defined(ECL_MS_WINDOWS_HOST)
    {
      HMODULE h = (HMODULE)(block->cblock.handle);
      p = GetProcAddress(h, symbol);
    }
#endif
#ifdef HAVE_MACH_O_DYLD_H
    NSSymbol sym;
    sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle),
                                 symbol);
    if (sym == 0) {
      p = 0;
    } else {
      p = NSAddressOfSymbol(sym);
    }
#endif
    ecl_enable_interrupts();
    /* Libraries whose symbols are being referenced by the FFI should not
     * get garbage collected. Until we find a better solution we simply lock
     * them for the rest of the runtime */
    if (p) {
      block->cblock.locked |= lock;
    }
  }
  if (!p)
    set_library_error(block);
  return p;
}

cl_object
ecl_library_error(cl_object block) {
  return block->cblock.error;
}

bool
ecl_library_close(cl_object block) {
  const cl_env_ptr the_env = ecl_process_env();
  bool success = TRUE;
  ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) {
    ecl_disable_interrupts();
    /* is it ever a case? no matter how many times i call
       load-foreign-module it seems that block->cblock.refs = 1 */
    if (block->cblock.refs > ecl_make_fixnum(1)) {
      block->cblock.refs = ecl_one_minus(block->cblock.refs);
      block = ECL_NIL;
    } else if (block->cblock.handle != NULL) {
      success = GC_call_with_alloc_lock(dlclose_wrapper, block);
      cl_core.libraries = ecl_remove_eq(block, cl_core.libraries);
    } else { /* block not loaded */
      success = FALSE;
    }
    ecl_enable_interrupts();
  } ECL_WITH_GLOBAL_LOCK_END;
  if (block != ECL_NIL && block->cblock.self_destruct) {
    if (!Null(block->cblock.name)) {
      ecl_unlink(ecl_filename_self(block->cblock.name));
    }
  }
  return success;
}

void
ecl_library_close_all(void)
{
  while (cl_core.libraries != ECL_NIL) {
    ecl_library_close(ECL_CONS_CAR(cl_core.libraries));
  }
}

ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static, const);

cl_object
_ecl_library_init_prefix(void)
{
  return init_prefix;
}

ecl_def_ct_base_string(default_entry, INIT_PREFIX "CODE", sizeof(INIT_PREFIX "CODE")-1,
                       static, const);

cl_object
_ecl_library_default_entry(void)
{
  return default_entry;
}
#endif /* ENABLE_DLOPEN */
