! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators io io.binary io.encodings.binary
+USING: combinators fry io io.binary io.encodings.binary
io.streams.byte-array kernel math namespaces
sequences strings ;
IN: base64
<PRIVATE
-: read1-ignoring ( ignoring -- ch )
- read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
+: read1-ignoring ( ignoring stream -- ch )
+ dup stream-read1 pick dupd member?
+ [ drop read1-ignoring ] [ 2nip ] if ;
-: read-ignoring ( ignoring n -- str )
- [ drop read1-ignoring ] with { } map-integers
- [ { f 0 } member? not ] filter
- [ f ] [ >string ] if-empty ;
+: read-ignoring ( n ignoring stream -- str )
+ '[ _ _ read1-ignoring ] replicate
+ [ { f 0 } member-eq? not ] "" filter-as
+ [ f ] when-empty ;
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
SYMBOL: column
-: write1-lines ( ch -- )
- write1
- column get [
- 1 + [ 76 = [ B{ CHAR: \r CHAR: \n } write ] when ]
- [ 76 mod column set ] bi
- ] when* ;
+: write1-lines ( column/f ch stream -- column' )
+ [ stream-write1 ] keep swap [
+ 1 + swap
+ '[ 76 = [ B{ CHAR: \r CHAR: \n } _ stream-write ] when ]
+ [ 76 mod ] bi
+ ] [ drop f ] if* ;
: write-lines ( str -- )
- [ write1-lines ] each ;
+ column output-stream get '[
+ swap [ _ write1-lines ] each
+ ] change ;
: encode3 ( seq -- )
- be> 4 iota <reversed> [
- -6 * shift 0x3f bitand ch>base64 write1-lines
- ] with each ; inline
+ column output-stream get '[
+ swap be> { 3 2 1 0 } [
+ -6 * shift 0x3f bitand ch>base64 _ write1-lines
+ ] with each
+ ] change ; inline
: encode-pad ( seq n -- )
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
- [ write1 ] each ; inline
+ output-stream get '[ _ stream-write1 ] each ; inline
+
+: (encode-base64) ( stream -- )
+ 3 over stream-read dup length {
+ { 0 [ 2drop ] }
+ { 3 [ encode3 (encode-base64) ] }
+ [ encode-pad (encode-base64) ]
+ } case ;
PRIVATE>
: encode-base64 ( -- )
- 3 read dup length {
- { 0 [ drop ] }
- { 3 [ encode3 encode-base64 ] }
- [ encode-pad encode-base64 ]
- } case ;
+ input-stream get (encode-base64) ;
: encode-base64-lines ( -- )
0 column [ encode-base64 ] with-variable ;
-: decode-base64 ( -- )
- "\n\r" 4 read-ignoring dup length {
- { 0 [ drop ] }
- { 4 [ decode4 decode-base64 ] }
+<PRIVATE
+
+: (decode-base64) ( stream -- )
+ 4 "\n\r" pick read-ignoring dup length {
+ { 0 [ 2drop ] }
+ { 4 [ decode4 (decode-base64) ] }
[ malformed-base64 ]
} case ;
+PRIVATE>
+
+: decode-base64 ( -- )
+ input-stream get (decode-base64) ;
+
: >base64 ( seq -- base64 )
binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;