guile/module/system/foreign-library.scm

;;; Dynamically linking foreign libraries via dlopen and dlsym
;;; Copyright (C) 2021 Free Software Foundation, Inc.
;;;
;;; This library 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.
;;;
;;; This library 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 this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;;
;;; Implementation of dynamic-link.
;;;
;;; Code:


(define-module (system foreign-library)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:use-module (system foreign)
  #:export (guile-extensions-path
            ltdl-library-path
            guile-system-extensions-path

            load-foreign-library
            foreign-library?
            foreign-library-pointer
            foreign-library-function))

(define-record-type <foreign-library>
  (make-foreign-library filename handle)
  foreign-library?
  (filename foreign-library-filename)
  (handle foreign-library-handle set-foreign-library-handle!))

(eval-when (expand load eval)
  (load-extension (string-append "libguile-" (effective-version))
                  "scm_init_system_foreign_library"))

(define system-library-extensions
  (cond
   ((string-contains %host-type "-darwin-")
    '(".bundle" ".so" ".dylib"))
   ((or (string-contains %host-type "cygwin")
        (string-contains %host-type "mingw")
        (string-contains %host-type "msys"))
    '(".dll"))
   (else
    '(".so"))))

(define (has-extension? head exts)
  (match exts
    (() #f)
    ((ext . exts)
     (or (string-contains head ext)
         (has-extension? head exts)))))

(define (file-exists-with-extension head exts)
  (if (has-extension? head exts)
      (and (file-exists? head) head)
      (let lp ((exts exts))
        (match exts
          (() #f)
          ((ext . exts)
           (let ((head (string-append head ext)))
             (if (file-exists? head)
                 head
                 (lp exts))))))))

(define (file-exists-in-path-with-extension basename path exts)
  (match path
    (() #f)
    ((dir . path)
     (or (file-exists-with-extension (in-vicinity dir basename) exts)
         (file-exists-in-path-with-extension basename path exts)))))

(define path-separator
  (case (system-file-name-convention)
    ((posix) #\:)
    ((windows) #\;)
    (else (error "unreachable"))))

(define (parse-path var)
  (match (getenv var)
    (#f #f)
    ;; Ignore e.g. "export GUILE_SYSTEM_EXTENSIONS_PATH=".
    ("" '())
    (val (string-split val path-separator))))

(define guile-extensions-path
  (make-parameter
   (or (parse-path "GUILE_EXTENSIONS_PATH") '())))

(define ltdl-library-path
  (make-parameter
   (or (parse-path "LTDL_LIBRARY_PATH") '())))

(define guile-system-extensions-path
  (make-parameter
   (or (parse-path "GUILE_SYSTEM_EXTENSIONS_PATH")
       (list (assq-ref %guile-build-info 'libdir)
             (assq-ref %guile-build-info 'extensiondir)))))

;; There are a few messy situations here related to libtool.
;;
;; Guile used to use libltdl, the dynamic library loader provided by
;; libtool.  This loader used LTDL_LIBRARY_PATH, and for backwards
;; compatibility we still support that path.
;;
;; However, libltdl would not only open ".so" (or ".dll", etc) files,
;; but also the ".la" files created by libtool.  In installed libraries
;; -- libraries that are in the target directories of "make install" --
;; .la files are never needed, to the extent that most GNU/Linux
;; distributions remove them entirely.  It is sufficient to just load
;; the ".so" (or ".dll", etc) files.
;;
;; But for uninstalled dynamic libraries, like those in a build tree, it
;; is a bit of a mess.  If you have a project that uses libtool to build
;; libraries -- which is the case for Guile, and for most projects using
;; autotools -- and you build foo.so in directory D, libtool will put
;; foo.la in D, but foo.so goes in D/.libs.
;;
;; The nice thing about ltdl was that it could load the .la file, even
;; from a build tree, preventing the existence of ".libs" from leaking
;; out to the user.
;;
;; We don't use libltdl now, essentially for flexibility and
;; error-reporting reasons.  But, it would be nice to keep this old
;; use-case working.  So as a stopgap solution, we add a ".libs" subdir
;; to the path for each entry in LTDL_LIBRARY_PATH, in case the .so is
;; there instead of alongside the .la file.
(define (augment-ltdl-library-path path)
  (match path
    (() '())
    ((dir . path)
     (cons* dir (in-vicinity dir ".libs")
            (augment-ltdl-library-path path)))))

(define (default-search-path search-ltdl-library-path?)
  (append
   (guile-extensions-path)
   (if search-ltdl-library-path?
       (augment-ltdl-library-path (ltdl-library-path))
       '())
   (guile-system-extensions-path)))

(define* (load-foreign-library #:optional filename #:key
                               (extensions system-library-extensions)
                               (search-ltdl-library-path? #t)
                               (search-path (default-search-path
                                              search-ltdl-library-path?))
                               (search-system-paths? #t)
                               (lazy? #t) (global? #f))
  (define (error-not-found)
    (scm-error 'misc-error "load-foreign-library"
               "file: ~S, message: ~S"
               (list filename "file not found")
               #f))
  (define flags
    (logior (if lazy? RTLD_LAZY RTLD_NOW)
            (if global? RTLD_GLOBAL RTLD_LOCAL)))
  (define (dlopen* name) (dlopen name flags))
  (make-foreign-library
   filename
   (cond
    ((not filename)
     ;; The self-open trick.
     (dlopen* #f))
    ((or (absolute-file-name? filename)
         (string-any file-name-separator? filename))
     (cond
      ((or (file-exists-with-extension filename extensions)
           (and search-ltdl-library-path?
                (file-exists-with-extension
                 (in-vicinity (in-vicinity (dirname filename) ".libs")
                              (basename filename))
                 extensions)))
       => dlopen*)
      (else
       (error-not-found))))
    ((file-exists-in-path-with-extension filename search-path extensions)
     => dlopen*)
    (search-system-paths?
     (if (or (null? extensions) (has-extension? filename extensions))
         (dlopen* filename)
         (let lp ((extensions extensions))
           (match extensions
             ((extension)
              ;; Open in tail position to propagate any exception.
              (dlopen* (string-append filename extension)))
             ((extension . extensions)
              ;; If there is more than one extension, unfortunately we
              ;; only report the error for the last extension.  This is
              ;; not great because maybe the library was found with the
              ;; first extension, failed to load and had an interesting
              ;; error, but then we swallowed that interesting error and
              ;; proceeded, eventually throwing a "file not found"
              ;; exception.  FIXME to use more structured exceptions and
              ;; stop if the error that we get is more specific than
              ;; just "file not found".
              (or (false-if-exception
                   (dlopen* (string-append filename extension)))
                  (lp extensions)))))))
    (else
     (error-not-found)))))

(define (->foreign-library lib)
  (if (foreign-library? lib)
      lib
      (load-foreign-library lib)))

(define* (foreign-library-pointer lib name)
  (let ((handle (foreign-library-handle (->foreign-library lib))))
    (dlsym handle name)))

(define* (foreign-library-function lib name
                                   #:key
                                   (return-type void)
                                   (arg-types '())
                                   (return-errno? #f))
  (let ((pointer (foreign-library-pointer lib name)))
    (pointer->procedure return-type pointer arg-types
                        #:return-errno? return-errno?)))