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

core/bootstrap/primitives.factor

@@ -98,26 +98,36 @@ H{ } clone class<map set
 H{ } clone update-map set
 
 ! Builtin classes
-: builtin-predicate ( class predicate -- )
+: builtin-predicate-quot ( class -- quot )
     [
-        over "type" word-prop dup
+        "type" word-prop dup
         \ tag-mask get < \ tag \ type ? , , \ eq? ,
-    ] [ ] make define-predicate* ;
+    ] [ ] make ;
 
-: register-builtin ( class -- )
+: define-builtin-predicate ( class -- )
-    dup "type" word-prop builtins get set-nth ;
+    dup
+    dup builtin-predicate-quot define-predicate
+    predicate-word make-inline ;
 
 : lookup-type-number ( word -- n )
     global [ target-word ] bind type-number ;
 
-: define-builtin ( symbol predicate slotspec -- )
+: register-builtin ( class -- )
-    >r dup make-inline >r
+    dup
-    dup dup lookup-type-number "type" set-word-prop
+    dup lookup-type-number "type" set-word-prop
+    dup "type" word-prop builtins get set-nth ;
+
+: define-builtin-slots ( symbol slotspec -- )
+    dupd 1 simple-slots
+    2dup "slots" set-word-prop
+    define-slots ;
+
+: define-builtin ( symbol slotspec -- )
+    >r
+    dup register-builtin
     dup f f builtin-class define-class
-    dup r> builtin-predicate
+    dup define-builtin-predicate
-    dup r> 1 simple-slots 2dup "slots" set-word-prop
+    r> define-builtin-slots ;
-    dupd define-slots
-    register-builtin ;
 
 H{ } clone typemap set
 num-types get f <array> builtins set
@@ -128,17 +138,15 @@ num-types get f <array> builtins set
 
 "null" "kernel" create drop
 
-"fixnum" "math" create "fixnum?" "math" create { } define-builtin
+"fixnum" "math" create { } define-builtin
 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
 
-"bignum" "math" create "bignum?" "math" create { } define-builtin
+"bignum" "math" create { } define-builtin
 "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
 
-"tuple" "kernel" create "tuple?" "kernel" create
+"tuple" "kernel" create { } define-builtin
-{ } define-builtin
 
