source: project/stream-base64/stream-base64.scm @ 1

Last change on this file since 1 was 1, checked in by azul, 15 years ago

Import everything.

File size: 2.4 KB
Line 
1;; $Id: stream-base64.scm 1578 2005-03-14 02:39:56Z azul $
2;;
3;; This file is in the public domain and may be reproduced or copied without
4;; permission from its author.  Citation of the source is appreciated.
5;;
6;; Alejandro Forero Cuervo <bachue@bachue.com>
7;;
8;; This file implements an egg for Chicken Scheme that allows you to decode
9;; a stream with a Base64 encoding.
10;;
11;; Documentation is available in HTML format.
12;;
13;; Newer versions might be available at:
14;;
15;;    http://anonymous:@afc.no-ip.info:8000/svn/home/src/chicken-eggs/base64
16;;
17;; Version history:
18;;
19;; 1.0 (r1578) - First public release
20
21
22(declare (export base64-decode base64-encode))
23(require-extension srfi-40 stream-ext)
24
25(define *alphabet* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
26
27(define *digits*
28  (list->vector
29    (list-tabulate 255 (lambda (i) (substring-index (string (integer->char i)) *alphabet*)))))
30
31(define (dig->num x) (vector-ref *digits* x))
32(define (num->dig x) (string-ref *alphabet* (bitwise-and x 63)))
33
34(define (transform chars-read read-trans bits-in out-get-val flush-all bits-out stop)
35  (lambda (in)
36    (let loop ((in in))
37      (stream-delay
38        (let-values (((num reads rest) (accum in chars-read read-trans bits-in)))
39          (if (zero? reads)
40            stream-null
41            (show-output out-get-val flush-all bits-out num (* reads bits-in) (if (< reads chars-read) (stop reads) (loop rest)))))))))
42
43(define base64-decode
44  (transform 4 dig->num 6 (lambda (i) (integer->char (bitwise-and i 255))) #f 8 (constantly stream-null)))
45
46(define base64-encode
47  (transform 3 identity 8 num->dig #t 6 (lambda (r) (make-stream (- 3 r) #\=))))
48
49(define (accum in stop getval shift)
50  (let loop ((str in) (num 0) (bytes 0))
51    (if (or (= bytes stop) (stream-null? str))
52      (values num bytes str)
53      (let ((value (getval (char->integer (stream-car str)))))
54        (if value
55          (loop (stream-cdr str) (bitwise-ior value (arithmetic-shift num shift)) (+ bytes 1))
56          (loop (stream-cdr str) num bytes))))))
57
58(define (show-output getval flush-all bits-char num bits-left tail)
59  (let loop ((left bits-left))
60    (stream-delay
61      (if (if flush-all (<= left 0) (< left bits-char))
62        tail
63        (stream-cons (getval (arithmetic-shift num (- bits-char left)))
64          (loop (- left bits-char)))))))
65
Note: See TracBrowser for help on using the repository browser.