summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-02-26 22:37:12 +0100
committerLudovic Courtès <ludo@gnu.org>2015-02-26 22:37:12 +0100
commit93be4e8e6c6b82a5825b56cce991563bf19aaaf2 (patch)
tree2b48c1c88f046ee6e1d59636d1f6e8fbbd1660c2 /guix/build
parenta068dba78bde9c83a69c755df1131c286d065850 (diff)
parente1509174957bd9eba777bec86ea290fb44a4bce3 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/download.scm84
-rw-r--r--guix/build/perl-build-system.scm59
2 files changed, 130 insertions, 13 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 5928ccd154..e8d61e0d92 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +30,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (open-connection-for-uri
+ resolve-uri-reference
maybe-expand-mirrors
url-fetch
progress-proc
@@ -204,6 +206,86 @@ which is not available during bootstrap."
(module-define! (resolve-module '(web client))
'shutdown (const #f))
+;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile
+;; up to 2.0.11.
+(unless (or (> (string->number (major-version)) 2)
+ (> (string->number (minor-version)) 0)
+ (> (string->number (micro-version)) 11))
+ (let ((var (module-variable (resolve-module '(web http))
+ 'declare-relative-uri-header!)))
+ ;; If 'declare-relative-uri-header!' doesn't exist, forget it.
+ (when (and var (variable-bound? var))
+ (let ((declare-relative-uri-header! (variable-ref var)))
+ (declare-relative-uri-header! "Location")))))
+
+(define (resolve-uri-reference ref base)
+ "Resolve the URI reference REF, interpreted relative to the BASE URI, into a
+target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
+Return the resulting target URI."
+
+ (define (merge-paths base-path rel-path)
+ (let* ((base-components (string-split base-path #\/))
+ (base-directory-components (match base-components
+ ((components ... last) components)
+ (() '())))
+ (base-directory (string-join base-directory-components "/")))
+ (string-append base-directory "/" rel-path)))
+
+ (define (remove-dot-segments path)
+ (let loop ((in
+ ;; Drop leading "." and ".." components from a relative path.
+ ;; (absolute paths will start with a "" component)
+ (drop-while (match-lambda
+ ((or "." "..") #t)
+ (_ #f))
+ (string-split path #\/)))
+ (out '()))
+ (match in
+ (("." . rest)
+ (loop rest out))
+ ((".." . rest)
+ (match out
+ ((or () (""))
+ (error "remove-dot-segments: too many '..' components" path))
+ (_
+ (loop rest (cdr out)))))
+ ((component . rest)
+ (loop rest (cons component out)))
+ (()
+ (string-join (reverse out) "/")))))
+
+ (cond ((or (uri-scheme ref)
+ (uri-host ref))
+ (build-uri (or (uri-scheme ref)
+ (uri-scheme base))
+ #:userinfo (uri-userinfo ref)
+ #:host (uri-host ref)
+ #:port (uri-port ref)
+ #:path (remove-dot-segments (uri-path ref))
+ #:query (uri-query ref)
+ #:fragment (uri-fragment ref)))
+ ((string-null? (uri-path ref))
+ (build-uri (uri-scheme base)
+ #:userinfo (uri-userinfo base)
+ #:host (uri-host base)
+ #:port (uri-port base)
+ #:path (remove-dot-segments (uri-path base))
+ #:query (or (uri-query ref)
+ (uri-query base))
+ #:fragment (uri-fragment ref)))
+ (else
+ (build-uri (uri-scheme base)
+ #:userinfo (uri-userinfo base)
+ #:host (uri-host base)
+ #:port (uri-port base)
+ #:path (remove-dot-segments
+ (if (string-prefix? "/" (uri-path ref))
+ (uri-path ref)
+ (merge-paths (uri-path base)
+ (uri-path ref))))
+ #:query (uri-query ref)
+ #:fragment (uri-fragment ref)))))
+
(define (http-fetch uri file)
"Fetch data from URI and write it to FILE. Return FILE on success."
@@ -260,7 +342,7 @@ which is not available during bootstrap."
file))
((301 ; moved permanently
302) ; found (redirection)
- (let ((uri (response-location resp)))
+ (let ((uri (resolve-uri-reference (response-location resp) uri)))
(format #t "following redirection to `~a'...~%"
(uri->string uri))
(close connection)
diff --git a/guix/build/perl-build-system.scm b/guix/build/perl-build-system.scm
index 904daf7ac2..7eb944ccd1 100644
--- a/guix/build/perl-build-system.scm
+++ b/guix/build/perl-build-system.scm
@@ -29,22 +29,57 @@
;;
;; Code:
-(define* (configure #:key outputs (make-maker-flags '())
+(define* (configure #:key outputs make-maker?
+ (make-maker-flags '()) (module-build-flags '())
#:allow-other-keys)
"Configure the given Perl package."
- (let ((out (assoc-ref outputs "out")))
- (if (file-exists? "Makefile.PL")
- (let ((args `("Makefile.PL" ,(string-append "PREFIX=" out)
- "INSTALLDIRS=site" ,@make-maker-flags)))
- (format #t "running `perl' with arguments ~s~%" args)
- (zero? (apply system* "perl" args)))
- (error "no Makefile.PL found"))))
+ (let* ((out (assoc-ref outputs "out"))
+ (args (cond
+ ;; Prefer to use Module::Build unless otherwise told
+ ((and (file-exists? "Build.PL")
+ (not make-maker?))
+ `("Build.PL" ,(string-append "--prefix=" out)
+ "--installdirs=site" ,@module-build-flags))
+ ((file-exists? "Makefile.PL")
+ `("Makefile.PL" ,(string-append "PREFIX=" out)
+ "INSTALLDIRS=site" ,@make-maker-flags))
+ (else (error "no Build.PL or Makefile.PL found")))))
+ (format #t "running `perl' with arguments ~s~%" args)
+ (zero? (apply system* "perl" args))))
+
+(define-syntax-rule (define-w/gnu-fallback* (name args ...) body ...)
+ (define* (name args ... #:rest rest)
+ (if (access? "Build" X_OK)
+ (begin body ...)
+ (apply (assoc-ref gnu:%standard-phases 'name) rest))))
+
+(define-w/gnu-fallback* (build)
+ (zero? (system* "./Build")))
+
+(define-w/gnu-fallback* (check #:key target
+ (tests? (not target)) (test-flags '())
+ #:allow-other-keys)
+ (if tests?
+ (zero? (apply system* "./Build" "test" test-flags))
+ (begin
+ (format #t "test suite not run~%")
+ #t)))
+
+(define-w/gnu-fallback* (install)
+ (zero? (system* "./Build" "install")))
(define %standard-phases
- ;; Everything is as with the GNU Build System except for the `configure'
- ;; phase.
- (alist-replace 'configure configure
- gnu:%standard-phases))
+ ;; Everything is as with the GNU Build System except for the `configure',
+ ;; `build', `check', and `install' phases.
+ (alist-replace
+ 'configure configure
+ (alist-replace
+ 'build build
+ (alist-replace
+ 'check check
+ (alist-replace
+ 'install install
+ gnu:%standard-phases)))))
(define* (perl-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)