mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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:
parent
eb95ace9f1
commit
3b4d01035f
3 changed files with 35 additions and 14 deletions
|
@ -37,6 +37,7 @@ (define-module (guix packages)
|
|||
#: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 @@ (define-module (guix packages)
|
|||
origin-method
|
||||
origin-sha256
|
||||
origin-file-name
|
||||
origin-actual-file-name
|
||||
origin-patches
|
||||
origin-patch-flags
|
||||
origin-patch-inputs
|
||||
|
@ -188,6 +190,26 @@ (define-syntax base32
|
|||
((_ 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.
|
||||
|
|
|
@ -33,7 +33,6 @@ (define-module (guix scripts graph)
|
|||
#: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 @@ (define-record-type* <node-type> node-type make-node-type
|
|||
;;; 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)))
|
||||
|
|
|
@ -177,6 +177,18 @@ (define read-at
|
|||
(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))
|
||||
|
|
Loading…
Reference in a new issue