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.
This commit is contained in:
Eric Bavier 2015-09-10 15:39:44 -05:00
parent eb95ace9f1
commit 3b4d01035f
3 changed files with 35 additions and 14 deletions

View File

@ -37,6 +37,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (web uri)
#:re-export (%current-system
%current-target-system
search-path-specification) ;for convenience
@ -46,6 +47,7 @@
origin-method
origin-sha256
origin-file-name
origin-actual-file-name
origin-patches
origin-patch-flags
origin-patch-inputs
@ -188,6 +190,26 @@ representation."
((_ 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
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.

View File

@ -33,7 +33,6 @@
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:use-module (web uri)
#:export (%package-node-type
%bag-node-type
%bag-emerged-node-type
@ -78,25 +77,13 @@
;;; 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)
"Return a human-readable name to denote THING, a package, origin, or file
name."
(cond ((package? thing)
(package-full-name thing))
((origin? thing)
(or (origin-file-name thing)
(match (origin-uri thing)
((head . tail)
(uri->file-name head))
((? string? uri)
(uri->file-name uri)))))
(origin-actual-file-name thing))
((string? thing) ;file name
(or (basename thing)
(error "basename" thing)))

View File

@ -177,6 +177,18 @@
(package-transitive-supported-systems d)
(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))
(u (dummy-origin))
(i (dummy-origin))