From 6d800a80eaa2a221ee44617fdd702bf7c92f22ed Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 9 Jun 2012 16:34:18 +0200
Subject: Add `base16-string->bytevector'.

* guix/utils.scm (base16-string->bytevector): New procedure.

* tests/utils.scm ("bytevector->base16-string->bytevector"): New test.
---
 guix/utils.scm  | 28 ++++++++++++++++++++++++++++
 tests/utils.scm |  7 +++++++
 2 files changed, 35 insertions(+)

diff --git a/guix/utils.scm b/guix/utils.scm
index 65e89a0e1b..77ed9ce6ee 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -35,6 +35,7 @@
             bytevector->base16-string
             base32-string->bytevector
             nix-base32-string->bytevector
+            base16-string->bytevector
             sha256
 
             %nixpkgs-directory
@@ -327,6 +328,33 @@ starting from the right of S."
           (loop (+ 1 i)
                 (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))
 
+(define base16-string->bytevector
+  (let ((chars->value (fold (lambda (i r)
+                              (vhash-consv (string-ref (number->string i 16)
+                                                       0)
+                                           i r))
+                            vlist-null
+                            (iota 16))))
+    (lambda (s)
+      "Return the bytevector whose hexadecimal representation is string S."
+      (define bv
+        (make-bytevector (quotient (string-length s) 2) 0))
+
+      (string-fold (lambda (chr i)
+                     (let ((j (quotient i 2))
+                           (v (and=> (vhash-assv chr chars->value) cdr)))
+                       (if v
+                           (if (zero? (logand i 1))
+                               (bytevector-u8-set! bv j
+                                                   (arithmetic-shift v 4))
+                               (let ((w (bytevector-u8-ref bv j)))
+                                 (bytevector-u8-set! bv j (logior v w))))
+                           (error "invalid hexadecimal character" chr)))
+                     (+ i 1))
+                   0
+                   s)
+      bv)))
+
 
 ;;;
 ;;; Hash.
diff --git a/tests/utils.scm b/tests/utils.scm
index edea11db72..db4eb5a340 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -62,6 +62,13 @@
          ;; Examples from RFC 4648.
          (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
 
+(test-assert "bytevector->base16-string->bytevector"
+  (every (lambda (bv)
+           (equal? (base16-string->bytevector
+                    (bytevector->base16-string bv))
+                   bv))
+         (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
+
 ;; The following tests requires `nix-hash' in $PATH.
 (test-skip (if (false-if-exception (system* "nix-hash" "--version"))
                0
-- 
cgit 1.4.1