;; Copyright (c) 2004 James Bailey (dgym.REMOVE_THIS.bailey@gmail.com). ;; Copyright (c) 2009 Jim Ursetto. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in all ;; copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. ;; base64 routines for bigloo, apart from the module info, bit routines, "when" ;; and fixed division "/fx" it should be slightly portable ;; Ported to CHICKEN by felix ;; Optimized for CHICKEN by Jim Ursetto. Optimization notes: ;; Local anonymous functions (bits-at) are not inlined; use define-inline. ;; Toplevel tables moved to lexical scope. ;; Encode algorithm moves the test for 1 or 2 remaining bytes out ;; of the main loop; generates -significantly- better code under Chicken. ;; Decode algorithm rewritten as state machine; invalid input is ;; silently skipped. ;; Compiling with -unsafe is HIGHLY recommended, and gains more benefit ;; as your inner loop gets tighter. ;; The optimized variants are almost on par with pure C. (declare (fixnum)) (module base64 (base64-encode base64-decode) ;; base64-decode/lax (import scheme chicken) (define (base64-encode str) (define-inline (bits-at idx) (char->integer (string-ref str idx))) (define-inline (b64->char n) (define enc-table '#(#\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 #\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 #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\/)) (vector-ref enc-table (bitwise-and n 63))) (define (encode-tail out i o r) ;; Handle last 1 or 2 bytes (case r ((0) out) ((1) (let ((n (arithmetic-shift (bits-at i) 16))) (string-set! out o (b64->char (arithmetic-shift n -18))) (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12))) out)) ((2) (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16) (arithmetic-shift (bits-at (+ i 1)) 8)))) (string-set! out o (b64->char (arithmetic-shift n -18))) (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12))) (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6))) out)))) (##sys#check-string str 'base64:encode) (let* ((l (string-length str)) (out (make-string (* 4 (/ (+ l 2) 3)) #\=))) (do ((i 0 (+ i 3)) (o 0 (+ o 4)) (r l (- r 3))) ((< r 3) (encode-tail out i o r)) (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16) (arithmetic-shift (bits-at (+ i 1)) 8) (bits-at (+ i 2))))) (string-set! out o (b64->char (arithmetic-shift n -18))) (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12))) (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6))) (string-set! out (+ o 3) (b64->char n)))))) ;; (define (calc-dec-table) ;; (let ((res (make-vector 256 -1))) ;; (do ((i 0 (+ i 1))) ;; ((>= i 64)) ;; (vector-set! res (char->integer (vector-ref enc-table i)) i)) ;; res)) (define (base64-decode str) (define-inline (bits-at idx) (define dec-table '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 62 -1 -1 -1 63 52 53 54 55 56 57 58 59 60 61 -1 -1 -1 -1 -1 -1 -1 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 -1 -1 -1 -1 -1 -1 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1)) (vector-ref dec-table (char->integer (string-ref str idx)))) (define-inline (int->char n) (integer->char (bitwise-and n 255))) ;; Guess upper bound for string length--assumes no invalid characters ;; encountered, and checks the last two chars for validity ;; in strings of length 4n. (define-inline (guess-out-length l) ; assumes L > 0 (let ((floored (fx* 4 (fx/ l 4)))) (+ (fx* 3 (fx/ l 4)) (cond ((not (= l floored)) 3) (else (if (= -1 (bits-at (- l 1))) (if (= -1 (bits-at (- l 2))) -2 -1) 0)))))) (##sys#check-string str 'base64:decode) (let ((l (string-length str))) (if (= l 0) "" (let* ((outlen (guess-out-length l)) ; avoid substring if possible (out (make-string outlen)) (o (let loop ((i 0) (o 0) (state 0) (n 0)) (if (>= i l) o (let ((b (bits-at i))) (if (= -1 b) (loop (+ i 1) o state n) (case state ((0) (loop (+ i 1) o 1 b)) ((1) (let ((n (bitwise-ior b (arithmetic-shift n 6)))) (string-set! out o (int->char (arithmetic-shift n -4))) (loop (+ i 1) (+ o 1) 2 n))) ((2) (let ((n (bitwise-ior b (arithmetic-shift n 6)))) (string-set! out o (int->char (arithmetic-shift n -2))) (loop (+ i 1) (+ o 1) 3 n))) (else (let ((n (bitwise-ior b (arithmetic-shift n 6)))) (string-set! out o (int->char n)) (loop (+ i 1) (+ o 1) 0 0)))))))))) ;; Pull this out of the loop; otherwise the code is pessimized. (if (= outlen o) out (substring out 0 o)))))) ;; Lax decode which includes invalid characters in input. ;; Around 2x faster. Not exported. (define (base64-decode/lax str) (define-inline (bits-at idx) (define dec-table '#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 62 0 0 0 63 52 53 54 55 56 57 58 59 60 61 0 0 0 0 0 0 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 0 0 0 0 0 0 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) (vector-ref dec-table (char->integer (string-ref str idx)))) (define-inline (int->char n) (integer->char (bitwise-and n 255))) (define (decode-tail out i o r) (case r ((0) out) ((1) (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 18) (arithmetic-shift (bits-at (+ i 1)) 12)))) (string-set! out o (int->char (arithmetic-shift n -16))) out)) ((2) (let ((n (bitwise-ior (bitwise-ior (arithmetic-shift (bits-at i) 18) (arithmetic-shift (bits-at (+ i 1)) 12)) (arithmetic-shift (bits-at (+ i 2)) 6)))) (string-set! out o (int->char (arithmetic-shift n -16))) (string-set! out (+ o 1) (int->char (arithmetic-shift n -8))) out)))) (##sys#check-string str 'base64:decode) (let ((l (string-length str))) (cond ((= l 0) "") ((not (= l (fx* 4 (fx/ l 4)))) (error 'base64:decode "string length must be a multiple of 4" l)) (else (let* ((outlen (- (* 3 (fx/ l 4)) (cond ((char=? (string-ref str (- l 2)) #\=) 2) ((char=? (string-ref str (- l 1)) #\=) 1) (else 0)))) (out (make-string outlen))) (do ((i 0 (+ i 4)) (o 0 (+ o 3)) (r outlen (- r 3))) ((< r 3) (decode-tail out i o r)) ;; take in 4 bytes, making a 24 bit integer (let ((n (bitwise-ior (bitwise-ior (arithmetic-shift (bits-at i) 18) (arithmetic-shift (bits-at (+ i 1)) 12)) (bitwise-ior (arithmetic-shift (bits-at (+ i 2)) 6) (bits-at (+ i 3)))))) ;; now write out 3 bytes at a time (string-set! out o (int->char (arithmetic-shift n -16))) (string-set! out (+ o 1) (int->char (arithmetic-shift n -8))) (string-set! out (+ o 2) (int->char n))))))))) )