From afb49942e032000ba03ae879a7a1d29803aac094 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 1 Apr 2013 16:08:31 +0200 Subject: 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" -- cgit v1.2.3