Merge branch 'master' of git://factorcode.org/git/factor

basis/base64/base64-tests.factor

@@ -1,4 +1,4 @@
-USING: kernel tools.test base64 strings ;
+USING: kernel tools.test base64 strings sequences  ;
 IN: base64.tests
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
@@ -7,6 +7,7 @@ IN: base64.tests
 [ "a" ] [ "a" >base64 base64> >string ] unit-test
 [ "ab" ] [ "ab" >base64 base64> >string ] unit-test
 [ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
 
 ! From http://en.wikipedia.org/wiki/Base64
 [ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
@@ -15,5 +16,11 @@ IN: base64.tests
     >base64 >string
 ] unit-test
 
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+    "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+    >base64-lines >string
+] unit-test
+
 \ >base64 must-infer
 \ base64> must-infer

basis/base64/base64.factor

@@ -1,16 +1,22 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.binary splitting grouping
+USING: combinators io io.binary io.encodings.binary
-accessors ;
+io.streams.byte-array io.streams.string kernel math namespaces
+sequences strings ;
 IN: base64
 
 <PRIVATE
 
-: count-end ( seq quot -- n )
+: read1-ignoring ( ignoring -- ch )
-    trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
+    read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
+
+: read-ignoring ( ignoring n -- str )
+    [ drop read1-ignoring ] with map harvest
+    [ f ] [ >string ] if-empty ;
 
 : ch>base64 ( ch -- ch )
-    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+    nth ; inline
 
 : base64>ch ( ch -- ch )
     {
@@ -19,32 +25,60 @@ IN: base64
         f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
         22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
         40 41 42 43 44 45 46 47 48 49 50 51
-    } nth ;
+    } nth ; inline
 
-: encode3 ( seq -- seq )
+SYMBOL: column
+
+: write1-lines ( ch -- )
+    write1
+    column get [
+        1+ [ 76 = [ "\r\n" write ] when ]
+        [ 76 mod column set ] bi
+    ] when* ;
+
+: write-lines ( str -- )
+    [ write1-lines ] each ;
+
+: encode3 ( seq -- )
     be> 4 <reversed> [
-        -6 * shift HEX: 3f bitand ch>base64
+        -6 * shift HEX: 3f bitand ch>base64 write1-lines
-    ] with B{ } map-as ;
+    ] with each ; inline
 
