aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--guix/import/cpan.scm151
-rw-r--r--tests/cpan.scm33
2 files changed, 116 insertions, 68 deletions
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index ec86f11743..4320f94c98 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,19 +28,39 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (json)
+ #:use-module (guix json)
#:use-module (gcrypt hash)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix base32)
#:use-module (guix ui)
#:use-module ((guix download) #:select (download-to-store url-fetch))
- #:use-module ((guix import utils) #:select (factorize-uri
- flatten assoc-ref*))
+ #:use-module ((guix import utils) #:select (factorize-uri))
#:use-module (guix import json)
#:use-module (guix packages)
#:use-module (guix upstream)
#:use-module (guix derivations)
- #:export (cpan->guix-package
+ #:export (cpan-dependency?
+ cpan-dependency-relationship
+ cpan-dependency-phase
+ cpan-dependency-module
+ cpan-dependency-version
+
+ cpan-release?
+ cpan-release-license
+ cpan-release-author
+ cpan-release-version
+ cpan-release-modle
+ cpan-release-distribution
+ cpan-release-download-url
+ cpan-release-abstract
+ cpan-release-home-page
+ cpan-release-dependencies
+ json->cpan-release
+
+ cpan-fetch
+ cpan->guix-package
+ metacpan-url->mirror-url
%cpan-updater))
;;; Commentary:
@@ -49,6 +70,45 @@
;;;
;;; Code:
+;; Dependency of a "release".
+(define-json-mapping <cpan-dependency> make-cpan-dependency cpan-dependency?
+ json->cpan-dependency
+ (relationship cpan-dependency-relationship "relationship"
+ string->symbol) ;requires | suggests
+ (phase cpan-dependency-phase "phase"
+ string->symbol) ;develop | configure | test | runtime
+ (module cpan-dependency-module) ;string
+ (version cpan-dependency-version)) ;string
+
+;; Release as returned by <https://fastapi.metacpan.org/v1/release/PKG>.
+(define-json-mapping <cpan-release> make-cpan-release cpan-release?
+ json->cpan-release
+ (license cpan-release-license)
+ (author cpan-release-author)
+ (version cpan-release-version "version"
+ (match-lambda
+ ((? number? version)
+ ;; Version is sometimes not quoted in the module json, so
+ ;; it gets imported into Guile as a number, so convert it
+ ;; to a string (example: "X11-Protocol-Other").
+ (number->string version))
+ ((? string? version)
+ ;; Sometimes we get a "v" prefix. Strip it.
+ (if (string-prefix? "v" version)
+ (string-drop version 1)
+ version))))
+ (module cpan-release-module "main_module") ;e.g., "Test::Script"
+ (distribution cpan-release-distribution) ;e.g., "Test-Script"
+ (download-url cpan-release-download-url "download_url")
+ (abstract cpan-release-abstract "abstract")
+ (home-page cpan-release-home-page "resources"
+ (match-lambda
+ (#f #f)
+ ((lst ...) (assoc-ref lst "homepage"))))
+ (dependencies cpan-release-dependencies "dependency"
+ (lambda (vector)
+ (map json->cpan-dependency (vector->list vector)))))
+
(define string->license
(match-lambda
;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
@@ -111,32 +171,25 @@ return \"Test-Simple\""
(_ #f)))))
(define (cpan-fetch name)
- "Return an alist representation of the CPAN metadata for the perl module MODULE,
-or #f on failure. MODULE should be e.g. \"Test::Script\""
+ "Return a <cpan-release> record for Perl module MODULE,
+or #f on failure. MODULE should be the distribution name, such as
+\"Test-Script\" for the \"Test::Script\" module."
;; This API always returns the latest release of the module.
- (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name)))
+ (json->cpan-release
+ (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/"
+ name))))
(define (cpan-home name)
(string-append "https://metacpan.org/release/" name))
-(define (cpan-source-url meta)
- "Return the download URL for a module's source tarball."
+(define (metacpan-url->mirror-url url)
+ "Replace 'https://cpan.metacpan.org' in URL with 'mirror://cpan'."
(regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
- (assoc-ref meta "download_url")
+ url
'pre "mirror://cpan" 'post))
-(define (cpan-version meta)
- "Return the version number from META."
- (match (assoc-ref meta "version")
- ((? number? version)
- ;; version is sometimes not quoted in the module json, so it gets
- ;; imported into Guile as a number, so convert it to a string.
- (number->string version))
- (version
- ;; Sometimes we get a "v" prefix. Strip it.
- (if (string-prefix? "v" version)
- (string-drop version 1)
- version))))
+(define cpan-source-url
+ (compose metacpan-url->mirror-url cpan-release-download-url))
(define (perl-package)
"Return the 'perl' package. This is a lazy reference so that we don't
@@ -179,42 +232,38 @@ depend on (gnu packages perl)."
first perl-version last))))
(loop)))))))))))
-(define (cpan-module->sexp meta)
- "Return the `package' s-expression for a CPAN module from the metadata in
-META."
+(define (cpan-module->sexp release)
+ "Return the 'package' s-expression for a CPAN module from the release data
+in RELEASE, a <cpan-release> record."
(define name
- (assoc-ref meta "distribution"))
+ (cpan-release-distribution release))
(define (guix-name name)
(if (string-prefix? "perl-" name)
(string-downcase name)
(string-append "perl-" (string-downcase name))))
- (define version (cpan-version meta))
- (define source-url (cpan-source-url meta))
+ (define version (cpan-release-version release))
+ (define source-url (cpan-source-url release))
(define (convert-inputs phases)
;; Convert phase dependencies into a list of name/variable pairs.
- (match (flatten
- (map (lambda (ph)
- (filter-map (lambda (t)
- (assoc-ref* meta "metadata" "prereqs" ph t))
- '("requires" "recommends" "suggests")))
- phases))
- (#f
- '())
+ (match (filter-map (lambda (dependency)
+ (and (memq (cpan-dependency-phase dependency)
+ phases)
+ (cpan-dependency-module dependency)))
+ (cpan-release-dependencies release))
((inputs ...)
(sort
(delete-duplicates
;; Listed dependencies may include core modules. Filter those out.
(filter-map (match-lambda
- (("perl" . _) ;implicit dependency
- #f)
- ((module . _)
- (and (not (core-module? module))
- (let ((name (guix-name (module->dist-name module))))
- (list name
- (list 'unquote (string->symbol name)))))))
+ ("perl" #f) ;implicit dependency
+ ((? core-module?) #f)
+ (module
+ (let ((name (guix-name (module->dist-name module))))
+ (list name
+ (list 'unquote (string->symbol name))))))
inputs))
(lambda args
(match args
@@ -247,19 +296,19 @@ META."
;; which says they are required during building. We
;; have not yet had a need for cross-compiled perl
;; modules, however, so we leave it out.
- (convert-inputs '("configure" "build" "test")))
+ (convert-inputs '(configure build test)))
,@(maybe-inputs 'propagated-inputs
- (convert-inputs '("runtime")))
+ (convert-inputs '(runtime)))
(home-page ,(cpan-home name))
- (synopsis ,(assoc-ref meta "abstract"))
+ (synopsis ,(cpan-release-abstract release))
(description fill-in-yourself!)
- (license ,(string->license (assoc-ref meta "license"))))))
+ (license ,(string->license (cpan-release-license release))))))
(define (cpan->guix-package module-name)
"Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
- (let ((module-meta (cpan-fetch (module->name module-name))))
- (and=> module-meta cpan-module->sexp)))
+ (let ((release (cpan-fetch (module->name module-name))))
+ (and=> release cpan-module->sexp)))
(define (cpan-package? package)
"Return #t if PACKAGE is a package from CPAN."
@@ -285,7 +334,7 @@ META."
"Return an <upstream-source> for the latest release of PACKAGE."
(match (cpan-fetch (package->upstream-name package))
(#f #f)
- (meta
+ (release
(let ((core-inputs
(match (package-direct-inputs package)
(((_ inputs _ ...) ...)
@@ -303,8 +352,8 @@ META."
(warning (G_ "input '~a' of ~a is in Perl core~%")
module (package-name package)))
core-inputs)))
- (let ((version (cpan-version meta))
- (url (cpan-source-url meta)))
+ (let ((version (cpan-release-version release))
+ (url (cpan-source-url release)))
(upstream-source
(package (package-name package))
(version version)
diff --git a/tests/cpan.scm b/tests/cpan.scm
index 189dd027e6..043d401032 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,13 +33,6 @@
(define test-json
"{
\"metadata\" : {
- \"prereqs\" : {
- \"runtime\" : {
- \"requires\" : {
- \"Test::Script\" : \"1.05\",
- }
- }
- }
\"name\" : \"Foo-Bar\",
\"version\" : \"0.1\"
}
@@ -47,6 +41,13 @@
\"license\" : [
\"perl_5\"
],
+ \"dependency\": [
+ { \"relationship\": \"requires\",
+ \"phase\": \"runtime\",
+ \"version\": \"1.05\",
+ \"module\": \"Test::Script\"
+ }
+ ],
\"abstract\" : \"Fizzle Fuzz\",
\"download_url\" : \"http://example.com/Foo-Bar-0.1.tar.gz\",
\"author\" : \"Guix\",
@@ -107,16 +108,14 @@
(x
(pk 'fail x #f))))))
-(test-equal "source-url-http"
- ((@@ (guix import cpan) cpan-source-url)
- `(("download_url" .
- "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))
- "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+(test-equal "metacpan-url->mirror-url, http"
+ "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
+ (metacpan-url->mirror-url
+ "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))
-(test-equal "source-url-https"
- ((@@ (guix import cpan) cpan-source-url)
- `(("download_url" .
- "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))
- "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+(test-equal "metacpan-url->mirror-url, https"
+ "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
+ (metacpan-url->mirror-url
+ "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))
(test-end "cpan")
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-19 06:15:41 +0000