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.

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))