Changeset 14426 in project


Ignore:
Timestamp:
04/25/09 01:26:51 (11 years ago)
Author:
Jim Ursetto
Message:

base64: support for input, output ports in encoder

Location:
release/4/base64/trunk
Files:
3 edited

Legend:

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

    r14249 r14426  
    4545 (test "lorem ipsum"
    4646       (apply string-append lorem-ipsum-base64)
    47        (base64-encode lorem-ipsum)))
     47       (base64-encode lorem-ipsum))
     48 (let ((s (make-string (+ 10 (* 57 60)) #\Q)))  ; past one input buffer
     49   (test "port > 1 buffer length -> port"
     50         (base64-encode s)
     51         (get-output-string (base64-encode (open-input-string s)
     52                                           (open-output-string))))
     53   (test "port > 1 buffer length -> string"
     54         (base64-encode s)
     55         (base64-encode (open-input-string s)))))
    4856
    4957(test-group
     
    8290                        "\r\n")
    8391         (base64-encode (make-string (+ 1 (* 57 2)) #\a)))
    84  (test "lorem ipsum"
    85        (string-intersperse
    86         lorem-ipsum-base64
    87         "\r\n")
    88        (base64-encode lorem-ipsum))
    89 
     92   (let ((lorem-ipsum-encoded (string-intersperse lorem-ipsum-base64 "\r\n")))
     93     (test "lorem ipsum"
     94           lorem-ipsum-encoded
     95           (base64-encode lorem-ipsum))
     96     (test "lorem ipsum string -> port"
     97           lorem-ipsum-encoded
     98           (get-output-string (base64-encode lorem-ipsum (open-output-string))))
     99     (test "lorem ipsum port -> string"
     100           lorem-ipsum-encoded
     101           (base64-encode (open-input-string lorem-ipsum)))
     102     (test "lorem ipsum port -> port"
     103           lorem-ipsum-encoded
     104           (get-output-string (base64-encode (open-input-string lorem-ipsum)
     105                                             (open-output-string)))))
    90106   ))
    91107
  • release/4/base64/trunk/base64.scm

    r14249 r14426  
    2424
    2525;; Ported to CHICKEN by felix
    26 ;; Optimized for CHICKEN by Jim Ursetto.  Optimization notes:
     26;; Rewritten for CHICKEN by Jim Ursetto.  Notes:
    2727;;  Local anonymous functions (bits-at) are not inlined; use define-inline.
    2828;;  Toplevel tables moved to lexical scope.
     
    3434;;  as your inner loop gets tighter.
    3535;;  The optimized variants are almost on par with pure C.
     36;;  Encoding and decoding can now operate on ports.
    3637
    3738(declare
    3839  (fixnum))
    3940
     41(cond-expand ((not compiling)
     42              (define-syntax define-inline
     43                (syntax-rules () ((_ e0 ...) (define e0 ...)))))
     44             (else))
     45
    4046(module base64
    41   (base64-encode base64-decode base64-line-breaks) ;; base64-decode/lax
    42  
    43   (import scheme chicken)
    44 
    45 (define (base64-encode-orig str)
    46   (define-inline (bits-at idx)
    47     (char->integer (string-ref str idx)))
    48   (define-inline (b64->char n)
    49     (define enc-table
    50       '#(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
    51          #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
    52          #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
    53          #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
    54          #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\/))
    55     (vector-ref enc-table (bitwise-and n 63)))
    56 
    57   (define (encode-tail out i o r)
    58     ;; Handle last 1 or 2 bytes
    59     (case r
    60       ((0) out)
    61       ((1)
    62        (let ((n (arithmetic-shift (bits-at i) 16)))
    63          (string-set! out o (b64->char (arithmetic-shift n -18)))
    64          (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
    65          out))
    66       ((2)
    67        (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
    68                              (arithmetic-shift (bits-at (+ i 1)) 8))))
    69          (string-set! out o (b64->char (arithmetic-shift n -18)))
    70          (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
    71          (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
    72          out))))
    73 
    74   (##sys#check-string str 'base64:encode)
    75   (let* ((l (string-length str))
    76          (out (make-string (* 4 (/ (+ l 2) 3)) #\=)))
    77     (do ((i 0 (+ i 3))
    78          (o 0 (+ o 4))
    79          (r l (- r 3)))
    80         ((< r 3) (encode-tail out i o r))
    81       (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
    82                             (arithmetic-shift (bits-at (+ i 1)) 8)
    83                             (bits-at (+ i 2)))))
    84         (string-set! out o       (b64->char (arithmetic-shift n -18)))
    85         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
    86         (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
    87         (string-set! out (+ o 3) (b64->char n))))))
    88 
    89 (define base64-line-breaks (make-parameter #f))
     47  (base64-encode base64-decode base64-line-breaks)
     48
     49  (import scheme chicken
     50          (only extras read-string!)
     51          (only srfi-13 string-concatenate-reverse))
     52  (require-library srfi-13)
     53
    9054;; If base64-line-breaks is true, a CRLF is inserted every
    9155;; 76 output chars (57 input chars) and at the end of the last
    9256;; line, if it was partial (between 1 and 75 output chars).
    93 (define (base64-encode str)
     57(define base64-line-breaks (make-parameter #f))
     58
     59;; Optimized string->string implementation
     60(define (base64-encode/string->string str)
    9461  (define-inline (bits-at idx)
    9562    (char->integer (string-ref str idx)))
     
    157124        out))))
    158125
     126(define (base64-encode in #!optional out)
     127  (define (port-to-port in out)
     128    (let* ((buflen (* 57 60))
     129           (buf (make-string buflen)))
     130      (let lp ()
     131        (let ((n (read-string! buflen buf in)))
     132          (cond ((= n 0) out)
     133                (else
     134                 (display (base64-encode/string->string
     135                           (if (< n buflen) (substring buf 0 n) buf))
     136                          out)
     137                 (lp)))))))
     138  (define (port-to-string in)
     139    ;; easier on GC than (let ((out (open-output-string)))
     140    ;;                     (get-output-string (port-to-port in out)))
     141    (let* ((buflen (* 57 60))
     142           (buf (make-string buflen)))
     143      (let lp ((lines '()))
     144        (let ((n (read-string! buflen buf in)))
     145          (cond ((= n 0)
     146                 (string-concatenate-reverse lines))
     147                (else
     148                 (lp (cons (base64-encode/string->string
     149                            (if (< n buflen) (substring buf 0 n) buf))
     150                           lines))))))))
     151  (if (port? out)
     152      (if (string? in)
     153          (port-to-port (open-input-string in) out)
     154          (port-to-port in out))     
     155      (if (string? in)
     156          (base64-encode/string->string in)
     157          (port-to-string in))))
     158
    159159;; (define (calc-dec-table)
    160160;;    (let ((res (make-vector 256 -1)))
     
    164164;;      res))
    165165
    166 (define (base64-decode str)
     166(define (base64-decode/string->string str)
    167167  (define-inline (bits-at idx)
    168168    (define dec-table
     
    227227              (substring out 0 o))))))
    228228
    229 ;; Lax decode which includes invalid characters in input.
    230 ;; Around 2x faster.  Not exported.
    231 (define (base64-decode/lax str)
    232   (define-inline (bits-at idx)
    233     (define dec-table
    234       '#(0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    235          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    236          0  0  0  0  0  0  0  0  0  0  0  62 0  0  0  63
    237          52 53 54 55 56 57 58 59 60 61 0  0  0  0  0  0
    238          0  0  1  2  3  4  5  6  7  8  9  10 11 12 13 14
    239          15 16 17 18 19 20 21 22 23 24 25 0  0  0  0  0
    240          0  26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
    241          41 42 43 44 45 46 47 48 49 50 51 0  0  0  0  0
    242          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    243          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    244          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    245          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    246          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    247          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    248          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
    249          0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0))
    250     (vector-ref dec-table (char->integer (string-ref str idx))))
    251   (define-inline (int->char n)
    252     (integer->char (bitwise-and n 255)))
    253   (define (decode-tail out i o r)
    254     (case r
    255       ((0) out)
    256       ((1) (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 18)
    257                                  (arithmetic-shift (bits-at (+ i 1)) 12))))
    258              (string-set! out o       (int->char (arithmetic-shift n -16)))
    259              out))
    260       ((2) (let ((n (bitwise-ior
    261                      (bitwise-ior (arithmetic-shift (bits-at i) 18)
    262                                   (arithmetic-shift (bits-at (+ i 1)) 12))
    263                      (arithmetic-shift (bits-at (+ i 2)) 6))))
    264              (string-set! out o       (int->char (arithmetic-shift n -16)))
    265              (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
    266              out))))
    267 
    268   (##sys#check-string str 'base64-decode)
    269   (let ((l (string-length str)))
    270     (cond
    271      ((= l 0) "")
    272      ((not (= l (fx* 4 (fx/ l 4))))
    273       (error 'base64-decode "string length must be a multiple of 4" l))
    274      (else
    275       (let* ((outlen (- (* 3 (fx/ l 4))
    276                         (cond
    277                          ((char=? (string-ref str (- l 2)) #\=) 2)
    278                          ((char=? (string-ref str (- l 1)) #\=) 1)
    279                          (else 0))))
    280              (out (make-string outlen)))
    281         (do ((i 0 (+ i 4))
    282              (o 0 (+ o 3))
    283              (r outlen (- r 3)))
    284             ((< r 3) (decode-tail out i o r))
    285           ;; take in 4 bytes, making a 24 bit integer
    286           (let ((n (bitwise-ior
    287                     (bitwise-ior (arithmetic-shift (bits-at i) 18)
    288                                  (arithmetic-shift (bits-at (+ i 1)) 12))
    289                     (bitwise-ior (arithmetic-shift (bits-at (+ i 2)) 6)
    290                                  (bits-at (+ i 3))))))
    291             ;; now write out 3 bytes at a time
    292             (string-set! out o       (int->char (arithmetic-shift n -16)))
    293             (string-set! out (+ o 1) (int->char (arithmetic-shift n -8)))
    294             (string-set! out (+ o 2) (int->char n)))))))))
     229(define (base64-decode in #!optional out)
     230  ; Copy and paste is ugly.
     231  (define (port-to-port in out)
     232    (let* ((buflen 2048)
     233           (buf (make-string buflen)))
     234      (let lp ()
     235        (let ((n (read-string! buflen buf in)))
     236          (cond ((= n 0) out)
     237                (else
     238                 (display (base64-decode/string->string
     239                           (if (< n buflen) (substring buf 0 n) buf))
     240                          out)
     241                 (lp)))))))
     242  (define (port-to-string in)
     243    (let* ((buflen 2048)
     244           (buf (make-string buflen)))
     245      (let lp ((lines '()))
     246        (let ((n (read-string! buflen buf in)))
     247          (cond ((= n 0)
     248                 (string-concatenate-reverse lines))
     249                (else
     250                 (lp (cons (base64-decode/string->string
     251                            (if (< n buflen) (substring buf 0 n) buf))
     252                           lines)))))))) 
     253  (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))
     258      (if (string? in)
     259          (base64-decode/string->string in)
     260          (error 'base64-decode "input port not supported yet")
     261;;           (port-to-string in)
     262          )))
    295263
    296264)
  • release/4/base64/trunk/base64.setup

    r14249 r14426  
    55 'base64
    66 '("base64.import.so" "base64.so")
    7  '((version 3.1)
     7 '((version 3.2)
    88   (documentation "base64.html")))
Note: See TracChangeset for help on using the changeset viewer.