! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs byte-arrays combinators fry io io.binary
-io.encodings.binary io.streams.byte-array kernel kernel.private
-literals math namespaces sbufs sequences ;
+USING: arrays assocs byte-arrays combinators fry growable io
+io.binary io.encodings.binary io.streams.byte-array kernel
+kernel.private literals locals math math.bitwise namespaces
+sbufs sequences sequences.private ;
IN: base64
ERROR: malformed-base64 ;
$[ alphabet alphabet-inverse 0 CHAR: = pick set-nth ] nth
[ malformed-base64 ] unless* { fixnum } declare ; inline
-: (write-lines) ( column byte-array -- column' )
- output-stream get dup '[
- _ stream-write1 1 + dup 76 = [
- drop B{ CHAR: \r CHAR: \n } _ stream-write 0
- ] when
- ] each ; inline
-
-: write-lines ( column byte-array -- column' )
- over [ (write-lines) ] [ write ] if ; inline
-
-: encode3 ( seq -- byte-array )
- be> { -18 -12 -6 0 } '[
- shift 0x3f bitand ch>base64
- ] with B{ } map-as ; inline
-
-: encode-pad ( seq n -- byte-array )
- [ 3 0 pad-tail encode3 ] [ 1 + ] bi* head-slice
- 4 CHAR: = pad-tail ; inline
-
-: (encode-base64) ( stream column -- )
- 3 pick stream-read dup length {
- { 0 [ 3drop ] }
- { 3 [ encode3 write-lines (encode-base64) ] }
- [ encode-pad write-lines (encode-base64) ]
- } case ;
+: encode3 ( x y z -- a b c d )
+ { fixnum fixnum fixnum } declare {
+ [ [ -2 shift ch>base64 ] [ 2 bits 4 shift ] bi ]
+ [ [ -4 shift bitor ch>base64 ] [ 4 bits 2 shift ] bi ]
+ [ [ -6 shift bitor ch>base64 ] [ 6 bits ch>base64 ] bi ]
+ } spread ; inline
+
+:: (stream-write-lines) ( column data stream -- column' )
+ column data over 71 > [
+ [
+ stream stream-write1 1 + dup 76 = [
+ drop 0
+ B{ CHAR: \r CHAR: \n } stream stream-write
+ ] when
+ ] each
+ ] [
+ stream stream-write 4 +
+ ] if ; inline
+
+: stream-write-lines ( column data stream -- column' )
+ pick [ (stream-write-lines) ] [ stream-write ] if ; inline
+
+: write-lines ( column data -- column' )
+ output-stream get stream-write-lines ; inline
+
+:: (encode-base64) ( input output column -- )
+ 4 <byte-array> :> data
+ column [ input stream-read1 dup ] [
+ input stream-read1
+ input stream-read1
+ [ [ 0 or ] bi@ encode3 ] 2keep [ 0 1 ? ] bi@ + {
+ { 0 [ ] }
+ { 1 [ drop CHAR: = ] }
+ { 2 [ 2drop CHAR: = CHAR: = ] }
+ } case data (4sequence) output stream-write-lines
+ ] while 2drop ; inline
PRIVATE>
: encode-base64 ( -- )
- input-stream get f (encode-base64) ;
+ input-stream get output-stream get f (encode-base64) ;
: encode-base64-lines ( -- )
- input-stream get 0 (encode-base64) ;
+ input-stream get output-stream get 0 (encode-base64) ;
<PRIVATE
: read1-ignoring ( ignoring stream -- ch )
- dup stream-read1 pick dupd member?
+ dup stream-read1 pick dupd member-eq?
[ drop read1-ignoring ] [ 2nip ] if ; inline recursive
-: push-ignoring ( accum ch -- accum )
- dup { f 0 } member-eq? [ drop ] [ suffix! ] if ; inline
-
-: read-into-ignoring ( accum n ignoring stream -- accum )
- '[ _ _ read1-ignoring push-ignoring ] times ; inline
-
: read-ignoring ( n ignoring stream -- accum )
- [ [ <sbuf> ] keep ] 2dip read-into-ignoring ; inline
-
-: decode4 ( seq -- )
- [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
- [ [ CHAR: = = ] count ] bi
- [ write ] [ head-slice* write ] if-zero ; inline
+ pick <sbuf> [
+ '[ _ _ read1-ignoring [ ] _ push-if ] times
+ ] keep ;
-: (decode-base64) ( stream -- )
- 4 "\n\r" pick read-ignoring dup length {
- { 0 [ 2drop ] }
- { 4 [ decode4 (decode-base64) ] }
- [ drop 4 CHAR: = pad-tail decode4 (decode-base64) ]
- } case ;
+: decode4 ( a b c d -- x y z )
+ { fixnum fixnum fixnum fixnum } declare {
+ [ base64>ch 2 shift ]
+ [ base64>ch [ -4 shift bitor ] [ 4 bits 4 shift ] bi ]
+ [ base64>ch [ -2 shift bitor ] [ 2 bits 6 shift ] bi ]
+ [ base64>ch bitor ]
+ } spread ; inline
+
+:: (decode-base64) ( input output -- )
+ 3 <byte-array> :> data
+ [ B{ CHAR: \n CHAR: \r } input read1-ignoring dup ] [
+ B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+ B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+ B{ CHAR: \n CHAR: \r } input read1-ignoring CHAR: = or
+ [ decode4 data (3sequence) ] 3keep
+ [ CHAR: = eq? 1 0 ? ] tri@ + +
+ [ head-slice* ] unless-zero
+ output stream-write
+ ] while drop ;
PRIVATE>
: decode-base64 ( -- )
- input-stream get (decode-base64) ;
+ input-stream get output-stream get (decode-base64) ;
+
+<PRIVATE
+
+: ensure-encode-length ( base64 -- base64 )
+ dup length 3 /mod zero? [ 1 + ] unless 4 *
+ output-stream get expand ;
+
+: ensure-decode-length ( seq -- seq )
+ dup length 4 /mod zero? [ 1 + ] unless 3 *
+ output-stream get expand ;
+
+PRIVATE>
-: >base64 ( seq -- base64 )
- binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;
+: >base64 ( base64 -- seq )
+ binary [
+ ensure-encode-length
+ binary [ encode-base64 ] with-byte-reader
+ ] with-byte-writer ;
: base64> ( base64 -- seq )
- binary [ binary [ decode-base64 ] with-byte-reader ] with-byte-writer ;
+ binary [
+ ensure-decode-length
+ binary [ decode-base64 ] with-byte-reader
+ ] with-byte-writer ;
: >base64-lines ( seq -- base64 )
- binary [ binary [ encode-base64-lines ] with-byte-reader ] with-byte-writer ;
+ binary [
+ ensure-encode-length
+ binary [ encode-base64-lines ] with-byte-reader
+ ] with-byte-writer ;
: >urlsafe-base64 ( seq -- base64 )
>base64 H{