source: project/release/3/stream-base64/stream-base64.scm @ 14902

Last change on this file since 14902 was 14902, checked in by azul, 11 years ago

Break base64 lines to make their length shorter than or equal to 76.

File size: 3.0 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 embedded-test)
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(test-group break-lines
47  (test (stream->string (break-lines (string->stream "1234") 2))
48        "12\n34")
49  (test (stream->string (break-lines (string->stream "12345") 2))
50        "12\n34\n5")
51  (test (stream->string (break-lines stream-null 2))
52        ""))
53
54(define (break-lines input len)
55  (stream-append
56    (stream-take-safe input len)
57    (let loop ((input (stream-drop-safe input len)))
58      (if (stream-null? input)
59        stream-null
60        (stream-cons
61          #\newline
62          (stream-append
63            (stream-take-safe input len)
64            (loop (stream-drop-safe input len))))))))
65
66(define base64-encode
67  (break-lines
68    (transform 3 identity 8 num->dig #t 6 (lambda (r) (make-stream (- 3 r) #\=)))
69    76))
70
71(define (accum in stop getval shift)
72  (let loop ((str in) (num 0) (bytes 0))
73    (if (or (= bytes stop) (stream-null? str))
74      (values num bytes str)
75      (let ((value (getval (char->integer (stream-car str)))))
76        (if value
77          (loop (stream-cdr str) (bitwise-ior value (arithmetic-shift num shift)) (+ bytes 1))
78          (loop (stream-cdr str) num bytes))))))
79
80(define (show-output getval flush-all bits-char num bits-left tail)
81  (let loop ((left bits-left))
82    (stream-delay
83      (if (if flush-all (<= left 0) (< left bits-char))
84        tail
85        (stream-cons (getval (arithmetic-shift num (- bits-char left)))
86          (loop (- left bits-char)))))))
87
Note: See TracBrowser for help on using the repository browser.