diff --git a/NEWS b/NEWS index 1b9e1877f..2ebb6baf2 100644 --- a/NEWS +++ b/NEWS @@ -261,6 +261,21 @@ binary-port) used to be implemented in C, making it non-suspendable--a bummer for programs using suspendable ports and Fibers. It has been rewritten in Scheme, addressing this limitation. +** improve 'load-foreign-library' handling of DLLs + +The non-libltdl load-foreign-library introduced in 3.0.6 does not handle +some common cases with libtool-generated DLLs. It has been updated +to search for DLLs that have a version number appended to the name +by libtool, such as libfoo-1.dll. + +Also, it has been updated to do library renaming for MSYS. On Cygwin, +when the #:rename-on-cygwin? option is #t, it already had the capability +to search for "libfoo" as "cygfoo.dll". It has been updated to add the +capability to search for "libfoo" as "msys-foo.dll" on MSYS. + +The load-foreign-library option #:rename-on-cygwin? has been changed to +#:host-type-rename?, and handles both Cygwin and MSYS. + * Performance improvements ** Better compilation of calls to procedures with keyword arguments diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index e572f176f..3b1ba8dc4 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -83,19 +83,24 @@ implemented in the @code{(system foreign-library)} module. [#:extensions=system-library-extensions] @ [#:search-ltdl-library-path?=#t] @ [#:search-path=search-path] @ - [#:search-system-paths?=#t] [#:lazy?=#t] [#:global=#f] - [#:rename-on-cygwin?=#t] -Find the shared library denoted by @var{library} (a string or @code{#f}) -and link it into the running Guile application. When everything works -out, return a Scheme object suitable for representing the linked object -file. Otherwise an error is thrown. + [#:search-system-paths?=#t] [#:lazy?=#t] [#:global=#f] @ + [#:host-type-rename?=#t] [#:allow-dll-version-suffix?=#t] -If @var{library} argument is omitted, it defaults to @code{#f}. If -@code{library} is false, the resulting foreign library gives access to -all symbols available for dynamic linking in the main binary. +This procedure finds the shared library denoted by @var{library} (a +string) and dynamically links it into the running Guile application. On +success, the procedure returns a Scheme object suitable for representing +the linked object file. Otherwise an error is thrown. -It is not necessary to include any extension such as @code{.so} in -@var{library}. For each system, Guile has a default set of extensions +In the common usage, the @var{library} parameter is a filename +with no path and with no filename extension, such as @code{.so}, +@code{.dylib} or @code{.dll}. The procedure will search for the library +in a set of standard locations using the common filename extensions for +the OS. The optional parameters can customize this behavior. + +When @var{library} has directory elements or a filename extension, a +more targeted search is performed. + +For each system, Guile has a default set of extensions that it will try. On GNU systems, the default extension set is just @code{.so}; on Windows, just @code{.dll}; and on Darwin (Mac OS), it is @code{.bundle}, @code{.so}, and @code{.dylib}. Pass @code{#:extensions @@ -113,10 +118,95 @@ environment variables: @table @env @item GUILE_EXTENSIONS_PATH -This is the main environment variable for users to add directories -containing Guile extensions. The default value has no entries. This -environment variable was added in Guile 3.0.6. +This is the environment variable for users to add directories containing +Guile extensions to the search path. The default value has no entries. +This environment variable was added in Guile 3.0.6. @item LTDL_LIBRARY_PATH +When @var{search-ltdl-library-path?} is true, this environment variable +can also be used to add directories to the search path. For each +directory given in this environment variable, two directories are added +to the search path: the given directory (for example, @code{D}) and a +@code{.libs} subdirectory (@code{D/.libs}). + +For more information on the rationale, see the note below. +@item GUILE_SYSTEM_EXTENSIONS_PATH +The last path in Guile's search path belongs to Guile itself, and +defaults to the libdir and the extensiondir, in that order. For +example, if you install to @file{/opt/guile}, these would probably be +@file{/opt/guile/lib} and +@code{/opt/guile/lib/guile/@value{EFFECTIVE-VERSION}/extensions}, +respectively. @xref{Parallel Installations}, for more details on +@code{extensionsdir}. + +For DLL-using systems, it searches bindir rather than libdir, so +@file{/opt/guile/bin} in this example. +@end table + +Finally, if no library is found in the search path, and if @var{library} +is not absolute and does not include directory separators, and if +@var{search-system-paths?} is true, the operating system may have its +own logic for where to locate @var{library}. For example, on GNU, there +will be a default set of paths (often @file{/usr/lib} and @file{/lib}, +though it depends on the system), and the @code{LD_LIBRARY_PATH} +environment variable can add additional paths. On DLL-using systems, +the @env{PATH} is searched. Other operating systems have other +conventions. + +Falling back to the operating system for search is usually not a great +thing; it is a recipe for making programs that work on one machine but +not on others. Still, when wrapping system libraries, it can be the +only way to get things working at all. + +If @var{lazy?} is true (the default), Guile will request the operating +system to resolve symbols used by the loaded library as they are first +used. If @var{global?} is true, symbols defined by the loaded library +will be available when other modules need to resolve symbols; the +default is @code{#f}, which keeps symbols local. + +If @var{host-type-rename?} is true (the default) library names may be +modified based on the current @code{%host-type}. On Cygwin hosts, +the search behavior is modified such that a filename that starts with +``lib'' will be searched for under the name ``cyg'', as is customary for +Cygwin. Similarly, for MSYS hosts, ``lib'' becomes ``msys-''. + +If @var{dll-version-suffix?} is true (the default), the search behavior +is modified such that when searching for a DLL, it will also search for +DLLs with version suffixes. For example, a search for +@file{libtiff.dll} will also allow @file{libtiff-1.dll}. When the +unversioned DLL is not found and multiple versioned DLLs exists, it will +return the versioned DLL with the highest version. Note that when +searching, directories take precedence. It does not return the highest +versioned DLL among all search directories collectively; it returns the +highest versioned in the first directory to have the DLL. + +If @var{library} argument is omitted, it defaults to @code{#f}. If +@code{library} is false, the resulting foreign library gives access to +all symbols available for dynamic linking in the currently running +executable. + +@end deffn + +The environment variables mentioned above are parsed when the +foreign-library module is first loaded and bound to parameters. Null +path components, for example the three components of +@env{GUILE_SYSTEM_EXTENSIONS_PATH="::"}, are ignored. + +@deffn {Scheme Parameter} guile-extensions-path +@deffnx {Scheme Parameter} ltdl-library-path +@deffnx {Scheme Parameter} guile-system-extensions-path +Parameters whose initial values are taken from +@env{GUILE_EXTENSIONS_PATH}, @env{LTDL_LIBRARY_PATH}, and +@env{GUILE_SYSTEM_EXTENSIONS_PATH}, respectively. @xref{Parameters}. +The current values of these parameters are used when building the search +path when @code{load-foreign-library} is called, unless the caller +explicitly passes a @code{#:search-path} argument. +@end deffn + +@deffn {Scheme Procedure} foreign-library? obj +Return @code{#t} if @var{obj} is a foreign library, or @code{#f} +otherwise. +@end deffn + Before Guile 3.0.6, Guile loaded foreign libraries using @code{libltdl}, the dynamic library loader provided by libtool. This loader used @env{LTDL_LIBRARY_PATH}, and for backwards compatibility we still @@ -149,63 +239,6 @@ error-reporting reasons. But, to keep this old use-case working, if additionally adding the @file{.libs} subdirectories for each entry, in case there are @file{.so} files there instead of alongside the @file{.la} files. -@item GUILE_SYSTEM_EXTENSIONS_PATH -The last path in Guile's search path belongs to Guile itself, and -defaults to the libdir and the extensiondir, in that order. For -example, if you install to @file{/opt/guile}, these would probably be -@file{/opt/guile/lib} and -@code{/opt/guile/lib/guile/@value{EFFECTIVE-VERSION}/extensions}, -respectively. @xref{Parallel Installations}, for more details on -@code{extensionsdir}. -@end table - -Finally, if no library is found in the search path, and if @var{library} -is not absolute and does not include directory separators, and if -@var{search-system-paths?} is true, the operating system may have its -own logic for where to locate @var{library}. For example, on GNU, there -will be a default set of paths (often @file{/usr/lib} and @file{/lib}, -though it depends on the system), and the @code{LD_LIBRARY_PATH} -environment variable can add additional paths. Other operating systems -have other conventions. - -Falling back to the operating system for search is usually not a great -thing; it is a recipe for making programs that work on one machine but -not on others. Still, when wrapping system libraries, it can be the -only way to get things working at all. - -If @var{lazy?} is true (the default), Guile will request the operating -system to resolve symbols used by the loaded library as they are first -used. If @var{global?} is true, symbols defined by the loaded library -will be available when other modules need to resolve symbols; the -default is @code{#f}, which keeps symbols local. - -If @var{rename-on-cygwin?} is true (the default) -- on Cygwin hosts only --- the search behavior is modified such that a filename that starts with -``lib'' will be searched for under the name ``cyg'', as is customary for -Cygwin. -@end deffn - -The environment variables mentioned above are parsed when the -foreign-library module is first loaded and bound to parameters. Null -path components, for example the three components of -@env{GUILE_SYSTEM_EXTENSIONS_PATH="::"}, are ignored. - -@deffn {Scheme Parameter} guile-extensions-path -@deffnx {Scheme Parameter} ltdl-library-path -@deffnx {Scheme Parameter} guile-system-extensions-path -Parameters whose initial values are taken from -@env{GUILE_EXTENSIONS_PATH}, @env{LTDL_LIBRARY_PATH}, and -@env{GUILE_SYSTEM_EXTENSIONS_PATH}, respectively. @xref{Parameters}. -The current values of these parameters are used when building the search -path when @code{load-foreign-library} is called, unless the caller -explicitly passes a @code{#:search-path} argument. -@end deffn - -@deffn {Scheme Procedure} foreign-library? obj -Return @code{#t} if @var{obj} is a foreign library, or @code{#f} -otherwise. -@end deffn - @node Foreign Extensions @subsection Foreign Extensions 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 #\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) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 6c3c31024..3329a0517 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -425,36 +425,104 @@ layout))))) -(with-test-prefix "lib->cyg" - (pass-if "name is #f" - (equal? #f (lib->cyg #f))) +(with-test-prefix "host-type-rename?" + (with-test-prefix "cyg" + (pass-if "name is #f" + (equal? #f (lib->cyg #f))) - (pass-if "name too short" - (string=? (lib->cyg "a") "a")) + (pass-if "name too short" + (string=? (lib->cyg "a") "a")) - (pass-if "name starts with 'lib'" - (string=? (lib->cyg "libfoo.dll") "cygfoo.dll")) + (pass-if "name starts with 'lib'" + (string=? (lib->cyg "libfoo.dll") "cygfoo.dll")) - (pass-if "name contains 'lib'" - (string=? (lib->cyg "foolib.dll") "foolib.dll")) + (pass-if "name contains 'lib'" + (string=? (lib->cyg "foolib.dll") "foolib.dll")) - (pass-if "name doesn't contain 'lib'" - (string=? (lib->cyg "foobar.dll") "foobar.dll")) + (pass-if "name doesn't contain 'lib'" + (string=? (lib->cyg "foobar.dll") "foobar.dll")) - (pass-if "name in path too short" - (string=? (lib->cyg "/lib/a") "/lib/a")) + (pass-if "name in path too short" + (string=? (lib->cyg "/lib/a") "/lib/a")) - (pass-if "name in path starts with 'lib'" - (string=? (lib->cyg "/lib/libfoo.dll") "/lib/cygfoo.dll")) + (pass-if "name in path starts with 'lib'" + (string=? (lib->cyg "/lib/libfoo.dll") "/lib/cygfoo.dll")) - (pass-if "name in path contains 'lib'" - (string=? (lib->cyg "/lib/foolib.dll") "/lib/foolib.dll")) + (pass-if "name in path contains 'lib'" + (string=? (lib->cyg "/lib/foolib.dll") "/lib/foolib.dll")) - (pass-if "name in path doesn't contain 'lib'" - (string=? (lib->cyg "/lib/foobar.dll") "/lib/foobar.dll")) + (pass-if "name in path doesn't contain 'lib'" + (string=? (lib->cyg "/lib/foobar.dll") "/lib/foobar.dll")) - (pass-if "name in windows path starts with 'lib'" - (string=? (lib->cyg "c:\\lib\\libfoo.dll") "c:\\lib\\cygfoo.dll")) + (pass-if "name in windows path starts with 'lib'" + (string=? (lib->cyg "c:\\lib\\libfoo.dll") "c:\\lib\\cygfoo.dll")) - (pass-if "name in windows path doesn't contain 'lib'" - (string=? (lib->cyg "c:\\lib\\foobar.dll") "c:\\lib\\foobar.dll"))) + (pass-if "name in windows path doesn't contain 'lib'" + (string=? (lib->cyg "c:\\lib\\foobar.dll") "c:\\lib\\foobar.dll"))) + + (with-test-prefix "msys" + + (pass-if "name is #f" + (equal? #f (lib->msys #f))) + + (pass-if "name too short" + (string=? (lib->msys "a") "a")) + + (pass-if "name starts with 'lib'" + (string=? (lib->msys "libfoo.dll") "msys-foo.dll")) + + (pass-if "name contains 'lib'" + (string=? (lib->msys "foolib.dll") "foolib.dll")) + + (pass-if "name doesn't contain 'lib'" + (string=? (lib->msys "foobar.dll") "foobar.dll")) + + (pass-if "name in path too short" + (string=? (lib->msys "/lib/a") "/lib/a")) + + (pass-if "name in path starts with 'lib'" + (string=? (lib->msys "/lib/libfoo.dll") "/lib/msys-foo.dll")) + + (pass-if "name in path contains 'lib'" + (string=? (lib->msys "/lib/foolib.dll") "/lib/foolib.dll")) + + (pass-if "name in path doesn't contain 'lib'" + (string=? (lib->msys "/lib/foobar.dll") "/lib/foobar.dll")) + + (pass-if "name in windows path starts with 'lib'" + (string=? (lib->msys "c:\\lib\\libfoo.dll") "c:\\lib\\msys-foo.dll")) + + (pass-if "name in windows path doesn't contain 'lib'" + (string=? (lib->msys "c:\\lib\\foobar.dll") "c:\\lib\\foobar.dll")))) + + + +(with-test-prefix "dll-name-match?" + (let ((dll-name-match? (@@ (system foreign-library) dll-name-match?))) + (pass-if "libfoo.dll == libfoo.dll" + (dll-name-match? "libfoo.dll" "libfoo.dll")) + (pass-if "libfoo-1.dll == libfoo.dll" + (dll-name-match? "libfoo-1.dll" "libfoo.dll")) + (pass-if "libfoo-10.dll == libfoo.dll" + (dll-name-match? "libfoo-10.dll" "libfoo.dll")) + (pass-if "libfoo-.dll != libfoo.dll" + (not (dll-name-match? "libfoo-.dll" "libfoo.dll"))) + (pass-if "libfoo-a.dll != libfoo.dll" + (not (dll-name-match? "libfoo-a.dll" "libfoo.dll"))) + (pass-if "libfoo-1a.dll != libfoo.dll" + (not (dll-name-match? "libfoo-a.dll" "libfoo.dll"))))) + +(with-test-prefix "find-best-dll-from-matches" + (let ((find-best? (@@ (system foreign-library) find-best-dll-from-matches))) + (pass-if-equal "prefer unversioned name" + "libfoo.dll" + (find-best? "libfoo.dll" '("libfoo.dll" "libfoo-1.dll"))) + (pass-if-equal "allow versioned name" + "libfoo-1.dll" + (find-best? "libfoo.dll" '("libfoo-1.dll"))) + (pass-if-equal "larger is better" + "libfoo-2.dll" + (find-best? "libfoo.dll" '("libfoo-1.dll" "libfoo-2.dll"))) + (pass-if-equal "multiple digits ok" + "libfoo-123.dll" + (find-best? "libfoo.dll" '("libfoo-1.dll" "libfoo-123.dll")))))