From 765b45690499e20cd6b6aaaf986b031241c3f469 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 14:10:18 -0500 Subject: [PATCH 01/30] Fix profiler --- vm/profiler.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/vm/profiler.c b/vm/profiler.c index 08bb846c85..58a4aa035e 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -11,11 +11,12 @@ F_COMPILED *compile_profiling_stub(F_WORD *word) CELL code = array_nth(quadruple,0); REGISTER_ROOT(code); - CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2)) - | (to_fixnum(array_nth(quadruple,1)) << 8)); - CELL rel_offset = array_nth(quadruple,3) * compiled_code_format(); + F_REL rel; + rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8); + rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format(); - CELL relocation = allot_array_2(rel_type,rel_offset); + F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL)); + memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL)); UNREGISTER_ROOT(code); UNREGISTER_ROOT(literals); @@ -24,7 +25,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word) WORD_TYPE, untag_object(code), NULL, /* no labels */ - untag_object(relocation), + tag_object(relocation), untag_object(literals)); } From cc662c94ed087fc89d5185193c74f253a64f30cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 16:13:47 -0500 Subject: [PATCH 02/30] Add some failing unit tests --- extra/db/tuples/tuples-tests.factor | 18 ++++++++++++++---- extra/db/tuples/tuples.factor | 4 ++-- extra/db/types/types.factor | 3 ++- 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index b7c6fce933..fa213efb2f 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -198,9 +198,10 @@ 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" "foob" "factor-test" } postgresql-db r> with-db ; +! : test-postgresql ( quot -- ) +! >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; +: test-postgresql drop ; : test-repeated-insert [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test @@ -415,7 +416,7 @@ TUPLE: does-not-persist ; ] test-postgresql -TUPLE: suparclass a ; +TUPLE: suparclass id a ; suparclass f { { "id" "ID" +db-assigned-id+ } @@ -429,7 +430,16 @@ subbclass "SUBCLASS" { } define-persistent : test-db-inheritance ( -- ) - [ ] [ subbclass ensure-table ] unit-test ; + [ ] [ subbclass ensure-table ] unit-test + + [ ] [ + subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set + ] unit-test + + [ t "hi" 5 ] [ + subbclass new "id" get >>id select-tuple + [ subbclass? ] [ b>> ] [ a>> ] tri + ] unit-test ; [ test-db-inheritance ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0ffbd5bd47..28ef2ea406 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -13,10 +13,10 @@ IN: db.tuples "db-columns" set-word-prop "db-relations" set-word-prop ; -ERROR: not-persistent ; +ERROR: not-persistent class ; : db-table ( class -- obj ) - "db-table" word-prop [ not-persistent ] unless* ; + dup "db-table" word-prop [ ] [ not-persistent ] ?if ; : db-columns ( class -- obj ) superclasses [ "db-columns" word-prop ] map concat ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 8dbf6786bc..03e6b15bdb 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -142,7 +142,8 @@ HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) - class "slots" word-prop slot-named slot-spec-offset ; + class superclasses [ "slots" word-prop ] map concat + slot-named slot-spec-offset ; : get-slot-named ( name obj -- value ) tuck offset-of-slot slot ; From 72c914ddfa82167d59b1bfc36b7364d6e22504b1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 18:00:42 -0500 Subject: [PATCH 03/30] commit local changes before pulling --- extra/db/errors/errors.factor | 11 ++++++++++ extra/db/queries/queries.factor | 39 +++++++++++++++++++++++++++++---- extra/db/sqlite/lib/lib.factor | 21 +++++++++--------- extra/db/tuples/tuples.factor | 2 ++ 4 files changed, 59 insertions(+), 14 deletions(-) create mode 100644 extra/db/errors/errors.factor diff --git a/extra/db/errors/errors.factor b/extra/db/errors/errors.factor new file mode 100644 index 0000000000..1e0d1e7fb4 --- /dev/null +++ b/extra/db/errors/errors.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: db.errors + +ERROR: db-error ; +ERROR: sql-error ; + + +ERROR: table-exists ; +ERROR: bad-schema ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 6dab4f80b8..e2d452d657 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math namespaces sequences random -strings -math.bitfields.lib namespaces.lib db db.tuples db.types -math.intervals ; +strings math.parser math.intervals combinators +math.bitfields.lib namespaces.lib db db.tuples db.types ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -15,7 +14,7 @@ GENERIC: where ( specs obj -- ) : query-make ( class quot -- ) >r sql-props r> - [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake + [ 0 sql-counter rot with-variable ] { "" { } { } } nmake maybe-make-retryable ; inline M: db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -127,3 +126,35 @@ M: db ( tuple class -- statement ) " from " 0% 0% where-clause ] query-make ; + +: do-group ( tuple groups -- ) + [ + ", " join " group by " prepend append + ] curry change-sql drop ; + +: do-order ( tuple order -- ) + [ + ", " join " order by " prepend append + ] curry change-sql drop ; + +: do-offset ( tuple n -- ) + [ + number>string " offset " prepend append + ] curry change-sql drop ; + +: do-limit ( tuple n -- ) + [ + number>string " limit " prepend append + ] curry change-sql drop ; + +: make-advanced-statement ( tuple advanced -- ) + { + [ group>> [ do-group ] [ drop ] if* ] + [ order>> [ do-order ] [ drop ] if* ] + [ limit>> [ do-limit ] [ drop ] if* ] + [ offset>> [ do-offset ] [ drop ] if* ] + } 2cleave ; + +M: db ( tuple class advanced -- tuple ) + >r r> + dupd make-advanced-statement ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e92c4bbd8a..f2e603b049 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,24 +4,25 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -io.backend ; +io.backend db.errors ; IN: db.sqlite.lib -: sqlite-error ( n -- * ) - sqlite-error-messages nth throw ; +ERROR: sqlite-error < db-error n string ; +ERROR: sqlite-sql-error < sql-error n string ; -: sqlite-statement-error-string ( -- str ) - db get db-handle sqlite3_errmsg ; +: throw-sqlite-error ( n -- * ) + dup sqlite-error-messages nth sqlite-error ; : sqlite-statement-error ( -- * ) - sqlite-statement-error-string throw ; + SQLITE_ERROR + db get db-handle sqlite3_errmsg sqlite-sql-error ; : sqlite-check-result ( n -- ) { - { [ dup SQLITE_OK = ] [ drop ] } - { [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] } - [ sqlite-error ] - } cond ; + { SQLITE_OK [ ] } + { SQLITE_ERROR [ sqlite-statement-error ] } + [ throw-sqlite-error ] + } case ; : sqlite-open ( path -- db ) normalize-path diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0ffbd5bd47..10010ba759 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -42,6 +42,8 @@ HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) +TUPLE: advanced-statement group order offset limit ; +HOOK: db ( tuple class advanced -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) From 155f24df4fb21c117424783d9c440df17505298b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 18:16:40 -0500 Subject: [PATCH 04/30] Fix circularity --- core/generator/fixup/fixup-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index 58bc32397f..64d733ef8c 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -1,5 +1,6 @@ -USING: help.syntax help.markup generator.fixup math kernel -words strings alien byte-array ; +USING: help.syntax help.markup math kernel +words strings alien ; +IN: generator.fixup HELP: frame-required { $values { "n" "a non-negative integer" } } From 07fffb2811896172290a0b73bd6d3919d3b1c16d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 18:16:51 -0500 Subject: [PATCH 05/30] Clean up logging and fix error logging --- extra/logging/logging-tests.factor | 24 +++++++++++++ extra/logging/logging.factor | 55 +++++++++++++----------------- 2 files changed, 47 insertions(+), 32 deletions(-) create mode 100644 extra/logging/logging-tests.factor diff --git a/extra/logging/logging-tests.factor b/extra/logging/logging-tests.factor new file mode 100644 index 0000000000..796c8769fc --- /dev/null +++ b/extra/logging/logging-tests.factor @@ -0,0 +1,24 @@ +IN: logging.tests +USING: tools.test logging math ; + +: input-logging-test ( a b -- c ) + ; + +\ input-logging-test NOTICE add-input-logging + +: output-logging-test ( a b -- c ) + ; + +\ output-logging-test DEBUG add-output-logging + +: error-logging-test ( a b -- c ) / ; + +\ error-logging-test ERROR add-error-logging + +"logging-test" [ + [ 4 ] [ 1 3 input-logging-test ] unit-test + + [ 4 ] [ 1 3 output-logging-test ] unit-test + + [ 4/3 ] [ 4 3 error-logging-test ] unit-test + + [ f ] [ 1 0 error-logging-test ] unit-test +] with-logging diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index f54ab05bbd..df03bf320b 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings -combinators.lib quotations ; +combinators.lib quotations fry symbols accessors ; IN: logging -SYMBOL: DEBUG -SYMBOL: NOTICE -SYMBOL: WARNING -SYMBOL: ERROR -SYMBOL: CRITICAL +SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; -: log-levels - { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; +: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; : send-to-log-server ( array string -- ) prefix "log-server" get send ; SYMBOL: log-service -: check-log-message - pick string? - pick word? - pick word? and and - [ "Bad parameters to log-message" throw ] unless ; +: check-log-message ( msg word level -- msg word level ) + 3dup [ string? ] [ word? ] [ word? ] tri* and and + [ "Bad parameters to log-message" throw ] unless ; inline : log-message ( msg word level -- ) check-log-message log-service get dup [ - >r >r >r string-lines r> word-name r> word-name r> + [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip 4array "log-message" send-to-log-server ] [ 4drop @@ -69,7 +62,7 @@ SYMBOL: log-service PRIVATE> : (define-logging) ( word level quot -- ) - >r >r dup r> r> 2curry annotate ; + [ dup ] 2dip 2curry annotate ; : call-logging-quot ( quot word level -- quot' ) "called" -rot [ log-message ] 3curry prepose ; @@ -79,31 +72,30 @@ PRIVATE> : log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray stack>message - r> r> log-message + [ [ ndup ] keep narray stack>message ] 2dip log-message ] [ 3drop ] if ; inline -: input# stack-effect effect-in length ; +: input# stack-effect in>> length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-stack ] 3curry prepose ; + rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; -: output# stack-effect effect-out length ; +: output# stack-effect out>> length ; : output-logging-quot ( quot word level -- quot' ) - over output# -rot [ log-stack ] 3curry compose ; + [ [ output# ] keep ] dip '[ @ , , , log-stack ] ; : add-output-logging ( word level -- ) [ output-logging-quot ] (define-logging) ; : (log-error) ( object word level -- ) log-service get [ - >r >r [ print-error ] with-string-writer r> r> log-message + [ [ print-error ] with-string-writer ] 2dip log-message ] [ 2drop rethrow ] if ; @@ -112,22 +104,21 @@ PRIVATE> : log-critical ( error word -- ) CRITICAL (log-error) ; -: stack-balancer ( effect word -- quot ) - >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry - swap effect-out length f append >quotation ; +: stack-balancer ( effect -- quot ) + [ in>> length [ ndrop ] curry ] + [ out>> length f >quotation ] + bi append ; : error-logging-quot ( quot word -- quot' ) - [ [ log-error ] curry ] keep - [ stack-effect ] keep stack-balancer compose - [ recover ] 2curry ; + dup stack-effect stack-balancer + '[ , [ , log-error @ ] recover ] ; : add-error-logging ( word level -- ) - [ over >r input-logging-quot r> error-logging-quot ] + [ [ input-logging-quot ] 2keep drop error-logging-quot ] (define-logging) ; : LOG: #! Syntax: name level - CREATE-WORD - dup scan-word - [ >r >r 1array stack>message r> r> log-message ] 2curry + CREATE-WORD dup scan-word + '[ 1array stack>message , , log-message ] define ; parsing From b173097418045cc4350f5547864cae45b51af362 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 18:37:34 -0500 Subject: [PATCH 06/30] fix inheritance --- extra/db/tuples/tuples.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index ad581d927c..d560acc1d1 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -77,7 +77,7 @@ M: retryable execute-statement* ( statement type -- ) ] curry 10 retry drop ; : resulting-tuple ( row out-params -- tuple ) - dup first class>> new [ + dup peek class>> new [ [ >r slot-name>> r> set-slot-named ] curry 2each From 8036c4af79a604552b4e2a152e143272c39cdc7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:02:19 -0500 Subject: [PATCH 07/30] Fix typo --- core/alien/structs/structs-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index e7e576293f..baf0b40707 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -91,6 +91,6 @@ $nl ARTICLE: "c-unions" "C unions" "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values." { $subsection POSTPONE: C-UNION: } -"C structure objects can be allocated by calling " { $link } " or " { $link malloc-object } "." +"C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "." $nl "Arrays of C unions can be created by calling " { $link } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ; From f3085d9f8e43043617bc9c164ef9bfe214627015 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:05:55 -0500 Subject: [PATCH 08/30] Add another failing test --- extra/db/tuples/tuples-tests.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index fa213efb2f..5ab52899da 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -429,8 +429,13 @@ subbclass "SUBCLASS" { { "b" "B" TEXT } } define-persistent +TUPLE: fubbclass < subbclass ; + +fubbclass "FUBCLASS" { } define-persistent + : test-db-inheritance ( -- ) [ ] [ subbclass ensure-table ] unit-test + [ ] [ fubbclass ensure-table ] unit-test [ ] [ subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set @@ -439,7 +444,11 @@ subbclass "SUBCLASS" { [ t "hi" 5 ] [ subbclass new "id" get >>id select-tuple [ subbclass? ] [ b>> ] [ a>> ] tri - ] unit-test ; + ] unit-test + + [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test + + [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ; [ test-db-inheritance ] test-sqlite From dfeca417d0a5918508030f460099827281dbfcee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 19:09:37 -0500 Subject: [PATCH 09/30] add random-exam for testing --- extra/db/tuples/tuples-tests.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index fa213efb2f..5c61a8f898 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -3,7 +3,8 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals -db.postgresql accessors random math.bitfields.lib ; +db.postgresql accessors random math.bitfields.lib +math.ranges strings sequences.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -225,6 +226,12 @@ TUPLE: serialize-me id data ; TUPLE: exam id name score ; +: random-exam ( -- exam ) + f + 6 [ CHAR: a CHAR: b [a,b] random ] replicate >string + 100 random + exam boa ; + : test-intervals ( -- ) exam "EXAM" { From cf0ed665bfe64da82da7f4dabedc33eb0693a621 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 19:21:20 -0500 Subject: [PATCH 10/30] refactor a bit of sqlite fix inheritance test in tuple-db --- extra/db/sqlite/lib/lib.factor | 11 +++++------ extra/db/sqlite/sqlite.factor | 3 +-- extra/db/tuples/tuples.factor | 10 +++++----- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index f2e603b049..b652e8fed7 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -159,12 +159,11 @@ ERROR: sqlite-sql-error < sql-error n string ; dup sqlite-#columns [ sqlite-column ] with map ; : sqlite-step-has-more-rows? ( prepared -- bool ) - dup SQLITE_ROW = [ - drop t - ] [ - dup SQLITE_DONE = - [ drop ] [ sqlite-check-result ] if f - ] if ; + { + { SQLITE_ROW [ t ] } + { SQLITE_DONE [ f ] } + [ sqlite-check-result f ] + } case ; : sqlite-next ( prepared -- ? ) sqlite3_step sqlite-step-has-more-rows? ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c10775f1c9..cc4e4d116a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -16,7 +16,7 @@ M: sqlite-db make-db* ( path db -- db ) swap >>path ; M: sqlite-db db-open ( db -- db ) - [ path>> sqlite-open ] [ swap >>handle ] bi ; + dup path>> sqlite-open >>handle ; M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; @@ -197,4 +197,3 @@ M: sqlite-db compound ( str seq -- str' ) { "default" [ first number>string join-space ] } [ 2drop ] } case ; - diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index d560acc1d1..2838a8433a 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -76,16 +76,16 @@ M: retryable execute-statement* ( statement type -- ) [ regenerate-params bind-statement* f ] cleanup ] curry 10 retry drop ; -: resulting-tuple ( row out-params -- tuple ) - dup peek class>> new [ +: resulting-tuple ( class row out-params -- tuple ) + rot class new [ [ >r slot-name>> r> set-slot-named ] curry 2each ] keep ; -: query-tuples ( statement -- seq ) +: query-tuples ( exemplar-tuple statement -- seq ) [ out-params>> ] keep query-results [ - [ sql-row-typed swap resulting-tuple ] with query-map + [ sql-row-typed swap resulting-tuple ] with with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) @@ -145,7 +145,7 @@ M: retryable execute-statement* ( statement type -- ) : select-tuples ( tuple -- tuples ) dup dup class [ - [ bind-tuple ] keep query-tuples + [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; : select-tuple ( tuple -- tuple/f ) select-tuples ?first ; From 73a06ed9b05b87c5aa847f582f0798153b6fbd42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:40:01 -0500 Subject: [PATCH 11/30] Use define-persistent inheritance in pastebin --- extra/webapps/pastebin/pastebin.factor | 76 +++++++++++++------------- 1 file changed, 39 insertions(+), 37 deletions(-) diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 9852bf47cb..43cae74ec8 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -15,18 +15,22 @@ IN: webapps.pastebin ! DOMAIN MODEL ! ! ! -TUPLE: paste id summary author mode date contents annotations ; +TUPLE: entity id summary author mode date contents ; -\ paste "PASTE" +entity f { { "id" "ID" INTEGER +db-assigned-id+ } { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } { "mode" "MODE" { VARCHAR 256 } +not-null+ } - { "date" "DATE" DATETIME +not-null+ , } + { "date" "DATE" DATETIME +not-null+ } { "contents" "CONTENTS" TEXT +not-null+ } } define-persistent +TUPLE: paste < entity annotations ; + +\ paste "PASTES" { } define-persistent + : ( id -- paste ) \ paste new swap >>id ; @@ -34,23 +38,17 @@ TUPLE: paste id summary author mode date contents annotations ; : pastes ( -- pastes ) f select-tuples ; -TUPLE: annotation aid id summary author mode contents date ; +TUPLE: annotation < entity parent ; -annotation "ANNOTATION" +annotation "ANNOTATIONS" { - { "aid" "AID" INTEGER +db-assigned-id+ } - { "id" "ID" INTEGER +not-null+ } - { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ } - { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } - { "mode" "MODE" { VARCHAR 256 } +not-null+ } - { "date" "DATE" DATETIME +not-null+ } - { "contents" "CONTENTS" TEXT +not-null+ } + { "parent" "PARENT" INTEGER +not-null+ } } define-persistent -: ( id aid -- annotation ) +: ( parent id -- annotation ) annotation new - swap >>aid - swap >>id ; + swap >>id + swap >>parent ; : fetch-annotations ( paste -- paste ) dup annotations>> [ @@ -76,8 +74,8 @@ M: paste entity-link id>> "id" associate "$pastebin/paste" swap link>string ; M: annotation entity-link - [ id>> "id" associate "$pastebin/paste" swap link>string ] - [ aid>> number>string "#" prepend ] bi + [ parent>> "parent" associate "$pastebin/paste" swap link>string ] + [ id>> number>string "#" prepend ] bi append ; : pastebin-template ( name -- template ) @@ -147,7 +145,7 @@ M: annotation entity-link [ validate-integer-id ] >>init [ "id" value paste annotations>> paste-feed ] >>feed ; -: validate-paste ( -- ) +: validate-entity ( -- ) { { "summary" [ v-one-line ] } { "author" [ v-one-line ] } @@ -156,7 +154,7 @@ M: annotation entity-link { "captcha" [ v-captcha ] } } validate-params ; -: deposit-paste-slots ( tuple -- ) +: deposit-entity-slots ( tuple -- ) now >>date { "summary" "author" "mode" "contents" } deposit-slots ; @@ -170,10 +168,10 @@ M: annotation entity-link "new-paste" pastebin-template >>template [ - validate-paste + validate-entity f - [ deposit-paste-slots ] + [ deposit-entity-slots ] [ insert-tuple ] [ id>> "$pastebin/paste" ] tri @@ -195,31 +193,35 @@ M: annotation entity-link : ( -- action ) - [ validate-paste ] >>validate - - [ "id" param "$pastebin/paste" ] >>display + [ + { { "id" [ v-integer ] } } validate-params + "id" value "$pastebin/paste" + ] >>display [ - f f - { - [ deposit-paste-slots ] - [ { "id" } deposit-slots ] - [ insert-tuple ] - [ - ! Add anchor here - id>> "$pastebin/paste" - ] - } cleave + { { "id" [ v-integer ] } } validate-params + validate-entity + ] >>validate + + [ + "id" value f + [ deposit-entity-slots ] + [ insert-tuple ] + [ + ! Add anchor here + parent>> "$pastebin/paste" + ] + tri ] >>submit ; : ( -- action ) - [ { { "aid" [ v-number ] } } validate-params ] >>validate + [ { { "id" [ v-number ] } } validate-params ] >>validate [ - f "aid" value select-tuple + f "id" value select-tuple [ delete-tuples ] - [ id>> "$pastebin/paste" ] + [ parent>> "$pastebin/paste" ] bi ] >>submit ; From 5663707cda4f937a1499c587e6e4342685cc8f9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 May 2008 19:49:57 -0500 Subject: [PATCH 12/30] Fix problem with walker threads hanging around --- extra/tools/walker/walker.factor | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index ef6dac66f6..2417e7ac39 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models arrays accessors -generic generic.standard ; +generic generic.standard definitions ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -73,6 +73,7 @@ M: object add-breakpoint ; { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] } { [ dup standard-generic? ] [ effective-method (step-into-execute) ] } { [ dup hook-generic? ] [ effective-method (step-into-execute) ] } + { [ dup uses \ suspend swap member? ] [ execute break ] } { [ dup primitive? ] [ execute break ] } [ word-def (step-into-quot) ] } cond ; @@ -89,7 +90,6 @@ SYMBOL: step-into SYMBOL: step-all SYMBOL: step-into-all SYMBOL: step-back -SYMBOL: detach SYMBOL: abandon SYMBOL: call-in @@ -137,7 +137,7 @@ SYMBOL: +stopped+ { >n ndrop >c c> continue continue-with - stop yield suspend sleep (spawn) + stop suspend (spawn) } [ dup [ execute break ] curry "step-into" set-word-prop @@ -168,10 +168,7 @@ SYMBOL: +stopped+ +running+ set-status ; : walker-stopped ( -- ) - +stopped+ set-status - [ status +stopped+ eq? ] - [ [ drop f ] handle-synchronous ] - [ ] while ; + +stopped+ set-status ; : step-into-all-loop ( -- ) +running+ set-status From 4732915a575aeff3e66bdc613c71be1ccd9aafbe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 30 May 2008 22:47:38 -0500 Subject: [PATCH 13/30] fix advanced tuple selects select-tuple uses limit 1 now --- extra/db/postgresql/postgresql.factor | 2 +- extra/db/queries/queries.factor | 9 +++++---- extra/db/sql/sql-tests.factor | 8 +++++--- extra/db/tuples/tuples.factor | 15 +++++++++------ 4 files changed, 20 insertions(+), 14 deletions(-) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 3e81b264d6..f55897db88 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -175,7 +175,7 @@ M: postgresql-db create-sql-statement ( class -- seq ) : drop-table-sql ( table -- statement ) [ - "drop table " 0% 0% ";" 0% drop + "drop table " 0% 0% drop ] query-make ; M: postgresql-db drop-sql-statement ( class -- seq ) diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index e2d452d657..9743e87f2e 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -147,7 +147,8 @@ M: db ( tuple class -- statement ) number>string " limit " prepend append ] curry change-sql drop ; -: make-advanced-statement ( tuple advanced -- ) +: make-advanced-statement ( tuple advanced -- tuple' ) + dupd { [ group>> [ do-group ] [ drop ] if* ] [ order>> [ do-order ] [ drop ] if* ] @@ -155,6 +156,6 @@ M: db ( tuple class -- statement ) [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db ( tuple class advanced -- tuple ) - >r r> - dupd make-advanced-statement ; +M: db ( tuple class group order limit offset -- tuple ) + advanced-statement boa + [ ] dip make-advanced-statement ; diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index cab7b83ced..0b57c2d8fa 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -4,9 +4,11 @@ IN: db.sql.tests ! TUPLE: person name age ; : insert-1 { insert - { table "person" } - { columns "name" "age" } - { values "erg" 26 } + { + { table "person" } + { columns "name" "age" } + { values "erg" 26 } + } } ; : update-1 diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 2838a8433a..0a69b9cde8 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -43,7 +43,7 @@ HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) TUPLE: advanced-statement group order offset limit ; -HOOK: db ( tuple class advanced -- tuple ) +HOOK: db ( tuple class group order offset limit -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) @@ -143,9 +143,12 @@ M: retryable execute-statement* ( statement type -- ) [ bind-tuple ] keep execute-statement ] with-disposal ; -: select-tuples ( tuple -- tuples ) - dup dup class [ - [ bind-tuple ] [ query-tuples ] 2bi - ] with-disposal ; +: do-select ( exemplar-tuple statement -- tuples ) + [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; -: select-tuple ( tuple -- tuple/f ) select-tuples ?first ; +: select-tuples ( tuple -- tuples ) + dup dup class do-select ; + +: select-tuple ( tuple -- tuple/f ) + dup dup class f f f 1 + do-select ?first ; From 620103351ebf092897819014fc4c975be3e3d230 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 00:07:30 -0500 Subject: [PATCH 14/30] Tweak stuff to reduce deploy image size --- core/alien/compiler/compiler.factor | 8 ++++---- extra/bunny/model/model.factor | 6 ++---- extra/tools/deploy/deploy-tests.factor | 8 +++++++- extra/tools/deploy/shaker/shaker.factor | 5 +++++ 4 files changed, 18 insertions(+), 9 deletions(-) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 08b52367b0..67665b4d7e 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators compiler.errors continuations layouts accessors -; +init ; IN: alien.compiler TUPLE: #alien-node < node return parameters abi ; @@ -336,7 +336,7 @@ M: #alien-indirect generate-node ! this hashtable, they will all be blown away by code GC, beware SYMBOL: callbacks -callbacks global [ H{ } assoc-like ] change-at +[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook : register-callback ( word -- ) dup callbacks get set-at ; @@ -344,7 +344,7 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - xt>> [ word-xt drop ] curry + xt>> [ [ register-callback ] [ word-xt drop ] bi ] curry recursive-state get infer-quot ; \ alien-callback [ @@ -354,7 +354,7 @@ M: alien-callback-error summary pop-literal nip >>abi pop-parameters >>parameters pop-literal nip >>return - gensym dup register-callback >>xt + gensym >>xt callback-bottom ] "infer" set-word-prop diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 2dac9eb688..8fef44a76a 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -35,10 +35,8 @@ IN: bunny.model [ normalize ] map ; : read-model ( stream -- model ) - "Reading model" print flush [ - ascii [ parse-model ] with-file-reader - [ normals ] 2keep 3array - ] time ; + ascii [ parse-model ] with-file-reader + [ normals ] 2keep 3array ; : model-path "bun_zipper.ply" temp-file ; diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 37689f749f..8ff22fb1ad 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -23,7 +23,7 @@ namespaces continuations layouts accessors ; [ ] [ "sudoku" shake-and-bake ] unit-test [ t ] [ - cell 8 = 30 15 ? 100000 * small-enough? + cell 8 = 20 10 ? 100000 * small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test @@ -37,6 +37,12 @@ namespaces continuations layouts accessors ; cell 8 = 40 20 ? 100000 * small-enough? ] unit-test +[ ] [ "maze" shake-and-bake ] unit-test + +[ t ] [ + cell 8 = 30 15 ? 100000 * small-enough? +] unit-test + [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 4f0d6ac036..e8675f5891 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -108,6 +108,8 @@ IN: tools.deploy.shaker : stripped-globals ( -- seq ) [ + "callbacks" "alien.compiler" lookup , + { bootstrap.stage2:bootstrap-time continuations:error @@ -142,6 +144,7 @@ IN: tools.deploy.shaker { gensym + name>char-hook classes:class-and-cache classes:class-not-cache classes:class-or-cache @@ -167,6 +170,8 @@ IN: tools.deploy.shaker vocabs:load-vocab-hook word } % + + { } { "optimizer.math.partial" } strip-vocab-globals % ] when strip-prettyprint? [ From 10a42163115ee2bc89b07b5dd21834e35d08efb8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 00:07:40 -0500 Subject: [PATCH 15/30] Fix typo --- extra/openssl/openssl.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index ca5a4e8846..03343820db 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -38,15 +38,15 @@ M: TLSv1 ssl-method drop TLSv1_method ; OpenSSL_add_all_digests OpenSSL_add_all_ciphers ; -SYMBOL: ssl-initiazed? +SYMBOL: ssl-initialized? : maybe-init-ssl ( -- ) - ssl-initiazed? get-global [ + ssl-initialized? get-global [ init-ssl - t ssl-initiazed? set-global + t ssl-initialized? set-global ] unless ; -[ f ssl-initiazed? set-global ] "openssl" add-init-hook +[ f ssl-initialized? set-global ] "openssl" add-init-hook TUPLE: openssl-context < secure-context aliens ; From 0090e613d900f892aaccd9d07c7c177963fe1a26 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 00:08:02 -0500 Subject: [PATCH 16/30] Windows I/O attempted fix --- extra/io/windows/nt/backend/backend.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 993aff5200..1a7462f304 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -64,9 +64,11 @@ M: winnt add-completion ( win32-handle -- ) : handle-overlapped ( timeout -- ? ) wait-for-overlapped [ - >r drop GetLastError - [ 1array ] [ expected-io-error? ] bi - [ r> 2drop f ] [ r> resume-callback t ] if + dup [ + >r drop GetLastError 1array r> resume-callback t + ] [ + 2drop f + ] if ] [ resume-callback t ] if ; From bca323f2bb4cbc25d89c21c9797a71e4aef3a0bb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:29:28 -0500 Subject: [PATCH 17/30] dns: move name-error from dns.cache --- extra/dns/cache/cache.factor | 2 +- extra/dns/dns.factor | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index 4167c7b16e..e32e081ad8 100644 --- a/extra/dns/cache/cache.factor +++ b/extra/dns/cache/cache.factor @@ -80,7 +80,7 @@ SYMBOL: NX ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -ERROR: name-error name ; +! ERROR: name-error name ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 9404ccdad1..f8a531b0c1 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -476,3 +476,6 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED : message-query ( message -- query ) question-section>> 1st ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ERROR: name-error name ; \ No newline at end of file From b440a63406be1ae09588b1ea575d06b55eabd492 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:29:54 -0500 Subject: [PATCH 18/30] dns.stub: A stub resolver --- extra/dns/stub/stub.factor | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 extra/dns/stub/stub.factor diff --git a/extra/dns/stub/stub.factor b/extra/dns/stub/stub.factor new file mode 100644 index 0000000000..a15feb5759 --- /dev/null +++ b/extra/dns/stub/stub.factor @@ -0,0 +1,20 @@ + +USING: kernel sequences random accessors dns ; + +IN: dns.stub + +! Stub resolver +! +! Generally useful, but particularly when running a forwarding, +! caching, nameserver on localhost with multiple Factor instances +! querying it. + +: name->ip ( name -- ip ) + A IN query boa + query->message + ask + dup rcode>> NAME-ERROR = + [ message-query name>> name-error ] + [ answer-section>> [ type>> A = ] filter random rdata>> ] + if ; + From f66fd9a1298801fa716443bf03b0885a86f16e9b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:39:20 -0500 Subject: [PATCH 19/30] dns: move fully-qualified from dns.resolver --- extra/dns/dns.factor | 12 +++++++++++- extra/dns/resolver/resolver.factor | 10 ---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index f8a531b0c1..6386655a4e 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -478,4 +478,14 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -ERROR: name-error name ; \ No newline at end of file +ERROR: name-error name ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fully-qualified ( name -- name ) + { + { [ dup empty? ] [ "." append ] } + { [ dup peek CHAR: . = ] [ ] } + { [ t ] [ "." append ] } + } + cond ; diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index 38fe59dc41..2e1e828cd3 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -78,16 +78,6 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: fully-qualified ( name -- name ) - { - { [ dup empty? ] [ "." append ] } - { [ dup peek CHAR: . = ] [ ] } - { [ t ] [ "." append ] } - } - cond ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : name->ip ( name -- ip ) fully-qualified dup name->ip/cache dup From f59cc01d9aa02288ab0cbb73924bd99bea5b9d95 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 07:42:38 -0500 Subject: [PATCH 20/30] dns.resolver: cache-message moved to dns. Also some minor cleanups. --- extra/dns/resolver/resolver.factor | 49 ++++-------------------------- 1 file changed, 6 insertions(+), 43 deletions(-) diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index 2e1e828cd3..2dae43b5d4 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -6,34 +6,6 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Need to cache records even in the case of name error - -: cache-message ( message -- message ) - dup dup rcode>> NAME-ERROR = - [ - [ question-section>> 1st ] - [ authority-section>> [ type>> SOA = ] filter random ttl>> ] - bi - cache-nx - ] - [ - { - [ answer-section>> cache-add-rrs ] - [ authority-section>> cache-add-rrs ] - [ additional-section>> cache-add-rrs ] - } - cleave - ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Ask and cache the records - -: ask* ( message -- message ) ask cache-message ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : canonical/cache ( name -- name ) dup CNAME IN query boa cache-get dup vector? ! name result ? [ nip 1st rdata>> ] @@ -43,26 +15,17 @@ IN: dns.resolver : name->ip/cache ( name -- ip ) canonical/cache dup A IN query boa cache-get ! name result - { { - [ dup NX = ] - [ 2drop f ] + { [ dup NX = ] [ 2drop f ] } + { [ dup f = ] [ 2drop f ] } + { [ t ] [ nip random rdata>> ] } } - { - [ dup f = ] - [ 2drop f ] - } - { - [ t ] - [ nip random rdata>> ] - } - } - cond ; + cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : canonical/server ( name -- name ) - dup CNAME IN query boa query->message ask* answer-section>> + dup CNAME IN query boa query->message ask cache-message answer-section>> [ type>> CNAME = ] filter dup empty? not [ nip 1st rdata>> ] [ drop ] @@ -70,7 +33,7 @@ IN: dns.resolver : name->ip/server ( name -- ip ) canonical/server - dup A IN query boa query->message ask* answer-section>> + dup A IN query boa query->message ask cache-message answer-section>> [ type>> A = ] filter dup empty? not [ nip random rdata>> ] [ 2drop f ] From 0e655a204d86186a063c163fd226890e58d2f20d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 31 May 2008 08:07:53 -0500 Subject: [PATCH 21/30] dns.cache: minor removal --- extra/dns/cache/cache.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index e32e081ad8..5c4539b913 100644 --- a/extra/dns/cache/cache.factor +++ b/extra/dns/cache/cache.factor @@ -80,10 +80,6 @@ SYMBOL: NX ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ERROR: name-error name ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : cache-get ( query -- rrs/f ) dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ; From b1bc993799f7b46a69b35fc9e77e6cb7c93a8f5e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 May 2008 22:46:15 -0700 Subject: [PATCH 22/30] Add a test suite for json.reader. Fix bugs in json.reader: failure to parse when more than one character of whitespace between tokens, failure to parse escape codes in strings, misinterpretation of "e+02" as a negative exponent, failure to handle leading whitespace, and failure to handle "+" as the first character of a number. Change json.reader to parse JSON booleans into Factor t and f, and to parse JSON null into the json-null symbol. --- extra/json/reader/reader-tests.factor | 43 ++++++++++++++++++++++++ extra/json/reader/reader.factor | 47 +++++++++++++++++++-------- 2 files changed, 76 insertions(+), 14 deletions(-) create mode 100644 extra/json/reader/reader-tests.factor diff --git a/extra/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor new file mode 100644 index 0000000000..e8dbc2eaa7 --- /dev/null +++ b/extra/json/reader/reader-tests.factor @@ -0,0 +1,43 @@ +USING: arrays json.reader kernel multiline strings tools.test ; +IN: json.reader.tests + +{ f } [ "false" json> ] unit-test +{ t } [ "true" json> ] unit-test +{ json-null } [ "null" json> ] unit-test +{ 0 } [ "0" json> ] unit-test +{ 0 } [ "0000" json> ] unit-test +{ 102 } [ "102" json> ] unit-test +{ -102 } [ "-102" json> ] unit-test +{ 102 } [ "+102" json> ] unit-test +{ 102.0 } [ "102.0" json> ] unit-test +{ 102.5 } [ "102.5" json> ] unit-test +{ 102.5 } [ "102.50" json> ] unit-test +{ -10250 } [ "-102.5e2" json> ] unit-test +{ -10250 } [ "-102.5E+2" json> ] unit-test +{ 10.25 } [ "1025e-2" json> ] unit-test + +{ "fuzzy pickles" } [ <" "fuzzy pickles" "> json> ] unit-test +{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test +{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test +{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test +{ "\"scare\" quotes" } [ <" "\"scare\" quotes" "> json> ] unit-test + +{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test +{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test +{ H{ + { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } } + { "prime" { 2 3 5 7 11 13 } } +} } [ <" { + "fib": [1, 1, 2, 3, 5, 8, + { "etc":"etc" } ], + "prime": + [ 2,3, 5,7, +11, +13 +] } +"> json> ] unit-test + +{ 0 } [ " 0" json> ] unit-test +{ 0 } [ "0 " json> ] unit-test +{ 0 } [ " 0 " json> ] unit-test + diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 17c1b272df..5e6b16dc2f 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -7,6 +7,8 @@ IN: json.reader ! Grammar for JSON from RFC 4627 +SYMBOL: json-null + : [<&>] ( quot -- quot ) { } make unclip [ <&> ] reduce ; @@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser ) " " token "\n" token <|> "\r" token <|> - "\t" token <|> - "" token <|> ; + "\t" token <|> <*> ; LAZY: spaced ( parser -- parser ) 'ws' swap &> 'ws' <& ; @@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser ) "," token spaced ; LAZY: 'false' ( -- parser ) - "false" token ; + "false" token [ drop f ] <@ ; LAZY: 'null' ( -- parser ) - "null" token ; + "null" token [ drop json-null ] <@ ; LAZY: 'true' ( -- parser ) - "true" token ; + "true" token [ drop t ] <@ ; LAZY: 'quot' ( -- parser ) "\"" token ; +LAZY: 'hex-digit' ( -- parser ) + [ digit> ] satisfy [ digit> ] <@ ; + +: hex-digits>ch ( digits -- ch ) + 0 [ swap 16 * + ] reduce ; + +LAZY: 'string-char' ( -- parser ) + [ quotable? ] satisfy + "\\b" token [ drop 8 ] <@ <|> + "\\t" token [ drop CHAR: \t ] <@ <|> + "\\n" token [ drop CHAR: \n ] <@ <|> + "\\f" token [ drop 12 ] <@ <|> + "\\r" token [ drop CHAR: \r ] <@ <|> + "\\\"" token [ drop CHAR: " ] <@ <|> + "\\/" token [ drop CHAR: / ] <@ <|> + "\\\\" token [ drop CHAR: \\ ] <@ <|> + "\\u" token 'hex-digit' 4 exactly-n &> + [ hex-digits>ch ] <@ <|> ; + LAZY: 'string' ( -- parser ) 'quot' - [ - [ quotable? ] keep - [ CHAR: \\ = or ] keep - CHAR: " = not and - ] satisfy <*> &> + 'string-char' <*> &> 'quot' <& [ >string ] <@ ; DEFER: 'value' @@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser ) LAZY: 'plus' ( -- parser ) "+" token ; +LAZY: 'sign' ( -- parser ) + 'minus' 'plus' <|> ; + LAZY: 'zero' ( -- parser ) "0" token [ drop 0 ] <@ ; @@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser ) : sign-number ( pair -- number ) #! Pair is { minus? num } #! Convert the json number value to a factor number - dup second swap first [ -1 * ] when ; + dup second swap first [ first "-" = [ -1 * ] when ] when* ; LAZY: 'exp' ( -- parser ) 'e' - 'minus' 'plus' <|> &> + 'sign' &> 'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ; : sequence>frac ( seq -- num ) @@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser ) dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ; LAZY: 'number' ( -- parser ) - 'minus' + 'sign' [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@ 'exp' <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ; @@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser ) 'object' , 'array' , 'number' , - ] [<|>] ; + ] [<|>] spaced ; : json> ( string -- object ) #! Parse a json formatted string to a factor object From 0b4a0f5e4d3bfc7596e3e1aa8eabb7aff81c5516 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 31 May 2008 09:10:11 -0700 Subject: [PATCH 23/30] Adjust json.reader unit tests a bit --- extra/json/reader/reader-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor index e8dbc2eaa7..4b7bd56f01 100644 --- a/extra/json/reader/reader-tests.factor +++ b/extra/json/reader/reader-tests.factor @@ -5,7 +5,6 @@ IN: json.reader.tests { t } [ "true" json> ] unit-test { json-null } [ "null" json> ] unit-test { 0 } [ "0" json> ] unit-test -{ 0 } [ "0000" json> ] unit-test { 102 } [ "102" json> ] unit-test { -102 } [ "-102" json> ] unit-test { 102 } [ "+102" json> ] unit-test @@ -15,12 +14,13 @@ IN: json.reader.tests { -10250 } [ "-102.5e2" json> ] unit-test { -10250 } [ "-102.5E+2" json> ] unit-test { 10.25 } [ "1025e-2" json> ] unit-test +{ 0.125 } [ "0.125" json> ] unit-test +{ -0.125 } [ "-0.125" json> ] unit-test -{ "fuzzy pickles" } [ <" "fuzzy pickles" "> json> ] unit-test +{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test { "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test -{ "\"scare\" quotes" } [ <" "\"scare\" quotes" "> json> ] unit-test { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test { H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test From 3ab71b00a99f391d9f036585eecc11b039f2d99d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 23:20:24 -0500 Subject: [PATCH 24/30] URLs library, abstracted out from http.server --- extra/urls/authors.txt | 1 + extra/urls/summary.txt | 1 + extra/urls/tags.txt | 2 + extra/urls/urls-tests.factor | 162 +++++++++++++++++++++++++++++++++++ extra/urls/urls.factor | 143 +++++++++++++++++++++++++++++++ 5 files changed, 309 insertions(+) create mode 100644 extra/urls/authors.txt create mode 100644 extra/urls/summary.txt create mode 100644 extra/urls/tags.txt create mode 100644 extra/urls/urls-tests.factor create mode 100644 extra/urls/urls.factor diff --git a/extra/urls/authors.txt b/extra/urls/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/urls/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/urls/summary.txt b/extra/urls/summary.txt new file mode 100644 index 0000000000..caeda3d21a --- /dev/null +++ b/extra/urls/summary.txt @@ -0,0 +1 @@ +Tools for working with URLs (uniform resource locators) diff --git a/extra/urls/tags.txt b/extra/urls/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/urls/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor new file mode 100644 index 0000000000..dd319a1e65 --- /dev/null +++ b/extra/urls/urls-tests.factor @@ -0,0 +1,162 @@ +IN: urls.tests +USING: urls tools.test tuple-syntax arrays kernel assocs ; + +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test +[ f ] [ "%XX%XX%XX" url-decode ] unit-test +[ f ] [ "%XX%XX%X" url-decode ] unit-test + +[ "hello world" ] [ "hello+world" url-decode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ " ! " ] [ "%20%21%20" url-decode ] unit-test +[ "hello world" ] [ "hello world%" url-decode ] unit-test +[ "hello world" ] [ "hello world%x" url-decode ] unit-test +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test + +[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test + +[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test + +[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +: urls + { + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com:1234/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/another/fine/path" + anchor: "foo" + } + "http://www.apple.com:1234/another/fine/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + anchor: "foo" + } + "/a/relative/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + } + "/a/relative/path" + } + { + TUPLE{ url + path: "a/relative/path" + } + "a/relative/path" + } + } ; + +urls [ + [ 1array ] [ [ string>url ] curry ] bi* unit-test +] assoc-each + +urls [ + swap [ 1array ] [ [ url>string ] curry ] bi* unit-test +] assoc-each + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } +] [ + TUPLE{ url + path: "/a/path" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + + derive-url +] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor new file mode 100644 index 0000000000..86f3de651d --- /dev/null +++ b/extra/urls/urls.factor @@ -0,0 +1,143 @@ +USING: kernel unicode.categories combinators sequences splitting +fry namespaces assocs arrays strings mirrors +io.encodings.string io.encodings.utf8 +math math.parser accessors namespaces.lib ; +IN: urls + +: url-quotable? ( ch -- ? ) + #! In a URL, can this character be used without + #! URL-encoding? + { + { [ dup letter? ] [ t ] } + { [ dup LETTER? ] [ t ] } + { [ dup digit? ] [ t ] } + { [ dup "/_-.:" member? ] [ t ] } + [ f ] + } cond nip ; foldable + +: push-utf8 ( ch -- ) + 1string utf8 encode + [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + +: url-encode ( str -- str ) + [ + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each + ] "" make ; + +: url-decode-hex ( index str -- ) + 2dup length 2 - >= [ + 2drop + ] [ + [ 1+ dup 2 + ] dip subseq hex> [ , ] when* + ] if ; + +: url-decode-% ( index str -- index str ) + 2dup url-decode-hex [ 3 + ] dip ; + +: url-decode-+-or-other ( index str ch -- index str ) + dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; + +: url-decode-iter ( index str -- ) + 2dup length >= [ + 2drop + ] [ + 2dup nth dup CHAR: % = [ + drop url-decode-% + ] [ + url-decode-+-or-other + ] if url-decode-iter + ] if ; + +: url-decode ( str -- str ) + [ 0 swap url-decode-iter ] "" make utf8 decode ; + +: add-query-param ( value key assoc -- ) + [ + at [ + { + { [ dup string? ] [ swap 2array ] } + { [ dup array? ] [ swap suffix ] } + { [ dup not ] [ drop ] } + } cond + ] when* + ] 2keep set-at ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split H{ } clone [ + [ + [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip + add-query-param + ] curry each + ] keep + ] when ; + +: assoc>query ( hash -- str ) + [ + { + { [ dup number? ] [ number>string 1array ] } + { [ dup string? ] [ 1array ] } + { [ dup sequence? ] [ ] } + } cond + ] assoc-map + [ + [ + [ url-encode ] dip + [ url-encode "=" swap 3append , ] with each + ] assoc-each + ] { } make "&" join ; + +TUPLE: url protocol host port path query anchor ; + +: parse-host-part ( protocol rest -- string' ) + [ "protocol" set ] [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 [ + ":" split1 + [ url-decode "host" set ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when "port" set + ] bi* + ] [ "/" prepend ] bi* + ] bi* ; + +: string>url ( string -- url ) + [ + ":" split1 [ parse-host-part ] when* + "#" split1 [ + "?" split1 [ query>assoc "query" set ] when* + url-decode "path" set + ] [ + url-decode "anchor" set + ] bi* + ] url make-object ; + +: unparse-host-part ( protocol -- ) + % + "://" % + "host" get url-encode % + "port" get [ ":" % # ] when* + "path" get "/" head? [ "Invalid URL" throw ] unless ; + +: url>string ( url -- string ) + [ + [ + "protocol" get [ unparse-host-part ] when* + "path" get url-encode % + "query" get [ "?" % assoc>query % ] when* + "anchor" get [ "#" % url-encode % ] when* + ] bind + ] "" make ; + +: fix-relative-path ( url base -- url base ) + over path>> '[ + "/" ?tail drop "/" , 3append + ] change-path + [ f >>path ] dip ; inline + +: derive-url ( url base -- url' ) + clone + over path>> "/" head? [ fix-relative-path ] unless + [ swap [ nip ] assoc-filter update ] keep ; From 18f139394e38380ea277e06cae4e83e8874cf5ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 31 May 2008 23:38:10 -0500 Subject: [PATCH 25/30] remove throwable conecpt from db --- extra/db/db.factor | 25 ++----------------------- extra/db/queries/queries.factor | 5 ++--- extra/db/tuples/tuples.factor | 4 ++-- 3 files changed, 6 insertions(+), 28 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 4b98612069..8d1feca6c7 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -SINGLETON: throwable -SINGLETON: nonthrowable - -: make-throwable ( obj -- obj' ) - dup sequence? [ - [ make-throwable ] map - ] [ - throwable >>type - ] if ; - -: make-nonthrowable ( obj -- obj' ) - dup sequence? [ - [ make-nonthrowable ] map - ] [ - nonthrowable >>type - ] if ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) new swap >>out-params swap >>in-params - swap >>sql - throwable >>type ; + swap >>sql ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? ) GENERIC: execute-statement* ( statement type -- ) -M: throwable execute-statement* ( statement type -- ) +M: object execute-statement* ( statement type -- ) drop query-results dispose ; -M: nonthrowable execute-statement* ( statement type -- ) - drop [ query-results dispose ] [ 2drop ] recover ; - : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 9743e87f2e..59ee60aa1f 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -8,9 +8,8 @@ IN: db.queries GENERIC: where ( specs obj -- ) : maybe-make-retryable ( statement -- statement ) - dup in-params>> [ generator-bind? ] contains? [ - make-retryable - ] when ; + dup in-params>> [ generator-bind? ] contains? + [ make-retryable ] when ; : query-make ( class quot -- ) >r sql-props r> diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0a69b9cde8..bac141d6d2 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -112,8 +112,8 @@ M: retryable execute-statement* ( statement type -- ) : recreate-table ( class -- ) [ - drop-sql-statement make-nonthrowable - [ execute-statement ] with-disposals + [ drop-sql-statement [ execute-statement ] with-disposals + ] curry ignore-errors ] [ create-table ] bi ; : ensure-table ( class -- ) From e5b370194df041a54e6e2be37be9c3b15e66f0c4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 1 Jun 2008 00:02:24 -0500 Subject: [PATCH 26/30] re-enable postgresql tests --- extra/db/tuples/tuples-tests.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index e4a16d0b16..f9a597e814 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -199,10 +199,9 @@ 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 ( quot -- ) -! >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; +: test-postgresql ( quot -- ) + >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; -: test-postgresql drop ; : test-repeated-insert [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test From 9f0b470f7319ecf32248856525dac475dcbd7fcd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 1 Jun 2008 00:59:06 -0500 Subject: [PATCH 27/30] Improving URL library --- extra/namespaces/lib/lib.factor | 8 +++- extra/urls/urls-tests.factor | 84 +++++++++++++++++++++++---------- extra/urls/urls.factor | 49 ++++++++++++------- 3 files changed, 98 insertions(+), 43 deletions(-) diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 47b6b33a9a..851f60d126 100755 --- 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 math.parser math sequences.lib locals ; + assocs.lib math.parser math sequences.lib locals mirrors ; IN: namespaces.lib @@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- ) ] with-scope ] ] ; + +: make-object ( quot class -- object ) + new [ swap bind ] keep ; inline + +: with-object ( object quot -- ) + [ ] dip bind ; inline diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index dd319a1e65..e28816fdb3 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -87,6 +87,18 @@ urls [ swap [ 1array ] [ [ url>string ] curry ] bi* unit-test ] assoc-each +[ "b" ] [ "a" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/" "b" url-append-path ] unit-test + +[ "/b" ] [ "a" "/b" url-append-path ] unit-test + +[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test + +[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test + [ TUPLE{ url protocol: "http" @@ -95,10 +107,6 @@ urls [ path: "/a/path" } ] [ - TUPLE{ url - path: "/a/path" - } - TUPLE{ url protocol: "http" host: "www.apple.com" @@ -106,29 +114,7 @@ urls [ path: "/foo" } - derive-url -] unit-test - -[ TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path/relative/path" - query: H{ { "a" "b" } } - anchor: "foo" - } -] [ - TUPLE{ url - path: "relative/path" - query: H{ { "a" "b" } } - anchor: "foo" - } - - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 path: "/a/path" } @@ -145,12 +131,32 @@ urls [ anchor: "foo" } ] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + TUPLE{ url path: "relative/path" query: H{ { "a" "b" } } anchor: "foo" } + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ TUPLE{ url protocol: "http" host: "www.apple.com" @@ -158,5 +164,31 @@ urls [ path: "/a/path/" } + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/baz" + } +] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/bar" + } + + TUPLE{ url + path: "baz" + } + derive-url ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 86f3de651d..e20df65656 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: kernel unicode.categories combinators sequences splitting fry namespaces assocs arrays strings mirrors io.encodings.string io.encodings.utf8 @@ -89,17 +91,25 @@ IN: urls TUPLE: url protocol host port path query anchor ; +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; + +: parse-host ( string -- host port ) + ":" split1 [ url-decode ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when + ] bi* ; + : parse-host-part ( protocol rest -- string' ) [ "protocol" set ] [ "//" ?head [ "Invalid URL" throw ] unless "/" split1 [ - ":" split1 - [ url-decode "host" set ] [ - dup [ - string>number - dup [ "Invalid port" throw ] unless - ] when "port" set - ] bi* + parse-host [ "host" set ] [ "port" set ] bi* ] [ "/" prepend ] bi* ] bi* ; @@ -131,13 +141,20 @@ TUPLE: url protocol host port path query anchor ; ] bind ] "" make ; -: fix-relative-path ( url base -- url base ) - over path>> '[ - "/" ?tail drop "/" , 3append - ] change-path - [ f >>path ] dip ; inline +: url-append-path ( path1 path2 -- path ) + { + { [ dup "/" head? ] [ nip ] } + { [ dup empty? ] [ drop ] } + { [ over "/" tail? ] [ append ] } + { [ "/" pick start not ] [ nip ] } + [ [ "/" last-split1 drop "/" ] dip 3append ] + } cond ; -: derive-url ( url base -- url' ) - clone - over path>> "/" head? [ fix-relative-path ] unless - [ swap [ nip ] assoc-filter update ] keep ; +: derive-url ( base url -- url' ) + [ clone dup ] dip + 2dup [ path>> ] bi@ url-append-path + [ [ ] bi@ [ nip ] assoc-filter update ] dip + >>path ; + +: relative-url ( url -- url' ) + clone f >>protocol f >>host f >>port ; From f0e3008317d7373c3174ea4b39e76531c1ba78bc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 1 Jun 2008 10:46:02 -0500 Subject: [PATCH 28/30] Add dns.misc --- extra/dns/misc/misc.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 extra/dns/misc/misc.factor diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor new file mode 100644 index 0000000000..90731cec43 --- /dev/null +++ b/extra/dns/misc/misc.factor @@ -0,0 +1,12 @@ + +USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ; + +IN: dns.misc + +: resolv-conf-servers ( -- seq ) + "/etc/resolv.conf" utf8 file-lines + [ " " split ] map + [ 1st "nameserver" = ] filter + [ 2nd ] map ; + +: resolv-conf-server ( -- ip ) resolv-conf-servers random ; \ No newline at end of file From 34ba89025b8ad28573ae3a3b3e5094ddf11b9272 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 1 Jun 2008 10:46:38 -0500 Subject: [PATCH 29/30] combinators.lib: fix bug --- extra/combinators/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 2c7f2bbb03..3976b36cb9 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -90,7 +90,7 @@ MACRO: 2|| ( quots -- ? ) [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ; MACRO: 3|| ( quots -- ? ) - [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ; + [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ifte From 904f91298e886c33e1bce4aa3cc52e2c54b068a1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 1 Jun 2008 10:47:23 -0500 Subject: [PATCH 30/30] dns.forwarding: Refactor a bit. Add a main. --- extra/dns/forwarding/forwarding.factor | 64 +++++++++++++++++--------- 1 file changed, 41 insertions(+), 23 deletions(-) diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor index 5da04e25b6..1c60532bbc 100644 --- a/extra/dns/forwarding/forwarding.factor +++ b/extra/dns/forwarding/forwarding.factor @@ -2,10 +2,12 @@ USING: kernel combinators vectors + sequences io.sockets accessors + combinators.lib newfx - dns dns.cache ; + dns dns.cache dns.misc ; IN: dns.forwarding @@ -17,7 +19,10 @@ IN: dns.forwarding : socket ( -- socket ) (socket) 1st ; -: init-socket ( -- ) f 5353 0 (socket) as-mutate ; +: init-socket-on-port ( port -- ) + f swap 0 (socket) as-mutate ; + +: init-socket ( -- ) 53 init-socket-on-port ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -27,30 +32,37 @@ IN: dns.forwarding : set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ; +: init-upstream-server ( -- ) + upstream-server not + [ resolv-conf-server set-upstream-server ] + when ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: 1&& <-&& ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ; + : query->answer/cache ( query -- rrs/NX/f ) - { - { [ dup type>> CNAME = ] [ cache-get* ] } - { - [ dup clone CNAME >>type cache-get* vector? ] - [ - dup clone CNAME >>type cache-get* 1st ! query rr/cname - dup rdata>> ! query rr/cname cname - >r swap clone r> ! rr/cname query cname - >>name ! rr/cname query - query->answer/cache ! rr/cname rrs/NX/f - { - { [ dup vector? ] [ clone push-on ] } - { [ dup NX = ] [ nip ] } - { [ dup f = ] [ nip ] } - } - cond + dup cache-get* dup { [ rrs? ] [ NX = ] } 1|| + [ nip ] + [ + drop + dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1|| + [ nip ] + [ ! query rrs + tuck ! rrs query rrs + 1st ! rrs query rr/cname + rdata>> ! rrs query name + >r clone r> >>name ! rrs query + query->answer/cache ! rrs rrs/NX/f + dup rrs? [ append ] [ nip ] if ] - } - { [ t ] [ cache-get* ] } - } - cond ; + if + ] + if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -88,4 +100,10 @@ IN: dns.forwarding message->ba ! addr-spec byte-array swap ! byte-array addr-spec socket send - loop ; \ No newline at end of file + loop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: start ( -- ) init-socket init-upstream-server loop ; + +MAIN: start \ No newline at end of file