From a7ee1d2642a39929f79a8d54d27fc1a36e66f85b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 26 Feb 2008 19:32:33 -0600 Subject: [PATCH 01/49] Assuring that \r\n is included as blank in unicode.categories --- extra/unicode/categories/categories.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/unicode/categories/categories.factor b/extra/unicode/categories/categories.factor index e5f157463d..4ba96fb9c4 100644 --- a/extra/unicode/categories/categories.factor +++ b/extra/unicode/categories/categories.factor @@ -1,7 +1,7 @@ USING: unicode.syntax ; IN: unicode.categories -CATEGORY: blank Zs Zl Zp ; +CATEGORY: blank Zs Zl Zp \r\n ; CATEGORY: letter Ll ; CATEGORY: LETTER Lu ; CATEGORY: Letter Lu Ll Lt Lm Lo ; From 914456f31578965c0f07fcaa6c065e5f48bc6230 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:07:25 -0600 Subject: [PATCH 02/49] year month day > timestamp year month day hour minute second > timestamp --- extra/calendar/format/format.factor | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 75ceea8ea2..d89afe615e 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -125,6 +125,35 @@ M: timestamp year. ( timestamp -- ) : rfc3339>timestamp ( str -- timestamp ) [ (rfc3339>timestamp) ] with-string-reader ; +: (ymdhms>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + " " expect + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + 0 ! timezone + ; + +: ymdhms>timestamp ( str -- timestamp ) + [ (ymdhms>timestamp) ] with-string-reader ; + +: (ymd>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + 0 0 0 0 ; + +: ymd>timestamp ( str -- timestamp ) + [ (ymd>timestamp) ] with-string-reader ; + : file-time-string ( timestamp -- string ) [ [ month>> month-abbreviations nth write ] keep bl From 82ed128f4733d1939bed9b4d64f0e4364c3aca94 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:10:29 -0600 Subject: [PATCH 03/49] make unknown elements f instead of 0 add hours:minutes:seconds --- extra/calendar/format/format.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index d89afe615e..9b349fcc6c 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -143,13 +143,25 @@ M: timestamp year. ( timestamp -- ) : ymdhms>timestamp ( str -- timestamp ) [ (ymdhms>timestamp) ] with-string-reader ; +: (hms>timestamp) ( -- timestamp ) + f f f + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + f ; + +: hms>timestamp ( str -- timestamp ) + [ (hms>timestamp) ] with-string-reader ; + : (ymd>timestamp) ( -- timestamp ) read-0000 ! year "-" expect read-00 ! month "-" expect read-00 ! day - 0 0 0 0 ; + f f f f ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; From 2c3b23286f823dde18effb55c5578adc066cac29 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:21:02 -0600 Subject: [PATCH 04/49] add timestamp>ymdhms and related code --- extra/calendar/format/format.factor | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 9b349fcc6c..c1bd6427a7 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -166,6 +166,34 @@ M: timestamp year. ( timestamp -- ) : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; + +: (timestamp>ymd) ( timestamp -- ) + dup timestamp-year number>string write + "-" write + dup timestamp-month write-00 + "-" write + timestamp-day write-00 ; + +: timestamp>ymd ( timestamp -- str ) + [ (timestamp>ymd) ] with-string-writer ; + +: (timestamp>hms) + dup timestamp-hour write-00 + ":" write + dup timestamp-minute write-00 + ":" write + timestamp-second >integer write-00 ; + +: timestamp>hms ( timestamp -- str ) + [ (timestamp>hms) ] with-string-writer ; + +: timestamp>ymdhms ( timestamp -- str ) + [ + dup (timestamp>ymd) + " " write + (timestamp>hms) + ] with-string-writer ; + : file-time-string ( timestamp -- string ) [ [ month>> month-abbreviations nth write ] keep bl From 2aabeb9bb3d16d021737c9ea28c8c1fc7a969cdc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 17:40:42 -0600 Subject: [PATCH 05/49] add failing unit test to farkup --- extra/farkup/farkup-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 2e0d9832b0..f4b3025fcd 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -42,3 +42,7 @@ IN: farkup.tests [ "

foo\n

aheading

\n

adfasd

" ] [ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test + +[ "

=foo\n

" ] [ "=foo\n" convert-farkup ] unit-test +[ "

foo

\n" ] [ "=foo=\n" convert-farkup ] unit-test +[ "

lol

foo

\n" ] [ "lol=foo=\n" convert-farkup ] unit-test From f84761ae0c5c0a172787d71312a87d6be518af21 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 18:15:28 -0600 Subject: [PATCH 06/49] fix docs for delay --- extra/peg/peg-docs.factor | 3 ++- extra/peg/peg.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 6dff95c829..9ad375ea04 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -135,9 +135,10 @@ HELP: hide HELP: delay { $values + { "quot" "a quotation" } { "parser" "a parser" } } { $description "Delays the construction of a parser until it is actually required to parse. This " "allows for calling a parser that results in a recursive call to itself. The quotation " - "should return the constructed parser." } ; \ No newline at end of file + "should return the constructed parser." } ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 01decc2c81..16cf40f884 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -358,7 +358,7 @@ MEMO: sp ( parser -- parser ) MEMO: hide ( parser -- parser ) [ drop ignore ] action ; -MEMO: delay ( parser -- parser ) +MEMO: delay ( quot -- parser ) delay-parser construct-boa init-parser ; : PEG: From 3eb7830d2c7c99aef369a7a3a5b1f5ec4deb0584 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 19:08:33 -0600 Subject: [PATCH 07/49] before major overhaul on return values --- extra/db/sqlite/lib/lib.factor | 32 +++++++++--- extra/db/sqlite/sqlite.factor | 8 ++- extra/db/tuples/tuples-tests.factor | 75 ++++++++++++++++++++++------- extra/db/types/types.factor | 28 ++++++----- 4 files changed, 105 insertions(+), 38 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 648d8493dc..40486ba19f 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -2,7 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators -continuations db.types ; +continuations db.types calendar.format serialize +io.streams.string byte-arrays ; +USE: tools.walker IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -55,6 +57,10 @@ IN: db.sqlite.lib : sqlite-bind-null ( handle i -- ) sqlite3_bind_null sqlite-check-result ; +: sqlite-bind-blob ( handle i byte-array -- ) + dup length SQLITE_TRANSIENT + sqlite3_bind_blob sqlite-check-result ; + : sqlite-bind-text-by-name ( handle name text -- ) parameter-index sqlite-bind-text ; @@ -67,20 +73,33 @@ IN: db.sqlite.lib : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; +: sqlite-bind-blob-by-name ( handle name blob -- ) + parameter-index sqlite-bind-blob ; + : sqlite-bind-null-by-name ( handle name obj -- ) parameter-index drop sqlite-bind-null ; : sqlite-bind-type ( handle key value type -- ) + over [ drop NULL ] unless dup array? [ first ] when { { INTEGER [ sqlite-bind-int-by-name ] } - { BIG_INTEGER [ sqlite-bind-int64-by-name ] } + { BIG-INTEGER [ sqlite-bind-int64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { TIMESTAMP [ sqlite-bind-double-by-name ] } + { DATE [ sqlite-bind-text-by-name ] } + { TIME [ sqlite-bind-text-by-name ] } + { DATETIME [ sqlite-bind-text-by-name ] } + { TIMESTAMP [ sqlite-bind-text-by-name ] } + { BLOB [ sqlite-bind-blob-by-name ] } + { FACTOR-BLOB [ + break + [ serialize ] with-string-writer >byte-array + sqlite-bind-blob-by-name + ] } { +native-id+ [ sqlite-bind-int-by-name ] } - ! { NULL [ sqlite-bind-null-by-name ] } + { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -93,21 +112,20 @@ IN: db.sqlite.lib : sqlite-#columns ( query -- int ) sqlite3_column_count ; -! TODO : sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column-typed ( handle index type -- obj ) { { INTEGER [ sqlite3_column_int ] } - { BIG_INTEGER [ sqlite3_column_int64 ] } + { BIG-INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } { TIMESTAMP [ sqlite3_column_double ] } + ! { NULL [ 2drop f ] } [ no-sql-type ] } case ; -! TODO : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index cfdcfc7750..1e55dc8331 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -179,8 +179,7 @@ M: sqlite-db ( tuple class -- statement ) " where " 0% [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ";" 0% - ] if + ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) @@ -209,8 +208,13 @@ M: sqlite-db type-table ( -- assoc ) { INTEGER "integer" } { TEXT "text" } { VARCHAR "text" } + { DATE "date" } + { TIME "time" } + { DATETIME "datetime" } { TIMESTAMP "timestamp" } { DOUBLE "real" } + { BLOB "blob" } + { FACTOR-BLOB "blob" } } ; M: sqlite-db create-type-table diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 517f8bcc36..e30b06411f 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,39 +2,45 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math -prettyprint tools.walker db.sqlite ; +prettyprint tools.walker db.sqlite calendar ; IN: db.tuples.tests -TUPLE: person the-id the-name the-number the-real ; +TUPLE: person the-id the-name the-number the-real ts date time blob ; : ( name age real -- person ) { set-person-the-name set-person-the-number set-person-the-real + set-person-ts + set-person-date + set-person-time + set-person-blob } person construct ; : ( id name number the-real -- obj ) [ set-person-the-id ] keep ; -SYMBOL: the-person1 -SYMBOL: the-person2 +SYMBOL: person1 +SYMBOL: person2 +SYMBOL: person3 +SYMBOL: person4 : test-tuples ( -- ) [ person drop-table ] [ drop ] recover [ ] [ person create-table ] unit-test [ person create-table ] must-fail - [ ] [ the-person1 get insert-tuple ] unit-test + [ ] [ person1 get insert-tuple ] unit-test - [ 1 ] [ the-person1 get person-the-id ] unit-test + [ 1 ] [ person1 get person-the-id ] unit-test - 200 the-person1 get set-person-the-number + 200 person1 get set-person-the-number - [ ] [ the-person1 get update-tuple ] unit-test + [ ] [ person1 get update-tuple ] unit-test [ T{ person f 1 "billy" 200 3.14 } ] [ T{ person f 1 } select-tuple ] unit-test - [ ] [ the-person2 get insert-tuple ] unit-test + [ ] [ person2 get insert-tuple ] unit-test [ { T{ person f 1 "billy" 200 3.14 } @@ -49,8 +55,19 @@ SYMBOL: the-person2 ] [ T{ person f } select-tuples ] unit-test - [ ] [ the-person1 get delete-tuple ] unit-test + [ ] [ person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test + + [ ] [ person3 get insert-tuple ] unit-test + + [ + T{ person f 3 "teddy" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 0 } + T{ timestamp f 2008 11 22 f f f f } + T{ timestamp f f f f 12 34 56 f } + "storeinablob" } + ] [ T{ person f 3 } select-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : make-native-person-table ( -- ) @@ -67,9 +84,14 @@ SYMBOL: the-person2 { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } } define-persistent - "billy" 10 3.14 the-person1 set - "johnny" 10 3.14 the-person2 set ; + "billy" 10 3.14 f f f f person1 set + "johnny" 10 3.14 f f f f person2 set + "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; : assigned-person-schema ( -- ) person "PERSON" @@ -78,10 +100,14 @@ SYMBOL: the-person2 { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } } define-persistent - 1 "billy" 10 3.14 the-person1 set - 2 "johnny" 10 3.14 the-person2 set ; - + 1 "billy" 10 3.14 f f f f person1 set + 2 "johnny" 10 3.14 f f f f person2 set + 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -125,7 +151,22 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; -[ native-person-schema test-tuples ] test-sqlite -[ assigned-person-schema test-tuples ] test-sqlite + +! [ native-person-schema test-tuples ] test-sqlite +! [ assigned-person-schema test-tuples ] test-sqlite + +TUPLE: serialize-me id data ; +[ + serialize-me "SERIALIZED" + { + { "id" "ID" +native-id+ } + { "data" "DATA" FACTOR-BLOB } + } define-persistent + [ serialize-me drop-table ] [ drop ] recover + [ ] [ serialize-me create-table ] unit-test + + [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test + [ ] [ T{ serialize-me f 1 } select-tuples ] unit-test +] test-sqlite ! [ make-native-person-table ] test-sqlite diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index c84b23c50f..89c26c1dd6 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,7 +3,8 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators ; +mirrors tuples combinators calendar.format serialize +io.streams.string ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -60,14 +61,19 @@ SYMBOL: +has-many+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; SYMBOL: INTEGER -SYMBOL: BIG_INTEGER +SYMBOL: BIG-INTEGER SYMBOL: DOUBLE SYMBOL: REAL SYMBOL: BOOLEAN SYMBOL: TEXT SYMBOL: VARCHAR -SYMBOL: TIMESTAMP SYMBOL: DATE +SYMBOL: TIME +SYMBOL: DATETIME +SYMBOL: TIMESTAMP +SYMBOL: BLOB +SYMBOL: FACTOR-BLOB +SYMBOL: NULL : spec>tuple ( class spec -- tuple ) [ ?first3 ] keep 3 ?tail* @@ -80,15 +86,6 @@ SYMBOL: DATE } sql-spec construct dup normalize-spec ; -: sql-type-hash ( -- assoc ) - H{ - { INTEGER "integer" } - { TEXT "text" } - { VARCHAR "varchar" } - { DOUBLE "real" } - { TIMESTAMP "timestamp" } - } ; - TUPLE: no-sql-type ; : no-sql-type ( -- * ) T{ no-sql-type } throw ; @@ -212,13 +209,20 @@ TUPLE: no-slot-named ; ] curry { } map>assoc ; : sql-type>factor-type ( obj type -- obj ) +break dup array? [ first ] when { { +native-id+ [ string>number ] } { INTEGER [ string>number ] } { DOUBLE [ string>number ] } { REAL [ string>number ] } + { DATE [ dup [ ymd>timestamp ] when ] } + { TIME [ dup [ hms>timestamp ] when ] } + { DATETIME [ dup [ ymdhms>timestamp ] when ] } + { TIMESTAMP [ dup [ ymdhms>timestamp ] when ] } { TEXT [ ] } { VARCHAR [ ] } + { BLOB [ ] } + { FACTOR-BLOB [ break [ deserialize ] with-string-reader ] } [ "no conversion from sql type to factor type" throw ] } case ; From dfb3dac5fd50973af8c2f4bae99cfab90db5f071 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 19:59:29 -0600 Subject: [PATCH 08/49] sqlite now gets return types with the optimized native functions removed a hack in type conversion serialize arbitrary factor objects to db --- extra/db/db.factor | 10 +++++++--- extra/db/sqlite/lib/lib.factor | 21 +++++++++++++++++++-- extra/db/sqlite/sqlite.factor | 5 +++-- extra/db/tuples/tuples-tests.factor | 19 ++++++++++++++----- extra/db/tuples/tuples.factor | 11 ++++------- extra/db/types/types.factor | 19 ------------------- 6 files changed, 47 insertions(+), 38 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index e834144d0c..170d9a60f1 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -34,7 +34,7 @@ HOOK: db-close db ( handle -- ) TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; -TUPLE: result-set sql params handle n max ; +TUPLE: result-set sql in-params out-params handle n max ; : ( sql in out -- statement ) { (>>sql) (>>in-params) (>>out-params) } statement construct ; @@ -47,6 +47,7 @@ GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC# row-column-typed 1 ( result-set n -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) @@ -67,13 +68,16 @@ GENERIC: more-rows? ( result-set -- ? ) 0 >>n drop ; : ( query handle tuple -- result-set ) - >r >r { sql>> in-params>> } get-slots r> - { (>>sql) (>>params) (>>handle) } result-set + >r >r { sql>> in-params>> out-params>> } get-slots r> + { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; +: sql-row-typed ( result-set -- seq ) + dup #columns [ row-column-typed ] with map ; + : query-each ( statement quot -- ) over more-rows? [ [ call ] 2keep over advance-row query-each diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 40486ba19f..f11f1e2ba6 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -94,7 +94,6 @@ IN: db.sqlite.lib { TIMESTAMP [ sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ - break [ serialize ] with-string-writer >byte-array sqlite-bind-blob-by-name ] } @@ -115,13 +114,31 @@ IN: db.sqlite.lib : sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-blob ( handle index -- byte-array/f ) + [ sqlite3_column_bytes ] 2keep + pick zero? [ + 3drop f + ] [ + sqlite3_column_blob swap memory>byte-array + ] if ; + : sqlite-column-typed ( handle index type -- obj ) + dup array? [ first ] when { + { +native-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } + { VARCHAR [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } - { TIMESTAMP [ sqlite3_column_double ] } + { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] } + { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] } + { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { BLOB [ sqlite-column-blob ] } + { FACTOR-BLOB [ + sqlite-column-blob [ deserialize ] with-string-reader + ] } ! { NULL [ 2drop f ] } [ no-sql-type ] } case ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1e55dc8331..1524ee5a4f 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -80,8 +80,9 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; -M: sqlite-result-set row-column-typed ( result-set n type -- obj ) - >r result-set-handle r> sqlite-column-typed ; +M: sqlite-result-set row-column-typed ( result-set n -- obj ) + dup pick result-set-out-params nth sql-spec-type + >r >r result-set-handle r> r> sqlite-column-typed ; M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index e30b06411f..c9ceffe035 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -61,11 +61,18 @@ SYMBOL: person4 [ ] [ person3 get insert-tuple ] unit-test [ - T{ person f 3 "teddy" 10 3.14 + T{ + person + f + 3 + "teddy" + 10 + 3.14 T{ timestamp f 2008 3 5 16 24 11 0 } T{ timestamp f 2008 11 22 f f f f } T{ timestamp f f f f 12 34 56 f } - "storeinablob" } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } + } ] [ T{ person f 3 } select-tuple ] unit-test [ ] [ person drop-table ] unit-test ; @@ -152,8 +159,8 @@ TUPLE: annotation n paste-id summary author mode contents ; >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; -! [ native-person-schema test-tuples ] test-sqlite -! [ assigned-person-schema test-tuples ] test-sqlite +[ native-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-tuples ] test-sqlite TUPLE: serialize-me id data ; [ @@ -166,7 +173,9 @@ TUPLE: serialize-me id data ; [ ] [ serialize-me create-table ] unit-test [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test - [ ] [ T{ serialize-me f 1 } select-tuples ] unit-test + [ + { T{ serialize-me f 1 H{ { 1 2 } } } } + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ] test-sqlite ! [ make-native-person-table ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e7fe7e49c2..10a7c115ac 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -37,27 +37,24 @@ HOOK: db ( class -- obj ) HOOK: db ( tuple -- tuple ) -HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: insert-tuple* db ( tuple statement -- ) : resulting-tuple ( row out-params -- tuple ) dup first sql-spec-class construct-empty [ [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ] keep ; : query-tuples ( statement -- seq ) [ statement-out-params ] keep query-results [ - [ sql-row swap resulting-tuple ] with query-map + [ sql-row-typed swap resulting-tuple ] with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) - [ query-results [ sql-row ] with-disposal ] keep + [ query-results [ sql-row-typed ] with-disposal ] keep statement-out-params rot [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ; : sql-props ( class -- columns table ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 89c26c1dd6..c2aa825db8 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -207,22 +207,3 @@ TUPLE: no-slot-named ; >r dup sql-spec-type swap sql-spec-slot-name r> get-slot-named swap ] curry { } map>assoc ; - -: sql-type>factor-type ( obj type -- obj ) -break - dup array? [ first ] when - { - { +native-id+ [ string>number ] } - { INTEGER [ string>number ] } - { DOUBLE [ string>number ] } - { REAL [ string>number ] } - { DATE [ dup [ ymd>timestamp ] when ] } - { TIME [ dup [ hms>timestamp ] when ] } - { DATETIME [ dup [ ymdhms>timestamp ] when ] } - { TIMESTAMP [ dup [ ymdhms>timestamp ] when ] } - { TEXT [ ] } - { VARCHAR [ ] } - { BLOB [ ] } - { FACTOR-BLOB [ break [ deserialize ] with-string-reader ] } - [ "no conversion from sql type to factor type" throw ] - } case ; From b8eb5abd13b84a068a33b30fb928d87ed83f569d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 20:56:40 -0600 Subject: [PATCH 09/49] before major query overhaul --- extra/db/sqlite/sqlite.factor | 12 +++----- extra/db/tuples/tuples-tests.factor | 48 +++++++++++++++++++++++------ 2 files changed, 44 insertions(+), 16 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1524ee5a4f..643b42165d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -142,6 +142,10 @@ M: sqlite-db ( tuple -- statement ) " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; +: where-clause ( specs -- ) + " where " 0% + [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + M: sqlite-db ( class -- statement ) [ "update " 0% @@ -174,13 +178,7 @@ M: sqlite-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - dup empty? [ - drop - ] [ - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ] if ";" 0% + dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9ceffe035..3a1e2c4f25 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,11 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math -prettyprint tools.walker db.sqlite calendar ; +prettyprint tools.walker db.sqlite calendar +math.intervals ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real ts date time blob ; -: ( name age real -- person ) +: ( name age real ts date time blob -- person ) { set-person-the-name set-person-the-number @@ -17,7 +18,7 @@ TUPLE: person the-id the-name the-number the-real ts date time blob ; set-person-blob } person construct ; -: ( id name number the-real -- obj ) +: ( id name age real ts date time blob -- person ) [ set-person-the-id ] keep ; SYMBOL: person1 @@ -54,6 +55,12 @@ SYMBOL: person4 } ] [ T{ person f } select-tuples ] unit-test + [ + { + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test + [ ] [ person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test @@ -151,19 +158,18 @@ TUPLE: annotation n paste-id summary author mode contents ; ! [ ] [ annotation create-table ] unit-test ! ] with-db - : test-sqlite ( quot -- ) >r "tuples-test.db" resource-path sqlite-db r> with-db ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; - [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite TUPLE: serialize-me id data ; -[ + +: test-serialize ( -- ) serialize-me "SERIALIZED" { { "id" "ID" +native-id+ } @@ -175,7 +181,31 @@ TUPLE: serialize-me id data ; [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test [ { T{ serialize-me f 1 H{ { 1 2 } } } } - ] [ T{ serialize-me f 1 } select-tuples ] unit-test -] test-sqlite + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -! [ make-native-person-table ] test-sqlite +! [ test-serialize ] test-sqlite + +TUPLE: exam id name score ; + +: test-ranges ( -- ) + exam "EXAM" + { + { "id" "ID" +native-id+ } + { "name" "NAME" TEXT } + { "score" "SCORE" INTEGER } + } define-persistent + [ exam drop-table ] [ drop ] recover + [ ] [ exam create-table ] unit-test + + [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test + + [ + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test + ; + +! [ test-ranges ] test-sqlite From 6fe9e6f1ce7b69d1220fdb40183d2503fdb7b799 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 21:35:08 -0600 Subject: [PATCH 10/49] add singleton classes --- extra/singleton/authors.txt | 1 + extra/singleton/singleton-docs.factor | 14 ++++++++++++++ extra/singleton/singleton.factor | 9 +++++++++ 3 files changed, 24 insertions(+) create mode 100644 extra/singleton/authors.txt create mode 100644 extra/singleton/singleton-docs.factor create mode 100644 extra/singleton/singleton.factor diff --git a/extra/singleton/authors.txt b/extra/singleton/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/singleton/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor new file mode 100644 index 0000000000..b87c557366 --- /dev/null +++ b/extra/singleton/singleton-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ; +IN: singleton + +HELP: SINGLETON: +{ $syntax "SINGLETON: class" +} { $values + { "class" "a new tuple class to define" } +} { $description + "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself." +} { $examples + { $example "SINGLETON: foo\nfoo ." "T{ foo f }" } +} { $see-also + POSTPONE: TUPLE: +} ; diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor new file mode 100644 index 0000000000..3a9af90071 --- /dev/null +++ b/extra/singleton/singleton.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser quotations tuples words ; +IN: singleton + +: SINGLETON: + CREATE-CLASS + dup { } define-tuple-class + dup construct-empty 1quotation define ; parsing From 9f66ce692e76f48b23f411791efa8b5c7d9167df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 21:37:25 -0600 Subject: [PATCH 11/49] begin work on regexp2 --- extra/regexp2/regexp2-tests.factor | 5 + extra/regexp2/regexp2.factor | 262 +++++++++++++++++++++++++++++ 2 files changed, 267 insertions(+) create mode 100644 extra/regexp2/regexp2-tests.factor create mode 100644 extra/regexp2/regexp2.factor diff --git a/extra/regexp2/regexp2-tests.factor b/extra/regexp2/regexp2-tests.factor new file mode 100644 index 0000000000..1fb3f61f29 --- /dev/null +++ b/extra/regexp2/regexp2-tests.factor @@ -0,0 +1,5 @@ +USING: kernel peg regexp2 sequences tools.test ; +IN: regexp2.tests + +[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ] + [ "056" 'octal' parse ] unit-test diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor new file mode 100644 index 0000000000..e62eb76cb1 --- /dev/null +++ b/extra/regexp2/regexp2.factor @@ -0,0 +1,262 @@ +USING: assocs combinators.lib kernel math math.parser +namespaces peg unicode.case sequences unicode.categories +memoize peg.parsers ; +USE: io +USE: tools.walker +IN: regexp2 + +upper [ swap ch>upper = ] ] [ [ = ] ] if + curry ; + +: char-between?-quot ( ch1 ch2 -- quot ) + ignore-case? get + [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ] + [ [ between? ] ] + if 2curry ; + +: or-predicates ( quots -- quot ) + [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + +: literal-action [ nip ] curry action ; + +: delay-action [ curry ] curry action ; + +PRIVATE> + +: ascii? ( n -- ? ) + 0 HEX: 7f between? ; + +: octal-digit? ( n -- ? ) + CHAR: 0 CHAR: 7 between? ; + +: hex-digit? ( n -- ? ) + { + [ dup digit? ] + [ dup CHAR: a CHAR: f between? ] + [ dup CHAR: A CHAR: F between? ] + } || nip ; + +: control-char? ( n -- ? ) + { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ; + +: punct? ( n -- ? ) + "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; + +: c-identifier-char? ( ch -- ? ) + { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ; + +: java-blank? ( n -- ? ) + { + CHAR: \s + CHAR: \t CHAR: \n CHAR: \r + HEX: c HEX: 7 HEX: 1b + } member? ; + +: java-printable? ( n -- ? ) + { [ dup alpha? ] [ dup punct? ] } || nip ; + +MEMO: 'ordinary-char' ( -- parser ) + [ "\\^*+?|(){}[$" member? not ] satisfy + [ char=-quot ] action ; + +MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; + +MEMO: 'octal' ( -- parser ) + "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq + [ first oct> ] action ; + +MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ; + +MEMO: 'hex' ( -- parser ) + "x" token hide 'hex-digit' 2 exactly-n 2seq + "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice + [ first hex> ] action ; + +: satisfy-tokens ( assoc -- parser ) + [ >r token r> literal-action ] { } assoc>map choice ; + +MEMO: 'simple-escape-char' ( -- parser ) + { + { "\\" CHAR: \\ } + { "t" CHAR: \t } + { "n" CHAR: \n } + { "r" CHAR: \r } + { "f" HEX: c } + { "a" HEX: 7 } + { "e" HEX: 1b } + } [ char=-quot ] assoc-map satisfy-tokens ; + +MEMO: 'predefined-char-class' ( -- parser ) + { + { "d" [ digit? ] } + { "D" [ digit? not ] } + { "s" [ java-blank? ] } + { "S" [ java-blank? not ] } + { "w" [ c-identifier-char? ] } + { "W" [ c-identifier-char? not ] } + } satisfy-tokens ; + +MEMO: 'posix-character-class' ( -- parser ) + { + { "Lower" [ letter? ] } + { "Upper" [ LETTER? ] } + { "ASCII" [ ascii? ] } + { "Alpha" [ Letter? ] } + { "Digit" [ digit? ] } + { "Alnum" [ alpha? ] } + { "Punct" [ punct? ] } + { "Graph" [ java-printable? ] } + { "Print" [ java-printable? ] } + { "Blank" [ " \t" member? ] } + { "Cntrl" [ control-char? ] } + { "XDigit" [ hex-digit? ] } + { "Space" [ java-blank? ] } + } satisfy-tokens "p{" "}" surrounded-by ; + +MEMO: 'simple-escape' ( -- parser ) + [ + 'octal' , + 'hex' , + "c" token hide [ LETTER? ] satisfy 2seq , + any-char , + ] choice* [ char=-quot ] action ; + +MEMO: 'escape' ( -- parser ) + "\\" token hide [ + 'simple-escape-char' , + 'predefined-char-class' , + 'posix-character-class' , + 'simple-escape' , + ] choice* 2seq ; + +MEMO: 'any-char' ( -- parser ) + "." token [ drop t ] literal-action ; + +MEMO: 'char' ( -- parser ) + 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ; + +DEFER: 'regexp' + +TUPLE: group-result str ; + +C: group-result + +MEMO: 'non-capturing-group' ( -- parser ) + "?:" token hide 'regexp' ; + +MEMO: 'positive-lookahead-group' ( -- parser ) + "?=" token hide 'regexp' [ ensure ] action ; + +MEMO: 'negative-lookahead-group' ( -- parser ) + "?!" token hide 'regexp' [ ensure-not ] action ; + +MEMO: 'simple-group' ( -- parser ) + 'regexp' [ [ ] action ] action ; + +MEMO: 'group' ( -- parser ) + [ + 'non-capturing-group' , + 'positive-lookahead-group' , + 'negative-lookahead-group' , + 'simple-group' , + ] choice* "(" ")" surrounded-by ; + +MEMO: 'range' ( -- parser ) + any-char "-" token hide any-char 3seq + [ first2 char-between?-quot ] action ; + +MEMO: 'character-class-term' ( -- parser ) + 'range' + 'escape' + [ "\\]" member? not ] satisfy [ char=-quot ] action + 3choice ; + +MEMO: 'positive-character-class' ( -- parser ) + ! todo + "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq + 'character-class-term' repeat1 2choice [ or-predicates ] action ; + +MEMO: 'negative-character-class' ( -- parser ) + "^" token hide 'positive-character-class' 2seq + [ [ not ] append ] action ; + +MEMO: 'character-class' ( -- parser ) + 'negative-character-class' 'positive-character-class' 2choice + "[" "]" surrounded-by [ satisfy ] action ; + +MEMO: 'escaped-seq' ( -- parser ) + any-char repeat1 + [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ; + +MEMO: 'break' ( quot -- parser ) + satisfy ensure + epsilon just 2choice ; + +MEMO: 'break-escape' ( -- parser ) + "$" token [ "\r\n" member? ] 'break' literal-action + "\\b" token [ blank? ] 'break' literal-action + "\\B" token [ blank? not ] 'break' literal-action + "\\z" token epsilon just literal-action 4choice ; + +MEMO: 'simple' ( -- parser ) + [ + 'escaped-seq' , + 'break-escape' , + 'group' , + 'character-class' , + 'char' , + ] choice* ; + +MEMO: 'exactly-n' ( -- parser ) + 'integer' [ exactly-n ] delay-action ; + +MEMO: 'at-least-n' ( -- parser ) + 'integer' "," token hide 2seq [ at-least-n ] delay-action ; + +MEMO: 'at-most-n' ( -- parser ) + "," token hide 'integer' 2seq [ at-most-n ] delay-action ; + +MEMO: 'from-m-to-n' ( -- parser ) + 'integer' "," token hide 'integer' 3seq + [ first2 from-m-to-n ] delay-action ; + +MEMO: 'greedy-interval' ( -- parser ) + 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ; + +MEMO: 'interval' ( -- parser ) + 'greedy-interval' + 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action + 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action + 3choice "{" "}" surrounded-by ; + +MEMO: 'repetition' ( -- parser ) + [ + ! Possessive + ! "*+" token [ ] literal-action , + ! "++" token [ ] literal-action , + ! "?+" token [ ] literal-action , + ! Reluctant + ! "*?" token [ <(*)> ] literal-action , + ! "+?" token [ <(+)> ] literal-action , + ! "??" token [ <(?)> ] literal-action , + ! Greedy + "*" token [ repeat0 ] literal-action , + "+" token [ repeat1 ] literal-action , + "?" token [ optional ] literal-action , + ] choice* ; + +MEMO: 'dummy' ( -- parser ) + epsilon [ ] literal-action ; + +! todo -- check the action +! MEMO: 'term' ( -- parser ) + ! 'simple' + ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action + ! [ ] action ; + From 2feda7c5d7de3488cffa5e0904978fe0b3905616 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 21:38:15 -0600 Subject: [PATCH 12/49] http.server form validation --- extra/destructors/destructors-docs.factor | 4 +- extra/destructors/destructors-tests.factor | 2 +- extra/destructors/destructors.factor | 16 +- extra/furnace/authors.txt | 2 - extra/furnace/furnace-tests.factor | 47 ---- extra/furnace/furnace.factor | 217 ------------------ extra/furnace/sessions/authors.txt | 1 - extra/furnace/sessions/sessions.factor | 50 ---- extra/furnace/summary.txt | 1 - extra/furnace/tags.txt | 1 - extra/furnace/validator/authors.txt | 1 - .../furnace/validator/validator-tests.factor | 30 --- extra/furnace/validator/validator.factor | 43 ---- .../http/server/actions/actions-tests.factor | 16 +- extra/http/server/actions/actions.factor | 37 +-- .../http/server/components/components.factor | 129 +++++++++++ extra/http/server/crud/crud.factor | 13 ++ extra/http/server/db/db.factor | 12 +- extra/http/server/server.factor | 22 +- .../server/templating/{ => fhtml}/authors.txt | 0 .../fhtml-tests.factor} | 8 +- .../{templating.factor => fhtml/fhtml.factor} | 2 +- .../templating/{ => fhtml}/test/bug.fhtml | 0 .../templating/{ => fhtml}/test/bug.html | 0 .../templating/{ => fhtml}/test/example.fhtml | 0 .../templating/{ => fhtml}/test/example.html | 0 .../templating/{ => fhtml}/test/stack.fhtml | 0 .../templating/{ => fhtml}/test/stack.html | 0 .../server/validators/validators-tests.factor | 4 + .../http/server/validators/validators.factor | 64 ++++++ 30 files changed, 280 insertions(+), 442 deletions(-) delete mode 100644 extra/furnace/authors.txt delete mode 100755 extra/furnace/furnace-tests.factor delete mode 100755 extra/furnace/furnace.factor delete mode 100755 extra/furnace/sessions/authors.txt delete mode 100755 extra/furnace/sessions/sessions.factor delete mode 100755 extra/furnace/summary.txt delete mode 100644 extra/furnace/tags.txt delete mode 100755 extra/furnace/validator/authors.txt delete mode 100644 extra/furnace/validator/validator-tests.factor delete mode 100644 extra/furnace/validator/validator.factor create mode 100644 extra/http/server/components/components.factor create mode 100644 extra/http/server/crud/crud.factor rename extra/http/server/templating/{ => fhtml}/authors.txt (100%) rename extra/http/server/templating/{templating-tests.factor => fhtml/fhtml-tests.factor} (65%) rename extra/http/server/templating/{templating.factor => fhtml/fhtml.factor} (98%) rename extra/http/server/templating/{ => fhtml}/test/bug.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/bug.html (100%) rename extra/http/server/templating/{ => fhtml}/test/example.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/example.html (100%) rename extra/http/server/templating/{ => fhtml}/test/stack.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/stack.html (100%) create mode 100644 extra/http/server/validators/validators-tests.factor create mode 100644 extra/http/server/validators/validators.factor diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index 4c51e7ddfb..f96931c412 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax libc kernel ; +USING: help.markup help.syntax libc kernel continuations ; IN: destructors HELP: free-always @@ -23,7 +23,7 @@ HELP: close-later HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } { $notes "Destructors are not allowed to throw exceptions. No exceptions." } { $examples { $code "[ 10 malloc free-always ] with-destructors" } diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index 09b4ccc357..147e183688 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ; C: dummy-destructor -M: dummy-destructor destruct ( obj -- ) +M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 0f8ec3af84..b2561c7439 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -GENERIC: destruct ( obj -- ) - SYMBOL: error-destructors SYMBOL: always-destructors TUPLE: destructor object destroyed? ; -M: destructor destruct +M: destructor dispose dup destructor-destroyed? [ drop ] [ - dup destructor-object destruct + dup destructor-object dispose t swap set-destructor-destroyed? ] if ; @@ -29,10 +27,10 @@ M: destructor destruct always-destructors get push ; : do-always-destructors ( -- ) - always-destructors get [ destruct ] each ; + always-destructors get [ dispose ] each ; : do-error-destructors ( -- ) - error-destructors get [ destruct ] each ; + error-destructors get [ dispose ] each ; : with-destructors ( quot -- ) [ @@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ; C: memory-destructor -M: memory-destructor destruct ( obj -- ) +M: memory-destructor dispose ( obj -- ) memory-destructor-alien free ; : free-always ( alien -- ) @@ -63,7 +61,7 @@ C: handle-destructor HOOK: destruct-handle io-backend ( obj -- ) -M: handle-destructor destruct ( obj -- ) +M: handle-destructor dispose ( obj -- ) handle-destructor-alien destruct-handle ; : close-always ( handle -- ) @@ -79,7 +77,7 @@ C: socket-destructor HOOK: destruct-socket io-backend ( obj -- ) -M: socket-destructor destruct ( obj -- ) +M: socket-destructor dispose ( obj -- ) socket-destructor-alien destruct-socket ; : close-socket-always ( handle -- ) diff --git a/extra/furnace/authors.txt b/extra/furnace/authors.txt deleted file mode 100644 index f372b574ae..0000000000 --- a/extra/furnace/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Doug Coleman diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor deleted file mode 100755 index d8124d1f2b..0000000000 --- a/extra/furnace/furnace-tests.factor +++ /dev/null @@ -1,47 +0,0 @@ -USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: furnace.tests - -TUPLE: test-tuple m n ; - -[ H{ { "m" 3 } { "n" 2 } } ] -[ - [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc -] unit-test - -[ - { 3 } -] [ - H{ { "n" "3" } } { { "n" v-number } } - [ action-param drop ] with map -] unit-test - -: foo ; - -\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action - -[ t ] [ [ 1 2 foo ] action-call? ] unit-test -[ f ] [ [ 2 + ] action-call? ] unit-test - -[ - { "2" "hello" } -] [ - [ - H{ - { "bar" "hello" } - } \ foo query>seq - ] with-scope -] unit-test - -[ - H{ { "foo" "1" } { "bar" "2" } } -] [ - { "1" "2" } \ foo quot>query -] unit-test - -[ - "/responder/furnace.tests/foo?foo=3" -] [ - [ - [ "3" foo ] quot-link - ] with-scope -] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor deleted file mode 100755 index 3bbd2d03da..0000000000 --- a/extra/furnace/furnace.factor +++ /dev/null @@ -1,217 +0,0 @@ -! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs calendar debugger furnace.sessions -furnace.validator hashtables heaps html.elements http -http.server.responders http.server.templating io.files kernel -math namespaces quotations sequences splitting words strings -vectors webapps.callback continuations tuples classes vocabs -html io ; -IN: furnace - -: code>quotation ( word/quot -- quot ) - dup word? [ 1quotation ] when ; - -SYMBOL: default-action -SYMBOL: template-path - -: render-template ( template -- ) - template-path get swap path+ - ".furnace" append resource-path - run-template-file ; - -: define-action ( word hash -- ) - over t "action" set-word-prop - "action-params" set-word-prop ; - -: define-form ( word1 word2 hash -- ) - dupd define-action - swap code>quotation "form-failed" set-word-prop ; - -: default-values ( word hash -- ) - "default-values" set-word-prop ; - -SYMBOL: request-params -SYMBOL: current-action -SYMBOL: validators-errored -SYMBOL: validation-errors - -: build-url ( str query-params -- newstr ) - [ - over % - dup assoc-empty? [ - 2drop - ] [ - CHAR: ? rot member? "&" "?" ? % - assoc>query % - ] if - ] "" make ; - -: action-link ( query action -- url ) - [ - "/responder/" % - dup word-vocabulary "webapps." ?head drop % - "/" % - word-name % - ] "" make swap build-url ; - -: action-param ( hash paramsepc -- obj error/f ) - unclip rot at swap >quotation apply-validators ; - -: query>seq ( hash word -- seq ) - "action-params" word-prop [ - dup first -rot - action-param [ - t validators-errored >session - rot validation-errors session> set-at - ] [ - nip - ] if* - ] with map ; - -: lookup-session ( hash -- session ) - "furnace-session-id" over at get-session - [ ] [ new-session "furnace-session-id" roll set-at ] ?if ; - -: quot>query ( seq action -- hash ) - >r >array r> "action-params" word-prop - [ first swap 2array ] 2map >hashtable ; - -PREDICATE: word action "action" word-prop ; - -: action-call? ( quot -- ? ) - >vector dup pop action? >r [ word? not ] all? r> and ; - -: unclip* dup 1 head* swap peek ; - -: quot-link ( quot -- url ) - dup action-call? [ - unclip* [ quot>query ] keep action-link - ] [ - t register-html-callback - ] if ; - -: replace-variables ( quot -- quot ) - [ dup string? [ request-params session> at ] when ] map ; - -: furnace-session-id ( -- hash ) - "furnace-session-id" request-params session> at - "furnace-session-id" associate ; - -: redirect-to-action ( -- ) - current-action session> - "form-failed" word-prop replace-variables - quot-link furnace-session-id build-url permanent-redirect ; - -: if-form-page ( if then -- ) - current-action session> "form-failed" word-prop -rot if ; - -: do-action - current-action session> [ query>seq ] keep add >quotation call ; - -: process-form ( -- ) - H{ } clone validation-errors >session - request-params session> current-action session> query>seq - validators-errored session> [ - drop redirect-to-action - ] [ - current-action session> add >quotation call - ] if ; - -: page-submitted ( -- ) - [ process-form ] [ request-params session> do-action ] if-form-page ; - -: action-first-time ( -- ) - request-params session> current-action session> - [ "default-values" word-prop swap union request-params >session ] keep - request-params session> do-action ; - -: page-not-submitted ( -- ) - [ redirect-to-action ] [ action-first-time ] if-form-page ; - -: setup-call-action ( hash word -- ) - over lookup-session session set - current-action >session - request-params session> swap union - request-params >session - f validators-errored >session ; - -: call-action ( hash word -- ) - setup-call-action - "furnace-form-submitted" request-params session> at - [ page-submitted ] [ page-not-submitted ] if ; - -: responder-vocab ( str -- newstr ) - "webapps." swap append ; - -: lookup-action ( str webapp -- word ) - responder-vocab lookup dup [ - dup "action" word-prop [ drop f ] unless - ] when ; - -: truncate-url ( str -- newstr ) - CHAR: / over index [ head ] when* ; - -: parse-action ( str -- word/f ) - dup empty? [ drop default-action get ] when - truncate-url "responder" get lookup-action ; - -: service-request ( hash str -- ) - parse-action [ - [ call-action ] [ 
 print-error
] recover - ] [ - "404 no such action: " "argument" get append httpd-error - ] if* ; - -: service-get - "query" get swap service-request ; - -: service-post - "response" get swap service-request ; - -: web-app ( name defaul path -- ) - [ - template-path set - default-action set - "responder" set - [ service-get ] "get" set - [ service-post ] "post" set - ] make-responder ; - -: explode-tuple ( tuple -- ) - dup tuple-slots swap class "slot-names" word-prop - [ set ] 2each ; - -SYMBOL: model - -: with-slots ( model quot -- ) - [ - >r [ dup model set explode-tuple ] when* r> call - ] with-scope ; - -: render-component ( model template -- ) - swap [ render-template ] with-slots ; - -: browse-webapp-source ( vocab -- ) - - "Browse source" write - ; - -: send-resource ( name -- ) - template-path get swap path+ resource-path - stdio get stream-copy ; - -: render-link ( quot name -- ) - write ; - -: session-var ( str -- newstr ) - request-params session> at ; - -: render ( str -- ) - request-params session> at [ write ] when* ; - -: render-error ( str error-str -- ) - swap validation-errors session> at validation-error? [ - write - ] [ - drop - ] if ; diff --git a/extra/furnace/sessions/authors.txt b/extra/furnace/sessions/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/furnace/sessions/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor deleted file mode 100755 index cf03fee6b1..0000000000 --- a/extra/furnace/sessions/sessions.factor +++ /dev/null @@ -1,50 +0,0 @@ -USING: assocs calendar init kernel math.parser -namespaces random boxes alarms combinators.lib ; -IN: furnace.sessions - -SYMBOL: sessions - -: timeout ( -- dt ) 20 minutes ; - -[ - H{ } clone sessions set-global -] "furnace.sessions" add-init-hook - -: new-session-id ( -- str ) - [ 4 big-random >hex ] - [ sessions get-global key? not ] generate ; - -TUPLE: session id namespace alarm user-agent ; - -: cancel-timeout ( session -- ) - session-alarm ?box [ cancel-alarm ] [ drop ] if ; - -: delete-session ( session -- ) - sessions get-global delete-at* - [ cancel-timeout ] [ drop ] if ; - -: touch-session ( session -- ) - dup cancel-timeout - dup [ session-id delete-session ] curry timeout later - swap session-alarm >box ; - -: ( id -- session ) - H{ } clone f session construct-boa ; - -: new-session ( -- session id ) - new-session-id [ - dup [ - [ sessions get-global set-at ] keep - touch-session - ] keep - ] keep ; - -: get-session ( id -- session/f ) - sessions get-global at* - [ dup touch-session ] when ; - -: session> ( str -- obj ) - session get session-namespace at ; - -: >session ( value key -- ) - session get session-namespace set-at ; diff --git a/extra/furnace/summary.txt b/extra/furnace/summary.txt deleted file mode 100755 index 5696506f79..0000000000 --- a/extra/furnace/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Action-based web framework diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt deleted file mode 100644 index 0aef4feca8..0000000000 --- a/extra/furnace/tags.txt +++ /dev/null @@ -1 +0,0 @@ -enterprise diff --git a/extra/furnace/validator/authors.txt b/extra/furnace/validator/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/furnace/validator/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor deleted file mode 100644 index e84e57be6a..0000000000 --- a/extra/furnace/validator/validator-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: furnace.validator.tests -USING: kernel sequences tools.test furnace.validator furnace ; - -[ - 123 f -] [ - H{ { "foo" "123" } } { "foo" v-number } action-param -] unit-test - -: validation-fails - [ action-param nip not ] append [ f ] swap unit-test ; - -[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails - -[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails - -[ "ABCD" f ] -[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ] -unit-test - -[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ] -validation-fails - -[ "AB" f ] -[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ] -unit-test - -[ "AB" f ] -[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ] -unit-test diff --git a/extra/furnace/validator/validator.factor b/extra/furnace/validator/validator.factor deleted file mode 100644 index 698c77fa9a..0000000000 --- a/extra/furnace/validator/validator.factor +++ /dev/null @@ -1,43 +0,0 @@ -! Copyright (C) 2006 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences math namespaces math.parser ; -IN: furnace.validator - -TUPLE: validation-error reason ; - -: apply-validators ( string quot -- obj error/f ) - [ - call f - ] [ - dup validation-error? [ >r 2drop f r> ] [ rethrow ] if - ] recover ; - -: validation-error ( msg -- * ) - \ validation-error construct-boa throw ; - -: v-default ( obj value -- obj ) - over empty? [ nip ] [ drop ] if ; - -: v-required ( str -- str ) - dup empty? [ "required" validation-error ] when ; - -: v-min-length ( str n -- str ) - over length over < [ - [ "must be at least " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-max-length ( str n -- str ) - over length over > [ - [ "must be no more than " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-number ( str -- n ) - string>number [ - "must be a number" validation-error - ] unless* ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 2d74e92e86..13089ae6e8 100644 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,11 +1,12 @@ IN: http.server.actions.tests USING: http.server.actions tools.test math math.parser multiline namespaces http io.streams.string http.server -sequences ; +sequences accessors ; -[ + ] -{ { "a" [ string>number ] } { "b" [ string>number ] } } -"GET" "action-1" set + + [ "a" get "b" get + ] >>get + { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params +"action-1" set STRING: action-request-test-1 GET http://foo/bar?a=12&b=13 HTTP/1.1 @@ -19,9 +20,10 @@ blah "action-1" get call-responder ] unit-test -[ "X" concat append ] -{ { +path+ [ ] } { "xxx" [ string>number ] } } -"POST" "action-2" set + + [ +path+ get "xxx" get "X" concat append ] >>post + { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params +"action-2" set STRING: action-request-test-2 POST http://foo/bar/baz HTTP/1.1 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index feb16a4488..5e5b7a9563 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots sequences kernel assocs combinators -http.server http hashtables namespaces ; +http.server http.server.validators http hashtables namespaces ; IN: http.server.actions SYMBOL: +path+ -TUPLE: action quot params method ; +TUPLE: action get get-params post post-params revalidate ; -C: action +: + action construct-empty + [ <400> ] >>get + [ <400> ] >>post + [ <400> ] >>revalidate ; : extract-params ( request path -- assoc ) >r dup method>> { @@ -16,15 +20,22 @@ C: action { "POST" [ post-data>> query>assoc ] } } case r> +path+ associate union ; -: push-params ( assoc action -- ... ) - params>> [ first2 >r swap at r> call ] with each ; +: action-params ( request path param -- error? ) + -rot extract-params validate-params ; + +: get-action ( request path -- response ) + action get get-params>> action-params + [ <400> ] [ action get get>> call ] if ; + +: post-action ( request path -- response ) + action get post-params>> action-params + [ action get revalidate>> ] [ action get post>> ] if call ; M: action call-responder ( request path action -- response ) - pick request set - pick method>> over method>> = [ - >r extract-params r> - [ push-params ] keep - quot>> call - ] [ - 3drop <400> - ] if ; + action set + over request set + over method>> + { + { "GET" [ get-action ] } + { "POST" [ post-action ] } + } case ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor new file mode 100644 index 0000000000..6fefb1b5dd --- /dev/null +++ b/extra/http/server/components/components.factor @@ -0,0 +1,129 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: new-slots html.elements http.server.validators +accessors namespaces kernel io farkup math.parser assocs +classes words tuples arrays sequences io.files +http.server.templating.fhtml splitting ; +IN: http.server.components + +SYMBOL: components + +TUPLE: component id ; + +: component ( name -- component ) + dup components get at + [ ] [ "No such component: " swap append throw ] ?if ; + +GENERIC: validate* ( string component -- result ) +GENERIC: render-view* ( value component -- ) +GENERIC: render-edit* ( value component -- ) +GENERIC: render-error* ( reason value component -- ) + +SYMBOL: values + +: value values get at ; + +: render-view ( component -- ) + dup id>> value swap render-view* ; + +: render-error ( error -- ) + write ; + +: render-edit ( component -- ) + dup id>> value dup validation-error? [ + dup reason>> swap value>> rot render-error* + ] [ + swap render-edit* + ] if ; + +: ( id string -- component ) + >r \ component construct-boa r> construct-delegate ; inline + +TUPLE: string min max ; + +: ( id -- component ) string ; + +M: string validate* + [ min>> v-min-length ] keep max>> v-max-length ; + +M: string render-view* + drop write ; + +: render-input + > dup =id =name =value input/> ; + +M: string render-edit* + render-input ; + +M: string render-error* + render-input render-error ; + +TUPLE: text ; + +: ( id -- component ) text construct-delegate ; + +: render-textarea + ; + +M: text render-edit* + render-textarea ; + +M: text render-error* + render-textarea render-error ; + +TUPLE: farkup ; + +: ( id -- component ) farkup construct-delegate ; + +M: farkup render-view* + drop string-lines "\n" join convert-farkup write ; + +TUPLE: number min max ; + +: ( id -- component ) number ; + +M: number validate* + >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ; + +M: number render-view* + drop number>string write ; + +M: number render-edit* + >r number>string r> render-input ; + +M: number render-error* + render-input render-error ; + +: tuple>slots ( tuple -- alist ) + dup class "slot-names" word-prop swap tuple-slots + 2array flip ; + +: with-components ( tuple components quot -- ) + [ + >r components set + dup tuple>slots values set + tuple set + r> call + ] with-scope ; inline + +TUPLE: form view-template edit-template components ; + +:
( id view-template edit-template -- form ) + V{ } clone form construct-boa + swap \ component construct-boa + over set-delegate ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +M: form render-view* ( value form -- ) + dup components>> + swap view-template>> + [ resource-path run-template-file ] curry + with-components ; + +M: form render-edit* ( value form -- ) + dup components>> + swap edit-template>> + [ resource-path run-template-file ] curry + with-components ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor new file mode 100644 index 0000000000..099ded2f7f --- /dev/null +++ b/extra/http/server/crud/crud.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.crud +USING: kernel namespaces db.tuples math.parser +http.server.actions accessors ; + +: by-id ( class -- tuple ) + construct-empty "id" get >>id ; + +: ( class -- action ) + + { { "id" [ string>number ] } } >>post-params + swap [ by-id delete-tuple f ] curry >>post ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 4baee5f02b..511921ce06 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db http.server kernel new-slots accessors -continuations namespaces ; +continuations namespaces destructors ; IN: http.server.db TUPLE: db-persistence responder db params ; C: db-persistence +: connect-db ( db-persistence -- ) + dup db>> swap params>> make-db + dup db set + dup db-open + add-always-destructor ; + M: db-persistence call-responder - dup db>> over params>> make-db dup db-open [ - db set responder>> call-responder - ] with-disposal ; + dup connect-db responder>> call-responder ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f397b280d0..990c77f71e 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -3,7 +3,8 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib -vocabs.loader debugger html continuations random combinators ; +vocabs.loader debugger html continuations random combinators +destructors ; IN: http.server GENERIC: call-responder ( request path responder -- response ) @@ -135,7 +136,7 @@ SYMBOL: development-mode swap method>> "HEAD" = [ drop ] [ write-response-body ] if ; -: do-request ( request -- request ) +: do-request ( request -- response ) [ dup dup path>> over host>> find-virtual-host call-responder @@ -149,13 +150,18 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; -: handle-client ( -- ) - default-timeout +: ?refresh-all ( -- ) development-mode get-global - [ global [ refresh-all ] bind ] when - read-request - dup log-request - do-request do-response ; + [ global [ refresh-all ] bind ] when ; + +: handle-client ( -- ) + [ + default-timeout + ?refresh-all + read-request + dup log-request + do-request do-response + ] with-destructors ; : httpd ( port -- ) internet-server "http.server" diff --git a/extra/http/server/templating/authors.txt b/extra/http/server/templating/fhtml/authors.txt similarity index 100% rename from extra/http/server/templating/authors.txt rename to extra/http/server/templating/fhtml/authors.txt diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor similarity index 65% rename from extra/http/server/templating/templating-tests.factor rename to extra/http/server/templating/fhtml/fhtml-tests.factor index ceb2ed95be..0ae3b41454 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,9 +1,9 @@ -USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; -IN: http.server.templating.tests +USING: io io.files io.streams.string +http.server.templating.fhtml kernel tools.test sequences ; +IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) - "extra/http/server/templating/test/" swap append + "extra/http/server/templating/fhtml/test/" swap append [ ".fhtml" append resource-path [ run-template-file ] with-string-writer diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/fhtml/fhtml.factor similarity index 98% rename from extra/http/server/templating/templating.factor rename to extra/http/server/templating/fhtml/fhtml.factor index b298faca74..37f4b85c51 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -7,7 +7,7 @@ source-files debugger combinators math quotations generic strings splitting accessors http.server.static http.server assocs ; -IN: http.server.templating +IN: http.server.templating.fhtml : templating-vocab ( -- vocab-name ) "http.server.templating" ; diff --git a/extra/http/server/templating/test/bug.fhtml b/extra/http/server/templating/fhtml/test/bug.fhtml similarity index 100% rename from extra/http/server/templating/test/bug.fhtml rename to extra/http/server/templating/fhtml/test/bug.fhtml diff --git a/extra/http/server/templating/test/bug.html b/extra/http/server/templating/fhtml/test/bug.html similarity index 100% rename from extra/http/server/templating/test/bug.html rename to extra/http/server/templating/fhtml/test/bug.html diff --git a/extra/http/server/templating/test/example.fhtml b/extra/http/server/templating/fhtml/test/example.fhtml similarity index 100% rename from extra/http/server/templating/test/example.fhtml rename to extra/http/server/templating/fhtml/test/example.fhtml diff --git a/extra/http/server/templating/test/example.html b/extra/http/server/templating/fhtml/test/example.html similarity index 100% rename from extra/http/server/templating/test/example.html rename to extra/http/server/templating/fhtml/test/example.html diff --git a/extra/http/server/templating/test/stack.fhtml b/extra/http/server/templating/fhtml/test/stack.fhtml similarity index 100% rename from extra/http/server/templating/test/stack.fhtml rename to extra/http/server/templating/fhtml/test/stack.fhtml diff --git a/extra/http/server/templating/test/stack.html b/extra/http/server/templating/fhtml/test/stack.html similarity index 100% rename from extra/http/server/templating/test/stack.html rename to extra/http/server/templating/fhtml/test/stack.html diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor new file mode 100644 index 0000000000..ff68dcfc64 --- /dev/null +++ b/extra/http/server/validators/validators-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.validators.tests +USING: kernel sequences tools.test http.server.validators ; + +[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor new file mode 100644 index 0000000000..03beb8c3ff --- /dev/null +++ b/extra/http/server/validators/validators.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2006, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations sequences math namespaces +math.parser assocs new-slots ; +IN: http.server.validators + +TUPLE: validation-error value reason ; + +: validation-error ( value reason -- * ) + \ validation-error construct-boa throw ; + +: with-validator ( string quot -- result error? ) + [ f ] compose curry + [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline + +: validate-param ( name validator assoc -- error? ) + swap pick + >r >r at r> with-validator swap r> set ; + +: validate-params ( validators assoc -- error? ) + [ validate-param ] curry { } assoc>map [ ] contains? ; + +: v-default ( str def -- str ) + over empty? spin ? ; + +: v-required ( str -- str ) + dup empty? [ "required" validation-error ] when ; + +: v-min-length ( str n -- str ) + over length over < [ + [ "must be at least " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-length ( str n -- str ) + over length over > [ + [ "must be no more than " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-number ( str -- n ) + dup string>number [ ] [ + "must be a number" validation-error + ] ?if ; + +: v-min-value ( str n -- str ) + 2dup < [ + [ "must be at least " % # ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-value ( str n -- str ) + 2dup > [ + [ "must be no more than " % # ] "" make + validation-error + ] [ + drop + ] if ; From b3fcd179a04d397b05d11c390577eb4d9b380be2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 22:07:45 -0600 Subject: [PATCH 13/49] refactor conversions --- extra/calendar/format/format.factor | 55 +++++++++-------------------- 1 file changed, 17 insertions(+), 38 deletions(-) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index c1bd6427a7..89e09e0d0c 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -36,8 +36,12 @@ M: timestamp year. ( timestamp -- ) : pad-00 number>string 2 CHAR: 0 pad-left ; +: pad-0000 number>string 4 CHAR: 0 pad-left ; + : write-00 pad-00 write ; +: write-0000 pad-0000 write ; + : (timestamp>string) ( timestamp -- ) dup day-of-week day-abbreviations3 nth write ", " write dup day>> number>string write bl @@ -107,18 +111,16 @@ M: timestamp year. ( timestamp -- ) 60 / + * ] if ; +: read-ymd ( -- y m d ) + read-0000 "-" expect read-00 "-" expect read-00 ; + +: read-hms ( -- h m s ) + read-00 ":" expect read-00 ":" expect read-00 ; + : (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day + read-ymd "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second + read-hms read-rfc3339-gmt-offset ! timezone ; @@ -126,49 +128,25 @@ M: timestamp year. ( timestamp -- ) [ (rfc3339>timestamp) ] with-string-reader ; : (ymdhms>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - " " expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - 0 ! timezone - ; + read-ymd " " expect read-hms 0 ; : ymdhms>timestamp ( str -- timestamp ) [ (ymdhms>timestamp) ] with-string-reader ; : (hms>timestamp) ( -- timestamp ) - f f f - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - f ; + f f f read-hms f ; : hms>timestamp ( str -- timestamp ) [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - f f f f ; + read-ymd f f f f ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; - : (timestamp>ymd) ( timestamp -- ) - dup timestamp-year number>string write + dup timestamp-year write-0000 "-" write dup timestamp-month write-00 "-" write @@ -188,6 +166,7 @@ M: timestamp year. ( timestamp -- ) [ (timestamp>hms) ] with-string-writer ; : timestamp>ymdhms ( timestamp -- str ) + >gmt [ dup (timestamp>ymd) " " write From 955387f5b7e59292ac36166b7a4a15795b9d4515 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:00:10 -0600 Subject: [PATCH 14/49] HTTP authorization framework, first cut --- extra/http/server/auth/auth.factor | 25 +++++++ extra/http/server/auth/basic/basic.factor | 41 +++++++++++ extra/http/server/auth/login/login.factor | 69 +++++++++++++++++++ extra/http/server/auth/login/login.fhtml | 25 +++++++ .../auth/providers/assoc/assoc-tests.factor | 18 +++++ .../server/auth/providers/assoc/assoc.factor | 23 +++++++ .../server/auth/providers/db/db-tests.factor | 24 +++++++ extra/http/server/auth/providers/db/db.factor | 53 ++++++++++++++ .../server/auth/providers/null/null.factor | 14 ++++ .../server/auth/providers/providers.factor | 18 +++++ .../server/sessions/sessions-tests.factor | 9 ++- extra/http/server/sessions/sessions.factor | 2 + .../http/server/templating/fhtml/fhtml.factor | 2 +- 13 files changed, 320 insertions(+), 3 deletions(-) create mode 100755 extra/http/server/auth/auth.factor create mode 100755 extra/http/server/auth/basic/basic.factor create mode 100755 extra/http/server/auth/login/login.factor create mode 100755 extra/http/server/auth/login/login.fhtml create mode 100755 extra/http/server/auth/providers/assoc/assoc-tests.factor create mode 100755 extra/http/server/auth/providers/assoc/assoc.factor create mode 100755 extra/http/server/auth/providers/db/db-tests.factor create mode 100755 extra/http/server/auth/providers/db/db.factor create mode 100755 extra/http/server/auth/providers/null/null.factor create mode 100755 extra/http/server/auth/providers/providers.factor diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor new file mode 100755 index 0000000000..a53905bce1 --- /dev/null +++ b/extra/http/server/auth/auth.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth +USING: new-slots accessors http.server.auth.providers.null +http.server.auth.strategies.null ; + +TUPLE: authentication responder provider strategy ; + +: ( responder -- authentication ) + null-auth-provider null-auth-strategy + authentication construct-boa ; + +SYMBOL: current-user-id +SYMBOL: auth-provider +SYMBOL: auth-strategy + +M: authentication call-responder ( request path responder -- response ) + dup provider>> auth-provider set + dup strategy>> auth-strategy set + pick auth-provider get logged-in? dup current-user-id set + [ + responder>> call-responder + ] [ + 2drop auth-provider get require-login + ] if* ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor new file mode 100755 index 0000000000..2ea74febba --- /dev/null +++ b/extra/http/server/auth/basic/basic.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.auth.providers.null +http sequences ; +IN: http.server.auth.basic + +TUPLE: basic-auth responder realm provider ; + +C: basic-auth + +: authorization-ok? ( provider header -- ? ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 spin check-login + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +: logged-in? ( request responder -- ? ) + provider>> swap "authorization" header authorization-ok? ; + +M: basic-auth call-responder ( request path responder -- response ) + pick over logged-in? + [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor new file mode 100755 index 0000000000..e2f9a3608a --- /dev/null +++ b/extra/http/server/auth/login/login.factor @@ -0,0 +1,69 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.actions +http.server.sessions http.server.templating.fhtml http sequences +io.files namespaces ; +IN: http.server.auth.login + +TUPLE: login-auth responder provider ; + +C: (login-auth) login-auth + +SYMBOL: logged-in? +SYMBOL: provider +SYMBOL: post-login-url + +: login-page ( -- response ) + "text/html" [ + "extra/http/server/auth/login/login.fhtml" + resource-path run-template-file + ] >>body ; + +: + + [ login-page ] >>get + + { + { "name" [ ] } + { "password" [ ] } + } >>post-params + [ + "password" get + "name" get + provider sget check-login [ + t logged-in? sset + post-login-url sget + ] [ + login-page + ] if + ] >>post ; + +: + + [ + f logged-in? sset + request get "login" + ] >>post ; + +M: login-auth call-responder ( request path responder -- response ) + logged-in? sget + [ responder>> call-responder ] [ + pick method>> "GET" = [ + nip + provider>> provider sset + dup request-url post-login-url sset + "login" f session-link + ] [ + 3drop <400> + ] if + ] if ; + +: ( responder provider -- auth ) + (login-auth) + + swap >>default + "login" add-responder + "logout" add-responder + ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml new file mode 100755 index 0000000000..9bb1438588 --- /dev/null +++ b/extra/http/server/auth/login/login.fhtml @@ -0,0 +1,25 @@ + + +

Login required

+ + + + + + + + + + + + + + +
User name:
Password:
+ + + + + + + diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor new file mode 100755 index 0000000000..3270fe06e3 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -0,0 +1,18 @@ +IN: http.server.auth.providers.assoc.tests +USING: http.server.auth.providers +http.server.auth.providers.assoc tools.test +namespaces ; + + "provider" set + +"slava" "provider" get new-user + +[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + +[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + +[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + +"fdasf" "slava" "provider" get set-password + +[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor new file mode 100755 index 0000000000..d57be622c7 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth.providers.assoc +USING: new-slots accessors assocs kernel +http.server.auth.providers ; + +TUPLE: assoc-auth-provider assoc ; + +: ( -- provider ) + H{ } clone assoc-auth-provider construct-boa ; + +M: assoc-auth-provider check-login + assoc>> at = ; + +M: assoc-auth-provider new-user + assoc>> + 2dup key? [ drop user-exists ] when + t -rot set-at ; + +M: assoc-auth-provider set-password + assoc>> + 2dup key? [ drop no-such-user ] unless + set-at ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor new file mode 100755 index 0000000000..384e094f39 --- /dev/null +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -0,0 +1,24 @@ +IN: http.server.auth.providers.db.tests +USING: http.server.auth.providers +http.server.auth.providers.db tools.test +namespaces db db.sqlite db.tuples continuations ; + +db-auth-provider "provider" set + +"auth-test.db" sqlite-db [ + + [ user drop-table ] ignore-errors + [ user create-table ] ignore-errors + + "slava" "provider" get new-user + + [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + + [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + + [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + + "fdasf" "slava" "provider" get set-password + + [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test +] with-db diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor new file mode 100755 index 0000000000..9583122875 --- /dev/null +++ b/extra/http/server/auth/providers/db/db.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db db.tuples db.types new-slots accessors +http.server.auth.providers kernel ; +IN: http.server.auth.providers.db + +TUPLE: user name password ; + +: user construct-empty ; + +user "USERS" +{ + { "name" "NAME" { VARCHAR 256 } +assigned-id+ } + { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } +} define-persistent + +: init-users-table ( -- ) + user create-table ; + +TUPLE: db-auth-provider ; + +: db-auth-provider T{ db-auth-provider } ; + +M: db-auth-provider check-login + drop + + swap >>name + swap >>password + select-tuple >boolean ; + +M: db-auth-provider new-user + drop + [ + + swap >>name + + dup select-tuple [ name>> user-exists ] when + + "unassigned" >>password + + insert-tuple + ] with-transaction ; + +M: db-auth-provider set-password + drop + [ + + swap >>name + + dup select-tuple [ ] [ no-such-user ] ?if + + swap >>password update-tuple + ] with-transaction ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor new file mode 100755 index 0000000000..702111972e --- /dev/null +++ b/extra/http/server/auth/providers/null/null.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.auth.providers kernel ; +IN: http.server.auth.providers.null + +TUPLE: null-auth-provider ; + +: null-auth-provider T{ null-auth-provider } ; + +M: null-auth-provider check-login 3drop f ; + +M: null-auth-provider new-user 3drop f ; + +M: null-auth-provider set-password 3drop f ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor new file mode 100755 index 0000000000..1e0fd33a67 --- /dev/null +++ b/extra/http/server/auth/providers/providers.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: http.server.auth.providers + +GENERIC: check-login ( password user provider -- ? ) + +GENERIC: new-user ( user provider -- ) + +GENERIC: set-password ( password user provider -- ) + +TUPLE: user-exists name ; + +: user-exists ( name -- * ) \ user-exists construct-boa throw ; + +TUPLE: no-such-user name ; + +: no-such-user ( name -- * ) \ no-such-user construct-boa throw ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 4c21ba3c8d..d771737c73 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -4,6 +4,12 @@ kernel accessors ; : with-session \ session swap with-variable ; inline +TUPLE: foo ; + +C: foo + +M: foo init-session drop 0 "x" sset ; + "1234" f [ [ ] [ 3 "x" sset ] unit-test @@ -18,8 +24,7 @@ kernel accessors ; [ t ] [ f cookie-sessions? ] unit-test [ ] [ - f - [ 0 "x" sset ] >>init + "manager" set ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 2977e5938d..d7fed6bb64 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -11,6 +11,8 @@ IN: http.server.sessions GENERIC: init-session ( responder -- ) +M: dispatcher init-session drop ; + TUPLE: session-manager responder sessions ; : ( responder class -- responder' ) diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 37f4b85c51..e5770affc5 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -9,7 +9,7 @@ assocs ; IN: http.server.templating.fhtml -: templating-vocab ( -- vocab-name ) "http.server.templating" ; +: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; ! See apps/http-server/test/ or libs/furnace/ for template usage ! examples From 3c5a959ff4053997a9e4c5ee361a1f3f097f44be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:02:01 -0600 Subject: [PATCH 15/49] Remove obsolete file --- extra/http/server/auth/auth.factor | 25 ------------------------- 1 file changed, 25 deletions(-) delete mode 100755 extra/http/server/auth/auth.factor diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor deleted file mode 100755 index a53905bce1..0000000000 --- a/extra/http/server/auth/auth.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: http.server.auth -USING: new-slots accessors http.server.auth.providers.null -http.server.auth.strategies.null ; - -TUPLE: authentication responder provider strategy ; - -: ( responder -- authentication ) - null-auth-provider null-auth-strategy - authentication construct-boa ; - -SYMBOL: current-user-id -SYMBOL: auth-provider -SYMBOL: auth-strategy - -M: authentication call-responder ( request path responder -- response ) - dup provider>> auth-provider set - dup strategy>> auth-strategy set - pick auth-provider get logged-in? dup current-user-id set - [ - responder>> call-responder - ] [ - 2drop auth-provider get require-login - ] if* ; From 626334303c4d60501ffec5210aaebad7524f7dfb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:03:07 -0600 Subject: [PATCH 16/49] Fix build dir pollution in unit tests --- extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/sqlite/test.db | Bin 2048 -> 0 bytes extra/db/tuples/tuples-tests.factor | 2 +- .../server/auth/providers/db/db-tests.factor | 5 +++-- 4 files changed, 5 insertions(+), 4 deletions(-) delete mode 100644 extra/db/sqlite/test.db diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 08139610a0..b30cb4ba80 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,7 +3,7 @@ prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; IN: db.sqlite.tests -: db-path "extra/db/sqlite/test.db" resource-path ; +: db-path "test.db" temp-file ; : test.db db-path sqlite-db ; [ ] [ [ db-path delete-file ] ignore-errors ] unit-test diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db deleted file mode 100644 index e483c47cea528c95f10fcf66fcbb67ffa351ffd1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 3a1e2c4f25..7d72a644bf 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -159,7 +159,7 @@ TUPLE: annotation n paste-id summary author mode contents ; ! ] with-db : test-sqlite ( quot -- ) - >r "tuples-test.db" resource-path sqlite-db r> with-db ; + >r "tuples-test.db" temp-file sqlite-db r> with-db ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 384e094f39..c4682c2051 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -1,11 +1,12 @@ IN: http.server.auth.providers.db.tests USING: http.server.auth.providers http.server.auth.providers.db tools.test -namespaces db db.sqlite db.tuples continuations ; +namespaces db db.sqlite db.tuples continuations +io.files ; db-auth-provider "provider" set -"auth-test.db" sqlite-db [ +"auth-test.db" temp-file sqlite-db [ [ user drop-table ] ignore-errors [ user create-table ] ignore-errors From 1b5d8d6a59c7185395ab98f7cb61b746eb546dcc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 09:52:56 -0600 Subject: [PATCH 17/49] add nmake to namespaces.lib --- extra/namespaces/lib/lib.factor | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 528e770558..8e7af02597 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib ; + assocs.lib math.parser math sequences.lib ; IN: namespaces.lib @@ -17,3 +17,30 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : set* ( val var -- ) namestack* set-assoc-stack ; + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, get-building-seq push ; +: n% get-building-seq push-all ; +: n# >r number>string r> n% ; + +: 0, 0 n, ; +: 0% 0 n% ; +: 0# 0 n# ; +: 1, 1 n, ; +: 1% 1 n% ; +: 1# 1 n# ; +: 2, 2 n, ; +: 2% 2 n% ; +: 2# 2 n# ; + +: nmake ( quot exemplars -- seqs ) + dup length dup zero? [ 1+ ] when + [ + [ + [ drop 1024 swap new-resizable ] 2map + [ building-seq set call ] keep + ] 2keep >r [ like ] 2map r> firstn + ] with-scope ; From ca6fc5edc61696f11446e5cdd659beeff33bae43 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 10:18:46 -0600 Subject: [PATCH 18/49] default constructor was not sticking around after USEing a vocab --- extra/singleton/singleton.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index 3a9af90071..b745e8f902 100644 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel parser quotations tuples words ; +USING: kernel parser quotations prettyprint tuples words ; IN: singleton : SINGLETON: CREATE-CLASS dup { } define-tuple-class + dup unparse create-in reset-generic dup construct-empty 1quotation define ; parsing From f2463f34aed3a30839b60c1e24982bf9a19ec9ba Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 11:28:49 -0600 Subject: [PATCH 19/49] hashtables: simplify (key@) --- core/hashtables/hashtables.factor | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 359bedd041..7d8c6f0b5f 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private slots.private math assocs -math.private sequences sequences.private vectors ; + math.private sequences sequences.private vectors ; IN: hashtables Date: Thu, 6 Mar 2008 11:37:44 -0600 Subject: [PATCH 20/49] builder: fix stack effect --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 92cd5f5241..41096e863c 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -39,7 +39,7 @@ IN: builder : record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ; -: do-make-clean ( -- desc ) { "make" "clean" } try-process ; +: do-make-clean ( -- ) { "make" "clean" } try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 9aa6219759fa25966212328d24a4d1420434de8f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 12:04:20 -0600 Subject: [PATCH 21/49] unix.stat: add lstat* --- extra/unix/stat/stat.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index 204321f30c..6d60caf987 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -74,3 +74,8 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; "stat" dup >r stat check-status r> ; + +: lstat* ( pathname -- stat ) + "stat" dup >r + lstat check-status + r> ; From 56919b42af6d41a701c5ef55de51cd4b8a58ac72 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 12:04:54 -0600 Subject: [PATCH 22/49] io.files: link-info --- core/io/files/files.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index b51d767069..899a1be006 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -54,6 +54,7 @@ TUPLE: no-parent-directory path ; TUPLE: file-info type size permissions modified ; HOOK: file-info io-backend ( path -- info ) +HOOK: link-info io-backend ( path -- info ) SYMBOL: +regular-file+ SYMBOL: +directory+ From 724041c31d5ea3525ef9aa397ed621273c06937e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 12:05:47 -0600 Subject: [PATCH 23/49] io.unix.files: add link-info unix backend --- extra/io/unix/files/files.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index db3cf674c7..4142c4be77 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -89,3 +89,12 @@ M: unix-io file-info ( path -- info ) [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] } cleave \ file-info construct-boa ; + +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 ; From a336cb7570db38c343b863fca05df740b2f2b407 Mon Sep 17 00:00:00 2001 From: dharmatech Date: Thu, 6 Mar 2008 13:46:15 -0600 Subject: [PATCH 24/49] Unit test fixes --- core/words/words-tests.factor | 6 +- extra/db/tuples/tuples-tests.factor | 6 +- extra/html/parser/analyzer/analyzer.factor | 9 +- extra/io/sniffer/bsd/bsd.factor | 2 +- extra/io/unix/kqueue/kqueue.factor | 3 +- extra/ldap/ldap-tests.factor | 5 +- extra/ldap/libldap/libldap.factor | 4 +- extra/openssl/libssl/libssl.factor | 4 +- extra/pdf/libhpdf/libhpdf.factor | 4 +- extra/pdf/pdf-tests.factor | 2 +- extra/pdf/test/font_test.pdf | 300 ------------------ extra/peg/search/search-tests.factor | 3 +- .../safe-words/safe-words.factor | 1 - extra/smtp/smtp-tests.factor | 3 +- extra/unix/unix.factor | 1 + extra/webapps/callback/authors.txt | 2 - extra/webapps/callback/callback.factor | 126 -------- extra/webapps/continuation/authors.txt | 1 - .../webapps/continuation/continuation.factor | 151 --------- .../webapps/continuation/examples/authors.txt | 1 - .../continuation/examples/examples.factor | 115 ------- 21 files changed, 31 insertions(+), 718 deletions(-) delete mode 100644 extra/pdf/test/font_test.pdf delete mode 100755 extra/webapps/callback/authors.txt delete mode 100644 extra/webapps/callback/callback.factor delete mode 100755 extra/webapps/continuation/authors.txt delete mode 100644 extra/webapps/continuation/continuation.factor delete mode 100755 extra/webapps/continuation/examples/authors.txt delete mode 100644 extra/webapps/continuation/examples/examples.factor diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 06f3c7a782..4d9933147b 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -141,7 +141,11 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ] +"undef-test" "words.tests" lookup [ + [ forget ] with-compilation-unit +] when* + +[ "IN: words.tests : undef-test ; << undef-test >>" eval ] [ [ undefined? ] is? ] must-fail-with [ ] [ diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 7d72a644bf..5913f053da 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples -db.types continuations namespaces db.postgresql math +db.types continuations namespaces math prettyprint tools.walker db.sqlite calendar math.intervals ; IN: db.tuples.tests @@ -161,8 +161,8 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-sqlite ( quot -- ) >r "tuples-test.db" temp-file sqlite-db r> with-db ; -: test-postgresql ( -- ) - >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; +! : test-postgresql ( -- ) +! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index fca15d9b07..8fc45ec486 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,6 +1,5 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces splitting -http.server.responders ; +arrays shuffle unicode.case namespaces splitting http ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) @@ -82,8 +81,8 @@ IN: html.parser.analyzer : href-contains? ( str tag -- ? ) tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; -: query>hash* ( str -- hash ) - "?" split1 nip query>hash ; +: query>assoc* ( str -- hash ) + "?" split1 nip query>assoc ; ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map @@ -91,5 +90,5 @@ IN: html.parser.analyzer ! "a" over find-opening-tags-by-name ! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset ! first first 8 + over nth -! tag-attributes "href" swap at query>hash* +! tag-attributes "href" swap at query>assoc* ! "lat" over at "lon" rot at diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor index 1c72a4780c..1456965858 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -7,7 +7,7 @@ sequences io.sniffer.backend ; QUALIFIED: unix IN: io.sniffer.bsd -M: unix-io destruct-handle ( obj -- ) unix:close drop ; +M: unix-io destruct-handle ( obj -- ) unix:close ; C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ; C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 60e3754ec6..c5dc964a7a 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -31,7 +31,8 @@ M: output-task io-task-filter drop EVFILT_WRITE ; swap io-task-filter over set-kevent-filter ; : register-kevent ( kevent mx -- ) - mx-fd swap 1 f 0 f kevent io-error ; + mx-fd swap 1 f 0 f kevent + 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) over EV_ADD make-kevent over register-kevent diff --git a/extra/ldap/ldap-tests.factor b/extra/ldap/ldap-tests.factor index e4338615ce..42e51c782a 100644 --- a/extra/ldap/ldap-tests.factor +++ b/extra/ldap/ldap-tests.factor @@ -5,10 +5,12 @@ tools.test ; get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 set-option -[ B{ 0 0 0 3 } ] [ +[ 3 ] [ get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" [ get-option ] keep + *int ] unit-test +[ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 @@ -52,3 +54,4 @@ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ get-ldp get-message next-message msgtype result-type ] with-bind +] drop diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor index 492aed1a54..ae613bd461 100755 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: ldap.libldap -"libldap" { +<< "libldap" { { [ win32? ] [ "libldap.dll" "stdcall" ] } { [ macosx? ] [ "libldap.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] } -} cond add-library +} cond add-library >> : LDAP_VERSION1 1 ; inline : LDAP_VERSION2 2 ; inline diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 29016f6d57..8d1b3b5247 100644 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl -"libssl" { +<< "libssl" { { [ win32? ] [ "ssleay32.dll" "stdcall" ] } { [ macosx? ] [ "libssl.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] } -} cond add-library +} cond add-library >> : X509_FILETYPE_PEM 1 ; inline : X509_FILETYPE_ASN1 2 ; inline diff --git a/extra/pdf/libhpdf/libhpdf.factor b/extra/pdf/libhpdf/libhpdf.factor index 85ccc70c25..a40b7cddee 100644 --- a/extra/pdf/libhpdf/libhpdf.factor +++ b/extra/pdf/libhpdf/libhpdf.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators system ; IN: pdf.libhpdf -"libhpdf" { +<< "libhpdf" { { [ win32? ] [ "libhpdf.dll" "stdcall" ] } { [ macosx? ] [ "libhpdf.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] } -} cond add-library +} cond add-library >> ! compression mode : HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed diff --git a/extra/pdf/pdf-tests.factor b/extra/pdf/pdf-tests.factor index dc42874d2a..097f671d9a 100644 --- a/extra/pdf/pdf-tests.factor +++ b/extra/pdf/pdf-tests.factor @@ -92,6 +92,6 @@ SYMBOL: twidth ] with-text - "extra/pdf/test/font_test.pdf" resource-path save-to-file + "font_test.pdf" temp-file save-to-file ] with-pdf diff --git a/extra/pdf/test/font_test.pdf b/extra/pdf/test/font_test.pdf deleted file mode 100644 index 4360cf349f..0000000000 --- a/extra/pdf/test/font_test.pdf +++ /dev/null @@ -1,300 +0,0 @@ -%PDF-1.3 -%·¾­ª -1 0 obj -<< -/Type /Catalog -/Pages 2 0 R ->> -endobj -2 0 obj -<< -/Type /Pages -/Kids [ 4 0 R ] -/Count 1 ->> -endobj -3 0 obj -<< -/Producer (Haru\040Free\040PDF\040Library\0402.0.8) ->> -endobj -4 0 obj -<< -/Type /Page -/MediaBox [ 0 0 595 841 ] -/Contents 5 0 R -/Resources << -/ProcSet [ /PDF /Text /ImageB /ImageC /ImageI ] -/Font << -/F1 7 0 R -/F2 8 0 R -/F3 9 0 R -/F4 10 0 R -/F5 11 0 R -/F6 12 0 R -/F7 13 0 R -/F8 14 0 R -/F9 15 0 R -/F10 16 0 R -/F11 17 0 R -/F12 18 0 R -/F13 19 0 R -/F14 20 0 R ->> ->> -/Parent 2 0 R ->> -endobj -5 0 obj -<< -/Length 6 0 R ->> -stream -1 w -50 50 495 731 re -S -/F1 24 Tf -BT -238.148 791 Td -(Font\040Demo) Tj -ET -BT -/F1 16 Tf -60 761 Td -(\074Standard\040Type1\040font\040samples\076) Tj -ET -BT -60 736 Td -/F2 9 Tf -(Courier) Tj -0 -18 Td -/F2 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F3 9 Tf -(Courier-Bold) Tj -0 -18 Td -/F3 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F4 9 Tf -(Courier-Oblique) Tj -0 -18 Td -/F4 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F5 9 Tf -(Courier-BoldOblique) Tj -0 -18 Td -/F5 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F1 9 Tf -(Helvetica) Tj -0 -18 Td -/F1 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F6 9 Tf -(Helvetica-Bold) Tj -0 -18 Td -/F6 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F7 9 Tf -(Helvetica-Oblique) Tj -0 -18 Td -/F7 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F8 9 Tf -(Helvetica-BoldOblique) Tj -0 -18 Td -/F8 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F9 9 Tf -(Times-Roman) Tj -0 -18 Td -/F9 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F10 9 Tf -(Times-Bold) Tj -0 -18 Td -/F10 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F11 9 Tf -(Times-Italic) Tj -0 -18 Td -/F11 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F12 9 Tf -(Times-BoldItalic) Tj -0 -18 Td -/F12 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F13 9 Tf -(Symbol) Tj -0 -18 Td -/F13 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F14 9 Tf -(ZapfDingbats) Tj -0 -18 Td -/F14 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -ET - -endstream -endobj -6 0 obj -1517 -endobj -7 0 obj -<< -/Type /Font -/BaseFont /Helvetica -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -8 0 obj -<< -/Type /Font -/BaseFont /Courier -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -9 0 obj -<< -/Type /Font -/BaseFont /Courier-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -10 0 obj -<< -/Type /Font -/BaseFont /Courier-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -11 0 obj -<< -/Type /Font -/BaseFont /Courier-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -12 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -13 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -14 0 obj -<< -/Type /Font -/BaseFont /Helvetica-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -15 0 obj -<< -/Type /Font -/BaseFont /Times-Roman -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -16 0 obj -<< -/Type /Font -/BaseFont /Times-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -17 0 obj -<< -/Type /Font -/BaseFont /Times-Italic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -18 0 obj -<< -/Type /Font -/BaseFont /Times-BoldItalic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -19 0 obj -<< -/Type /Font -/BaseFont /Symbol -/Subtype /Type1 ->> -endobj -20 0 obj -<< -/Type /Font -/BaseFont /ZapfDingbats -/Subtype /Type1 ->> -endobj -xref -0 21 -0000000000 65535 f -0000000015 00000 n -0000000064 00000 n -0000000123 00000 n -0000000196 00000 n -0000000518 00000 n -0000002089 00000 n -0000002109 00000 n -0000002207 00000 n -0000002303 00000 n -0000002404 00000 n -0000002509 00000 n -0000002618 00000 n -0000002722 00000 n -0000002829 00000 n -0000002940 00000 n -0000003041 00000 n -0000003141 00000 n -0000003243 00000 n -0000003349 00000 n -0000003417 00000 n -trailer -<< -/Root 1 0 R -/Info 3 0 R -/Size 21 ->> -startxref -3491 -%%EOF diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor index c65001be09..b22a5ef0d0 100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel math math.parser arrays tools.test peg peg.search ; +USING: kernel math math.parser arrays tools.test peg peg.parsers +peg.search ; IN: peg.search.tests { V{ 123 456 } } [ diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor index ab528786bb..f7eac4c32d 100755 --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -54,7 +54,6 @@ IN: random-tester.safe-words : method-words { - method-def forget-word } ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index c1afeced3d..32b2f3be14 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -84,6 +84,7 @@ IN: smtp.tests [ ] [ [ + "localhost" smtp-host set 4321 smtp-port set "Hi guys\nBye guys" @@ -96,4 +97,4 @@ IN: smtp.tests send-simple-message ] with-scope -] unit-test \ No newline at end of file +] unit-test diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 9cc8552f98..e1d49b8c6c 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -21,6 +21,7 @@ TYPEDEF: ulong size_t : MAP_FAILED -1 ; inline +: ESRCH 3 ; inline : EEXIST 17 ; inline ! ! ! Unix functions diff --git a/extra/webapps/callback/authors.txt b/extra/webapps/callback/authors.txt deleted file mode 100755 index a8fb961d36..0000000000 --- a/extra/webapps/callback/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Chris Double -Slava Pestov diff --git a/extra/webapps/callback/callback.factor b/extra/webapps/callback/callback.factor deleted file mode 100644 index 6bdc84bfa6..0000000000 --- a/extra/webapps/callback/callback.factor +++ /dev/null @@ -1,126 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! Copyright (C) 2006 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: html http http.server.responders io kernel math -namespaces prettyprint continuations random system sequences -assocs ; -IN: webapps.callback - -#! Name of the variable holding the continuation used to exit -#! back to the httpd responder. -SYMBOL: exit-continuation - -#! Tuple to hold global request data. This gets passed to -#! the continuation when resumed so it can restore things -#! like 'stdio' so it writes to the correct socket. -TUPLE: request stream exitcc method url raw-query query header response ; - -: ( -- request ) - stdio get - exit-continuation get - "method" get - "request" get - "raw-query" get - "query" get - "header" get - "response" get - request construct-boa ; - -: restore-request ( -- ) - request get - dup request-stream stdio set - dup request-method "method" set - dup request-raw-query "raw-query" set - dup request-query "query" set - dup request-header "header" set - dup request-response "response" set - request-exitcc exit-continuation set ; - -: update-request ( request new-request -- ) - [ request-stream over set-request-stream ] keep - [ request-method over set-request-method ] keep - [ request-url over set-request-url ] keep - [ request-raw-query over set-request-raw-query ] keep - [ request-query over set-request-query ] keep - [ request-header over set-request-header ] keep - [ request-response over set-request-response ] keep - request-exitcc swap set-request-exitcc ; - -: with-exit-continuation ( quot -- ) - #! Call the quotation with the variable exit-continuation bound - #! such that when the exit continuation is called, computation - #! will resume from the end of this 'with-exit-continuation' call. - [ - exit-continuation set call exit-continuation get continue - ] callcc0 drop ; - -: expiry-timeout ( -- ms ) 900 1000 * ; - -: get-random-id ( -- id ) - #! Generate a random id to use for continuation URL's - 4 big-random unparse ; - -: callback-table ( -- ) - #! Return the global table of continuations - \ callback-table get-global ; - -: reset-callback-table ( -- ) - #! Create the initial global table - H{ } clone \ callback-table set-global ; - -reset-callback-table - -#! Tuple for holding data related to a callback. -TUPLE: item quot expire? request id time-added ; - -: ( quot expire? request id -- item ) - millis item construct-boa ; - -: expired? ( item -- ? ) - #! Return true if the callback item is expirable - #! and has expired (ie. was added to the table more than - #! timeout milliseconds ago). - [ item-time-added expiry-timeout + millis < ] keep - item-expire? and ; - -: expire-callbacks ( -- ) - #! Expire all continuations in the continuation table - #! if they are 'timeout-seconds' old (ie. were added - #! more than 'timeout-seconds' ago. - callback-table clone [ - expired? [ callback-table delete-at ] [ drop ] if - ] assoc-each ; - -: id>url ( id -- string ) - #! Convert the continuation id to an URL suitable for - #! embedding in an HREF or other HTML. - "/responder/callback/?id=" swap url-encode append ; - -: register-callback ( quot expire? -- url ) - #! Store a continuation in the table and associate it with - #! a random id. That continuation will be expired after - #! a certain period of time if 'expire?' is true. - request get get-random-id [ ] keep - [ callback-table set-at ] keep - id>url ; - -: register-html-callback ( quot expire? -- url ) - >r [ serving-html ] swap append r> register-callback ; - -: callback-responder ( -- ) - expire-callbacks - "id" query-param callback-table at [ - [ - dup item-request [ - update-request - ] when* - item-quot call - exit-continuation get continue - ] with-exit-continuation drop - ] [ - "404 Callback not available" httpd-error - ] if* ; - -global [ - "callback" [ callback-responder ] add-simple-responder -] bind diff --git a/extra/webapps/continuation/authors.txt b/extra/webapps/continuation/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/webapps/continuation/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/continuation/continuation.factor b/extra/webapps/continuation/continuation.factor deleted file mode 100644 index 6b6838d89f..0000000000 --- a/extra/webapps/continuation/continuation.factor +++ /dev/null @@ -1,151 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! See http://factorcode.org/license.txt for BSD license. - -USING: http math namespaces io strings kernel html html.elements -hashtables continuations quotations parser generic sequences -webapps.callback http.server.responders ; -IN: webapps.continuation - -#! Used inside the session state of responders to indicate whether the -#! next request should use the post-refresh-get pattern. It is set to -#! true after each request. -SYMBOL: post-refresh-get? - -: >callable ( quot|interp|f -- interp ) - dup continuation? [ - [ continue ] curry - ] when ; - -: forward-to-url ( url -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - [ - "HTTP/1.1 302 Document Moved\nLocation: " % % - "\nContent-Length: 0\nContent-Type: text/plain\n\n" % - ] "" make write exit-continuation get continue ; - -: forward-to-id ( id -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - >r "request" get r> id>url append forward-to-url ; - -SYMBOL: current-show - -: store-current-show ( -- ) - #! Store the current continuation in the variable 'current-show' - #! so it can be returned to later by href callbacks. Note that it - #! recalls itself when the continuation is called to ensure that - #! it resets its value back to the most recent show call. - [ ( 0 -- ) - [ ( 0 1 -- ) - current-show set ( 0 -- ) - continue - ] callcc1 - nip - restore-request - call - store-current-show - ] callcc0 restore-request ; - -: redirect-to-here ( -- ) - #! Force a redirect to the client browser so that the browser - #! goes to the current point in the code. This forces an URL - #! change on the browser so that refreshing that URL will - #! immediately run from this code point. This prevents the - #! "this request will issue a POST" warning from the browser - #! and prevents re-running the previous POST logic. This is - #! known as the 'post-refresh-get' pattern. - post-refresh-get? get [ - [ - >callable t register-callback forward-to-url - ] callcc0 restore-request - ] [ - t post-refresh-get? set - ] if ; - -: (show) ( quot -- hashtable ) - #! See comments for show. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-current-show redirect-to-here - [ - >callable t register-callback swap with-scope - exit-continuation get continue - ] callcc0 drop restore-request "response" get ; - -: show ( quot -- namespace ) - #! Call the quotation with the URL associated with the current - #! continuation. All output from the quotation goes to the client - #! browser. When the URL is later referenced then - #! computation will resume from this 'show' call with a hashtable on - #! the stack containing any query or post parameters. - #! 'quot' has stack effect ( url -- ) - #! NOTE: On return from 'show' the stack is exactly the same as - #! initial entry with 'quot' popped off and the hashtable pushed on. Even - #! if the quotation consumes items on the stack. - [ serving-html ] swap append (show) ; - -: (show-final) ( quot -- namespace ) - #! See comments for show-final. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-current-show redirect-to-here - with-scope exit-continuation get continue ; - -: show-final ( quot -- namespace ) - #! Similar to 'show', except the quotation does not receive the URL - #! to resume computation following 'show-final'. No continuation is - #! stored for this resumption. As a result, 'show-final' is for use - #! when a page is to be displayed with no further action to occur. Its - #! use is an optimisation to save having to generate and save a continuation - #! in that special case. - #! 'quot' has stack effect ( -- ). - [ serving-html ] swap compose (show-final) ; - -#! Name of variable for holding initial continuation id that starts -#! the responder. -SYMBOL: root-callback - -: cont-get/post-responder ( id-or-f -- ) - #! httpd responder that handles the root continuation request. - #! The requests for actual continuation are processed by the - #! 'callback-responder'. - [ - [ f post-refresh-get? set request set root-callback get call ] with-scope - exit-continuation get continue - ] with-exit-continuation drop ; - -: quot-url ( quot -- url ) - current-show get [ continue-with ] 2curry t register-callback ; - -: quot-href ( text quot -- ) - #! Write to standard output an HTML HREF where the href, - #! when referenced, will call the quotation and then return - #! back to the most recent 'show' call (via the callback-cc). - #! The text of the link will be the 'text' argument on the - #! stack. - write ; - -: install-cont-responder ( name quot -- ) - #! Install a cont-responder with the given name - #! that will initially run the given quotation. - #! - #! Convert the quotation so it is run within a session namespace - #! and that namespace is initialized first. - [ - [ cont-get/post-responder ] "get" set - [ cont-get/post-responder ] "post" set - swap "responder" set - root-callback set - ] make-responder ; - -: show-message-page ( message -- ) - #! Display the message in an HTML page with an OK button. - [ - "Press OK to Continue" [ - swap paragraph - "OK" write - ] simple-page - ] show 2drop ; diff --git a/extra/webapps/continuation/examples/authors.txt b/extra/webapps/continuation/examples/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/webapps/continuation/examples/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/continuation/examples/examples.factor b/extra/webapps/continuation/examples/examples.factor deleted file mode 100644 index 2899562503..0000000000 --- a/extra/webapps/continuation/examples/examples.factor +++ /dev/null @@ -1,115 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! -! Simple test applications -USING: hashtables html kernel io html html.elements strings math -assocs quotations webapps.continuation namespaces prettyprint -sequences ; - -IN: webapps.continuation.examples - -: display-page ( title -- ) - #! Display a page with some text to test the cont-responder. - #! The page has a link to the 'next' continuation. - [ -

over write

- swap [ - "Next" write - ] simple-html-document - ] show 2drop ; - -: display-get-name-page ( -- name ) - #! Display a page prompting for input of a name and return that name. - [ - "Enter your name" [ -

swap write

-
- "Name: " write - - -
- ] simple-html-document - ] show "name" swap at ; - -: test-cont-responder ( -- ) - #! Test the cont-responder responder by displaying a few pages in a row. - "Page one" display-page - "Hello " display-get-name-page append display-page - "Page three" display-page ; - -: test-cont-responder2 ( -- ) - #! Test the cont-responder responder by displaying a few pages in a loop. - [ "one" "two" "three" "four" ] [ display-page ] each - "Done!" display-page ; - -: test-cont-responder3 ( -- ) - #! Test the quot-href word by displaying a menu of the current - #! test words. Note that we use show-final as we don't link to a 'next' page. - [ - "Menu" [ -

"Menu" write

-
    -
  1. "Test responder1" [ test-cont-responder ] quot-href
    2. -
  2. "Test responder2" [ test-cont-responder2 ] quot-href
    3. -
- ] simple-html-document - ] show-final ; - -: counter-example ( count -- ) - #! Display a counter which can be incremented or decremented - #! using anchors. - #! - #! Don't need the original alist - [ - #! And we don't need the 'url' argument - drop - "Counter: " over unparse append [ - dup

unparse write

- "++" over 1quotation [ f ] swap append [ 1 + counter-example ] append quot-href - "--" over 1quotation [ f ] swap append [ 1 - counter-example ] append quot-href - drop - ] simple-html-document - ] show drop ; - -: counter-example2 ( -- ) - #! Display a counter which can be incremented or decremented - #! using anchors. - #! - 0 "counter" set - [ - #! We don't need the 'url' argument - drop - "Counter: " "counter" get unparse append [ -

"counter" get unparse write

- "++" [ "counter" get 1 + "counter" set ] quot-href - "--" [ "counter" get 1 - "counter" set ] quot-href - ] simple-html-document - ] show - drop ; - -! Install the examples -"counter1" [ drop 0 counter-example ] install-cont-responder -"counter2" [ drop counter-example2 ] install-cont-responder -"test1" [ test-cont-responder ] install-cont-responder -"test2" [ drop test-cont-responder2 ] install-cont-responder -"test3" [ drop test-cont-responder3 ] install-cont-responder From 549a7538c7d94349106c24b6ff083b5339512c62 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 15:58:05 -0600 Subject: [PATCH 25/49] Clean up some of Dan's code after merge --- core/bootstrap/primitives.factor | 1 + core/inference/known-words/known-words.factor | 2 + core/io/io-tests.factor | 9 +++-- core/io/streams/c/c-tests.factor | 4 +- core/io/streams/c/c.factor | 17 ++++---- extra/http/server/server.factor | 4 +- extra/io/nonblocking/nonblocking.factor | 22 ++++++----- extra/io/sockets/sockets.factor | 8 ++-- extra/io/unix/sockets/sockets.factor | 16 ++++---- extra/io/windows/nt/sockets/sockets.factor | 29 +++++--------- vm/io.c | 39 +++++++++++++++---- vm/io.h | 5 ++- vm/primitives.c | 1 + 13 files changed, 92 insertions(+), 65 deletions(-) mode change 100644 => 100755 core/io/io-tests.factor diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f3f233ea0b..ab0e1cebe0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -623,6 +623,7 @@ builtins get num-tags get tail f union-class define-class { "fopen" "io.streams.c" } { "fgetc" "io.streams.c" } { "fread" "io.streams.c" } + { "fputc" "io.streams.c" } { "fwrite" "io.streams.c" } { "fflush" "io.streams.c" } { "fclose" "io.streams.c" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 8e8251ff62..5e150e66b7 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -538,6 +538,8 @@ set-primitive-effect \ fwrite { string alien } { } set-primitive-effect +\ fputc { object alien } { } set-primitive-effect + \ fread { integer string } { object } set-primitive-effect \ fflush { alien } { } set-primitive-effect diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor old mode 100644 new mode 100755 index 8b5e763e45..22c942d2d9 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,5 +1,6 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces io.encodings.ascii io.encodings.binary ; +tools.test words namespaces io.encodings.latin1 +io.encodings.binary ; IN: io.tests [ f ] [ @@ -8,7 +9,7 @@ IN: io.tests ] unit-test : ( resource -- stream ) - resource-path binary ; + resource-path latin1 ; [ "This is a line.\rThis is another line.\r" @@ -31,10 +32,10 @@ IN: io.tests ! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test -[ "" ] [ +[ "/core/io/test/binary.txt" [ 0.2 read ] with-stream -] unit-test +] must-fail [ { diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 6c7e57cabb..321cad4d19 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,4 +1,5 @@ -USING: tools.test io.files io io.streams.c io.encodings.ascii ; +USING: tools.test io.files io io.streams.c +io.encodings.ascii strings ; IN: io.streams.c.tests [ "hello world" ] [ @@ -7,4 +8,5 @@ IN: io.streams.c.tests ] with-file-writer "test.txt" temp-file "rb" fopen contents + >string ] unit-test diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index de49e0dfe6..372acbe0c1 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private namespaces io io.encodings -strings sequences math generic threads.private classes -io.backend io.streams.duplex io.files continuations -io.encodings.utf8 ; +sequences math generic threads.private classes io.backend +io.streams.duplex io.files continuations byte-arrays ; IN: io.streams.c TUPLE: c-writer handle ; @@ -11,10 +10,10 @@ TUPLE: c-writer handle ; C: c-writer M: c-writer stream-write1 - >r 1string r> stream-write ; + c-writer-handle fputc ; M: c-writer stream-write - >r >string r> c-writer-handle fwrite ; + c-writer-handle fwrite ; M: c-writer stream-flush c-writer-handle fflush ; @@ -27,7 +26,7 @@ TUPLE: c-reader handle ; C: c-reader M: c-reader stream-read - >r >fixnum r> c-reader-handle fread ; + c-reader-handle fread ; M: c-reader stream-read-partial stream-read ; @@ -43,7 +42,7 @@ M: c-reader stream-read1 ] if ; M: c-reader stream-read-until - [ swap read-until-loop ] "" make swap + [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; M: c-reader dispose @@ -76,4 +75,6 @@ M: object (file-appender) #! print stuff from contexts where the I/O system would #! otherwise not work (tools.deploy.shaker, the I/O #! multiplexer thread). - "\r\n" append stdout-handle fwrite stdout-handle fflush ; + "\r\n" append >byte-array + stdout-handle fwrite + stdout-handle fflush ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 858ccd1009..133783114d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,7 +4,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib vocabs.loader debugger html continuations random combinators -destructors ; +destructors io.encodings.latin1 ; IN: http.server GENERIC: call-responder ( request path responder -- response ) @@ -165,7 +165,7 @@ LOG: httpd-hit NOTICE : httpd ( port -- ) internet-server "http.server" - binary [ handle-client ] with-server ; + latin1 [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index b0ce1fcc12..6eee3739d9 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers io.timeouts generic -sbufs system io.streams.duplex io.encodings +byte-vectors system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces splitting dlists assocs io.encodings.binary ; @@ -71,7 +71,7 @@ GENERIC: (wait-to-read) ( port -- ) M: input-port stream-read1 dup wait-to-read1 [ buffer-pop ] unless-eof ; -: read-step ( count port -- string/f ) +: read-step ( count port -- byte-array/f ) [ wait-to-read ] 2keep [ dupd buffer> ] unless-eof nip ; @@ -90,10 +90,10 @@ M: input-port stream-read >r 0 max >fixnum r> 2dup read-step dup [ pick over length > [ - pick + pick [ push-all ] keep [ read-loop ] keep - "" like + B{ } like ] [ 2nip ] if @@ -101,7 +101,7 @@ M: input-port stream-read 2nip ] if ; -: read-until-step ( separators port -- string/f separator/f ) +: read-until-step ( separators port -- byte-array/f separator/f ) dup wait-to-read1 dup port-eof? [ f swap set-port-eof? drop f f @@ -109,7 +109,7 @@ M: input-port stream-read buffer-until ] if ; -: read-until-loop ( seps port sbuf -- separator/f ) +: read-until-loop ( seps port byte-vector -- separator/f ) 2over read-until-step over [ >r over push-all r> dup [ >r 3drop r> @@ -120,18 +120,20 @@ M: input-port stream-read >r 2drop 2drop r> ] if ; -M: input-port stream-read-until ( seps port -- str/f sep/f ) +M: input-port stream-read-until ( seps port -- byte-array/f sep/f ) 2dup read-until-step dup [ >r 2nip r> ] [ over [ - drop >sbuf [ read-until-loop ] keep "" like swap + drop >byte-vector + [ read-until-loop ] keep + B{ } like swap ] [ >r 2nip r> ] if ] if ; -M: input-port stream-read-partial ( max stream -- string/f ) +M: input-port stream-read-partial ( max stream -- byte-array/f ) >r 0 max >fixnum r> read-step ; : can-write? ( len writer -- ? ) @@ -169,7 +171,7 @@ M: port dispose [ dup port-type >r closed over set-port-type r> close-port ] if ; -TUPLE: server-port addr client encoding ; +TUPLE: server-port addr client client-addr encoding ; : ( handle addr encoding -- server ) rot f server-port diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index c10d7e963c..1dc7f4883d 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -33,17 +33,19 @@ M: array client* [ (client) 2array ] attempt-all first2 ; M: object client* (client) ; : ( addrspec encoding -- stream ) - over client* rot ; + >r client* r> ; HOOK: (server) io-backend ( addrspec -- handle ) : ( addrspec encoding -- server ) >r [ (server) ] keep r> ; -HOOK: (accept) io-backend ( server -- stream-in stream-out ) +HOOK: (accept) io-backend ( server -- addrspec handle ) : accept ( server -- client ) - [ (accept) ] keep server-port-encoding ; + [ (accept) dup ] keep + server-port-encoding + ; HOOK: io-backend ( addrspec -- datagram ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 2af77e83c4..bd7dfd9ce1 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -42,7 +42,7 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io (client) ( addrspec -- stream ) +M: unix-io (client) ( addrspec -- client-in client-out ) dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd dup r> r> connect @@ -71,10 +71,10 @@ TUPLE: accept-task ; dup [ swap heap-size accept ] keep ; inline : do-accept ( port fd sockaddr -- ) - rot [ - server-port-addr parse-sockaddr - swap dup - ] keep set-server-port-client ; + rot + [ server-port-addr parse-sockaddr ] keep + [ set-server-port-client-addr ] keep + set-server-port-client ; M: accept-task do-io-task io-task-port dup accept-sockaddr @@ -95,13 +95,13 @@ M: unix-io (server) ( addrspec -- handle ) SOCK_STREAM server-fd dup 10 listen zero? [ dup close (io-error) ] unless ; -M: unix-io (accept) ( server -- client-in client-out ) +M: unix-io (accept) ( server -- addrspec handle ) #! Wait for a client connection. dup check-server-port dup wait-to-accept dup pending-error - server-port-client - { duplex-stream-in duplex-stream-out } get-slots ; + dup server-port-client-addr + swap server-port-client ; ! Datagram sockets - UDP and Unix domain M: unix-io diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 7af7df9bef..a63a533ba1 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -45,13 +45,12 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( ConnectEx -- ) - dup ConnectEx-args-lpOverlapped* - swap ConnectEx-args-port duplex-stream-in - [ save-callback ] 2keep +: connect-continuation ( ConnectEx port -- ) + >r ConnectEx-args-lpOverlapped* r> + 2dup save-callback get-overlapped-result drop ; -M: windows-nt-io (client) ( addrspec -- duplex-stream ) +M: windows-nt-io (client) ( addrspec -- client-in client-out ) [ \ ConnectEx-args construct-empty over make-sockaddr/size pick init-connect @@ -61,14 +60,8 @@ M: windows-nt-io (client) ( addrspec -- duplex-stream ) dup ConnectEx-args-s* INADDR_ANY roll bind-socket dup (ConnectEx) - dup ConnectEx-args-s* - dup - over set-ConnectEx-args-port - - dup connect-continuation - ConnectEx-args-port - [ duplex-stream-in pending-error ] keep - [ duplex-stream-out pending-error ] keep + dup ConnectEx-args-s* dup + >r [ connect-continuation ] keep [ pending-error ] keep r> ] with-destructors ; TUPLE: AcceptEx-args port @@ -118,17 +111,15 @@ TUPLE: AcceptEx-args port ] keep *void* ] keep AcceptEx-args-port server-port-addr parse-sockaddr ; -: accept-continuation ( AcceptEx -- client ) +: accept-continuation ( AcceptEx -- addrspec client ) [ make-accept-continuation ] keep [ check-accept-error ] keep [ extract-remote-host ] keep ! addrspec AcceptEx - [ - AcceptEx-args-sAcceptSocket* add-completion - ] keep + [ AcceptEx-args-sAcceptSocket* add-completion ] keep AcceptEx-args-sAcceptSocket* ; -M: windows-nt-io (accept) ( server -- client-in client-out ) +M: windows-nt-io (accept) ( server -- addrspec handle ) [ [ dup check-server-port @@ -137,8 +128,6 @@ M: windows-nt-io (accept) ( server -- client-in client-out ) [ ((accept)) ] keep [ accept-continuation ] keep AcceptEx-args-port pending-error - dup duplex-stream-in pending-error - dup duplex-stream-out pending-error ] with-timeout ] with-destructors ; diff --git a/vm/io.c b/vm/io.c index d3a29abe72..faf681bbef 100755 --- a/vm/io.c +++ b/vm/io.c @@ -102,21 +102,46 @@ DEFINE_PRIMITIVE(fread) } else { - dpush(tag_object(memory_to_char_string( - (char *)(buf + 1),c))); + if(c != size) + { + REGISTER_UNTAGGED(buf); + F_BYTE_ARRAY *new_buf = allot_byte_array(c); + UNREGISTER_UNTAGGED(buf); + memcpy(new_buf + 1, buf + 1,c); + buf = new_buf; + } + dpush(tag_object(buf)); break; } } } +DEFINE_PRIMITIVE(fputc) +{ + FILE *file = unbox_alien(); + F_FIXNUM ch = to_fixnum(dpop()); + + for(;;) + { + if(fputc(ch,file) == EOF) + { + io_error(); + + /* Still here? EINTR */ + } + else + break; + } +} + DEFINE_PRIMITIVE(fwrite) { - FILE* file = unbox_alien(); - F_STRING* text = untag_string(dpop()); - F_FIXNUM length = untag_fixnum_fast(text->length); - char* string = to_char_string(text,false); + FILE *file = unbox_alien(); + F_BYTE_ARRAY *text = untag_byte_array(dpop()); + F_FIXNUM length = array_capacity(text); + char *string = (char *)(text + 1); - if(string_capacity(text) == 0) + if(length == 0) return; for(;;) diff --git a/vm/io.h b/vm/io.h index 39e7390c3e..a19da3887c 100755 --- a/vm/io.h +++ b/vm/io.h @@ -3,11 +3,12 @@ void io_error(void); int err_no(void); DECLARE_PRIMITIVE(fopen); +DECLARE_PRIMITIVE(fgetc); +DECLARE_PRIMITIVE(fread); +DECLARE_PRIMITIVE(fputc); DECLARE_PRIMITIVE(fwrite); DECLARE_PRIMITIVE(fflush); DECLARE_PRIMITIVE(fclose); -DECLARE_PRIMITIVE(fgetc); -DECLARE_PRIMITIVE(fread); /* Platform specific primitives */ DECLARE_PRIMITIVE(open_file); diff --git a/vm/primitives.c b/vm/primitives.c index a5cdb4f1ef..1b29dc65b7 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -162,6 +162,7 @@ void *primitives[] = { primitive_fopen, primitive_fgetc, primitive_fread, + primitive_fputc, primitive_fwrite, primitive_fflush, primitive_fclose, From 62568770a9fad32a8b911f2ec19de0979f640b0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 16:07:30 -0600 Subject: [PATCH 26/49] Fix --- core/io/binary/binary.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 core/io/binary/binary.factor diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor old mode 100644 new mode 100755 index c4d3abefce..9f6231b643 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,7 +10,7 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- str ) [ nth-byte ] with "" map-as ; +: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; : >be ( x n -- str ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) From eaf11d94e386458a2f7efc6d4bca7b18d79e9b7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 16:55:54 -0600 Subject: [PATCH 27/49] Fix editors.jedit --- extra/editors/jedit/jedit.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index ed579dde42..3ce2c40192 100644 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions io kernel math namespaces parser prettyprint sequences strings words -editors io.files io.sockets io.streams.string io.binary -math.parser io.encodings.ascii ; +editors io.files io.sockets io.streams.byte-array io.binary +math.parser io.encodings.ascii io.encodings.binary +io.encodings.utf8 ; IN: editors.jedit : jedit-server-info ( -- port auth ) @@ -14,17 +15,17 @@ IN: editors.jedit ] with-file-reader ; : make-jedit-request ( files -- code ) - [ + utf8 [ "EditServer.handleClient(false,false,false," write cwd pprint "," write "new String[] {" write [ pprint "," write ] each "null});\n" write - ] with-string-writer ; + ] with-byte-writer ; : send-jedit-request ( request -- ) - jedit-server-info swap "localhost" swap [ + jedit-server-info "localhost" rot binary [ 4 >be write dup length 2 >be write write From e6d4afa1c1c7a71845b3f1516fe9cc74f21166cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:03:44 -0600 Subject: [PATCH 28/49] remove unique from core/ docs --- core/io/files/files-docs.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index f68d5eafbd..9609cd123b 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -89,7 +89,6 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "fs-meta" } { $subsection "directories" } { $subsection "delete-move-copy" } -{ $subsection "unique" } { $see-also "os" } ; ABOUT: "io.files" From 488579e1c0f6493977b605e78635afbe559d0bde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:09:48 -0600 Subject: [PATCH 29/49] add some more find words --- extra/html/parser/analyzer/analyzer.factor | 74 ++++++++++++++++++---- 1 file changed, 60 insertions(+), 14 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index fca15d9b07..511730efb4 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,8 +1,50 @@ USING: assocs html.parser kernel math sequences strings ascii arrays shuffle unicode.case namespaces splitting -http.server.responders ; +http.server.responders sequences.lib ; IN: html.parser.analyzer +: multi-find* ( n seq quots -- i elt ) + ; + +: multi-find ( seq quots -- i elt ) + 0 -rot ; + +: (find-relative) + [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; + +: find-relative ( seq quot n -- i elt ) + >r over [ find drop ] dip r> swap pick + (find-relative) ; + +: (find-all) ( n seq quot -- ) + 2dup >r >r find* [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; + +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; + +: (find-nth) ( offset seq quot n count -- obj ) + >r >r [ find* ] 2keep 4 npick [ + r> r> 1+ 2dup <= [ + 4drop + ] [ + >r >r >r >r drop 1+ r> r> r> r> + (find-nth) + ] if + ] [ + 2drop r> r> 2drop + ] if ; + +: find-nth ( seq quot n -- i elt ) + 0 -roll 0 (find-nth) ; + +: find-nth-relative ( seq quot n offest -- i elt ) + >r [ find-nth ] 3keep 2drop nip r> swap pick + (find-relative) ; + : remove-blank-text ( vector -- vector' ) [ dup tag-name text = [ @@ -52,29 +94,33 @@ IN: html.parser.analyzer >r >lower r> [ tag-attributes at over = ] with find rot drop ; -: find-between ( i/f tag/f vector -- vector ) +: find-between* ( i/f tag/f vector -- vector ) pick integer? [ - rot 1+ tail-slice + rot tail-slice >r tag-name r> - [ find-matching-close drop ] keep swap head + [ find-matching-close drop 1+ ] keep swap head ] [ 3drop V{ } clone ] if ; + +: find-between ( i/f tag/f vector -- vector ) + find-between* dup length 3 >= [ + [ 1 tail-slice 1 head-slice* ] keep like + ] when ; + +: find-between-first ( string vector -- vector' ) + [ find-first-name ] keep find-between ; + +: tag-link ( tag -- link/f ) + tag-attributes [ "href" swap at ] [ f ] if* ; : find-links ( vector -- vector ) [ tag-name "a" = ] subset - [ tag-attributes "href" swap at ] map - [ ] subset ; + [ tag-link ] subset ; -: (find-all) ( n seq quot -- ) - 2dup >r >r find* [ - dupd 2array , 1+ r> r> (find-all) - ] [ - r> r> 3drop - ] if* ; -: find-all ( seq quot -- alist ) - [ 0 -rot (find-all) ] { } make ; +: find-by-text ( seq quot -- tag ) + [ dup tag-name text = ] swap compose find drop ; : find-opening-tags-by-name ( name seq -- seq ) [ [ tag-name = ] keep tag-closing? not and ] with find-all ; From 635749a50b87da69393346d740318bb6b04fc648 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:10:17 -0600 Subject: [PATCH 30/49] move nmake to namespaces.lib --- extra/db/types/types.factor | 27 --------------------------- 1 file changed, 27 deletions(-) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index c2aa825db8..023c72cd2d 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -153,33 +153,6 @@ TUPLE: no-sql-modifier ; [ lookup-modifier ] map " " join dup empty? [ " " swap append ] unless ; -SYMBOL: building-seq -: get-building-seq ( n -- seq ) - building-seq get nth ; - -: n, get-building-seq push ; -: n% get-building-seq push-all ; -: n# >r number>string r> n% ; - -: 0, 0 n, ; -: 0% 0 n% ; -: 0# 0 n# ; -: 1, 1 n, ; -: 1% 1 n% ; -: 1# 1 n# ; -: 2, 2 n, ; -: 2% 2 n% ; -: 2# 2 n# ; - -: nmake ( quot exemplars -- seqs ) - dup length dup zero? [ 1+ ] when - [ - [ - [ drop 1024 swap new-resizable ] 2map - [ building-seq set call ] keep - ] 2keep >r [ like ] 2map r> firstn - ] with-scope ; - HOOK: bind% db ( spec -- ) TUPLE: no-slot-named ; From 61c77e616f6100933774062cf4e1aa5d9f51f439 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:10:56 -0600 Subject: [PATCH 31/49] rename nths to switches add ?nth* and nths to sequences.lib --- extra/sequences/lib/lib.factor | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index c02932a020..050de0ae1c 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -140,13 +140,13 @@ PRIVATE> : strings ( alphabet length -- seqs ) >r dup length r> number-strings map-alphabet ; -: nths ( nths seq -- subseq ) - ! nths is a sequence of ones and zeroes +: switches ( seq1 seq -- subseq ) + ! seq1 is a sequence of ones and zeroes >r [ length ] keep [ nth 1 = ] curry subset r> [ nth ] curry { } map-as ; : power-set ( seq -- subsets ) - 2 over length exact-number-strings swap [ nths ] curry map ; + 2 over length exact-number-strings swap [ switches ] curry map ; : push-either ( elt quot accum1 accum2 -- ) >r >r keep swap r> r> ? push ; inline @@ -214,3 +214,9 @@ PRIVATE> : attempt-each ( seq quot -- result ) (each) iterate-prep (attempt-each-integer) ; inline + +: ?nth* ( n seq -- elt/f ? ) + 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable + +: nths ( indices seq -- seq' ) + [ swap nth ] with map ; From 68f1b9432f67d49c7c8127adbac8d56ffb78126d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:55:18 -0600 Subject: [PATCH 32/49] load file-info on windows by default fix the file type add commented out file times --- extra/io/windows/ce/ce.factor | 1 + extra/io/windows/files/files.factor | 20 +++++++++++--------- extra/io/windows/nt/nt.factor | 1 + 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index a5e0cb6b4a..878f5899f6 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -3,4 +3,5 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher namespaces io.windows.mmap ; IN: io.windows.ce +USE: io.windows.files T{ windows-ce-io } set-io-backend diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index fdd574d00e..d107f80723 100644 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -50,17 +50,20 @@ SYMBOL: +encrypted+ { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } } get-flags ; +: win32-file-type ( n -- symbol ) + FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; + : WIN32_FIND_DATA>file-info { - [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] [ [ WIN32_FIND_DATA-nFileSizeLow ] [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit ] [ WIN32_FIND_DATA-dwFileAttributes ] - [ - WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp - ] + ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ] + [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ] + ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ] } cleave \ file-info construct-boa ; @@ -73,16 +76,15 @@ SYMBOL: +encrypted+ : BY_HANDLE_FILE_INFORMATION>file-info { - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ] [ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit ] [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] - [ - BY_HANDLE_FILE_INFORMATION-ftLastWriteTime - FILETIME>timestamp - ] + ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] + [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] + ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] } cleave \ file-info construct-boa ; diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index be57a398a2..9bc587e00e 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -9,6 +9,7 @@ USE: io.windows.nt.launcher USE: io.windows.nt.monitors USE: io.windows.nt.sockets USE: io.windows.mmap +USE: io.windows.files USE: io.backend T{ windows-nt-io } set-io-backend From 05b02f3c38be9e7560c97b68a84f8e00948faecc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 20:44:52 -0600 Subject: [PATCH 33/49] Changing launcher to use new_slots --- core/bootstrap/primitives.factor | 4 +- core/inference/known-words/known-words.factor | 5 +- core/system/system-tests.factor | 15 +- core/system/system.factor | 5 +- extra/io/launcher/launcher-docs.factor | 195 +++++++----------- extra/io/launcher/launcher.factor | 156 +++++++------- extra/io/unix/kqueue/kqueue.factor | 2 +- extra/io/unix/launcher/launcher-tests.factor | 53 +++-- extra/io/unix/launcher/launcher.factor | 55 +++-- extra/io/windows/launcher/launcher.factor | 2 +- extra/tools/deploy/backend/backend.factor | 12 +- extra/tools/disassembler/disassembler.factor | 12 +- vm/os-unix.c | 23 +++ vm/os-windows.c | 5 + vm/primitives.c | 1 + vm/run.h | 1 + 16 files changed, 287 insertions(+), 259 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index ab0e1cebe0..5ac637572a 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -78,6 +78,7 @@ call "strings" "strings.private" "system" + "system.private" "threads.private" "tools.profiler.private" "tuples" @@ -646,7 +647,8 @@ builtins get num-tags get tail f union-class define-class { "innermost-frame-scan" "kernel.private" } { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } - { "(os-envs)" "system" } + { "(os-envs)" "system.private" } + { "(set-os-envs)" "system.private" } { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 5e150e66b7..235c2924bb 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -10,7 +10,8 @@ namespaces.private parser prettyprint quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private tuples tuples.private vectors vectors.private -words words.private assocs inspector compiler.units ; +words words.private assocs inspector compiler.units +system.private ; IN: inference.known-words ! Shuffle words @@ -597,6 +598,8 @@ set-primitive-effect \ (os-envs) { } { array } set-primitive-effect +\ (set-os-envs) { array } { } set-primitive-effect + \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop \ dll-valid? { object } { object } set-primitive-effect diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index 296f542418..ad0e5e07cb 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,6 +1,17 @@ -USING: math tools.test system prettyprint ; +USING: math tools.test system prettyprint namespaces kernel ; IN: system.tests [ t ] [ cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test -[ ] [ os-envs . ] unit-test + +wince? [ + [ ] [ os-envs . ] unit-test +] unless + +unix? [ + [ ] [ os-envs "envs" set ] unit-test + [ ] [ { { "A" "B" } } set-os-envs ] unit-test + [ "B" ] [ "A" os-env ] unit-test + [ ] [ "envs" get set-os-envs ] unit-test + [ t ] [ os-envs "envs" get = ] unit-test +] when diff --git a/core/system/system.factor b/core/system/system.factor index 4500720058..58abd4be2f 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: system USING: kernel kernel.private sequences math namespaces -splitting assocs ; +splitting assocs system.private ; : cell ( -- n ) 7 getenv ; foldable @@ -59,3 +59,6 @@ splitting assocs ; : os-envs ( -- assoc ) (os-envs) [ "=" split1 ] H{ } map>assoc ; + +: set-os-envs ( assoc -- ) + [ "=" swap 3append ] { } assoc>map (set-os-envs) ; diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 0e50fd642a..5f72917e66 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -4,102 +4,71 @@ USING: help.markup help.syntax quotations kernel io math calendar ; IN: io.launcher -HELP: +command+ -{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ; +ARTICLE: "io.launcher.command" "Specifying a command" +"The " { $snippet "command" } " slot of a " { $link process } " can contain either a string or a sequence of strings. In the first case, the string is processed in an operating system-specific manner. In the second case, the first element is a program name and the remaining elements are passed to the program as command-line arguments." ; -HELP: +arguments+ -{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ; +ARTICLE: "io.launcher.detached" "Running processes in the background" +"By default, " { $link run-process } " waits for the process to complete. To run a process without waiting for it to finish, set the " { $snippet "detached" } " slot of a " { $link process } ", or use the following word:" +{ $subsection run-detached } ; -HELP: +detached+ -{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete." +ARTICLE: "io.launcher.environment" "Setting environment variables" +"The " { $snippet "environment" } " slot of a " { $link process } " contains an association mapping environment variable names to values. The interpretation of environment variables is operating system-specific." $nl -"Default value is " { $link f } "." } -{ $notes "Cannot be used with " { $link } "." } -{ $see-also run-detached } ; +"The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:" +{ $subsection +prepend-environment+ } +{ $subsection +replace-environment+ } +{ $subsection +append-environment+ } +"The default value is " { $link +append-environment+ } "." ; -HELP: +environment+ -{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key." +ARTICLE: "io.launcher.redirection" "Input/output redirection" +"On all operating systems except for Windows CE, the default input/output/error streams can be redirected." $nl -"Default value is an empty association." } ; - -HELP: +environment-mode+ -{ $description "Launch descriptor key. Must equal of the following:" - { $list - { $link +prepend-environment+ } - { $link +replace-environment+ } - { $link +append-environment+ } - } -"Default value is " { $link +append-environment+ } "." -} ; - -HELP: +stdin+ -{ $description "Launch descriptor key. Must equal one of the following:" - { $list - { { $link f } " - standard input is either inherited from the current process, or is a " { $link } " pipe" } - { { $link +inherit+ } " - standard input is inherited from the current process" } - { { $link +closed+ } " - standard input is closed" } - { "a path name - standard input is read from the given file, which must exist" } - { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" } - } -} ; - -HELP: +stdout+ -{ $description "Launch descriptor key. Must equal one of the following:" - { $list - { { $link f } " - standard output is either inherited from the current process, or is a " { $link } " pipe" } - { { $link +inherit+ } " - standard output is inherited from the current process" } - { { $link +closed+ } " - standard output is closed" } - { "a path name - standard output is written to the given file, which is overwritten if it already exists" } - { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" } - } -} ; - -HELP: +stderr+ -{ $description "Launch descriptor key. Must equal one of the following:" - { $list - { { $link f } " - standard error is inherited from the current process" } - { { $link +inherit+ } " - same as above" } - { { $link +stdout+ } " - standard error is merged with standard output" } - { { $link +closed+ } " - standard error is closed" } - { "a path name - standard error is written to the given file, which is overwritten if it already exists" } - { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" } - } +"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:" +{ $list + { { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link } " pipe" } + { { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" } + { { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" } + { "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" } + { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" } } ; HELP: +closed+ -{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; +{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ; HELP: +inherit+ -{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; +{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ; + +HELP: +stdout+ +{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ; HELP: +prepend-environment+ -{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." +{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "." +$nl +"If this value is set, the child process environment consists of the value of the " { $snippet "environment" } " slot together with the current environment, with entries from the current environment taking precedence." $nl "This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ; HELP: +replace-environment+ -{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key." +{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "." +$nl +"The child process environment consists of the value of the " { $snippet "environment" } " slot." $nl "This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ; HELP: +append-environment+ -{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence." +{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "." +$nl +"The child process environment consists of the current environment together with the value of the " { $snippet "environment" } " key, with entries from the " { $snippet "environment" } " key taking precedence." $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; -HELP: +timeout+ -{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; - -HELP: default-descriptor -{ $description "Association storing default values for launch descriptor keys." } ; - -HELP: with-descriptor -{ $values { "desc" "a launch descriptor" } { "quot" quotation } } -{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ; +ARTICLE: "io.launcher.timeouts" "Process run-time timeouts" +{ $description "The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." } ; HELP: get-environment -{ $values { "env" "an association" } } -{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ; +{ $values { "process" process } { "env" "an association" } } +{ $description "Combines the current environment with the value of the " { $snippet "environment" } " slot of the " { $link process } " using the " { $snippet "environment-mode" } " slot." } ; HELP: current-process-handle { $values { "handle" "a process handle" } } @@ -110,20 +79,16 @@ HELP: run-process* { $contract "Launches a process using the launch descriptor." } { $notes "User code should call " { $link run-process } " instead." } ; -HELP: >descriptor -{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } } -{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ; - HELP: run-process { $values { "desc" "a launch descriptor" } { "process" process } } -{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." } +{ $description "Launches a process. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." } { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; HELP: run-detached { $values { "desc" "a launch descriptor" } { "process" process } } -{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." } +{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." } { $notes - "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set." + "This word is functionally identical to passing a " { $link process } " to " { $link run-process } " having the " { $snippet "detached" } " slot set." $nl "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; @@ -147,11 +112,11 @@ HELP: kill-process* { $notes "User code should call " { $link kill-process } " intead." } ; HELP: process -{ $class-description "A class representing an active or finished process." -$nl -"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances." -$nl -"Processes can be passed to " { $link wait-for-process } "." } ; +{ $class-description "A class representing a process. Instances are created by calling " { $link } "." } ; + +HELP: +{ $values { "process" process } } +{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ; HELP: process-stream { $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; @@ -161,8 +126,7 @@ HELP: { "desc" "a launch descriptor" } { "encoding" "an encoding descriptor" } { "stream" "a bidirectional stream" } } -{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } -{ $notes "Closing the stream will block until the process exits." } ; +{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ; HELP: with-process-stream { $values @@ -176,41 +140,40 @@ HELP: wait-for-process { $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ; ARTICLE: "io.launcher.descriptors" "Launch descriptors" -"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:" -{ $list - { "strings are wrapped in an assoc with a single " { $link +command+ } " key" } - { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" } - { "associations can be passed in, which allows finer control over launch parameters" } -} -"The associations can contain the following keys:" -{ $subsection +command+ } -{ $subsection +arguments+ } -{ $subsection +detached+ } -{ $subsection +environment+ } -{ $subsection +environment-mode+ } -{ $subsection +timeout+ } -{ $subsection +stdin+ } -{ $subsection +stdout+ } -{ $subsection +stderr+ } ; +"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "." +$nl +"Strings and string arrays are wrapped in a new empty " { $link process } " with the " { $snippet "command" } " slot set. This covers basic use-cases where no launch parameters need to be set." +$nl +"A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ; -ARTICLE: "io.launcher" "Launching OS processes" -"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." -{ $subsection "io.launcher.descriptors" } -"The following words are used to launch processes:" +ARTICLE: "io.launcher.lifecycle" "The process lifecycle" +"A freshly instantiated " { $link process } " represents a set of launch parameters. Words for launching processes take a fresh process which has never been started before as input, and output a copy as output." +{ $link process-started? } +"The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running." +{ $link process-running? } +"It is possible to wait for a process to exit:" +{ $link wait-for-process } +"A running process can also be killed:" +{ $link kill-process } ; + +ARTICLE: "io.launcher.launch" "Launching processes" +"Launching processes:" { $subsection run-process } -{ $subsection run-detached } { $subsection try-process } -"Stopping processes:" -{ $subsection kill-process } -"Finding the current process handle:" -{ $subsection current-process-handle } "Redirecting standard input and output to a pipe:" { $subsection } -{ $subsection with-process-stream } -"A class representing an active or finished process:" -{ $subsection process } -"Waiting for a process to end, or getting the exit code of a finished process:" -{ $subsection wait-for-process } -"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ; +{ $subsection with-process-stream } ; + +ARTICLE: "io.launcher" "Operating system processes" +"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." +{ $subsection "io.launcher.descriptors" } +{ $subsection "io.launcher.launch" } +"Advanced topics:" +{ $subsection "io.launcher.lifecycle" } +{ $subsection "io.launcher.command" } +{ $subsection "io.launcher.detached" } +{ $subsection "io.launcher.environment" } +{ $subsection "io.launcher.redirection" } +{ $subsection "io.launcher.timeouts" } ; ABOUT: "io.launcher" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index ea5c58a3d3..08f5160a61 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -3,68 +3,71 @@ USING: io io.backend io.timeouts system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math io.encodings io.streams.duplex -io.nonblocking ; +io.nonblocking new-slots accessors ; IN: io.launcher + +TUPLE: process + +command +detached + +environment +environment-mode + +stdin +stdout +stderr + +timeout + +handle status +killed ; + +SYMBOL: +closed+ +SYMBOL: +inherit+ +SYMBOL: +stdout+ + +SYMBOL: +prepend-environment+ +SYMBOL: +replace-environment+ +SYMBOL: +append-environment+ + +: ( -- process ) + process construct-empty + H{ } clone >>environment + +append-environment+ >>environment-mode ; + +: process-started? ( process -- ? ) + dup handle>> swap status>> or ; + +: process-running? ( process -- ? ) + process-handle >boolean ; + ! Non-blocking process exit notification facility SYMBOL: processes [ H{ } clone processes set-global ] "io.launcher" add-init-hook -TUPLE: process handle status killed? timeout ; - HOOK: register-process io-backend ( process -- ) M: object register-process drop ; -: ( handle -- process ) - f f f process construct-boa +: process-started ( process handle -- ) + >>handle V{ } clone over processes get set-at - dup register-process ; + register-process ; M: process equal? 2drop f ; M: process hashcode* process-handle hashcode* ; -: process-running? ( process -- ? ) process-status not ; +: pass-environment? ( process -- ? ) + dup environment>> assoc-empty? not + swap environment-mode>> +replace-environment+ eq? or ; -SYMBOL: +command+ -SYMBOL: +arguments+ -SYMBOL: +detached+ -SYMBOL: +environment+ -SYMBOL: +environment-mode+ -SYMBOL: +stdin+ -SYMBOL: +stdout+ -SYMBOL: +stderr+ - -SYMBOL: +timeout+ - -SYMBOL: +prepend-environment+ -SYMBOL: +replace-environment+ -SYMBOL: +append-environment+ - -SYMBOL: +closed+ -SYMBOL: +inherit+ - -: default-descriptor - H{ - { +command+ f } - { +arguments+ f } - { +detached+ f } - { +environment+ H{ } } - { +environment-mode+ +append-environment+ } - } ; - -: with-descriptor ( desc quot -- ) - default-descriptor [ >r clone r> bind ] bind ; inline - -: pass-environment? ( -- ? ) - +environment+ get assoc-empty? not - +environment-mode+ get +replace-environment+ eq? or ; - -: get-environment ( -- env ) - +environment+ get - +environment-mode+ get { +: get-environment ( process -- env ) + dup environment>> + swap environment-mode>> { { +prepend-environment+ [ os-envs union ] } { +append-environment+ [ os-envs swap union ] } { +replace-environment+ [ ] } @@ -73,78 +76,81 @@ SYMBOL: +inherit+ : string-array? ( obj -- ? ) dup sequence? [ [ string? ] all? ] [ drop f ] if ; -: >descriptor ( desc -- desc ) - { - { [ dup string? ] [ +command+ associate ] } - { [ dup string-array? ] [ +arguments+ associate ] } - { [ dup assoc? ] [ >hashtable ] } - } cond ; +GENERIC: >process ( obj -- process ) + +M: process >process + dup process-started? [ + "Process has already been started once" throw + ] when + clone ; + +M: object >process swap >>command ; HOOK: current-process-handle io-backend ( -- handle ) -HOOK: run-process* io-backend ( desc -- handle ) +HOOK: run-process* io-backend ( process -- handle ) : wait-for-process ( process -- status ) [ - dup process-handle + dup handle>> [ dup [ processes get at push ] curry "process" suspend drop ] when - dup process-killed? - [ "Process was killed" throw ] [ process-status ] if + dup killed>> + [ "Process was killed" throw ] [ status>> ] if ] with-timeout ; -: run-process ( desc -- process ) - >descriptor - dup run-process* - +timeout+ pick at [ over set-timeout ] when* - +detached+ rot at [ dup wait-for-process drop ] unless ; - : run-detached ( desc -- process ) - >descriptor H{ { +detached+ t } } union run-process ; + >process + dup dup run-process* process-started + dup timeout>> [ over set-timeout ] when* ; + +: run-process ( desc -- process ) + run-detached + dup detached>> [ dup wait-for-process drop ] unless ; TUPLE: process-failed code ; : process-failed ( code -- * ) \ process-failed construct-boa throw ; -: try-process ( desc -- ) +: try-process ( command/process -- ) run-process wait-for-process dup zero? [ drop ] [ process-failed ] if ; HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) - t over set-process-killed? - process-handle [ kill-process* ] when* ; + t >>killed + handle>> [ kill-process* ] when* ; -M: process timeout process-timeout ; +M: process timeout timeout>> ; M: process set-timeout set-process-timeout ; M: process timed-out kill-process ; -HOOK: (process-stream) io-backend ( desc -- in out process ) +HOOK: (process-stream) io-backend ( process -- handle in out ) TUPLE: process-stream process ; : ( desc encoding -- stream ) - swap >descriptor - [ (process-stream) >r rot r> ] keep - +timeout+ swap at [ over set-timeout ] when* - { set-delegate set-process-stream-process } - process-stream construct ; + >r >process dup dup (process-stream) + >r >r process-started process-stream construct-boa + r> r> r> + over set-delegate ; : with-process-stream ( desc quot -- status ) swap [ swap with-stream ] keep - process-stream-process wait-for-process ; inline + process>> wait-for-process ; inline -: notify-exit ( status process -- ) - [ set-process-status ] keep +: notify-exit ( process status -- ) + >>status [ processes get delete-at* drop [ resume ] each ] keep - f swap set-process-handle ; + f >>handle + drop ; GENERIC: underlying-handle ( stream -- handle ) diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index c5dc964a7a..97b186edf3 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -54,7 +54,7 @@ M: kqueue-mx unregister-io-task ( task mx -- ) : kevent-proc-task ( pid -- ) dup wait-for-pid swap find-process - dup [ notify-exit ] [ 2drop ] if ; + dup [ swap notify-exit ] [ 2drop ] if ; : handle-kevent ( mx kevent -- ) dup kevent-ident swap kevent-filter { diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index c24d5c7c9e..aa54d3ec94 100644 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,6 +1,7 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces -continuations math io.encodings.ascii ; +continuations math io.encodings.ascii io.encodings.latin1 +accessors kernel sequences ; [ ] [ [ "launcher-test-1" temp-file delete-file ] ignore-errors @@ -20,10 +21,10 @@ continuations math io.encodings.ascii ; ] unit-test [ ] [ - [ - "echo Hello" +command+ set - "launcher-test-1" temp-file +stdout+ set - ] { } make-assoc try-process + + "echo Hello" >>command + "launcher-test-1" temp-file >>stdout + try-process ] unit-test [ "Hello\n" ] [ @@ -34,12 +35,12 @@ continuations math io.encodings.ascii ; ] unit-test [ "" ] [ - [ + "cat" "launcher-test-1" temp-file - 2array +arguments+ set - +inherit+ +stdout+ set - ] { } make-assoc ascii contents + 2array >>command + +inherit+ >>stdout + ascii contents ] unit-test [ ] [ @@ -47,11 +48,11 @@ continuations math io.encodings.ascii ; ] unit-test [ ] [ - [ - "cat" +command+ set - +closed+ +stdin+ set - "launcher-test-1" temp-file +stdout+ set - ] { } make-assoc try-process + + "cat" >>command + +closed+ >>stdin + "launcher-test-1" temp-file >>stdout + try-process ] unit-test [ "" ] [ @@ -64,10 +65,10 @@ continuations math io.encodings.ascii ; [ ] [ 2 [ "launcher-test-1" temp-file ascii [ - [ - +stdout+ set - "echo Hello" +command+ set - ] { } make-assoc try-process + + swap >>stdout + "echo Hello" >>command + try-process ] with-disposal ] times ] unit-test @@ -78,3 +79,19 @@ continuations math io.encodings.ascii ; 2array ascii contents ] unit-test + +[ t ] [ + + "env" >>command + { { "A" "B" } } >>environment + latin1 lines + "A=B" swap member? +] unit-test + +[ { "A=B" } ] [ + + "env" >>command + { { "A" "B" } } >>environment + +replace-environment+ >>environment-mode + latin1 lines +] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index e79ca43e33..7b4831a2c5 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,14 +4,14 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process strings threads unix -io.unix.launcher.parser io.encodings.latin1 ; +io.unix.launcher.parser io.encodings.latin1 accessors new-slots ; IN: io.unix.launcher ! Search unix first USE: unix -: get-arguments ( -- seq ) - +command+ get [ tokenize-command ] [ +arguments+ get ] if* ; +: get-arguments ( process -- seq ) + command>> dup string? [ tokenize-command ] when ; : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; @@ -44,28 +44,27 @@ USE: unix : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ; -: setup-redirection ( -- ) - +stdin+ get ?closed read-flags 0 redirect - +stdout+ get ?closed write-flags 1 redirect - +stderr+ get dup +stdout+ eq? +: setup-redirection ( process -- process ) + dup stdin>> ?closed read-flags 0 redirect + dup stdout>> ?closed write-flags 1 redirect + dup stderr>> dup +stdout+ eq? [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ; -: spawn-process ( -- ) +: spawn-process ( process -- * ) [ setup-redirection - get-arguments - pass-environment? - [ get-environment assoc>env exec-args-with-env ] - [ exec-args-with-path ] if - io-error - ] [ error. :c flush ] recover 1 exit ; + dup pass-environment? [ + dup get-environment set-os-envs + ] when + + get-arguments exec-args-with-path + (io-error) + ] [ 255 exit ] recover ; M: unix-io current-process-handle ( -- handle ) getpid ; -M: unix-io run-process* ( desc -- pid ) - [ - [ spawn-process ] [ ] with-fork - ] with-descriptor ; +M: unix-io run-process* ( process -- pid ) + [ spawn-process ] curry [ ] with-fork ; M: unix-io kill-process* ( pid -- ) SIGTERM kill io-error ; @@ -78,21 +77,15 @@ M: unix-io kill-process* ( pid -- ) 2dup first close second close >r first 0 dup2 drop r> second 1 dup2 drop ; -: spawn-process-stream ( -- in out pid ) - open-pipe open-pipe [ - setup-stdio-pipe - spawn-process - ] [ - -rot 2dup second close first close - ] with-fork first swap second rot ; - M: unix-io (process-stream) - [ - spawn-process-stream >r r> - ] with-descriptor ; + >r open-pipe open-pipe r> + [ >r setup-stdio-pipe r> spawn-process ] curry + [ -rot 2dup second close first close ] + with-fork + first swap second ; : find-process ( handle -- process ) - processes get swap [ nip swap process-handle = ] curry + processes get swap [ nip swap handle>> = ] curry assoc-find 2drop ; ! Inefficient process wait polling, used on Linux and Solaris. @@ -103,7 +96,7 @@ M: unix-io (process-stream) 2drop t ] [ find-process dup [ - >r *int WEXITSTATUS r> notify-exit f + swap *int WEXITSTATUS notify-exit f ] [ 2drop f ] if diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 708dc1dc38..9b6a410a80 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -134,7 +134,7 @@ M: windows-io kill-process* ( handle -- ) : process-exited ( process -- ) dup process-handle exit-code over process-handle dispose-process - swap notify-exit ; + notify-exit ; : wait-for-processes ( processes -- ? ) keys dup diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index bcdc0f806f..6e8a231b81 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -6,7 +6,7 @@ continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend quotations io.launcher words.private tools.deploy.config -bootstrap.image io.encodings.utf8 ; +bootstrap.image io.encodings.utf8 accessors ; IN: tools.deploy.backend : (copy-lines) ( stream -- ) @@ -17,11 +17,11 @@ IN: tools.deploy.backend [ (copy-lines) ] with-disposal ; : run-with-output ( arguments -- ) - [ - +arguments+ set - +stdout+ +stderr+ set - ] H{ } make-assoc utf8 - dup duplex-stream-out dispose + + swap >>command + +stdout+ >>stderr + +closed+ >>stdin + utf8 dup copy-lines process-stream-process wait-for-process zero? [ "Deployment failed" throw diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 647b02baa5..1e003dcf69 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -system math generator.fixup io.encodings.ascii ; +system math generator.fixup io.encodings.ascii accessors ; IN: tools.disassembler : in-file "gdb-in.txt" temp-file ; @@ -23,11 +23,11 @@ M: pair make-disassemble-cmd ] with-file-writer ; : run-gdb ( -- lines ) - [ - +closed+ +stdin+ set - out-file +stdout+ set - [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set - ] { } make-assoc try-process + + +closed+ >>stdin + out-file >>stdout + [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command + try-process out-file ascii file-lines ; : tabs>spaces ( str -- str' ) diff --git a/vm/os-unix.c b/vm/os-unix.c index a84b29c2e2..37dceb0d37 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -117,6 +117,29 @@ DEFINE_PRIMITIVE(os_envs) dpush(result); } +DEFINE_PRIMITIVE(set_os_envs) +{ + F_ARRAY *array = untag_array(dpop()); + CELL size = array_capacity(array); + + /* Memory leak */ + char **env = calloc(size + 1,sizeof(CELL)); + + CELL i; + for(i = 0; i < size; i++) + { + F_STRING *string = untag_string(array_nth(array,i)); + CELL length = to_fixnum(string->length); + + char *chars = malloc(length + 1); + char_string_to_memory(string,chars); + chars[length] = '\0'; + env[i] = chars; + } + + environ = env; +} + F_SEGMENT *alloc_segment(CELL size) { int pagesize = getpagesize(); diff --git a/vm/os-windows.c b/vm/os-windows.c index e28debd449..f9b80ea32a 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -233,3 +233,8 @@ void sleep_millis(DWORD msec) { Sleep(msec); } + +DECLARE_PRIMITIVE(set_os_envs) +{ + not_implemented_error(); +} diff --git a/vm/primitives.c b/vm/primitives.c index 1b29dc65b7..d1d956dca0 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -186,6 +186,7 @@ void *primitives[] = { primitive_set_innermost_stack_frame_quot, primitive_call_clear, primitive_os_envs, + primitive_set_os_envs, primitive_resize_byte_array, primitive_resize_bit_array, primitive_resize_float_array, diff --git a/vm/run.h b/vm/run.h index f9b8057069..216a00b27d 100755 --- a/vm/run.h +++ b/vm/run.h @@ -249,6 +249,7 @@ DECLARE_PRIMITIVE(setenv); DECLARE_PRIMITIVE(exit); DECLARE_PRIMITIVE(os_env); DECLARE_PRIMITIVE(os_envs); +DECLARE_PRIMITIVE(set_os_envs); DECLARE_PRIMITIVE(eq); DECLARE_PRIMITIVE(millis); DECLARE_PRIMITIVE(sleep); From c9c7548ffd983df67e506bf4d347a6d53ff8faa0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 20:45:56 -0600 Subject: [PATCH 34/49] Updating windows launcher for new-slots --- extra/io/windows/launcher/launcher.factor | 90 +++++++++++------------ 1 file changed, 43 insertions(+), 47 deletions(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 708dc1dc38..4af16ec375 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init strings combinators -io.backend ; +io.backend new-slots accessors ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -22,30 +22,25 @@ TUPLE: CreateProcess-args stdout-pipe stdin-pipe ; : default-CreateProcess-args ( -- obj ) - 0 + CreateProcess-args construct-empty + 0 >>dwCreateFlags "STARTUPINFO" - "STARTUPINFO" heap-size over set-STARTUPINFO-cb - "PROCESS_INFORMATION" - TRUE - { - set-CreateProcess-args-dwCreateFlags - set-CreateProcess-args-lpStartupInfo - set-CreateProcess-args-lpProcessInformation - set-CreateProcess-args-bInheritHandles - } \ CreateProcess-args construct ; + "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo + "PROCESS_INFORMATION" >>lpProcessInformation + TRUE >>bInheritHandles ; : call-CreateProcess ( CreateProcess-args -- ) { - CreateProcess-args-lpApplicationName - CreateProcess-args-lpCommandLine - CreateProcess-args-lpProcessAttributes - CreateProcess-args-lpThreadAttributes - CreateProcess-args-bInheritHandles - CreateProcess-args-dwCreateFlags - CreateProcess-args-lpEnvironment - CreateProcess-args-lpCurrentDirectory - CreateProcess-args-lpStartupInfo - CreateProcess-args-lpProcessInformation + lpApplicationName>> + lpCommandLine>> + lpProcessAttributes>> + lpThreadAttributes>> + bInheritHandles>> + dwCreateFlags>> + lpEnvironment>> + lpCurrentDirectory>> + lpStartupInfo>> + lpProcessInformation>> } get-slots CreateProcess win32-error=0/f ; : escape-argument ( str -- newstr ) @@ -54,54 +49,55 @@ TUPLE: CreateProcess-args : join-arguments ( args -- cmd-line ) [ escape-argument ] map " " join ; -: app-name/cmd-line ( -- app-name cmd-line ) - +command+ get [ +: app-name/cmd-line ( process -- app-name cmd-line ) + command>> dup string? [ " " split1 ] [ - +arguments+ get unclip swap join-arguments - ] if* ; + unclip swap join-arguments + ] if ; -: cmd-line ( -- cmd-line ) - +command+ get [ +arguments+ get join-arguments ] unless* ; +: cmd-line ( process -- cmd-line ) + command>> dup string? [ join-arguments ] unless ; -: fill-lpApplicationName - app-name/cmd-line - pick set-CreateProcess-args-lpCommandLine - over set-CreateProcess-args-lpApplicationName ; +: fill-lpApplicationName ( process args -- process args ) + over app-name/cmd-line + >r >>lpApplicationName + r> >>lpCommandLine ; -: fill-lpCommandLine - cmd-line over set-CreateProcess-args-lpCommandLine ; +: fill-lpCommandLine ( process args -- process args ) + over cmd-line >>lpCommandLine ; -: fill-dwCreateFlags +: fill-dwCreateFlags ( process args -- process args ) 0 - pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when - +detached+ get winnt? and [ DETACHED_PROCESS bitor ] when - over set-CreateProcess-args-dwCreateFlags ; + over pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when + over detached>> winnt? and [ DETACHED_PROCESS bitor ] when + >>dwCreateFlags ; -: fill-lpEnvironment - pass-environment? [ +: fill-lpEnvironment ( process args -- process args ) + over pass-environment? [ [ - get-environment + over get-environment [ "=" swap 3append string>u16-alien % ] assoc-each "\0" % ] { } make >c-ushort-array - over set-CreateProcess-args-lpEnvironment + >>lpEnvironment ] when ; -: fill-startup-info - dup CreateProcess-args-lpStartupInfo +: fill-startup-info ( process args -- process args ) + dup lpStartupInfo>> STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ; -HOOK: fill-redirection io-backend ( args -- args ) +HOOK: fill-redirection io-backend ( process args -- process args ) M: windows-ce-io fill-redirection ; -: make-CreateProcess-args ( -- args ) +: make-CreateProcess-args ( process -- args ) default-CreateProcess-args wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if fill-dwCreateFlags fill-lpEnvironment - fill-startup-info ; + fill-startup-info + nip ; M: windows-io current-process-handle ( -- handle ) GetCurrentProcessId ; @@ -112,7 +108,7 @@ M: windows-io run-process* ( desc -- handle ) make-CreateProcess-args fill-redirection dup call-CreateProcess - CreateProcess-args-lpProcessInformation + CreateProcess-args-lpProcessInformation ] with-descriptor ] with-destructors ; From 755003df088889288f225e90899402572c8dfd31 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 01:55:29 -0600 Subject: [PATCH 35/49] Launcher now uses new-slots; fix Windows environment passing bug --- extra/io/launcher/authors.txt | 1 + extra/io/launcher/launcher-docs.factor | 54 +++++++- extra/io/windows/launcher/launcher.factor | 27 ++-- .../windows/nt/launcher/launcher-tests.factor | 131 ++++++++++++++++++ extra/io/windows/nt/launcher/launcher.factor | 82 +++++------ extra/io/windows/nt/launcher/test/env.factor | 3 + .../io/windows/nt/launcher/test/stderr.factor | 5 + extra/io/windows/nt/pipes/pipes.factor | 14 +- 8 files changed, 245 insertions(+), 72 deletions(-) create mode 100755 extra/io/windows/nt/launcher/launcher-tests.factor create mode 100755 extra/io/windows/nt/launcher/test/env.factor create mode 100755 extra/io/windows/nt/launcher/test/stderr.factor diff --git a/extra/io/launcher/authors.txt b/extra/io/launcher/authors.txt index 7c1b2f2279..5674120196 100644 --- a/extra/io/launcher/authors.txt +++ b/extra/io/launcher/authors.txt @@ -1 +1,2 @@ Doug Coleman +Slava Pestov diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 5f72917e66..01da3bf64f 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -64,7 +64,7 @@ $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; ARTICLE: "io.launcher.timeouts" "Process run-time timeouts" -{ $description "The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." } ; +"The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." ; HELP: get-environment { $values { "process" process } { "env" "an association" } } @@ -147,14 +147,17 @@ $nl "A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ; ARTICLE: "io.launcher.lifecycle" "The process lifecycle" -"A freshly instantiated " { $link process } " represents a set of launch parameters. Words for launching processes take a fresh process which has never been started before as input, and output a copy as output." -{ $link process-started? } +"A freshly instantiated " { $link process } " represents a set of launch parameters." +{ $subsection process } +{ $subsection } +"Words for launching processes take a fresh process which has never been started before as input, and output a copy as output." +{ $subsection process-started? } "The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running." -{ $link process-running? } +{ $subsection process-running? } "It is possible to wait for a process to exit:" -{ $link wait-for-process } +{ $subsection wait-for-process } "A running process can also be killed:" -{ $link kill-process } ; +{ $subsection kill-process } ; ARTICLE: "io.launcher.launch" "Launching processes" "Launching processes:" @@ -164,8 +167,47 @@ ARTICLE: "io.launcher.launch" "Launching processes" { $subsection } { $subsection with-process-stream } ; +ARTICLE: "io.launcher.examples" "Launcher examples" +"Starting a command and waiting for it to finish:" +{ $code + "\"ls /etc\" run-process" +} +"Starting a program in the background:" +{ $code + "{ \"emacs\" \"foo.txt\" } run-detached" +} +"Running a command, throwing an exception if it exits unsuccessfully:" +{ $code + "\"make clean all\" try-process" +} +"Running a command, throwing an exception if it exits unsuccessfully or if it takes too long to run:" +{ $code + "" + " \"make test\" >>command" + " 5 minutes >>timeout" + "try-process" +} +"Running a command, throwing an exception if it exits unsuccessfully, and redirecting output and error messages to a log file:" +{ $code + "" + " \"make clean all\" >>command" + " \"log.txt\" >>stdout" + " +stdout+ >>stderr" + "try-process" +} +"Running a command, appending error messages to a log file, and reading the output for further processing:" +{ $code + "\"log.txt\" [" + " " + " swap >>stderr" + " \"report\" >>command" + " ascii lines sort reverse [ print ] each" + "] with-disposal" +} ; + ARTICLE: "io.launcher" "Operating system processes" "The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." +{ $subsection "io.launcher.examples" } { $subsection "io.launcher.descriptors" } { $subsection "io.launcher.launch" } "Advanced topics:" diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 0fa8442ea0..b09d867e10 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -69,27 +69,26 @@ TUPLE: CreateProcess-args : fill-dwCreateFlags ( process args -- process args ) 0 - over pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when - over detached>> winnt? and [ DETACHED_PROCESS bitor ] when + pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when + pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when >>dwCreateFlags ; : fill-lpEnvironment ( process args -- process args ) over pass-environment? [ [ over get-environment - [ "=" swap 3append string>u16-alien % ] assoc-each + [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] { } make >c-ushort-array + ] "" make >c-ushort-array >>lpEnvironment ] when ; : fill-startup-info ( process args -- process args ) - dup lpStartupInfo>> - STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ; + STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ; -HOOK: fill-redirection io-backend ( process args -- process args ) +HOOK: fill-redirection io-backend ( process args -- ) -M: windows-ce-io fill-redirection ; +M: windows-ce-io fill-redirection 2drop ; : make-CreateProcess-args ( process -- args ) default-CreateProcess-args @@ -102,14 +101,12 @@ M: windows-ce-io fill-redirection ; M: windows-io current-process-handle ( -- handle ) GetCurrentProcessId ; -M: windows-io run-process* ( desc -- handle ) +M: windows-io run-process* ( process -- handle ) [ - [ - make-CreateProcess-args - fill-redirection - dup call-CreateProcess - CreateProcess-args-lpProcessInformation - ] with-descriptor + dup make-CreateProcess-args + tuck fill-redirection + dup call-CreateProcess + lpProcessInformation>> ] with-destructors ; M: windows-io kill-process* ( handle -- ) diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor new file mode 100755 index 0000000000..fac6471b8c --- /dev/null +++ b/extra/io/windows/nt/launcher/launcher-tests.factor @@ -0,0 +1,131 @@ +IN: io.windows.launcher.nt.tests +USING: io.launcher tools.test calendar accessors +namespaces kernel system arrays io io.files io.encodings.ascii +sequences parser assocs hashtables ; + +[ ] [ + + "notepad" >>command + 1/2 seconds >>timeout + "notepad" set +] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ f ] [ "notepad" get process-started? ] unit-test + +[ ] [ "notepad" [ run-detached ] change ] unit-test + +[ "notepad" get wait-for-process ] must-fail + +[ t ] [ "notepad" get killed>> ] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ ] [ + + vm "-quiet" "-run=hello-world" 3array >>command + "out.txt" temp-file >>stdout + try-process +] unit-test + +[ "Hello world" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + + vm "-run=listener" 2array >>command + +closed+ >>stdin + try-process +] unit-test + +[ ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + "err.txt" temp-file >>stderr + try-process + ] with-directory +] unit-test + +[ "output" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "error" ] [ + "err.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + +stdout+ >>stderr + try-process + ] with-directory +] unit-test + +[ "outputerror" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "output" ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii lines first + ] with-directory +] unit-test + +[ "error" ] [ + "err2.txt" temp-file ascii file-lines first +] unit-test + +[ t ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ t ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ "B" ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii contents + ] with-directory eval + + "A" swap at +] unit-test + +[ f ] [ + "extra/io/windows/nt/launcher/test" resource-path [ + + vm "-script" "env.factor" 3array >>command + { { "HOME" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii contents + ] with-directory eval + + "HOME" swap at "XXX" = +] unit-test diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 500a2b0d1f..c342b2ee9a 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -5,7 +5,7 @@ io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings io.windows.launcher io.windows.nt.pipes io.backend -combinators shuffle ; +combinators shuffle accessors locals ; IN: io.windows.nt.launcher : duplicate-handle ( handle -- handle' ) @@ -31,13 +31,12 @@ IN: io.windows.nt.launcher : redirect-closed ( default obj access-mode create-mode -- handle ) drop 2nip null-pipe ; -: redirect-file ( default path access-mode create-mode -- handle ) - >r >r >r drop r> - normalize-pathname - r> ! access-mode +:: redirect-file ( default path access-mode create-mode -- handle ) + path normalize-pathname + access-mode share-mode security-attributes-inherit - r> ! create-mode + create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file CreateFile dup invalid-handle? dup close-later ; @@ -60,24 +59,25 @@ IN: io.windows.nt.launcher } cond ; : default-stdout ( args -- handle ) - CreateProcess-args-stdout-pipe dup [ pipe-out ] when ; + stdout-pipe>> dup [ pipe-out ] when ; -: redirect-stdout ( args -- handle ) +: redirect-stdout ( process args -- handle ) default-stdout - +stdout+ get + swap stdout>> GENERIC_WRITE CREATE_ALWAYS redirect STD_OUTPUT_HANDLE GetStdHandle or ; -: redirect-stderr ( args -- handle ) - +stderr+ get +stdout+ eq? [ - CreateProcess-args-lpStartupInfo +: redirect-stderr ( process args -- handle ) + over stderr>> +stdout+ eq? [ + lpStartupInfo>> STARTUPINFO-hStdOutput + nip ] [ drop f - +stderr+ get + swap stderr>> GENERIC_WRITE CREATE_ALWAYS redirect @@ -85,11 +85,11 @@ IN: io.windows.nt.launcher ] if ; : default-stdin ( args -- handle ) - CreateProcess-args-stdin-pipe dup [ pipe-in ] when ; + stdin-pipe>> dup [ pipe-in ] when ; -: redirect-stdin ( args -- handle ) +: redirect-stdin ( process args -- handle ) default-stdin - +stdin+ get + swap stdin>> GENERIC_READ OPEN_EXISTING redirect @@ -97,48 +97,42 @@ IN: io.windows.nt.launcher : add-pipe-dtors ( pipe -- ) dup - pipe-in close-later - pipe-out close-later ; + in>> close-later + out>> close-later ; -: fill-stdout-pipe +: fill-stdout-pipe ( args -- args ) dup add-pipe-dtors dup pipe-in f set-inherit - over set-CreateProcess-args-stdout-pipe ; + >>stdout-pipe ; -: fill-stdin-pipe +: fill-stdin-pipe ( args -- args ) dup add-pipe-dtors dup pipe-out f set-inherit - over set-CreateProcess-args-stdin-pipe ; + >>stdin-pipe ; -M: windows-nt-io fill-redirection - dup CreateProcess-args-lpStartupInfo - over redirect-stdout over set-STARTUPINFO-hStdOutput - over redirect-stderr over set-STARTUPINFO-hStdError - over redirect-stdin over set-STARTUPINFO-hStdInput - drop ; +M: windows-nt-io fill-redirection ( process args -- ) + [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput + [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError + [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput + 2drop ; M: windows-nt-io (process-stream) [ - [ - make-CreateProcess-args + dup make-CreateProcess-args - fill-stdout-pipe - fill-stdin-pipe + fill-stdout-pipe + fill-stdin-pipe - fill-redirection + tuck fill-redirection - dup call-CreateProcess + dup call-CreateProcess - dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop - dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop + dup stdin-pipe>> pipe-in CloseHandle drop + dup stdout-pipe>> pipe-out CloseHandle drop - dup CreateProcess-args-stdout-pipe pipe-in - over CreateProcess-args-stdin-pipe pipe-out - - [ f ] 2apply - - rot CreateProcess-args-lpProcessInformation - ] with-destructors - ] with-descriptor ; + dup lpProcessInformation>> + over stdout-pipe>> in>> f + rot stdin-pipe>> out>> f + ] with-destructors ; diff --git a/extra/io/windows/nt/launcher/test/env.factor b/extra/io/windows/nt/launcher/test/env.factor new file mode 100755 index 0000000000..a0015f7ea2 --- /dev/null +++ b/extra/io/windows/nt/launcher/test/env.factor @@ -0,0 +1,3 @@ +USE: system +USE: prettyprint +os-envs . diff --git a/extra/io/windows/nt/launcher/test/stderr.factor b/extra/io/windows/nt/launcher/test/stderr.factor new file mode 100755 index 0000000000..0b97387cf7 --- /dev/null +++ b/extra/io/windows/nt/launcher/test/stderr.factor @@ -0,0 +1,5 @@ +USE: io +USE: namespaces + +"output" write flush +"error" stderr get stream-write stderr get stream-flush diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 9591063609..eb6dae2a0a 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays destructors io io.windows libc windows.types math windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random -combinators ; +combinators new-slots accessors ; IN: io.windows.nt.pipes ! This code is based on @@ -42,8 +42,8 @@ TUPLE: pipe in out ; : close-pipe ( pipe -- ) dup - pipe-in CloseHandle drop - pipe-out CloseHandle drop ; + in>> CloseHandle drop + out>> CloseHandle drop ; : ( name -- pipe ) PIPE_ACCESS_INBOUND GENERIC_WRITE ; @@ -70,13 +70,13 @@ TUPLE: pipe in out ; ! /dev/null simulation : null-input ( -- pipe ) - dup pipe-out CloseHandle drop - pipe-in ; + dup out>> CloseHandle drop + in>> ; : null-output ( -- pipe ) - dup pipe-in CloseHandle drop - pipe-out ; + dup in>> CloseHandle drop + out>> ; : null-pipe ( mode -- pipe ) { From 047a6c27a1f825a5a882f0305a07d728ecf161bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 01:55:38 -0600 Subject: [PATCH 36/49] smtp now uses new-slots --- extra/smtp/smtp-tests.factor | 72 +++++++++++----------------- extra/smtp/smtp.factor | 92 +++++++++++++++++------------------- 2 files changed, 70 insertions(+), 94 deletions(-) diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 32b2f3be14..76ceaceea4 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,5 +1,6 @@ USING: smtp tools.test io.streams.string threads -smtp.server kernel sequences namespaces logging ; +smtp.server kernel sequences namespaces logging accessors +assocs sorting ; IN: smtp.tests { 0 0 } [ [ ] with-smtp-connection ] must-infer-as @@ -12,7 +13,7 @@ IN: smtp.tests [ { "hello" "." "world" } validate-message ] must-fail [ "hello\r\nworld\r\n.\r\n" ] [ - { "hello" "world" } [ send-body ] with-string-writer + "hello\nworld" [ send-body ] with-string-writer ] unit-test [ "500 syntax error" check-response ] must-fail @@ -38,46 +39,27 @@ IN: smtp.tests ] must-fail [ - V{ - { "To" "Slava , Ed " } + { { "From" "Doug " } { "Subject" "Factor rules" } + { "To" "Slava , Ed " } } { "slava@factorcode.org" "dharmatech@factorcode.org" } "erg@factorcode.org" ] [ - "Factor rules" - { - "Slava " - "Ed " - } - "Doug " - simple-headers >r >r 2 head* r> r> -] unit-test - -[ - { - "To: Slava , Ed " - "From: Doug " - "Subject: Factor rules" - f - f - "" - "Hi guys" - "Bye guys" - } - { "slava@factorcode.org" "dharmatech@factorcode.org" } - "erg@factorcode.org" -] [ - "Hi guys\nBye guys" - "Factor rules" - { - "Slava " - "Ed " - } - "Doug " - prepare-simple-message - >r >r f 3 pick set-nth f 4 pick set-nth r> r> + + "Factor rules" >>subject + { + "Slava " + "Ed " + } >>to + "Doug " >>from + prepare + dup headers>> >alist sort-keys [ + drop { "Date" "Message-Id" } member? not + ] assoc-subset + over to>> + rot from>> ] unit-test [ ] [ [ 4321 smtp-server ] in-thread ] unit-test @@ -87,14 +69,14 @@ IN: smtp.tests "localhost" smtp-host set 4321 smtp-port set - "Hi guys\nBye guys" - "Factor rules" - { - "Slava " - "Ed " - } - "Doug " - - send-simple-message + + "Hi guys\nBye guys" >>body + "Factor rules" >>subject + { + "Slava " + "Ed " + } >>to + "Doug " >>from + send ] with-scope ] unit-test diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index bbec129ef6..b23d5e3798 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,8 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar io.encodings.ascii calendar.format ; - +math.parser random system calendar io.encodings.ascii +calendar.format new-slots accessors ; IN: smtp SYMBOL: smtp-domain @@ -49,6 +49,7 @@ SYMBOL: esmtp t esmtp set-global "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; : send-body ( body -- ) + string-lines validate-message [ write crlf ] each "." write crlf ; @@ -89,28 +90,36 @@ LOG: smtp-response DEBUG : get-ok ( -- ) flush receive-response check-response ; -: send-raw-message ( body to from -- ) - [ - helo get-ok - mail-from get-ok - [ rcpt-to get-ok ] each - data get-ok - send-body get-ok - quit get-ok - ] with-smtp-connection ; - : validate-header ( string -- string' ) dup [ "\r\n" member? ] contains? [ "Invalid header string: " swap append throw ] when ; -: prepare-header ( key value -- ) +: write-header ( key value -- ) swap - validate-header % - ": " % - validate-header % ; + validate-header write + ": " write + validate-header write + crlf ; -: prepare-headers ( assoc -- ) - [ [ prepare-header ] "" make , ] assoc-each ; +: write-headers ( assoc -- ) + [ write-header ] assoc-each ; + +TUPLE: email from to subject headers body ; + +M: email clone + (clone) [ clone ] change-headers ; + +: (send) ( email -- ) + [ + helo get-ok + dup from>> mail-from get-ok + dup to>> [ rcpt-to get-ok ] each + data get-ok + dup headers>> write-headers + crlf + body>> send-body get-ok + quit get-ok + ] with-smtp-connection ; : extract-email ( recepient -- email ) #! This could be much smarter. @@ -127,30 +136,25 @@ LOG: smtp-response DEBUG ">" % ] "" make ; -: simple-headers ( subject to from -- headers to from ) - [ - >r dup ", " join "To" set [ extract-email ] map r> - dup "From" set extract-email - rot "Subject" set - now timestamp>rfc822-string "Date" set - message-id "Message-Id" set - ] { } make-assoc -rot ; +: set-header ( email value key -- email ) + pick headers>> set-at ; -: prepare-message ( body headers -- body' ) - [ - prepare-headers - "" , - dup string? [ string-lines ] when % - ] { } make ; +: prepare ( email -- email ) + clone + dup from>> "From" set-header + [ extract-email ] change-from + dup to>> ", " join "To" set-header + [ [ extract-email ] map ] change-to + dup subject>> "Subject" set-header + now timestamp>rfc822-string "Date" set-header + message-id "Message-Id" set-header ; -: prepare-simple-message ( body subject to from -- body' to from ) - simple-headers >r >r prepare-message r> r> ; +: ( -- email ) + email construct-empty + H{ } clone >>headers ; -: send-message ( body headers to from -- ) - >r >r prepare-message r> r> send-raw-message ; - -: send-simple-message ( body subject to from -- ) - prepare-simple-message send-raw-message ; +: send ( email -- ) + prepare (send) ; ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about ! CRAM MD5, and the old code didn't work properly either, so here @@ -171,13 +175,3 @@ LOG: smtp-response DEBUG ! (cram-md5-auth) "\r\n" append get-ok ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: new-slots - -TUPLE: email from to subject body ; - -: ( -- email ) email construct-empty ; - -: send ( email -- ) - { email-body email-subject email-to email-from } get-slots - send-simple-message ; From 997dbed4efae6420936fb7a4a7dd0c4081024e31 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 01:55:45 -0600 Subject: [PATCH 37/49] Document fry --- extra/fry/fry-docs.factor | 108 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 108 insertions(+) create mode 100755 extra/fry/fry-docs.factor diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor new file mode 100755 index 0000000000..31b544d488 --- /dev/null +++ b/extra/fry/fry-docs.factor @@ -0,0 +1,108 @@ +USING: help.markup help.syntax quotations kernel ; +IN: fry + +HELP: , +{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ; + +HELP: @ +{ $description "Fry specifier. Splices a quotation into the fried quotation." } ; + +HELP: _ +{ $description "Fry specifier. Shifts all fry specifiers to the left down by one stack position." } ; + +HELP: fry +{ $values { "quot" quotation } { "quot'" quotation } } +{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." } +{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:" + { $code "[ X ] fry call" "'[ X ]" } +} ; + +HELP: '[ +{ $syntax "code... ]" } +{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ; + +ARTICLE: "fry.examples" "Examples of fried quotations" +"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples." +$nl +"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":" +{ $code "{ 10 20 30 } '[ . ] each" } +"Occurrences of " { $link , } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:" +{ $code + "{ 10 20 30 } 5 '[ , + ] map" + "{ 10 20 30 } 5 [ + ] curry map" + "{ 10 20 30 } [ 5 + ] map" +} +"Occurrences of " { $link , } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:" +{ $code + "{ 10 20 30 } 5 '[ 3 , / ] map" + "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map" + "{ 10 20 30 } [ 3 5 / ] map" +} +"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:" +{ $code + "{ 10 20 30 } [ sq ] '[ @ . ] map" + "{ 10 20 30 } [ sq ] [ . ] compose map" + "{ 10 20 30 } [ sq . ] map" +} +"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:" +{ $code + "{ 8 13 14 27 } [ even? ] 5 [ @ dup , ? ] map" + "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" + "{ 8 13 14 27 } [ even? dup 5 ? ] map" +} +"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":" +{ $code + "{ 10 20 30 } 1 '[ , _ / ] map" + "{ 10 20 30 } 1 [ swap / ] curry map" + "{ 10 20 30 } [ 1 swap / ] map" +} +"For any quotation body " { $snippet "X" } ", the following two are equivalent:" +{ $code + "[ >r X r> ]" + "[ X _ ]" +} +"Here are some built-in combinators rewritten in terms of fried quotations:" +{ $table + { { $link literalize } { $snippet ": literalize '[ , ] ;" } } + { { $link slip } { $snippet ": slip '[ @ , ] call ;" } } + { { $link dip } { $snippet ": dip '[ @ _ ] call ;" } } + { { $link curry } { $snippet ": curry '[ , @ ] ;" } } + { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } } + { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } + { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } } +} ; + +ARTICLE: "fry.philosophy" "Fried quotation philosophy" +"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "." +$nl +"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" +{ $code + "'[ 3 , + 4 , / ]" + "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]" +} +"The " { $link _ } " fry specifier has no direct analogue in " { $vocab-link "locals" } ", however closure conversion together with the " { $link dip } " combinator achieve the same effect:" +{ $code + "'[ , 2 + , * _ / ]" + "[let | a [ ] b [ ] | [ [ a 2 + b * ] dip / ] ]" +} ; + +ARTICLE: "fry.limitations" "Fried quotation limitations" +"As with " { $link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". Unlike " { $link "locals" } ", using " { $link dip } " is not a suitable workaround since unlike closure conversion, fry conversion is not recursive, and so the quotation passed to " { $link dip } " cannot contain fry specifiers." ; + +ARTICLE: "fry" "Fried quotations" +"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation." +$nl +"Fried quotations are denoted with a special parsing word:" +{ $subsection POSTPONE: '[ } +"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":" +{ $subsection , } +{ $subsection @ } +{ $subsection _ } +"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left." +{ $subsection "fry.examples" } +{ $subsection "fry.philosophy" } +{ $subsection "fry.limitations" } +"Quotations can also be fried without using a parsing word:" +{ $subsection fry } ; + +ABOUT: "fry" From b38706635758d2d191d574e0bac84d39aafb91ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 02:28:29 -0600 Subject: [PATCH 38/49] Fix slot name --- core/bootstrap/primitives.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5ac637572a..aeb5ec1d82 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -275,7 +275,7 @@ define-builtin } { { "object" "kernel" } - "?" + "compiled?" { "compiled?" "words" } f } From 219a3a4a408ed91105ff9dd05b390f90190f17c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 02:28:45 -0600 Subject: [PATCH 39/49] Fix style nesting bug in help --- extra/help/markup/markup.factor | 6 +++--- extra/help/stylesheet/stylesheet.factor | 8 ++++++-- 2 files changed, 9 insertions(+), 5 deletions(-) mode change 100644 => 100755 extra/help/stylesheet/stylesheet.factor diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 32e29db7db..d81e9cd81e 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic io kernel assocs hashtables namespaces parser prettyprint sequences strings io.styles @@ -42,9 +42,9 @@ M: f print-element drop ; [ print-element ] with-style ; : with-default-style ( quot -- ) - default-style get [ + default-span-style get [ last-element off - default-style get swap with-nesting + default-block-style get swap with-nesting ] with-style ; inline : print-content ( element -- ) diff --git a/extra/help/stylesheet/stylesheet.factor b/extra/help/stylesheet/stylesheet.factor old mode 100644 new mode 100755 index 3c5271d381..945d9a4ce1 --- a/extra/help/stylesheet/stylesheet.factor +++ b/extra/help/stylesheet/stylesheet.factor @@ -3,13 +3,17 @@ USING: io.styles namespaces ; IN: help.stylesheet -SYMBOL: default-style +SYMBOL: default-span-style H{ { font "sans-serif" } { font-size 12 } { font-style plain } +} default-span-style set-global + +SYMBOL: default-block-style +H{ { wrap-margin 500 } -} default-style set-global +} default-block-style set-global SYMBOL: link-style H{ From 60a4cc48a54ec78130ddb75862a698c4191c574f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 02:29:00 -0600 Subject: [PATCH 40/49] Mirror keys are now slot names not reader words --- core/mirrors/mirrors-docs.factor | 6 +++--- core/mirrors/mirrors-tests.factor | 6 +++--- core/mirrors/mirrors.factor | 10 ++++++---- core/slots/slots.factor | 3 +++ extra/http/server/components/components.factor | 8 ++------ 5 files changed, 17 insertions(+), 16 deletions(-) mode change 100644 => 100755 core/mirrors/mirrors-docs.factor mode change 100644 => 100755 core/mirrors/mirrors-tests.factor mode change 100644 => 100755 extra/http/server/components/components.factor diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor old mode 100644 new mode 100755 index ae40c85c0d..8da9e9dd69 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -20,7 +20,7 @@ HELP: object-slots HELP: mirror { $class-description "An associative structure which wraps an object and presents itself as a mapping from slot names to the object's slot values. Mirrors are used to build reflective developer tools." $nl -"Mirrors are mutable, however new keys cannot be inserted and keys cannot be deleted, only values of existing keys can be changed." +"Mirrors are mutable, however new keys cannot be inserted, only values of existing keys can be changed. Deleting a key has the effect of setting its value to " { $link f } "." $nl "Mirrors are created by calling " { $link } " or " { $link make-mirror } "." } ; @@ -33,7 +33,7 @@ HELP: "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." - "{ { circle-center { 100 50 } } { circle-radius 15 } }" + "{ { \"center\" { 100 50 } } { \"radius\" 15 } }" } } ; @@ -47,5 +47,5 @@ $nl "Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; HELP: make-mirror -{ $values { "obj" object } { "assoc" "an assoc" } } +{ $values { "obj" object } { "assoc" assoc } } { $description "Creates an assoc which reflects the internal structure of the object." } ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor old mode 100644 new mode 100755 index 863c4baa42..8f2964b19d --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -5,12 +5,12 @@ TUPLE: foo bar baz ; C: foo -[ { foo-bar foo-baz } ] [ 1 2 keys ] unit-test +[ { "bar" "baz" } ] [ 1 2 keys ] unit-test -[ 1 t ] [ \ foo-bar 1 2 at* ] unit-test +[ 1 t ] [ "bar" 1 2 at* ] unit-test [ f f ] [ "hi" 1 2 at* ] unit-test [ 3 ] [ - 3 \ foo-baz 1 2 [ set-at ] keep foo-baz + 3 "baz" 1 2 [ set-at ] keep foo-baz ] unit-test diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index af540ef86c..8f12bbb2f4 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -21,12 +21,14 @@ TUPLE: mirror object slots ; : >mirror< ( mirror -- obj slots ) dup mirror-object swap mirror-slots ; +: mirror@ ( slot-name mirror -- obj slot-spec ) + >mirror< swapd slot-named ; + M: mirror at* - >mirror< swapd slot-of-reader - dup [ slot-spec-offset slot t ] [ 2drop f f ] if ; + mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ; M: mirror set-at ( val key mirror -- ) - >mirror< swapd slot-of-reader dup [ + mirror@ dup [ dup slot-spec-writer [ slot-spec-offset set-slot ] [ @@ -42,7 +44,7 @@ M: mirror delete-at ( key mirror -- ) M: mirror >alist ( mirror -- alist ) >mirror< [ [ slot-spec-offset slot ] with map ] keep - [ slot-spec-reader ] map swap 2array flip ; + [ slot-spec-name ] map swap 2array flip ; M: mirror assoc-size mirror-slots length ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 40f0dd3da1..92d22247bd 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -110,3 +110,6 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ; : slot-of-writer ( writer specs -- spec/f ) [ slot-spec-writer eq? ] with find nip ; + +: slot-named ( string specs -- spec/f ) + [ slot-spec-name = ] with find nip ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor old mode 100644 new mode 100755 index 6fefb1b5dd..f14b766910 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -3,7 +3,7 @@ USING: new-slots html.elements http.server.validators accessors namespaces kernel io farkup math.parser assocs classes words tuples arrays sequences io.files -http.server.templating.fhtml splitting ; +http.server.templating.fhtml splitting mirrors ; IN: http.server.components SYMBOL: components @@ -94,14 +94,10 @@ M: number render-edit* M: number render-error* render-input render-error ; -: tuple>slots ( tuple -- alist ) - dup class "slot-names" word-prop swap tuple-slots - 2array flip ; - : with-components ( tuple components quot -- ) [ >r components set - dup tuple>slots values set + dup make-mirror values set tuple set r> call ] with-scope ; inline From 93950e7d7a664cec706d83b311e475cd1ab667e8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 7 Mar 2008 08:52:23 -0600 Subject: [PATCH 41/49] builder.*: update for new code changes --- extra/builder/builder.factor | 27 +++++++++++++------------- extra/builder/release/release.factor | 2 +- extra/builder/util/util.factor | 29 ++++++++++++++-------------- 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 41096e863c..728e87f28d 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,6 +2,7 @@ USING: kernel namespaces sequences splitting system combinators continuations parser io io.files io.launcher io.sockets prettyprint threads bootstrap.image benchmark vars bake smtp builder.util accessors + io.encodings.utf8 calendar builder.common builder.benchmark @@ -35,20 +36,20 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : git-id ( -- id ) - { "git" "show" } [ readln ] with-stream " " split second ; + { "git" "show" } utf8 + [ readln ] with-stream " " split second ; -: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ; +: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; : do-make-clean ( -- ) { "make" "clean" } try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : make-vm ( -- desc ) - - { "make" } >>arguments + + { "make" } >>command "../compile-log" >>stdout - +stdout+ >>stderr - >desc ; + +stdout+ >>stderr ; : do-make-vm ( -- ) make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; @@ -65,13 +66,12 @@ IN: builder { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; : bootstrap ( -- desc ) - - bootstrap-cmd >>arguments + + bootstrap-cmd >>command +closed+ >>stdin "../boot-log" >>stdout +stdout+ >>stderr - 20 minutes >>timeout - >desc ; + 20 minutes >>timeout ; : do-bootstrap ( -- ) bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; @@ -80,13 +80,12 @@ IN: builder { "./factor" "-run=builder.test" } to-strings ; : builder-test ( -- desc ) - - builder-test-cmd >>arguments + + builder-test-cmd >>command +closed+ >>stdin "../test-log" >>stdout +stdout+ >>stderr - 45 minutes >>timeout - >desc ; + 45 minutes >>timeout ; : do-builder-test ( -- ) builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index 849d1a54a3..f0cf0ee113 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -19,7 +19,7 @@ IN: builder.release { "boot.x86.32.image" "boot.x86.64.image" - "boot.macosx-ppc.boot" + "boot.macosx-ppc.image" "vm" "temp" "logs" diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 9682fc1346..50d74ddfc8 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -4,6 +4,7 @@ USING: kernel words namespaces classes parser continuations math math.parser combinators sequences splitting quotations arrays strings tools.time sequences.deep new-slots accessors assocs.lib + io.encodings.utf8 combinators.cleave bake calendar calendar.format ; IN: builder.util @@ -14,7 +15,7 @@ IN: builder.util : minutes>ms ( min -- ms ) 60 * 1000 * ; -: file>string ( file -- string ) [ stdio get contents ] with-file-reader ; +: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -39,18 +40,18 @@ DEFER: to-strings ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: process* arguments stdin stdout stderr timeout ; +! TUPLE: process* arguments stdin stdout stderr timeout ; -: process* construct-empty ; +! : process* construct-empty ; -: >desc ( process* -- desc ) - H{ } clone - over arguments>> [ +arguments+ swap put-at ] when* - over stdin>> [ +stdin+ swap put-at ] when* - over stdout>> [ +stdout+ swap put-at ] when* - over stderr>> [ +stderr+ swap put-at ] when* - over timeout>> [ +timeout+ swap put-at ] when* - nip ; +! : >desc ( process* -- desc ) +! H{ } clone +! over arguments>> [ +arguments+ swap put-at ] when* +! over stdin>> [ +stdin+ swap put-at ] when* +! over stdout>> [ +stdout+ swap put-at ] when* +! over stderr>> [ +stderr+ swap put-at ] when* +! over timeout>> [ +timeout+ swap put-at ] when* +! nip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -71,7 +72,7 @@ TUPLE: process* arguments stdin stdout stderr timeout ; : eval-file ( file -- obj ) file-contents eval ; -: cat ( file -- ) file-contents print ; +: cat ( file -- ) utf8 file-contents print ; : run-or-bail ( desc quot -- ) [ [ try-process ] curry ] @@ -96,7 +97,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; if ; : cat-n ( file n -- ) - [ file-lines ] [ ] bi* + [ utf8 file-lines ] [ ] bi* maybe-tail* [ print ] each ; @@ -104,7 +105,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ; USE: prettyprint -: to-file ( object file -- ) [ . ] with-file-writer ; +: to-file ( object file -- ) utf8 [ . ] with-file-writer ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 677a1f81cae0d2976c86fd1bee5062fce2ce9148 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 11:26:40 -0600 Subject: [PATCH 42/49] fix unit test --- extra/windows/time/time-tests.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/windows/time/time-tests.factor b/extra/windows/time/time-tests.factor index dc846a1b04..5492b34a54 100755 --- a/extra/windows/time/time-tests.factor +++ b/extra/windows/time/time-tests.factor @@ -1,6 +1,8 @@ -USING: calendar calendar.windows kernel tools.test ; - -[ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test -[ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test -[ t ] [ windows-1601 400 years time+ [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test - +USING: calendar calendar.windows kernel tools.test +windows.time ; +IN: windows.time.tests + +[ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test +[ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test +[ t ] [ windows-1601 400 years time+ [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test + From 17abc90d48ea58dc8093b9ff66cd0a2e46f25f71 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 15:52:41 -0600 Subject: [PATCH 43/49] Updated http client --- extra/http/client/client.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index f7a160017a..b00032e259 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting calendar continuations accessors vectors io.encodings.binary ; +splitting calendar continuations accessors vectors io.encodings.latin1 +io.encodings.binary ; IN: http.client : parse-url ( url -- resource host port ) @@ -42,7 +43,7 @@ DEFER: (http-request) ] if ; : (http-request) ( request -- response stream ) - dup host>> over port>> stdio set + dup host>> over port>> latin1 stdio set dup "r" set-global write-request flush read-response do-redirect ; From 915fd4e0f8f103b613523814f5a8712b2b2f6dbb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 7 Mar 2008 16:45:11 -0600 Subject: [PATCH 44/49] fix two load errors --- extra/db/sqlite/sqlite.factor | 2 +- extra/html/parser/analyzer/analyzer.factor | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 643b42165d..d0bf721aa7 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators tools.walker -combinators.cleave io ; +combinators.cleave io namespaces.lib ; IN: db.sqlite TUPLE: sqlite-db path ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 45197b1a90..1a60390f64 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,5 +1,6 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces splitting http ; +arrays shuffle unicode.case namespaces splitting http +sequences.lib ; IN: html.parser.analyzer : (find-relative) From 695dbe1a59b371d0811204883d652307cc0d9ead Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 16:59:44 -0600 Subject: [PATCH 45/49] Move web apps to unmaintained/ for now; get more stuff in extra to load --- extra/alarms/alarms.factor | 3 +++ extra/http/server/cgi/cgi.factor | 11 ++++----- extra/logging/insomniac/insomniac.factor | 24 +++++++++---------- extra/slides/slides.factor | 6 ++++- .../webapps/fjsc/authors.txt | 0 .../webapps/fjsc/fjsc.factor | 0 .../webapps/fjsc/head.furnace | 0 .../webapps/fjsc/repl.furnace | 0 .../webapps/fjsc/resources/repl.js | 0 .../webapps/fjsc/resources/termlib/faq.html | 0 .../webapps/fjsc/resources/termlib/index.html | 0 .../resources/termlib/multiterm_test.html | 0 .../fjsc/resources/termlib/parser_sample.html | 0 .../webapps/fjsc/resources/termlib/readme.txt | 0 .../fjsc/resources/termlib/term_styles.css | 0 .../webapps/fjsc/resources/termlib/termlib.js | 0 .../fjsc/resources/termlib/termlib_parser.js | 0 .../webapps/fjsc/summary.txt | 0 {extra => unmaintained}/webapps/fjsc/tags.txt | 0 .../webapps/help/authors.txt | 0 .../webapps/help/help.factor | 0 .../webapps/numbers/authors.txt | 0 .../webapps/numbers/numbers.factor | 0 .../webapps/pastebin/annotate-paste.furnace | 0 .../webapps/pastebin/annotation.furnace | 0 .../webapps/pastebin/authors.txt | 0 .../webapps/pastebin/footer.furnace | 0 .../webapps/pastebin/header.furnace | 0 .../webapps/pastebin/modes.furnace | 0 .../webapps/pastebin/new-paste.furnace | 0 .../webapps/pastebin/paste-list.furnace | 0 .../webapps/pastebin/paste-summary.furnace | 0 .../webapps/pastebin/pastebin.factor | 0 .../webapps/pastebin/show-paste.furnace | 0 .../webapps/pastebin/style.css | 0 .../webapps/pastebin/syntax.furnace | 0 .../webapps/planet/authors.txt | 0 .../webapps/planet/planet.factor | 0 .../webapps/planet/planet.furnace | 0 .../webapps/planet/style.css | 0 40 files changed, 25 insertions(+), 19 deletions(-) rename {extra => unmaintained}/webapps/fjsc/authors.txt (100%) rename {extra => unmaintained}/webapps/fjsc/fjsc.factor (100%) rename {extra => unmaintained}/webapps/fjsc/head.furnace (100%) rename {extra => unmaintained}/webapps/fjsc/repl.furnace (100%) rename {extra => unmaintained}/webapps/fjsc/resources/repl.js (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/faq.html (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/index.html (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/multiterm_test.html (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/parser_sample.html (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/readme.txt (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/term_styles.css (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/termlib.js (100%) rename {extra => unmaintained}/webapps/fjsc/resources/termlib/termlib_parser.js (100%) rename {extra => unmaintained}/webapps/fjsc/summary.txt (100%) rename {extra => unmaintained}/webapps/fjsc/tags.txt (100%) rename {extra => unmaintained}/webapps/help/authors.txt (100%) rename {extra => unmaintained}/webapps/help/help.factor (100%) rename {extra => unmaintained}/webapps/numbers/authors.txt (100%) rename {extra => unmaintained}/webapps/numbers/numbers.factor (100%) rename {extra => unmaintained}/webapps/pastebin/annotate-paste.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/annotation.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/authors.txt (100%) rename {extra => unmaintained}/webapps/pastebin/footer.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/header.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/modes.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/new-paste.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/paste-list.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/paste-summary.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/pastebin.factor (100%) rename {extra => unmaintained}/webapps/pastebin/show-paste.furnace (100%) rename {extra => unmaintained}/webapps/pastebin/style.css (100%) rename {extra => unmaintained}/webapps/pastebin/syntax.furnace (100%) rename {extra => unmaintained}/webapps/planet/authors.txt (100%) rename {extra => unmaintained}/webapps/planet/planet.factor (100%) rename {extra => unmaintained}/webapps/planet/planet.furnace (100%) rename {extra => unmaintained}/webapps/planet/style.css (100%) diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 1ccfdcbd30..55a66c5231 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -85,5 +85,8 @@ PRIVATE> : later ( quot dt -- alarm ) from-now f add-alarm ; +: every ( quot dt -- alarm ) + [ from-now ] keep add-alarm ; + : cancel-alarm ( alarm -- ) alarm-entry [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index 9950a9a4a4..cce3e5402d 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -41,18 +41,17 @@ IN: http.server.cgi ] when ] H{ } make-assoc ; -: cgi-descriptor ( name -- desc ) - [ - dup 1array +arguments+ set - cgi-variables +environment+ set - ] H{ } make-assoc ; +: ( name -- desc ) + + over 1array >>command + swap cgi-variables >>environment ; : serve-cgi ( name -- response ) 200 >>code "CGI output follows" >>message swap [ - stdio get swap cgi-descriptor [ + stdio get swap [ post? [ request get post-data>> write flush ] when diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index 0294085eda..83339af1c0 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron assocs -io.encodings.utf8 ; +kernel io.files io.streams.string namespaces alarms assocs +io.encodings.utf8 accessors calendar ; IN: logging.insomniac SYMBOL: insomniac-smtp-host @@ -29,13 +29,14 @@ SYMBOL: insomniac-recipients : (email-log-report) ( service word-names -- ) [ - over >r - ?analyze-log dup [ - r> email-subject - insomniac-recipients get - insomniac-sender get - send-simple-message - ] [ r> 2drop ] if + dupd ?analyze-log dup [ + + swap >>body + insomniac-recipients get >>to + insomniac-sender get >>from + swap email-subject >>subject + send + ] [ 2drop ] if ] with-insomniac-smtp ; \ (email-log-report) NOTICE add-error-logging @@ -44,6 +45,5 @@ SYMBOL: insomniac-recipients "logging.insomniac" [ (email-log-report) ] with-logging ; : schedule-insomniac ( service word-names -- ) - { 25 } { 6 } f f f -rot [ - [ email-log-report ] assoc-each rotate-logs - ] 2curry schedule ; + [ [ email-log-report ] assoc-each rotate-logs ] 2curry + 1 days every drop ; diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index a0065d6fe3..b58253381c 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -6,10 +6,14 @@ IN: slides : stylesheet H{ - { default-style + { default-span-style H{ { font "sans-serif" } { font-size 36 } + } + } + { default-block-style + H{ { wrap-margin 1000 } } } diff --git a/extra/webapps/fjsc/authors.txt b/unmaintained/webapps/fjsc/authors.txt similarity index 100% rename from extra/webapps/fjsc/authors.txt rename to unmaintained/webapps/fjsc/authors.txt diff --git a/extra/webapps/fjsc/fjsc.factor b/unmaintained/webapps/fjsc/fjsc.factor similarity index 100% rename from extra/webapps/fjsc/fjsc.factor rename to unmaintained/webapps/fjsc/fjsc.factor diff --git a/extra/webapps/fjsc/head.furnace b/unmaintained/webapps/fjsc/head.furnace similarity index 100% rename from extra/webapps/fjsc/head.furnace rename to unmaintained/webapps/fjsc/head.furnace diff --git a/extra/webapps/fjsc/repl.furnace b/unmaintained/webapps/fjsc/repl.furnace similarity index 100% rename from extra/webapps/fjsc/repl.furnace rename to unmaintained/webapps/fjsc/repl.furnace diff --git a/extra/webapps/fjsc/resources/repl.js b/unmaintained/webapps/fjsc/resources/repl.js similarity index 100% rename from extra/webapps/fjsc/resources/repl.js rename to unmaintained/webapps/fjsc/resources/repl.js diff --git a/extra/webapps/fjsc/resources/termlib/faq.html b/unmaintained/webapps/fjsc/resources/termlib/faq.html similarity index 100% rename from extra/webapps/fjsc/resources/termlib/faq.html rename to unmaintained/webapps/fjsc/resources/termlib/faq.html diff --git a/extra/webapps/fjsc/resources/termlib/index.html b/unmaintained/webapps/fjsc/resources/termlib/index.html similarity index 100% rename from extra/webapps/fjsc/resources/termlib/index.html rename to unmaintained/webapps/fjsc/resources/termlib/index.html diff --git a/extra/webapps/fjsc/resources/termlib/multiterm_test.html b/unmaintained/webapps/fjsc/resources/termlib/multiterm_test.html similarity index 100% rename from extra/webapps/fjsc/resources/termlib/multiterm_test.html rename to unmaintained/webapps/fjsc/resources/termlib/multiterm_test.html diff --git a/extra/webapps/fjsc/resources/termlib/parser_sample.html b/unmaintained/webapps/fjsc/resources/termlib/parser_sample.html similarity index 100% rename from extra/webapps/fjsc/resources/termlib/parser_sample.html rename to unmaintained/webapps/fjsc/resources/termlib/parser_sample.html diff --git a/extra/webapps/fjsc/resources/termlib/readme.txt b/unmaintained/webapps/fjsc/resources/termlib/readme.txt similarity index 100% rename from extra/webapps/fjsc/resources/termlib/readme.txt rename to unmaintained/webapps/fjsc/resources/termlib/readme.txt diff --git a/extra/webapps/fjsc/resources/termlib/term_styles.css b/unmaintained/webapps/fjsc/resources/termlib/term_styles.css similarity index 100% rename from extra/webapps/fjsc/resources/termlib/term_styles.css rename to unmaintained/webapps/fjsc/resources/termlib/term_styles.css diff --git a/extra/webapps/fjsc/resources/termlib/termlib.js b/unmaintained/webapps/fjsc/resources/termlib/termlib.js similarity index 100% rename from extra/webapps/fjsc/resources/termlib/termlib.js rename to unmaintained/webapps/fjsc/resources/termlib/termlib.js diff --git a/extra/webapps/fjsc/resources/termlib/termlib_parser.js b/unmaintained/webapps/fjsc/resources/termlib/termlib_parser.js similarity index 100% rename from extra/webapps/fjsc/resources/termlib/termlib_parser.js rename to unmaintained/webapps/fjsc/resources/termlib/termlib_parser.js diff --git a/extra/webapps/fjsc/summary.txt b/unmaintained/webapps/fjsc/summary.txt similarity index 100% rename from extra/webapps/fjsc/summary.txt rename to unmaintained/webapps/fjsc/summary.txt diff --git a/extra/webapps/fjsc/tags.txt b/unmaintained/webapps/fjsc/tags.txt similarity index 100% rename from extra/webapps/fjsc/tags.txt rename to unmaintained/webapps/fjsc/tags.txt diff --git a/extra/webapps/help/authors.txt b/unmaintained/webapps/help/authors.txt similarity index 100% rename from extra/webapps/help/authors.txt rename to unmaintained/webapps/help/authors.txt diff --git a/extra/webapps/help/help.factor b/unmaintained/webapps/help/help.factor similarity index 100% rename from extra/webapps/help/help.factor rename to unmaintained/webapps/help/help.factor diff --git a/extra/webapps/numbers/authors.txt b/unmaintained/webapps/numbers/authors.txt similarity index 100% rename from extra/webapps/numbers/authors.txt rename to unmaintained/webapps/numbers/authors.txt diff --git a/extra/webapps/numbers/numbers.factor b/unmaintained/webapps/numbers/numbers.factor similarity index 100% rename from extra/webapps/numbers/numbers.factor rename to unmaintained/webapps/numbers/numbers.factor diff --git a/extra/webapps/pastebin/annotate-paste.furnace b/unmaintained/webapps/pastebin/annotate-paste.furnace similarity index 100% rename from extra/webapps/pastebin/annotate-paste.furnace rename to unmaintained/webapps/pastebin/annotate-paste.furnace diff --git a/extra/webapps/pastebin/annotation.furnace b/unmaintained/webapps/pastebin/annotation.furnace similarity index 100% rename from extra/webapps/pastebin/annotation.furnace rename to unmaintained/webapps/pastebin/annotation.furnace diff --git a/extra/webapps/pastebin/authors.txt b/unmaintained/webapps/pastebin/authors.txt similarity index 100% rename from extra/webapps/pastebin/authors.txt rename to unmaintained/webapps/pastebin/authors.txt diff --git a/extra/webapps/pastebin/footer.furnace b/unmaintained/webapps/pastebin/footer.furnace similarity index 100% rename from extra/webapps/pastebin/footer.furnace rename to unmaintained/webapps/pastebin/footer.furnace diff --git a/extra/webapps/pastebin/header.furnace b/unmaintained/webapps/pastebin/header.furnace similarity index 100% rename from extra/webapps/pastebin/header.furnace rename to unmaintained/webapps/pastebin/header.furnace diff --git a/extra/webapps/pastebin/modes.furnace b/unmaintained/webapps/pastebin/modes.furnace similarity index 100% rename from extra/webapps/pastebin/modes.furnace rename to unmaintained/webapps/pastebin/modes.furnace diff --git a/extra/webapps/pastebin/new-paste.furnace b/unmaintained/webapps/pastebin/new-paste.furnace similarity index 100% rename from extra/webapps/pastebin/new-paste.furnace rename to unmaintained/webapps/pastebin/new-paste.furnace diff --git a/extra/webapps/pastebin/paste-list.furnace b/unmaintained/webapps/pastebin/paste-list.furnace similarity index 100% rename from extra/webapps/pastebin/paste-list.furnace rename to unmaintained/webapps/pastebin/paste-list.furnace diff --git a/extra/webapps/pastebin/paste-summary.furnace b/unmaintained/webapps/pastebin/paste-summary.furnace similarity index 100% rename from extra/webapps/pastebin/paste-summary.furnace rename to unmaintained/webapps/pastebin/paste-summary.furnace diff --git a/extra/webapps/pastebin/pastebin.factor b/unmaintained/webapps/pastebin/pastebin.factor similarity index 100% rename from extra/webapps/pastebin/pastebin.factor rename to unmaintained/webapps/pastebin/pastebin.factor diff --git a/extra/webapps/pastebin/show-paste.furnace b/unmaintained/webapps/pastebin/show-paste.furnace similarity index 100% rename from extra/webapps/pastebin/show-paste.furnace rename to unmaintained/webapps/pastebin/show-paste.furnace diff --git a/extra/webapps/pastebin/style.css b/unmaintained/webapps/pastebin/style.css similarity index 100% rename from extra/webapps/pastebin/style.css rename to unmaintained/webapps/pastebin/style.css diff --git a/extra/webapps/pastebin/syntax.furnace b/unmaintained/webapps/pastebin/syntax.furnace similarity index 100% rename from extra/webapps/pastebin/syntax.furnace rename to unmaintained/webapps/pastebin/syntax.furnace diff --git a/extra/webapps/planet/authors.txt b/unmaintained/webapps/planet/authors.txt similarity index 100% rename from extra/webapps/planet/authors.txt rename to unmaintained/webapps/planet/authors.txt diff --git a/extra/webapps/planet/planet.factor b/unmaintained/webapps/planet/planet.factor similarity index 100% rename from extra/webapps/planet/planet.factor rename to unmaintained/webapps/planet/planet.factor diff --git a/extra/webapps/planet/planet.furnace b/unmaintained/webapps/planet/planet.furnace similarity index 100% rename from extra/webapps/planet/planet.furnace rename to unmaintained/webapps/planet/planet.furnace diff --git a/extra/webapps/planet/style.css b/unmaintained/webapps/planet/style.css similarity index 100% rename from extra/webapps/planet/style.css rename to unmaintained/webapps/planet/style.css From c6c7269d45669a884fae67d9ff6189f17c0c7189 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 17:00:55 -0600 Subject: [PATCH 46/49] Remove obsolete scripts --- misc/macos-release.sh | 35 ----------------------------------- misc/source-release.sh | 7 ------- misc/windows-release.sh | 31 ------------------------------- 3 files changed, 73 deletions(-) delete mode 100644 misc/macos-release.sh delete mode 100755 misc/source-release.sh delete mode 100755 misc/windows-release.sh diff --git a/misc/macos-release.sh b/misc/macos-release.sh deleted file mode 100644 index 3a080e0ae6..0000000000 --- a/misc/macos-release.sh +++ /dev/null @@ -1,35 +0,0 @@ -source misc/version.sh - -TARGET=$1 - -if [ "$1" = "x86" ]; then - CPU="x86.32" - TARGET=macosx-x86-32 -else - CPU="macosx-ppc" - TARGET=macosx-ppc -fi - -BOOT_IMAGE=boot.$CPU.image -wget http://factorcode.org/images/$VERSION/$BOOT_IMAGE - -make $TARGET -Factor.app/Contents/MacOS/factor -i=$BOOT_IMAGE -no-user-init - -DISK_IMAGE_DIR=Factor-$VERSION -DISK_IMAGE=Factor-$VERSION-$TARGET.dmg - -rm -f $DISK_IMAGE -rm -rf $DISK_IMAGE_DIR -mkdir $DISK_IMAGE_DIR -mkdir -p $DISK_IMAGE_DIR/Factor/ -cp -R Factor.app $DISK_IMAGE_DIR/Factor/Factor.app -chmod +x cp_dir -cp factor.image license.txt README.txt $DISK_IMAGE_DIR/Factor/ -find core extra fonts misc unmaintained -type f \ - -exec ./cp_dir {} $DISK_IMAGE_DIR/Factor/{} \; -hdiutil create -srcfolder "$DISK_IMAGE_DIR" -fs HFS+ \ - -volname "$DISK_IMAGE_DIR" "$DISK_IMAGE" - -ssh linode mkdir -p w/downloads/$VERSION/ -scp $DISK_IMAGE linode:w/downloads/$VERSION/ diff --git a/misc/source-release.sh b/misc/source-release.sh deleted file mode 100755 index 6b1bb2dafc..0000000000 --- a/misc/source-release.sh +++ /dev/null @@ -1,7 +0,0 @@ -source misc/version.sh -rm -rf .git .gitignore -cd .. -tar cfz Factor-$VERSION.tar.gz factor/ - -ssh linode mkdir -p w/downloads/$VERSION/ -scp Factor-$VERSION.tar.gz linode:w/downloads/$VERSION/ diff --git a/misc/windows-release.sh b/misc/windows-release.sh deleted file mode 100755 index 7c3941a39a..0000000000 --- a/misc/windows-release.sh +++ /dev/null @@ -1,31 +0,0 @@ -source misc/version.sh - -CPU=$1 - -if [ "$CPU" = "x86" ]; then - FLAGS="-no-sse2" -fi - -make windows-nt-x86-32 - -wget http://factorcode.org/dlls/freetype6.dll -wget http://factorcode.org/dlls/zlib1.dll -wget http://factorcode.org/images/$VERSION/boot.x86.32.image - -CMD="./factor-nt -i=boot.x86.32.image -no-user-init $FLAGS" -echo $CMD -$CMD -rm -rf .git/ .gitignore -rm -rf Factor.app/ -rm -rf vm/ -rm -f Makefile -rm -f cp_dir -rm -f boot.*.image - -FILE=Factor-$VERSION-win32-$CPU.zip - -cd .. -zip -r $FILE Factor/ - -ssh linode mkdir -p w/downloads/$VERSION/ -scp $FILE linode:w/downloads/$VERSION/ From 71a1edf42665dee0bc6fc6c95e5ad275d92a1c28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 17:20:15 -0600 Subject: [PATCH 47/49] Fixing logging --- extra/logging/analysis/analysis.factor | 16 +++++++--------- extra/logging/insomniac/insomniac.factor | 11 +++++++---- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index b530c09b22..e2c77377ac 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces words assocs logging sorting -prettyprint io io.styles strings logging.parser ; +prettyprint io io.styles strings logging.parser calendar.format ; IN: logging.analysis SYMBOL: word-names @@ -42,16 +42,14 @@ SYMBOL: message-histogram ] tabular-output ; : log-entry. - [ - dup first [ write ] with-cell - dup second [ pprint ] with-cell - dup third [ write ] with-cell - fourth "\n" join [ write ] with-cell - ] with-row ; + "====== " write + dup first (timestamp>string) bl + dup second pprint bl + dup third write nl + fourth "\n" join print ; : errors. ( errors -- ) - standard-table-style - [ [ log-entry. ] each ] tabular-output ; + [ log-entry. ] each ; : analysis. ( errors word-histogram message-histogram -- ) "==== INTERESTING MESSAGES:" print nl diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index 83339af1c0..dfd7f430d2 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces alarms assocs -io.encodings.utf8 accessors calendar ; +USING: logging.analysis logging.server logging smtp kernel +io.files io.streams.string namespaces alarms assocs +io.encodings.utf8 accessors calendar qualified ; +QUALIFIED: io.sockets IN: logging.insomniac SYMBOL: insomniac-smtp-host @@ -25,7 +26,9 @@ SYMBOL: insomniac-recipients ] with-scope ; inline : email-subject ( service -- string ) - [ "[INSOMNIAC] " % % " on " % host-name % ] "" make ; + [ + "[INSOMNIAC] " % % " on " % io.sockets:host-name % + ] "" make ; : (email-log-report) ( service word-names -- ) [ From 68f276b444624a016f8b8ef4a337c3dcef594085 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 Mar 2008 17:21:20 -0600 Subject: [PATCH 48/49] HTTP server and client fixes --- extra/http/client/client-tests.factor | 1 - extra/http/client/client.factor | 63 ++++++++++++++------------ extra/http/http-tests.factor | 27 +++++++++++ extra/http/server/static/static.factor | 4 +- extra/http/test/foo.html | 1 + extra/io/server/server.factor | 8 ++-- 6 files changed, 68 insertions(+), 36 deletions(-) create mode 100644 extra/http/test/foo.html diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 4fca1697a5..661f63ab59 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -23,6 +23,5 @@ tuple-syntax namespaces ; [ "http://www.apple.com/index.html" - request-with-url ] with-scope ] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index b00032e259..f011ff537e 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -6,72 +6,76 @@ splitting calendar continuations accessors vectors io.encodings.latin1 io.encodings.binary ; IN: http.client +DEFER: http-request + +r >>path r> dup [ query>assoc ] when >>query ; -! This is all pretty complex because it needs to handle -! HTTP redirects, which might be absolute or relative : request-with-url ( url request -- request ) - clone dup "request" set swap parse-url >r >r store-path r> >>host r> >>port ; -DEFER: (http-request) - +! This is all pretty complex because it needs to handle +! HTTP redirects, which might be absolute or relative : absolute-redirect ( url -- request ) - "request" get request-with-url ; + request get request-with-url ; : relative-redirect ( path -- request ) - "request" get swap store-path ; + request get swap store-path ; : do-redirect ( response -- response stream ) dup response-code 300 399 between? [ + stdio get dispose header>> "location" swap at dup "http://" head? [ absolute-redirect ] [ relative-redirect - ] if "GET" >>method (http-request) + ] if "GET" >>method http-request ] [ stdio get ] if ; -: (http-request) ( request -- response stream ) - dup host>> over port>> latin1 stdio set - dup "r" set-global write-request flush read-response - do-redirect ; +: request-addr ( request -- addr ) + dup host>> swap port>> ; + +: close-on-error ( stream quot -- ) + [ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ; + inline PRIVATE> -: http-request ( url request -- response stream ) - [ - request-with-url +: http-request ( request -- response stream ) + dup request [ + dup request-addr latin1 + 1 minutes over set-timeout [ - (http-request) - 1 minutes over set-timeout - ] [ ] [ stdio get dispose ] cleanup - ] with-scope ; + write-request flush + read-response + do-redirect + ] close-on-error + ] with-variable ; -: ( -- request ) - "GET" >>method ; +: ( url -- request ) + request-with-url "GET" >>method ; : http-get-stream ( url -- response stream ) http-request ; : success? ( code -- ? ) 200 = ; -: check-response ( response stream -- stream ) - swap code>> success? - [ dispose "HTTP download failed" throw ] unless ; +: check-response ( response -- ) + code>> success? + [ "HTTP download failed" throw ] unless ; : http-get ( url -- string ) - http-get-stream check-response contents ; + http-get-stream contents swap check-response ; : download-name ( url -- name ) file-name "?" split1 drop "/" ?tail drop ; @@ -84,12 +88,13 @@ PRIVATE> : download ( url -- ) dup download-name download-to ; -: ( content-type content -- request ) +: ( content-type content url -- request ) + request-with-url "POST" >>method swap >>post-data swap >>post-data-type ; : http-post ( content-type content url -- response string ) #! The content is URL encoded for you. - -rot url-encode http-request contents ; + >r url-encode r> http-request contents ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index b706f34d13..16be0d026d 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -127,3 +127,30 @@ read-response-test-1' 1array [ "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" dup parse-cookies unparse-cookies = ] unit-test + +! Live-fire exercise +USING: http.server http.server.static http.server.actions +http.client io.server io.files io accessors namespaces threads +io.encodings.ascii ; + +[ ] [ + [ + + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>get + "quit" add-responder + "extra/http/test" resource-path >>default + default-host set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ t ] [ + "extra/http/test/foo.html" resource-path ascii file-contents + "http://localhost:1237/foo.html" http-get = +] unit-test + +[ "Goodbye" ] [ + "http://localhost:1237/quit" http-get +] unit-test diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 8d47d38eb1..93eb51ce4e 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http http.server namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements logging -calendar.format new-slots accessors ; +calendar.format new-slots accessors io.encodings.binary ; IN: http.server.static SYMBOL: responder @@ -33,7 +33,7 @@ TUPLE: file-responder root hook special ; over file-length "content-length" set-header over file-http-date "last-modified" set-header - swap [ stdio get stream-copy ] curry >>body + swap [ binary stdio get stream-copy ] curry >>body ] ; : serve-static ( filename mime-type -- response ) diff --git a/extra/http/test/foo.html b/extra/http/test/foo.html new file mode 100644 index 0000000000..2638986853 --- /dev/null +++ b/extra/http/test/foo.html @@ -0,0 +1 @@ +HelloHTTPd test diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 4267f7d1e8..0b7e626908 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -40,11 +40,11 @@ PRIVATE> f swap t resolve-host ; : with-server ( seq service encoding quot -- ) - V{ } clone [ - swap servers [ + V{ } clone servers [ + [ [ server-loop ] 2curry with-logging - ] with-variable - ] 3curry curry parallel-each ; inline + ] 3curry parallel-each + ] with-variable ; inline : stop-server ( -- ) servers get [ dispose ] each ; From 9ffe013d0331c7619d7974f764ff126baeb1c9f0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 7 Mar 2008 18:30:47 -0600 Subject: [PATCH 49/49] builder.*: lots of updates for the new language changes --- extra/builder/builder.factor | 2 +- extra/builder/test/test.factor | 14 ++++++++------ extra/builder/util/util.factor | 2 +- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 728e87f28d..747f0cd1e5 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -102,7 +102,7 @@ SYMBOL: build-status enter-build-dir - "report" + "report" utf8 [ "Build machine: " write host-name print "CPU: " write cpu print diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index c664941132..d03be0781a 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -6,22 +6,24 @@ USING: kernel namespaces sequences assocs builder continuations prettyprint tools.browser tools.test + io.encodings.utf8 bootstrap.stage2 benchmark builder.util ; IN: builder.test : do-load ( -- ) - try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ; + try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ; : do-tests ( -- ) - run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ; + run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ; -: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ; +: do-benchmarks ( -- ) + run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ; : do-all ( -- ) - bootstrap-time get "../boot-time" [ . ] with-file-writer - [ do-load ] runtime "../load-time" [ . ] with-file-writer - [ do-tests ] runtime "../test-time" [ . ] with-file-writer + bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer + [ do-load ] runtime "../load-time" utf8 [ . ] with-file-writer + [ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer do-benchmarks ; MAIN: do-all \ No newline at end of file diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 50d74ddfc8..82514ca43d 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -70,7 +70,7 @@ DEFER: to-strings : milli-seconds>time ( n -- string ) 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; -: eval-file ( file -- obj ) file-contents eval ; +: eval-file ( file -- obj ) utf8 file-contents eval ; : cat ( file -- ) utf8 file-contents print ;