diff options
| -rw-r--r-- | guix/packages.scm | 22 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 15 | ||||
| -rw-r--r-- | tests/packages.scm | 12 |
3 files changed, 35 insertions, 14 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index e466ffeda0..edcb53ec93 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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. diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2b671be131..cddd63e5b7 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -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))) diff --git a/tests/packages.scm b/tests/packages.scm index 00a0998b4c..ace2f36f19 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -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)) |