Changeset 14427 in project


Ignore:
Timestamp:
04/25/09 10:43:39 (10 years ago)
Author:
Jim Ursetto
Message:

base64: support input, output ports in decoder as well

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/base64/trunk/base64.scm

    r14426 r14427  
    164164;;      res))
    165165
     166
     167;; Optimized string->string decoder implementation.  A bit faster than
     168;; the partial decoder--part of which is less garbage generation due
     169;; to a better string length guess in the best possible case--but the
     170;; partial decoder is more general.  So we will probably drop this.
     171;; It's not currently used.
    166172(define (base64-decode/string->string str)
    167173  (define-inline (bits-at idx)
     
    228234
    229235(define (base64-decode in #!optional out)
    230   ; Copy and paste is ugly.
    231236  (define (port-to-port in out)
    232     (let* ((buflen 2048)
    233            (buf (make-string buflen)))
     237    (let* ((buflen 4096)
     238           (buf (make-string buflen))
     239           (st (vector 0 0 0 0)))
    234240      (let lp ()
    235241        (let ((n (read-string! buflen buf in)))
    236           (cond ((= n 0) out)
     242          (cond ((< n buflen)   ; works for ""
     243                 (display (base64-decode-partial (substring buf 0 n)
     244                                                 st #f)
     245                          out)
     246                 out)
    237247                (else
    238                  (display (base64-decode/string->string
    239                            (if (< n buflen) (substring buf 0 n) buf))
     248                 (display (base64-decode-partial buf st #t)
    240249                          out)
    241250                 (lp)))))))
    242251  (define (port-to-string in)
    243     (let* ((buflen 2048)
    244            (buf (make-string buflen)))
     252    (let* ((buflen 4096)
     253           (buf (make-string buflen))
     254           (st (vector 0 0 0 0)))
    245255      (let lp ((lines '()))
    246256        (let ((n (read-string! buflen buf in)))
    247           (cond ((= n 0)
    248                  (string-concatenate-reverse lines))
     257          (cond ((< n buflen)
     258                 (string-concatenate-reverse
     259                  (cons (base64-decode-partial (substring buf 0 n) st #f)
     260                        lines)))
    249261                (else
    250                  (lp (cons (base64-decode/string->string
    251                             (if (< n buflen) (substring buf 0 n) buf))
    252                            lines)))))))) 
     262                 (lp (cons (base64-decode-partial buf st #t)
     263                           lines))))))))
    253264  (if (port? out)
    254       (error 'base64-decode "output port not supported yet")
    255 ;;       (if (string? in)
    256 ;;           (port-to-port (open-input-string in) out)
    257 ;;           (port-to-port in out))
    258265      (if (string? in)
    259           (base64-decode/string->string in)
    260           (error 'base64-decode "input port not supported yet")
    261 ;;           (port-to-string in)
    262           )))
     266          (port-to-port (open-input-string in) out)
     267          (port-to-port in out))
     268      (if (string? in)
     269;;           (base64-decode/string->string in)
     270          (let ((st (vector 0 0 0 0)))
     271            (base64-decode-partial in st #f))
     272          (port-to-string in))))
     273
     274;; Incremental base64 decoder
     275;; Requires initial state vector st: #(state c1 c2 c3)
     276;; Returns: str; mutates state vector st when more?.
     277;; If a full 4 encoded characters are not available, AND there is
     278;; possibly more data, we cannot decode the remaining chars.  We must
     279;; retain up to 3 input characters along with the current
     280;; input state, so the decoder may be restarted where it left off.
     281(define (base64-decode-partial str st more?)
     282  (define-inline (bits-at idx)
     283    (define dec-table
     284      '#(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -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 62 -1 -1 -1 63
     287            52 53 54 55 56 57 58 59 60 61 -1 -1 -1 -1 -1 -1
     288            -1  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14
     289            15 16 17 18 19 20 21 22 23 24 25 -1 -1 -1 -1 -1
     290            -1 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
     291            41 42 43 44 45 46 47 48 49 50 51 -1 -1 -1 -1 -1
     292            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     293            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     294            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     295            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     296            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     297            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     298            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
     299            -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1))
     300    (vector-ref dec-table (char->integer (string-ref str idx))))
     301  (define-inline (int->char n)
     302    (integer->char (bitwise-and n 255)))
     303  ;; Upper bound for string length--nothing fancy for partial reads.
     304  ;; But add state (# of chars pending) to input length.
     305  (define-inline (guess-out-length len state)
     306    (let ((c (+ state len)))
     307      (if (= 0 (bitwise-and c 3))   ; (fxmod c 4)
     308          (fx* 3 (fx/ c 4))
     309          (fx* 3 (+ 1 (fx/ c 4))))))
     310
     311  ;; When no MORE? data, write out the remaining chars.
     312  (define (decode-tail out o state c1 c2 c3)
     313    (case state
     314      ((0 1) o)
     315      ((2) (let ((n (bitwise-ior (arithmetic-shift c1 18)
     316                                 (arithmetic-shift c2 12))))
     317             (string-set! out o       (int->char (arithmetic-shift n -16)))
     318             (+ o 1)))
     319      ((3) (let ((n (bitwise-ior
     320                     (bitwise-ior (arithmetic-shift c1 18)
     321                                  (arithmetic-shift c2 12))
     322                     (arithmetic-shift c3 6))))
     323             (string-set! out o       (int->char (arithmetic-shift n -16)))
     324             (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
     325             (+ o 2)))))
     326
     327  ;; Finish up.  The state vector has already been updated unconditionally;
     328  ;; write the remaining chars into the buffer if we expect no more data.  Return
     329  ;; the buffer, truncating if necessary.
     330  (define-inline (do-tail out o st)
     331    (let ((o (if more? o
     332                 (decode-tail out o
     333                              (vector-ref st 0)
     334                              (vector-ref st 1)
     335                              (vector-ref st 2)
     336                              (vector-ref st 3)))))
     337      (if (= o (string-length out))
     338          out
     339          (substring out 0 o))))
     340 
     341  (##sys#check-string str 'base64-decode)
     342  (let* ((len (string-length str))
     343         (state (vector-ref st 0))
     344         (outlen (guess-out-length len state))
     345         (out (make-string outlen)))
     346    (let ((o
     347           (let loop ((i 0) (o 0) (state state)
     348                      (c1 (vector-ref st 1))
     349                      (c2 (vector-ref st 2))
     350                      (c3 (vector-ref st 3)))
     351             (cond ((>= i len)
     352                    (vector-set! st 0 state)
     353                    (vector-set! st 1 c1)
     354                    (vector-set! st 2 c2)
     355                    (vector-set! st 3 c3)
     356                    o)
     357                   (else
     358                    (let ((c (bits-at i)))
     359                      (if (= -1 c)
     360                          (loop (+ i 1) o state c1 c2 c3)
     361                          (case state
     362                            ((0) (loop (+ i 1) o 1 c  c2 c3))
     363                            ((1) (loop (+ i 1) o 2 c1 c  c3))
     364                            ((2) (loop (+ i 1) o 3 c1 c2 c ))
     365                            (else
     366                             (let ((n (bitwise-ior
     367                                       (bitwise-ior (arithmetic-shift c1 18)
     368                                                    (arithmetic-shift c2 12))
     369                                       (bitwise-ior (arithmetic-shift c3 6)
     370                                                    c))))
     371                               (string-set! out o       (int->char (arithmetic-shift n -16)))
     372                               (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
     373                               (string-set! out (+ o 2) (int->char n))
     374                               (loop (+ i 1) (+ o 3) 0 c1 c2 c3)))))))))))
     375      ;; Pull out of loop to avoid stack probe and interrupt check
     376      ;; causing > 2x slowdown.  decode-tail arguments must then
     377      ;; be pulled from the state vector.
     378      (do-tail out o st))))
    263379
    264380)
Note: See TracChangeset for help on using the changeset viewer.