mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 14:19:18 +02:00
Adding bytevector support to base64 lib.
This commit is contained in:
parent
1e06cd215a
commit
f425126a11
3 changed files with 193 additions and 133 deletions
|
@ -45,24 +45,24 @@
|
||||||
(vector-set! res (char->integer #\=) *pad-char*)
|
(vector-set! res (char->integer #\=) *pad-char*)
|
||||||
res))
|
res))
|
||||||
|
|
||||||
(define (base64-decode-char c)
|
(define (base64-decode-u8 u8)
|
||||||
(vector-ref *base64-decode-table* (char->integer c)))
|
(vector-ref *base64-decode-table* u8))
|
||||||
|
|
||||||
(define *base64-encode-table*
|
(define *base64-encode-table*
|
||||||
(let ((res (make-vector 64)))
|
(let ((res (make-vector 64)))
|
||||||
(let lp ((i 0)) ; map letters
|
(let lp ((i 0)) ; map letters
|
||||||
(cond
|
(cond
|
||||||
((<= i 25)
|
((<= i 25)
|
||||||
(vector-set! res i (integer->char (+ i 65)))
|
(vector-set! res i (+ i 65))
|
||||||
(vector-set! res (+ i 26) (integer->char (+ i 97)))
|
(vector-set! res (+ i 26) (+ i 97))
|
||||||
(lp (+ i 1)))))
|
(lp (+ i 1)))))
|
||||||
(let lp ((i 0)) ; map numbers
|
(let lp ((i 0)) ; map numbers
|
||||||
(cond
|
(cond
|
||||||
((<= i 9)
|
((<= i 9)
|
||||||
(vector-set! res (+ i 52) (integer->char (+ i 48)))
|
(vector-set! res (+ i 52) (+ i 48))
|
||||||
(lp (+ i 1)))))
|
(lp (+ i 1)))))
|
||||||
(vector-set! res 62 #\+)
|
(vector-set! res 62 (char->integer #\+))
|
||||||
(vector-set! res 63 #\/)
|
(vector-set! res 63 (char->integer #\/))
|
||||||
res))
|
res))
|
||||||
|
|
||||||
(define (enc i)
|
(define (enc i)
|
||||||
|
@ -90,17 +90,21 @@
|
||||||
;; input, and pass it to the internal base64-decode-string! utility.
|
;; input, and pass it to the internal base64-decode-string! utility.
|
||||||
;; If the resulting length used is exact, we can return that buffer,
|
;; If the resulting length used is exact, we can return that buffer,
|
||||||
;; otherwise we return the appropriate substring.
|
;; otherwise we return the appropriate substring.
|
||||||
(define (base64-decode-string src)
|
|
||||||
(let* ((len (string-length src))
|
(define (base64-decode-string str)
|
||||||
|
(utf8->string (base64-decode-bytevector (string->utf8 str))))
|
||||||
|
|
||||||
|
(define (base64-decode-bytevector src)
|
||||||
|
(let* ((len (bytevector-length src))
|
||||||
(dst-len (* 3 (arithmetic-shift (+ 3 len) -2)))
|
(dst-len (* 3 (arithmetic-shift (+ 3 len) -2)))
|
||||||
(dst (make-string dst-len)))
|
(dst (make-bytevector dst-len)))
|
||||||
(base64-decode-string!
|
(base64-decode-bytevector!
|
||||||
src 0 len dst
|
src 0 len dst
|
||||||
(lambda (src-offset res-len b1 b2 b3)
|
(lambda (src-offset res-len b1 b2 b3)
|
||||||
(let ((res-len (base64-decode-finish dst res-len b1 b2 b3)))
|
(let ((res-len (base64-decode-finish dst res-len b1 b2 b3)))
|
||||||
(if (= res-len dst-len)
|
(if (= res-len dst-len)
|
||||||
dst
|
dst
|
||||||
(substring dst 0 res-len)))))))
|
(bytevector-copy dst 0 res-len)))))))
|
||||||
|
|
||||||
;; This is a little funky.
|
;; This is a little funky.
|
||||||
;;
|
;;
|
||||||
|
@ -112,7 +116,7 @@
|
||||||
;; really bad about optimizing nested loops of primitives, so we
|
;; really bad about optimizing nested loops of primitives, so we
|
||||||
;; flatten this into a single loop, using conditionals to determine
|
;; flatten this into a single loop, using conditionals to determine
|
||||||
;; which character is currently being read.
|
;; which character is currently being read.
|
||||||
(define (base64-decode-string! src start end dst kont)
|
(define (base64-decode-bytevector! src start end dst kont)
|
||||||
(let lp ((i start)
|
(let lp ((i start)
|
||||||
(j 0)
|
(j 0)
|
||||||
(b1 *outside-char*)
|
(b1 *outside-char*)
|
||||||
|
@ -120,7 +124,7 @@
|
||||||
(b3 *outside-char*))
|
(b3 *outside-char*))
|
||||||
(if (>= i end)
|
(if (>= i end)
|
||||||
(kont i j b1 b2 b3)
|
(kont i j b1 b2 b3)
|
||||||
(let ((c (base64-decode-char (string-ref src i))))
|
(let ((c (base64-decode-u8 (bytevector-u8-ref src i))))
|
||||||
(cond
|
(cond
|
||||||
((eqv? c *pad-char*)
|
((eqv? c *pad-char*)
|
||||||
(kont i j b1 b2 b3))
|
(kont i j b1 b2 b3))
|
||||||
|
@ -133,23 +137,23 @@
|
||||||
((eqv? b3 *outside-char*)
|
((eqv? b3 *outside-char*)
|
||||||
(lp (+ i 1) j b1 b2 c))
|
(lp (+ i 1) j b1 b2 c))
|
||||||
(else
|
(else
|
||||||
(string-set! dst
|
(bytevector-u8-set!
|
||||||
|
dst
|
||||||
j
|
j
|
||||||
(integer->char
|
|
||||||
(bitwise-ior (arithmetic-shift b1 2)
|
(bitwise-ior (arithmetic-shift b1 2)
|
||||||
(extract-bit-field 2 4 b2))))
|
(extract-bit-field 2 4 b2)))
|
||||||
(string-set! dst
|
(bytevector-u8-set!
|
||||||
|
dst
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(integer->char
|
|
||||||
(bitwise-ior
|
(bitwise-ior
|
||||||
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
|
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
|
||||||
(extract-bit-field 4 2 b3))))
|
(extract-bit-field 4 2 b3)))
|
||||||
(string-set! dst
|
(bytevector-u8-set!
|
||||||
|
dst
|
||||||
(+ j 2)
|
(+ j 2)
|
||||||
(integer->char
|
|
||||||
(bitwise-ior
|
(bitwise-ior
|
||||||
(arithmetic-shift (extract-bit-field 2 0 b3) 6)
|
(arithmetic-shift (extract-bit-field 2 0 b3) 6)
|
||||||
c)))
|
c))
|
||||||
(lp (+ i 1) (+ j 3)
|
(lp (+ i 1) (+ j 3)
|
||||||
*outside-char* *outside-char* *outside-char*)))))))
|
*outside-char* *outside-char* *outside-char*)))))))
|
||||||
|
|
||||||
|
@ -162,24 +166,22 @@
|
||||||
((eqv? b1 *outside-char*)
|
((eqv? b1 *outside-char*)
|
||||||
j)
|
j)
|
||||||
((eqv? b2 *outside-char*)
|
((eqv? b2 *outside-char*)
|
||||||
(string-set! dst j (integer->char (arithmetic-shift b1 2)))
|
(bytevector-u8-set! dst j (arithmetic-shift b1 2))
|
||||||
(+ j 1))
|
(+ j 1))
|
||||||
(else
|
(else
|
||||||
(string-set! dst
|
(bytevector-u8-set! dst
|
||||||
j
|
j
|
||||||
(integer->char
|
|
||||||
(bitwise-ior (arithmetic-shift b1 2)
|
(bitwise-ior (arithmetic-shift b1 2)
|
||||||
(extract-bit-field 2 4 b2))))
|
(extract-bit-field 2 4 b2)))
|
||||||
(cond
|
(cond
|
||||||
((eqv? b3 *outside-char*)
|
((eqv? b3 *outside-char*)
|
||||||
(+ j 1))
|
(+ j 1))
|
||||||
(else
|
(else
|
||||||
(string-set! dst
|
(bytevector-u8-set! dst
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(integer->char
|
|
||||||
(bitwise-ior
|
(bitwise-ior
|
||||||
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
|
(arithmetic-shift (extract-bit-field 4 0 b2) 4)
|
||||||
(extract-bit-field 4 2 b3))))
|
(extract-bit-field 4 2 b3)))
|
||||||
(+ j 2))))))
|
(+ j 2))))))
|
||||||
|
|
||||||
;;> Variation of the above to read and write to ports.
|
;;> Variation of the above to read and write to ports.
|
||||||
|
@ -189,15 +191,20 @@
|
||||||
(out (if (and (pair? o) (pair? (cdr o)))
|
(out (if (and (pair? o) (pair? (cdr o)))
|
||||||
(cadr o)
|
(cadr o)
|
||||||
(current-output-port))))
|
(current-output-port))))
|
||||||
(let ((src (make-string decode-src-length))
|
(cond
|
||||||
(dst (make-string decode-dst-length)))
|
((not (binary-port? in))
|
||||||
|
(write-string (base64-decode-string (port->string in)) out))
|
||||||
|
(else
|
||||||
|
(let ((src (make-bytevector decode-src-length))
|
||||||
|
(dst (make-bytevector decode-dst-length)))
|
||||||
(let lp ((offset 0))
|
(let lp ((offset 0))
|
||||||
(let ((src-len (+ offset
|
(let ((src-len
|
||||||
(read-string! decode-src-length src in offset))))
|
(+ offset
|
||||||
|
(read-bytevector! decode-src-length src in offset))))
|
||||||
(cond
|
(cond
|
||||||
((= src-len decode-src-length)
|
((= src-len decode-src-length)
|
||||||
;; read a full chunk: decode, write and loop
|
;; read a full chunk: decode, write and loop
|
||||||
(base64-decode-string!
|
(base64-decode-bytevector!
|
||||||
src 0 decode-src-length dst
|
src 0 decode-src-length dst
|
||||||
(lambda (src-offset dst-len b1 b2 b3)
|
(lambda (src-offset dst-len b1 b2 b3)
|
||||||
(cond
|
(cond
|
||||||
|
@ -205,32 +212,32 @@
|
||||||
(eqv? #\= (string-ref src src-offset)))
|
(eqv? #\= (string-ref src src-offset)))
|
||||||
;; done
|
;; done
|
||||||
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
|
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
|
||||||
(write-string dst out 0 dst-len)))
|
(write-bytevector dst out 0 dst-len)))
|
||||||
((eqv? b1 *outside-char*)
|
((eqv? b1 *outside-char*)
|
||||||
(write-string dst out 0 dst-len)
|
(write-string dst out 0 dst-len)
|
||||||
(lp 0))
|
(lp 0))
|
||||||
(else
|
(else
|
||||||
(write-string dst out 0 dst-len)
|
(write-bytevector dst out 0 dst-len)
|
||||||
;; one to three chars left in buffer
|
;; one to three chars left in buffer
|
||||||
(string-set! src 0 (enc b1))
|
(bytevector-u8-set! src 0 (enc b1))
|
||||||
(cond
|
(cond
|
||||||
((eqv? b2 *outside-char*)
|
((eqv? b2 *outside-char*)
|
||||||
(lp 1))
|
(lp 1))
|
||||||
(else
|
(else
|
||||||
(string-set! src 1 (enc b2))
|
(bytevector-u8-set! src 1 (enc b2))
|
||||||
(cond
|
(cond
|
||||||
((eqv? b3 *outside-char*)
|
((eqv? b3 *outside-char*)
|
||||||
(lp 2))
|
(lp 2))
|
||||||
(else
|
(else
|
||||||
(string-set! src 2 (enc b3))
|
(bytevector-u8-set! src 2 (enc b3))
|
||||||
(lp 3))))))))))
|
(lp 3))))))))))
|
||||||
(else
|
(else
|
||||||
;; end of source - just decode and write once
|
;; end of source - just decode and write once
|
||||||
(base64-decode-string!
|
(base64-decode-bytevector!
|
||||||
src 0 src-len dst
|
src 0 src-len dst
|
||||||
(lambda (src-offset dst-len b1 b2 b3)
|
(lambda (src-offset dst-len b1 b2 b3)
|
||||||
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
|
(let ((dst-len (base64-decode-finish dst dst-len b1 b2 b3)))
|
||||||
(write-string dst out 0 dst-len)))))))))))
|
(write-string dst out 0 dst-len)))))))))))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; encoding
|
;; encoding
|
||||||
|
@ -239,57 +246,65 @@
|
||||||
;;> official base64 standard as described in RFC3548.
|
;;> official base64 standard as described in RFC3548.
|
||||||
|
|
||||||
(define (base64-encode-string str)
|
(define (base64-encode-string str)
|
||||||
(let* ((len (string-length str))
|
(utf8->string (base64-encode-bytevector (string->utf8 str))))
|
||||||
|
|
||||||
|
(define (base64-encode-bytevector bv)
|
||||||
|
(let* ((len (bytevector-length bv))
|
||||||
(quot (quotient len 3))
|
(quot (quotient len 3))
|
||||||
(rem (- len (* quot 3)))
|
(rem (- len (* quot 3)))
|
||||||
(res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2))
|
(res-len (arithmetic-shift (+ quot (if (zero? rem) 0 1)) 2))
|
||||||
(res (make-string res-len)))
|
(res (make-bytevector res-len)))
|
||||||
(base64-encode-string! str 0 len res)
|
(base64-encode-bytevector! bv 0 len res)
|
||||||
res))
|
res))
|
||||||
|
|
||||||
(define (base64-encode-string! str start end res)
|
(define (base64-encode-bytevector! bv start end res)
|
||||||
(let* ((res-len (string-length res))
|
(let* ((res-len (bytevector-length res))
|
||||||
(limit (- end 2)))
|
(limit (- end 2)))
|
||||||
(let lp ((i start) (j 0))
|
(let lp ((i start) (j 0))
|
||||||
(if (>= i limit)
|
(if (>= i limit)
|
||||||
(case (- end i)
|
(case (- end i)
|
||||||
((1)
|
((1)
|
||||||
(let ((b1 (char->integer (string-ref str i))))
|
(let ((b1 (bytevector-u8-ref bv i)))
|
||||||
(string-set! res j (enc (arithmetic-shift b1 -2)))
|
(bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
|
||||||
(string-set! res
|
(bytevector-u8-set!
|
||||||
|
res
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
|
(enc (arithmetic-shift (bitwise-and #b11 b1) 4)))
|
||||||
(string-set! res (+ j 2) #\=)
|
(bytevector-u8-set! res (+ j 2) (char->integer #\=))
|
||||||
(string-set! res (+ j 3) #\=)))
|
(bytevector-u8-set! res (+ j 3) (char->integer #\=))))
|
||||||
((2)
|
((2)
|
||||||
(let ((b1 (char->integer (string-ref str i)))
|
(let ((b1 (bytevector-u8-ref bv i))
|
||||||
(b2 (char->integer (string-ref str (+ i 1)))))
|
(b2 (bytevector-u8-ref bv (+ i 1))))
|
||||||
(string-set! res j (enc (arithmetic-shift b1 -2)))
|
(bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
|
||||||
(string-set! res
|
(bytevector-u8-set!
|
||||||
|
res
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(enc (bitwise-ior
|
(enc (bitwise-ior
|
||||||
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
||||||
(extract-bit-field 4 4 b2))))
|
(extract-bit-field 4 4 b2))))
|
||||||
(string-set! res
|
(bytevector-u8-set!
|
||||||
|
res
|
||||||
(+ j 2)
|
(+ j 2)
|
||||||
(enc (arithmetic-shift (extract-bit-field 4 0 b2)
|
(enc (arithmetic-shift (extract-bit-field 4 0 b2)
|
||||||
2)))
|
2)))
|
||||||
(string-set! res (+ j 3) #\=))))
|
(bytevector-u8-set! res (+ j 3) (char->integer #\=)))))
|
||||||
(let ((b1 (char->integer (string-ref str i)))
|
(let ((b1 (bytevector-u8-ref bv i))
|
||||||
(b2 (char->integer (string-ref str (+ i 1))))
|
(b2 (bytevector-u8-ref bv (+ i 1)))
|
||||||
(b3 (char->integer (string-ref str (+ i 2)))))
|
(b3 (bytevector-u8-ref bv (+ i 2))))
|
||||||
(string-set! res j (enc (arithmetic-shift b1 -2)))
|
(bytevector-u8-set! res j (enc (arithmetic-shift b1 -2)))
|
||||||
(string-set! res
|
(bytevector-u8-set!
|
||||||
|
res
|
||||||
(+ j 1)
|
(+ j 1)
|
||||||
(enc (bitwise-ior
|
(enc (bitwise-ior
|
||||||
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
(arithmetic-shift (bitwise-and #b11 b1) 4)
|
||||||
(extract-bit-field 4 4 b2))))
|
(extract-bit-field 4 4 b2))))
|
||||||
(string-set! res
|
(bytevector-u8-set!
|
||||||
|
res
|
||||||
(+ j 2)
|
(+ j 2)
|
||||||
(enc (bitwise-ior
|
(enc (bitwise-ior
|
||||||
(arithmetic-shift (extract-bit-field 4 0 b2) 2)
|
(arithmetic-shift (extract-bit-field 4 0 b2) 2)
|
||||||
(extract-bit-field 2 6 b3))))
|
(extract-bit-field 2 6 b3))))
|
||||||
(string-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
|
(bytevector-u8-set! res (+ j 3) (enc (bitwise-and #b111111 b3)))
|
||||||
(lp (+ i 3) (+ j 4)))))))
|
(lp (+ i 3) (+ j 4)))))))
|
||||||
|
|
||||||
;;> Variation of the above to read and write to ports.
|
;;> Variation of the above to read and write to ports.
|
||||||
|
@ -299,15 +314,19 @@
|
||||||
(out (if (and (pair? o) (pair? (cdr o)))
|
(out (if (and (pair? o) (pair? (cdr o)))
|
||||||
(cadr o)
|
(cadr o)
|
||||||
(current-output-port))))
|
(current-output-port))))
|
||||||
|
(cond
|
||||||
|
((not (binary-port? in))
|
||||||
|
(write-string (base64-encode-string (port->string in)) out))
|
||||||
|
(else
|
||||||
(let ((src (make-string encode-src-length))
|
(let ((src (make-string encode-src-length))
|
||||||
(dst (make-string
|
(dst (make-string
|
||||||
(arithmetic-shift (quotient encode-src-length 3) 2))))
|
(arithmetic-shift (quotient encode-src-length 3) 2))))
|
||||||
(let lp ()
|
(let lp ()
|
||||||
(let ((n (read-string! 2048 src in)))
|
(let ((n (read-bytevector! src in 0 2048)))
|
||||||
(base64-encode-string! src 0 n dst)
|
(base64-encode-bytevector! src 0 n dst)
|
||||||
(write-string dst out 0 (* 3 (quotient (+ n 3) 4)))
|
(write-bytevector dst out 0 (* 3 (quotient (+ n 3) 4)))
|
||||||
(if (= n 2048)
|
(if (= n 2048)
|
||||||
(lp)))))))
|
(lp)))))))))
|
||||||
|
|
||||||
;;> Return a base64 encoded representation of the string \var{str} as
|
;;> Return a base64 encoded representation of the string \var{str} as
|
||||||
;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
|
;;> above, wrapped in =?ENC?B?...?= as per RFC1522, split across
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
|
|
||||||
(define-library (chibi base64)
|
(define-library (chibi base64)
|
||||||
(export base64-encode base64-encode-string
|
(export base64-encode base64-encode-string base64-encode-bytevector
|
||||||
base64-decode base64-decode-string
|
base64-decode base64-decode-string base64-decode-bytevector
|
||||||
base64-encode-header)
|
base64-encode-header)
|
||||||
(import (chibi) (srfi 33) (chibi io))
|
(import (scheme base) (srfi 33) (chibi io)
|
||||||
|
(only (chibi) string-concatenate))
|
||||||
(include "base64.scm"))
|
(include "base64.scm"))
|
||||||
|
|
40
tests/base64-tests.scm
Normal file
40
tests/base64-tests.scm
Normal file
|
@ -0,0 +1,40 @@
|
||||||
|
|
||||||
|
(import (chibi) (chibi base64) (chibi test))
|
||||||
|
|
||||||
|
(test-begin "base64")
|
||||||
|
|
||||||
|
(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
|
||||||
|
(base64-encode-string "any carnal pleasure."))
|
||||||
|
(test "YW55IGNhcm5hbCBwbGVhc3VyZQ=="
|
||||||
|
(base64-encode-string "any carnal pleasure"))
|
||||||
|
(test "YW55IGNhcm5hbCBwbGVhc3Vy"
|
||||||
|
(base64-encode-string "any carnal pleasur"))
|
||||||
|
(test "YW55IGNhcm5hbCBwbGVhc3U="
|
||||||
|
(base64-encode-string "any carnal pleasu"))
|
||||||
|
(test "YW55IGNhcm5hbCBwbGVhcw=="
|
||||||
|
(base64-encode-string "any carnal pleas"))
|
||||||
|
|
||||||
|
(test "any carnal pleas"
|
||||||
|
(base64-decode-string "YW55IGNhcm5hbCBwbGVhcw=="))
|
||||||
|
(test "any carnal pleasu"
|
||||||
|
(base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U="))
|
||||||
|
(test "any carnal pleasur"
|
||||||
|
(base64-decode-string "YW55IGNhcm5hbCBwbGVhc3Vy"))
|
||||||
|
(test "any carnal pleas"
|
||||||
|
(base64-decode-string "YW55IGNhcm5hbCBwbGVhcw"))
|
||||||
|
(test "any carnal pleasu"
|
||||||
|
(base64-decode-string "YW55IGNhcm5hbCBwbGVhc3U"))
|
||||||
|
|
||||||
|
(test "YW55IGNhcm5hbCBwbGVhc3VyZS4="
|
||||||
|
(call-with-output-string
|
||||||
|
(lambda (out)
|
||||||
|
(call-with-input-string "any carnal pleasure."
|
||||||
|
(lambda (in) (base64-encode in out))))))
|
||||||
|
|
||||||
|
(test "any carnal pleasure."
|
||||||
|
(call-with-output-string
|
||||||
|
(lambda (out)
|
||||||
|
(call-with-input-string "YW55IGNhcm5hbCBwbGVhc3VyZS4="
|
||||||
|
(lambda (in) (base64-decode in out))))))
|
||||||
|
|
||||||
|
(test-end)
|
Loading…
Add table
Reference in a new issue