-: decode4 ( str -- str )
+: encode-pad ( seq n -- )
-    0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
+    [ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
+    [ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
 
-: >base64-rem ( str -- str )
+ERROR: malformed-base64 ;
-    [ 3 0 pad-right encode3 ] [ length 1+ ] bi
+
-    head-slice 4 CHAR: = pad-right ;
+: decode4 ( seq -- )
+    [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
+    [ [ CHAR: = = ] count ] bi head-slice*
+    [ write1 ] each ; inline
 
 PRIVATE>
 
-: >base64 ( seq -- base64 )
+: encode-base64 ( -- )
-    #! cut string into two pieces, convert 3 bytes at a time
+    3 read dup length {
-    #! pad string with = when not enough bits
+        { 0 [ drop ] }
-    dup length dup 3 mod - cut
+        { 3 [ encode3 encode-base64 ] }
-    [ 3 <groups> [ encode3 ] map concat ]
+        [ encode-pad encode-base64 ]
-    [ [ "" ] [ >base64-rem ] if-empty ]
+    } case ;
-    bi* append ;
 
-: base64> ( base64 -- seq )
+: encode-base64-lines ( -- )
-    #! input length must be a multiple of 4
+    0 column [ encode-base64 ] with-variable ;
-    [ 4 <groups> [ decode4 ] map concat ]
+
-    [ [ CHAR: = = ] count-end ]
+: decode-base64 ( -- )
-    bi head* ;
+    "\n\r" 4 read-ignoring dup length {
+        { 0 [ drop ] }
+        { 4 [ decode4 decode-base64 ] }
+        [ malformed-base64 ]
+    } case ;
+
+: >base64 ( str -- base64 )
+    binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
+
+: base64> ( base64 -- str )
+    [ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
+
+: >base64-lines ( str -- base64 )
+    binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;

basis/generalizations/generalizations-docs.factor

@@ -229,8 +229,9 @@ HELP: napply
 { $examples
   "Some core words expressed in terms of " { $link napply } ":"
     { $table
-        { { $link bi@ } { $snippet "1 napply" } }
+        { { $link call } { $snippet "1 napply" } }
-        { { $link tri@ } { $snippet "2 napply" } }
+        { { $link bi@ } { $snippet "2 napply" } }
+        { { $link tri@ } { $snippet "3 napply" } }
     }
 } ;
 

basis/generalizations/generalizations-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test generalizations kernel math arrays sequences ;
+USING: tools.test generalizations kernel math arrays sequences ascii ;
 IN: generalizations.tests
 
 { 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
@@ -28,6 +28,8 @@ IN: generalizations.tests
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
 [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
+
+[ "HELLO" ] [ "hello" [ >upper ] 1 napply ] unit-test
 [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
 [ [ dup 2^ 2array ] 5 napply ] must-infer
 

basis/generalizations/generalizations.factor

@@ -73,10 +73,8 @@ MACRO: ncleave ( quots n -- )
     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
     compose ;
 
-MACRO: napply ( n -- )
+MACRO: napply ( quot n -- )
-    2 [a,b]
+    swap <repetition> spread>quot ;
-    [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
-    map concat >quotation [ call ] append ;
 
 MACRO: mnswap ( m n -- )
     1+ '[ _ -nrot ] <repetition> spread>quot ;

basis/io/streams/null/null-docs.factor

@@ -0,0 +1,28 @@
+USING: io help.markup help.syntax quotations ;
+IN: io.streams.null
+
+HELP: null-reader
+{ $class-description "Singleton class of null reader streams." } ;
+
+HELP: null-writer
+{ $class-description "Singleton class of null writer streams." } ;
+
+HELP: with-null-reader
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
+
+HELP: with-null-writer
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
+
+ARTICLE: "io.streams.null" "Null streams"
+"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
+$nl
+"Null readers:"
+{ $subsection null-reader }
+{ $subsection with-null-writer }
+"Null writers:"
+{ $subsection null-writer }
+{ $subsection with-null-reader } ;
+
+ABOUT: "io.streams.null"

basis/io/streams/null/null.factor

@@ -1,22 +1,19 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io io.timeouts io.styles destructors ;
 IN: io.streams.null
-USING: kernel io io.timeouts io.streams.duplex destructors ;
 
-TUPLE: null-stream ;
+SINGLETONS: null-reader null-writer ;
+UNION: null-stream null-reader null-writer ;
 
 M: null-stream dispose drop ;
 M: null-stream set-timeout 2drop ;
 
-TUPLE: null-reader < null-stream ;
-
 M: null-reader stream-readln drop f ;
 M: null-reader stream-read1 drop f ;
 M: null-reader stream-read-until 2drop f f ;
 M: null-reader stream-read 2drop f ;
 
-TUPLE: null-writer < null-stream ;
-
 M: null-writer stream-write1 2drop ;
 M: null-writer stream-write 2drop ;
 M: null-writer stream-nl drop ;
@@ -28,11 +25,7 @@ M: null-writer make-cell-stream nip ;
 M: null-writer stream-write-table 3drop ;
 
 : with-null-reader ( quot -- )
-    T{ null-reader } swap with-input-stream* ; inline
+    null-reader swap with-input-stream* ; inline
 
 : with-null-writer ( quot -- )
-    T{ null-writer } swap with-output-stream* ; inline
+    null-writer swap with-output-stream* ; inline
-
-: with-null-stream ( quot -- )
-    T{ duplex-stream f T{ null-reader } T{ null-writer } }
-    swap with-stream* ; inline

basis/io/styles/styles-tests.factor

@@ -0,0 +1,8 @@
+IN: io.styles.tests
+USING: io.styles tools.test ;
+
+\ stream-format must-infer
+\ stream-write-table must-infer
+\ make-span-stream must-infer
+\ make-block-stream must-infer
+\ make-cell-stream must-infer

basis/smtp/smtp-tests.factor

@@ -15,7 +15,7 @@ IN: smtp.tests
 
 [ { "hello" "." "world" } validate-message ] must-fail
 
-[ "hello\r\nworld\r\n.\r\n" ] [
+[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
     "hello\nworld" [ send-body ] with-string-writer
 ] unit-test
 
@@ -50,7 +50,10 @@ IN: smtp.tests
 
 [
     {
+        { "Content-Transfer-Encoding" "base64" }
+        { "Content-Type" "Text/plain; charset=utf-8" }
         { "From" "Doug <erg@factorcode.org>" }
+        { "MIME-Version" "1.0" }
         { "Subject" "Factor rules" }
         { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
     }

basis/smtp/smtp.factor

@@ -92,9 +92,8 @@ M: message-contains-dot summary ( obj -- string )
     [ message-contains-dot ] when ;
 
 : send-body ( body -- )
-    string-lines
+    utf8 encode
-    validate-message
+    >base64-lines write crlf
-    [ write crlf ] each
     "." command ;
 
 : quit ( -- )
@@ -167,6 +166,13 @@ M: plain-auth send-auth
 
 : auth ( -- ) smtp-auth get send-auth ;
 
+: encode-header ( string -- string' )
+    dup aux>> [
+        "=?utf-8?B?"
+        swap utf8 encode >base64
+        "?=" 3append
+    ] when ;
+
 ERROR: invalid-header-string string ;
 
 : validate-header ( string -- string' )
@@ -175,7 +181,7 @@ ERROR: invalid-header-string string ;
 
 : write-header ( key value -- )
     [ validate-header write ]
-    [ ": " write validate-header write ] bi* crlf ;
+    [ ": " write validate-header encode-header write ] bi* crlf ;
 
 : write-headers ( assoc -- )
     [ write-header ] assoc-each ;
@@ -195,6 +201,13 @@ ERROR: invalid-header-string string ;
     ! This could be much smarter.
     " " split1-last swap or "<" ?head drop ">" ?tail drop ;
 
+: utf8-mime-header ( -- alist )
+    {
+        { "MIME-Version" "1.0" }
+        { "Content-Transfer-Encoding" "base64" }
+        { "Content-Type" "Text/plain; charset=utf-8" }
+    } ;
+
 : email>headers ( email -- hashtable )
     [
         {
@@ -205,7 +218,7 @@ ERROR: invalid-header-string string ;
         } cleave
         now timestamp>rfc822 "Date" set
         message-id "Message-Id" set
-    ] { } make-assoc ;
+    ] { } make-assoc utf8-mime-header append ;
 
 : (send-email) ( headers email -- )
     [

basis/stack-checker/stack-checker-tests.factor

@@ -416,12 +416,7 @@ DEFER: bar
 \ stream-write must-infer
 \ stream-write1 must-infer
 \ stream-nl must-infer
-\ stream-format must-infer
-\ stream-write-table must-infer
 \ stream-flush must-infer
-\ make-span-stream must-infer
-\ make-block-stream must-infer
-\ make-cell-stream must-infer
 
 ! Test stream utilities
 \ lines must-infer

basis/ui/gadgets/scrollers/scrollers.factor

@@ -37,13 +37,14 @@ scroller H{
     new-frame
         t >>root?
         <scroller-model> >>model
-        faint-boundary
 
-        dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add
+        dup model>> dependencies>>
-        dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add
+        [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
+        [ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
 
-        tuck model>> <viewport> >>viewport
+        tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
-        dup viewport>> @center grid-add ; inline
+
+        faint-boundary ; inline
 
 : <scroller> ( gadget -- scroller ) scroller new-scroller ;
 

basis/ui/gadgets/viewports/viewports.factor

@@ -1,18 +1,23 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: ui.gadgets.viewports
 USING: accessors arrays ui.gadgets ui.gadgets.borders
-kernel math namespaces sequences models math.vectors math.geometry.rect ;
+kernel math namespaces sequences models math.vectors
+math.geometry.rect ;
+IN: ui.gadgets.viewports
 
-: viewport-gap { 3 3 } ; inline
+CONSTANT: viewport-gap { 3 3 }
+CONSTANT: scroller-border { 1 1 }
 
 TUPLE: viewport < gadget ;
 
 : find-viewport ( gadget -- viewport )
     [ viewport? ] find-parent ;
 
+: viewport-padding ( -- padding )
+    viewport-gap 2 v*n scroller-border v+ ;
+
 : viewport-dim ( viewport -- dim )
-    gadget-child pref-dim viewport-gap 2 v*n v+ ;
+    gadget-child pref-dim viewport-padding v+ ;
 
 : <viewport> ( content model -- viewport )
     viewport new-gadget
@@ -21,11 +26,11 @@ TUPLE: viewport < gadget ;
         swap add-gadget ;
 
 M: viewport layout*
-    [
+    [ gadget-child ] [
-        [ rect-dim viewport-gap 2 v*n v- ]
+        [ dim>> viewport-padding v- ]
         [ gadget-child pref-dim ]
         bi vmax
-    ] [ gadget-child ] bi (>>dim) ;
+    ] bi >>dim drop ;
 
 M: viewport focusable-child*
     gadget-child ;
@@ -37,13 +42,17 @@ M: viewport pref-dim* viewport-dim ;
 
 M: viewport model-changed
     nip
-    dup relayout-1
+    [ relayout-1 ]
-    dup scroller-value
+    [
-    vneg viewport-gap v+
+        [ gadget-child ]
-    swap gadget-child (>>loc) ;
+        [
+            scroller-value vneg
+            viewport-gap v+
+            scroller-border v+
+        ] bi
+        >>loc drop
+    ] bi ;
 
 : visible-dim ( gadget -- dim )
     dup parent>> viewport?
-      [ parent>> rect-dim viewport-gap 2 v*n v- ]
+    [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;
-      [ rect-dim ]
-    if ;

core/strings/strings-tests.factor

@@ -108,7 +108,7 @@ unit-test
             ] times
             .
         ] times
-    ] with-null-stream
+    ] with-null-writer
 ] unit-test
 
 [ t ] [