From babeea3f9f46c1f1f812e590f46283e91684f327 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 31 May 2018 09:16:01 +0200 Subject: build-system/r: Use invoke. * guix/build/r-build-system.scm (invoke-r): Use invoke. (pipe-to-r): Raise invoke-error on non-zero return value. (check): Unconditionally return #t. --- guix/build/r-build-system.scm | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) (limited to 'guix/build/r-build-system.scm') diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 5e18939d22..4d8ac5b479 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ (define-module (guix build r-build-system) #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:export (%standard-phases r-build)) @@ -34,12 +35,19 @@ (define-module (guix build r-build-system) ;; Code: (define (invoke-r command params) - (zero? (apply system* "R" "CMD" command params))) + (apply invoke "R" "CMD" command params)) (define (pipe-to-r command params) (let ((port (apply open-pipe* OPEN_WRITE "R" params))) (display command port) - (zero? (status:exit-val (close-pipe port))))) + (let ((code (status:exit-val (close-pipe port)))) + (unless (zero? code) + (raise (condition ((@@ (guix build utils) &invoke-error) + (program "R") + (arguments (string-append params " " command)) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code))))))))) (define (generate-site-path inputs) (string-join (map (match-lambda @@ -68,13 +76,12 @@ (define* (check #:key test-target inputs outputs tests? #:allow-other-keys) (pkg-name (car (scandir libdir (negate (cut member <> '("." "..")))))) (testdir (string-append libdir pkg-name "/" test-target)) (site-path (string-append libdir ":" (generate-site-path inputs)))) - (if (and tests? (file-exists? testdir)) - (begin - (setenv "R_LIBS_SITE" site-path) - (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " - "lib.loc = \"" libdir "\")") - '("--no-save" "--slave"))) - #t))) + (when (and tests? (file-exists? testdir)) + (setenv "R_LIBS_SITE" site-path) + (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " + "lib.loc = \"" libdir "\")") + '("--no-save" "--slave"))) + #t)) (define* (install #:key outputs inputs (configure-flags '()) #:allow-other-keys) -- cgit v1.2.3