guix/base16.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix base16)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-26)
  22   #:use-module (srfi srfi-60)
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (ice-9 vlist)
  25   #:use-module (ice-9 format)
  26   #:export (bytevector->base16-string
  27             base16-string->bytevector))
  28 \f
  29 ;;;
  30 ;;; Base 16.
  31 ;;;
  32
  33 (define (bytevector->base16-string bv)
  34   "Return the hexadecimal representation of BV's contents."
  35   (define len
  36     (bytevector-length bv))
  37
  38   (let-syntax ((base16-chars (lambda (s)
  39                                (syntax-case s ()
  40                                  (_
  41                                   (let ((v (list->vector
  42                                             (unfold (cut > <> 255)
  43                                                     (lambda (n)
  44                                                       (format #f "~2,'0x" n))
  45                                                     1+
  46                                                     0))))
  47                                     v))))))
  48     (define chars base16-chars)
  49     (let loop ((i len)
  50                (r '()))
  51       (if (zero? i)
  52           (string-concatenate r)
  53           (let ((i (- i 1)))
  54             (loop i
  55                   (cons (vector-ref chars (bytevector-u8-ref bv i)) r)))))))
  56
  57 (define base16-string->bytevector
  58   (let ((chars->value (fold (lambda (i r)
  59                               (vhash-consv (string-ref (number->string i 16)
  60                                                        0)
  61                                            i r))
  62                             vlist-null
  63                             (iota 16))))
  64     (lambda (s)
  65       "Return the bytevector whose hexadecimal representation is string S."
  66       (define bv
  67         (make-bytevector (quotient (string-length s) 2) 0))
  68
  69       (string-fold (lambda (chr i)
  70                      (let ((j (quotient i 2))
  71                            (v (and=> (vhash-assv chr chars->value) cdr)))
  72                        (if v
  73                            (if (zero? (logand i 1))
  74                                (bytevector-u8-set! bv j
  75                                                    (arithmetic-shift v 4))
  76                                (let ((w (bytevector-u8-ref bv j)))
  77                                  (bytevector-u8-set! bv j (logior v w))))
  78                            (error "invalid hexadecimal character" chr)))
  79                      (+ i 1))
  80                    0
  81                    s)
  82       bv)))
  83