-"ratio" "math" create "ratio?" "math" create
+"ratio" "math" create {
-{
     {
         { "integer" "math" }
         "numerator"
@@ -153,11 +161,10 @@ num-types get f <array> builtins set
     }
 } define-builtin
 
-"float" "math" create "float?" "math" create { } define-builtin
+"float" "math" create { } define-builtin
 "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
 
-"complex" "math" create "complex?" "math" create
+"complex" "math" create {
-{
     {
         { "real" "math" }
         "real-part"
@@ -172,14 +179,13 @@ num-types get f <array> builtins set
     }
 } define-builtin
 
-"f" "syntax" lookup "not" "kernel" create
+"f" "syntax" lookup { } define-builtin
-{ } define-builtin
 
-"array" "arrays" create "array?" "arrays" create
+! do not word...
-{ } define-builtin
 
-"wrapper" "kernel" create "wrapper?" "kernel" create
+"array" "arrays" create { } define-builtin
-{
+
+"wrapper" "kernel" create {
     {
         { "object" "kernel" }
         "wrapped"
@@ -188,8 +194,7 @@ num-types get f <array> builtins set
     }
 } define-builtin
 
-"string" "strings" create "string?" "strings" create
+"string" "strings" create {
-{
     {
         { "array-capacity" "sequences.private" }
         "length"
@@ -203,8 +208,7 @@ num-types get f <array> builtins set
     }
 } define-builtin
 
-"quotation" "quotations" create "quotation?" "quotations" create
+"quotation" "quotations" create {
-{
     {
         { "object" "kernel" }
         "array"
@@ -219,8 +223,7 @@ num-types get f <array> builtins set
     }
 } define-builtin
 
-"dll" "alien" create "dll?" "alien" create
+"dll" "alien" create {
-{
     {
         { "byte-array" "byte-arrays" }
         "path"
@@ -230,8 +233,7 @@ num-types get f <array> builtins set
 }
 define-builtin
 
-"alien" "alien" create "alien?" "alien" create
+"alien" "alien" create {
-{
     {
         { "c-ptr" "alien" }
         "alien"
@@ -246,8 +248,7 @@ define-builtin
 }
 define-builtin
 
-"word" "words" create "word?" "words" create
+"word" "words" create {
-{
     f
     {
         { "object" "kernel" }
@@ -287,20 +288,13 @@ define-builtin
     }
 } define-builtin
 
-"byte-array" "byte-arrays" create
+"byte-array" "byte-arrays" create { } define-builtin
-"byte-array?" "byte-arrays" create
-{ } define-builtin
 
-"bit-array" "bit-arrays" create
+"bit-array" "bit-arrays" create { } define-builtin
-"bit-array?" "bit-arrays" create
-{ } define-builtin
 
-"float-array" "float-arrays" create
+"float-array" "float-arrays" create { } define-builtin
-"float-array?" "float-arrays" create
-{ } define-builtin
 
-"callstack" "kernel" create "callstack?" "kernel" create
+"callstack" "kernel" create { } define-builtin
-{ } define-builtin
 
 ! Define general-t type, which is any object that is not f.
 "general-t" "kernel" create

extra/builder/benchmark/benchmark.factor

@@ -21,7 +21,7 @@ IN: builder.benchmark
   [ benchmark-difference ] with map ;
 
 : benchmark-deltas ( -- table )
-  "../../benchmarks" "../benchmarks" [ eval-file ] 2apply
+  "../benchmarks" "benchmarks" [ eval-file ] 2apply
   compare-tables
   sort-values ;
 

extra/builder/builder.factor

@@ -4,6 +4,7 @@ USING: kernel namespaces sequences splitting system combinators continuations
        bootstrap.image benchmark vars bake smtp builder.util accessors
        io.encodings.utf8
        calendar
+       tools.test
        builder.common
        builder.benchmark
        builder.release ;
@@ -131,7 +132,10 @@ SYMBOL: build-status
       "Test time: " write "test-time" eval-file milli-seconds>time print nl
 
       "Did not pass load-everything: " print "load-everything-vocabs" cat
+      
       "Did not pass test-all: "        print "test-all-vocabs"        cat
+      "test-all-vocabs" eval-file test-failures.
+      
       "help-lint results:"             print "help-lint"              cat
 
       "Benchmarks: " print "benchmarks" eval-file benchmarks.

extra/builder/test/test.factor

@@ -16,18 +16,18 @@ IN: builder.test
 : do-load ( -- )
   try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
 
-! : do-tests ( -- )
-!   run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
-
 : do-tests ( -- )
-  run-all-tests
+  run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
-  "../test-all-vocabs" utf8
+
-    [
+! : do-tests ( -- )
-        [ keys . ]
+!   run-all-tests
-        [ test-failures. ]
+!   "../test-all-vocabs" utf8
-      bi
+!     [
-    ]
+!         [ keys . ]
-  with-file-writer ;
+!         [ test-failures. ]
+!       bi
+!     ]
+!   with-file-writer ;
 
 : do-help-lint ( -- )
   "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;

extra/combinators/cleave/cleave-docs.factor

@@ -7,10 +7,18 @@ IN: combinators.cleave
 
 ARTICLE: "cleave-combinators" "Cleave Combinators"
 
+"Basic cleavers:"
+
 { $subsection bi  }
 { $subsection tri }
+
+"General cleave: "
 { $subsection cleave }
 
+"Cleave combinators for quotations with arity 2:"
+{ $subsection 2bi  }
+{ $subsection 2tri }
+
 { $notes
   "From the Merriam-Webster Dictionary: "
   $nl
@@ -56,6 +64,10 @@ HELP: cleave
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+{ bi tri cleave 2bi 2tri } related-words
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 ARTICLE: "spread-combinators" "Spread Combinators"
 
 { $subsection bi* }

extra/help/cookbook/cookbook.factor

@@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
 }
 "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
 { $code
-    "\"mydata.dat\" dup file-length ["
+    "\"mydata.dat\" dup file-info file-info-length ["
     "    4 <sliced-groups> [ reverse-here ] change-each"
     "] with-mapped-file"
 }

extra/http/client/client.factor

@@ -95,5 +95,4 @@ PRIVATE>
     swap >>post-data-type ;
 
 : http-post ( content-type content url -- response string )
-    #! The content is URL encoded for you.
+    <post-request> http-request contents ;
-    >r url-encode r> <post-request> http-request contents ;

extra/http/http.factor

@@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math
 namespaces math.parser assocs sequences strings splitting ascii
 io.encodings.utf8 io.encodings.string namespaces unicode.case
 combinators vectors sorting new-slots accessors calendar
-calendar.format quotations arrays ;
+calendar.format quotations arrays combinators.cleave
+combinators.lib byte-arrays ;
 IN: http
 
 : http-port 80 ; inline
@@ -12,18 +13,21 @@ IN: http
 : url-quotable? ( ch -- ? )
     #! In a URL, can this character be used without
     #! URL-encoding?
-    dup letter?
+    {
-    over LETTER? or
+        [ dup letter? ]
-    over digit? or
+        [ dup LETTER? ]
-    swap "/_-." member? or ; foldable
+        [ dup digit? ]
+        [ dup "/_-.:" member? ]
+    } || nip ; foldable
 
 : push-utf8 ( ch -- )
-    1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+    1string utf8 encode
+    [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
 
 : url-encode ( str -- str )
-    [ [
+    [
-        dup url-quotable? [ , ] [ push-utf8 ] if
+        [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
-    ] each ] "" make ;
+    ] "" make ;
 
 : url-decode-hex ( index str -- )
     2dup length 2 - >= [
@@ -108,7 +112,12 @@ IN: http
     ] when ;
 
 : assoc>query ( hash -- str )
-    [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
+    [
+        [ url-encode ]
+        [ dup number? [ number>string ] when url-encode ]
+        bi*
+        "=" swap 3append
+    ] { } assoc>map
     "&" join ;
 
 TUPLE: cookie name value path domain expires http-only ;
@@ -169,10 +178,10 @@ cookies ;
 
 : <request>
     request construct-empty
-    "1.1" >>version
+        "1.1" >>version
-    http-port >>port
+        http-port >>port
-    H{ } clone >>query
+        H{ } clone >>query
-    V{ } clone >>cookies ;
+        V{ } clone >>cookies ;
 
 : query-param ( request key -- value )
     swap query>> at ;
@@ -245,6 +254,10 @@ SYMBOL: max-post-request
 : extract-post-data-type ( request -- request )
     dup "content-type" header >>post-data-type ;
 
+: parse-post-data ( request -- request )
+    dup post-data-type>> "application/x-www-form-urlencoded" =
+    [ dup post-data>> query>assoc >>post-data ] when ;
+
 : extract-cookies ( request -- request )
     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 
@@ -257,24 +270,31 @@ SYMBOL: max-post-request
     read-post-data
     extract-host
     extract-post-data-type
+    parse-post-data
     extract-cookies ;
 
 : write-method ( request -- request )
     dup method>> write bl ;
 
-: write-url ( request -- request )
+: (link>string) ( url query -- url' )
-    dup path>> url-encode write
+    [ url-encode ] [ assoc>query ] bi*
-    dup query>> dup assoc-empty? [ drop ] [
+    dup empty? [ drop ] [ "?" swap 3append ] if ;
-        "?" write
+
-        assoc>query write
+: write-url ( request -- )
-    ] if ;
+    [ path>> ] [ query>> ] bi (link>string) write ;
 
 : write-request-url ( request -- request )
-    write-url bl ;
+    dup write-url bl ;
 
 : write-version ( request -- request )
     "HTTP/" write dup request-version write crlf ;
 
+: unparse-post-data ( request -- request )
+    dup post-data>> dup sequence? [ drop ] [
+        assoc>query >>post-data
+        "application/x-www-form-urlencoded" >>post-data-type
+    ] if ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
     over host>> [ "host" pick set-at ] when*
@@ -287,6 +307,7 @@ SYMBOL: max-post-request
     dup post-data>> [ write ] when* ;
 
 : write-request ( request -- )
+    unparse-post-data
     write-method
     write-request-url
     write-version
@@ -297,15 +318,16 @@ SYMBOL: max-post-request
 
 : request-url ( request -- url )
     [
-        dup host>> [
+        [
-            "http://" write
+            dup host>> [
-            dup host>> url-encode write
+                [ "http://" write host>> url-encode write ]
-            ":" write
+                [ ":" write port>> number>string write ]
-            dup port>> number>string write
+                bi
-        ] when
+            ] [ drop ] if
-        dup path>> "/" head? [ "/" write ] unless
+        ]
-        write-url
+        [ path>> "/" head? [ "/" write ] unless ]
-        drop
+        [ write-url ]
+        tri
     ] with-string-writer ;
 
 : set-header ( request/response value key -- request/response )

extra/http/server/actions/actions-tests.factor

@@ -29,6 +29,7 @@ blah
 STRING: action-request-test-2
 POST http://foo/bar/baz HTTP/1.1
 content-length: 5
+content-type: application/x-www-form-urlencoded
 
 xxx=4
 ;

extra/http/server/actions/actions.factor

@@ -17,14 +17,6 @@ TUPLE: action init display submit get-params post-params ;
         [ <400> ] >>display
         [ <400> ] >>submit ;
 
-: extract-params ( path -- assoc )
-    +path+ associate
-    request get dup method>> {
-        { "GET" [ query>> ] }
-        { "HEAD" [ query>> ] }
-        { "POST" [ post-data>> query>assoc ] }
-    } case union ;
-
 : with-validator ( string quot -- result error? )
     '[ , @ f ] [
         dup validation-error? [ t ] [ rethrow ] if
@@ -50,12 +42,10 @@ TUPLE: action init display submit get-params post-params ;
     action get display>> call exit-with ;
 
 M: action call-responder ( path action -- response )
-    [ extract-params params set ]
+    [ +path+ associate request-params union params set ]
-    [
+    [ action set ] bi*
-        action set
+    request get method>> {
-        request get method>> {
+        { "GET" [ handle-get ] }
-            { "GET" [ handle-get ] }
+        { "HEAD" [ handle-get ] }
-            { "HEAD" [ handle-get ] }
+        { "POST" [ handle-post ] }
-            { "POST" [ handle-post ] }
+    } case ;
-        } case
-    ] bi* ;

extra/http/server/auth/login/login.factor

@@ -30,7 +30,8 @@ SYMBOL: login-failed?
 
 : successful-login ( user -- response )
     logged-in-user sset
-    post-login-url sget f <permanent-redirect> ;
+    post-login-url sget "" or f <permanent-redirect>
+    f post-login-url sset ;
 
 :: <login-action> ( -- action )
     [let | form [ <login-form> ] |

extra/http/server/auth/login/login.fhtml

@@ -1,10 +1,13 @@
-<% USING: http.server.auth.login http.server.components kernel
+<% USING: http.server.auth.login http.server.components http.server
-namespaces ; %>
+kernel namespaces ; %>
 <html>
 <body>
 <h1>Login required</h1>
 
 <form method="POST" action="login">
+
+<% hidden-form-field %>
+
 <table>
 
 <tr>
@@ -30,10 +33,12 @@ login-failed? get
 
 <p>
 <% allow-registration? [ %>
-    <a href="register">Register</a>
+    <a href="<% "register" f write-link %>">Register</a>
 <% ] when %>
 <% allow-password-recovery? [ %>
-    <a href="recover-password">Recover Password</a>
+    <a href="<% "recover-password" f write-link %>">
+    	Recover Password
+    </a>
 <% ] when %>
 </p>
 

extra/http/server/auth/login/recover-1.fhtml

@@ -1,4 +1,4 @@
-<% USING: http.server.components ; %>
+<% USING: http.server.components http.server ; %>
 <html>
 <body>
 <h1>Recover lost password: step 1 of 4</h1>
@@ -6,6 +6,9 @@
 <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
 
 <form method="POST" action="recover-password">
+
+<% hidden-form-field %>
+
 <table>
 
 <tr>

extra/http/server/auth/login/recover-3.fhtml

@@ -1,4 +1,4 @@
-<% USING: http.server.components http.server.auth.login
+<% USING: http.server.components http.server.auth.login http.server
 namespaces kernel combinators ; %>
 <html>
 <body>
@@ -7,6 +7,9 @@ namespaces kernel combinators ; %>
 <p>Choose a new password for your account.</p>
 
 <form method="POST" action="new-password">
+
+<% hidden-form-field %>
+
 <table>
 
 <% "username" component render-edit %>
@@ -32,7 +35,7 @@ namespaces kernel combinators ; %>
 <p><input type="submit" value="Set password" />
 
 <% password-mismatch? get [
-"passwords do not match" render-error
+    "passwords do not match" render-error
 ] when %>
 
 </p>

extra/http/server/auth/login/recover-4.fhtml

@@ -1,10 +1,10 @@
-<% USING: http.server.components http.server.auth.login
+<% USING: http.server ; %>
-namespaces kernel combinators ; %>
 <html>
 <body>
 <h1>Recover lost password: step 4 of 4</h1>
 
-<p>Your password has been reset. You may now <a href="login">log in</a>.</p>
+<p>Your password has been reset.
+You may now <a href="<% "login" f write-link %>">log in</a>.</p>
 
 </body>
 </html>

extra/http/server/auth/login/register.fhtml

@@ -1,10 +1,12 @@
 <% USING: http.server.components http.server.auth.login
-namespaces kernel combinators ; %>
+http.server namespaces kernel combinators ; %>
 <html>
 <body>
 <h1>New user registration</h1>
 
 <form method="POST" action="register">
+<% hidden-form-field %>
+
 <table>
 
 <tr>

extra/http/server/auth/providers/db/db.factor

@@ -14,9 +14,7 @@ user "USERS"
     { "profile" "PROFILE" FACTOR-BLOB }
 } define-persistent
 
-: init-users-table ( -- )
+: init-users-table user ensure-table ;
-    [ user drop-table ] ignore-errors
-    user create-table ;
 
 TUPLE: from-db ;
 

extra/http/server/server.factor

@@ -9,6 +9,13 @@ IN: http.server
 
 GENERIC: call-responder ( path responder -- response )
 
+: request-params ( -- assoc )
+    request get dup method>> {
+        { "GET" [ query>> ] }
+        { "HEAD" [ query>> ] }
+        { "POST" [ post-data>> ] }
+    } case ;
+
 : <content> ( content-type -- response )
     <response>
         200 >>code
@@ -45,19 +52,27 @@ SYMBOL: 404-responder
 
 [ <404> ] <trivial-responder> 404-responder set-global
 
-: url-redirect ( to query -- url )
+SYMBOL: link-hook
-    #! Different host.
+
-    dup assoc-empty? [
+: modify-query ( query -- query )
-        drop
+    link-hook get [ ] or call ;
-    ] [
+
-        assoc>query "?" swap 3append
+: link>string ( url query -- url' )
-    ] if ;
+    modify-query (link>string) ;
+
+: write-link ( url query -- )
+    link>string write ;
+
+SYMBOL: form-hook
+
+: hidden-form-field ( -- )
+    form-hook get [ ] or call ;
 
 : absolute-redirect ( to query -- url )
     #! Same host.
     request get clone
         swap [ >>query ] when*
-        swap >>path
+        swap url-encode >>path
     request-url ;
 
 : replace-last-component ( path with -- path' )
@@ -67,11 +82,12 @@ SYMBOL: 404-responder
     request get clone
     swap [ >>query ] when*
     swap [ '[ , replace-last-component ] change-path ] when*
+    dup query>> modify-query >>query
     request-url ;
 
 : derive-url ( to query -- url )
     {
-        { [ over "http://" head? ] [ url-redirect ] }
+        { [ over "http://" head? ] [ link>string ] }
         { [ over "/" head? ] [ absolute-redirect ] }
         { [ t ] [ relative-redirect ] }
     } cond ;

extra/http/server/sessions/sessions-tests.factor

@@ -2,6 +2,8 @@ IN: http.server.sessions.tests
 USING: tools.test http.server.sessions math namespaces
 kernel accessors ;
 
+[ H{ } ] [ H{ } add-session-id ] unit-test
+
 : with-session \ session swap with-variable ; inline
 
 TUPLE: foo ;
@@ -10,7 +12,9 @@ C: <foo> foo
 
 M: foo init-session* drop 0 "x" sset ;
 
-f <session> [
+f <session> "123" >>id [
+    [ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
+
     [ ] [ 3 "x" sset ] unit-test
     
     [ 9 ] [ "x" sget sq ] unit-test

extra/http/server/sessions/sessions.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs calendar kernel math.parser namespaces random
 boxes alarms new-slots accessors http http.server
-quotations hashtables sequences fry combinators.cleave ;
+quotations hashtables sequences fry combinators.cleave
+html.elements ;
 IN: http.server.sessions
 
 ! ! ! ! ! !
@@ -67,12 +68,6 @@ TUPLE: session manager id namespace alarm ;
 : sessions ( -- manager/f )
     \ session get dup [ manager>> ] when ;
 
-GENERIC: session-link* ( url query sessions -- string )
-
-M: object session-link* 2drop url-encode ;
-
-: session-link ( url query -- string ) sessions session-link* ;
-
 TUPLE: null-sessions ;
 
 : <null-sessions>
@@ -88,23 +83,30 @@ TUPLE: url-sessions ;
 
 : sess-id "factorsessid" ;
 
-: current-session ( responder request -- session )
+: current-session ( responder -- session )
-    sess-id query-param swap get-session ;
+    >r request-params sess-id swap at r> get-session ;
+
+: add-session-id ( query -- query' )
+    \ session get [ id>> sess-id associate union ] when* ;
+
+: session-form-field ( -- )
+    <input
+    "hidden" =type
+    sess-id =id
+    sess-id =name
+    \ session get id>> =value
+    input/> ;
 
 M: url-sessions call-responder ( path responder -- response )
-    dup request get current-session [
+    [ add-session-id ] link-hook set
+    [ session-form-field ] form-hook set
+    dup current-session [
         call-responder/session
     ] [
         nip
         f swap new-session sess-id associate <temporary-redirect>
     ] if* ;
 
-M: url-sessions session-link*
-    drop
-    url-encode
-    \ session get id>> sess-id associate union assoc>query
-    dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
-
 TUPLE: cookie-sessions ;
 
 : <cookie-sessions> ( responder -- responder' )

extra/http/server/static/static.factor

@@ -10,12 +10,8 @@ IN: http.server.static
 ! special maps mime types to quots with effect ( path -- )
 TUPLE: file-responder root hook special ;
 
-: unix-time>timestamp ( n -- timestamp )
-    >r unix-1970 r> seconds time+ ;
-
 : file-http-date ( filename -- string )
-    file-info file-info-modified
+    file-info file-info-modified timestamp>http-string ;
-    unix-time>timestamp timestamp>http-string ;
 
 : last-modified-matches? ( filename -- ? )
     file-http-date dup [

extra/io/encodings/ascii/ascii-tests.factor

@@ -0,0 +1,9 @@
+USING: io.encodings.string io.encodings.ascii tools.test strings arrays ;
+IN: io.encodings.ascii.tests
+
+[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
+[ { 128 } >string ascii encode ] must-fail
+[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
+
+[ "bar" ] [ "bar" ascii decode ] unit-test
+[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test

extra/io/encodings/ascii/ascii.factor

@@ -3,13 +3,16 @@
 USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
 IN: io.encodings.ascii
 
-: encode-check<= ( string stream max -- )
+: encode-check< ( string stream max -- )
     [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
 
+: push-if< ( sbuf character max -- )
+    over <= [ drop HEX: fffd ] when swap push ;
+
 TUPLE: ascii ;
 
 M: ascii stream-write-encoded ( string stream encoding -- )
-    drop 128 encode-check<= ;
+    drop 128 encode-check< ;
 
 M: ascii decode-step
-    drop dup 128 >= [ decode-error ] [ swap push ] if ;
+    drop 128 push-if< ;

extra/io/encodings/latin1/latin1-tests.factor

@@ -0,0 +1,9 @@
+USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
+IN: io.encodings.latin1.tests
+
+[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
+[ { 256 } >string latin1 encode ] must-fail
+[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
+
+[ "bar" ] [ "bar" latin1 decode ] unit-test
+[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test

extra/io/encodings/latin1/latin1.factor

@@ -6,7 +6,7 @@ IN: io.encodings.latin1
 TUPLE: latin1 ;
 
 M: latin1 stream-write-encoded 
-    drop 256 encode-check<= ;
+    drop 256 encode-check< ;
 
 M: latin1 decode-step
     drop swap push ;

extra/io/mmap/mmap-tests.factor

@@ -4,7 +4,7 @@ IN: io.mmap.tests
 
 [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
 [ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
 [ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
 [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors

extra/io/unix/files/files.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.backend io.nonblocking io.unix.backend io.files io
-unix unix.stat unix.time kernel math continuations math.bitfields
+unix unix.stat unix.time kernel math continuations
-byte-arrays alien combinators combinators.cleave calendar
+math.bitfields byte-arrays alien combinators combinators.cleave
-io.encodings.binary ;
+calendar io.encodings.binary ;
 
 IN: io.unix.files
 
 M: unix-io cwd
-    MAXPATHLEN dup <byte-array> swap
+    MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
-    getcwd [ (io-error) ] unless* ;
+    [ (io-error) ] unless* ;
 
 M: unix-io cd
     chdir io-error ;
@@ -68,7 +68,9 @@ M: unix-io delete-directory ( path -- )
     ] with-disposal ;
 
 M: unix-io copy-file ( from to -- )
-    [ (copy-file) ] 2keep swap file-info file-info-permissions io-error ;
+    [ (copy-file) ]
+    [ swap file-info file-info-permissions chmod  io-error ]
+    2bi ;
 
 : stat>type ( stat -- type )
     stat-st_mode {
@@ -82,8 +84,8 @@ M: unix-io copy-file ( from to -- )
         { [ t            ] [ +unknown+          ] }
       } cond nip ;
 
-M: unix-io file-info ( path -- info )
+: stat>file-info ( stat -- info )
-    stat* {
+    {
         [ stat>type ]
         [ stat-st_size ]
         [ stat-st_mode ]
@@ -91,11 +93,8 @@ M: unix-io file-info ( path -- info )
     } cleave
     \ file-info construct-boa ;
 
+M: unix-io file-info ( path -- info )
+    stat* stat>file-info ;
+
 M: unix-io link-info ( path -- info )
-    lstat* {
+    lstat* stat>file-info ;
-        [ stat>type ]
-        [ stat-st_size ]
-        [ stat-st_mode ]
-        [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
-    } cleave
-    \ file-info construct-boa ;

extra/io/windows/windows.factor

@@ -76,7 +76,7 @@ M: win32-file close-handle ( handle -- )
     ] when drop ;
 
 : open-append ( path -- handle length )
-    dup file-length dup [
+    dup file-info file-info-size dup [
         >r (open-append) r> 2dup set-file-pointer
     ] [
         drop open-write

extra/tools/deploy/deploy-tests.factor

@@ -12,25 +12,25 @@ tools.deploy.backend math sequences io.launcher ;
 [ ] [ "hello-world" shake-and-bake ] unit-test
 
 [ t ] [
-    "hello.image" temp-file file-length 500000 <=
+    "hello.image" temp-file file-info file-info-size 500000 <=
 ] unit-test
 
 [ ] [ "sudoku" shake-and-bake ] unit-test
 
 [ t ] [
-    "hello.image" temp-file file-length 1500000 <=
+    "hello.image" temp-file file-info file-info-size 1500000 <=
 ] unit-test
 
 [ ] [ "hello-ui" shake-and-bake ] unit-test
 
 [ t ] [
-    "hello.image" temp-file file-length 2000000 <=
+    "hello.image" temp-file file-info file-info-size 2000000 <=
 ] unit-test
 
 [ ] [ "bunny" shake-and-bake ] unit-test
 
 [ t ] [
-    "hello.image" temp-file file-length 3000000 <=
+    "hello.image" temp-file file-info file-info-size 3000000 <=
 ] unit-test
 
 [ ] [