summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/ant-build-system.scm44
-rw-r--r--guix/build/asdf-build-system.scm182
-rw-r--r--guix/build/bournish.scm52
-rw-r--r--guix/build/cargo-build-system.scm11
-rw-r--r--guix/build/download.scm23
-rw-r--r--guix/build/emacs-build-system.scm36
-rw-r--r--guix/build/java-utils.scm55
-rw-r--r--guix/build/lisp-utils.scm384
-rw-r--r--guix/build/profiles.scm6
-rw-r--r--guix/build/pull.scm75
-rw-r--r--guix/build/syscalls.scm169
-rw-r--r--guix/build/union.scm43
12 files changed, 697 insertions, 383 deletions
diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm
index 00a4a46d81..4042630a10 100644
--- a/guix/build/ant-build-system.scm
+++ b/guix/build/ant-build-system.scm
@@ -35,7 +35,8 @@
;;
;; Code:
-(define (default-build.xml jar-name prefix)
+(define* (default-build.xml jar-name prefix #:optional
+ (source-dir ".") (test-dir "./test"))
"Create a simple build.xml with standard targets for Ant."
(call-with-output-file "build.xml"
(lambda (port)
@@ -47,6 +48,10 @@
(value "${basedir}/build/jar")))
(property (@ (name "dist.dir")
(value ,prefix)))
+ (property (@ (name "test.home")
+ (value ,test-dir)))
+ (property (@ (name "test.classes.dir")
+ (value "${basedir}/build/test-classes")))
;; respect the CLASSPATH environment variable
(property (@ (name "build.sysclasspath")
@@ -58,10 +63,39 @@
(target (@ (name "compile"))
(mkdir (@ (dir "${classes.dir}")))
(javac (@ (includeantruntime "false")
- (srcdir "src")
+ (srcdir ,source-dir)
(destdir "${classes.dir}")
(classpath (@ (refid "classpath"))))))
+ (target (@ (name "compile-tests"))
+ (mkdir (@ (dir "${test.classes.dir}")))
+ (javac (@ (includeantruntime "false")
+ (srcdir ,test-dir)
+ (destdir "${test.classes.dir}"))
+ (classpath
+ (pathelement (@ (path "${env.CLASSPATH}")))
+ (pathelement (@ (location "${classes.dir}")))
+ (pathelement (@ (location "${test.classes.dir}"))))))
+
+ (target (@ (name "check")
+ (depends "compile-tests"))
+ (mkdir (@ (dir "${test.home}/test-reports")))
+ (junit (@ (printsummary "true")
+ (showoutput "true")
+ (fork "yes")
+ (haltonfailure "yes"))
+ (classpath
+ (pathelement (@ (path "${env.CLASSPATH}")))
+ (pathelement (@ (location "${test.home}/resources")))
+ (pathelement (@ (location "${classes.dir}")))
+ (pathelement (@ (location "${test.classes.dir}"))))
+ (formatter (@ (type "plain")
+ (usefile "true")))
+ (batchtest (@ (fork "yes")
+ (todir "${test.home}/test-reports"))
+ (fileset (@ (dir "${test.home}/java"))
+ (include (@ (name "**/*Test.java" )))))))
+
(target (@ (name "jar")
(depends "compile"))
(mkdir (@ (dir "${jar.dir}")))
@@ -98,11 +132,13 @@ to the default GNU unpack strategy."
((assq-ref gnu:%standard-phases 'unpack) #:source source)))
(define* (configure #:key inputs outputs (jar-name #f)
- #:allow-other-keys)
+ (source-dir "src")
+ (test-dir "src/test") #:allow-other-keys)
(when jar-name
(default-build.xml jar-name
(string-append (assoc-ref outputs "out")
- "/share/java")))
+ "/share/java")
+ source-dir test-dir))
(setenv "JAVA_HOME" (assoc-ref inputs "jdk"))
(setenv "CLASSPATH" (generate-classpath inputs)))
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 085d073dea..c5e820a00a 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +21,7 @@
#:use-module (guix build utils)
#:use-module (guix build lisp-utils)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
@@ -42,50 +43,42 @@
(define %object-prefix "/lib")
-(define (source-install-prefix lisp)
- (string-append %install-prefix "/" lisp "-source"))
+(define (%lisp-source-install-prefix)
+ (string-append %source-install-prefix "/" (%lisp-type) "-source"))
(define %system-install-prefix
- (string-append %install-prefix "/systems"))
+ (string-append %source-install-prefix "/systems"))
-(define (output-path->package-name path)
- (package-name->name+version (strip-store-file-name path)))
-
-(define (outputs->name outputs)
- (output-path->package-name
- (assoc-ref outputs "out")))
-
-(define (lisp-source-directory output lisp name)
- (string-append output (source-install-prefix lisp) "/" name))
+(define (lisp-source-directory output name)
+ (string-append output (%lisp-source-install-prefix) "/" name))
(define (source-directory output name)
- (string-append output %install-prefix "/source/" name))
+ (string-append output %source-install-prefix "/source/" name))
-(define (library-directory output lisp)
+(define (library-directory output)
(string-append output %object-prefix
- "/" lisp))
+ "/" (%lisp-type)))
(define (output-translation source-path
- object-output
- lisp)
+ object-output)
"Return a translation for the system's source path
to it's binary output."
`((,source-path
:**/ :*.*.*)
- (,(library-directory object-output lisp)
+ (,(library-directory object-output)
:**/ :*.*.*)))
-(define (source-asd-file output lisp name asd-file)
- (string-append (lisp-source-directory output lisp name) "/" asd-file))
-
-(define (copy-files-to-output outputs output name)
- "Copy all files from OUTPUT to \"out\". Create an extra link to any
-system-defining files in the source to a convenient location. This is done
-before any compiling so that the compiled source locations will be valid."
- (let* ((out (assoc-ref outputs output))
- (source (getcwd))
- (target (source-directory out name))
- (system-path (string-append out %system-install-prefix)))
+(define (source-asd-file output name asd-file)
+ (string-append (lisp-source-directory output name) "/" asd-file))
+
+(define (copy-files-to-output out name)
+ "Copy all files from the current directory to OUT. Create an extra link to
+any system-defining files in the source to a convenient location. This is
+done before any compiling so that the compiled source locations will be
+valid."
+ (let ((source (getcwd))
+ (target (source-directory out name))
+ (system-path (string-append out %system-install-prefix)))
(copy-recursively source target)
(mkdir-p system-path)
(for-each
@@ -97,45 +90,38 @@ before any compiling so that the compiled source locations will be valid."
(define* (install #:key outputs #:allow-other-keys)
"Copy and symlink all the source files."
- (copy-files-to-output outputs "out" (outputs->name outputs)))
-
-(define* (copy-source #:key outputs lisp #:allow-other-keys)
- "Copy the source to \"out\"."
- (let* ((out (assoc-ref outputs "out"))
- (name (remove-lisp-from-name (output-path->package-name out) lisp))
- (install-path (string-append out %install-prefix)))
- (copy-files-to-output outputs "out" name)
+ (define output (assoc-ref outputs "out"))
+ (copy-files-to-output output
+ (package-name->name+version
+ (strip-store-file-name output))))
+
+(define* (copy-source #:key outputs asd-system-name #:allow-other-keys)
+ "Copy the source to the library output."
+ (let* ((out (library-output outputs))
+ (install-path (string-append out %source-install-prefix)))
+ (copy-files-to-output out asd-system-name)
;; Hide the files from asdf
(with-directory-excursion install-path
- (rename-file "source" (string-append lisp "-source"))
+ (rename-file "source" (string-append (%lisp-type) "-source"))
(delete-file-recursively "systems")))
#t)
-(define* (build #:key outputs inputs lisp asd-file
+(define* (build #:key outputs inputs asd-file asd-system-name
#:allow-other-keys)
"Compile the system."
- (let* ((out (assoc-ref outputs "out"))
- (name (remove-lisp-from-name (output-path->package-name out) lisp))
- (source-path (lisp-source-directory out lisp name))
+ (let* ((out (library-output outputs))
+ (source-path (lisp-source-directory out asd-system-name))
(translations (wrap-output-translations
`(,(output-translation source-path
- out
- lisp))))
- (asd-file (and=> asd-file (cut source-asd-file out lisp name <>))))
+ out))))
+ (asd-file (source-asd-file out asd-system-name asd-file)))
(setenv "ASDF_OUTPUT_TRANSLATIONS"
(replace-escaped-macros (format #f "~S" translations)))
- ;; We don't need this if we have the asd file, and it can mess with the
- ;; load ordering we're trying to enforce
- (unless asd-file
- (prepend-to-source-registry (string-append source-path "//")))
-
(setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
- (parameterize ((%lisp (string-append
- (assoc-ref inputs lisp) "/bin/" lisp)))
- (compile-system name lisp asd-file))
+ (compile-system asd-system-name asd-file)
;; As above, ecl will sometimes create this even though it doesn't use it
@@ -144,56 +130,48 @@ before any compiling so that the compiled source locations will be valid."
(delete-file-recursively cache-directory))))
#t)
-(define* (check #:key lisp tests? outputs inputs asd-file
+(define* (check #:key tests? outputs inputs asd-file asd-system-name
+ test-asd-file
#:allow-other-keys)
"Test the system."
- (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp))
- (out (assoc-ref outputs "out"))
- (asd-file (and=> asd-file (cut source-asd-file out lisp name <>))))
+ (let* ((out (library-output outputs))
+ (asd-file (source-asd-file out asd-system-name asd-file))
+ (test-asd-file
+ (and=> test-asd-file
+ (cut source-asd-file out asd-system-name <>))))
(if tests?
- (parameterize ((%lisp (string-append
- (assoc-ref inputs lisp) "/bin/" lisp)))
- (test-system name lisp asd-file))
+ (test-system asd-system-name asd-file test-asd-file)
(format #t "test suite not run~%")))
#t)
-(define* (patch-asd-files #:key outputs
+(define* (create-asd-file #:key outputs
inputs
- lisp
- special-dependencies
- test-only-systems
+ asd-file
+ asd-system-name
#:allow-other-keys)
- "Patch any asd files created by the compilation process so that they can
-find their dependencies. Exclude any TEST-ONLY-SYSTEMS which were only
-included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP
-implementation itself provides."
- (let* ((out (assoc-ref outputs "out"))
- (name (remove-lisp-from-name (output-path->package-name out) lisp))
- (registry (lset-difference
- (lambda (input system)
- (match input
- ((name . path) (string=? name system))))
- (lisp-dependencies lisp inputs)
- test-only-systems))
- (lisp-systems (map first registry)))
-
- (for-each
- (lambda (asd-file)
- (patch-asd-file asd-file registry lisp
- (append lisp-systems special-dependencies)))
- (find-files out "\\.asd$")))
+ "Create a system definition file for the built system."
+ (let*-values (((out) (library-output outputs))
+ ((_ version) (package-name->name+version
+ (strip-store-file-name out)))
+ ((new-asd-file) (string-append
+ (library-directory out)
+ "/" (normalize-string asd-system-name)
+ ".asd")))
+
+ (make-asd-file new-asd-file
+ #:system asd-system-name
+ #:version version
+ #:inputs inputs
+ #:system-asd-file asd-file))
#t)
-(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys)
+(define* (symlink-asd-files #:key outputs #:allow-other-keys)
"Create an extra reference to the system in a convenient location."
- (let* ((out (assoc-ref outputs "out")))
+ (let* ((out (library-output outputs)))
(for-each
(lambda (asd-file)
- (substitute* asd-file
- ((";;; Built for.*") "") ; remove potential non-determinism
- (("^\\(DEFSYSTEM(.*)$" all end) (string-append "(asdf:defsystem" end)))
(receive (new-asd-file asd-file-directory)
- (bundle-asd-file out asd-file lisp)
+ (bundle-asd-file out asd-file)
(mkdir-p asd-file-directory)
(symlink asd-file new-asd-file)
;; Update the source registry for future phases which might want to
@@ -201,15 +179,14 @@ implementation itself provides."
(prepend-to-source-registry
(string-append asd-file-directory "/"))))
- (find-files (string-append out %object-prefix) "\\.asd$"))
-)
+ (find-files (string-append out %object-prefix) "\\.asd$")))
#t)
-(define* (cleanup-files #:key outputs lisp
- #:allow-other-keys)
+(define* (cleanup-files #:key outputs
+ #:allow-other-keys)
"Remove any compiled files which are not a part of the final bundle."
- (let ((out (assoc-ref outputs "out")))
- (match lisp
+ (let ((out (library-output outputs)))
+ (match (%lisp-type)
("sbcl"
(for-each
(lambda (file)
@@ -219,10 +196,9 @@ implementation itself provides."
("ecl"
(for-each delete-file
(append (find-files out "\\.fas$")
- (find-files out "\\.o$")
- (find-files out "\\.a$")))))
+ (find-files out "\\.o$")))))
- (with-directory-excursion (library-directory out lisp)
+ (with-directory-excursion (library-directory out)
(for-each
(lambda (file)
(rename-file file
@@ -237,9 +213,9 @@ implementation itself provides."
(string<> ".." file)))))))
#t)
-(define* (strip #:key lisp #:allow-other-keys #:rest args)
+(define* (strip #:rest args)
;; stripping sbcl binaries removes their entry program and extra systems
- (or (string=? lisp "sbcl")
+ (or (string=? (%lisp-type) "sbcl")
(apply (assoc-ref gnu:%standard-phases 'strip) args)))
(define %standard-phases/source
@@ -257,8 +233,8 @@ implementation itself provides."
(add-before 'build 'copy-source copy-source)
(replace 'check check)
(replace 'strip strip)
- (add-after 'check 'link-dependencies patch-asd-files)
- (add-after 'link-dependencies 'cleanup cleanup-files)
+ (add-after 'check 'create-asd-file create-asd-file)
+ (add-after 'create-asd-file 'cleanup cleanup-files)
(add-after 'cleanup 'create-symlinks symlink-asd-files)))
(define* (asdf-build #:key inputs
diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm
index e948cd03d3..247a687d80 100644
--- a/guix/build/bournish.scm
+++ b/guix/build/bournish.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
@@ -48,11 +48,19 @@ refers to."
str))
(define* (display-tabulated lst
- #:key (columns 3)
- (column-width (/ 78 columns)))
- "Display the list of string LST in COLUMNS columns of COLUMN-WIDTH
-characters."
+ #:key
+ (terminal-width 80)
+ (column-gap 2))
+ "Display the list of string LST in as many columns as needed given
+TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns."
(define len (length lst))
+ (define column-width
+ ;; The width of a column. Assume all the columns have the same width
+ ;; (GNU ls is smarter than that.)
+ (+ column-gap (reduce max 0 (map string-length lst))))
+ (define columns
+ (max 1
+ (quotient terminal-width column-width)))
(define pad
(if (zero? (modulo len columns))
0
@@ -81,16 +89,30 @@ characters."
(()
(display-tabulated (scandir ".")))
(files
- (let ((files (filter (lambda (file)
- (catch 'system-error
- (lambda ()
- (lstat file))
- (lambda args
- (let ((errno (system-error-errno args)))
- (format (current-error-port) "~a: ~a~%"
- file (strerror errno))
- #f))))
- files)))
+ (let ((files (append-map (lambda (file)
+ (catch 'system-error
+ (lambda ()
+ (match (stat:type (lstat file))
+ ('directory
+ ;; Like GNU ls, list the contents of
+ ;; FILE rather than FILE itself.
+ (match (scandir file
+ (match-lambda
+ ((or "." "..") #f)
+ (_ #t)))
+ (#f
+ (list file))
+ ((files ...)
+ (map (cut string-append file "/" <>)
+ files))))
+ (_
+ (list file))))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (format (current-error-port) "~a: ~a~%"
+ file (strerror errno))
+ '()))))
+ files)))
(display-tabulated files)))))
(define (ls-command . files)
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index f11d858749..139b40321f 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -116,12 +117,12 @@ directory = '" port)
(close-pipe port)
result)))
-;; Example dir-name: "/gnu/store/hwlr49riz3la33m6in2n898ly045ylld-rust-rand-0.3.15".
(define (generate-checksums dir-name src-name)
- "Given DIR-NAME, checksum all the files in it one by one and put the
- result into the file \".cargo-checksum.json\" in the same directory.
- Also includes the checksum of an extra file SRC-NAME as if it was
- part of the directory DIR-NAME with name \"package\"."
+ "Given DIR-NAME, a store directory, checksum all the files in it one
+by one and put the result into the file \".cargo-checksum.json\" in
+the same directory. Also includes the checksum of an extra file
+SRC-NAME as if it was part of the directory DIR-NAME with name
+\"package\"."
(let* ((file-names (find-files dir-name "."))
(dir-prefix-name (string-append dir-name "/"))
(dir-prefix-name-len (string-length dir-prefix-name))
diff --git a/guix/build/download.scm b/guix/build/download.scm
index e3d5244590..ce4708a873 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -140,6 +140,13 @@ Otherwise return STORE-PATH."
(string-drop base 32)))
store-path))
+(cond-expand
+ (guile-2.2
+ ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+ ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
+ (define time-monotonic time-tai))
+ (else #t))
+
(define* (progress-proc file size
#:optional (log-port (current-output-port))
#:key (abbreviation basename))
@@ -389,7 +396,21 @@ host name without trailing dot."
;;(set-log-level! 10)
;;(set-log-procedure! log)
- (handshake session)
+ (catch 'gnutls-error
+ (lambda ()
+ (handshake session))
+ (lambda (key err proc . rest)
+ (cond ((eq? err error/warning-alert-received)
+ ;; Like Wget, do no stop upon non-fatal alerts such as
+ ;; 'alert-description/unrecognized-name'.
+ (format (current-error-port)
+ "warning: TLS warning alert received: ~a~%"
+ (alert-description->string (alert-get session)))
+ (handshake session))
+ (else
+ ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't
+ ;; provide a binding for this.
+ (apply throw key err proc rest)))))
;; Verify the server's certificate if needed.
(when verify-certificate?
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 44e8b0d31e..50af4be363 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -47,10 +47,12 @@
(define (store-file->elisp-source-file file)
"Convert FILE, a store file name for an Emacs Lisp source file, into a file
name that has been stripped of the hash and version number."
- (let-values (((name version)
- (package-name->name+version
- (strip-store-file-name file))))
- (string-append name ".el")))
+ (let ((suffix ".el"))
+ (let-values (((name version)
+ (package-name->name+version
+ (basename
+ (strip-store-file-name file) suffix))))
+ (string-append name suffix))))
(define* (unpack #:key source #:allow-other-keys)
"Unpack SOURCE into the build directory. SOURCE may be a compressed
@@ -93,14 +95,30 @@ store in '.el' files."
(substitute-cmd))))
#t))
-(define* (install #:key outputs #:allow-other-keys)
+(define* (install #:key outputs
+ (include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$"))
+ (exclude '("^\\.dir-locals\\.el$" "-pkg\\.el$" "^[^/]*tests?\\.el$"))
+ #:allow-other-keys)
"Install the package contents."
+
+ (define source (getcwd))
+
+ (define (install-file? file stat)
+ (let ((stripped-file (string-trim (string-drop file (string-length source)) #\/)))
+ (and (any (cut string-match <> stripped-file) include)
+ (not (any (cut string-match <> stripped-file) exclude)))))
+
(let* ((out (assoc-ref outputs "out"))
(elpa-name-ver (store-directory->elpa-name-version out))
- (src-dir (getcwd))
- (tgt-dir (string-append out %install-suffix "/" elpa-name-ver)))
- (copy-recursively src-dir tgt-dir)
- #t))
+ (target-directory (string-append out %install-suffix "/" elpa-name-ver)))
+ (for-each
+ (lambda (file)
+ (let* ((stripped-file (string-drop file (string-length source)))
+ (target-file (string-append target-directory stripped-file)))
+ (format #t "`~a' -> `~a'~%" file target-file)
+ (install-file file (dirname target-file))))
+ (find-files source install-file?)))
+ #t)
(define* (move-doc #:key outputs #:allow-other-keys)
"Move info files from the ELPA package directory to the info directory."
diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm
new file mode 100644
index 0000000000..402d377bf8
--- /dev/null
+++ b/guix/build/java-utils.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix build java-utils)
+ #:use-module (guix build utils)
+ #:export (ant-build-javadoc
+ install-jars
+ install-javadoc))
+
+;; Copied from haskell-build-system.scm
+(define (package-name-version store-dir)
+ "Given a store directory STORE-DIR return 'name-version' of the package."
+ (let* ((base (basename store-dir)))
+ (string-drop base (+ 1 (string-index base #\-)))))
+
+(define* (ant-build-javadoc #:key (target "javadoc") (make-flags '())
+ #:allow-other-keys)
+ (zero? (apply system* `("ant" ,target ,@make-flags))))
+
+(define* (install-jars jar-directory)
+ "Install jar files from JAR-DIRECTORY to the default target directory. This
+is used in case the build.xml does not include an install target."
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let ((share (string-append (assoc-ref outputs "out")
+ "/share/java")))
+ (for-each (lambda (f) (install-file f share))
+ (find-files jar-directory "\\.jar$"))
+ #t)))
+
+(define* (install-javadoc apidoc-directory)
+ "Install the APIDOC-DIRECTORY to the target directory. This is used to
+install javadocs when this is not done by the install target."
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (docs (string-append (or (assoc-ref outputs "doc") out)
+ "/share/doc/" (package-name-version out) "/")))
+ (mkdir-p docs)
+ (copy-recursively apidoc-directory docs)
+ #t)))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 55a07c7207..21cb620d59 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,13 +18,15 @@
(define-module (guix build lisp-utils)
#:use-module (ice-9 format)
+ #:use-module (ice-9 hash-table)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (guix build utils)
#:export (%lisp
- %install-prefix
+ %lisp-type
+ %source-install-prefix
lisp-eval-program
compile-system
test-system
@@ -32,15 +34,16 @@
generate-executable-wrapper-system
generate-executable-entry-point
generate-executable-for-system
- patch-asd-file
- bundle-install-prefix
- lisp-dependencies
+ %bundle-install-prefix
bundle-asd-file
- remove-lisp-from-name
wrap-output-translations
prepend-to-source-registry
build-program
- build-image))
+ build-image
+ make-asd-file
+ valid-char-set
+ normalize-string
+ library-output))
;;; Commentary:
;;;
@@ -54,102 +57,164 @@
;; File name of the Lisp compiler.
(make-parameter "lisp"))
-(define %install-prefix "/share/common-lisp")
-
-(define (bundle-install-prefix lisp)
- (string-append %install-prefix "/" lisp "-bundle-systems"))
+(define %lisp-type
+ ;; String representing the class of implementation being used.
+ (make-parameter "lisp"))
-(define (remove-lisp-from-name name lisp)
- (string-drop name (1+ (string-length lisp))))
+;; The common parent for Lisp source files, as will as the symbolic
+;; link farm for system definition (.asd) files.
+(define %source-install-prefix "/share/common-lisp")
+
+(define (%bundle-install-prefix)
+ (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
+
+(define (library-output outputs)
+ "If a `lib' output exists, build things there. Otherwise use `out'."
+ (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))
+
+;; See nix/libstore/store-api.cc#checkStoreName.
+(define valid-char-set
+ (string->char-set
+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))
+
+(define (normalize-string str)
+ "Replace invalid characters in STR with a hyphen."
+ (string-join (string-tokenize str valid-char-set) "-"))
+
+(define (inputs->asd-file-map inputs)
+ "Produce a hash table of the form (system . asd-file), where system is the
+name of an ASD system, and asd-file is the full path to its definition."
+ (alist->hash-table
+ (filter-map
+ (match-lambda
+ ((_ . path)
+ (let ((prefix (string-append path (%bundle-install-prefix))))
+ (and (directory-exists? prefix)
+ (match (find-files prefix "\\.asd$")
+ ((asd-file)
+ (cons
+ (string-drop-right (basename asd-file) 4) ; drop ".asd"
+ asd-file))
+ (_ #f))))))
+ inputs)))
(define (wrap-output-translations translations)
`(:output-translations
,@translations
:inherit-configuration))
-(define (lisp-eval-program lisp program)
+(define (lisp-eval-program program)
"Evaluate PROGRAM with a given LISP implementation."
(unless (zero? (apply system*
- (lisp-invoke lisp (format #f "~S" program))))
- (error "lisp-eval-program failed!" lisp program)))
-
-(define (lisp-invoke lisp program)
+ (lisp-invocation program)))
+ (error "lisp-eval-program failed!" (%lisp) program)))
+
+(define (spread-statements program argument-name)
+ "Return a list with the statements from PROGRAM spread between
+ARGUMENT-NAME, a string representing the argument a lisp implementation uses
+to accept statements to be evaluated before starting."
+ (append-map (lambda (statement)
+ (list argument-name (format #f "~S" statement)))
+ program))
+
+(define (lisp-invocation program)
"Return a list of arguments for system* determining how to invoke LISP
with PROGRAM."
- (match lisp
- ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
- ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))
+ (match (%lisp-type)
+ ("sbcl" `(,(%lisp) "--non-interactive"
+ ,@(spread-statements program "--eval")))
+ ("ecl" `(,(%lisp)
+ ,@(spread-statements program "--eval")
+ "--eval" "(quit)"))
+ (_ (error "The LISP provided is not supported at this time."))))
(define (asdf-load-all systems)
(map (lambda (system)
- `(funcall
- (find-symbol
- (symbol-name :load-system)
- (symbol-name :asdf))
- ,system))
+ `(asdf:load-system ,system))
systems))
-(define (compile-system system lisp asd-file)
+(define (compile-system system asd-file)
"Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE
-first if SYSTEM is defined there."
- (lisp-eval-program lisp
- `(progn
- (require :asdf)
- (in-package :asdf)
- ,@(if asd-file
- `((load ,asd-file))
- '())
- (in-package :cl-user)
- (funcall (find-symbol
- (symbol-name :operate)
- (symbol-name :asdf))
- (find-symbol
- (symbol-name :compile-bundle-op)
- (symbol-name :asdf))
- ,system)
- (funcall (find-symbol
- (symbol-name :operate)
- (symbol-name :asdf))
- (find-symbol
- (symbol-name :deliver-asd-op)
- (symbol-name :asdf))
- ,system))))
-
-(define (test-system system lisp asd-file)
- "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first
-if SYSTEM is defined there."
- (lisp-eval-program lisp
- `(progn
- (require :asdf)
- (in-package :asdf)
- ,@(if asd-file
- `((load ,asd-file))
- '())
- (in-package :cl-user)
- (funcall (find-symbol
- (symbol-name :test-system)
- (symbol-name :asdf))
- ,system))))
+first."
+ (lisp-eval-program
+ `((require :asdf)
+ (let ((*package* (find-package :asdf)))
+ (load ,asd-file))
+ (asdf:operate 'asdf:compile-bundle-op ,system))))
+
+(define (system-dependencies system asd-file)
+ "Return the dependencies of SYSTEM, as reported by
+asdf:system-depends-on. First load the system's ASD-FILE."
+ (define deps-file ".deps.sexp")
+ (define program
+ `((require :asdf)
+ (let ((*package* (find-package :asdf)))
+ (load ,asd-file))
+ (with-open-file
+ (stream ,deps-file :direction :output)
+ (format stream
+ "~s~%"
+ (asdf:system-depends-on
+ (asdf:find-system ,system))))))
+
+ (dynamic-wind
+ (lambda _
+ (lisp-eval-program program))
+ (lambda _
+ (call-with-input-file deps-file read))
+ (lambda _
+ (when (file-exists? deps-file)
+ (delete-file deps-file)))))
+
+(define (compiled-system system)
+ (let ((system (basename system))) ; this is how asdf handles slashes
+ (match (%lisp-type)
+ ("sbcl" (string-append system "--system"))
+ (_ system))))
+
+(define* (generate-system-definition system
+ #:key version dependencies)
+ `(asdf:defsystem
+ ,(normalize-string system)
+ :class asdf/bundle:prebuilt-system
+ :version ,version
+ :depends-on ,dependencies
+ :components ((:compiled-file ,(compiled-system system)))
+ ,@(if (string=? "ecl" (%lisp-type))
+ `(:lib ,(string-append system ".a"))
+ '())))
+
+(define (test-system system asd-file test-asd-file)
+ "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first.
+Also load TEST-ASD-FILE if necessary."
+ (lisp-eval-program
+ `((require :asdf)
+ (let ((*package* (find-package :asdf)))
+ (load ,asd-file)
+ ,@(if test-asd-file
+ `((load ,test-asd-file))
+ ;; Try some likely files.
+ (map (lambda (file)
+ `(when (uiop:file-exists-p ,file)
+ (load ,file)))
+ (list
+ (string-append system "-tests.asd")
+ (string-append system "-test.asd")
+ "tests.asd"
+ "test.asd"))))
+ (asdf:test-system ,system))))
(define (string->lisp-keyword . strings)
"Return a lisp keyword for the concatenation of STRINGS."
(string->symbol (apply string-append ":" strings)))
-(define (generate-executable-for-system type system lisp)
- "Use LISP to generate an executable, whose TYPE can be \"image\" or
-\"program\". The latter will always be standalone. Depends on having created
-a \"SYSTEM-exec\" system which contains the entry program."
+(define (generate-executable-for-system type system)
+ "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
+'asdf:program-op. The latter will always be standalone. Depends on having
+created a \"SYSTEM-exec\" system which contains the entry program."
(lisp-eval-program
- lisp
- `(progn
- (require :asdf)
- (funcall (find-symbol
- (symbol-name :operate)
- (symbol-name :asdf))
- (find-symbol
- (symbol-name ,(string->lisp-keyword type "-op"))
- (symbol-name :asdf))
- ,(string-append system "-exec")))))
+ `((require :asdf)
+ (asdf:operate ',type ,(string-append system "-exec")))))
(define (generate-executable-wrapper-system system dependencies)
"Generates a system which can be used by asdf to produce an image or program
@@ -183,65 +248,59 @@ ENTRY-PROGRAM for SYSTEM within the current directory."
(declare (ignorable arguments))
,@entry-program))))))))
-(define (wrap-perform-method lisp registry dependencies file-name)
- "Creates a wrapper method which allows the system to locate its dependent
-systems from REGISTRY, an alist of the same form as %outputs, which contains
-lisp systems which the systems is dependent on. All DEPENDENCIES which the
-system depends on will the be loaded before this system."
- (let* ((system (string-drop-right (basename file-name) 4))
- (system-symbol (string->lisp-keyword system)))
-
- `(defmethod asdf:perform :before
- (op (c (eql (asdf:find-system ,system-symbol))))
- (asdf/source-registry:ensure-source-registry)
- ,@(map (match-lambda
- ((name . path)
- (let ((asd-file (string-append path
- (bundle-install-prefix lisp)
- "/" name ".asd")))
- `(setf
- (gethash ,name
- asdf/source-registry:*source-registry*)
- ,(string->symbol "#p")
- ,(bundle-asd-file path asd-file lisp)))))
- registry)
- ,@(map (lambda (system)
- `(asdf:load-system ,(string->lisp-keyword system)))
- dependencies))))
-
-(define (patch-asd-file asd-file registry lisp dependencies)
- "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD."
- (chmod asd-file #o644)
- (let ((port (open-file asd-file "a")))
- (dynamic-wind
- (lambda _ #t)
- (lambda _
- (display
- (replace-escaped-macros
- (format #f "~%~y~%"
- (wrap-perform-method lisp registry
- dependencies asd-file)))
- port))
- (lambda _ (close-port port))))
- (chmod asd-file #o444))
-
-(define (lisp-dependencies lisp inputs)
- "Determine which inputs are lisp system dependencies, by using the convention
-that a lisp system dependency will resemble \"system-LISP\"."
- (filter-map (match-lambda
- ((name . value)
- (and (string-prefix? lisp name)
- (string<> lisp name)
- `(,(remove-lisp-from-name name lisp)
- . ,value))))
- inputs))
-
-(define (bundle-asd-file output-path original-asd-file lisp)
+(define (generate-dependency-links registry system)
+ "Creates a program which populates asdf's source registry from REGISTRY, an
+alist of dependency names to corresponding asd files. This allows the system
+to locate its dependent systems."
+ `(progn
+ (asdf/source-registry:ensure-source-registry)
+ ,@(map (match-lambda
+ ((name . asd-file)
+ `(setf
+ (gethash ,name
+ asdf/source-registry:*source-registry*)
+ ,(string->symbol "#p")
+ ,asd-file)))
+ registry)))
+
+(define* (make-asd-file asd-file
+ #:key system version inputs
+ (system-asd-file #f))
+ "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
+system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
+ (define dependencies
+ (let ((deps
+ (system-dependencies system system-asd-file)))
+ (if (eq? 'NIL deps)
+ '()
+ (map normalize-string deps))))
+
+ (define lisp-input-map
+ (inputs->asd-file-map inputs))
+
+ (define registry
+ (filter-map hash-get-handle
+ (make-list (length dependencies)
+ lisp-input-map)
+ dependencies))
+
+ (call-with-output-file asd-file
+ (lambda (port)
+ (display
+ (replace-escaped-macros
+ (format #f "~y~%~y~%"
+ (generate-system-definition system
+ #:version version
+ #:dependencies dependencies)
+ (generate-dependency-links registry system)))
+ port))))
+
+(define (bundle-asd-file output-path original-asd-file)
"Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two
values: the asd file itself and the directory in which it resides."
(let ((bundle-asd-path (string-append output-path
- (bundle-install-prefix lisp))))
+ (%bundle-install-prefix))))
(values (string-append bundle-asd-path "/" (basename original-asd-file))
bundle-asd-path)))
@@ -256,19 +315,22 @@ which are not nested."
(setenv "CL_SOURCE_REGISTRY"
(string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
-(define* (build-program lisp program #:key inputs
+(define* (build-program program outputs #:key
+ (dependency-prefixes (list (library-output outputs)))
(dependencies (list (basename program)))
entry-program
#:allow-other-keys)
"Generate an executable program containing all DEPENDENCIES, and which will
execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it
will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
-has been bound to the command-line arguments which were passed."
- (generate-executable lisp program
- #:inputs inputs
+has been bound to the command-line arguments which were passed. Link in any
+asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
+retained."
+ (generate-executable program
#:dependencies dependencies
+ #:dependency-prefixes dependency-prefixes
#:entry-program entry-program
- #:type "program")
+ #:type 'asdf:program-op)
(let* ((name (basename program))
(bin-directory (dirname program)))
(with-directory-excursion bin-directory
@@ -276,16 +338,18 @@ has been bound to the command-line arguments which were passed."
name)))
#t)
-(define* (build-image lisp image #:key inputs
+(define* (build-image image outputs #:key
+ (dependency-prefixes (list (library-output outputs)))
(dependencies (list (basename image)))
#:allow-other-keys)
"Generate an image, possibly standalone, which contains all DEPENDENCIES,
-placing the result in IMAGE.image."
- (generate-executable lisp image
- #:inputs inputs
+placing the result in IMAGE.image. Link in any asd files from
+DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
+ (generate-executable image
#:dependencies dependencies
+ #:dependency-prefixes dependency-prefixes
#:entry-program '(nil)
- #:type "image")
+ #:type 'asdf:image-op)
(let* ((name (basename image))
(bin-directory (dirname image)))
(with-directory-excursion bin-directory
@@ -293,14 +357,16 @@ placing the result in IMAGE.image."
(string-append name ".image"))))
#t)
-(define* (generate-executable lisp out-file #:key inputs
+(define* (generate-executable out-file #:key
dependencies
+ dependency-prefixes
entry-program
type
#:allow-other-keys)
- "Generate an executable by using asdf's TYPE-op, containing whithin the
+ "Generate an executable by using asdf operation TYPE, containing whithin the
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
-executable."
+executable. Link in any asd files from DEPENDENCY-PREFIXES to ensure
+references to those libraries are retained."
(let* ((bin-directory (dirname out-file))
(name (basename out-file)))
(mkdir-p bin-directory)
@@ -319,9 +385,25 @@ executable."
`(((,bin-directory :**/ :*.*.*)
(,bin-directory :**/ :*.*.*)))))))
- (parameterize ((%lisp (string-append
- (assoc-ref inputs lisp) "/bin/" lisp)))
- (generate-executable-for-system type name lisp))
+ (generate-executable-for-system type name)
+
+ (let* ((after-store-prefix-index
+ (string-index out-file #\/
+ (1+ (string-length (%store-directory)))))
+ (output (string-take out-file after-store-prefix-index))
+ (hidden-asd-links (string-append output "/.asd-files")))
+
+ (mkdir-p hidden-asd-links)
+ (for-each
+ (lambda (path)
+ (for-each
+ (lambda (asd-file)
+ (symlink asd-file
+ (string-append hidden-asd-links
+ "/" (basename asd-file))))
+ (find-files (string-append path (%bundle-install-prefix))
+ "\\.asd$")))
+ dependency-prefixes))
(delete-file (string-append bin-directory "/" name "-exec.asd"))
(delete-file (string-append bin-directory "/" name "-exec.lisp"))))
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index 42eabfaf19..5c96fe9067 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -75,14 +75,14 @@ definitions for all the SEARCH-PATHS."
;; source ~/.guix-profile/etc/profile ~/.guix-profile
;;
;; However, when 'source' is used with no arguments, $1 refers to the
- ;; first positional parameter of the calling scripts, so we can rely on
- ;; it.
+ ;; first positional parameter of the calling script, so we cannot rely
+ ;; on it.
(display "\
# Source this file to define all the relevant environment variables in Bash
# for this profile. You may want to define the 'GUIX_PROFILE' environment
# variable to point to the \"visible\" name of the profile, like this:
#
-# GUIX_PROFILE=/path/to/profile
+# GUIX_PROFILE=/path/to/profile \\
# source /path/to/profile/etc/profile
#
# When GUIX_PROFILE is undefined, the various environment variables refer
diff --git a/guix/build/pull.scm b/guix/build/pull.scm
index 6034e93cbf..d2e0404b14 100644
--- a/guix/build/pull.scm
+++ b/guix/build/pull.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -18,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build pull)
+ #:use-module (guix modules)
#:use-module (guix build utils)
#:use-module (system base compile)
#:use-module (ice-9 ftw)
@@ -35,6 +36,56 @@
;;;
;;; Code:
+(define (depends-on-guile-ssh? file)
+ "Return true if FILE is a Scheme source file that depends, directly or
+indirectly, on Guile-SSH."
+ (find (match-lambda
+ (('ssh _ ...) #t)
+ (_ #f))
+ (source-module-closure file #:select? (const #t))))
+
+(define (all-scheme-files directory)
+ "Return a sorted list of Scheme files found in DIRECTORY."
+ ;; Load guix/ modules before gnu/ modules to get somewhat steadier
+ ;; progress reporting.
+ (sort (filter (cut string-suffix? ".scm" <>)
+ (find-files directory "\\.scm"))
+ (let ((guix (string-append directory "/guix"))
+ (gnu (string-append directory "/gnu")))
+ (lambda (a b)
+ (or (and (string-prefix? guix a)
+ (string-prefix? gnu b))
+ (string<? a b))))))
+
+(cond-expand
+ (guile-2.2 (use-modules (language tree-il optimize)
+ (language cps optimize)))
+ (else #f))
+
+(define %default-optimizations
+ ;; Default optimization options (equivalent to -O2 on Guile 2.2).
+ (cond-expand
+ (guile-2.2 (append (tree-il-default-optimization-options)
+ (cps-default-optimization-options)))
+ (else '())))
+
+(define %lightweight-optimizations
+ ;; Lightweight optimizations (like -O0, but with partial evaluation).
+ (let loop ((opts %default-optimizations)
+ (result '()))
+ (match opts
+ (() (reverse result))
+ ((#:partial-eval? _ rest ...)
+ (loop rest `(#t #:partial-eval? ,@result)))
+ ((kw _ rest ...)
+ (loop rest `(#f ,kw ,@result))))))
+
+(define (optimization-options file)
+ (if (string-contains file "gnu/packages/")
+ %lightweight-optimizations ;build faster
+ '()))
+
+
(define* (build-guix out source
#:key
system
@@ -55,7 +106,8 @@ containing the source code. Write any debugging output to DEBUG-PORT."
(setvbuf (current-error-port) _IOLBF)
(with-directory-excursion source
- (format #t "copying and compiling to '~a'...~%" out)
+ (format #t "copying and compiling to '~a' with Guile ~a...~%"
+ out (version))
;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm.
(copy-recursively "guix" (string-append out "/guix")
@@ -92,17 +144,12 @@ containing the source code. Write any debugging output to DEBUG-PORT."
;; Compile the .scm files. Load all the files before compiling them to
;; work around <http://bugs.gnu.org/15602> (FIXME).
- (let* ((files
- ;; Load guix/ modules before gnu/ modules to get somewhat steadier
- ;; progress reporting.
- (sort (filter (cut string-suffix? ".scm" <>)
- (find-files out "\\.scm"))
- (let ((guix (string-append out "/guix"))
- (gnu (string-append out "/gnu")))
- (lambda (a b)
- (or (and (string-prefix? guix a)
- (string-prefix? gnu b))
- (string<? a b))))))
+ ;; Filter out files depending on Guile-SSH when Guile-SSH is missing.
+ (let* ((files (remove (if (false-if-exception
+ (resolve-interface '(ssh session)))
+ (const #f)
+ depends-on-guile-ssh?)
+ (all-scheme-files out)))
(total (length files)))
(let loop ((files files)
(completed 0))
@@ -140,7 +187,7 @@ containing the source code. Write any debugging output to DEBUG-PORT."
(parameterize ((current-warning-port (%make-void-port "w")))
(compile-file file
#:output-file go
- #:opts %auto-compilation-options)))
+ #:opts (optimization-options file))))
(with-mutex mutex
(set! completed (+ 1 completed))))
files))))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 5aae1530f4..0529c228a5 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -44,8 +45,6 @@
MNT_EXPIRE
UMOUNT_NOFOLLOW
restart-on-EINTR
- mount
- umount
mount-points
swapon
swapoff
@@ -83,17 +82,11 @@
PF_PACKET
AF_PACKET
- IFF_UP
- IFF_BROADCAST
- IFF_LOOPBACK
all-network-interface-names
network-interface-names
- network-interface-flags
network-interface-netmask
loopback-network-interface?
network-interface-address
- set-network-interface-flags
- set-network-interface-address
set-network-interface-netmask
set-network-interface-up
configure-network-interface
@@ -149,8 +142,19 @@
;;; Commentary:
;;;
;;; This module provides bindings to libc's syscall wrappers. It uses the
-;;; FFI, and thus requires a dynamically-linked Guile. (For statically-linked
-;;; Guile, we instead apply 'guile-linux-syscalls.patch'.)
+;;; FFI, and thus requires a dynamically-linked Guile.
+;;;
+;;; Some syscalls are already defined in statically-linked Guile by applying
+;;; 'guile-linux-syscalls.patch'.
+;;;
+;;; Visibility of syscall's symbols shared between this module and static Guile
+;;; is a bit delicate. It is handled by 'define-as-needed' macro.
+;;;
+;;; This macro is used to export symbols in dynamic Guile context, and to
+;;; re-export them in static Guile context.
+;;;
+;;; This way, even if they don't appear in #:export list, it is safe to use
+;;; syscalls from this module in static or dynamic Guile context.
;;;
;;; Code:
@@ -409,6 +413,25 @@ the returned procedure is called."
(error (format #f "~a: syscall->procedure failed: ~s"
name args))))))
+(define-syntax define-as-needed
+ (syntax-rules ()
+ "Define VARIABLE. If VARIABLE already exists in (guile) then re-export it,
+ otherwise export the newly-defined VARIABLE."
+ ((_ (proc args ...) body ...)
+ (define-as-needed proc (lambda* (args ...) body ...)))
+ ((_ variable value)
+ (begin
+ (when (module-defined? the-scm-module 'variable)
+ (re-export variable))
+
+ (define variable
+ (if (module-defined? the-scm-module 'variable)
+ (module-ref the-scm-module 'variable)
+ value))
+
+ (unless (module-defined? the-scm-module 'variable)
+ (export variable))))))
+
;;;
;;; File systems.
@@ -461,48 +484,50 @@ the returned procedure is called."
(define MNT_EXPIRE 4)
(define UMOUNT_NOFOLLOW 8)
-(define mount
+(define-as-needed (mount source target type
+ #:optional (flags 0) options
+ #:key (update-mtab? #f))
+ "Mount device SOURCE on TARGET as a file system TYPE.
+Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h>
+constants, and OPTIONS may be a string. When FLAGS contains
+MS_REMOUNT, SOURCE and TYPE are ignored. When UPDATE-MTAB? is true,
+update /etc/mtab. Raise a 'system-error' exception on error."
+ ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
(let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
- (lambda* (source target type #:optional (flags 0) options
- #:key (update-mtab? #f))
- "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS
-may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a
-string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored. When
-UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on
-error."
- (let-values (((ret err)
- (proc (if source
- (string->pointer source)
- %null-pointer)
- (string->pointer target)
- (if type
- (string->pointer type)
- %null-pointer)
- flags
- (if options
- (string->pointer options)
- %null-pointer))))
- (unless (zero? ret)
- (throw 'system-error "mount" "mount ~S on ~S: ~A"
- (list source target (strerror err))
- (list err)))
- (when update-mtab?
- (augment-mtab source target type options))))))
-
-(define umount
- (let ((proc (syscall->procedure int "umount2" `(* ,int))))
- (lambda* (target #:optional (flags 0)
- #:key (update-mtab? #f))
- "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
+ (let-values (((ret err)
+ (proc (if source
+ (string->pointer source)
+ %null-pointer)
+ (string->pointer target)
+ (if type
+ (string->pointer type)
+ %null-pointer)
+ flags
+ (if options
+ (string->pointer options)
+ %null-pointer))))
+ (unless (zero? ret)
+ (throw 'system-error "mount" "mount ~S on ~S: ~A"
+ (list source target (strerror err))
+ (list err)))
+ (when update-mtab?
+ (augment-mtab source target type options)))))
+
+(define-as-needed (umount target
+ #:optional (flags 0)
+ #:key (update-mtab? #f))
+ "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
constants from <sys/mount.h>."
- (let-values (((ret err)
- (proc (string->pointer target) flags)))
- (unless (zero? ret)
- (throw 'system-error "umount" "~S: ~A"
- (list target (strerror err))
- (list err)))
- (when update-mtab?
- (remove-from-mtab target))))))
+ ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
+ (let ((proc (syscall->procedure int "umount2" `(* ,int))))
+ (let-values (((ret err)
+ (proc (string->pointer target) flags)))
+ (unless (zero? ret)
+ (throw 'system-error "umount" "~S: ~A"
+ (list target (strerror err))
+ (list err)))
+ (when update-mtab?
+ (remove-from-mtab target)))))
(define (mount-points)
"Return the mounts points for currently mounted file systems."
@@ -537,6 +562,34 @@ constants from <sys/mount.h>."
(list device (strerror err))
(list err)))))))
+(define-as-needed RB_AUTOBOOT #x01234567)
+(define-as-needed RB_HALT_SYSTEM #xcdef0123)
+(define-as-needed RB_ENABLED_CAD #x89abcdef)
+(define-as-needed RB_DISABLE_CAD 0)
+(define-as-needed RB_POWER_OFF #x4321fedc)
+(define-as-needed RB_SW_SUSPEND #xd000fce2)
+(define-as-needed RB_KEXEC #x45584543)
+
+(define-as-needed (reboot #:optional (cmd RB_AUTOBOOT))
+ (let ((proc (syscall->procedure int "reboot" (list int))))
+ (let-values (((ret err) (proc cmd)))
+ (unless (zero? ret)
+ (throw 'system-error "reboot" "~S: ~A"
+ (list cmd (strerror err))
+ (list err))))))
+
+(define-as-needed (load-linux-module data #:optional (options ""))
+ (let ((proc (syscall->procedure int "init_module"
+ (list '* unsigned-long '*))))
+ (let-values (((ret err)
+ (proc (bytevector->pointer data)
+ (bytevector-length data)
+ (string->pointer options))))
+ (unless (zero? ret)
+ (throw 'system-error "load-linux-module" "~A"
+ (list (strerror err))
+ (list err))))))
+
(define (kernel? pid)
"Return #t if PID designates a \"kernel thread\" rather than a normal
user-land process."
@@ -873,9 +926,9 @@ exception if it's already taken."
;; Flags and constants from <net/if.h>.
-(define IFF_UP #x1) ;Interface is up
-(define IFF_BROADCAST #x2) ;Broadcast address valid.
-(define IFF_LOOPBACK #x8) ;Is a loopback net.
+(define-as-needed IFF_UP #x1) ;Interface is up
+(define-as-needed IFF_BROADCAST #x2) ;Broadcast address valid.
+(define-as-needed IFF_LOOPBACK #x8) ;Is a loopback net.
(define IF_NAMESIZE 16) ;maximum interface name size
@@ -1022,7 +1075,7 @@ that are not up."
(else
(loop interfaces))))))))
-(define (network-interface-flags socket name)
+(define-as-needed (network-interface-flags socket name)
"Return a number that is the bit-wise or of 'IFF*' flags for network
interface NAME."
(let ((req (make-bytevector ifreq-struct-size)))
@@ -1033,8 +1086,8 @@ interface NAME."
(bytevector->pointer req))))
(if (zero? ret)
- ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of
- ;; 'struct ifreq', and it's a short int.
+ ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the
+ ;; beginning of 'struct ifreq', and it's a short int.
(bytevector-sint-ref req IF_NAMESIZE (native-endianness)
(sizeof short))
@@ -1050,7 +1103,7 @@ interface NAME."
(close-port sock)
(not (zero? (logand flags IFF_LOOPBACK)))))
-(define (set-network-interface-flags socket name flags)
+(define-as-needed (set-network-interface-flags socket name flags)
"Set the flag of network interface NAME to FLAGS."
(let ((req (make-bytevector ifreq-struct-size)))
(bytevector-copy! (string->utf8 name) 0 req 0
@@ -1067,7 +1120,7 @@ interface NAME."
(list name (strerror err))
(list err))))))
-(define (set-network-interface-address socket name sockaddr)
+(define-as-needed (set-network-interface-address socket name sockaddr)
"Set the address of network interface NAME to SOCKADDR."
(let ((req (make-bytevector ifreq-struct-size)))
(bytevector-copy! (string->utf8 name) 0 req 0
diff --git a/guix/build/union.scm b/guix/build/union.scm
index a2ea72e1f5..18167fa3e3 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -47,31 +47,34 @@
(loop (cons file files)))))))
(define (file-is-directory? file)
- (eq? 'directory (stat:type (stat file))))
+ (match (stat file #f)
+ (#f #f) ;maybe a dangling symlink
+ (st (eq? 'directory (stat:type st)))))
(define (file=? file1 file2)
"Return #t if FILE1 and FILE2 are regular files and their contents are
identical, #f otherwise."
- (let ((st1 (stat file1))
- (st2 (stat file2)))
+ (let ((st1 (stat file1 #f))
+ (st2 (stat file2 #f)))
;; When deduplication is enabled, identical files share the same inode.
- (or (= (stat:ino st1) (stat:ino st2))
- (and (eq? (stat:type st1) 'regular)
- (eq? (stat:type st2) 'regular)
- (= (stat:size st1) (stat:size st2))
- (call-with-input-file file1
- (lambda (port1)
- (call-with-input-file file2
- (lambda (port2)
- (define len 8192)
- (define buf1 (make-bytevector len))
- (define buf2 (make-bytevector len))
- (let loop ()
- (let ((n1 (get-bytevector-n! port1 buf1 0 len))
- (n2 (get-bytevector-n! port2 buf2 0 len)))
- (and (equal? n1 n2)
- (or (eof-object? n1)
- (loop)))))))))))))
+ (and st1 st2
+ (or (= (stat:ino st1) (stat:ino st2))
+ (and (eq? (stat:type st1) 'regular)
+ (eq? (stat:type st2) 'regular)
+ (= (stat:size st1) (stat:size st2))
+ (call-with-input-file file1
+ (lambda (port1)
+ (call-with-input-file file2
+ (lambda (port2)
+ (define len 8192)
+ (define buf1 (make-bytevector len))
+ (define buf2 (make-bytevector len))
+ (let loop ()
+ (let ((n1 (get-bytevector-n! port1 buf1 0 len))
+ (n2 (get-bytevector-n! port2 buf2 0 len)))
+ (and (equal? n1 n2)
+ (or (eof-object? n1)
+ (loop))))))))))))))
(define* (union-build output inputs
#:key (log-port (current-error-port))
generated by cgit v1.2.3 (git 2.47.1) at 2025-01-27 00:26:50 +0000