summaryrefslogtreecommitdiff
path: root/module/system/foreign-library.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/foreign-library.scm')
-rw-r--r--module/system/foreign-library.scm151
1 files changed, 136 insertions, 15 deletions
diff --git a/module/system/foreign-library.scm b/module/system/foreign-library.scm
index dc426385f..d0de93a2d 100644
--- a/module/system/foreign-library.scm
+++ b/module/system/foreign-library.scm
@@ -26,11 +26,13 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
+ #:use-module ((ice-9 ftw) #:select (scandir))
+ #:use-module ((srfi srfi-1) #:select (find))
#:export (guile-extensions-path
ltdl-library-path
guile-system-extensions-path
- lib->cyg
+ lib->cyg lib->msys
load-foreign-library
foreign-library?
foreign-library-pointer
@@ -64,24 +66,96 @@
(or (string-contains head ext)
(has-extension? head exts)))))
-(define (file-exists-with-extension head exts)
- (if (has-extension? head exts)
+(define (is-integer-string? str)
+ (and
+ (not (string-null? str))
+ (let ((n (string-length str)))
+ (let lp ((i 0))
+ (let ((c (string-ref str i)))
+ (if (or (char<? c #\0) (char>? c #\9))
+ #f
+ (if (= i (1- n))
+ #t
+ (lp (1+ i)))))))))
+
+(define (dll-name-match? src tgt)
+ (let ((srclen (string-length src))
+ (tgtlen (string-length tgt)))
+ (cond
+ ((or (< srclen tgtlen)
+ (< tgtlen 5)
+ (string-ci<> src ".dll" (- srclen 4))
+ (string-ci<> tgt ".dll" (- tgtlen 4))
+ (string-ci<> src tgt 0 (- tgtlen 4) 0 (- tgtlen 4)))
+ #f)
+ (else
+ (let ((mid (substring src (- tgtlen 4) (- srclen 4))))
+ (cond
+ ((or (string-null? mid)
+ (and (char=? (string-ref mid 0) #\-)
+ (is-integer-string? (string-drop mid 1))))
+ #t)
+ (else
+ #f)))))))
+
+(define (find-best-dll-from-matches dllname lst)
+ ;; A DLL name without a version suffix is preferred,
+ ;; like libfoo.dll. But if we must have a version
+ ;; suffix as in libfoo-5.dll, we want the largest one.
+ (define (ver>? a b)
+ (cond
+ ((> (string-length a) (string-length b))
+ #t)
+ ((< (string-length a) (string-length b))
+ #f)
+ (else
+ (string-ci>? a b))))
+
+ (cond
+ ((null? lst)
+ #f)
+ ((= (length lst) 1)
+ (car lst))
+ (else
+ (or
+ (find (lambda (entry) (string-ci= entry dllname)) lst)
+ ;; The longest string that is alphabetically last
+ ;; is numerically the highest.
+ (car (sort lst ver>?))))))
+
+(define (dll-exists-with-version head)
+ ;; Searches for a DLL given a filepath, allowing
+ ;; for DLLs with version suffixes.
+ (let* ((fname (if (has-extension? head '(".dll"))
+ head
+ (string-append head ".dll")))
+ (dir (dirname fname))
+ (base (basename fname)))
+ (let ((matches (scandir dir (lambda (f) (dll-name-match? f base)))))
+ (if (or (not matches) (null? matches))
+ #f
+ (in-vicinity dir (find-best-dll-from-matches fname matches))))))
+
+(define (file-exists-with-extension head extensions versioned-dlls?)
+ (if (has-extension? head extensions)
(and (file-exists? head) head)
- (let lp ((exts exts))
+ (let lp ((exts extensions))
(match exts
- (() #f)
+ (() (if (and versioned-dlls? (member ".dll" extensions))
+ (dll-exists-with-version head)
+ #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)
+(define (file-exists-in-path-with-extension basename path exts versioned-dlls?)
(match path
(() #f)
((dir . path)
- (or (file-exists-with-extension (in-vicinity dir basename) exts)
- (file-exists-in-path-with-extension basename path exts)))))
+ (or (file-exists-with-extension (in-vicinity dir basename) exts versioned-dlls?)
+ (file-exists-in-path-with-extension basename path exts versioned-dlls?)))))
(define path-separator
(case (system-file-name-convention)
@@ -107,9 +181,17 @@
(define guile-system-extensions-path
(make-parameter
(or (parse-path "GUILE_SYSTEM_EXTENSIONS_PATH")
- (list (assq-ref %guile-build-info 'libdir)
+ (list (if (or (string-contains %host-type "cygwin")
+ (string-contains %host-type "mingw")
+ (string-contains %host-type "msys"))
+ (assq-ref %guile-build-info 'bindir)
+ (assq-ref %guile-build-info 'libdir))
(assq-ref %guile-build-info 'extensiondir)))))
+(define system-dll-path
+ (make-parameter
+ (or (parse-path "PATH") '())))
+
;; There are a few messy situations here related to libtool.
;;
;; Guile used to use libltdl, the dynamic library loader provided by
@@ -145,6 +227,7 @@
(cons* dir (in-vicinity dir ".libs")
(augment-ltdl-library-path path)))))
+
(define (default-search-path search-ltdl-library-path?)
(append
(guile-extensions-path)
@@ -172,13 +255,33 @@ name."
(else
name)))))
+(define (lib->msys name)
+ "Convert a standard shared library name to a MSYS shared library
+name."
+ (if (not name)
+ #f
+ (let ((start (1+ (or (string-index-right
+ name
+ (lambda (c) (or (char=? #\\ c) (char=? #\/ c))))
+ -1))))
+ (cond
+ ((>= (+ 3 start) (string-length name))
+ name)
+ ((string= name "lib" start (+ start 3))
+ (string-append (substring name 0 start)
+ "msys-"
+ (substring name (+ start 3))))
+ (else
+ name)))))
+
(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) (rename-on-cygwin? #t))
+ (lazy? #t) (global? #f) (host-type-rename? #t)
+ (allow-dll-version-suffix? #t))
(define (error-not-found)
(scm-error 'misc-error "load-foreign-library"
"file: ~S, message: ~S"
@@ -187,9 +290,18 @@ name."
(define flags
(logior (if lazy? RTLD_LAZY RTLD_NOW)
(if global? RTLD_GLOBAL RTLD_LOCAL)))
- (define (dlopen* name) (dlopen name flags))
- (if (and rename-on-cygwin? (string-contains %host-type "cygwin"))
+ (define (dlopen* name)
+ (dlopen name flags))
+ (define (file-exists-with-ext filename extensions)
+ (file-exists-with-extension filename extensions allow-dll-version-suffix?))
+ (define (file-exists-in-path-with-ext filename search-path extensions)
+ (file-exists-in-path-with-extension
+ filename search-path extensions allow-dll-version-suffix?))
+ (when host-type-rename?
+ (when (string-contains %host-type "cygwin")
(set! filename (lib->cyg filename)))
+ (when (string-contains %host-type "msys")
+ (set! filename (lib->msys filename))))
(make-foreign-library
filename
(cond
@@ -199,17 +311,26 @@ name."
((or (absolute-file-name? filename)
(string-any file-name-separator? filename))
(cond
- ((or (file-exists-with-extension filename extensions)
+ ((or (file-exists-with-ext filename extensions)
(and search-ltdl-library-path?
- (file-exists-with-extension
+ (file-exists-with-ext
(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)
+ ((file-exists-in-path-with-ext filename search-path extensions)
=> dlopen*)
+ ((and search-system-paths?
+ (or (string-contains %host-type "cygwin")
+ (string-contains %host-type "mingw")
+ (string-contains %host-type "msys")))
+ (let ((fullname (file-exists-in-path-with-ext filename (system-dll-path) '(".dll"))))
+ (if fullname
+ (dlopen* fullname)
+ (error-not-found))))
+
(search-system-paths?
(if (or (null? extensions) (has-extension? filename extensions))
(dlopen* filename)