From 2d2a53fc24a3feb723772dfc45bb438256de41f9 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Thu, 22 Jan 2015 23:18:57 -0600 Subject: build-system/perl: Use Build.PL for builds if present. * guix/build/perl-build-system.scm (configure): Use Build.PL if present. (build, check, install): New procedures. (%standard-phases): Replace build, check, and install phases. * guix/build-system/perl (perl-build): Add make-maker? and module-build-flags arguments. * doc/guix.texi (Build Systems)[perl-build-system]: Document behavior rsp. Build.PL and new arguments. --- guix/build/perl-build-system.scm | 59 ++++++++++++++++++++++++++++++++-------- 1 file changed, 47 insertions(+), 12 deletions(-) (limited to 'guix/build') 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) -- cgit v1.2.3 From 04dec194d8e460831ec0695a944d9c7313affea2 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 18 Feb 2015 19:33:10 -0500 Subject: download: Handle HTTP redirects to relative URI references. Fixes . Reported by Ricardo Wurmus . * guix/build/download.scm: On Guile 2.0.11 or earlier, redefine the http "Location" header to accept relative URIs. (resolve-uri-reference): New exported procedure. (http-fetch): Use 'resolve-uri-reference' to resolve redirections. * guix/http-client.scm (http-fetch): Use 'resolve-uri-reference' --- guix/build/download.scm | 82 ++++++++++++++++++++++++++++++++++++++++++++++++- guix/http-client.scm | 4 ++- 2 files changed, 84 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 5928ccd154..16afb1dce1 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 +;;; Copyright © 2015 Mark H Weaver ;;; ;;; 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,84 @@ which is not available during bootstrap." (module-define! (resolve-module '(web client)) 'shutdown (const #f)) +;; XXX: Work around , 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 ((declare-relative-uri-header! + (module-ref (resolve-module '(web http)) + 'declare-relative-uri-header!))) + (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 +340,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/http-client.scm b/guix/http-client.scm index 4770628e45..aad7656e19 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2012 Free Software Foundation, Inc. ;;; ;;; This file is part of GNU Guix. @@ -29,6 +30,7 @@ #:use-module (rnrs bytevectors) #:use-module (guix ui) #:use-module (guix utils) + #:use-module ((guix build download) #:select (resolve-uri-reference)) #:export (&http-get-error http-get-error? http-get-error-uri @@ -227,7 +229,7 @@ Raise an '&http-get-error' condition if downloading fails." (values data len))))) ((301 ; moved permanently 302) ; found (redirection) - (let ((uri (response-location resp))) + (let ((uri (resolve-uri-reference (response-location resp) uri))) (close-port port) (format #t (_ "following redirection to `~a'...~%") (uri->string uri)) -- cgit v1.2.3 From c964a15d8239d28144be51868868aa21d5d4ddce Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 24 Feb 2015 19:58:13 -0500 Subject: download: Cope with Guile 2.0.6 or earlier. * guix/build/download.scm: Do not attempt to support relative URIs in "Location" headers if 'declare-relative-uri-header!' is not present. This is the case for Guile 2.0.6 or earlier. --- guix/build/download.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 16afb1dce1..e8d61e0d92 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -211,10 +211,12 @@ which is not available during bootstrap." (unless (or (> (string->number (major-version)) 2) (> (string->number (minor-version)) 0) (> (string->number (micro-version)) 11)) - (let ((declare-relative-uri-header! - (module-ref (resolve-module '(web http)) - 'declare-relative-uri-header!))) - (declare-relative-uri-header! "Location"))) + (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 -- cgit v1.2.3