1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
4 ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
5 ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
7 ;;; This file is part of GNU Guix.
9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
10 ;;; under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 3 of the License, or (at
12 ;;; your option) any later version.
14 ;;; GNU Guix is distributed in the hope that it will be useful, but
15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;;; GNU General Public License for more details.
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (guix import cpan)
23 #:use-module (ice-9 match)
24 #:use-module (ice-9 regex)
25 #:use-module ((ice-9 popen) #:select (open-pipe* close-pipe))
26 #:use-module ((ice-9 rdelim) #:select (read-line))
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-26)
30 #:use-module (gcrypt hash)
31 #:use-module (guix store)
32 #:use-module (guix utils)
33 #:use-module (guix base32)
34 #:use-module (guix ui)
35 #:use-module ((guix download) #:select (download-to-store url-fetch))
36 #:use-module ((guix import utils) #:select (factorize-uri
38 #:use-module (guix import json)
39 #:use-module (guix packages)
40 #:use-module (guix upstream)
41 #:use-module (guix derivations)
42 #:export (cpan->guix-package
47 ;;; Generate a package declaration template for the latest version of a CPAN
48 ;;; module, using meta-data from metacpan.org.
52 (define string->license
54 ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
55 ;; Some licenses are excluded based on their absense from (guix licenses).
58 ("apache_2_0" 'asl2.0)
60 ("artistic_2" 'artistic2.0)
72 ("mozilla_1_1" 'mpl1.1)
74 ("perl_5" 'perl-license) ;GPL1+ and Artistic 1
79 ((x) (string->license x))
80 ((lst ...) `(list ,@(map string->license lst)))
83 (define (module->name module)
84 "Transform a 'module' name into a 'release' name"
85 (regexp-substitute/global #f "::" module 'pre "-" 'post))
87 (define (module->dist-name module)
88 "Return the base distribution module for a given module. E.g. the 'ok'
89 module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
90 return \"Test-Simple\""
91 (assoc-ref (json-fetch-alist (string-append
92 "https://fastapi.metacpan.org/v1/module/"
94 "?fields=distribution"))
97 (define (package->upstream-name package)
98 "Return the CPAN name of PACKAGE."
99 (let* ((properties (package-properties package))
100 (upstream-name (and=> properties
101 (cut assoc-ref <> 'upstream-name))))
103 (match (package-source package)
105 (match (origin-uri origin)
106 ((or (? string? url) (url _ ...))
107 (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
109 (m (match:substring m 1))))
113 (define (cpan-fetch name)
114 "Return an alist representation of the CPAN metadata for the perl module MODULE,
115 or #f on failure. MODULE should be e.g. \"Test::Script\""
116 ;; This API always returns the latest release of the module.
117 (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
119 (define (cpan-home name)
120 (string-append "https://metacpan.org/release/" name))
122 (define (cpan-source-url meta)
123 "Return the download URL for a module's source tarball."
124 (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
125 (assoc-ref meta "download_url")
126 'pre "mirror://cpan" 'post))
128 (define (cpan-version meta)
129 "Return the version number from META."
130 (match (assoc-ref meta "version")
132 ;; version is sometimes not quoted in the module json, so it gets
133 ;; imported into Guile as a number, so convert it to a string.
134 (number->string version))
136 ;; Sometimes we get a "v" prefix. Strip it.
137 (if (string-prefix? "v" version)
138 (string-drop version 1)
141 (define (perl-package)
142 "Return the 'perl' package. This is a lazy reference so that we don't
143 depend on (gnu packages perl)."
144 (module-ref (resolve-interface '(gnu packages perl)) 'perl))
148 (let* ((perl (with-store store
149 (derivation->output-path
150 (package-derivation store (perl-package)))))
151 (core (string-append perl "/bin/corelist")))
152 (and (access? core X_OK)
156 (let ((rx (make-regexp
157 (string-append "released with perl v?([0-9\\.]*)"
158 "(.*and removed from v?([0-9\\.]*))?"))))
161 (package-version (perl-package)))
163 (define (version-between? lower version upper)
164 (and (version>=? version lower)
166 (version>? upper version))))
167 (and (force %corelist)
168 (parameterize ((current-error-port (%make-void-port "w")))
169 (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
171 (let ((line (read-line corelist)))
172 (if (eof-object? line)
173 (begin (close-pipe corelist) #f)
174 (or (and=> (regexp-exec rx line)
176 (let ((first (match:substring m 1))
177 (last (match:substring m 3)))
179 first perl-version last))))
182 (define (cpan-module->sexp meta)
183 "Return the `package' s-expression for a CPAN module from the metadata in
186 (assoc-ref meta "distribution"))
188 (define (guix-name name)
189 (if (string-prefix? "perl-" name)
190 (string-downcase name)
191 (string-append "perl-" (string-downcase name))))
193 (define version (cpan-version meta))
194 (define source-url (cpan-source-url meta))
196 (define (convert-inputs phases)
197 ;; Convert phase dependencies into a list of name/variable pairs.
200 (filter-map (lambda (t)
201 (assoc-ref* meta "metadata" "prereqs" ph t))
202 '("requires" "recommends" "suggests")))
209 ;; Listed dependencies may include core modules. Filter those out.
210 (filter-map (match-lambda
211 (("perl" . _) ;implicit dependency
214 (and (not (core-module? module))
215 (let ((name (guix-name (module->dist-name module))))
217 (list 'unquote (string->symbol name)))))))
221 (((a _ ...) (b _ ...))
222 (string<? a b))))))))
224 (define (maybe-inputs guix-name inputs)
229 (list (list guix-name
230 (list 'quasiquote inputs))))))
232 (let ((tarball (with-store store
233 (download-to-store store source-url))))
235 (name ,(guix-name name))
239 (uri (string-append ,@(factorize-uri source-url version)))
242 ,(bytevector->nix-base32-string (file-sha256 tarball))))))
243 (build-system perl-build-system)
244 ,@(maybe-inputs 'native-inputs
245 ;; "runtime" may also be needed here. See
246 ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
247 ;; which says they are required during building. We
248 ;; have not yet had a need for cross-compiled perl
249 ;; modules, however, so we leave it out.
250 (convert-inputs '("configure" "build" "test")))
251 ,@(maybe-inputs 'propagated-inputs
252 (convert-inputs '("runtime")))
253 (home-page ,(cpan-home name))
254 (synopsis ,(assoc-ref meta "abstract"))
255 (description fill-in-yourself!)
256 (license ,(string->license (assoc-ref meta "license"))))))
258 (define (cpan->guix-package module-name)
259 "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
260 `package' s-expression corresponding to that package, or #f on failure."
261 (let ((module-meta (cpan-fetch (module->name module-name))))
262 (and=> module-meta cpan-module->sexp)))
264 (define (cpan-package? package)
265 "Return #t if PACKAGE is a package from CPAN."
267 (let ((cpan-rx (make-regexp (string-append "("
269 "https?://www.cpan.org" "|"
270 "https?://cpan.metacpan.org"
273 (regexp-exec cpan-rx url))))
275 (let ((source-url (and=> (package-source package) origin-uri))
276 (fetch-method (and=> (package-source package) origin-method)))
277 (and (eq? fetch-method url-fetch)
280 (cpan-url? source-url))
282 (any cpan-url? source-url))))))
284 (define (latest-release package)
285 "Return an <upstream-source> for the latest release of PACKAGE."
286 (match (cpan-fetch (package->upstream-name package))
290 (match (package-direct-inputs package)
291 (((_ inputs _ ...) ...)
292 (filter-map (match-lambda
295 (= package->upstream-name
296 (? core-module? name)))
300 ;; Warn about inputs that are part of perl's core
301 (unless (null? core-inputs)
302 (for-each (lambda (module)
303 (warning (G_ "input '~a' of ~a is in Perl core~%")
304 module (package-name package)))
306 (let ((version (cpan-version meta))
307 (url (cpan-source-url meta)))
309 (package (package-name package))
311 (urls (list url)))))))
313 (define %cpan-updater
316 (description "Updater for CPAN packages")
318 (latest latest-release)))