guix: packages: Add origin-actual-file-name.
* guix/scripts/graph.scm (uri->file-name, node-full-name): Move origin file name logic to... * guix/packages.scm (origin-actual-file-name): ...here. * tests/packages.scm ("origin-actual-file-name") ("origin-actual-file-name, file-name"): New tests.master
parent
eb95ace9f1
commit
3b4d01035f
|
@ -37,6 +37,7 @@
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
|
#:use-module (web uri)
|
||||||
#:re-export (%current-system
|
#:re-export (%current-system
|
||||||
%current-target-system
|
%current-target-system
|
||||||
search-path-specification) ;for convenience
|
search-path-specification) ;for convenience
|
||||||
|
@ -46,6 +47,7 @@
|
||||||
origin-method
|
origin-method
|
||||||
origin-sha256
|
origin-sha256
|
||||||
origin-file-name
|
origin-file-name
|
||||||
|
origin-actual-file-name
|
||||||
origin-patches
|
origin-patches
|
||||||
origin-patch-flags
|
origin-patch-flags
|
||||||
origin-patch-inputs
|
origin-patch-inputs
|
||||||
|
@ -188,6 +190,26 @@ representation."
|
||||||
((_ str)
|
((_ str)
|
||||||
#'(nix-base32-string->bytevector str)))))
|
#'(nix-base32-string->bytevector str)))))
|
||||||
|
|
||||||
|
(define (origin-actual-file-name origin)
|
||||||
|
"Return the file name of ORIGIN, either its 'file-name' field or the file
|
||||||
|
name of its URI."
|
||||||
|
(define (uri->file-name uri)
|
||||||
|
;; Return the 'base name' of URI or URI itself, where URI is a string.
|
||||||
|
(let ((path (and=> (string->uri uri) uri-path)))
|
||||||
|
(if path
|
||||||
|
(basename path)
|
||||||
|
uri)))
|
||||||
|
|
||||||
|
(or (origin-file-name origin)
|
||||||
|
(match (origin-uri origin)
|
||||||
|
((head . tail)
|
||||||
|
(uri->file-name head))
|
||||||
|
((? string? uri)
|
||||||
|
(uri->file-name uri))
|
||||||
|
(else
|
||||||
|
;; git, svn, cvs, etc. reference
|
||||||
|
#f))))
|
||||||
|
|
||||||
(define %supported-systems
|
(define %supported-systems
|
||||||
;; This is the list of system types that are supported. By default, we
|
;; This is the list of system types that are supported. By default, we
|
||||||
;; expect all packages to build successfully here.
|
;; expect all packages to build successfully here.
|
||||||
|
|
|
@ -33,7 +33,6 @@
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-37)
|
#:use-module (srfi srfi-37)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (web uri)
|
|
||||||
#:export (%package-node-type
|
#:export (%package-node-type
|
||||||
%bag-node-type
|
%bag-node-type
|
||||||
%bag-emerged-node-type
|
%bag-emerged-node-type
|
||||||
|
@ -78,25 +77,13 @@
|
||||||
;;; Package DAG.
|
;;; Package DAG.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define (uri->file-name uri)
|
|
||||||
"Return the 'base name' of URI or URI itself, where URI is a string."
|
|
||||||
(let ((path (and=> (string->uri uri) uri-path)))
|
|
||||||
(if path
|
|
||||||
(basename path)
|
|
||||||
uri)))
|
|
||||||
|
|
||||||
(define (node-full-name thing)
|
(define (node-full-name thing)
|
||||||
"Return a human-readable name to denote THING, a package, origin, or file
|
"Return a human-readable name to denote THING, a package, origin, or file
|
||||||
name."
|
name."
|
||||||
(cond ((package? thing)
|
(cond ((package? thing)
|
||||||
(package-full-name thing))
|
(package-full-name thing))
|
||||||
((origin? thing)
|
((origin? thing)
|
||||||
(or (origin-file-name thing)
|
(origin-actual-file-name thing))
|
||||||
(match (origin-uri thing)
|
|
||||||
((head . tail)
|
|
||||||
(uri->file-name head))
|
|
||||||
((? string? uri)
|
|
||||||
(uri->file-name uri)))))
|
|
||||||
((string? thing) ;file name
|
((string? thing) ;file name
|
||||||
(or (basename thing)
|
(or (basename thing)
|
||||||
(error "basename" thing)))
|
(error "basename" thing)))
|
||||||
|
|
|
@ -177,6 +177,18 @@
|
||||||
(package-transitive-supported-systems d)
|
(package-transitive-supported-systems d)
|
||||||
(package-transitive-supported-systems e))))
|
(package-transitive-supported-systems e))))
|
||||||
|
|
||||||
|
(test-equal "origin-actual-file-name"
|
||||||
|
"foo-1.tar.gz"
|
||||||
|
(let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
|
||||||
|
(origin-actual-file-name o)))
|
||||||
|
|
||||||
|
(test-equal "origin-actual-file-name, file-name"
|
||||||
|
"foo-1.tar.gz"
|
||||||
|
(let ((o (dummy-origin
|
||||||
|
(uri "http://www.example.com/tarball")
|
||||||
|
(file-name "foo-1.tar.gz"))))
|
||||||
|
(origin-actual-file-name o)))
|
||||||
|
|
||||||
(let* ((o (dummy-origin))
|
(let* ((o (dummy-origin))
|
||||||
(u (dummy-origin))
|
(u (dummy-origin))
|
||||||
(i (dummy-origin))
|
(i (dummy-origin))
|
||||||
|
|
Loading…
Reference in New Issue