From 2cb658a9a7c491ee8ea13da9682170e40deb25ed Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 6 Mar 2019 23:48:41 +0100
Subject: describe: Add 'package-provenance'.

* guix/scripts/package.scm (package-provenance): Move to...
* guix/describe.scm (package-provenance): ... here.
---
 guix/scripts/package.scm | 36 +-----------------------------------
 1 file changed, 1 insertion(+), 35 deletions(-)

(limited to 'guix/scripts/package.scm')

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 0e70315708..efff511299 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -36,7 +36,7 @@
   #:use-module (guix config)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
-  #:autoload   (guix describe) (current-profile-entries)
+  #:autoload   (guix describe) (package-provenance)
   #:use-module ((guix build utils)
                 #:select (directory-exists? mkdir-p))
   #:use-module (ice-9 format)
@@ -552,40 +552,6 @@ upgrading, #f otherwise."
       (output "out")                              ;XXX: wild guess
       (item item))))
 
-(define (package-provenance package)
-  "Return the provenance of PACKAGE as an sexp for use as the 'provenance'
-property of manifest entries, or #f if it could not be determined."
-  (define (entry-source entry)
-    (match (assq 'source
-                 (manifest-entry-properties entry))
-      (('source value) value)
-      (_ #f)))
-
-  (match (and=> (package-location package) location-file)
-    (#f #f)
-    (file
-     (let ((file (if (string-prefix? "/" file)
-                     file
-                     (search-path %load-path file))))
-       (and file
-            (string-prefix? (%store-prefix) file)
-
-            ;; Always store information about the 'guix' channel and
-            ;; optionally about the specific channel FILE comes from.
-            (or (let ((main  (and=> (find (lambda (entry)
-                                            (string=? "guix"
-                                                      (manifest-entry-name entry)))
-                                          (current-profile-entries))
-                                    entry-source))
-                      (extra (any (lambda (entry)
-                                    (let ((item (manifest-entry-item entry)))
-                                      (and (string-prefix? item file)
-                                           (entry-source entry))))
-                                  (current-profile-entries))))
-                  (and main
-                       `(,main
-                         ,@(if extra (list extra) '()))))))))))
-
 (define (package->manifest-entry* package output)
   "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to
 the resulting manifest entry."
-- 
cgit v1.2.3