Merge branch 'master' into core-updates

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)