Fix bytevector->hex-string.
[guile-toxcore.git] / tox / util.scm
1 ;;; guile-toxcore
2 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; guile-toxcore is free software: you can redistribute it and/or modify it
5 ;;; under the terms of the GNU General Public License as published by the Free
6 ;;; Software Foundation, either version 3 of the License, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; guile-toxcore is distributed in the hope that it will be useful, but
10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
11 ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
12 ;;; for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19 ;;
20 ;; Utility procedures.
21 ;;
22 ;;; Code:
23
24 (define-module (tox util)
25 #:use-module (ice-9 format)
26 #:use-module (rnrs bytevectors)
27 #:use-module (system foreign)
28 #:export (boolean->number
29 one?
30 define-enumeration
31 hex-string->bytevector bytevector->hex-string
32 utf8-pointer->string
33 bytevector-slice
34 false-if-negative false-if-zero
35 htons))
36
37 (define (boolean->number true?)
38 "Return 1 if TRUE? is #t, 0 otherwise."
39 (if true? 1 0))
40
41 (define (one? n)
42 "Return #t if N is equal to 1, #f otherwise."
43 (= n 1))
44
45 ;; Borrowed from guile-opengl
46 (define-syntax-rule (define-enumeration enumerator (name value) ...)
47 (define-syntax enumerator
48 (lambda (x)
49 (syntax-case x ()
50 ((_)
51 #''(name ...))
52 ((_ enum) (number? (syntax->datum #'enum))
53 #'enum)
54 ((_ enum)
55 (or (assq-ref '((name . value) ...)
56 (syntax->datum #'enum))
57 (syntax-violation 'enumerator "invalid enumerated value"
58 #'enum)))))))
59
60 (define (hex-string->bytevector str)
61 "Return a newly allocated bytevector containing the binary representation of
62 the hexadecimal encoded string STR. The length of STR must be even."
63 (define (read-byte start)
64 (string->number
65 (string-append "#x" (substring str start (+ start 2)))))
66
67 (let* ((size (/ (string-length str) 2))
68 (bv (make-bytevector size)))
69 (let loop ((i 0))
70 (when (< i size)
71 (bytevector-u8-set! bv i (read-byte (* i 2)))
72 (loop (1+ i))))
73 bv))
74
75 (define (bytevector->hex-string bv)
76 "Return a newly allocated string containing the hexadecimal representation
77 of the contents of the bytevector BV."
78 (string-upcase
79 (string-concatenate
80 (map (lambda (n)
81 (format #f "~2,'0x" n))
82 (bytevector->u8-list bv)))))
83
84 (define (utf8-pointer->string pointer length)
85 "Return a newly allocated string containing the characters within the UTF-8
86 encoded foreign POINTER of LENGTH bytes."
87 (utf8->string (pointer->bytevector pointer length)))
88
89 (define (bytevector-slice bv begin end)
90 "Return a newly allocated bytevector containing the contents of BV from the
91 index BEGIN, inclusive, to the index END, exclusive."
92 (let ((ret (make-bytevector (- end begin))))
93 (let loop ((i begin))
94 (when (< i end)
95 (u8vector-set! ret (- i begin) (u8vector-ref bv i))
96 (loop (1+ i))))
97 ret))
98
99 (define (false-if-negative n)
100 "Return #f is N is negative, or N otherwise."
101 (if (negative? n) #f n))
102
103 (define (false-if-zero n)
104 "Return #f is N is zero, or N otherwise."
105 (if (zero? n) #f n))
106
107 ;; The htons available in Guile has been deprecated as of version 2.0.11.
108 (define (htons n)
109 "Converts the unsigned short integer N from host byte order to network byte
110 order. N is assumed to be a positive integer in the range [0, 65535]."
111 (logand (logior (ash n 8) (ash n -8)) #xffff))