From afb49942e032000ba03ae879a7a1d29803aac094 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 1 Apr 2013 16:08:31 +0200
Subject: [PATCH] store: Add `store-path-hash-part'.

* guix/store.scm (store-path-hash-part): New procedure.
* tests/store.scm ("store-path-hash-part", "store-path-hash-part #f"):
  New tests.
---
 guix/store.scm  | 12 +++++++++++-
 tests/store.scm | 12 ++++++++++++
 2 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/guix/store.scm b/guix/store.scm
index 4d078c5899..3bb2656bb6 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -83,7 +83,8 @@
             %store-prefix
             store-path?
             derivation-path?
-            store-path-package-name))
+            store-path-package-name
+            store-path-hash-part))
 
 (define %protocol-version #x10c)
 
@@ -751,3 +752,12 @@ collected, and the number of bytes freed."
 
   (and=> (regexp-exec store-path-rx path)
          (cut match:substring <> 1)))
+
+(define (store-path-hash-part path)
+  "Return the hash part of PATH as a base32 string, or #f if PATH is not a
+syntactically valid store path."
+  (let ((path-rx (make-regexp
+                  (string-append"^" (regexp-quote (%store-prefix))
+                                "/([0-9a-df-np-sv-z]{32})-[^/]+$"))))
+    (and=> (regexp-exec path-rx path)
+           (cut match:substring <> 1))))
diff --git a/tests/store.scm b/tests/store.scm
index c2de99e160..d6e1aa54e3 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -48,6 +48,18 @@
 
 (test-begin "store")
 
+(test-equal "store-path-hash-part"
+  "283gqy39v3g9dxjy26rynl0zls82fmcg"
+  (store-path-hash-part
+   (string-append (%store-prefix)
+                  "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
+
+(test-equal "store-path-hash-part #f"
+  #f
+  (store-path-hash-part
+   (string-append (%store-prefix)
+                  "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
+
 (test-skip (if %store 0 10))
 
 (test-assert "dead-paths"