source: project/release/5/base64/trunk/base64.scm @ 35640

Last change on this file since 35640 was 35640, checked in by felix winkelmann, 2 years ago

base64 egg for C5

File size: 16.6 KB
Line 
1;; Copyright (c) 2004 James Bailey (dgym.REMOVE_THIS.bailey@gmail.com).
2;; Copyright (c) 2009 Jim Ursetto.
3;;
4;; Permission is hereby granted, free of charge, to any person obtaining a
5;; copy of this software and associated documentation files (the "Software"), to
6;; deal in the Software without restriction, including without limitation the
7;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
8;; sell copies of the Software, and to permit persons to whom the Software is
9;; furnished to do so, subject to the following conditions:
10;;
11;; The above copyright notice and this permission notice shall be included in all
12;; copies or substantial portions of the Software.
13;;
14;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
17;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
19;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20;; SOFTWARE.
21
22;; base64 routines for bigloo, apart from the module info, bit routines, "when"
23;; and fixed division "/fx" it should be slightly portable
24
25;; Ported to CHICKEN by felix
26;; Rewritten for CHICKEN by Jim Ursetto.  Notes:
27;;  Local anonymous functions (bits-at) are not inlined; use define-inline. (removed, because define-inline does not respect local scoping)
28;;  Toplevel tables moved to lexical scope.
29;;  Encode algorithm moves the test for 1 or 2 remaining bytes out
30;;  of the main loop; generates -significantly- better code under Chicken.
31;;  Decode algorithm rewritten as state machine; invalid input is
32;;  silently skipped.
33;;  Compiling with -unsafe is HIGHLY recommended, and gains more benefit
34;;  as your inner loop gets tighter.
35;;  The optimized variants are almost on par with pure C.
36;;  Encoding and decoding can now operate on ports.
37
38(declare (fixnum))
39
40(module base64
41  (base64-encode base64-decode base64-line-breaks)
42
43  (import scheme chicken.base chicken.bitwise chicken.fixnum
44          (only chicken.io read-string!)
45          (only srfi-13 string-concatenate-reverse))
46
47;; If base64-line-breaks is true, a CRLF is inserted every
48;; 76 output chars (57 input chars) and at the end of the last
49;; line, if it was partial (between 1 and 75 output chars).
50(define base64-line-breaks (make-parameter #f))
51
52;; Optimized string->string implementation
53(define (base64-encode/string->string str)
54  (define (bits-at idx)
55    (char->integer (string-ref str idx)))
56  (define (b64->char n)
57    (define enc-table
58      '#(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
59         #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
60         #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
61         #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
62         #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\/))
63    (vector-ref enc-table (bitwise-and n 63)))
64
65  (define (encode-tail out i o r)
66    ;; Handle last 1 or 2 bytes
67    (case r
68      ((0) o)
69      ((1)
70       (let ((n (arithmetic-shift (bits-at i) 16)))
71         (string-set! out o (b64->char (arithmetic-shift n -18)))
72         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
73         (+ o 4)))
74      ((2)
75       (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
76                             (arithmetic-shift (bits-at (+ i 1)) 8))))
77         (string-set! out o (b64->char (arithmetic-shift n -18)))
78         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
79         (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
80         (+ o 4)))))
81
82  (##sys#check-string str 'base64-encode)
83  (let ((l (string-length str)))
84    (let* ((nobreak? (not (base64-line-breaks)))
85           (outlen (* 4 (fx/ (+ l 2) 3)))
86           (full-lines (fx/ l 57))
87           (partial-line (not (= 0 (fxmod l 57))))
88           (outlen (if nobreak?
89                       outlen
90                       (+ outlen (fx* 2 (+ full-lines
91                                           (if partial-line 1 0))))))
92           (out (make-string outlen #\=)))
93      (let ((o
94             (let loop ((i 0) (o 0) (r l) (c 1))
95               (if (< r 3)
96                   (encode-tail out i o r)
97                   (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
98                                         (arithmetic-shift (bits-at (+ i 1)) 8)
99                                         (bits-at (+ i 2)))))
100                     (string-set! out o       (b64->char (arithmetic-shift n -18)))
101                     (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
102                     (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
103                     (string-set! out (+ o 3) (b64->char n))
104                     (cond (nobreak?
105                            (loop (+ i 3) (+ o 4) (- r 3) c))
106                           ((< c 19)  ; 57/3 = 76/4 = 19
107                            (loop (+ i 3) (+ o 4) (- r 3) (+ c 1)))
108                           (else
109                            (string-set! out (+ o 4) #\return)
110                            (string-set! out (+ o 5) #\newline)
111                            (loop (+ i 3) (+ o 6) (- r 3) 1)))
112                     )))))
113        (when (and (not nobreak?)
114                   partial-line)
115          (string-set! out o #\return)
116          (string-set! out (+ o 1) #\newline))
117        out))))
118
119(define (base64-encode in #!optional out)
120  (define (port-to-port in out)
121    (let* ((buflen (* 57 60))
122           (buf (make-string buflen)))
123      (let lp ()
124        (let ((n (read-string! buflen buf in)))
125          (cond ((= n 0) out)
126                (else
127                 (display (base64-encode/string->string
128                           (if (< n buflen) (substring buf 0 n) buf))
129                          out)
130                 (lp)))))))
131  (define (port-to-string in)
132    ;; easier on GC than (let ((out (open-output-string)))
133    ;;                     (get-output-string (port-to-port in out)))
134    (let* ((buflen (* 57 60))
135           (buf (make-string buflen)))
136      (let lp ((lines '()))
137        (let ((n (read-string! buflen buf in)))
138          (cond ((= n 0)
139                 (string-concatenate-reverse lines))
140                (else
141                 (lp (cons (base64-encode/string->string
142                            (if (< n buflen) (substring buf 0 n) buf))
143                           lines))))))))
144  (if (port? out)
145      (if (string? in)
146          (port-to-port (open-input-string in) out)
147          (port-to-port in out))     
148      (if (string? in)
149          (base64-encode/string->string in)
150          (port-to-string in))))
151
152;; (define (calc-dec-table)
153;;    (let ((res (make-vector 256 -1)))
154;;      (do ((i 0 (+ i 1)))
155;;          ((>= i 64))
156;;        (vector-set! res (char->integer (vector-ref enc-table i)) i))
157;;      res))
158
159
160;; Optimized string->string decoder implementation.  A bit faster than
161;; the partial decoder--part of which is less garbage generation due
162;; to a better string length guess in the best possible case--but the
163;; partial decoder is more general.  So we will probably drop this.
164;; It's not currently used.
165(define (base64-decode/string->string str)
166  (define (bits-at idx)
167    (define dec-table
168         '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
169            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
170            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 62 -1 -1 -1 63
171            52 53 54 55 56 57 58 59 60 61 -1 -1 -1 -1 -1 -1
172            -1  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14
173            15 16 17 18 19 20 21 22 23 24 25 -1 -1 -1 -1 -1
174            -1 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
175            41 42 43 44 45 46 47 48 49 50 51 -1 -1 -1 -1 -1
176            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
177            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
178            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
179            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
180            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
181            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
182            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
183            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1))
184    (vector-ref dec-table (char->integer (string-ref str idx))))
185  (define (int->char n)
186    (integer->char (bitwise-and n 255)))
187  ;; Guess upper bound for string length--assumes no invalid characters
188  ;; encountered, and checks the last two chars for validity
189  ;; in strings of length 4n.
190  (define (guess-out-length l)           ; assumes L > 0
191    (let ((floored (fx* 4 (fx/ l 4))))
192      (+ (fx* 3 (fx/ l 4))
193         (cond ((not (= l floored)) 3)
194               (else
195                (if (= -1 (bits-at (- l 1)))
196                    (if (= -1 (bits-at (- l 2))) -2 -1)
197                    0))))))
198
199  (##sys#check-string str 'base64-decode)
200  (let ((l (string-length str)))
201    (if (= l 0)
202        str
203        (let* ((outlen (guess-out-length l))  ; avoid substring if possible
204               (out (make-string outlen))
205               (o 
206                (let loop ((i 0) (o 0) (state 0) (n 0))
207                  (if (>= i l)
208                      o
209                      (let ((b (bits-at i)))
210                        (if (= -1 b)
211                            (loop (+ i 1) o state n)
212                            (case state
213                              ((0) (loop (+ i 1) o 1 b))
214                              ((1) (let ((n (bitwise-ior b (arithmetic-shift n 6))))
215                                     (string-set! out o (int->char (arithmetic-shift n -4)))
216                                     (loop (+ i 1) (+ o 1) 2 n)))
217                              ((2) (let ((n (bitwise-ior b (arithmetic-shift n 6))))
218                                     (string-set! out o (int->char (arithmetic-shift n -2)))
219                                     (loop (+ i 1) (+ o 1) 3 n)))
220                              (else (let ((n (bitwise-ior b (arithmetic-shift n 6))))
221                                      (string-set! out o (int->char n))
222                                      (loop (+ i 1) (+ o 1) 0 0))))))))))
223          ;; Pull this out of the loop; otherwise the code is pessimized.
224          (if (= outlen o)
225              out
226              (substring out 0 o))))))
227
228(define (base64-decode in #!optional out)
229  (define (port-to-port in out)
230    (let* ((buflen 4096)
231           (buf (make-string buflen))
232           (st (vector 0 0 0 0)))
233      (let lp ()
234        (let ((n (read-string! buflen buf in)))
235          (cond ((< n buflen)   ; works for ""
236                 (display (base64-decode-partial (substring buf 0 n)
237                                                 st #f)
238                          out)
239                 out)
240                (else
241                 (display (base64-decode-partial buf st #t)
242                          out)
243                 (lp)))))))
244  (define (port-to-string in)
245    (let* ((buflen 4096)
246           (buf (make-string buflen))
247           (st (vector 0 0 0 0)))
248      (let lp ((lines '()))
249        (let ((n (read-string! buflen buf in)))
250          (cond ((< n buflen)
251                 (string-concatenate-reverse
252                  (cons (base64-decode-partial (substring buf 0 n) st #f)
253                        lines)))
254                (else
255                 (lp (cons (base64-decode-partial buf st #t)
256                           lines))))))))
257  (if (port? out)
258      (if (string? in)
259          (port-to-port (open-input-string in) out)
260          (port-to-port in out))
261      (if (string? in)
262;;           (base64-decode/string->string in)
263          (let ((st (vector 0 0 0 0)))
264            (base64-decode-partial in st #f))
265          (port-to-string in))))
266
267;; Incremental base64 decoder
268;; Requires initial state vector st: #(state c1 c2 c3)
269;; Returns: str; mutates state vector st when more?.
270;; If a full 4 encoded characters are not available, AND there is
271;; possibly more data, we cannot decode the remaining chars.  We must
272;; retain up to 3 input characters along with the current
273;; input state, so the decoder may be restarted where it left off.
274(define (base64-decode-partial str st more?)
275  (define (bits-at idx)
276    (define dec-table
277      '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
278            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
279            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 62 -1 -1 -1 63
280            52 53 54 55 56 57 58 59 60 61 -1 -1 -1 -1 -1 -1
281            -1  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14
282            15 16 17 18 19 20 21 22 23 24 25 -1 -1 -1 -1 -1
283            -1 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
284            41 42 43 44 45 46 47 48 49 50 51 -1 -1 -1 -1 -1
285            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
286            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
287            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
288            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
289            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
290            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
291            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
292            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1))
293    (vector-ref dec-table (char->integer (string-ref str idx))))
294  (define (int->char n)
295    (integer->char (bitwise-and n 255)))
296  ;; Upper bound for string length--nothing fancy for partial reads.
297  ;; But add state (# of chars pending) to input length.
298  (define (guess-out-length len state)
299    (let ((c (+ state len)))
300      (if (= 0 (bitwise-and c 3))   ; (fxmod c 4)
301          (fx* 3 (fx/ c 4))
302          (fx* 3 (+ 1 (fx/ c 4))))))
303
304  ;; When no MORE? data, write out the remaining chars.
305  (define (decode-tail out o state c1 c2 c3)
306    (case state
307      ((0 1) o)
308      ((2) (let ((n (bitwise-ior (arithmetic-shift c1 18)
309                                 (arithmetic-shift c2 12))))
310             (string-set! out o       (int->char (arithmetic-shift n -16)))
311             (+ o 1)))
312      ((3) (let ((n (bitwise-ior
313                     (bitwise-ior (arithmetic-shift c1 18)
314                                  (arithmetic-shift c2 12))
315                     (arithmetic-shift c3 6))))
316             (string-set! out o       (int->char (arithmetic-shift n -16)))
317             (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
318             (+ o 2)))))
319
320  ;; Finish up.  The state vector has already been updated unconditionally;
321  ;; write the remaining chars into the buffer if we expect no more data.  Return
322  ;; the buffer, truncating if necessary.
323  (define (do-tail out o st)
324    (let ((o (if more? o
325                 (decode-tail out o
326                              (vector-ref st 0)
327                              (vector-ref st 1)
328                              (vector-ref st 2)
329                              (vector-ref st 3)))))
330      (if (= o (string-length out))
331          out
332          (substring out 0 o))))
333 
334  (##sys#check-string str 'base64-decode)
335  (let* ((len (string-length str))
336         (state (vector-ref st 0))
337         (outlen (guess-out-length len state))
338         (out (make-string outlen)))
339    (let ((o
340           (let loop ((i 0) (o 0) (state state)
341                      (c1 (vector-ref st 1))
342                      (c2 (vector-ref st 2))
343                      (c3 (vector-ref st 3)))
344             (cond ((>= i len)
345                    (vector-set! st 0 state)
346                    (vector-set! st 1 c1)
347                    (vector-set! st 2 c2)
348                    (vector-set! st 3 c3)
349                    o)
350                   (else
351                    (let ((c (bits-at i)))
352                      (if (= -1 c)
353                          (loop (+ i 1) o state c1 c2 c3)
354                          (case state
355                            ((0) (loop (+ i 1) o 1 c  c2 c3))
356                            ((1) (loop (+ i 1) o 2 c1 c  c3))
357                            ((2) (loop (+ i 1) o 3 c1 c2 c ))
358                            (else
359                             (let ((n (bitwise-ior
360                                       (bitwise-ior (arithmetic-shift c1 18)
361                                                    (arithmetic-shift c2 12))
362                                       (bitwise-ior (arithmetic-shift c3 6)
363                                                    c))))
364                               (string-set! out o       (int->char (arithmetic-shift n -16)))
365                               (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
366                               (string-set! out (+ o 2) (int->char n))
367                               (loop (+ i 1) (+ o 3) 0 c1 c2 c3)))))))))))
368      ;; Pull out of loop to avoid stack probe and interrupt check
369      ;; causing > 2x slowdown.  decode-tail arguments must then
370      ;; be pulled from the state vector.
371      (do-tail out o st))))
372
373)
Note: See TracBrowser for help on using the repository browser.