diff options
| -rw-r--r-- | guix/utils.scm | 100 | ||||
| -rw-r--r-- | tests/utils.scm | 53 |
2 files changed, 153 insertions, 0 deletions
diff --git a/guix/utils.scm b/guix/utils.scm new file mode 100644 index 0000000000..69abcb4b55 --- /dev/null +++ b/guix/utils.scm @@ -0,0 +1,100 @@ +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Guix. +;;; +;;; Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix utils) + #:use-module (srfi srfi-60) + #:use-module (rnrs bytevectors) + #:export (bytevector-quintet-length + bytevector->base32-string + bytevector->nix-base32-string)) + +(define bytevector-quintet-ref + (let* ((ref bytevector-u8-ref) + (ref+ (lambda (bv offset) + (let ((o (+ 1 offset))) + (if (>= o (bytevector-length bv)) + 0 + (bytevector-u8-ref bv o))))) + (ref0 (lambda (bv offset) + (bit-field (ref bv offset) 3 8))) + (ref1 (lambda (bv offset) + (logior (ash (bit-field (ref bv offset) 0 3) 2) + (bit-field (ref+ bv offset) 6 8)))) + (ref2 (lambda (bv offset) + (bit-field (ref bv offset) 1 6))) + (ref3 (lambda (bv offset) + (logior (ash (bit-field (ref bv offset) 0 1) 4) + (bit-field (ref+ bv offset) 4 8)))) + (ref4 (lambda (bv offset) + (logior (ash (bit-field (ref bv offset) 0 4) 1) + (bit-field (ref+ bv offset) 7 8)))) + (ref5 (lambda (bv offset) + (bit-field (ref bv offset) 2 7))) + (ref6 (lambda (bv offset) + (logior (ash (bit-field (ref bv offset) 0 2) 3) + (bit-field (ref+ bv offset) 5 8)))) + (ref7 (lambda (bv offset) + (bit-field (ref bv offset) 0 5))) + (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) + (lambda (bv index) + "Return the INDEXth quintet of BV." + (let ((p (vector-ref refs (modulo index 8)))) + (p bv (quotient (* index 5) 8)))))) + +(define (bytevector-quintet-length bv) + "Return the number of quintets (including truncated ones) available in BV." + (ceiling (/ (* (bytevector-length bv) 8) 5))) + +(define (bytevector-quintet-fold proc init bv) + "Return the result of applying PROC to each quintet of BV and the result of +the previous application or INIT." + (define len + (bytevector-quintet-length bv)) + + (let loop ((i 0) + (r init)) + (if (= i len) + r + (loop (1+ i) (proc (bytevector-quintet-ref bv i) r))))) + +(define (make-bytevector->base32-string base32-chars) + (lambda (bv) + "Return a base32 encoding of BV using BASE32-CHARS as the alphabet." + (let ((chars (bytevector-quintet-fold (lambda (q r) + (cons (vector-ref base32-chars q) + r)) + '() + bv))) + (list->string (reverse chars))))) + +(define %nix-base32-chars + ;; See `libutil/hash.cc'. + #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n + #\p #\q #\r #\s #\v #\w #\x #\y #\z)) + +(define %rfc4648-base32-chars + #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z + #\2 #\3 #\4 #\5 #\6 #\7)) + +(define bytevector->base32-string + (make-bytevector->base32-string %rfc4648-base32-chars)) + +(define bytevector->nix-base32-string + (make-bytevector->base32-string %nix-base32-chars)) diff --git a/tests/utils.scm b/tests/utils.scm new file mode 100644 index 0000000000..57705e6f48 --- /dev/null +++ b/tests/utils.scm @@ -0,0 +1,53 @@ +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Guix. +;;; +;;; Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. + + +(define-module (test-utils) + #:use-module (guix utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors)) + +(test-begin "utils") + +(test-assert "bytevector->base32-string" + (fold (lambda (bv expected result) + (and result + (string=? (bytevector->base32-string bv) + expected))) + #t + + ;; Examples from RFC 4648. + (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")) + '("" + "my" + "mzxq" + "mzxw6" + "mzxw6yq" + "mzxw6ytb" + "mzxw6ytboi"))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'test-assert 'scheme-indent-function 1) +;;; End: |