mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Improve DLL search strategy for load-foreign-library
The new non-libltdl foreign library loading algorithm from 3.0.6
fails to cover common cases regarding how libtool names and installs
DLL files. Notably, it fails to recognize when libtool has added the
major version number into the filename itself, such as libfoo-1.dll
Also, it does not search in binary directories and the PATH for DLL
files, where libtool is likely to install DLLs.
This adds the option to search for dlls with major version numbers
in the filename, and modifies the search strategy for DLL-using
OSs to check bindir and PATH.
For MSYS, libraries are installed with the 'msys-' prefix. So this
modifies load-foreign-library to handle that prefix as well.
It changes the #:rename-on-cygwin? option to #:host-type-rename? to
better reflect that is works on both Cygwin and MSYS.
Partially based on a patch by Hannes Müller.
* NEWS: updated
* doc/ref/api-foreign.texi: document updates to load-foreign-library
and system-dll-path
* module/system/foreign-library.scm (is-integer-string?): new utility function
(dll-name-match?): new utility function
(find-best-dll-from-matches): new utility function
(dll-exists-with-version): new function that implements new dll search logic
(file-exists-with-extension): add flag argument to allow new dll search
(file-exists-in-path-with-extension): add flag argument to all new dll search
(system-dll-path): new parameter
(lib->msys): new helper function
(load-foreign-library): add new optarg flag #:allow-dll-version-suffix?
Pass new flag to library search functions.
Implement new search strategy for #:search-system-paths? on DLL systems'
replace #:rename-on-cygwin? with #:host-type-rename?
Use that option to rename both MSYS and Cygwin libraries.
(guile-system-extensions-path): prefer bindir to libdir on DLL systems
* test-suite/tests/foreign.test ("dll-name-match?"): new test category
("find-best-dll-from-matches"): new test category
("lib->msys"): new unit tests
This commit is contained in:
Michael Gran
parent
c9a19a03f8
commit
7b41294049
4 changed files with 346 additions and 109 deletions
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue