diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-23 16:31:55 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-23 16:31:55 +0200 |
commit | b866096e7a84f59b33b90fc2e7875e2969b05df2 (patch) | |
tree | 225b88955d1314a8100dad8602d13c7933cca0f6 /module/util/base64.scm | |
parent | Remove custom if + *unspecified*. (diff) | |
download | calp-b866096e7a84f59b33b90fc2e7875e2969b05df2.tar.gz calp-b866096e7a84f59b33b90fc2e7875e2969b05df2.tar.xz |
Base64 now free floating top level.
Diffstat (limited to 'module/util/base64.scm')
-rw-r--r-- | module/util/base64.scm | 156 |
1 files changed, 0 insertions, 156 deletions
diff --git a/module/util/base64.scm b/module/util/base64.scm deleted file mode 100644 index 148055c9..00000000 --- a/module/util/base64.scm +++ /dev/null @@ -1,156 +0,0 @@ -(define-module (util base64) - :use-module (util) - :use-module ((rnrs bytevectors) - :select (bytevector-u8-ref - bytevector-u8-set! - bytevector-length - make-bytevector)) - :use-module ((rnrs io ports) - :select (string->bytevector - bytevector->string - make-transcoder - latin-1-codec - native-transcoder))) - -(define table - (list->vector - (map char->integer - (string->list - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")))) - -(define (real->encoded byte) - (vector-ref table byte)) - -(define (encoded->real byte) - (define A (char->integer #\A)) - (define Z (char->integer #\Z)) - (define a (char->integer #\a)) - (define z (char->integer #\z)) - (define zero (char->integer #\0)) - (define nine (char->integer #\9)) - (cond [(= byte (char->integer #\=)) 0] - [(= byte (char->integer #\+)) 62] - [(= byte (char->integer #\/)) 63] - [(<= A byte Z) - (- byte A)] - [(<= a byte z) - (+ 26 (- byte a))] - [(<= zero byte nine) - (+ 26 26 (- byte zero))] - [else (error "Invalid encoded value" byte (integer->char byte))])) - -(define ref - (make-procedure-with-setter - bytevector-u8-ref - bytevector-u8-set!)) - -(define-public (base64->bytevector bv) - (let ((len* (bytevector-length bv))) - (if (zero? len*) - (make-bytevector 0) - (let* ((rest (+ (if (= (char->integer #\=) (ref bv (- len* 1))) - 1 0) - (if (= (char->integer #\=) (ref bv (- len* 2))) - 1 0))) - (x (/ (- len* rest) 4)) - (ret-len (floor (* 3 x)))) - - (define ret (make-bytevector ret-len)) - - (do ((i 0 (1+ i))) - ((>= i (floor x))) - (let ((a (encoded->real (ref bv (+ (* i 4) 0)))) - (b (encoded->real (ref bv (+ (* i 4) 1)))) - (c (encoded->real (ref bv (+ (* i 4) 2)))) - (d (encoded->real (ref bv (+ (* i 4) 3))))) - (let ((aa (logior (ash a 2) (ash b -4))) - (ab (logior (ash (logand b #xF) 4) (ash c -2))) - (ac (logior (ash (logand c 3) 6) d))) - - (set! (ref ret (+ (* i 3) 0)) aa - (ref ret (+ (* i 3) 1)) ab - (ref ret (+ (* i 3) 2)) ac)))) - - - (case rest - [(2) - (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0)))) - (b (encoded->real (ref bv (+ (* (floor x) 4) 1))))) - (let ((aa (logior (ash a 2) (ash b -4)))) - (set! (ref ret (- ret-len 1)) aa)))] - [(1) - (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0)))) - (b (encoded->real (ref bv (+ (* (floor x) 4) 1)))) - (c (encoded->real (ref bv (+ (* (floor x) 4) 2))))) - (let ((aa (logior (ash a 2) (ash b -4))) - (ab (logior (ash (logand b #xF) 4) (ash c -2)))) - (set! (ref ret (- ret-len 2)) aa - (ref ret (- ret-len 1)) ab)))]) - - ret)))) - -(define-public (bytevector->base64 bv) - (let* ((len (bytevector-length bv)) - (iterations rest (floor/ len 3))) - (define ret (make-bytevector (+ (* 4 iterations) - (if (zero? rest) - 0 4)))) - - (do ((i 0 (1+ i))) - ((>= i iterations)) - (let ((a (ref bv (+ (* i 3) 0))) - (b (ref bv (+ (* i 3) 1))) - (c (ref bv (+ (* i 3) 2)))) - (let ((aa (ash a -2)) - (ab (logior (ash (logand #b11 a) 4) (ash b -4))) - (ac (logior (ash (logand b #b1111) 2) (ash c -6))) - (ad (logand c #x3F))) - (set! (ref ret (+ (* i 4) 0)) (real->encoded aa) - (ref ret (+ (* i 4) 1)) (real->encoded ab) - (ref ret (+ (* i 4) 2)) (real->encoded ac) - (ref ret (+ (* i 4) 3)) (real->encoded ad))))) - - (case rest - [(1) - (let ((byte (ref bv (- len 1)))) - (let ((a (ash byte -2)) - (b (ash (logand byte 3) 4))) - (set! (ref ret (+ 0 (* 4 iterations))) (real->encoded a) - (ref ret (+ 1 (* 4 iterations))) (real->encoded b) - (ref ret (+ 2 (* 4 iterations))) (char->integer #\=) - (ref ret (+ 3 (* 4 iterations))) (char->integer #\=))))] - [(2) - (let ((byte1 (ref bv (- len 2))) - (byte2 (ref bv (- len 1)))) - (let ((a (ash byte1 -2)) - (b (logior (ash (logand byte1 3) 4) (ash byte2 -4 ))) - (c (ash (logand byte2 #xF) 2))) - (set! (ref ret (+ 0 (* 4 iterations))) (real->encoded a) - (ref ret (+ 1 (* 4 iterations))) (real->encoded b) - (ref ret (+ 2 (* 4 iterations))) (real->encoded c) - (ref ret (+ 3 (* 4 iterations))) (char->integer #\=))))]) - - ret)) - -;; string -> bv -(define-public (base64-string->bytevector string) - (base64->bytevector - (string->bytevector string (make-transcoder (latin-1-codec))))) - -;; bv -> string -(define-public (bytevector->base64-string bv) - (bytevector->string (bytevector->base64 bv) - (make-transcoder (latin-1-codec)))) - -;; string -> string -(define*-public (base64encode string optional: (transcoder (native-transcoder))) - (bytevector->string - (bytevector->base64 (string->bytevector string transcoder)) - (make-transcoder (latin-1-codec)))) - -;; string -> string -(define*-public (base64decode string optional: (transcoder (native-transcoder))) - (bytevector->string - (base64->bytevector - (string->bytevector string (make-transcoder (latin-1-codec)))) - transcoder)) |