diff options
Diffstat (limited to 'module/system/foreign-library.scm')
-rw-r--r-- | module/system/foreign-library.scm | 151 |
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) |