diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index aeb5ec1d82..b900b2fd49 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -98,26 +98,36 @@ H{ } clone classr dup make-inline >r - dup dup lookup-type-number "type" set-word-prop +: register-builtin ( class -- ) + dup + 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 r> 1 simple-slots 2dup "slots" set-word-prop - dupd define-slots - register-builtin ; + dup define-builtin-predicate + r> define-builtin-slots ; H{ } clone typemap set num-types get f builtins set @@ -128,17 +138,15 @@ num-types get f 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 -{ } define-builtin +"tuple" "kernel" create { } define-builtin -"ratio" "math" create "ratio?" "math" create -{ +"ratio" "math" create { { { "integer" "math" } "numerator" @@ -153,11 +161,10 @@ num-types get f 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 builtins set } } define-builtin -"f" "syntax" lookup "not" "kernel" create -{ } define-builtin +"f" "syntax" lookup { } define-builtin -"array" "arrays" create "array?" "arrays" create -{ } define-builtin +! do not word... -"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 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 builtins set } } define-builtin -"quotation" "quotations" create "quotation?" "quotations" create -{ +"quotation" "quotations" create { { { "object" "kernel" } "array" @@ -219,8 +223,7 @@ num-types get f 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 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 -{ } define-builtin +"callstack" "kernel" create { } define-builtin ! Define general-t type, which is any object that is not f. "general-t" "kernel" create diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor index 48891593d2..444e5b6ea7 100644 --- a/extra/builder/benchmark/benchmark.factor +++ b/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 ; diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index da96e51dd4..52150b07a8 100644 --- a/extra/builder/builder.factor +++ b/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. diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 409d0db11c..54c40f18c8 100755 --- a/extra/builder/test/test.factor +++ b/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 - "../test-all-vocabs" utf8 - [ - [ keys . ] - [ test-failures. ] - bi - ] - with-file-writer ; + run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; + +! : do-tests ( -- ) +! run-all-tests +! "../test-all-vocabs" utf8 +! [ +! [ keys . ] +! [ test-failures. ] +! bi +! ] +! with-file-writer ; : do-help-lint ( -- ) "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ; diff --git a/extra/combinators/cleave/cleave-docs.factor b/extra/combinators/cleave/cleave-docs.factor index 18968628d5..46e9abcd9f 100644 --- a/extra/combinators/cleave/cleave-docs.factor +++ b/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* } diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 72b300b585..319dd1586b 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/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 [ reverse-here ] change-each" "] with-mapped-file" } diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index ee0d5f7f3b..6d875ef560 100755 --- a/extra/http/client/client.factor +++ b/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. - >r url-encode r> http-request contents ; + http-request contents ; diff --git a/extra/http/http.factor b/extra/http/http.factor index c72a631d16..4dd433f85d 100755 --- a/extra/http/http.factor +++ b/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 - over digit? or - swap "/_-." member? or ; foldable + { + [ dup letter? ] + [ dup LETTER? ] + [ 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 - ] each ] "" make ; + [ + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each + ] "" 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 construct-empty - "1.1" >>version - http-port >>port - H{ } clone >>query - V{ } clone >>cookies ; + "1.1" >>version + http-port >>port + H{ } clone >>query + 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 ) - dup path>> url-encode write - dup query>> dup assoc-empty? [ drop ] [ - "?" write - assoc>query write - ] if ; +: (link>string) ( url query -- url' ) + [ url-encode ] [ assoc>query ] bi* + dup empty? [ drop ] [ "?" swap 3append ] if ; + +: write-url ( request -- ) + [ 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>> url-encode write - ":" write - dup port>> number>string write - ] when - dup path>> "/" head? [ "/" write ] unless - write-url - drop + [ + dup host>> [ + [ "http://" write host>> url-encode write ] + [ ":" write port>> number>string write ] + bi + ] [ drop ] if + ] + [ path>> "/" head? [ "/" write ] unless ] + [ write-url ] + tri ] with-string-writer ; : set-header ( request/response value key -- request/response ) diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 98a92e083a..45f7ff385d 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/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 ; diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index bab55eef0c..72c2d2df8e 100755 --- a/extra/http/server/actions/actions.factor +++ b/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 ] - [ - action set - request get method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case - ] bi* ; + [ +path+ associate request-params union params set ] + [ action set ] bi* + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 7d92c727c6..9b2648158d 100755 --- a/extra/http/server/auth/login/login.factor +++ b/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 ; + post-login-url sget "" or f + f post-login-url sset ; :: ( -- action ) [let | form [ ] | diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml index 8e879420a9..07201719e5 100755 --- a/extra/http/server/auth/login/login.fhtml +++ b/extra/http/server/auth/login/login.fhtml @@ -1,10 +1,13 @@ -<% USING: http.server.auth.login http.server.components kernel -namespaces ; %> +<% USING: http.server.auth.login http.server.components http.server +kernel namespaces ; %>

Login required

+ +<% hidden-form-field %> + @@ -30,10 +33,12 @@ login-failed? get

<% allow-registration? [ %> - Register + ">Register <% ] when %> <% allow-password-recovery? [ %> - Recover Password + "> + Recover Password + <% ] when %>

diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml index 3e8448f64b..8ec01f22e9 100755 --- a/extra/http/server/auth/login/recover-1.fhtml +++ b/extra/http/server/auth/login/recover-1.fhtml @@ -1,4 +1,4 @@ -<% USING: http.server.components ; %> +<% USING: http.server.components http.server ; %>

Recover lost password: step 1 of 4

@@ -6,6 +6,9 @@

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.

+ +<% hidden-form-field %> +
diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml index b220cc4f75..edd32fffe8 100755 --- a/extra/http/server/auth/login/recover-3.fhtml +++ b/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 ; %> @@ -7,6 +7,9 @@ namespaces kernel combinators ; %>

Choose a new password for your account.

+ +<% hidden-form-field %> +
<% "username" component render-edit %> @@ -32,7 +35,7 @@ namespaces kernel combinators ; %>

<% password-mismatch? get [ -"passwords do not match" render-error + "passwords do not match" render-error ] when %>

diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml index dec7a5404f..239d71d293 100755 --- a/extra/http/server/auth/login/recover-4.fhtml +++ b/extra/http/server/auth/login/recover-4.fhtml @@ -1,10 +1,10 @@ -<% USING: http.server.components http.server.auth.login -namespaces kernel combinators ; %> +<% USING: http.server ; %>

Recover lost password: step 4 of 4

-

Your password has been reset. You may now log in.

+

Your password has been reset. +You may now ">log in.

diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml index c7e274e626..99d1547d03 100755 --- a/extra/http/server/auth/login/register.fhtml +++ b/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 ; %>

New user registration

+<% hidden-form-field %> +
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index e9e79ff82f..c9e1328052 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -14,9 +14,7 @@ user "USERS" { "profile" "PROFILE" FACTOR-BLOB } } define-persistent -: init-users-table ( -- ) - [ user drop-table ] ignore-errors - user create-table ; +: init-users-table user ensure-table ; TUPLE: from-db ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index b3fafc543f..60bb5d921d 100755 --- a/extra/http/server/server.factor +++ b/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-type -- response ) 200 >>code @@ -45,19 +52,27 @@ SYMBOL: 404-responder [ <404> ] 404-responder set-global -: url-redirect ( to query -- url ) - #! Different host. - dup assoc-empty? [ - drop - ] [ - assoc>query "?" swap 3append - ] if ; +SYMBOL: link-hook + +: modify-query ( query -- query ) + link-hook get [ ] or call ; + +: link>string ( url query -- url' ) + 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 ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 5c2d3a57cd..5530b04611 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/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 M: foo init-session* drop 0 "x" sset ; -f [ +f "123" >>id [ + [ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test + [ ] [ 3 "x" sset ] unit-test [ 9 ] [ "x" sget sq ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 1d90a32faf..260c80914e 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/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 ; : @@ -88,23 +83,30 @@ TUPLE: url-sessions ; : sess-id "factorsessid" ; -: current-session ( responder request -- session ) - sess-id query-param swap get-session ; +: current-session ( responder -- 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 ( -- ) + > =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 ] 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 ; : ( responder -- responder' ) diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 9c05b87a71..b408b1b6b0 100755 --- a/extra/http/server/static/static.factor +++ b/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 - unix-time>timestamp timestamp>http-string ; + file-info file-info-modified timestamp>http-string ; : last-modified-matches? ( filename -- ? ) file-http-date dup [ diff --git a/extra/io/encodings/ascii/ascii-tests.factor b/extra/io/encodings/ascii/ascii-tests.factor new file mode 100644 index 0000000000..4f6d28835a --- /dev/null +++ b/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 diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 1c50e4c2a4..bd71b733f1 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/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< ; diff --git a/extra/io/encodings/latin1/latin1-tests.factor b/extra/io/encodings/latin1/latin1-tests.factor new file mode 100644 index 0000000000..a89bfe0e6f --- /dev/null +++ b/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 diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index 3cb361b2fd..71e98a1747 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/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 ; diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor old mode 100644 new mode 100755 index f1c65178d9..c75c7b9bd4 --- a/extra/io/mmap/mmap-tests.factor +++ b/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 -[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] 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-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 diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index bdcd0b985d..1e7d682314 100755 --- a/extra/io/unix/files/files.factor +++ b/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 -byte-arrays alien combinators combinators.cleave calendar -io.encodings.binary ; +unix unix.stat unix.time kernel math continuations +math.bitfields byte-arrays alien combinators combinators.cleave +calendar io.encodings.binary ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup swap - getcwd [ (io-error) ] unless* ; + MAXPATHLEN [ ] [ ] bi getcwd + [ (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* { +: stat>file-info ( stat -- info ) + { [ 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* { - [ stat>type ] - [ stat-st_size ] - [ stat-st_mode ] - [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] - } cleave - \ file-info construct-boa ; + lstat* stat>file-info ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 094a6ec0d6..f6a9dd451f 100755 --- a/extra/io/windows/windows.factor +++ b/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 diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index c68c259a6e..a6e126ea9e 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/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 [ ] [