From fad155d47ea22c7ffd042ffddd03b0a6babd3b65 Mon Sep 17 00:00:00 2001
From: Mathieu Lirzin <mthl@gnu.org>
Date: Sun, 28 Feb 2016 17:50:58 +0100
Subject: packages: Factorize package specification search.

* gnu/packages.scm (%find-package): New procedure.
(specification->package, specification->package+output): Use it.
---
 gnu/packages.scm | 66 ++++++++++++++++++++++++++------------------------------
 1 file changed, 31 insertions(+), 35 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 64a695d970..9b111eda28 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -276,26 +277,31 @@ return its return value."
                     (lambda (k signum)
                       (handler signum))))
 
+
+;;;
+;;; Package specification.
+;;;
+
+(define (%find-package spec name version)
+  (match (find-best-packages-by-name name version)
+    ((pkg . pkg*)
+     (unless (null? pkg*)
+       (warning (_ "ambiguous package specification `~a'~%") spec)
+       (warning (_ "choosing ~a from ~a~%")
+                (package-full-name pkg)
+                (location->string (package-location pkg))))
+     pkg)
+    (_
+     (if version
+         (leave (_ "~A: package not found for version ~a~%") name version)
+         (leave (_ "~A: unknown package~%") name)))))
+
 (define (specification->package spec)
   "Return a package matching SPEC.  SPEC may be a package name, or a package
 name followed by a hyphen and a version number.  If the version number is not
 present, return the preferred newest version."
-  (let-values (((name version)
-                (package-name->name+version spec)))
-    (match (find-best-packages-by-name name version)
-      ((p)                                      ; one match
-       p)
-      ((p x ...)                                ; several matches
-       (warning (_ "ambiguous package specification `~a'~%") spec)
-       (warning (_ "choosing ~a from ~a~%")
-                (package-full-name p)
-                (location->string (package-location p)))
-       p)
-      (_                                        ; no matches
-       (if version
-           (leave (_ "~A: package not found for version ~a~%")
-                  name version)
-           (leave (_ "~A: unknown package~%") name))))))
+  (let-values (((name version) (package-name->name+version spec)))
+    (%find-package spec name version)))
 
 (define* (specification->package+output spec #:optional (output "out"))
   "Return the package and output specified by SPEC, or #f and #f; SPEC may
@@ -308,24 +314,14 @@ optionally contain a version number and an output name, as in these examples:
 
 If SPEC does not specify a version number, return the preferred newest
 version; if SPEC does not specify an output, return OUTPUT."
-  (define (ensure-output p sub-drv)
-    (if (member sub-drv (package-outputs p))
-        sub-drv
-        (leave (_ "package `~a' lacks output `~a'~%")
-               (package-full-name p)
-               sub-drv)))
-
   (let-values (((name version sub-drv)
                 (package-specification->name+version+output spec output)))
-    (match (find-best-packages-by-name name version)
-      ((p)
-       (values p (ensure-output p sub-drv)))
-      ((p p* ...)
-       (warning (_ "ambiguous package specification `~a'~%")
-                spec)
-       (warning (_ "choosing ~a from ~a~%")
-                (package-full-name p)
-                (location->string (package-location p)))
-       (values p (ensure-output p sub-drv)))
-      (()
-       (leave (_ "~a: package not found~%") spec)))))
+    (match (%find-package spec name version)
+      (#f
+       (values #f #f))
+      (package
+       (if (member sub-drv (package-outputs package))
+           (values package sub-drv)
+           (leave (_ "package `~a' lacks output `~a'~%")
+                  (package-full-name package)
+                  sub-drv))))))
-- 
cgit 1.4.1