From d6ede4dda5c35c8c27819928958e09e4936f27ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 Feb 2008 16:52:00 -0600 Subject: [PATCH 01/25] intermediate work on db, everything is broken --- extra/db/postgresql/postgresql-tests.factor | 50 ++++++- extra/db/postgresql/postgresql.factor | 151 ++++++++++---------- extra/db/tuples/tuples-tests.factor | 41 +++++- extra/db/tuples/tuples.factor | 62 +++++--- extra/db/types/types.factor | 51 +++++-- 5 files changed, 243 insertions(+), 112 deletions(-) diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 36b6fc829b..9c98b53626 100644 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -1,8 +1,9 @@ ! You will need to run 'createdb factor-test' to create the database. ! Set username and password in the 'connect' word. -USING: kernel db.postgresql alien continuations io prettyprint -sequences namespaces tools.test db db.types ; +USING: kernel db.postgresql alien continuations io classes +prettyprint sequences namespaces tools.test db +db.tuples db.types unicode.case ; IN: temporary IN: scratchpad @@ -108,3 +109,48 @@ IN: temporary "select * from person" sql-query length ] with-db ] unit-test + + + +! TEST TUPLE DB + +TUPLE: puppy id name age ; +: ( name age -- puppy ) + { set-puppy-name set-puppy-age } puppy construct ; + +puppy "PUPPY" { + { "id" "ID" +native-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: kitty id name age ; +: ( name age -- kitty ) + { set-kitty-name set-kitty-age } kitty construct ; + +kitty "KITTY" { + { "id" "ID" +native-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: basket id puppies kitties ; +basket "BASKET" +{ + { "id" "ID" +native-id+ } + { "location" "LOCATION" TEXT } + { "puppies" { +has-many+ puppy } } + { "kitties" { +has-many+ kitty } } +} define-persistent + +[ + { "name" "age" } + ! "insert into table puppy(name, age) values($1, $2);" + "select add_puppy($1, $2, $3);" +] [ + T{ postgresql-db } db [ + "Mr Clunkers" 3 + class dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 03746bcaa0..b877d72060 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -4,7 +4,7 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators ; +combinators sequences.lib classes ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -117,52 +117,13 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -: postgresql-type-hash* ( -- assoc ) - H{ - { SERIAL "serial" } - } ; - -: postgresql-type-hash ( -- assoc ) - H{ - { INTEGER "integer" } - { SERIAL "integer" } - { TEXT "text" } - { VARCHAR "varchar" } - { DOUBLE "real" } - } ; - -: enquote ( str -- newstr ) "(" swap ")" 3append ; - -: postgresql-type ( str n/str -- newstr ) - " " swap number>string* enquote 3append ; - -: >sql-type* ( obj -- str ) - dup pair? [ - first2 >r >sql-type* r> postgresql-type - ] [ - dup postgresql-type-hash* at* [ - nip - ] [ - drop >sql-type - ] if - ] if ; - -M: postgresql-db >sql-type ( hash obj -- str ) - dup pair? [ - first2 >r >sql-type r> postgresql-type - ] [ - postgresql-type-hash at* [ - no-sql-type - ] unless - ] if ; - -: insert-function ( columns table -- sql ) +: insert-function ( columns table -- sql types ) [ >r remove-id r> "create function add_" % dup % "(" % over [ "," % ] - [ third dup array? [ first ] when >sql-type % ] interleave + [ third dup array? [ first ] when >sql-type-string % ] interleave ")" % " returns bigint as '" % @@ -177,31 +138,31 @@ M: postgresql-db >sql-type ( hash obj -- str ) "select currval(''" % % "_id_seq'');' language sql;" % drop - ] "" make ; + ] "" make f ; : drop-function ( columns table -- sql ) [ >r remove-id r> "drop function add_" % % "(" % - [ "," % ] [ third >sql-type % ] interleave + [ "," % ] [ third >sql-type-string % ] interleave ")" % - ] "" make ; + ] "" nmake ; -M: postgresql-db create-sql ( columns table -- seq ) - [ - [ - 2dup - "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type* % " " % - sql-modifiers " " join % - ] interleave "); " % - ] "" make , - - over native-id? [ insert-function , ] [ 2drop ] if - ] { } make ; +! M: postgresql-db create-sql ( columns table -- seq ) + ! [ + ! [ + ! 2dup + ! "create table " % % + ! " (" % [ ", " % ] [ + ! dup second % " " % + ! dup third >sql-type-string % " " % + ! sql-modifiers " " join % + ! ] interleave "); " % + ! ] "" make , +! + ! over native-id? [ insert-function , ] [ 2drop ] if + ! ] { } make ; M: postgresql-db drop-sql ( columns table -- seq ) [ @@ -211,15 +172,15 @@ M: postgresql-db drop-sql ( columns table -- seq ) over native-id? [ drop-function , ] [ 2drop ] if ] { } make ; -M: postgresql-db insert-sql* ( columns table -- slot-names sql ) +M: postgresql-db insert-sql* ( columns table -- sql slots ) [ "select add_" % % "(" % - length [1,b] [ ", " % ] [ "$" % # ] interleave - ")" % + dup length [1,b] [ ", " % ] [ "$" % # ] interleave + ");" % ] "" make ; -M: postgresql-db update-sql* ( columns table -- slot-names sql ) +M: postgresql-db update-sql* ( columns table -- sql slots ) [ "update " % % @@ -239,8 +200,42 @@ M: postgresql-db delete-sql* ( columns table -- slot-names sql ) first second % " = $1" % ] "" make ; -M: postgresql-db select-sql ( columns table -- slot-names sql ) - drop ; +: column-name% ( spec -- ) + dup sql-spec-column-name 0% + sql-spec-type >sql-type-string 1, ; + +: column-names% ( class -- ) + db-columns [ "," 0, ] [ column-name% ] interleave ; + +M: postgresql-db column-bind% ( spec -- ) + + + ; + + +! : select-foreign-table-sql ( tuple relation -- ) +! ! select id, name, age from puppy, basket where puppy.basket_id = basket.id + ! "select " 0% + ! ; +! TODO +: select-relations-sql ( tuple -- seq ) + ! seq -- { sql types } + dup class db-relations [ + [ + ! select-foreign-table-sql + ] { "" { } } 2 nmake + ] with { } map>assoc ; + +! TODO +: select-by-slots-sql ( tuple -- sql ) + dup tuple>filled-slots + ; + + +M: postgresql-db select-sql ( tuple -- sql slot-names ) + [ + + ] { } 2 nmake ; M: postgresql-db tuple>params ( columns tuple -- obj ) [ >r dup third swap first r> get-slot-named swap ] @@ -248,7 +243,8 @@ M: postgresql-db tuple>params ( columns tuple -- obj ) : postgresql-db-modifiers ( -- hashtable ) H{ - { +native-id+ "not null primary key" } + { +native-id+ "primary key" } + { +foreign-key+ "" } { +assigned-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } @@ -257,13 +253,16 @@ M: postgresql-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -M: postgresql-db sql-modifiers* ( modifiers -- str ) - postgresql-db-modifiers swap [ - dup array? [ - first2 - >r swap at r> number>string* - " " swap 3append - ] [ - swap at - ] if - ] with map [ ] subset ; +! M: postgresql-db sql-modifier>string ( modifier -- str ) + ! dup array? [ + ! first2 + ! >r swap at r> number>string* + ! " " swap 3append + ! ] [ + ! swap at + ! ] if ; +! +! M: postgresql-db sql-modifiers* ( modifiers -- str ) + ! postgresql-db-modifiers swap [ + ! sql-modifier>string + ! ] with map [ ] subset ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index ea57193750..7df0b430de 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -54,7 +54,7 @@ person "PERSON" "billy" 10 3.14 the-person set ! test-sqlite - test-postgresql +! test-postgresql ! person "PERSON" ! { @@ -68,3 +68,42 @@ person "PERSON" ! test-sqlite ! test-postgresql + +TUPLE: paste n summary author channel mode contents timestamp annotations ; +TUPLE: annotation n paste-id summary author mode contents ; + +paste "PASTE" +{ + { "n" "ID" SERIAL +native-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "date" "DATE" TIMESTAMP } + { "annotations" { +has-many+ annotation } } +} define-persistent + +! n + ! NO: drop insert + ! YES: create update delete select +! annotations + ! NO: create drop insert update delete + ! YES: select + +annotation "ANNOTATION" +{ + { "n" "ID" SERIAL +native-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-key+ paste "n" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } +} define-persistent + +"localhost" "postgres" "" "factor-test" [ + ! paste drop-table + ! annotation drop-table + paste create-table + annotation create-table +] with-db diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 20cdd8a386..30ca260b93 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -2,11 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces tuples words sequences slots slots.private math -math.parser io prettyprint db.types continuations ; +math.parser io prettyprint db.types continuations +mirrors sequences.lib ; IN: db.tuples -: db-columns ( class -- obj ) "db-columns" word-prop ; : db-table ( class -- obj ) "db-table" word-prop ; +: db-columns ( class -- obj ) "db-columns" word-prop ; +: db-relations ( class -- obj ) "db-relations" word-prop ; TUPLE: no-slot-named ; : no-slot-named ( -- * ) T{ no-slot-named } throw ; @@ -41,26 +43,15 @@ TUPLE: no-slot-named ; HOOK: create-sql db ( columns table -- seq ) HOOK: drop-sql db ( columns table -- seq ) -HOOK: insert-sql* db ( columns table -- slot-names sql ) -HOOK: update-sql* db ( columns table -- slot-names sql ) -HOOK: delete-sql* db ( columns table -- slot-names sql ) -HOOK: select-sql db ( tuple -- statement ) +HOOK: insert-sql* db ( columns table -- sql slot-names ) +HOOK: update-sql* db ( columns table -- sql slot-names ) +HOOK: delete-sql* db ( columns table -- sql slot-names ) +HOOK: select-sql db ( tuple -- seq/statement ) HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: sql-type>factor-type db ( obj type -- obj ) HOOK: tuple>params db ( columns tuple -- obj ) - -HOOK: make-slot-names* db ( quot -- seq ) -HOOK: column-slot-name% db ( spec -- ) -HOOK: column-bind-name% db ( spec -- ) - -: make-slots-names ( quot -- seq str ) - [ make-slot-names* ] "" make ; inline -: slot-name% ( seq -- ) first % ; -: column-name% ( seq -- ) second % ; -: column-type% ( seq -- ) third % ; - : insert-sql ( columns class -- statement ) db get db-insert-statements [ insert-sql* ] cache-statement ; @@ -108,8 +99,37 @@ HOOK: column-bind-name% db ( spec -- ) dup primary-key [ update-tuple ] [ insert-tuple ] if ; : define-persistent ( class table columns -- ) - >r dupd "db-table" set-word-prop r> - "db-columns" set-word-prop ; + >r dupd "db-table" set-word-prop dup r> + [ relation? ] partition swapd + [ spec>tuple ] map "db-columns" set-word-prop + "db-relations" set-word-prop ; -: define-relation ( spec -- ) - drop ; +: tuple>filled-slots ( tuple -- alist ) + dup mirror-slots [ slot-spec-name ] map + swap tuple-slots 2array flip [ nip ] assoc-subset ; + +! [ tuple>filled-slots ] keep +! [ >r first r> get-slot-named ] curry each + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, get-building-seq push ; +: n% get-building-seq push-all ; + +: 0, 0 n, ; +: 0% 0 n% ; +: 1, 1 n, ; +: 1% 1 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 ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 7cacbcf861..b75d3616f1 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser -sequences continuations ; +sequences continuations sequences.deep sequences.lib ; IN: db.types ! ID is the Primary key @@ -17,6 +17,8 @@ SYMBOL: +assigned-id+ : assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; : native-id? ( columns -- ? ) +native-id+ contains-id? ; +SYMBOL: +foreign-key+ + ! Same concept, SQLite has autoincrement, PostgreSQL has serial SYMBOL: +autoincrement+ SYMBOL: +serial+ @@ -28,9 +30,13 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ -SYMBOL: SERIAL +: relation? ( spec -- ? ) + [ +has-many+ = ] deep-find* nip ; + SYMBOL: INTEGER +SYMBOL: BIG_INTEGER SYMBOL: DOUBLE + SYMBOL: BOOLEAN SYMBOL: TEXT @@ -39,29 +45,50 @@ SYMBOL: VARCHAR SYMBOL: TIMESTAMP SYMBOL: DATE -SYMBOL: BIG_INTEGER - TUPLE: no-sql-type ; : no-sql-type ( -- * ) T{ no-sql-type } throw ; -HOOK: sql-modifiers* db ( modifiers -- str ) -HOOK: >sql-type db ( obj -- str ) - -! HOOK: >factor-type db ( obj -- obj ) - : number>string* ( n/str -- str ) dup number? [ number>string ] when ; : maybe-remove-id ( columns -- obj ) [ +native-id+ swap member? not ] subset ; +: remove-relations ( columns -- newcolumns ) + [ relation? not ] subset ; + : remove-id ( columns -- obj ) [ primary-key? not ] subset ; -: sql-modifiers ( spec -- seq ) - 3 tail sql-modifiers* ; - ! SQLite Types: http://www.sqlite.org/datatype3.html ! NULL INTEGER REAL TEXT BLOB ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html + +TUPLE: sql-spec slot-name column-name type modifiers ; + +: spec>tuple ( spec -- tuple ) + [ ?first3 ] keep 3 ?tail* sql-spec construct-boa ; + +: sql-type-hash ( -- assoc ) + H{ + { INTEGER "integer" } + { TEXT "text" } + { VARCHAR "varchar" } + { DOUBLE "real" } + { TIMESTAMP "timestamp" } + } ; + +! HOOK: sql-type-hash db ( -- obj ) +! HOOK: >sql-type-string db ( obj -- str ) + +: >sql-type-string ( obj -- str/f ) + dup pair? [ + first >sql-type-string + ] [ + sql-type-hash at* [ drop "" ] unless + ] if ; + +: full-sql-type-string ( obj -- str ) + [ >sql-type-string ] keep second + number>string " " swap 3append ; From d98fd6e758dfdd68eb7f7444a1acabafcb255bdd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 Feb 2008 17:07:01 -0600 Subject: [PATCH 02/25] add ?subseq, ?tail*, ?head* --- extra/sequences/lib/lib-tests.factor | 4 +--- extra/sequences/lib/lib.factor | 13 +++++++++++-- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 2f50ad1786..d4af66b72f 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -20,8 +20,6 @@ IN: temporary [ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test [ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test - [ -4 ] [ 1 -4 [ abs ] higher ] unit-test [ 1 ] [ 1 -4 [ abs ] lower ] unit-test @@ -80,4 +78,4 @@ IN: temporary { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test +[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1beec90b75..c02932a020 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -18,8 +18,9 @@ IN: sequences.lib : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline -MACRO: nfirst ( n -- ) - [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ; +MACRO: firstn ( n -- ) + [ [ swap nth ] curry + [ keep ] curry ] map concat [ drop ] compose ; : prepare-index ( seq quot -- seq n quot ) >r dup length r> ; inline @@ -182,6 +183,14 @@ PRIVATE> : ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline : ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline +USE: continuations +: ?subseq ( from to seq -- subseq ) + >r >r 0 max r> r> + [ length tuck min >r min r> ] keep subseq ; + +: ?head* ( seq n -- seq/f ) (head) ?subseq ; +: ?tail* ( seq n -- seq/f ) (tail) ?subseq ; + : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; From c12600815f6833da3238db473c46797ba37cffe6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 19 Feb 2008 16:00:50 -0600 Subject: [PATCH 03/25] add lots of unit tests to postgresql select queries are generated now --- extra/db/db.factor | 8 +- extra/db/postgresql/lib/lib.factor | 4 +- extra/db/postgresql/postgresql-tests.factor | 226 ++++++++++++++- extra/db/postgresql/postgresql.factor | 289 +++++++++++--------- extra/db/tuples/tuples.factor | 8 +- extra/db/types/types.factor | 128 ++++++--- 6 files changed, 480 insertions(+), 183 deletions(-) mode change 100644 => 100755 extra/db/postgresql/lib/lib.factor mode change 100644 => 100755 extra/db/postgresql/postgresql-tests.factor diff --git a/extra/db/db.factor b/extra/db/db.factor index d88bbaee03..fe8459031e 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -23,12 +23,12 @@ HOOK: db-close db ( handle -- ) db-handle db-close ] with-variable ; -TUPLE: statement sql params handle bound? slot-names ; +TUPLE: statement handle sql slot-names bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; HOOK: db ( str -- statement ) -HOOK: db ( str -- statement ) +HOOK: db ( str slot-names -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: reset-statement ( statement -- ) @@ -47,7 +47,7 @@ GENERIC: more-rows? ( result-set -- ? ) : bind-statement ( obj statement -- ) dup statement-bound? [ dup reset-statement ] when [ bind-statement* ] 2keep - [ set-statement-params ] keep + [ set-statement-bind-params ] keep t swap set-statement-bound? ; : init-result-set ( result-set -- ) @@ -55,7 +55,7 @@ GENERIC: more-rows? ( result-set -- ? ) 0 swap set-result-set-n ; : ( query handle tuple -- result-set ) - >r >r { statement-sql statement-params } get-slots r> + >r >r { statement-sql statement-bind-params } get-slots r> { set-result-set-sql set-result-set-params diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor old mode 100644 new mode 100755 index c48eff964a..8a0e24e4cb --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -37,8 +37,8 @@ IN: db.postgresql.lib : do-postgresql-bound-statement ( statement -- res ) >r db get db-handle r> [ statement-sql ] keep - [ statement-params length f ] keep - statement-params + [ statement-bind-params length f ] keep + statement-bind-params [ first number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor old mode 100644 new mode 100755 index 9c98b53626..bdb434cfdd --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -111,6 +111,8 @@ IN: temporary ] unit-test +: with-dummy-db ( quot -- ) + >r T{ postgresql-db } db r> with-variable ; ! TEST TUPLE DB @@ -119,8 +121,8 @@ TUPLE: puppy id name age ; { set-puppy-name set-puppy-age } puppy construct ; puppy "PUPPY" { - { "id" "ID" +native-id+ } - { "name" "NAME" TEXT } + { "id" "ID" +native-id+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } { "age" "AGE" INTEGER } } define-persistent @@ -129,7 +131,7 @@ TUPLE: kitty id name age ; { set-kitty-name set-kitty-age } kitty construct ; kitty "KITTY" { - { "id" "ID" +native-id+ } + { "id" "ID" INTEGER +assigned-id+ } { "name" "NAME" TEXT } { "age" "AGE" INTEGER } } define-persistent @@ -137,20 +139,226 @@ kitty "KITTY" { TUPLE: basket id puppies kitties ; basket "BASKET" { - { "id" "ID" +native-id+ } + { "id" "ID" +native-id+ +not-null+ } { "location" "LOCATION" TEXT } { "puppies" { +has-many+ puppy } } { "kitties" { +has-many+ kitty } } } define-persistent +! Create table [ - { "name" "age" } - ! "insert into table puppy(name, age) values($1, $2);" - "select add_puppy($1, $2, $3);" + "create table puppy(id serial primary key not null, name varchar 256, age integer);" ] [ T{ postgresql-db } db [ - "Mr Clunkers" 3 - class dup db-columns swap db-table insert-sql* >lower + puppy dup db-columns swap db-table create-table-sql >lower ] with-variable ] unit-test +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id serial primary key not null, location text);" +] [ + T{ postgresql-db } db [ + basket dup db-columns swap db-table create-table-sql >lower + ] with-variable +] unit-test + +! Create function +[ + "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table create-function-sql >lower + ] with-variable +] unit-test + +! Drop table + +[ + "drop table puppy;" +] [ + T{ postgresql-db } db [ + puppy db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ postgresql-db } db [ + kitty db-table drop-table-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ postgresql-db } db [ + basket db-table drop-table-sql >lower + ] with-variable +] unit-test + + +! Drop function +[ + "drop function add_puppy(varchar, integer);" +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table drop-function-sql >lower + ] with-variable +] unit-test + +! Insert +[ + "select add_puppy($1, $2);" + { + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } } + T{ sql-spec f "age" "AGE" INTEGER { } } + } + { + T{ sql-spec f "id" "ID" +native-id+ { +not-null+ } +native-id+ } + } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table insert-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values($1, $2, $3);" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table insert-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table update-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "update kitty set name = $1, age = $2 where id = $3" + { + T{ sql-spec f "name" "NAME" TEXT { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table update-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = $1" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + puppy dup db-columns swap db-table delete-sql* >r >r >lower r> r> + ] with-variable +] unit-test + +[ + "delete from KITTY where ID = $1" + { + T{ + sql-spec + f + "id" + "ID" + INTEGER + { +assigned-id+ } + +assigned-id+ + } + } + { } +] [ + T{ postgresql-db } db [ + kitty dup db-columns swap db-table delete-sql* + ] with-variable +] unit-test + +! Select +[ + "select from PUPPY ID, NAME, AGE where NAME = $1;" + { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } } + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } +] [ + T{ postgresql-db } db [ + T{ puppy f f "Mr. Clunkers" } + select-by-slots-sql + ] with-variable +] unit-test diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index b877d72060..3e949c3900 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -4,7 +4,7 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators sequences.lib classes ; +combinators sequences.lib classes locals words ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -39,7 +39,7 @@ M: postgresql-db dispose ( db -- ) >r r> with-disposal ; M: postgresql-statement bind-statement* ( seq statement -- ) - set-statement-params ; + set-statement-bind-params ; M: postgresql-statement reset-statement ( statement -- ) drop ; @@ -68,7 +68,7 @@ M: postgresql-statement insert-statement ( statement -- id ) query-results [ 0 row-column ] with-disposal string>number ; M: postgresql-statement query-results ( query -- result-set ) - dup statement-params [ + dup statement-bind-params [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -96,7 +96,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ >r db get db-handle "" r> - dup statement-sql swap statement-params + dup statement-sql swap statement-bind-params length f PQprepare postgresql-error ] keep set-statement-handle ; @@ -104,9 +104,10 @@ M: postgresql-db ( sql -- statement ) { set-statement-sql } statement construct ; -M: postgresql-db ( sql -- statement ) - { set-statement-sql } statement construct - ; +M: postgresql-db ( pair -- statement ) + ?first2 + { set-statement-sql set-statement-slot-names } + statement construct ; M: postgresql-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -117,134 +118,179 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -: insert-function ( columns table -- sql types ) +: modifiers% ( spec -- ) + sql-spec-modifiers + [ lookup-modifier ] map + " " join + dup empty? [ drop ] [ " " % % ] if ; + +SYMBOL: postgresql-counter +: bind% ( spec -- ) + 1, + CHAR: $ 0, + postgresql-counter [ inc ] keep get 0# ; + +: postgresql-make ( quot -- ) + [ postgresql-counter off ] swap compose + { "" { } { } } nmake ; + +:: create-table-sql | specs table | [ - >r remove-id r> - "create function add_" % dup % + "create table " % table % "(" % - over [ "," % ] - [ third dup array? [ first ] when >sql-type-string % ] interleave - ")" % - " returns bigint as '" % + specs [ ", " % ] [ + dup sql-spec-column-name % + " " % + dup sql-spec-type t lookup-type % + modifiers% + ] interleave ");" % + ] "" make ; - 2dup "insert into " % - % - "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - length [1,b] [ ", " % ] [ "$" % # ] interleave - "); " % - - "select currval(''" % % "_id_seq'');' language sql;" % - drop - ] "" make f ; - -: drop-function ( columns table -- sql ) +:: create-function-sql | specs table | + [ + [let | specs [ specs remove-id ] | + "create function add_" 0% table 0% + "(" 0% + specs [ "," 0% ] + [ + sql-spec-type f lookup-type 0% + ] interleave + ")" 0% + " returns bigint as '" 0% + + "insert into " 0% + table 0% + "(" 0% + specs [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + specs [ ", " 0% ] [ bind% ] interleave + "); " 0% + + "select currval(''" 0% table 0% "_id_seq'');' language sql;" 0% + ] + ] postgresql-make 2drop ; + +: drop-function-sql ( specs table -- sql ) [ - >r remove-id r> "drop function add_" % % "(" % - [ "," % ] [ third >sql-type-string % ] interleave - ")" % - ] "" nmake ; - -! M: postgresql-db create-sql ( columns table -- seq ) - ! [ - ! [ - ! 2dup - ! "create table " % % - ! " (" % [ ", " % ] [ - ! dup second % " " % - ! dup third >sql-type-string % " " % - ! sql-modifiers " " join % - ! ] interleave "); " % - ! ] "" make , -! - ! over native-id? [ insert-function , ] [ 2drop ] if - ! ] { } make ; - -M: postgresql-db drop-sql ( columns table -- seq ) - [ - [ - dup "drop table " % % ";" % - ] "" make , - over native-id? [ drop-function , ] [ 2drop ] if - ] { } make ; - -M: postgresql-db insert-sql* ( columns table -- sql slots ) - [ - "select add_" % % - "(" % - dup length [1,b] [ ", " % ] [ "$" % # ] interleave + remove-id + [ ", " % ] [ sql-spec-type f lookup-type % ] interleave ");" % ] "" make ; -M: postgresql-db update-sql* ( columns table -- sql slots ) +: drop-table-sql ( table -- sql ) [ - "update " % - % - " set " % + "drop table " % % ";" % + ] "" make ; + +M: postgresql-db create-sql ( specs table -- seq ) + [ + 2dup create-table-sql , + over find-primary-key native-id? + [ create-function-sql , ] [ 2drop ] if + ] { } make ; + +M: postgresql-db drop-sql ( specs table -- seq ) + [ + dup drop-table-sql , + over find-primary-key native-id? + [ drop-function-sql , ] [ 2drop ] if + ] { } make ; + +: insert-table-sql ( specs table -- sql in-specs out-specs ) + [ + "insert into " 0% 0% + "(" 0% + dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ")" 0% + + " values(" 0% + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +: insert-function-sql ( specs table -- sql in-specs out-specs ) + [ + "select add_" 0% 0% + "(" 0% + dup find-primary-key 2, + remove-id + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +M: postgresql-db insert-sql* ( specs table -- sql in-specs out-specs ) + over find-primary-key native-id? + [ insert-function-sql ] [ insert-table-sql ] if ; + +M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs ) + [ + "update " 0% 0% + " set " 0% dup remove-id - dup length [1,b] swap 2array flip - [ ", " % ] [ first2 second % " = $" % # ] interleave - " where " % - [ primary-key? ] find nip second dup % " = $" % length 2 + # - ] "" make ; + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; -M: postgresql-db delete-sql* ( columns table -- slot-names sql ) +M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs ) [ - "delete from " % - % - " where " % - first second % " = $1" % - ] "" make ; + "delete from " 0% 0% + " where " 0% + find-primary-key + dup sql-spec-column-name 0% " = " 0% bind% + ] postgresql-make ; -: column-name% ( spec -- ) - dup sql-spec-column-name 0% - sql-spec-type >sql-type-string 1, ; - -: column-names% ( class -- ) - db-columns [ "," 0, ] [ column-name% ] interleave ; - -M: postgresql-db column-bind% ( spec -- ) - - - ; - - -! : select-foreign-table-sql ( tuple relation -- ) -! ! select id, name, age from puppy, basket where puppy.basket_id = basket.id - ! "select " 0% - ! ; -! TODO -: select-relations-sql ( tuple -- seq ) - ! seq -- { sql types } - dup class db-relations [ - [ - ! select-foreign-table-sql - ] { "" { } } 2 nmake - ] with { } map>assoc ; - -! TODO -: select-by-slots-sql ( tuple -- sql ) - dup tuple>filled-slots - ; - - -M: postgresql-db select-sql ( tuple -- sql slot-names ) +: select-by-slots-sql ( tuple -- sql in-specs out-specs ) [ - - ] { } 2 nmake ; + "select from " 0% dup class db-table 0% + " " 0% + dup class db-columns [ ", " 0% ] + [ dup sql-spec-column-name 0% 2, ] interleave -M: postgresql-db tuple>params ( columns tuple -- obj ) + dup class db-columns + [ sql-spec-slot-name swap get-slot-named ] with subset + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] postgresql-make ; + +! : select-with-relations ( tuple -- sql in-specs out-specs ) + +M: postgresql-db select-sql ( tuple -- sql in-specs out-specs ) + select-by-slots-sql ; + +M: postgresql-db tuple>params ( specs tuple -- obj ) [ >r dup third swap first r> get-slot-named swap ] curry { } map>assoc ; + +M: postgresql-db type-table ( -- hash ) + H{ + { +native-id+ "integer" } + { TEXT "text" } + { VARCHAR "varchar" } + { INTEGER "integer" } + } ; + +M: postgresql-db create-type-table ( -- hash ) + H{ + { +native-id+ "serial primary key" } + } ; + +: postgresql-compound ( str n -- newstr ) + dup number? [ "compound -- not a number" throw ] unless + number>string " " swap 3append ; + +M: postgresql-db compound-modifier ( str n -- newstr ) + postgresql-compound ; -: postgresql-db-modifiers ( -- hashtable ) +M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } - { +foreign-key+ "" } { +assigned-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } @@ -253,16 +299,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -! M: postgresql-db sql-modifier>string ( modifier -- str ) - ! dup array? [ - ! first2 - ! >r swap at r> number>string* - ! " " swap 3append - ! ] [ - ! swap at - ! ] if ; -! -! M: postgresql-db sql-modifiers* ( modifiers -- str ) - ! postgresql-db-modifiers swap [ - ! sql-modifier>string - ! ] with map [ ] subset ; +M: postgresql-db compound-type ( str n -- newstr ) + postgresql-compound ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 30ca260b93..9c22ba2a65 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -47,6 +47,7 @@ HOOK: insert-sql* db ( columns table -- sql slot-names ) HOOK: update-sql* db ( columns table -- sql slot-names ) HOOK: delete-sql* db ( columns table -- sql slot-names ) HOOK: select-sql db ( tuple -- seq/statement ) +HOOK: select-relations-sql db ( tuple -- seq/statement ) HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: sql-type>factor-type db ( obj type -- obj ) @@ -101,7 +102,8 @@ HOOK: tuple>params db ( columns tuple -- obj ) : define-persistent ( class table columns -- ) >r dupd "db-table" set-word-prop dup r> [ relation? ] partition swapd - [ spec>tuple ] map "db-columns" set-word-prop + [ spec>tuple ] map + "db-columns" set-word-prop "db-relations" set-word-prop ; : tuple>filled-slots ( tuple -- alist ) @@ -117,13 +119,17 @@ SYMBOL: building-seq : 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 diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index b75d3616f1..9354f4fe37 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -1,21 +1,38 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser -sequences continuations sequences.deep sequences.lib ; +sequences continuations sequences.deep sequences.lib +words ; IN: db.types +TUPLE: sql-spec slot-name column-name type modifiers primary-key ; ! ID is the Primary key +! +native-id+ can be a columns type or a modifier SYMBOL: +native-id+ +! +assigned-id+ can only be a modifier SYMBOL: +assigned-id+ -: primary-key? ( spec -- ? ) - [ { +native-id+ +assigned-id+ } member? ] contains? ; +: primary-key? ( obj -- ? ) + { +native-id+ +assigned-id+ } member? ; -: contains-id? ( columns id -- ? ) - swap [ member? ] with contains? ; - -: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; -: native-id? ( columns -- ? ) +native-id+ contains-id? ; +: normalize-spec ( spec -- ) + dup sql-spec-type dup primary-key? [ + swap set-sql-spec-primary-key + ] [ + drop dup sql-spec-modifiers [ + primary-key? + ] deep-find + [ swap set-sql-spec-primary-key ] [ drop ] if* + ] if ; + +: find-primary-key ( specs -- obj ) + [ sql-spec-primary-key ] find nip ; + +: native-id? ( spec -- ? ) + sql-spec-primary-key +native-id+ = ; + +: assigned-id? ( spec -- ? ) + sql-spec-primary-key +assigned-id+ = ; SYMBOL: +foreign-key+ @@ -31,7 +48,7 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ : relation? ( spec -- ? ) - [ +has-many+ = ] deep-find* nip ; + [ +has-many+ = ] deep-find ; SYMBOL: INTEGER SYMBOL: BIG_INTEGER @@ -45,30 +62,15 @@ SYMBOL: VARCHAR SYMBOL: TIMESTAMP SYMBOL: DATE -TUPLE: no-sql-type ; -: no-sql-type ( -- * ) T{ no-sql-type } throw ; - -: number>string* ( n/str -- str ) - dup number? [ number>string ] when ; - -: maybe-remove-id ( columns -- obj ) - [ +native-id+ swap member? not ] subset ; - -: remove-relations ( columns -- newcolumns ) - [ relation? not ] subset ; - -: remove-id ( columns -- obj ) - [ primary-key? not ] subset ; - -! SQLite Types: http://www.sqlite.org/datatype3.html -! NULL INTEGER REAL TEXT BLOB -! PostgreSQL Types: -! http://developer.postgresql.org/pgdocs/postgres/datatype.html - -TUPLE: sql-spec slot-name column-name type modifiers ; - : spec>tuple ( spec -- tuple ) - [ ?first3 ] keep 3 ?tail* sql-spec construct-boa ; + [ ?first3 ] keep 3 ?tail* + { + set-sql-spec-slot-name + set-sql-spec-column-name + set-sql-spec-type + set-sql-spec-modifiers + } sql-spec construct + dup normalize-spec ; : sql-type-hash ( -- assoc ) H{ @@ -79,16 +81,62 @@ TUPLE: sql-spec slot-name column-name type modifiers ; { TIMESTAMP "timestamp" } } ; -! HOOK: sql-type-hash db ( -- obj ) -! HOOK: >sql-type-string db ( obj -- str ) +TUPLE: no-sql-type ; +: no-sql-type ( -- * ) T{ no-sql-type } throw ; -: >sql-type-string ( obj -- str/f ) +TUPLE: no-sql-modifier ; +: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; + +: number>string* ( n/str -- str ) + dup number? [ number>string ] when ; + +: maybe-remove-id ( specs -- obj ) + [ native-id? not ] subset ; + +: remove-relations ( specs -- newcolumns ) + [ relation? not ] subset ; + +: remove-id ( specs -- obj ) + [ sql-spec-primary-key not ] subset ; + +! SQLite Types: http://www.sqlite.org/datatype3.html +! NULL INTEGER REAL TEXT BLOB +! PostgreSQL Types: +! http://developer.postgresql.org/pgdocs/postgres/datatype.html + + + +HOOK: modifier-table db ( -- hash ) +HOOK: compound-modifier db ( str n -- hash ) + +: lookup-modifier ( obj -- str ) dup pair? [ - first >sql-type-string + first2 >r lookup-modifier r> compound-modifier ] [ - sql-type-hash at* [ drop "" ] unless + modifier-table at* + [ "unknown modifier" throw ] unless ] if ; -: full-sql-type-string ( obj -- str ) - [ >sql-type-string ] keep second - number>string " " swap 3append ; + +HOOK: type-table db ( -- hash ) +HOOK: create-type-table db ( -- hash ) +HOOK: compound-type db ( str n -- hash ) + +: lookup-type* ( obj -- str ) + dup pair? [ + first lookup-type* + ] [ + type-table at* + [ no-sql-type ] unless + ] if ; + +: lookup-create-type ( obj -- str ) + dup pair? [ + first2 >r lookup-create-type r> compound-type + ] [ + dup create-type-table at* + [ nip ] [ drop lookup-type* ] if + ] if ; + +: lookup-type ( obj create? -- str ) + [ lookup-create-type ] [ lookup-type* ] if ; From 779bd8c8d9ea5118a6403d20afabfefbfe1cc660 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 Feb 2008 11:30:48 -0600 Subject: [PATCH 04/25] sql is correctly generated for sqlite and postgresql up to basic selects --- extra/db/db.factor | 6 +- extra/db/postgresql/lib/lib.factor | 4 +- extra/db/postgresql/postgresql.factor | 27 +++-- extra/db/sqlite/lib/lib.factor | 4 +- extra/db/sqlite/sqlite-tests.factor | 157 +++++++++++++++++++++++++- extra/db/sqlite/sqlite.factor | 107 +++++++++--------- extra/db/tuples/tuples-tests.factor | 26 ++--- extra/db/tuples/tuples.factor | 1 - extra/db/types/types.factor | 33 ++++-- 9 files changed, 269 insertions(+), 96 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index fe8459031e..d269d4654c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -23,7 +23,7 @@ HOOK: db-close db ( handle -- ) db-handle db-close ] with-variable ; -TUPLE: statement handle sql slot-names bind-params bound? ; +TUPLE: statement handle sql slot-names bound? in-params out-params ; TUPLE: simple-statement ; TUPLE: prepared-statement ; @@ -47,7 +47,7 @@ GENERIC: more-rows? ( result-set -- ? ) : bind-statement ( obj statement -- ) dup statement-bound? [ dup reset-statement ] when [ bind-statement* ] 2keep - [ set-statement-bind-params ] keep + [ set-statement-in-params ] keep t swap set-statement-bound? ; : init-result-set ( result-set -- ) @@ -55,7 +55,7 @@ GENERIC: more-rows? ( result-set -- ? ) 0 swap set-result-set-n ; : ( query handle tuple -- result-set ) - >r >r { statement-sql statement-bind-params } get-slots r> + >r >r { statement-sql statement-in-params } get-slots r> { set-result-set-sql set-result-set-params diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 8a0e24e4cb..5f24dd9ea0 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -37,8 +37,8 @@ IN: db.postgresql.lib : do-postgresql-bound-statement ( statement -- res ) >r db get db-handle r> [ statement-sql ] keep - [ statement-bind-params length f ] keep - statement-bind-params + [ statement-in-params length f ] keep + statement-in-params [ first number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 3e949c3900..8cf7e79f53 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -39,7 +39,7 @@ M: postgresql-db dispose ( db -- ) >r r> with-disposal ; M: postgresql-statement bind-statement* ( seq statement -- ) - set-statement-bind-params ; + set-statement-in-params ; M: postgresql-statement reset-statement ( statement -- ) drop ; @@ -68,7 +68,7 @@ M: postgresql-statement insert-statement ( statement -- id ) query-results [ 0 row-column ] with-disposal string>number ; M: postgresql-statement query-results ( query -- result-set ) - dup statement-bind-params [ + dup statement-in-params [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -96,7 +96,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ >r db get db-handle "" r> - dup statement-sql swap statement-bind-params + dup statement-sql swap statement-in-params length f PQprepare postgresql-error ] keep set-statement-handle ; @@ -118,12 +118,6 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -: modifiers% ( spec -- ) - sql-spec-modifiers - [ lookup-modifier ] map - " " join - dup empty? [ drop ] [ " " % % ] if ; - SYMBOL: postgresql-counter : bind% ( spec -- ) 1, @@ -274,6 +268,7 @@ M: postgresql-db type-table ( -- hash ) { TEXT "text" } { VARCHAR "varchar" } { INTEGER "integer" } + { TIMESTAMP "timestamp" } } ; M: postgresql-db create-type-table ( -- hash ) @@ -282,16 +277,24 @@ M: postgresql-db create-type-table ( -- hash ) } ; : postgresql-compound ( str n -- newstr ) - dup number? [ "compound -- not a number" throw ] unless - number>string " " swap 3append ; + over { + { "varchar" [ first number>string join-space ] } + { "references" + [ + first2 >r [ unparse join-space ] keep db-columns r> + swap [ sql-spec-slot-name = ] with find nip sql-spec-column-name paren append + ] } + [ "no compound found" 3array throw ] + } case ; -M: postgresql-db compound-modifier ( str n -- newstr ) +M: postgresql-db compound-modifier ( str seq -- newstr ) postgresql-compound ; M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +foreign-id+ "references" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 85aa671d4d..6a3d7d03ae 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -78,7 +78,7 @@ IN: db.sqlite.lib { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { SERIAL [ sqlite-bind-int-by-name ] } + { TIMESTAMP [ sqlite-bind-double-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -102,6 +102,8 @@ IN: db.sqlite.lib { BIG_INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } + { TIMESTAMP [ sqlite3_column_double ] } + [ no-sql-type ] } case ; ! TODO diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index d3388b4648..3f5372ac26 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences -continuations db.types ; +continuations db.types db.tuples unicode.case ; IN: temporary : test.db "extra/db/sqlite/test.db" resource-path ; @@ -89,3 +89,158 @@ IN: temporary "select * from person" sql-query length ] with-sqlite ] unit-test + +! TEST TUPLE DB + +TUPLE: puppy id name age ; +: ( name age -- puppy ) + { set-puppy-name set-puppy-age } puppy construct ; + +puppy "PUPPY" { + { "id" "ID" +native-id+ +not-null+ } + { "name" "NAME" { VARCHAR 256 } } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: kitty id name age ; +: ( name age -- kitty ) + { set-kitty-name set-kitty-age } kitty construct ; + +kitty "KITTY" { + { "id" "ID" INTEGER +assigned-id+ } + { "name" "NAME" TEXT } + { "age" "AGE" INTEGER } +} define-persistent + +TUPLE: basket id puppies kitties ; +basket "BASKET" +{ + { "id" "ID" +native-id+ +not-null+ } + { "location" "LOCATION" TEXT } + { "puppies" { +has-many+ puppy } } + { "kitties" { +has-many+ kitty } } +} define-persistent + +! Create table +[ + "create table puppy(id integer primary key not null, name varchar 256, age integer);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table kitty(id integer primary key, name text, age integer);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +[ + "create table basket(id integer primary key not null, location text);" +] [ + T{ sqlite-db } db [ + basket dup db-columns swap db-table create-sql >lower + ] with-variable +] unit-test + +! Drop table +[ + "drop table puppy;" +] [ + T{ sqlite-db } db [ + puppy db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table kitty;" +] [ + T{ sqlite-db } db [ + kitty db-table drop-sql >lower + ] with-variable +] unit-test + +[ + "drop table basket;" +] [ + T{ sqlite-db } db [ + basket db-table drop-sql >lower + ] with-variable +] unit-test + +! Insert +[ + "insert into puppy(name, age) values(:name, :age);" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +[ + "insert into kitty(id, name, age) values(:id, :name, :age);" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table insert-sql* >lower + ] with-variable +] unit-test + +! Update +[ + "update puppy set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +[ + "update kitty set name = :name, age = :age where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table update-sql* >lower + ] with-variable +] unit-test + +! Delete +[ + "delete from puppy where id = :id" +] [ + T{ sqlite-db } db [ + puppy dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +[ + "delete from kitty where id = :id" +] [ + T{ sqlite-db } db [ + kitty dup db-columns swap db-table delete-sql* >lower + ] with-variable +] unit-test + +! Select +[ + "select from puppy id, name, age where name = :name;" + { + T{ + sql-spec + f + "id" + "ID" + +native-id+ + { +not-null+ } + +native-id+ + } + T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } + T{ sql-spec f "age" "AGE" INTEGER { } f } + } +] [ + T{ sqlite-db } db [ + T{ puppy f f "Mr. Clunkers" } + select-sql >r >lower r> + ] with-variable +] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 4eabfc2ecd..dcb581a76c 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db 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 ; +words combinators.lib db.types combinators ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -86,54 +86,53 @@ M: sqlite-db commit-transaction ( -- ) M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -M: sqlite-db create-sql ( columns table -- sql ) +M: sqlite-db create-sql ( specs table -- sql ) [ "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type % " " % - sql-modifiers " " join % - ] interleave ")" % + "(" % [ ", " % ] [ + dup sql-spec-column-name % + " " % + dup sql-spec-type t lookup-type % + modifiers% + ] interleave ");" % ] "" make ; -M: sqlite-db drop-sql ( columns table -- sql ) +M: sqlite-db drop-sql ( specs table -- sql ) [ - "drop table " % % - drop + "drop table " % % ";" % ] "" make ; -M: sqlite-db insert-sql* ( columns table -- sql ) +M: sqlite-db insert-sql* ( specs table -- sql ) [ - "insert into " % - % + "insert into " % % "(" % - dup [ ", " % ] [ second % ] interleave - ") " % - " values (" % - [ ", " % ] [ ":" % second % ] interleave - ")" % + maybe-remove-id + dup [ ", " % ] [ sql-spec-column-name % ] interleave + ") values(" % + [ ", " % ] [ ":" % sql-spec-column-name % ] interleave + ");" % ] "" make ; -: where-primary-key% ( columns -- ) +: where-primary-key% ( specs -- ) " where " % - [ primary-key? ] find nip second dup % " = :" % % ; + find-primary-key sql-spec-column-name dup % " = :" % % ; -M: sqlite-db update-sql* ( columns table -- sql ) +M: sqlite-db update-sql* ( specs table -- sql ) [ "update " % % " set " % dup remove-id - [ ", " % ] [ second dup % " = :" % % ] interleave + [ ", " % ] [ sql-spec-column-name dup % " = :" % % ] interleave where-primary-key% ] "" make ; -M: sqlite-db delete-sql* ( columns table -- sql ) +M: sqlite-db delete-sql* ( specs table -- sql ) [ - "delete from " % - % + "delete from " % % " where " % - first second dup % " = :" % % + find-primary-key + sql-spec-column-name dup % " = :" % % ] "" make ; : select-interval ( interval name -- ) @@ -142,22 +141,32 @@ M: sqlite-db delete-sql* ( columns table -- sql ) : select-sequence ( seq name -- ) ; -M: sqlite-db select-sql ( columns table -- sql ) +: select-by-slots-sql ( tuple -- sql out-specs ) [ - "select ROWID, " % - over [ ", " % ] [ second % ] interleave - " from " % % - " where " % - ] "" make ; + "select from " 0% dup class db-table 0% + " " 0% + dup class db-columns [ ", " 0% ] + [ dup sql-spec-column-name 0% 1, ] interleave -M: sqlite-db tuple>params ( columns tuple -- obj ) + dup class db-columns + [ sql-spec-slot-name swap get-slot-named ] with subset + " where " 0% + [ ", " 0% ] + [ sql-spec-column-name dup 0% " = :" 0% 0% ] interleave + ";" 0% + ] { "" { } } nmake ; + +M: sqlite-db select-sql ( tuple -- sql ) + select-by-slots-sql ; + +M: sqlite-db tuple>params ( specs tuple -- obj ) [ >r [ second ":" swap append ] keep r> dupd >r first r> get-slot-named swap third 3array ] curry map ; -: sqlite-db-modifiers ( -- hashtable ) +M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } @@ -168,32 +177,24 @@ M: sqlite-db tuple>params ( columns tuple -- obj ) { +not-null+ "not null" } } ; -M: sqlite-db sql-modifiers* ( modifiers -- str ) - sqlite-db-modifiers swap [ - dup array? [ - first2 - >r swap at r> number>string* - " " swap 3append - ] [ - swap at - ] if - ] with map [ ] subset ; +M: sqlite-db compound-type ( str seq -- ) + over { + { "varchar" [ first number>string join-space ] } + [ 2drop "" ] ! "no sqlite compound data type" 3array throw ] + } case ; -: sqlite-type-hash ( -- assoc ) +M: sqlite-db type-table ( -- assoc ) H{ + { +native-id+ "integer primary key" } { INTEGER "integer" } - { SERIAL "integer" } { TEXT "text" } - { VARCHAR "text" } + { VARCHAR "varchar" } + { TIMESTAMP "timestamp" } { DOUBLE "real" } } ; -M: sqlite-db >sql-type ( obj -- str ) - dup pair? [ - first >sql-type - ] [ - sqlite-type-hash at* [ T{ no-sql-type } throw ] unless - ] if ; +M: sqlite-db create-type-table + type-table ; ! HOOK: get-column-value ( n result-set type -- ) ! M: sqlite get-column-value { { "TEXT" get-text-column } { diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 7df0b430de..742702cebf 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.sqlite db.tuples -db.types continuations namespaces db.postgresql math ; +db.types continuations namespaces db.postgresql math +prettyprint ; ! tools.time ; IN: temporary @@ -45,7 +46,7 @@ SYMBOL: the-person person "PERSON" { - { "the-id" "ID" SERIAL +native-id+ } + { "the-id" "ID" +native-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "real" "REAL" DOUBLE { +default+ 0.3 } } @@ -53,7 +54,7 @@ person "PERSON" "billy" 10 3.14 the-person set -! test-sqlite +test-sqlite ! test-postgresql ! person "PERSON" @@ -74,7 +75,7 @@ TUPLE: annotation n paste-id summary author mode contents ; paste "PASTE" { - { "n" "ID" SERIAL +native-id+ } + { "n" "ID" +native-id+ } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } { "channel" "CHANNEL" TEXT } @@ -84,17 +85,10 @@ paste "PASTE" { "annotations" { +has-many+ annotation } } } define-persistent -! n - ! NO: drop insert - ! YES: create update delete select -! annotations - ! NO: create drop insert update delete - ! YES: select - annotation "ANNOTATION" { - { "n" "ID" SERIAL +native-id+ } - { "paste-id" "PASTE_ID" INTEGER { +foreign-key+ paste "n" } } + { "n" "ID" +native-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } { "mode" "MODE" TEXT } @@ -102,8 +96,10 @@ annotation "ANNOTATION" } define-persistent "localhost" "postgres" "" "factor-test" [ - ! paste drop-table - ! annotation drop-table + [ paste drop-table ] [ drop ] recover + [ annotation drop-table ] [ drop ] recover + [ paste drop-table ] [ drop ] recover + [ annotation drop-table ] [ drop ] recover paste create-table annotation create-table ] with-db diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 9c22ba2a65..11926b832d 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -65,7 +65,6 @@ HOOK: tuple>params db ( columns tuple -- obj ) : tuple-statement ( columns tuple quot -- statement ) >r [ tuple>params ] 2keep class r> call - 2dup . . [ bind-statement ] keep ; : make-tuple-statement ( tuple columns-quot statement-quot -- statement ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9354f4fe37..ad19c45e6a 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib -words ; +words namespaces ; IN: db.types TUPLE: sql-spec slot-name column-name type modifiers primary-key ; @@ -34,7 +34,7 @@ SYMBOL: +assigned-id+ : assigned-id? ( spec -- ? ) sql-spec-primary-key +assigned-id+ = ; -SYMBOL: +foreign-key+ +SYMBOL: +foreign-id+ ! Same concept, SQLite has autoincrement, PostgreSQL has serial SYMBOL: +autoincrement+ @@ -107,23 +107,27 @@ TUPLE: no-sql-modifier ; HOOK: modifier-table db ( -- hash ) -HOOK: compound-modifier db ( str n -- hash ) +HOOK: compound-modifier db ( str seq -- hash ) : lookup-modifier ( obj -- str ) - dup pair? [ - first2 >r lookup-modifier r> compound-modifier + dup array? [ + unclip lookup-modifier swap compound-modifier ] [ modifier-table at* [ "unknown modifier" throw ] unless ] if ; +: modifiers% ( spec -- ) + sql-spec-modifiers + [ lookup-modifier ] map " " join + dup empty? [ drop ] [ " " % % ] if ; HOOK: type-table db ( -- hash ) HOOK: create-type-table db ( -- hash ) HOOK: compound-type db ( str n -- hash ) : lookup-type* ( obj -- str ) - dup pair? [ + dup array? [ first lookup-type* ] [ type-table at* @@ -131,12 +135,25 @@ HOOK: compound-type db ( str n -- hash ) ] if ; : lookup-create-type ( obj -- str ) - dup pair? [ - first2 >r lookup-create-type r> compound-type + dup array? [ + unclip lookup-create-type swap compound-type ] [ dup create-type-table at* [ nip ] [ drop lookup-type* ] if ] if ; +USE: prettyprint : lookup-type ( obj create? -- str ) [ lookup-create-type ] [ lookup-type* ] if ; + +: single-quote ( str -- newstr ) + "'" swap "'" 3append ; + +: double-quote ( str -- newstr ) + "\"" swap "\"" 3append ; + +: paren ( str -- newstr ) + "(" swap ")" 3append ; + +: join-space ( str1 str2 -- newstr ) + " " swap 3append ; From 117a7b664314d594d7b26b18f2f105bf483552fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 Feb 2008 12:05:25 -0600 Subject: [PATCH 05/25] debugging sqlite --- extra/db/sqlite/sqlite.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index dcb581a76c..e1a3a63030 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -177,10 +177,13 @@ M: sqlite-db modifier-table ( -- hashtable ) { +not-null+ "not null" } } ; -M: sqlite-db compound-type ( str seq -- ) +M: sqlite-db compound-modifier ( str obj -- newstr ) + drop ; + +M: sqlite-db compound-type ( str seq -- newstr ) over { - { "varchar" [ first number>string join-space ] } - [ 2drop "" ] ! "no sqlite compound data type" 3array throw ] + ! { "varchar" [ first number>string join-space ] } + [ drop ] ! "no sqlite compound data type" 3array throw ] } case ; M: sqlite-db type-table ( -- assoc ) From 4b881bb3dd24f4f743b32a58c354ab734a4230d3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 Feb 2008 18:30:55 -0600 Subject: [PATCH 06/25] work on the sql types --- extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/sqlite/sqlite.factor | 8 ++++---- extra/db/types/types.factor | 3 --- 3 files changed, 5 insertions(+), 8 deletions(-) mode change 100644 => 100755 extra/db/sqlite/sqlite-tests.factor diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor old mode 100644 new mode 100755 index 3f5372ac26..6c4b65ff9f --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -123,7 +123,7 @@ basket "BASKET" ! Create table [ - "create table puppy(id integer primary key not null, name varchar 256, age integer);" + "create table puppy(id integer primary key not null, name varchar, age integer);" ] [ T{ sqlite-db } db [ puppy dup db-columns swap db-table create-sql >lower diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index e1a3a63030..748b2bbf68 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -178,12 +178,12 @@ M: sqlite-db modifier-table ( -- hashtable ) } ; M: sqlite-db compound-modifier ( str obj -- newstr ) - drop ; + compound-type ; M: sqlite-db compound-type ( str seq -- newstr ) over { - ! { "varchar" [ first number>string join-space ] } - [ drop ] ! "no sqlite compound data type" 3array throw ] + { "default" [ first number>string join-space ] } + [ 2drop ] ! "no sqlite compound data type" 3array throw ] } case ; M: sqlite-db type-table ( -- assoc ) @@ -191,7 +191,7 @@ M: sqlite-db type-table ( -- assoc ) { +native-id+ "integer primary key" } { INTEGER "integer" } { TEXT "text" } - { VARCHAR "varchar" } + { VARCHAR "text" } { TIMESTAMP "timestamp" } { DOUBLE "real" } } ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index ad19c45e6a..77c704d1c9 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -104,8 +104,6 @@ TUPLE: no-sql-modifier ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html - - HOOK: modifier-table db ( -- hash ) HOOK: compound-modifier db ( str seq -- hash ) @@ -142,7 +140,6 @@ HOOK: compound-type db ( str n -- hash ) [ nip ] [ drop lookup-type* ] if ] if ; -USE: prettyprint : lookup-type ( obj create? -- str ) [ lookup-create-type ] [ lookup-type* ] if ; From d1e5fddbedc4eec27dce70bda5a029472b17133c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 21 Feb 2008 15:57:18 -0600 Subject: [PATCH 07/25] fix a couple of minor bugs before major overhaul --- extra/db/db.factor | 4 +-- extra/db/postgresql/postgresql.factor | 39 ++++++++++++++++----------- extra/db/sqlite/lib/lib.factor | 1 + extra/db/sqlite/sqlite.factor | 10 +++---- extra/db/tuples/tuples-tests.factor | 37 ++++++++++++------------- extra/db/tuples/tuples.factor | 6 ++--- extra/db/types/types.factor | 11 +++++--- 7 files changed, 60 insertions(+), 48 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index d269d4654c..4fae508bb1 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -23,12 +23,12 @@ HOOK: db-close db ( handle -- ) db-handle db-close ] with-variable ; -TUPLE: statement handle sql slot-names bound? in-params out-params ; +TUPLE: statement handle sql bound? in-params out-params ; TUPLE: simple-statement ; TUPLE: prepared-statement ; HOOK: db ( str -- statement ) -HOOK: db ( str slot-names -- statement ) +HOOK: db ( str -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: reset-statement ( statement -- ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 8cf7e79f53..97e32a411d 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -4,7 +4,7 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators sequences.lib classes locals words ; +combinators sequences.lib classes locals words tools.walker ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -65,6 +65,7 @@ M: postgresql-result-set sql-type>factor-type ( obj type -- newobj ) } case ; M: postgresql-statement insert-statement ( statement -- id ) +break query-results [ 0 row-column ] with-disposal string>number ; M: postgresql-statement query-results ( query -- result-set ) @@ -104,10 +105,13 @@ M: postgresql-db ( sql -- statement ) { set-statement-sql } statement construct ; -M: postgresql-db ( pair -- statement ) - ?first2 - { set-statement-sql set-statement-slot-names } - statement construct ; +M: postgresql-db ( triple -- statement ) + ?first3 + { + set-statement-sql + set-statement-in-params + set-statement-out-params + } statement construct ; M: postgresql-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -166,6 +170,7 @@ SYMBOL: postgresql-counter : drop-function-sql ( specs table -- sql ) [ +break "drop function add_" % % "(" % remove-id @@ -215,8 +220,8 @@ M: postgresql-db drop-sql ( specs table -- seq ) ] postgresql-make ; M: postgresql-db insert-sql* ( specs table -- sql in-specs out-specs ) - over find-primary-key native-id? - [ insert-function-sql ] [ insert-table-sql ] if ; + dup class db-columns find-primary-key native-id? + [ insert-function-sql ] [ insert-table-sql ] if 3array ; M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs ) [ @@ -228,7 +233,7 @@ M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs ) " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make ; + ] postgresql-make 3array ; M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs ) [ @@ -236,7 +241,7 @@ M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs ) " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make ; + ] postgresql-make 3array ; : select-by-slots-sql ( tuple -- sql in-specs out-specs ) [ @@ -251,7 +256,7 @@ M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs ) [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ";" 0% - ] postgresql-make ; + ] postgresql-make 3array ; ! : select-with-relations ( tuple -- sql in-specs out-specs ) @@ -259,7 +264,7 @@ M: postgresql-db select-sql ( tuple -- sql in-specs out-specs ) select-by-slots-sql ; M: postgresql-db tuple>params ( specs tuple -- obj ) - [ >r dup third swap first r> get-slot-named swap ] + [ >r dup sql-spec-type swap sql-spec-slot-name r> get-slot-named swap ] curry { } map>assoc ; M: postgresql-db type-table ( -- hash ) @@ -268,6 +273,7 @@ M: postgresql-db type-table ( -- hash ) { TEXT "text" } { VARCHAR "varchar" } { INTEGER "integer" } + { DOUBLE "real" } { TIMESTAMP "timestamp" } } ; @@ -278,12 +284,13 @@ M: postgresql-db create-type-table ( -- hash ) : postgresql-compound ( str n -- newstr ) over { - { "varchar" [ first number>string join-space ] } - { "references" - [ + { "default" [ first number>string join-space ] } + { "varchar" [ first number>string paren append ] } + { "references" [ first2 >r [ unparse join-space ] keep db-columns r> - swap [ sql-spec-slot-name = ] with find nip sql-spec-column-name paren append - ] } + swap [ sql-spec-slot-name = ] with find nip + sql-spec-column-name paren append + ] } [ "no compound found" 3array throw ] } case ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 6a3d7d03ae..648d8493dc 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -79,6 +79,7 @@ IN: db.sqlite.lib { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } { TIMESTAMP [ sqlite-bind-double-by-name ] } + { +native-id+ [ sqlite-bind-int-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 748b2bbf68..249856e8bc 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db 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 ; +words combinators.lib db.types combinators tools.walker ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -99,7 +99,7 @@ M: sqlite-db create-sql ( specs table -- sql ) M: sqlite-db drop-sql ( specs table -- sql ) [ - "drop table " % % ";" % + "drop table " % % ";" % drop ] "" make ; M: sqlite-db insert-sql* ( specs table -- sql ) @@ -161,9 +161,9 @@ M: sqlite-db select-sql ( tuple -- sql ) M: sqlite-db tuple>params ( specs tuple -- obj ) [ - >r [ second ":" swap append ] keep r> - dupd >r first r> get-slot-named swap - third 3array + >r [ sql-spec-column-name ":" swap append ] keep r> + dupd >r sql-spec-slot-name r> get-slot-named swap + sql-spec-type 3array ] curry map ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 742702cebf..5a5df7c185 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,19 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.sqlite db.tuples db.types continuations namespaces db.postgresql math -prettyprint ; -! tools.time ; +prettyprint tools.walker ; IN: temporary -TUPLE: person the-id the-name the-number real ; +TUPLE: person the-id the-name the-number the-real ; : ( name age real -- person ) { set-person-the-name set-person-the-number - set-person-real + set-person-the-real } person construct ; -: ( id name number real -- obj ) +: ( id name number the-real -- obj ) [ set-person-the-id ] keep ; SYMBOL: the-person @@ -31,8 +30,10 @@ SYMBOL: the-person [ ] [ the-person get update-tuple ] unit-test + ! T{ person f f f 200 f } select-tuples + [ ] [ the-person get delete-tuple ] unit-test - ; ! 1 [ ] [ person drop-table ] unit-test ; + [ ] [ person drop-table ] unit-test ; : test-sqlite ( -- ) "tuples-test.db" resource-path [ @@ -49,20 +50,20 @@ person "PERSON" { "the-id" "ID" +native-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } - { "real" "REAL" DOUBLE { +default+ 0.3 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } } define-persistent "billy" 10 3.14 the-person set -test-sqlite -! test-postgresql +! test-sqlite +test-postgresql ! person "PERSON" ! { ! { "the-id" "ID" INTEGER +assigned-id+ } ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ } ! { "the-number" "AGE" INTEGER { +default+ 0 } } - ! { "real" "REAL" DOUBLE { +default+ 0.3 } } + ! { "the-real" "REAL" DOUBLE { +default+ 0.3 } } ! } define-persistent ! 1 "billy" 20 6.28 the-person set @@ -95,11 +96,11 @@ annotation "ANNOTATION" { "contents" "CONTENTS" TEXT } } define-persistent -"localhost" "postgres" "" "factor-test" [ - [ paste drop-table ] [ drop ] recover - [ annotation drop-table ] [ drop ] recover - [ paste drop-table ] [ drop ] recover - [ annotation drop-table ] [ drop ] recover - paste create-table - annotation create-table -] with-db +! "localhost" "postgres" "" "factor-test" [ + ! [ paste drop-table ] [ drop ] recover + ! [ annotation drop-table ] [ drop ] recover + ! [ paste drop-table ] [ drop ] recover + ! [ annotation drop-table ] [ drop ] recover + ! [ ] [ paste create-table ] unit-test + ! [ ] [ annotation create-table ] unit-test +! ] with-db diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 11926b832d..7a95cc8e0e 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays assocs classes db kernel namespaces tuples words sequences slots slots.private math math.parser io prettyprint db.types continuations -mirrors sequences.lib ; +mirrors sequences.lib tools.walker ; IN: db.tuples : db-table ( class -- obj ) "db-table" word-prop ; @@ -33,7 +33,7 @@ TUPLE: no-slot-named ; dup class primary-key-spec get-slot-named ; : set-primary-key ( obj tuple -- ) - [ class primary-key-spec first ] keep + [ class primary-key-spec sql-spec-slot-name ] keep set-slot-named ; : cache-statement ( columns class assoc quot -- statement ) @@ -92,7 +92,7 @@ HOOK: tuple>params db ( columns tuple -- obj ) : delete-tuple ( tuple -- ) [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ; -: select-tuple ( tuple -- ) +: select-tuples ( tuple -- ) [ select-sql ] keep do-query ; : persist ( tuple -- ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 77c704d1c9..a99ccc09f7 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib -words namespaces ; +words namespaces tools.walker ; IN: db.types TUPLE: sql-spec slot-name column-name type modifiers primary-key ; @@ -12,15 +12,18 @@ SYMBOL: +native-id+ ! +assigned-id+ can only be a modifier SYMBOL: +assigned-id+ -: primary-key? ( obj -- ? ) +: (primary-key?) ( obj -- ? ) { +native-id+ +assigned-id+ } member? ; +: primary-key? ( spec -- ? ) + sql-spec-primary-key (primary-key?) ; + : normalize-spec ( spec -- ) - dup sql-spec-type dup primary-key? [ + dup sql-spec-type dup (primary-key?) [ swap set-sql-spec-primary-key ] [ drop dup sql-spec-modifiers [ - primary-key? + (primary-key?) ] deep-find [ swap set-sql-spec-primary-key ] [ drop ] if* ] if ; From 67876e13d9bfd593d4fa2774f1da365668a36fa9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 Feb 2008 17:06:00 -0600 Subject: [PATCH 08/25] break sqlite postgresql create/drop/insert/update/delete/select works --- extra/db/db.factor | 47 +++-- extra/db/postgresql/lib/lib.factor | 8 +- extra/db/postgresql/postgresql-tests.factor | 2 +- extra/db/postgresql/postgresql.factor | 204 +++++++++----------- extra/db/tuples/tuples-tests.factor | 16 +- extra/db/tuples/tuples.factor | 165 ++++++---------- extra/db/types/types.factor | 105 ++++++++-- 7 files changed, 277 insertions(+), 270 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 4fae508bb1..36f2908078 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math -namespaces sequences sequences.lib tuples words strings ; +namespaces sequences sequences.lib tuples words strings +tools.walker ; IN: db -TUPLE: db handle insert-statements update-statements delete-statements ; +TUPLE: db handle ; +! TUPLE: db handle insert-statements update-statements delete-statements ; : ( handle -- obj ) - H{ } clone H{ } clone H{ } clone + ! H{ } clone H{ } clone H{ } clone db construct-boa ; GENERIC: db-open ( db -- ) @@ -17,22 +19,29 @@ HOOK: db-close db ( handle -- ) : dispose-db ( db -- ) dup db [ - dup db-insert-statements dispose-statements - dup db-update-statements dispose-statements - dup db-delete-statements dispose-statements + ! dup db-insert-statements dispose-statements + ! dup db-update-statements dispose-statements + ! dup db-delete-statements dispose-statements db-handle db-close ] with-variable ; -TUPLE: statement handle sql bound? in-params out-params ; +TUPLE: statement handle sql in-params out-params bind-params bound? ; +: ( sql in out -- statement ) + { + set-statement-sql + set-statement-in-params + set-statement-out-params + } statement construct ; + TUPLE: simple-statement ; TUPLE: prepared-statement ; -HOOK: db ( str -- statement ) -HOOK: db ( str -- statement ) +HOOK: db ( str in out -- statement ) +HOOK: db ( str in out -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: reset-statement ( statement -- ) -GENERIC: insert-statement ( statement -- id ) +GENERIC: bind-tuple ( tuple statement -- ) TUPLE: result-set sql params handle n max ; GENERIC: query-results ( query -- result-set ) @@ -42,14 +51,20 @@ GENERIC# row-column 1 ( result-set n -- obj ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -: execute-statement ( statement -- ) query-results dispose ; +: execute-statement ( statement -- ) + dup sequence? [ + [ execute-statement ] each + ] [ + query-results dispose + ] if ; : bind-statement ( obj statement -- ) dup statement-bound? [ dup reset-statement ] when [ bind-statement* ] 2keep - [ set-statement-in-params ] keep + [ set-statement-bind-params ] keep t swap set-statement-bound? ; + : init-result-set ( result-set -- ) dup #rows over set-result-set-max 0 swap set-result-set-n ; @@ -81,11 +96,11 @@ GENERIC: more-rows? ( result-set -- ? ) [ db swap with-variable ] curry with-disposal ] with-scope ; -: do-query ( query -- result-set ) +: default-query ( query -- result-set ) query-results [ [ sql-row ] query-map ] with-disposal ; : do-bound-query ( obj query -- rows ) - [ bind-statement ] keep do-query ; + [ bind-statement ] keep default-query ; : do-bound-command ( obj query -- ) [ bind-statement ] keep execute-statement ; @@ -105,11 +120,11 @@ HOOK: rollback-transaction db ( -- ) ] with-variable ; : sql-query ( sql -- rows ) - [ do-query ] with-disposal ; + f f [ default-query ] with-disposal ; : sql-command ( sql -- ) dup string? [ - [ execute-statement ] with-disposal + f f [ execute-statement ] with-disposal ] [ ! [ [ sql-command ] each diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 5f24dd9ea0..cdfa3535a0 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types -db.types ; +db.types tools.walker ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -37,9 +37,9 @@ IN: db.postgresql.lib : do-postgresql-bound-statement ( statement -- res ) >r db get db-handle r> [ statement-sql ] keep - [ statement-in-params length f ] keep - statement-in-params - [ first number>string* malloc-char-string ] map >c-void*-array + [ statement-bind-params length f ] keep + statement-bind-params + [ number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index bdb434cfdd..09e81e6ec3 100755 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -40,7 +40,7 @@ IN: temporary ] [ test-db [ "select * from person where name = $1 and country = $2" - [ + f f [ { { "Jane" TEXT } { "New Zealand" TEXT } } over do-bound-query diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 97e32a411d..ef7c870501 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -10,7 +10,8 @@ IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-statement ; TUPLE: postgresql-result-set ; -: ( statement -- postgresql-statement ) +: ( statement in out -- postgresql-statement ) + postgresql-statement construct-delegate ; : ( host user pass db -- obj ) @@ -39,11 +40,17 @@ M: postgresql-db dispose ( db -- ) >r r> with-disposal ; M: postgresql-statement bind-statement* ( seq statement -- ) - set-statement-in-params ; + set-statement-bind-params ; M: postgresql-statement reset-statement ( statement -- ) drop ; +M: postgresql-statement bind-tuple ( tuple statement -- ) + [ + statement-in-params + [ sql-spec-slot-name swap get-slot-named ] with map + ] keep set-statement-bind-params ; + M: postgresql-result-set #rows ( result-set -- n ) result-set-handle PQntuples ; @@ -56,20 +63,8 @@ M: postgresql-result-set row-column ( result-set n -- obj ) M: postgresql-result-set row-column-typed ( result-set n type -- obj ) >r row-column r> sql-type>factor-type ; -M: postgresql-result-set sql-type>factor-type ( obj type -- newobj ) - { - { INTEGER [ string>number ] } - { BIG_INTEGER [ string>number ] } - { DOUBLE [ string>number ] } - [ drop ] - } case ; - -M: postgresql-statement insert-statement ( statement -- id ) -break - query-results [ 0 row-column ] with-disposal string>number ; - M: postgresql-statement query-results ( query -- result-set ) - dup statement-in-params [ + dup statement-bind-params [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -101,17 +96,11 @@ M: postgresql-statement prepare-statement ( statement -- ) length f PQprepare postgresql-error ] keep set-statement-handle ; -M: postgresql-db ( sql -- statement ) - { set-statement-sql } statement construct +M: postgresql-db ( sql in out -- statement ) ; -M: postgresql-db ( triple -- statement ) - ?first3 - { - set-statement-sql - set-statement-in-params - set-statement-out-params - } statement construct ; +M: postgresql-db ( sql in out -- statement ) + dup prepare-statement ; M: postgresql-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -123,81 +112,91 @@ M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; SYMBOL: postgresql-counter -: bind% ( spec -- ) - 1, +: bind-name% ( -- ) CHAR: $ 0, postgresql-counter [ inc ] keep get 0# ; -: postgresql-make ( quot -- ) +M: postgresql-db bind% ( spec -- ) + 1, bind-name% ; + +: postgresql-make ( class quot -- ) + >r sql-props r> [ postgresql-counter off ] swap compose - { "" { } { } } nmake ; + { "" { } { } } nmake ; -:: create-table-sql | specs table | +: create-table-sql ( class -- statement ) [ - "create table " % table % - "(" % - specs [ ", " % ] [ - dup sql-spec-column-name % - " " % - dup sql-spec-type t lookup-type % - modifiers% - ] interleave ");" % - ] "" make ; + "create table " 0% 0% + "(" 0% + [ ", " 0% ] [ + dup sql-spec-column-name 0% + " " 0% + dup sql-spec-type t lookup-type 0% + modifiers 0% + ] interleave ");" 0% + ] postgresql-make ; -:: create-function-sql | specs table | +: create-function-sql ( class -- statement ) [ - [let | specs [ specs remove-id ] | - "create function add_" 0% table 0% - "(" 0% - specs [ "," 0% ] - [ - sql-spec-type f lookup-type 0% - ] interleave - ")" 0% - " returns bigint as '" 0% + >r remove-id r> + "create function add_" 0% dup 0% + "(" 0% + over [ "," 0% ] + [ + sql-spec-type f lookup-type 0% + ] interleave + ")" 0% + " returns bigint as '" 0% - "insert into " 0% - table 0% - "(" 0% - specs [ ", " 0% ] [ sql-spec-column-name 0% ] interleave - ") values(" 0% - specs [ ", " 0% ] [ bind% ] interleave - "); " 0% + "insert into " 0% + dup 0% + "(" 0% + over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + swap [ ", " 0% ] [ drop bind-name% ] interleave + "); " 0% + "select currval(''" 0% 0% "_id_seq'');' language sql;" 0% + ] postgresql-make ; - "select currval(''" 0% table 0% "_id_seq'');' language sql;" 0% - ] - ] postgresql-make 2drop ; - -: drop-function-sql ( specs table -- sql ) +M: postgresql-db create-sql-statement ( class -- seq ) [ -break - "drop function add_" % % - "(" % - remove-id - [ ", " % ] [ sql-spec-type f lookup-type % ] interleave - ");" % - ] "" make ; - -: drop-table-sql ( table -- sql ) - [ - "drop table " % % ";" % - ] "" make ; - -M: postgresql-db create-sql ( specs table -- seq ) - [ - 2dup create-table-sql , - over find-primary-key native-id? + [ create-table-sql , ] keep + dup db-columns find-primary-key native-id? [ create-function-sql , ] [ 2drop ] if ] { } make ; -M: postgresql-db drop-sql ( specs table -- seq ) +: drop-function-sql ( class -- statement ) [ - dup drop-table-sql , - over find-primary-key native-id? + "drop function add_" 0% 0% + "(" 0% + remove-id + [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave + ");" 0% + ] postgresql-make ; + +: drop-table-sql ( table -- statement ) + [ + "drop table " 0% 0% ";" 0% drop + ] postgresql-make dup . ; + +M: postgresql-db drop-sql-statement ( class -- seq ) + [ + [ drop-table-sql , ] keep + dup db-columns find-primary-key native-id? [ drop-function-sql , ] [ 2drop ] if ] { } make ; -: insert-table-sql ( specs table -- sql in-specs out-specs ) +M: postgresql-db ( tuple -- statement ) + [ + "select add_" 0% 0% + "(" 0% + dup find-primary-key 2, + remove-id + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] postgresql-make ; + +M: postgresql-db ( tuple -- statement ) [ "insert into " 0% 0% "(" 0% @@ -209,21 +208,7 @@ M: postgresql-db drop-sql ( specs table -- seq ) ");" 0% ] postgresql-make ; -: insert-function-sql ( specs table -- sql in-specs out-specs ) - [ - "select add_" 0% 0% - "(" 0% - dup find-primary-key 2, - remove-id - [ ", " 0% ] [ bind% ] interleave - ");" 0% - ] postgresql-make ; - -M: postgresql-db insert-sql* ( specs table -- sql in-specs out-specs ) - dup class db-columns find-primary-key native-id? - [ insert-function-sql ] [ insert-table-sql ] if 3array ; - -M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs ) +M: postgresql-db ( tuple -- statement ) [ "update " 0% 0% " set " 0% @@ -233,39 +218,30 @@ M: postgresql-db update-sql* ( specs table -- sql in-specs out-specs ) " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make 3array ; + ] postgresql-make ; -M: postgresql-db delete-sql* ( specs table -- sql in-specs out-specs ) +M: postgresql-db ( tuple -- statement ) [ "delete from " 0% 0% " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make 3array ; + ] postgresql-make ; -: select-by-slots-sql ( tuple -- sql in-specs out-specs ) +M: postgresql-db ( tuple class -- statement ) [ - "select from " 0% dup class db-table 0% - " " 0% - dup class db-columns [ ", " 0% ] + ! tuple columns table + "select " 0% + over [ ", " 0% ] [ dup sql-spec-column-name 0% 2, ] interleave - dup class db-columns + " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset " where " 0% [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ";" 0% - ] postgresql-make 3array ; - -! : select-with-relations ( tuple -- sql in-specs out-specs ) - -M: postgresql-db select-sql ( tuple -- sql in-specs out-specs ) - select-by-slots-sql ; - -M: postgresql-db tuple>params ( specs tuple -- obj ) - [ >r dup sql-spec-type swap sql-spec-slot-name r> get-slot-named swap ] - curry { } map>assoc ; + ] postgresql-make ; M: postgresql-db type-table ( -- hash ) H{ diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 5a5df7c185..b484ccf016 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel tools.test db db.sqlite db.tuples +USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math prettyprint tools.walker ; +! db.sqlite IN: temporary TUPLE: person the-id the-name the-number the-real ; @@ -32,13 +33,14 @@ SYMBOL: the-person ! T{ person f f f 200 f } select-tuples - [ ] [ the-person get delete-tuple ] unit-test - [ ] [ person drop-table ] unit-test ; + ! [ ] [ the-person get delete-tuple ] unit-test + ! [ ] [ person drop-table ] unit-test + ; -: test-sqlite ( -- ) - "tuples-test.db" resource-path [ - test-tuples - ] with-db ; +! : test-sqlite ( -- ) + ! "tuples-test.db" resource-path [ + ! test-tuples + ! ] with-db ; : test-postgresql ( -- ) "localhost" "postgres" "" "factor-test" [ diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 7a95cc8e0e..ea66d5890f 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,140 +1,89 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces -tuples words sequences slots slots.private math +tuples words sequences slots math math.parser io prettyprint db.types continuations -mirrors sequences.lib tools.walker ; +mirrors sequences.lib tools.walker combinators.lib ; IN: db.tuples +: define-persistent ( class table columns -- ) + >r dupd "db-table" set-word-prop dup r> + [ relation? ] partition swapd + dupd [ spec>tuple ] with map + "db-columns" set-word-prop + "db-relations" set-word-prop ; + : db-table ( class -- obj ) "db-table" word-prop ; : db-columns ( class -- obj ) "db-columns" word-prop ; : db-relations ( class -- obj ) "db-relations" word-prop ; -TUPLE: no-slot-named ; -: no-slot-named ( -- * ) T{ no-slot-named } throw ; +! returns a sequence of prepared-statements +HOOK: create-sql-statement db ( class -- obj ) +HOOK: drop-sql-statement db ( class -- obj ) -: slot-spec-named ( str class -- slot-spec ) - "slots" word-prop [ slot-spec-name = ] with find nip - [ no-slot-named ] unless* ; +HOOK: db ( tuple -- obj ) +HOOK: db ( tuple -- obj ) -: offset-of-slot ( str obj -- n ) - class slot-spec-named slot-spec-offset ; +HOOK: db ( tuple -- obj ) +HOOK: db ( tuple -- obj ) -: get-slot-named ( str obj -- value ) - tuck offset-of-slot [ no-slot-named ] unless* slot ; - -: set-slot-named ( value str obj -- ) - tuck offset-of-slot [ no-slot-named ] unless* set-slot ; - -: primary-key-spec ( class -- spec ) - db-columns [ primary-key? ] find nip ; - -: primary-key ( tuple -- obj ) - dup class primary-key-spec get-slot-named ; - -: set-primary-key ( obj tuple -- ) - [ class primary-key-spec sql-spec-slot-name ] keep - set-slot-named ; - -: cache-statement ( columns class assoc quot -- statement ) - [ db-table dupd ] swap - [ ] 3compose cache nip ; inline - -HOOK: create-sql db ( columns table -- seq ) -HOOK: drop-sql db ( columns table -- seq ) - -HOOK: insert-sql* db ( columns table -- sql slot-names ) -HOOK: update-sql* db ( columns table -- sql slot-names ) -HOOK: delete-sql* db ( columns table -- sql slot-names ) -HOOK: select-sql db ( tuple -- seq/statement ) -HOOK: select-relations-sql db ( tuple -- seq/statement ) +HOOK: db ( tuple -- obj ) +HOOK: db ( tuple -- obj ) HOOK: row-column-typed db ( result-set n type -- sql ) -HOOK: sql-type>factor-type db ( obj type -- obj ) -HOOK: tuple>params db ( columns tuple -- obj ) -: insert-sql ( columns class -- statement ) - db get db-insert-statements [ insert-sql* ] cache-statement ; +: query-tuple ( tuple statement -- seq ) + dupd + [ query-results [ sql-row ] with-disposal ] keep + statement-out-params rot [ + >r [ sql-spec-type sql-type>factor-type ] keep + sql-spec-slot-name r> set-slot-named + ] curry 2each ; + +: query-tuples ( statement -- seq ) + ; -: update-sql ( columns class -- statement ) - db get db-update-statements [ update-sql* ] cache-statement ; +: sql-props ( class -- columns table ) + dup db-columns swap db-table ; -: delete-sql ( columns class -- statement ) - db get db-delete-statements [ delete-sql* ] cache-statement ; +: create-table ( class -- ) create-sql-statement execute-statement ; +: drop-table ( class -- ) drop-sql-statement execute-statement ; +: insert-native ( tuple -- ) + dup class + [ bind-tuple ] 2keep query-tuple ; -: tuple-statement ( columns tuple quot -- statement ) - >r [ tuple>params ] 2keep class r> call - [ bind-statement ] keep ; - -: make-tuple-statement ( tuple columns-quot statement-quot -- statement ) - >r [ class db-columns ] swap compose keep - r> tuple-statement ; - -: do-tuple-statement ( tuple columns-quot statement-quot -- ) - make-tuple-statement execute-statement ; - -: create-table ( class -- ) - dup db-columns swap db-table create-sql sql-command ; - -: drop-table ( class -- ) - dup db-columns swap db-table drop-sql sql-command ; +: insert-assigned ( tuple -- ) + dup + [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - [ - [ maybe-remove-id ] [ insert-sql ] - make-tuple-statement insert-statement - ] keep set-primary-key ; + dup class db-columns find-primary-key assigned-id? [ + insert-assigned + ] [ + insert-native + ] if ; : update-tuple ( tuple -- ) - [ ] [ update-sql ] do-tuple-statement ; + execute-statement ; -: delete-tuple ( tuple -- ) - [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ; +: update-tuples ( seq -- ) + execute-statement ; -: select-tuples ( tuple -- ) - [ select-sql ] keep do-query ; -: persist ( tuple -- ) - dup primary-key [ update-tuple ] [ insert-tuple ] if ; -: define-persistent ( class table columns -- ) - >r dupd "db-table" set-word-prop dup r> - [ relation? ] partition swapd - [ spec>tuple ] map - "db-columns" set-word-prop - "db-relations" set-word-prop ; +! : persist ( tuple -- ) -: tuple>filled-slots ( tuple -- alist ) - dup mirror-slots [ slot-spec-name ] map - swap tuple-slots 2array flip [ nip ] assoc-subset ; +HOOK: delete-by-id db ( tuple -- ) +! : delete-tuple ( tuple -- ) -one-sql execute-statement ; +! : delete-tuples ( seq -- ) delete-many-sql execute-statement ; -! [ tuple>filled-slots ] keep -! [ >r first r> get-slot-named ] curry each +HOOK: db ( tuple -- tuple ) -SYMBOL: building-seq -: get-building-seq ( n -- seq ) - building-seq get nth ; +: select-tuple ( tuple -- tuple ) + dup dup class + [ bind-tuple ] 2keep query-tuple ; -: 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 ; +: select-tuples ( tuple -- tuple ) + dup dup class + [ bind-tuple ] 2keep query-tuples ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index a99ccc09f7..c84b23c50f 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -2,10 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib -words namespaces tools.walker ; +words namespaces tools.walker slots slots.private classes +mirrors tuples combinators ; IN: db.types -TUPLE: sql-spec slot-name column-name type modifiers primary-key ; +HOOK: modifier-table db ( -- hash ) +HOOK: compound-modifier db ( str seq -- hash ) +HOOK: type-table db ( -- hash ) +HOOK: create-type-table db ( -- hash ) +HOOK: compound-type db ( str n -- hash ) + +TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; ! ID is the Primary key ! +native-id+ can be a columns type or a modifier SYMBOL: +native-id+ @@ -50,24 +57,22 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ -: relation? ( spec -- ? ) - [ +has-many+ = ] deep-find ; +: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; SYMBOL: INTEGER SYMBOL: BIG_INTEGER SYMBOL: DOUBLE - +SYMBOL: REAL SYMBOL: BOOLEAN - SYMBOL: TEXT SYMBOL: VARCHAR - SYMBOL: TIMESTAMP SYMBOL: DATE -: spec>tuple ( spec -- tuple ) +: spec>tuple ( class spec -- tuple ) [ ?first3 ] keep 3 ?tail* { + set-sql-spec-class set-sql-spec-slot-name set-sql-spec-column-name set-sql-spec-type @@ -107,9 +112,6 @@ TUPLE: no-sql-modifier ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html -HOOK: modifier-table db ( -- hash ) -HOOK: compound-modifier db ( str seq -- hash ) - : lookup-modifier ( obj -- str ) dup array? [ unclip lookup-modifier swap compound-modifier @@ -118,15 +120,6 @@ HOOK: compound-modifier db ( str seq -- hash ) [ "unknown modifier" throw ] unless ] if ; -: modifiers% ( spec -- ) - sql-spec-modifiers - [ lookup-modifier ] map " " join - dup empty? [ drop ] [ " " % % ] if ; - -HOOK: type-table db ( -- hash ) -HOOK: create-type-table db ( -- hash ) -HOOK: compound-type db ( str n -- hash ) - : lookup-type* ( obj -- str ) dup array? [ first lookup-type* @@ -157,3 +150,75 @@ HOOK: compound-type db ( str n -- hash ) : join-space ( str1 str2 -- newstr ) " " swap 3append ; + +: modifiers ( spec -- str ) + sql-spec-modifiers + [ 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 ; +: no-slot-named ( -- * ) T{ no-slot-named } throw ; + +: slot-spec-named ( str class -- slot-spec ) + "slots" word-prop [ slot-spec-name = ] with find nip + [ no-slot-named ] unless* ; + +: offset-of-slot ( str obj -- n ) + class slot-spec-named slot-spec-offset ; + +: get-slot-named ( str obj -- value ) + tuck offset-of-slot [ no-slot-named ] unless* slot ; + +: set-slot-named ( value str obj -- ) + tuck offset-of-slot [ no-slot-named ] unless* set-slot ; + +: tuple>filled-slots ( tuple -- alist ) + dup mirror-slots [ slot-spec-name ] map + swap tuple-slots 2array flip [ nip ] assoc-subset ; + +: tuple>params ( specs tuple -- obj ) + [ + >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 ) + dup array? [ first ] when + { + { +native-id+ [ string>number ] } + { INTEGER [ string>number ] } + { DOUBLE [ string>number ] } + { REAL [ string>number ] } + { TEXT [ ] } + { VARCHAR [ ] } + [ "no conversion from sql type to factor type" throw ] + } case ; From a73972c6b30efdb2af191662828bd957114bf9b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Feb 2008 00:26:54 -0600 Subject: [PATCH 09/25] Fix another parser bug --- core/classes/classes.factor | 3 +-- core/parser/parser-tests.factor | 31 +++++++++++++++++++++++++++++++ core/parser/parser.factor | 9 ++++++++- 3 files changed, 40 insertions(+), 3 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 70088f2b03..48ddb2adf5 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -255,8 +255,7 @@ PRIVATE> : (define-class) ( word props -- ) over reset-class - over reset-generic - over define-symbol + over deferred? [ over define-symbol ] when >r dup word-props r> union over set-word-props t "class" set-word-prop ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a0e7e4b909..3d2963fc85 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -395,3 +395,34 @@ IN: temporary [ t ] [ "foo?" "temporary" lookup word eq? ] unit-test + +[ ] [ + "IN: temporary TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop +] unit-test + +[ ] [ + "IN: temporary M: f foo ;" + "redefining-a-class-6" parse-stream drop +] unit-test + +[ f ] [ f "foo" "temporary" lookup execute ] unit-test + +[ ] [ + "IN: temporary TUPLE: foo ; GENERIC: foo" + "redefining-a-class-5" parse-stream drop +] unit-test + +[ f ] [ f "foo" "temporary" lookup execute ] unit-test + +[ ] [ + "IN: temporary TUPLE: foo ; GENERIC: foo" + "redefining-a-class-7" parse-stream drop +] unit-test + +[ ] [ + "IN: temporary TUPLE: foo ;" + "redefining-a-class-7" parse-stream drop +] unit-test + +[ t ] [ "foo" "temporary" lookup symbol? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e2efdd8163..bc129041e5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -464,9 +464,16 @@ SYMBOL: interactive-vocabs dup values concat prune swap keys ] keep ; +: fix-class-words ( -- ) + #! If a class word had a compound definition which was + #! removed, it must go back to being a symbol. + new-definitions get first2 diff + [ nip define-symbol ] assoc-each ; + : forget-smudged ( -- ) smudged-usage forget-all - over empty? [ 2dup smudged-usage-warning ] unless 2drop ; + over empty? [ 2dup smudged-usage-warning ] unless 2drop + fix-class-words ; : finish-parsing ( lines quot -- ) file get From fe8354f2f1bec5c94bce1ca1bd23edf61b63ff38 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Feb 2008 00:38:49 -0600 Subject: [PATCH 10/25] Add reverse complement unit test --- .../reverse-complement-test-out.txt | 0 .../reverse-complement-tests.factor | 13 +++++++++++++ 2 files changed, 13 insertions(+) mode change 100644 => 100755 extra/benchmark/reverse-complement/reverse-complement-test-out.txt create mode 100755 extra/benchmark/reverse-complement/reverse-complement-tests.factor diff --git a/extra/benchmark/reverse-complement/reverse-complement-test-out.txt b/extra/benchmark/reverse-complement/reverse-complement-test-out.txt old mode 100644 new mode 100755 diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor new file mode 100755 index 0000000000..c8da5f2c9f --- /dev/null +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -0,0 +1,13 @@ +IN: temporary +USING: tools.test benchmark.reverse-complement crypto.md5 +io.files kernel ; + +[ "c071aa7e007a9770b2fb4304f55a17e5" ] [ + "extra/benchmark/reverse-complement/reverse-complement-test-in.txt" + "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" + [ resource-path ] 2apply + reverse-complement + + "extra/benchmark/reverse-complement/reverse-complement-test-out.txt" + resource-path file>md5str +] unit-test From b58d61a541a709b98b90520543cc4afbe6840f51 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Feb 2008 02:18:50 -0600 Subject: [PATCH 11/25] Threads now inherit the namestack once again --- core/threads/threads-docs.factor | 7 +++++-- core/threads/threads.factor | 1 - extra/io/server/server.factor | 7 +------ extra/ui/tools/listener/listener.factor | 2 +- 4 files changed, 7 insertions(+), 10 deletions(-) diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index a8e4eef587..fa79906cdf 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private io threads.private continuations dlists init quotations strings -assocs heaps boxes ; +assocs heaps boxes namespaces ; IN: threads ARTICLE: "threads-start/stop" "Starting and stopping threads" @@ -127,7 +127,10 @@ HELP: spawn { $values { "quot" quotation } { "name" string } } { $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue." $nl -"The new thread begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." } +"The new thread begins with an empty data stack, an empty retain stack, and an empty catch stack. The name stack is inherited from the parent thread but may be cleared with " { $link init-namespaces } "." } +{ $notes + "The recommended way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." +} { $examples { $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" } } ; diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2ba5179c1c..70ed44e539 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -165,7 +165,6 @@ M: f nap nap-until ; resume-now [ dup set-self dup register-thread - init-namespaces V{ } set-catchstack { } set-retainstack >r { } set-datastack r> diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 6cc11ea6b6..a76ebcc450 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -10,10 +10,6 @@ SYMBOL: servers r [ dup get ] H{ } map>assoc [ swap bind ] 2curry r> - spawn drop ; - LOG: accepted-connection NOTICE : with-client ( client quot -- ) @@ -26,8 +22,7 @@ LOG: accepted-connection NOTICE : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 2curry - { log-service servers } "Client" spawn-vars + >r accept r> [ with-client ] 2curry "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec quot -- ) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 7617b0f32d..d828471609 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -133,7 +133,7 @@ M: stack-display tool-scroller : restart-listener ( listener -- ) dup com-end dup clear-output - [ listener-thread ] curry + [ init-namespaces listener-thread ] curry "Listener" spawn drop ; : init-listener ( listener -- ) From d2c5f28b653b3ec2398f4927a56d732a3263f195 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Feb 2008 02:19:38 -0600 Subject: [PATCH 12/25] Do tuple reshaping at the end of a compilation unit, preserving a consistent view of the heap to code running during compilation --- core/alien/alien-docs.factor | 10 +++---- core/bootstrap/compiler/compiler.factor | 16 +++++------ core/bootstrap/primitives.factor | 2 +- core/compiler/compiler-docs.factor | 33 ++++++---------------- core/compiler/compiler.factor | 26 ++++++----------- core/compiler/units/units-docs.factor | 8 ++++++ core/compiler/units/units.factor | 23 ++++++++++++--- core/cpu/x86/32/32.factor | 9 ++++-- core/memory/memory-docs.factor | 4 +-- core/tuples/tuples-tests.factor | 37 +++++++++++++++++++++++++ core/tuples/tuples.factor | 12 +++++--- core/words/words-docs.factor | 4 +-- 12 files changed, 112 insertions(+), 72 deletions(-) mode change 100644 => 100755 core/memory/memory-docs.factor diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 19ee52b039..475cf72d28 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -87,7 +87,7 @@ $nl HELP: alien-invoke-error { $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "The symbol or library could not be found." } { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." } @@ -103,7 +103,7 @@ HELP: alien-invoke HELP: alien-indirect-error { $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the three inputs to " { $link alien-indirect } " is not a literal value." } } @@ -120,7 +120,7 @@ HELP: alien-indirect HELP: alien-callback-error { $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:" { $list - { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." } + { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." } { "The return type or parameter list references an unknown C type." } { "One of the four inputs to " { $link alien-callback } " is not a literal value." } } @@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor" { $subsection alien-invoke } "Sometimes it is necessary to invoke a C function pointer, rather than a named C function:" { $subsection alien-indirect } -"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." -$nl -"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ; +"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ; ARTICLE: "alien-callback-gc" "Callbacks and code GC" "A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body." diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 608b5cb581..5ccde88e28 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -16,6 +16,14 @@ IN: bootstrap.compiler "cpu." cpu append require +: enable-compiler ( -- ) + [ optimized-recompile-hook ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ default-recompile-hook ] recompile-hook set-global ; + +enable-compiler + nl "Compiling some words to speed up bootstrap..." write flush @@ -74,12 +82,4 @@ nl malloc free memcpy } compile -: enable-compiler ( -- ) - [ compiled-usages recompile ] recompile-hook set-global ; - -: disable-compiler ( -- ) - [ default-recompile-hook ] recompile-hook set-global ; - -enable-compiler - " done" print flush diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 97712972f3..6b85eb63e8 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -30,7 +30,7 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set -[ drop ] recompile-hook set +[ default-recompile-hook ] recompile-hook set call call diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 17e6938a0c..7196a4b4fb 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -1,18 +1,14 @@ USING: generator help.markup help.syntax words io parser -assocs words.private sequences ; +assocs words.private sequences compiler.units ; IN: compiler ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly." $nl -"The main entry points to the optimizing compiler:" -{ $subsection compile } -{ $subsection recompile } -{ $subsection recompile-all } +"The main entry point to the optimizing compiler:" +{ $subsection optimized-recompile-hook } "Removing a word's optimized definition:" -{ $subsection decompile } -"The optimizing compiler can also compile and call a single quotation:" -{ $subsection compile-call } ; +{ $subsection decompile } ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" @@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler" ABOUT: "compiler" -HELP: compile -{ $values { "seq" "a sequence of words" } } -{ $description "Compiles a set of words. Ignores words which are already compiled." } ; - -HELP: recompile -{ $values { "seq" "a sequence of words" } } -{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ; - -HELP: compile-call -{ $values { "quot" "a quotation" } } -{ $description "Compiles and runs a quotation." } -{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; - -HELP: recompile-all -{ $description "Recompiles all words." } ; - HELP: decompile { $values { "word" word } } { $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; @@ -50,3 +30,8 @@ HELP: (compile) { $values { "word" word } } { $description "Compile a single word." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; + +HELP: optimized-recompile-hook +{ $values { "words" "a sequence of words" } { "alist" "an association list" } } +{ $description "Compile a set of words." } +{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index f0caec7ad1..e388b2a675 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -4,7 +4,7 @@ USING: kernel namespaces arrays sequences io inference.backend inference.state generator debugger math.parser prettyprint words compiler.units continuations vocabs assocs alien.compiler dlists optimizer definitions math compiler.errors threads graphs -generic ; +generic inference ; IN: compiler : compiled-usages ( words -- seq ) @@ -49,27 +49,17 @@ IN: compiler compile-loop ] if ; -: recompile ( words -- ) +: decompile ( word -- ) + f 2array 1array t modify-code-heap ; + +: optimized-recompile-hook ( words -- alist ) [ H{ } clone compile-queue set H{ } clone compiled set - [ queue-compile ] each + compiled-usages [ queue-compile ] each compile-queue get compile-loop compiled get >alist - dup [ drop crossref? ] assoc-contains? - modify-code-heap - ] with-scope ; inline - -: compile ( words -- ) - [ compiled? not ] subset recompile ; - -: compile-call ( quot -- ) - H{ } clone changed-words - [ define-temp dup 1array compile ] with-variable - execute ; + ] with-scope ; : recompile-all ( -- ) - [ all-words recompile ] with-compiler-errors ; - -: decompile ( word -- ) - f 2array 1array t modify-code-heap ; + forget-errors all-words compile ; diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index 99124d40ae..d30c5457d5 100755 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -61,3 +61,11 @@ HELP: modify-code-heap ( alist -- ) { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; + +HELP: compile +{ $values { "seq" "a sequence of words" } } +{ $description "Compiles a set of words." } ; + +HELP: compile-call +{ $values { "quot" "a quotation" } } +{ $description "Compiles and runs a quotation." } ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 225e1c17c6..ff8cd50f84 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -63,24 +63,39 @@ GENERIC: definitions-changed ( assoc obj -- ) dup changed-words get update dup dup changed-vocabs update ; +: compile ( words -- ) + recompile-hook get call + dup [ drop crossref? ] assoc-contains? + modify-code-heap ; + +SYMBOL: post-compile-tasks + +: after-compilation ( quot -- ) + post-compile-tasks get push ; + : finish-compilation-unit ( -- ) changed-words get keys recompile-hook get call + dup [ drop crossref? ] assoc-contains? + post-compile-tasks get [ call ] each + modify-code-heap changed-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) [ H{ } clone changed-words set H{ } clone forgotten-definitions set + V{ } clone post-compile-tasks set new-definitions set old-definitions set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline -: default-recompile-hook - [ f ] { } map>assoc - dup [ drop crossref? ] assoc-contains? - modify-code-heap ; +: compile-call ( quot -- ) + [ define-temp ] with-compilation-unit execute ; + +: default-recompile-hook ( words -- alist ) + [ f ] { } map>assoc ; recompile-hook global [ [ default-recompile-hook ] or ] diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index ecae55e69a..649cfbabab 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup generator system alien.compiler combinators command-line -compiler io vocabs.loader ; +compiler compiler.units io vocabs.loader ; IN: cpu.x86.32 PREDICATE: x86-backend x86-32-backend @@ -281,7 +281,10 @@ T{ x86-backend f 4 } compiler-backend set-global "-no-sse2" cli-args member? [ "Checking if your CPU supports SSE2..." print flush - [ sse2? ] compile-call [ + [ optimized-recompile-hook ] recompile-hook [ + [ sse2? ] compile-call + ] with-variable + [ " - yes" print "cpu.x86.sse2" require ] [ diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor old mode 100644 new mode 100755 index 7d99e6311e..e29844dc89 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -47,8 +47,8 @@ HELP: gc-time ( -- n ) { $values { "n" "a timestamp in milliseconds" } } { $description "Outputs the total time spent in garbage collection during this Factor session." } ; -HELP: data-room ( -- cards semi generations ) -{ $values { "cards" "number of bytes reserved for card marking" } { "semi" "number of bytes reserved for tenured semi-space" } { "generations" "array of free/total bytes pairs" } } +HELP: data-room ( -- cards generations ) +{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } } { $description "Queries the runtime for memory usage information." } ; HELP: code-room ( -- code-free code-total ) diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index c9656a3b9e..8680a3ce61 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -237,3 +237,40 @@ C: erg's-reshape-problem [ "IN: temporary SYMBOL: not-a-class C: not-a-class" eval ] [ [ check-tuple? ] is? ] must-fail-with + +! Hardcore unit tests +USE: threads + +\ thread "slot-names" word-prop "slot-names" set + +[ ] [ + [ + \ thread { "xxx" } "slot-names" get append + define-tuple-class + ] with-compilation-unit + + [ 1337 sleep ] "Test" spawn drop + + [ + \ thread "slot-names" get + define-tuple-class + ] with-compilation-unit +] unit-test + +USE: vocabs + +\ vocab "slot-names" word-prop "slot-names" set + +[ ] [ + [ + \ vocab { "xxx" } "slot-names" get append + define-tuple-class + ] with-compilation-unit + + all-words drop + + [ + \ vocab "slot-names" get + define-tuple-class + ] with-compilation-unit +] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index ea74645525..e48a803659 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -3,7 +3,7 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic -classes classes.private slots slots.private ; +classes classes.private slots slots.private compiler.units ; IN: tuples M: tuple delegate 3 slot ; @@ -35,9 +35,12 @@ M: tuple class class-of-tuple ; append (>tuple) ; : reshape-tuples ( class newslots -- ) - >r dup [ swap class eq? ] curry instances dup - rot "slot-names" word-prop r> permutation - [ reshape-tuple ] curry map become ; + >r dup "slot-names" word-prop r> permutation + [ + >r [ swap class eq? ] curry instances dup r> + [ reshape-tuple ] curry map + become + ] 2curry after-compilation ; : old-slots ( class newslots -- seq ) swap "slots" word-prop 1 tail-slice @@ -55,6 +58,7 @@ M: tuple class class-of-tuple ; over "slot-names" word-prop over = [ 2dup forget-slots 2dup reshape-tuples + over changed-word over redefined ] unless ] when 2drop ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 91b5295427..f1cc678d17 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -76,9 +76,9 @@ $nl ARTICLE: "declarations" "Declarations" "Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word." $nl -"The first declaration specifies the time when a word runs. It affects both interpreted and compiled definitions." +"The first declaration specifies the time when a word runs. It affects both the non-optimizing and optimizing compilers:" { $subsection POSTPONE: parsing } -"The remaining declarations only affect compiled definitions. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." +"The remaining declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." { $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } { $subsection POSTPONE: inline } { $subsection POSTPONE: foldable } From a4518150a7f34165fc7d810d95899c4a85fe1e66 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 Feb 2008 12:32:36 -0600 Subject: [PATCH 13/25] fix postgresql connect error message fix unit test --- extra/db/postgresql/lib/lib.factor | 12 ++++++--- extra/db/postgresql/postgresql.factor | 4 +-- extra/db/tuples/tuples-tests.factor | 3 ++- extra/db/tuples/tuples.factor | 35 +++++++++++++++++++-------- 4 files changed, 37 insertions(+), 17 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index cdfa3535a0..25b3a6d2cf 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -2,21 +2,25 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types -db.types tools.walker ; +db.types tools.walker ascii splitting ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) dup zero? [ drop f ] [ - PQresultErrorMessage [ CHAR: \n = ] right-trim + PQresultErrorMessage [ blank? ] trim ] if ; : postgres-result-error ( res -- ) postgresql-result-error-message [ throw ] when* ; +: (postgresql-error-message) ( handle -- str ) + PQerrorMessage + "\n" split [ [ blank? ] trim ] map "\n" join ; + : postgresql-error-message ( -- str ) - db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ; + db get db-handle (postgresql-error-message) ; : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; @@ -27,7 +31,7 @@ IN: db.postgresql.lib : connect-postgres ( host port pgopts pgtty db user pass -- conn ) PQsetdbLogin - dup PQstatus zero? [ postgresql-error-message throw ] unless ; + dup PQstatus zero? [ (postgresql-error-message) throw ] unless ; : do-postgresql-statement ( statement -- res ) db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index ef7c870501..85fcca4b43 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -208,7 +208,7 @@ M: postgresql-db ( tuple -- statement ) ");" 0% ] postgresql-make ; -M: postgresql-db ( tuple -- statement ) +M: postgresql-db ( class -- statement ) [ "update " 0% 0% " set " 0% @@ -220,7 +220,7 @@ M: postgresql-db ( tuple -- statement ) dup sql-spec-column-name 0% " = " 0% bind% ] postgresql-make ; -M: postgresql-db ( tuple -- statement ) +M: postgresql-db ( class -- statement ) [ "delete from " 0% 0% " where " 0% diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index b484ccf016..9177e4981c 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -31,7 +31,8 @@ SYMBOL: the-person [ ] [ the-person get update-tuple ] unit-test - ! T{ person f f f 200 f } select-tuples + [ T{ person f 1 "billy" 200 3.14 } ] + [ T{ person f 1 } select-tuple ] unit-test ! [ ] [ the-person get delete-tuple ] unit-test ! [ ] [ person drop-table ] unit-test diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index ea66d5890f..5c9e3f6b64 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -32,6 +32,12 @@ HOOK: db ( tuple -- obj ) HOOK: row-column-typed db ( result-set n type -- sql ) +: resulting-tuple ( class out-params row -- tuple ) + >r >r construct-empty r> r> rot [ + >r [ sql-spec-type sql-type>factor-type ] keep + sql-spec-slot-name r> set-slot-named + ] curry 2each ; + : query-tuple ( tuple statement -- seq ) dupd [ query-results [ sql-row ] with-disposal ] keep @@ -40,8 +46,14 @@ HOOK: row-column-typed db ( result-set n type -- sql ) sql-spec-slot-name r> set-slot-named ] curry 2each ; -: query-tuples ( statement -- seq ) - ; +: query-tuples ( tuple statement -- seq ) + dup query-results [ + statement-out-params [ +break + >r [ sql-spec-type sql-type>factor-type ] keep + sql-spec-slot-name r> set-slot-named + ] with with query-map + ] with-disposal ; : sql-props ( class -- columns table ) dup db-columns swap db-table ; @@ -51,7 +63,7 @@ HOOK: row-column-typed db ( result-set n type -- sql ) : insert-native ( tuple -- ) dup class - [ bind-tuple ] 2keep query-tuple ; + [ bind-tuple ] 2keep query-tuple drop ; : insert-assigned ( tuple -- ) dup @@ -65,13 +77,12 @@ HOOK: row-column-typed db ( result-set n type -- sql ) ] if ; : update-tuple ( tuple -- ) - execute-statement ; + dup class + [ bind-tuple ] keep execute-statement ; : update-tuples ( seq -- ) execute-statement ; - - ! : persist ( tuple -- ) HOOK: delete-by-id db ( tuple -- ) @@ -80,10 +91,14 @@ HOOK: delete-by-id db ( tuple -- ) HOOK: db ( tuple -- tuple ) -: select-tuple ( tuple -- tuple ) +: setup-select ( tuple -- tuple statement ) dup dup class - [ bind-tuple ] 2keep query-tuple ; + [ bind-tuple ] 2keep ; + +: select-tuple ( tuple -- tuple ) + setup-select query-tuple ; : select-tuples ( tuple -- tuple ) - dup dup class - [ bind-tuple ] 2keep query-tuples ; + setup-select query-tuples ; + +! uniqueResult From 425fd8e551a4e1c74755d68b202be332f7794ef7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Feb 2008 17:40:28 -0600 Subject: [PATCH 14/25] edit-vocab word --- extra/editors/editors.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index f0c5289dd9..3b65466225 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -35,6 +35,9 @@ SYMBOL: edit-hook : edit ( defspec -- ) where [ first2 edit-location ] when* ; +: edit-vocab ( name -- ) + vocab-source-path 1 edit-location ; + : :edit ( -- ) error get delegates [ parse-error? ] find-last nip [ dup parse-error-file source-file-path ?resource-path From 643b3b7dcb413e4e46286320f7533eb172ed4f1e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Feb 2008 17:40:39 -0600 Subject: [PATCH 15/25] Fix bootstrap --- core/bootstrap/stage2.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3bc82bbe6a..195c0f65ec 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -29,9 +29,7 @@ SYMBOL: bootstrap-time : compile-remaining ( -- ) "Compiling remaining words..." print flush - vocabs [ - words "compile" "compiler" lookup execute - ] each ; + vocabs [ words compile ] each ; : count-words ( pred -- ) all-words swap subset length number>string write ; From 609e5f0cfb7ca36d1d5346fe319fff4f5af53fa4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Feb 2008 17:40:58 -0600 Subject: [PATCH 16/25] Rename "doc-root" variable to doc-root, fix information leakage in source responder --- extra/webapps/cgi/cgi.factor | 2 +- extra/webapps/file/file.factor | 13 +++++++------ extra/webapps/fjsc/fjsc.factor | 4 ++-- extra/webapps/source/source.factor | 6 ++++-- 4 files changed, 14 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/webapps/cgi/cgi.factor diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor old mode 100644 new mode 100755 index 967036a797..6be99088d0 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -58,7 +58,7 @@ SYMBOL: cgi-root ] with-stream ; : serve-regular-file ( -- ) - cgi-root get "doc-root" [ file-responder ] with-variable ; + cgi-root get doc-root [ file-responder ] with-variable ; : do-cgi ( name -- ) { diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 552f5e0977..c324561279 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -1,14 +1,15 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: calendar html io io.files kernel math math.parser http.server.responders http.server.templating namespaces parser sequences strings assocs hashtables debugger http.mime sorting html.elements logging ; - IN: webapps.file +SYMBOL: doc-root + : serving-path ( filename -- filename ) - "" or "doc-root" get swap path+ ; + "" or doc-root get swap path+ ; : file-http-date ( filename -- string ) file-modified unix-time>timestamp timestamp>http-string ; @@ -61,7 +62,7 @@ SYMBOL: page \ run-page DEBUG add-input-logging : include-page ( filename -- ) - "doc-root" get swap path+ run-page ; + serving-path run-page ; : serve-fhtml ( filename -- ) serving-html @@ -115,14 +116,14 @@ SYMBOL: page ] if ; : file-responder ( -- ) - "doc-root" get [ + doc-root get [ "argument" get serve-object ] [ "404 doc-root not set" httpd-error ] if ; global [ - ! Serves files from a directory stored in the "doc-root" + ! Serves files from a directory stored in the doc-root ! variable. You can set the variable in the global ! namespace, or inside the responder. "file" [ file-responder ] add-simple-responder diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 55609c72f9..56ecb3f546 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -53,7 +53,7 @@ IN: webapps.fjsc ! the 'fjsc' responder. "fjsc-resources" [ [ - "extra/fjsc/resources/" resource-path "doc-root" set + "extra/fjsc/resources/" resource-path doc-root set file-responder ] with-scope ] add-simple-responder @@ -62,7 +62,7 @@ IN: webapps.fjsc ! 'termlib'. "fjsc-repl-resources" [ [ - "extra/webapps/fjsc/resources/" resource-path "doc-root" set + "extra/webapps/fjsc/resources/" resource-path doc-root set file-responder ] with-scope ] add-simple-responder ; diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor index 4c0701c687..98fb5b8873 100755 --- a/extra/webapps/source/source.factor +++ b/extra/webapps/source/source.factor @@ -15,14 +15,16 @@ IN: webapps.source : source-responder ( path mime-type -- ) drop serving-html - [ dup htmlize-stream ] with-html-stream ; + [ + dup file-name swap htmlize-stream + ] with-html-stream ; global [ ! Serve up our own source code "source" [ "argument" get check-source-path [ [ - "" resource-path "doc-root" set + "" resource-path doc-root set [ source-responder ] serve-file-hook set file-responder ] with-scope From b1876ee2698cfc592dd37ed35f7229d5164af197 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 Feb 2008 19:23:14 -0600 Subject: [PATCH 17/25] select-tuple, select-tuples work for postgresql --- extra/db/tuples/tuples.factor | 43 +++++++++++++++++------------------ 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 5c9e3f6b64..da69452fa3 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -32,28 +32,28 @@ HOOK: db ( tuple -- obj ) HOOK: row-column-typed db ( result-set n type -- sql ) -: resulting-tuple ( class out-params row -- tuple ) - >r >r construct-empty r> r> rot [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named - ] curry 2each ; +: 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 + ] curry 2each + ] keep ; -: query-tuple ( tuple statement -- seq ) - dupd +: query-tuples ( statement -- seq ) + [ statement-out-params ] keep query-results [ + ! out-parms result-set + [ + sql-row swap resulting-tuple + ] with query-map + ] with-disposal ; + +: query-modify-tuple ( tuple statement -- ) [ query-results [ sql-row ] with-disposal ] keep statement-out-params rot [ >r [ sql-spec-type sql-type>factor-type ] keep sql-spec-slot-name r> set-slot-named ] curry 2each ; - -: query-tuples ( tuple statement -- seq ) - dup query-results [ - statement-out-params [ -break - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named - ] with with query-map - ] with-disposal ; : sql-props ( class -- columns table ) dup db-columns swap db-table ; @@ -63,7 +63,7 @@ break : insert-native ( tuple -- ) dup class - [ bind-tuple ] 2keep query-tuple drop ; + [ bind-tuple ] 2keep query-modify-tuple ; : insert-assigned ( tuple -- ) dup @@ -91,14 +91,13 @@ HOOK: delete-by-id db ( tuple -- ) HOOK: db ( tuple -- tuple ) -: setup-select ( tuple -- tuple statement ) +: setup-select ( tuple -- statement ) dup dup class - [ bind-tuple ] 2keep ; + [ bind-tuple ] keep ; : select-tuple ( tuple -- tuple ) - setup-select query-tuple ; + setup-select query-tuples first ; -: select-tuples ( tuple -- tuple ) - setup-select query-tuples ; +: select-tuples ( tuple -- tuple ) setup-select query-tuples ; ! uniqueResult From 86bbec1f428321879b9c40c7d161a7807b613224 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 24 Feb 2008 21:30:45 -0600 Subject: [PATCH 18/25] builder: minor fixes --- extra/builder/builder.factor | 1 + extra/builder/release/release.factor | 22 ++++++++++++++++++---- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d9961f9452..b123b9c428 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -178,6 +178,7 @@ SYMBOL: builder-recipients : build ( -- ) [ (build) ] [ drop ] recover + maybe-release [ send-builder-email ] [ drop "not sending mail" . ] recover ".." cd { "rm" "-rf" "factor" } run-process drop [ compress-image ] [ drop ] recover ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index db903c9501..eb947ff14f 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,12 +1,12 @@ USING: kernel namespaces sequences combinators io.files io.launcher - combinators.cleave builder.common builder.util ; + bake combinators.cleave builder.common builder.util ; IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: releases ( -- path ) builds "/releases" append ; +: releases ( -- path ) builds "/releases" append dup make-directory ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -57,7 +57,8 @@ USING: system sequences splitting ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: move-file ( source destination -- ) swap { "mv" , , } run-process drop ; +: move-file ( source destination -- ) + swap { "mv" , , } bake run-process drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -114,4 +115,17 @@ USING: system sequences splitting ; { "macosx" [ macosx-release ] } } case ; - \ No newline at end of file + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: release? ( -- ? ) + { + "../load-everything-vocabs" + "../test-all-vocabs" + } + [ eval-file empty? ] + all? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: maybe-release ( -- ) release? [ release ] when ; \ No newline at end of file From a902349dc481ba1fe780970bac221403aa182a12 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Feb 2008 03:38:37 -0600 Subject: [PATCH 19/25] Fix overly long bootstrap time --- core/bootstrap/stage2.factor | 2 +- core/compiler/compiler.factor | 7 +------ core/compiler/units/units.factor | 14 ++++++++++---- core/inference/state/state.factor | 5 +---- core/words/words.factor | 8 ++++++++ 5 files changed, 21 insertions(+), 15 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 195c0f65ec..3b5918a4f8 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -29,7 +29,7 @@ SYMBOL: bootstrap-time : compile-remaining ( -- ) "Compiling remaining words..." print flush - vocabs [ words compile ] each ; + vocabs [ words [ compiled? not ] subset compile ] each ; : count-words ( pred -- ) all-words swap subset length number>string write ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index e388b2a675..111d84cde0 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -7,11 +7,6 @@ optimizer definitions math compiler.errors threads graphs generic inference ; IN: compiler -: compiled-usages ( words -- seq ) - [ [ dup ] H{ } map>assoc dup ] keep [ - compiled-usage [ nip +inlined+ eq? ] assoc-subset update - ] with each keys ; - : ripple-up ( word -- ) compiled-usage [ drop queue-compile ] assoc-each ; @@ -56,7 +51,7 @@ IN: compiler [ H{ } clone compile-queue set H{ } clone compiled set - compiled-usages [ queue-compile ] each + [ queue-compile ] each compile-queue get compile-loop compiled get >alist ] with-scope ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index ff8cd50f84..5fcf7b3047 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -73,11 +73,17 @@ SYMBOL: post-compile-tasks : after-compilation ( quot -- ) post-compile-tasks get push ; +: call-recompile-hook ( -- ) + changed-words get keys + compiled-usages recompile-hook get call ; + +: call-post-compile-tasks ( -- ) + post-compile-tasks get [ call ] each ; + : finish-compilation-unit ( -- ) - changed-words get keys recompile-hook get call - dup [ drop crossref? ] assoc-contains? - post-compile-tasks get [ call ] each - modify-code-heap + call-recompile-hook + call-post-compile-tasks + dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; : with-compilation-unit ( quot -- ) diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor index cf11ffc88a..a426f410e2 100755 --- a/core/inference/state/state.factor +++ b/core/inference/state/state.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs namespaces sequences kernel ; +USING: assocs namespaces sequences kernel words ; IN: inference.state ! Nesting state to solve recursion @@ -31,9 +31,6 @@ SYMBOL: current-node ! Words that the current dataflow IR depends on SYMBOL: dependencies -SYMBOL: +inlined+ -SYMBOL: +called+ - : depends-on ( word how -- ) swap dependencies get dup [ 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if diff --git a/core/words/words.factor b/core/words/words.factor index efb3d06a9b..e8b3fd9781 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -111,9 +111,17 @@ compiled-crossref global [ H{ } assoc-like ] change-at dup compiled-unxref compiled-crossref get delete-at ; +SYMBOL: +inlined+ +SYMBOL: +called+ + : compiled-usage ( word -- assoc ) compiled-crossref get at ; +: compiled-usages ( words -- seq ) + [ [ dup ] H{ } map>assoc dup ] keep [ + compiled-usage [ nip +inlined+ eq? ] assoc-subset update + ] with each keys ; + M: word redefined* ( word -- ) { "inferred-effect" "no-effect" } reset-props ; From 27245cd979c565c9491e5a94368119e910f5f63c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Feb 2008 03:38:52 -0600 Subject: [PATCH 20/25] Clean up io.paths file search combinators --- extra/editors/editpadpro/editpadpro.factor | 2 +- extra/editors/gvim/windows/windows.factor | 2 +- extra/io/paths/paths.factor | 85 +++++++++++----------- 3 files changed, 46 insertions(+), 43 deletions(-) mode change 100644 => 100755 extra/editors/gvim/windows/windows.factor mode change 100644 => 100755 extra/io/paths/paths.factor diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index 5a8168a181..eb31b2aa47 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -6,7 +6,7 @@ IN: editors.editpadpro : editpadpro-path \ editpadpro-path get-global [ program-files "JGsoft" path+ - [ >lower "editpadpro.exe" tail? ] find-file-breadth + t [ >lower "editpadpro.exe" tail? ] find-file ] unless* ; : editpadpro ( file line -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor old mode 100644 new mode 100755 index e68bf04732..030c968e81 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -5,5 +5,5 @@ IN: editors.gvim.windows M: windows-io gvim-path \ gvim-path get-global [ program-files "vim" path+ - [ "gvim.exe" tail? ] find-file-breadth + t [ "gvim.exe" tail? ] find-file ] unless* ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor old mode 100644 new mode 100755 index a393cef7fa..8980eacc3d --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,49 +1,52 @@ -USING: arrays assocs combinators.lib dlists io.files -kernel namespaces sequences shuffle vectors ; +USING: io.files kernel sequences new-slots accessors +dlists arrays ; IN: io.paths -! HOOK: library-roots io-backend ( -- seq ) -! HOOK: binary-roots io-backend ( -- seq ) +TUPLE: directory-iterator path bfs queue ; -r path+ r> ] with* assoc-map ; +: qualified-directory ( path -- seq ) + dup directory [ first2 >r path+ r> 2array ] with map ; -: get-paths ( dir -- paths ) - dup directory append-path ; +: push-directory ( path iter -- ) + >r qualified-directory r> [ + dup queue>> swap bfs>> + [ push-front ] [ push-back ] if + ] curry each ; -: (walk-dir) ( path -- ) - first2 [ - get-paths dup keys % [ (walk-dir) ] each +: ( path bfs? -- iterator ) + directory-iterator construct-boa + dup path>> over push-directory ; + +: next-file ( iter -- file/f ) + dup queue>> dlist-empty? [ drop f ] [ + dup queue>> pop-back first2 + [ over push-directory next-file ] [ nip ] if + ] if ; + +: iterate-directory ( iter quot -- obj ) + 2dup >r >r >r next-file dup [ + r> call dup [ + r> r> 2drop + ] [ + drop r> r> iterate-directory + ] if ] [ + drop r> r> r> 3drop f + ] if ; inline + +: prepare-find-file ( path bfs? quot -- iter quot' ) + >r r> [ keep and ] curry ; inline + +: find-file ( path bfs? quot -- path/f ) + prepare-find-file iterate-directory ; + +: find-all-files ( path bfs? quot -- paths ) + prepare-find-file V{ } clone [ + [ over [ push ] [ 2drop ] if f ] curry compose + iterate-directory drop - ] if ; -PRIVATE> + ] keep ; inline -: walk-dir ( path -- seq ) - dup directory? 2array [ (walk-dir) ] { } make ; - -GENERIC# find-file* 1 ( obj quot -- path/f ) - -M: dlist find-file* ( dlist quot -- path/f ) - over dlist-empty? [ 2drop f ] [ - 2dup >r pop-front get-paths dup r> assoc-find - [ drop 3nip ] - [ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if - ] if ; - -M: vector find-file* ( vector quot -- path/f ) - over empty? [ 2drop f ] [ - 2dup >r pop get-paths dup r> assoc-find - [ drop 3nip ] - [ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if - ] if ; - -: prepare-find-file ( quot -- quot ) - [ drop ] swap compose ; - -: find-file-depth ( path quot -- path/f ) - prepare-find-file >r 1vector r> find-file* ; - -: find-file-breadth ( path quot -- path/f ) - prepare-find-file >r 1dlist r> find-file* ; +: recursive-directory ( path bfs? -- paths ) + + [ dup next-file dup ] [ ] [ drop ] unfold nip ; From 308a5db9963978cba5cebfb2394c23da4c1d3c9c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 25 Feb 2008 12:42:52 -0600 Subject: [PATCH 21/25] Binary on winnt is now 'factor.exe' instead of 'factor-nt.exe' --- vm/Config.windows.nt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/Config.windows.nt b/vm/Config.windows.nt index c712c7d053..140dea8fdd 100644 --- a/vm/Config.windows.nt +++ b/vm/Config.windows.nt @@ -1,5 +1,5 @@ LIBS = -lm -EXE_SUFFIX=-nt +EXE_SUFFIX= DLL_SUFFIX=-nt PLAF_DLL_OBJS += vm/os-windows-nt.o PLAF_EXE_OBJS += vm/resources.o From b68c60488a4d2b56cf2e966970b34677453d978d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 25 Feb 2008 13:05:11 -0600 Subject: [PATCH 22/25] Dll on winnt is now 'factor.dll' instead of 'factor-nt.dll' to be consistent with the binary name. --- vm/Config.windows.nt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/Config.windows.nt b/vm/Config.windows.nt index 140dea8fdd..4c6279bf8f 100644 --- a/vm/Config.windows.nt +++ b/vm/Config.windows.nt @@ -1,6 +1,6 @@ LIBS = -lm EXE_SUFFIX= -DLL_SUFFIX=-nt +DLL_SUFFIX= PLAF_DLL_OBJS += vm/os-windows-nt.o PLAF_EXE_OBJS += vm/resources.o PLAF_EXE_OBJS += vm/main-windows-nt.o From 4b92faed909328441dda1855119fd1d2d7fe779a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 25 Feb 2008 13:10:35 -0600 Subject: [PATCH 23/25] Change 'os-windows-nt.h' to reflect rename to 'factor.dll' --- vm/os-windows-nt.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h index e289b6617d..1b680befad 100755 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -13,8 +13,8 @@ typedef char F_SYMBOL; #define from_symbol_string from_char_string #define FACTOR_OS_STRING "winnt" -#define FACTOR_DLL L"factor-nt.dll" -#define FACTOR_DLL_NAME "factor-nt.dll" +#define FACTOR_DLL L"factor.dll" +#define FACTOR_DLL_NAME "factor.dll" void c_to_factor_toplevel(CELL quot); long exception_handler(PEXCEPTION_POINTERS pe); From 94b183d5e672eea90bd0fd05f32ca6a043b10739 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 Feb 2008 14:50:42 -0600 Subject: [PATCH 24/25] db.tuples tests pass for postgresql redo the with-db word --- extra/db/db.factor | 11 +- extra/db/postgresql/postgresql-tests.factor | 24 ++-- extra/db/postgresql/postgresql.factor | 28 ++-- extra/db/sqlite/sqlite.factor | 135 ++++++++++---------- extra/db/tuples/tuples-tests.factor | 13 +- extra/db/tuples/tuples.factor | 26 ++-- 6 files changed, 117 insertions(+), 120 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 36f2908078..d5242659ae 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -11,6 +11,8 @@ TUPLE: db handle ; ! H{ } clone H{ } clone H{ } clone db construct-boa ; +GENERIC: make-db* ( seq class -- db ) +: make-db ( seq class -- db ) construct-empty make-db* ; GENERIC: db-open ( db -- ) HOOK: db-close db ( handle -- ) @@ -64,7 +66,6 @@ GENERIC: more-rows? ( result-set -- ? ) [ set-statement-bind-params ] keep t swap set-statement-bound? ; - : init-result-set ( result-set -- ) dup #rows over set-result-set-max 0 swap set-result-set-n ; @@ -90,11 +91,9 @@ GENERIC: more-rows? ( result-set -- ? ) : query-map ( statement quot -- seq ) accumulator >r query-each r> { } like ; inline -: with-db ( db quot -- ) - [ - over db-open - [ db swap with-variable ] curry with-disposal - ] with-scope ; +: with-db ( db seq quot -- ) + >r make-db dup db-open db r> + [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ; : default-query ( query -- result-set ) query-results [ [ sql-row ] query-map ] with-disposal ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 09e81e6ec3..7ea2bb629a 100755 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -8,7 +8,7 @@ IN: temporary IN: scratchpad : test-db ( -- postgresql-db ) - "localhost" "postgres" "" "factor-test" ; + { "localhost" "postgres" "" "factor-test" } postgresql-db ; IN: temporary [ ] [ test-db [ ] with-db ] unit-test @@ -217,17 +217,9 @@ basket "BASKET" ! Insert [ - "select add_puppy($1, $2);" - { - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } } - T{ sql-spec f "age" "AGE" INTEGER { } } - } - { - T{ sql-spec f "id" "ID" +native-id+ { +not-null+ } +native-id+ } - } ] [ T{ postgresql-db } db [ - puppy dup db-columns swap db-table insert-sql* >r >r >lower r> r> + puppy ] with-variable ] unit-test @@ -249,7 +241,7 @@ basket "BASKET" { } ] [ T{ postgresql-db } db [ - kitty dup db-columns swap db-table insert-sql* >r >r >lower r> r> + kitty ] with-variable ] unit-test @@ -272,7 +264,7 @@ basket "BASKET" { } ] [ T{ postgresql-db } db [ - puppy dup db-columns swap db-table update-sql* >r >r >lower r> r> + puppy dup db-columns swap db-table >r >r >lower r> r> ] with-variable ] unit-test @@ -294,7 +286,7 @@ basket "BASKET" { } ] [ T{ postgresql-db } db [ - kitty dup db-columns swap db-table update-sql* >r >r >lower r> r> + kitty dup db-columns swap db-table >r >r >lower r> r> ] with-variable ] unit-test @@ -315,7 +307,7 @@ basket "BASKET" { } ] [ T{ postgresql-db } db [ - puppy dup db-columns swap db-table delete-sql* >r >r >lower r> r> + puppy dup db-columns swap db-table >r >r >lower r> r> ] with-variable ] unit-test @@ -335,7 +327,7 @@ basket "BASKET" { } ] [ T{ postgresql-db } db [ - kitty dup db-columns swap db-table delete-sql* + kitty dup db-columns swap db-table ] with-variable ] unit-test @@ -359,6 +351,6 @@ basket "BASKET" ] [ T{ postgresql-db } db [ T{ puppy f f "Mr. Clunkers" } - select-by-slots-sql + ] with-variable ] unit-test diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 85fcca4b43..e5bb3b0695 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -14,16 +14,18 @@ TUPLE: postgresql-result-set ; postgresql-statement construct-delegate ; -: ( host user pass db -- obj ) - { - set-postgresql-db-host - set-postgresql-db-user - set-postgresql-db-pass - set-postgresql-db-db - } postgresql-db construct ; +M: postgresql-db make-db* ( seq tuple -- db ) + >r first4 r> [ + { + set-postgresql-db-host + set-postgresql-db-user + set-postgresql-db-pass + set-postgresql-db-db + } set-slots + ] keep ; M: postgresql-db db-open ( db -- ) - dup { + dup { postgresql-db-host postgresql-db-port postgresql-db-pgopts @@ -36,9 +38,6 @@ M: postgresql-db db-open ( db -- ) M: postgresql-db dispose ( db -- ) db-handle PQfinish ; -: with-postgresql ( host ust pass db quot -- ) - >r r> with-disposal ; - M: postgresql-statement bind-statement* ( seq statement -- ) set-statement-bind-params ; @@ -186,7 +185,7 @@ M: postgresql-db drop-sql-statement ( class -- seq ) [ drop-function-sql , ] [ 2drop ] if ] { } make ; -M: postgresql-db ( tuple -- statement ) +M: postgresql-db ( class -- statement ) [ "select add_" 0% 0% "(" 0% @@ -196,7 +195,7 @@ M: postgresql-db ( tuple -- statement ) ");" 0% ] postgresql-make ; -M: postgresql-db ( tuple -- statement ) +M: postgresql-db ( class -- statement ) [ "insert into " 0% 0% "(" 0% @@ -208,6 +207,9 @@ M: postgresql-db ( tuple -- statement ) ");" 0% ] postgresql-make ; +M: postgresql-db insert-tuple* ( tuple statement -- ) + query-modify-tuple ; + M: postgresql-db ( class -- statement ) [ "update " 0% 0% diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 249856e8bc..b8e8bca300 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -23,7 +23,6 @@ M: sqlite-db dispose ( db -- ) dispose-db ; >r r> with-db ; inline TUPLE: sqlite-statement ; -C: sqlite-statement TUPLE: sqlite-result-set has-more? ; @@ -31,9 +30,15 @@ M: sqlite-db ( str -- obj ) ; M: sqlite-db ( str -- obj ) - db get db-handle over sqlite-prepare - { set-statement-sql set-statement-handle } statement construct - [ set-delegate ] keep ; + db get db-handle + { + set-statement-sql + set-statement-in-params + set-statement-out-params + set-statement-handle + } statement construct + dup statement-handle over statement-sql sqlite-prepare + sqlite-statement construct-delegate ; M: sqlite-statement dispose ( statement -- ) statement-handle sqlite-finalize ; @@ -41,10 +46,11 @@ M: sqlite-statement dispose ( statement -- ) M: sqlite-result-set dispose ( result-set -- ) f swap set-result-set-handle ; -: sqlite-bind ( triples handle -- ) - swap [ first3 sqlite-bind-type ] with each ; +: sqlite-bind ( specs handle -- ) +break + swap [ sqlite-bind-type ] with each ; -M: sqlite-statement bind-statement* ( triples statement -- ) +M: sqlite-statement bind-statement* ( obj statement -- ) statement-handle sqlite-bind ; M: sqlite-statement reset-statement ( statement -- ) @@ -54,8 +60,8 @@ M: sqlite-statement reset-statement ( statement -- ) db get db-handle sqlite3_last_insert_rowid dup zero? [ "last-id failed" throw ] when ; -M: sqlite-statement insert-statement ( statement -- id ) - execute-statement last-insert-id ; +M: sqlite-statement insert-tuple* ( tuple statement -- ) + execute-statement last-insert-id swap set-primary-key ; M: sqlite-result-set #columns ( result-set -- n ) result-set-handle sqlite-#columns ; @@ -74,6 +80,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? ) sqlite-result-set-has-more? ; M: sqlite-statement query-results ( query -- result-set ) +break dup statement-handle sqlite-result-set dup advance-row ; @@ -86,85 +93,83 @@ M: sqlite-db commit-transaction ( -- ) M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -M: sqlite-db create-sql ( specs table -- sql ) - [ - "create table " % % - "(" % [ ", " % ] [ - dup sql-spec-column-name % - " " % - dup sql-spec-type t lookup-type % - modifiers% - ] interleave ");" % - ] "" make ; +: sqlite-make ( class quot -- ) + >r sql-props r> + { "" { } { } } nmake ; -M: sqlite-db drop-sql ( specs table -- sql ) +M: sqlite-db create-sql-statement ( class -- statement ) [ - "drop table " % % ";" % drop - ] "" make ; + "create table " 0% 0% + "(" 0% [ ", " 0% ] [ + dup sql-spec-column-name 0% + " " 0% + dup sql-spec-type t lookup-type 0% + modifiers 0% + ] interleave ");" 0% + ] sqlite-make ; -M: sqlite-db insert-sql* ( specs table -- sql ) +M: sqlite-db drop-sql-statement ( class -- statement ) [ - "insert into " % % - "(" % + "drop table " 0% 0% ";" 0% drop + ] sqlite-make ; + +M: sqlite-db ( tuple -- statement ) + [ + "insert into " 0% 0% + "(" 0% maybe-remove-id - dup [ ", " % ] [ sql-spec-column-name % ] interleave - ") values(" % - [ ", " % ] [ ":" % sql-spec-column-name % ] interleave - ");" % - ] "" make ; + dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + ") values(" 0% + [ ", " 0% ] [ bind% ] interleave + ");" 0% + ] sqlite-make ; + +M: sqlite-db ( tuple -- statement ) + ; : where-primary-key% ( specs -- ) - " where " % - find-primary-key sql-spec-column-name dup % " = :" % % ; + " where " 0% + find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ; -M: sqlite-db update-sql* ( specs table -- sql ) +M: sqlite-db ( class -- statement ) [ - "update " % - % - " set " % + "update " 0% + 0% + " set " 0% dup remove-id - [ ", " % ] [ sql-spec-column-name dup % " = :" % % ] interleave + [ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave where-primary-key% - ] "" make ; + ] sqlite-make ; -M: sqlite-db delete-sql* ( specs table -- sql ) +M: sqlite-db ( specs table -- sql ) [ - "delete from " % % - " where " % + "delete from " 0% 0% + " where " 0% find-primary-key - sql-spec-column-name dup % " = :" % % - ] "" make ; + sql-spec-column-name dup 0% " = " 0% bind% + ] sqlite-make ; -: select-interval ( interval name -- ) - ; +! : select-interval ( interval name -- ) ; +! : select-sequence ( seq name -- ) ; -: select-sequence ( seq name -- ) - ; +M: sqlite-db bind% ( spec -- ) + dup 1, sql-spec-column-name ":" swap append 0% ; + ! dup 1, sql-spec-column-name + ! dup 0% " = " 0% ":" swap append 0% ; -: select-by-slots-sql ( tuple -- sql out-specs ) +M: sqlite-db ( tuple class -- statement ) [ - "select from " 0% dup class db-table 0% - " " 0% - dup class db-columns [ ", " 0% ] - [ dup sql-spec-column-name 0% 1, ] interleave + "select " 0% + over [ ", " 0% ] + [ dup sql-spec-column-name 0% 2, ] interleave - dup class db-columns + " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset " where " 0% [ ", " 0% ] - [ sql-spec-column-name dup 0% " = :" 0% 0% ] interleave + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ";" 0% - ] { "" { } } nmake ; - -M: sqlite-db select-sql ( tuple -- sql ) - select-by-slots-sql ; - -M: sqlite-db tuple>params ( specs tuple -- obj ) - [ - >r [ sql-spec-column-name ":" swap append ] keep r> - dupd >r sql-spec-slot-name r> get-slot-named swap - sql-spec-type 3array - ] curry map ; + ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) H{ diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 9177e4981c..82bc96e156 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,8 +2,7 @@ ! 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 ; IN: temporary TUPLE: person the-id the-name the-number the-real ; @@ -38,13 +37,13 @@ SYMBOL: the-person ! [ ] [ person drop-table ] unit-test ; -! : test-sqlite ( -- ) - ! "tuples-test.db" resource-path [ - ! test-tuples - ! ] with-db ; +: test-sqlite ( -- ) + "tuples-test.db" resource-path [ + test-tuples + ] with-db ; : test-postgresql ( -- ) - "localhost" "postgres" "" "factor-test" [ + { "localhost" "postgres" "" "factor-test" } postgresql-db [ test-tuples ] with-db ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index da69452fa3..a7f2abf8b8 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -17,6 +17,11 @@ IN: db.tuples : db-columns ( class -- obj ) "db-columns" word-prop ; : db-relations ( class -- obj ) "db-relations" word-prop ; +: set-primary-key ( key tuple -- ) + [ + class db-columns find-primary-key sql-spec-slot-name + ] keep set-slot-named ; + ! returns a sequence of prepared-statements HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) @@ -30,7 +35,10 @@ HOOK: db ( tuple -- obj ) HOOK: db ( tuple -- obj ) HOOK: db ( tuple -- 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 [ @@ -63,10 +71,10 @@ HOOK: row-column-typed db ( result-set n type -- sql ) : insert-native ( tuple -- ) dup class - [ bind-tuple ] 2keep query-modify-tuple ; + [ bind-tuple ] 2keep insert-tuple* ; : insert-assigned ( tuple -- ) - dup + dup class [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) @@ -83,21 +91,13 @@ HOOK: row-column-typed db ( result-set n type -- sql ) : update-tuples ( seq -- ) execute-statement ; -! : persist ( tuple -- ) +: persist ( tuple -- ) + dup class db-columns find-primary-key ; -HOOK: delete-by-id db ( tuple -- ) -! : delete-tuple ( tuple -- ) -one-sql execute-statement ; -! : delete-tuples ( seq -- ) delete-many-sql execute-statement ; - -HOOK: db ( tuple -- tuple ) : setup-select ( tuple -- statement ) dup dup class [ bind-tuple ] keep ; -: select-tuple ( tuple -- tuple ) - setup-select query-tuples first ; - : select-tuples ( tuple -- tuple ) setup-select query-tuples ; - -! uniqueResult +: select-tuple ( tuple -- tuple ) select-tuples first ; From d8e19ccb9540dfa13b54ad13e7ab9fbd08a37340 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 Feb 2008 14:55:40 -0600 Subject: [PATCH 25/25] fix a couple of bugs in http.server --- extra/http/server/responders/responders.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index e4e0e257c4..70507f002b 100755 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -77,7 +77,7 @@ SYMBOL: max-post-request 1024 256 * max-post-request set-global : content-length ( header -- n ) - "Content-Length" swap at string>number dup [ + "content-length" peek at string>number dup [ dup max-post-request get > [ "Content-Length > max-post-request" throw ] when @@ -136,7 +136,7 @@ LOG: log-headers DEBUG : host ( -- string ) #! The host the current responder was called from. - "Host" header-param ":" split1 drop ; + "host" header-param ":" split1 drop ; : add-responder ( responder -- ) #! Add a responder object to the list.