From 1752a17a1e6f7138892eeeb4806cd04ccb3ca1b0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 Jun 2016 17:52:08 +0200 Subject: utils: 'with-atomic-file-output' calls 'fdatasync'. Suggested by Danny Milosavljevic at . * guix/build/syscalls.scm (fdatasync): New procedure. * guix/utils.scm (with-atomic-file-output): Use it. Use 'close-port' instead of 'close'. --- guix/build/syscalls.scm | 15 +++++++++++++++ guix/utils.scm | 5 +++-- 2 files changed, 18 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 48ff227e10..ed0eb060d9 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -64,6 +64,7 @@ (define-module (guix build syscalls) processes mkdtemp! + fdatasync pivot-root fcntl-flock @@ -506,6 +507,20 @@ (define mkdtemp! (list err))) (pointer->string result))))) +(define fdatasync + (let ((proc (syscall->procedure int "fdatasync" (list int)))) + (lambda (port) + "Flush buffered output of PORT, an output file port, and then call +fdatasync(2) on the underlying file descriptor." + (force-output port) + (let* ((fd (fileno port)) + (ret (proc fd)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "fdatasync" "~S: ~A" + (list fd (strerror err)) + (list err))))))) + (define-record-type (file-system type block-size blocks blocks-free diff --git a/guix/utils.scm b/guix/utils.scm index c77da5d846..18d913c514 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -34,7 +34,7 @@ (define-module (guix utils) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix combinators) #:use-module ((guix build utils) #:select (dump-port)) - #:use-module ((guix build syscalls) #:select (mkdtemp!)) + #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) @@ -625,7 +625,8 @@ (define (with-atomic-file-output file proc) (with-throw-handler #t (lambda () (let ((result (proc out))) - (close out) + (fdatasync out) + (close-port out) (rename-file template file) result)) (lambda (key . args) -- cgit v1.2.3 From d1f33ba44b60526d20da04d384f3af5437f8a3ae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 Jun 2016 17:57:25 +0200 Subject: syscalls: Use 'syscall->procedure' everywhere. * guix/build/syscalls.scm (mkdtemp!, setns, %ioctl, network-interfaces): (free-ifaddrs): Use 'syscall->procedure'. --- guix/build/syscalls.scm | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ed0eb060d9..c663899160 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -494,8 +494,7 @@ (define (processes) <)) (define mkdtemp! - (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) - (proc (pointer->procedure '* ptr '(*)))) + (let ((proc (syscall->procedure '* "mkdtemp" '(*)))) (lambda (tmpl) "Create a new unique directory in the file system using the template string TMPL and return its file name. TMPL must end with 'XXXXXX'." @@ -626,8 +625,7 @@ (define setns ;; Some systems may be using an old (pre-2.14) version of glibc where there ;; is no 'setns' function available. (false-if-exception - (let* ((ptr (dynamic-func "setns" (dynamic-link))) - (proc (pointer->procedure int ptr (list int int)))) + (let ((proc (syscall->procedure int "setns" (list int int)))) (lambda (fdes nstype) "Reassociate the current process with the namespace specified by FDES, a file descriptor obtained by opening a /proc/PID/ns/* file. NSTYPE specifies @@ -833,9 +831,7 @@ (define* (read-socket-address bv #:optional (index 0)) (define %ioctl ;; The most terrible interface, live from Scheme. - (pointer->procedure int - (dynamic-func "ioctl" (dynamic-link)) - (list int unsigned-long '*))) + (syscall->procedure int "ioctl" (list int unsigned-long '*))) (define (bytevector->string-list bv stride len) "Return the null-terminated strings found in BV every STRIDE bytes. Read at @@ -1075,8 +1071,7 @@ (define (unfold-interface-list ptr) (loop ptr (cons ifaddr result))))))) (define network-interfaces - (let* ((ptr (dynamic-func "getifaddrs" (dynamic-link))) - (proc (pointer->procedure int ptr (list '*)))) + (let ((proc (syscall->procedure int "getifaddrs" (list '*)))) (lambda () "Return a list of objects, each denoting a configured network interface. This is implemented using the 'getifaddrs' libc function." @@ -1093,8 +1088,7 @@ (define network-interfaces (list err))))))) (define free-ifaddrs - (let ((ptr (dynamic-func "freeifaddrs" (dynamic-link)))) - (pointer->procedure void ptr '(*)))) + (syscall->procedure void "freeifaddrs" '(*))) ;;; -- cgit v1.2.3 From c25637dfe8aaf2aa7550c9196fb7e18820552ca6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 Jun 2016 18:00:29 +0200 Subject: utils: 'with-atomic-file-output' closes the port upon exception. Previously it could have left the file descriptor open. * guix/utils.scm (with-atomic-file-output): Call 'close-port' in handler. --- guix/utils.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 18d913c514..2d8bfd84b0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -630,7 +630,8 @@ (define (with-atomic-file-output file proc) (rename-file template file) result)) (lambda (key . args) - (false-if-exception (delete-file template)))))) + (false-if-exception (delete-file template)) + (close-port out))))) (define (cache-directory) "Return the cache directory for Guix, by default ~/.cache/guix." -- cgit v1.2.3 From 266785d21e9ed3fcbecebea302231cf35e303d66 Mon Sep 17 00:00:00 2001 From: Cyril Roelandt Date: Sun, 27 Dec 2015 03:26:11 +0100 Subject: import: pypi: read requirements from wheels. * doc/guix.tex (Invoking guix import): Mention that the pypi importer works better with "unzip". * guix/import/pypi.scm (latest-wheel-release, wheel-url->extracted-directory): New procedures. * tests/pypi.scm (("pypi->guix-package, wheels"): New test. --- doc/guix.texi | 4 +- guix/import/pypi.scm | 113 +++++++++++++++++++++++++++++++++++++++------------ tests/pypi.scm | 78 ++++++++++++++++++++++++++++++++++- 3 files changed, 166 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 46d9e77fe6..0a30b52fca 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4545,7 +4545,9 @@ Import metadata from the @uref{https://pypi.python.org/, Python Package Index}@footnote{This functionality requires Guile-JSON to be installed. @xref{Requirements}.}. Information is taken from the JSON-formatted description available at @code{pypi.python.org} and usually includes all -the relevant information, including package dependencies. +the relevant information, including package dependencies. For maximum +efficiency, it is recommended to install the @command{unzip} utility, so +that the importer can unzip Python wheels and gather data from them. The command below imports metadata for the @code{itsdangerous} Python package: diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index de30f4bea6..70ef507666 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -71,6 +71,16 @@ (define (latest-source-release pypi-package) (raise (condition (&missing-source-error (package pypi-package))))))) +(define (latest-wheel-release pypi-package) + "Return the url of the wheel for the latest release of pypi-package, +or #f if there isn't any." + (let ((releases (assoc-ref* pypi-package "releases" + (assoc-ref* pypi-package "info" "version")))) + (or (find (lambda (release) + (string=? "bdist_wheel" (assoc-ref release "packagetype"))) + releases) + #f))) + (define (python->package-name name) "Given the NAME of a package on PyPI, return a Guix-compliant name for the package." @@ -88,6 +98,11 @@ (define (guix-package->pypi-name package) ;; '/' + package name + '/' + ... (substring source-url 42 (string-rindex source-url #\/)))) +(define (wheel-url->extracted-directory wheel-url) + (match (string-split (basename wheel-url) #\-) + ((name version _ ...) + (string-append name "-" version ".dist-info")))) + (define (maybe-inputs package-inputs) "Given a list of PACKAGE-INPUTS, tries to generate the 'inputs' field of a package definition." @@ -97,10 +112,10 @@ (define (maybe-inputs package-inputs) ((package-inputs ...) `((inputs (,'quasiquote ,package-inputs)))))) -(define (guess-requirements source-url tarball) - "Given SOURCE-URL and a TARBALL of the package, return a list of the required -packages specified in the requirements.txt file. TARBALL will be extracted in -the current directory, and will be deleted." +(define (guess-requirements source-url wheel-url tarball) + "Given SOURCE-URL, WHEEL-URL and a TARBALL of the package, return a list of +the required packages specified in the requirements.txt file. TARBALL will be +extracted in the current directory, and will be deleted." (define (tarball-directory url) ;; Given the URL of the package's tarball, return the name of the directory @@ -147,26 +162,69 @@ (define (read-requirements requirements-file) (loop (cons (python->package-name (clean-requirement line)) result)))))))))) - (let ((dirname (tarball-directory source-url))) - (if (string? dirname) - (let* ((req-file (string-append dirname "/requirements.txt")) - (exit-code (system* "tar" "xf" tarball req-file))) - ;; TODO: support more formats. - (if (zero? exit-code) - (dynamic-wind - (const #t) - (lambda () - (read-requirements req-file)) - (lambda () - (delete-file req-file) - (rmdir dirname))) - (begin - (warning (_ "'tar xf' failed with exit code ~a\n") - exit-code) - '()))) - '()))) + (define (read-wheel-metadata wheel-archive) + ;; Given WHEEL-ARCHIVE, a ZIP Python wheel archive, return the package's + ;; requirements. + (let* ((dirname (wheel-url->extracted-directory wheel-url)) + (json-file (string-append dirname "/metadata.json"))) + (and (zero? (system* "unzip" "-q" wheel-archive json-file)) + (dynamic-wind + (const #t) + (lambda () + (call-with-input-file json-file + (lambda (port) + (let* ((metadata (json->scm port)) + (run_requires (hash-ref metadata "run_requires")) + (requirements (hash-ref (list-ref run_requires 0) + "requires"))) + (map (lambda (r) + (python->package-name (clean-requirement r))) + requirements))))) + (lambda () + (delete-file json-file) + (rmdir dirname)))))) + + (define (guess-requirements-from-wheel) + ;; Return the package's requirements using the wheel, or #f if an error + ;; occurs. + (call-with-temporary-output-file + (lambda (temp port) + (if wheel-url + (and (url-fetch wheel-url temp) + (read-wheel-metadata temp)) + #f)))) + + + (define (guess-requirements-from-source) + ;; Return the package's requirements by guessing them from the source. + (let ((dirname (tarball-directory source-url))) + (if (string? dirname) + (let* ((req-file (string-append dirname "/requirements.txt")) + (exit-code (system* "tar" "xf" tarball req-file))) + ;; TODO: support more formats. + (if (zero? exit-code) + (dynamic-wind + (const #t) + (lambda () + (read-requirements req-file)) + (lambda () + (delete-file req-file) + (rmdir dirname))) + (begin + (warning (_ "'tar xf' failed with exit code ~a\n") + exit-code) + '()))) + '()))) + + ;; First, try to compute the requirements using the wheel, since that is the + ;; most reliable option. If a wheel is not provided for this package, try + ;; getting them by reading the "requirements.txt" file from the source. Note + ;; that "requirements.txt" is not mandatory, so this is likely to fail. + (or (guess-requirements-from-wheel) + (guess-requirements-from-source))) + -(define (compute-inputs source-url tarball) +(define (compute-inputs source-url wheel-url tarball) "Given the SOURCE-URL of an already downloaded TARBALL, return a list of name/variable pairs describing the required inputs of this package." (sort @@ -175,13 +233,13 @@ (define (compute-inputs source-url tarball) (append '("python-setuptools") ;; Argparse has been part of Python since 2.7. (remove (cut string=? "python-argparse" <>) - (guess-requirements source-url tarball)))) + (guess-requirements source-url wheel-url tarball)))) (lambda args (match args (((a _ ...) (b _ ...)) (string-ciguix-package package-name) (let ((name (assoc-ref* package "info" "name")) (version (assoc-ref* package "info" "version")) (release (assoc-ref (latest-source-release package) "url")) + (wheel (assoc-ref (latest-wheel-release package) "url")) (synopsis (assoc-ref* package "info" "summary")) (description (assoc-ref* package "info" "summary")) (home-page (assoc-ref* package "info" "home_page")) (license (string->license (assoc-ref* package "info" "license")))) - (make-pypi-sexp name version release home-page synopsis + (make-pypi-sexp name version release wheel home-page synopsis description license)))))) (define (pypi-package? package) diff --git a/tests/pypi.scm b/tests/pypi.scm index e463467c41..379c288394 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -21,7 +21,7 @@ (define-module (test-pypi) #:use-module (guix base32) #:use-module (guix hash) #:use-module (guix tests) - #:use-module ((guix build utils) #:select (delete-file-recursively)) + #:use-module ((guix build utils) #:select (delete-file-recursively which)) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -42,6 +42,9 @@ (define test-json }, { \"url\": \"https://example.com/foo-1.0.0.tar.gz\", \"packagetype\": \"sdist\", + }, { + \"url\": \"https://example.com/foo-1.0.0-py2.py3-none-any.whl\", + \"packagetype\": \"bdist_wheel\", } ] } @@ -56,6 +59,18 @@ (define test-requirements bar baz > 13.37") +(define test-metadata + "{ + \"run_requires\": [ + { + \"requires\": [ + \"bar\", + \"baz (>13.37)\" + ] + } + ] +}") + (test-begin "pypi") (test-assert "pypi->guix-package" @@ -77,6 +92,67 @@ (define test-requirements (delete-file-recursively "foo-1.0.0") (set! test-source-hash (call-with-input-file file-name port-sha256)))) + ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) + (_ (error "Unexpected URL: " url))))) + (match (pypi->guix-package "foo") + (('package + ('name "python-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri (string-append "https://example.com/foo-" + version ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'python-build-system) + ('inputs + ('quasiquote + (("python-bar" ('unquote 'python-bar)) + ("python-baz" ('unquote 'python-baz)) + ("python-setuptools" ('unquote 'python-setuptools))))) + ('home-page "http://example.com") + ('synopsis "summary") + ('description "summary") + ('license 'lgpl2.0)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f))))) + +(test-skip (if (which "zip") 0 1)) +(test-assert "pypi->guix-package, wheels" + ;; Replace network resources with sample data. + (mock ((guix import utils) url-fetch + (lambda (url file-name) + (match url + ("https://pypi.python.org/pypi/foo/json" + (with-output-to-file file-name + (lambda () + (display test-json)))) + ("https://example.com/foo-1.0.0.tar.gz" + (begin + (mkdir "foo-1.0.0") + (with-output-to-file "foo-1.0.0/requirements.txt" + (lambda () + (display test-requirements))) + (system* "tar" "czvf" file-name "foo-1.0.0/") + (delete-file-recursively "foo-1.0.0") + (set! test-source-hash + (call-with-input-file file-name port-sha256)))) + ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" + (begin + (mkdir "foo-1.0.0.dist-info") + (with-output-to-file "foo-1.0.0.dist-info/metadata.json" + (lambda () + (display test-metadata))) + (let ((zip-file (string-append file-name ".zip"))) + ;; zip always adds a "zip" extension to the file it creates, + ;; so we need to rename it. + (system* "zip" zip-file "foo-1.0.0.dist-info/metadata.json") + (rename-file zip-file file-name)) + (delete-file-recursively "foo-1.0.0.dist-info"))) (_ (error "Unexpected URL: " url))))) (match (pypi->guix-package "foo") (('package -- cgit v1.2.3 From 5257ab6de29b15e9d663311e8f3b291363d44344 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Jun 2016 21:34:07 +0200 Subject: packages: Recognize the '.Z' extension. Reported by thomasd on #guix. * guix/packages.scm (patch-and-repack)[decompression-type]: Add "Z". --- guix/packages.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index d62d1f3343..5cba5a5121 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -406,6 +406,7 @@ (define lookup-input (define decompression-type (cond ((string-suffix? "gz" source-file-name) "gzip") + ((string-suffix? "Z" source-file-name) "gzip") ((string-suffix? "bz2" source-file-name) "bzip2") ((string-suffix? "lz" source-file-name) "lzip") ((string-suffix? "zip" source-file-name) "unzip") -- cgit v1.2.3 From 789510640d8ac30298c45d0edc80ec9078aa3afd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Jun 2016 10:16:56 +0200 Subject: packages: 'origin->derivation' expects an origin and nothing else. * guix/packages.scm (origin->derivation): Rename 'source' parameter to 'origin'. Move cases where SOURCE is a string to... (package-source-derivation): ... here. --- guix/packages.scm | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 5cba5a5121..1e816179a6 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1129,12 +1129,10 @@ (define-gexp-compiler (package-compiler (package package?) system target) (package->cross-derivation package target system) (package->derivation package system))) -(define* (origin->derivation source +(define* (origin->derivation origin #:optional (system (%current-system))) - "When SOURCE is an object, return its derivation for SYSTEM. When -SOURCE is a file name, return either the interned file name (if SOURCE is -outside of the store) or SOURCE itself (if SOURCE is already a store item.)" - (match source + "Return the derivation corresponding to ORIGIN." + (match origin (($ uri method sha256 name (= force ()) #f) ;; No patches, no snippet: this is a fixed-output derivation. (method uri 'sha256 sha256 name #:system system)) @@ -1155,18 +1153,24 @@ (define* (origin->derivation source #:system system #:modules modules #:imported-modules modules - #:guile-for-build guile))) - ((and (? string?) (? direct-store-path?) file) - (with-monad %store-monad - (return file))) - ((? string? file) - (interned-file file (basename file) - #:recursive? #t)))) + #:guile-for-build guile))))) (define-gexp-compiler (origin-compiler (origin origin?) system target) ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring ;; to an origin from within a gexp. (origin->derivation origin system)) -(define package-source-derivation - (store-lower origin->derivation)) +(define package-source-derivation ;somewhat deprecated + (let ((lower (store-lower origin->derivation))) + (lambda* (store source #:optional (system (%current-system))) + "Return the derivation or file corresponding to SOURCE, which can be an + or a file name. When SOURCE is a file name, return either the +interned file name (if SOURCE is outside of the store) or SOURCE itself (if +SOURCE is already a store item.)" + (match source + ((and (? string?) (? direct-store-path?) file) + file) + ((? string? file) + (add-to-store store (basename file) #t "sha256" file)) + (_ + (lower store source system)))))) -- cgit v1.2.3 From da675305ddf2ba574e309e515d18ae1f778297be Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Jun 2016 10:38:46 +0200 Subject: packages: The 'source' can be any lowerable object. * guix/packages.scm (expand-input): Use 'struct?' instead of 'origin?' when matching SOURCE. (package-source-derivation): Use 'lower-object' instead of 'origin->derivation'. * tests/packages.scm ("package-source-derivation, local-file"): New test. * doc/guix.texi (package Reference): Update 'source' documentation accordingly. --- doc/guix.texi | 8 ++++++-- guix/packages.scm | 10 +++++----- tests/packages.scm | 15 +++++++++++++++ 3 files changed, 26 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 0a30b52fca..18a1960cf7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2503,8 +2503,12 @@ The name of the package, as a string. The version of the package, as a string. @item @code{source} -An origin object telling how the source code for the package should be -acquired (@pxref{origin Reference}). +An object telling how the source code for the package should be +acquired. Most of the time, this is an @code{origin} object, which +denotes a file fetched from the Internet (@pxref{origin Reference}). It +can also be any other ``file-like'' object such as a @code{local-file}, +which denotes a file from the local file system (@pxref{G-Expressions, +@code{local-file}}). @item @code{build-system} The build system that should be used to build the package (@pxref{Build diff --git a/guix/packages.scm b/guix/packages.scm index 1e816179a6..05a632cf05 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -792,7 +792,7 @@ (define derivation ;; store path, it needs to be added anyway, so it can be used as a ;; source. (list name (intern file))) - (((? string? name) (? origin? source)) + (((? string? name) (? struct? source)) (list name (package-source-derivation store source system))) (x (raise (condition (&package-input-error @@ -1161,12 +1161,12 @@ (define-gexp-compiler (origin-compiler (origin origin?) system target) (origin->derivation origin system)) (define package-source-derivation ;somewhat deprecated - (let ((lower (store-lower origin->derivation))) + (let ((lower (store-lower lower-object))) (lambda* (store source #:optional (system (%current-system))) "Return the derivation or file corresponding to SOURCE, which can be an - or a file name. When SOURCE is a file name, return either the -interned file name (if SOURCE is outside of the store) or SOURCE itself (if -SOURCE is already a store item.)" +a file name or any object handled by 'lower-object', such as an . +When SOURCE is a file name, return either the interned file name (if SOURCE is +outside of the store) or SOURCE itself (if SOURCE is already a store item.)" (match source ((and (? string?) (? direct-store-path?) file) file) diff --git a/tests/packages.scm b/tests/packages.scm index 94e8150b75..d3f432ada2 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -21,6 +21,7 @@ (define-module (test-packages) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) + #:use-module ((guix gexp) #:select (local-file local-file-file)) #:use-module ((guix utils) ;; Rename the 'location' binding to allow proper syntax ;; matching when setting the 'location' field of a package. @@ -295,6 +296,20 @@ (define read-at (and (direct-store-path? source) (string-suffix? "utils.scm" source)))) +(test-assert "package-source-derivation, local-file" + (let* ((file (local-file "../guix/base32.scm")) + (package (package (inherit (dummy-package "p")) + (source file))) + (source (package-source-derivation %store + (package-source package)))) + (and (store-path? source) + (string-suffix? "base32.scm" source) + (valid-path? %store source) + (equal? (call-with-input-file source get-bytevector-all) + (call-with-input-file + (search-path %load-path "guix/base32.scm") + get-bytevector-all))))) + (unless (network-reachable?) (test-skip 1)) (test-equal "package-source-derivation, snippet" "OK" -- cgit v1.2.3 From 1ec32f4a9d35f235a9947f288370af1445f8ab8b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Jun 2016 11:51:16 +0200 Subject: store: Add #:select? parameter to 'add-to-store'. * guix/store.scm (write-arg): Remove 'file' case. (true): New procedure. (add-to-store): Add #:select? parameter and honor it. Use hand-coded stub instead of 'operation'. (interned-file): Add #:select? parameter and honor it. * doc/guix.texi (The Store Monad): Adjust 'interned-file' documentation accordingly. --- doc/guix.texi | 7 ++++++- guix/store.scm | 60 ++++++++++++++++++++++++++++++++++++++++------------------ 2 files changed, 48 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 18a1960cf7..97c01be213 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3502,7 +3502,7 @@ resulting text file refers to; it defaults to the empty list. @end deffn @deffn {Monadic Procedure} interned-file @var{file} [@var{name}] @ - [#:recursive? #t] + [#:recursive? #t] [#:select? (const #t)] Return the name of @var{file} once interned in the store. Use @var{name} as its store name, or the basename of @var{file} if @var{name} is omitted. @@ -3511,6 +3511,11 @@ When @var{recursive?} is true, the contents of @var{file} are added recursively; if @var{file} designates a flat file and @var{recursive?} is true, its contents are added, and its permission bits are kept. +When @var{recursive?} is true, call @code{(@var{select?} @var{file} +@var{stat})} for each directory entry, where @var{file} is the entry's +absolute file name and @var{stat} is the result of @code{lstat}; exclude +entries for which @var{select?} does not return true. + The example below adds a file to the store, under two different names: @example diff --git a/guix/store.scm b/guix/store.scm index e3033ee61a..a64016611d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -263,14 +263,12 @@ (define (read-path-info p) (path-info deriver hash refs registration-time nar-size))) (define-syntax write-arg - (syntax-rules (integer boolean file string string-list string-pairs + (syntax-rules (integer boolean string string-list string-pairs store-path store-path-list base16) ((_ integer arg p) (write-int arg p)) ((_ boolean arg p) (write-int (if arg 1 0) p)) - ((_ file arg p) - (write-file arg p)) ((_ string arg p) (write-string arg p)) ((_ string-list arg p) @@ -653,30 +651,51 @@ (define add-text-to-store (hash-set! cache args path) path)))))) +(define true + ;; Define it once and for all since we use it as a default value for + ;; 'add-to-store' and want to make sure two default values are 'eq?' for the + ;; purposes or memoization. + (lambda (file stat) + #t)) + (define add-to-store ;; A memoizing version of `add-to-store'. This is important because ;; `add-to-store' leads to huge data transfers to the server, and ;; because it's often called many times with the very same argument. - (let ((add-to-store (operation (add-to-store (string basename) - (boolean fixed?) ; obsolete, must be #t - (boolean recursive?) - (string hash-algo) - (file file-name)) - #f - store-path))) - (lambda (server basename recursive? hash-algo file-name) + (let ((add-to-store + (lambda* (server basename recursive? hash-algo file-name + #:key (select? true)) + ;; We don't use the 'operation' macro so we can pass SELECT? to + ;; 'write-file'. + (let ((port (nix-server-socket server))) + (write-int (operation-id add-to-store) port) + (write-string basename port) + (write-int 1 port) ;obsolete, must be #t + (write-int (if recursive? 1 0) port) + (write-string hash-algo port) + (write-file file-name port #:select? select?) + (let loop ((done? (process-stderr server))) + (or done? (loop (process-stderr server)))) + (read-store-path port))))) + (lambda* (server basename recursive? hash-algo file-name + #:key (select? true)) "Add the contents of FILE-NAME under BASENAME to the store. When RECURSIVE? is false, FILE-NAME must designate a regular file--not a directory nor a symlink. When RECURSIVE? is true and FILE-NAME designates a directory, the contents of FILE-NAME are added recursively; if FILE-NAME designates a flat file and RECURSIVE? is true, its contents are added, and its permission -bits are kept. HASH-ALGO must be a string such as \"sha256\"." +bits are kept. HASH-ALGO must be a string such as \"sha256\". + +When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, +where FILE is the entry's absolute file name and STAT is the result of +'lstat'; exclude entries for which SELECT? does not return true." (let* ((st (false-if-exception (lstat file-name))) - (args `(,st ,basename ,recursive? ,hash-algo)) + (args `(,st ,basename ,recursive? ,hash-algo ,select?)) (cache (nix-server-add-to-store-cache server))) (or (and st (hash-ref cache args)) - (let ((path (add-to-store server basename #t recursive? - hash-algo file-name))) + (let ((path (add-to-store server basename recursive? + hash-algo file-name + #:select? select?))) (hash-set! cache args path) path)))))) @@ -1111,16 +1130,21 @@ (define* (text-file name text store))) (define* (interned-file file #:optional name - #:key (recursive? #t)) + #:key (recursive? #t) (select? true)) "Return the name of FILE once interned in the store. Use NAME as its store name, or the basename of FILE if NAME is omitted. When RECURSIVE? is true, the contents of FILE are added recursively; if FILE designates a flat file and RECURSIVE? is true, its contents are added, and its -permission bits are kept." +permission bits are kept. + +When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, +where FILE is the entry's absolute file name and STAT is the result of +'lstat'; exclude entries for which SELECT? does not return true." (lambda (store) (values (add-to-store store (or name (basename file)) - recursive? "sha256" file) + recursive? "sha256" file + #:select? select?) store))) (define build -- cgit v1.2.3 From c4e48b68bdf41e7f6805473fc4f545b215251c6d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Jun 2016 10:38:10 +0200 Subject: guix: Add downloader for Mercurial repositories. * guix/build/hg.scm: New file. * guix/hg-download.scm: New file. * Makefile.am (MODULES): Add them. --- Makefile.am | 2 ++ guix/build/hg.scm | 51 +++++++++++++++++++++++++++++++ guix/hg-download.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 137 insertions(+) create mode 100644 guix/build/hg.scm create mode 100644 guix/hg-download.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 50cde52701..8fd1c1b0b6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -43,6 +43,7 @@ MODULES = \ guix/sets.scm \ guix/download.scm \ guix/git-download.scm \ + guix/hg-download.scm \ guix/monads.scm \ guix/monad-repl.scm \ guix/gexp.scm \ @@ -82,6 +83,7 @@ MODULES = \ guix/build/cmake-build-system.scm \ guix/build/emacs-build-system.scm \ guix/build/git.scm \ + guix/build/hg.scm \ guix/build/glib-or-gtk-build-system.scm \ guix/build/gnu-build-system.scm \ guix/build/gnu-dist.scm \ diff --git a/guix/build/hg.scm b/guix/build/hg.scm new file mode 100644 index 0000000000..ae4574de57 --- /dev/null +++ b/guix/build/hg.scm @@ -0,0 +1,51 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ricardo Wurmus +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build hg) + #:use-module (guix build utils) + #:export (hg-fetch)) + +;;; Commentary: +;;; +;;; This is the build-side support code of (guix hg-download). It allows a +;;; Mercurial repository to be cloned and checked out at a specific changeset +;;; identifier. +;;; +;;; Code: + +(define* (hg-fetch url changeset directory + #:key (hg-command "hg")) + "Fetch CHANGESET from URL into DIRECTORY. CHANGESET must be a valid +Mercurial changeset identifier. Return #t on success, #f otherwise." + + (and (zero? (system* hg-command + "clone" url + "--rev" changeset + ;; Disable TLS certificate verification. The hash of + ;; the checkout is known in advance anyway. + "--insecure" + directory)) + (with-directory-excursion directory + (begin + ;; The contents of '.hg' vary as a function of the current + ;; status of the Mercurial repo. Since we want a fixed + ;; output, this directory needs to be taken out. + (delete-file-recursively ".hg") + #t)))) + +;;; hg.scm ends here diff --git a/guix/hg-download.scm b/guix/hg-download.scm new file mode 100644 index 0000000000..f3e1d2906a --- /dev/null +++ b/guix/hg-download.scm @@ -0,0 +1,84 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015 Ludovic Courtès +;;; Copyright © 2016 Ricardo Wurmus +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix hg-download) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix packages) + #:autoload (guix build-system gnu) (standard-packages) + #:use-module (ice-9 match) + #:export (hg-reference + hg-reference? + hg-reference-url + hg-reference-changeset + hg-reference-recursive? + + hg-fetch)) + +;;; Commentary: +;;; +;;; An method that fetches a specific changeset from a Mercurial +;;; repository. The repository URL and changeset ID are specified with a +;;; object. +;;; +;;; Code: + +(define-record-type* + hg-reference make-hg-reference + hg-reference? + (url hg-reference-url) + (changeset hg-reference-changeset)) + +(define (hg-package) + "Return the default Mercurial package." + (let ((distro (resolve-interface '(gnu packages version-control)))) + (module-ref distro 'mercurial))) + +(define* (hg-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (hg (hg-package))) + "Return a fixed-output derivation that fetches REF, a +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (define build + #~(begin + (use-modules (guix build hg) + (guix build utils) + (ice-9 match)) + + (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg")))) + + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name "hg-checkout") build + #:system system + #:local-build? #t ;don't offload repo cloning + #:hash-algo hash-algo + #:hash hash + #:recursive? #t + #:modules '((guix build hg) + (guix build utils)) + #:guile-for-build guile))) + +;;; hg-download.scm ends here -- cgit v1.2.3 From 07c8a98c3b45dca9fd36af7c4a300d3af58734dd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Jun 2016 23:08:05 +0200 Subject: gexp: Move 'current-source-directory' to (guix utils). * guix/gexp.scm (extract-directory, current-source-directory): Move to... * guix/utils.scm (extract-directory, current-source-directory): ... here. New procedures. --- guix/gexp.scm | 13 ------------- guix/utils.scm | 15 +++++++++++++++ 2 files changed, 15 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index b4d737ecae..8e604ff7cf 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -202,19 +202,6 @@ (define* (%local-file file promise #:optional (name (basename file)) ;; %%LOCAL-FILE is not. (%%local-file file promise name recursive?)) -(define (extract-directory properties) - "Extract the directory name from source location PROPERTIES." - (match (assq 'filename properties) - (('filename . (? string? file-name)) - (dirname file-name)) - (_ - #f))) - -(define-syntax-rule (current-source-directory) - "Expand to the directory of the current source file or #f if it could not -be determined." - (extract-directory (current-source-location))) - (define (absolute-file-name file directory) "Return the canonical absolute file name for FILE, which lives in the vicinity of DIRECTORY." diff --git a/guix/utils.scm b/guix/utils.scm index 2d8bfd84b0..19fd0b0844 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -53,6 +53,8 @@ (define-module (guix utils) substitute-keyword-arguments ensure-keyword-arguments + current-source-directory + location location? @@ -700,6 +702,19 @@ (define (read! bv start n) ;;; Source location. ;;; +(define (extract-directory properties) + "Extract the directory name from source location PROPERTIES." + (match (assq 'filename properties) + (('filename . (? string? file-name)) + (dirname file-name)) + (_ + #f))) + +(define-syntax-rule (current-source-directory) + "Expand to the directory of the current source file or #f if it could not +be determined." + (extract-directory (current-source-location))) + ;; A source location. (define-record-type (make-location file line column) -- cgit v1.2.3 From 0687fc9cd98e38feab80e2f9c8044e77ad52c7fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Jun 2016 00:06:27 +0200 Subject: gexp: Add #:select? parameter to 'local-file'. * guix/gexp.scm ()[select?]: New field. (true): New procedure. (%local-file): Add #:select? and honor it. (local-file): Likewise. * tests/gexp.scm ("local-file, #:select?"): New test. * doc/guix.texi (G-Expressions): Adjust accordingly. --- doc/guix.texi | 7 ++++++- guix/gexp.scm | 20 ++++++++++++++------ tests/gexp.scm | 18 +++++++++++++++++- 3 files changed, 37 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index f85221d065..227d861482 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3804,7 +3804,7 @@ does not have any effect on what the G-expression does. content is directly passed as a string. @deffn {Scheme Procedure} local-file @var{file} [@var{name}] @ - [#:recursive? #f] + [#:recursive? #f] [#:select? (const #t)] Return an object representing local file @var{file} to add to the store; this object can be used in a gexp. If @var{file} is a relative file name, it is looked up relative to the source file where this form appears. @var{file} will be added to @@ -3814,6 +3814,11 @@ When @var{recursive?} is true, the contents of @var{file} are added recursively; designates a flat file and @var{recursive?} is true, its contents are added, and its permission bits are kept. +When @var{recursive?} is true, call @code{(@var{select?} @var{file} +@var{stat})} for each directory entry, where @var{file} is the entry's +absolute file name and @var{stat} is the result of @code{lstat}; exclude +entries for which @var{select?} does not return true. + This is the declarative counterpart of the @code{interned-file} monadic procedure (@pxref{The Store Monad, @code{interned-file}}). @end deffn diff --git a/guix/gexp.scm b/guix/gexp.scm index 8e604ff7cf..2bf1013b3c 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -189,18 +189,21 @@ (define-gexp-compiler (derivation-compiler (drv derivation?) system target) ;; absolute file name. We keep it in a promise to compute it lazily and avoid ;; repeated 'stat' calls. (define-record-type - (%%local-file file absolute name recursive?) + (%%local-file file absolute name recursive? select?) local-file? (file local-file-file) ;string (absolute %local-file-absolute-file-name) ;promise string (name local-file-name) ;string - (recursive? local-file-recursive?)) ;Boolean + (recursive? local-file-recursive?) ;Boolean + (select? local-file-select?)) ;string stat -> Boolean + +(define (true file stat) #t) (define* (%local-file file promise #:optional (name (basename file)) - #:key recursive?) + #:key recursive? (select? true)) ;; This intermediate procedure is part of our ABI, but the underlying ;; %%LOCAL-FILE is not. - (%%local-file file promise name recursive?)) + (%%local-file file promise name recursive? select?)) (define (absolute-file-name file directory) "Return the canonical absolute file name for FILE, which lives in the @@ -222,6 +225,10 @@ (define-syntax-rule (local-file file rest ...) designates a flat file and RECURSIVE? is true, its contents are added, and its permission bits are kept. +When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, +where FILE is the entry's absolute file name and STAT is the result of +'lstat'; exclude entries for which SELECT? does not return true. + This is the declarative counterpart of the 'interned-file' monadic procedure." (%local-file file (delay (absolute-file-name file (current-source-directory))) @@ -235,12 +242,13 @@ (define (local-file-absolute-file-name file) (define-gexp-compiler (local-file-compiler (file local-file?) system target) ;; "Compile" FILE by adding it to the store. (match file - (($ file (= force absolute) name recursive?) + (($ file (= force absolute) name recursive? select?) ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would ;; just throw an error, both of which are inconvenient. - (interned-file absolute name #:recursive? recursive?)))) + (interned-file absolute name + #:recursive? recursive? #:select? select?)))) (define-record-type (%plain-file name content references) diff --git a/tests/gexp.scm b/tests/gexp.scm index db0ffd2fdd..f504b92d84 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -33,7 +33,8 @@ (define-module (test-gexp) #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:use-module (ice-9 popen)) + #:use-module (ice-9 popen) + #:use-module (ice-9 ftw)) ;; Test the (guix gexp) module. @@ -132,6 +133,21 @@ (define-syntax-rule (test-assertm name exp) (lambda () (false-if-exception (delete-file link)))))) +(test-assertm "local-file, #:select?" + (mlet* %store-monad ((select? -> (lambda (file stat) + (member (basename file) + '("guix.scm" "tests" + "gexp.scm")))) + (file -> (local-file ".." "directory" + #:recursive? #t + #:select? select?)) + (dir (lower-object file))) + (return (and (store-path? dir) + (equal? (scandir dir) + '("." ".." "guix.scm" "tests")) + (equal? (scandir (string-append dir "/tests")) + '("." ".." "gexp.scm")))))) + (test-assert "one plain file" (let* ((file (plain-file "hi" "Hello, world!")) (exp (gexp (display (ungexp file)))) -- cgit v1.2.3 From a7db719f3dc16b6be7aaab45e718798902d82833 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Jun 2016 14:31:52 +0200 Subject: packages: Disambiguate 'modules' and 'imported-modules' in . The two mistakes made here (confusion between 'modules' and 'imported-modules') were canceling each other. * guix/packages.scm (patch-and-repack): Use IMPORTED-MODULES, not MODULES, as the base of the module list passed as #:modules to 'gexp->derivation'. (origin->derivation): Pass IMPORTED-MODULES, not MODULES, as the #:imported-modules argument of 'patch-and-repack'. * gnu/packages/engineering.scm (fastcap)[source]: Add 'imported-modules' field. --- gnu/packages/engineering.scm | 1 + guix/packages.scm | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm index 02b1c4e9eb..7b21c11ad3 100644 --- a/gnu/packages/engineering.scm +++ b/gnu/packages/engineering.scm @@ -232,6 +232,7 @@ (define-public fastcap (modules '((guix build utils) (guix build download) (guix ftp-client))) + (imported-modules modules) (patches (search-patches "fastcap-mulSetup.patch" "fastcap-mulGlobal.patch")))) (build-system gnu-build-system) diff --git a/guix/packages.scm b/guix/packages.scm index 05a632cf05..acb8f34417 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -544,7 +544,8 @@ (define (first-file directory) "--files-from=.file_list"))))))))) (let ((name (tarxz-name original-file-name)) - (modules (delete-duplicates (cons '(guix build utils) modules)))) + (modules (delete-duplicates (cons '(guix build utils) + imported-modules)))) (gexp->derivation name build #:graft? #f #:system system @@ -1152,7 +1153,7 @@ (define* (origin->derivation origin #:flags flags #:system system #:modules modules - #:imported-modules modules + #:imported-modules imported-modules #:guile-for-build guile))))) (define-gexp-compiler (origin-compiler (origin origin?) system target) -- cgit v1.2.3 From 5dbae738f0ff83bf629b53d6f4e52a8384a97fb1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Jun 2016 22:05:10 +0200 Subject: utils: 'current-source-directory' is now purely an expansion-time thing. * guix/utils.scm (extract-directory): Remove. (current-source-directory): Rewrite as a 'syntax-case' macro. --- guix/utils.scm | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 19fd0b0844..8aadfb0075 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -702,18 +702,16 @@ (define (read! bv start n) ;;; Source location. ;;; -(define (extract-directory properties) - "Extract the directory name from source location PROPERTIES." - (match (assq 'filename properties) - (('filename . (? string? file-name)) - (dirname file-name)) - (_ - #f))) - -(define-syntax-rule (current-source-directory) - "Expand to the directory of the current source file or #f if it could not -be determined." - (extract-directory (current-source-location))) +(define-syntax current-source-directory + (lambda (s) + "Return the current directory name or #f if it could not be determined." + (syntax-case s () + ((_) + (match (assq 'filename (syntax-source s)) + (('filename . (? string? file-name)) + (dirname file-name)) + (_ + #f)))))) ;; A source location. (define-record-type -- cgit v1.2.3 From d4dd37fc4614859461952a251a49c1abb2d71ddc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Jun 2016 22:24:14 +0200 Subject: utils: 'current-source-directory' returns the absolute directory name. * guix/utils.scm (current-source-directory): When FILE-NAME is relative, use 'search-path' to determine the absolute file name. --- guix/utils.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 8aadfb0075..a642bd3d62 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -704,12 +704,18 @@ (define (read! bv start n) (define-syntax current-source-directory (lambda (s) - "Return the current directory name or #f if it could not be determined." + "Return the absolute name of the current directory, or #f if it could not +be determined." (syntax-case s () ((_) (match (assq 'filename (syntax-source s)) (('filename . (? string? file-name)) - (dirname file-name)) + ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME + ;; can be relative. In that case, we try to find out the absolute + ;; file name by looking at %LOAD-PATH. + (if (string-prefix? "/" file-name) + (dirname file-name) + (and=> (search-path %load-path file-name) dirname))) (_ #f)))))) -- cgit v1.2.3