steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

db.tuples tests pass for postgresql 

redo the with-db word
db4
Doug Coleman 2008-02-25 14:50:42 -06:00
parent be1a22e7e2
commit 94b183d5e6
6 changed files with 117 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
extra/db/db.factor
View File

@ -11,6 +11,8 @@ TUPLE: db handle ;
! H{ } clone H{ } clone H{ } clone ! H{ } clone H{ } clone H{ } clone
db construct-boa ; db construct-boa ;
GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db ) construct-empty make-db* ;
GENERIC: db-open ( db -- ) GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- ) HOOK: db-close db ( handle -- )
@ -64,7 +66,6 @@ GENERIC: more-rows? ( result-set -- ? )
[ set-statement-bind-params ] keep [ set-statement-bind-params ] keep
t swap set-statement-bound? ; t swap set-statement-bound? ;
: init-result-set ( result-set -- ) : init-result-set ( result-set -- )
dup #rows over set-result-set-max dup #rows over set-result-set-max
0 swap set-result-set-n ; 0 swap set-result-set-n ;
@ -90,11 +91,9 @@ GENERIC: more-rows? ( result-set -- ? )
: query-map ( statement quot -- seq ) : query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline accumulator >r query-each r> { } like ; inline
: with-db ( db quot -- ) : with-db ( db seq quot -- )
[ >r make-db dup db-open db r>
over db-open [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
[ db swap with-variable ] curry with-disposal
] with-scope ;
: default-query ( query -- result-set ) : default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ; query-results [ [ sql-row ] query-map ] with-disposal ;

24
extra/db/postgresql/postgresql-tests.factor
View File

@ -8,7 +8,7 @@ IN: temporary
IN: scratchpad IN: scratchpad
: test-db ( -- postgresql-db ) : test-db ( -- postgresql-db )
"localhost" "postgres" "" "factor-test" <postgresql-db> ; { "localhost" "postgres" "" "factor-test" } postgresql-db ;
IN: temporary IN: temporary
[ ] [ test-db [ ] with-db ] unit-test [ ] [ test-db [ ] with-db ] unit-test
@ -217,17 +217,9 @@ basket "BASKET"
! Insert ! 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 [ T{ postgresql-db } db [
puppy dup db-columns swap db-table insert-sql* >r >r >lower r> r> puppy <insert-native-statement>
] with-variable ] with-variable
] unit-test ] unit-test
@ -249,7 +241,7 @@ basket "BASKET"
{ } { }
] [ ] [
T{ postgresql-db } db [ T{ postgresql-db } db [
kitty dup db-columns swap db-table insert-sql* >r >r >lower r> r> kitty <insert-assigned-statement>
] with-variable ] with-variable
] unit-test ] unit-test
@ -272,7 +264,7 @@ basket "BASKET"
{ } { }
] [ ] [
T{ postgresql-db } db [ 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 <update-tuple-statement> >r >r >lower r> r>
] with-variable ] with-variable
] unit-test ] unit-test
@ -294,7 +286,7 @@ basket "BASKET"
{ } { }
] [ ] [
T{ postgresql-db } db [ 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 <update-tuple-statement> >r >r >lower r> r>
] with-variable ] with-variable
] unit-test ] unit-test
@ -315,7 +307,7 @@ basket "BASKET"
{ } { }
] [ ] [
T{ postgresql-db } db [ 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 <delete-tuple-statement> >r >r >lower r> r>
] with-variable ] with-variable
] unit-test ] unit-test
@ -335,7 +327,7 @@ basket "BASKET"
{ } { }
] [ ] [
T{ postgresql-db } db [ T{ postgresql-db } db [
kitty dup db-columns swap db-table delete-sql* kitty dup db-columns swap db-table <delete-tuple-statement>
] with-variable ] with-variable
] unit-test ] unit-test
@ -359,6 +351,6 @@ basket "BASKET"
] [ ] [
T{ postgresql-db } db [ T{ postgresql-db } db [
T{ puppy f f "Mr. Clunkers" } T{ puppy f f "Mr. Clunkers" }
select-by-slots-sql <select-by-slots-statement>
] with-variable ] with-variable
] unit-test ] unit-test

28
extra/db/postgresql/postgresql.factor
View File

@ -14,16 +14,18 @@ TUPLE: postgresql-result-set ;
<statement> <statement>
postgresql-statement construct-delegate ; postgresql-statement construct-delegate ;
: <postgresql-db> ( host user pass db -- obj ) M: postgresql-db make-db* ( seq tuple -- db )
{ >r first4 r> [
set-postgresql-db-host {
set-postgresql-db-user set-postgresql-db-host
set-postgresql-db-pass set-postgresql-db-user
set-postgresql-db-db set-postgresql-db-pass
} postgresql-db construct ; set-postgresql-db-db
} set-slots
] keep ;
M: postgresql-db db-open ( db -- ) M: postgresql-db db-open ( db -- )
dup { dup {
postgresql-db-host postgresql-db-host
postgresql-db-port postgresql-db-port
postgresql-db-pgopts postgresql-db-pgopts
@ -36,9 +38,6 @@ M: postgresql-db db-open ( db -- )
M: postgresql-db dispose ( db -- ) M: postgresql-db dispose ( db -- )
db-handle PQfinish ; db-handle PQfinish ;
: with-postgresql ( host ust pass db quot -- )
>r <postgresql-db> r> with-disposal ;
M: postgresql-statement bind-statement* ( seq statement -- ) M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-bind-params ; set-statement-bind-params ;
@ -186,7 +185,7 @@ M: postgresql-db drop-sql-statement ( class -- seq )
[ drop-function-sql , ] [ 2drop ] if [ drop-function-sql , ] [ 2drop ] if
] { } make ; ] { } make ;
M: postgresql-db <insert-native-statement> ( tuple -- statement ) M: postgresql-db <insert-native-statement> ( class -- statement )
[ [
"select add_" 0% 0% "select add_" 0% 0%
"(" 0% "(" 0%
@ -196,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( tuple -- statement )
");" 0% ");" 0%
] postgresql-make ; ] postgresql-make ;
M: postgresql-db <insert-assigned-statement> ( tuple -- statement ) M: postgresql-db <insert-assigned-statement> ( class -- statement )
[ [
"insert into " 0% 0% "insert into " 0% 0%
"(" 0% "(" 0%
@ -208,6 +207,9 @@ M: postgresql-db <insert-assigned-statement> ( tuple -- statement )
");" 0% ");" 0%
] postgresql-make ; ] postgresql-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db <update-tuple-statement> ( class -- statement ) M: postgresql-db <update-tuple-statement> ( class -- statement )
[ [
"update " 0% 0% "update " 0% 0%

135
extra/db/sqlite/sqlite.factor
View File

@ -23,7 +23,6 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
>r <sqlite-db> r> with-db ; inline >r <sqlite-db> r> with-db ; inline
TUPLE: sqlite-statement ; TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set has-more? ; TUPLE: sqlite-result-set has-more? ;
@ -31,9 +30,15 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ; <prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj ) M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle over sqlite-prepare db get db-handle
{ set-statement-sql set-statement-handle } statement construct {
<sqlite-statement> [ set-delegate ] keep ; 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 -- ) M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ; statement-handle sqlite-finalize ;
@ -41,10 +46,11 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- ) M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ; f swap set-result-set-handle ;
: sqlite-bind ( triples handle -- ) : sqlite-bind ( specs handle -- )
swap [ first3 sqlite-bind-type ] with each ; 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 ; statement-handle sqlite-bind ;
M: sqlite-statement reset-statement ( statement -- ) M: sqlite-statement reset-statement ( statement -- )
@ -54,8 +60,8 @@ M: sqlite-statement reset-statement ( statement -- )
db get db-handle sqlite3_last_insert_rowid db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ; dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-statement ( statement -- id ) M: sqlite-statement insert-tuple* ( tuple statement -- )
execute-statement last-insert-id ; execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ; result-set-handle sqlite-#columns ;
@ -74,6 +80,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ; sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set ) M: sqlite-statement query-results ( query -- result-set )
break
dup statement-handle sqlite-result-set <result-set> dup statement-handle sqlite-result-set <result-set>
dup advance-row ; dup advance-row ;
@ -86,85 +93,83 @@ M: sqlite-db commit-transaction ( -- )
M: sqlite-db rollback-transaction ( -- ) M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ; "ROLLBACK" sql-command ;
M: sqlite-db create-sql ( specs table -- sql ) : sqlite-make ( class quot -- )
[ >r sql-props r>
"create table " % % { "" { } { } } nmake <simple-statement> ;
"(" % [ ", " % ] [
dup sql-spec-column-name %
" " %
dup sql-spec-type t lookup-type %
modifiers%
] interleave ");" %
] "" make ;
M: sqlite-db drop-sql ( specs table -- sql ) M: sqlite-db create-sql-statement ( class -- statement )
[ [
"drop table " % % ";" % drop "create table " 0% 0%
] "" make ; "(" 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 <insert-native-statement> ( tuple -- statement )
[
"insert into " 0% 0%
"(" 0%
maybe-remove-id maybe-remove-id
dup [ ", " % ] [ sql-spec-column-name % ] interleave dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
") values(" % ") values(" 0%
[ ", " % ] [ ":" % sql-spec-column-name % ] interleave [ ", " 0% ] [ bind% ] interleave
");" % ");" 0%
] "" make ; ] sqlite-make ;
M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- ) : where-primary-key% ( specs -- )
" where " % " where " 0%
find-primary-key sql-spec-column-name dup % " = :" % % ; find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
M: sqlite-db update-sql* ( specs table -- sql ) M: sqlite-db <update-tuple-statement> ( class -- statement )
[ [
"update " % "update " 0%
% 0%
" set " % " set " 0%
dup remove-id dup remove-id
[ ", " % ] [ sql-spec-column-name dup % " = :" % % ] interleave [ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
where-primary-key% where-primary-key%
] "" make ; ] sqlite-make ;
M: sqlite-db delete-sql* ( specs table -- sql ) M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
[ [
"delete from " % % "delete from " 0% 0%
" where " % " where " 0%
find-primary-key find-primary-key
sql-spec-column-name dup % " = :" % % sql-spec-column-name dup 0% " = " 0% bind%
] "" make ; ] 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 <select-by-slots-statement> ( tuple class -- statement )
[ [
"select from " 0% dup class db-table 0% "select " 0%
" " 0% over [ ", " 0% ]
dup class db-columns [ ", " 0% ] [ dup sql-spec-column-name 0% 2, ] interleave
[ dup sql-spec-column-name 0% 1, ] interleave
dup class db-columns " from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset [ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0% " where " 0%
[ ", " 0% ] [ ", " 0% ]
[ sql-spec-column-name dup 0% " = :" 0% 0% ] interleave [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0% ";" 0%
] { "" { } } nmake ; ] sqlite-make ;
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 ;
M: sqlite-db modifier-table ( -- hashtable ) M: sqlite-db modifier-table ( -- hashtable )
H{ H{

13
extra/db/tuples/tuples-tests.factor
View File

@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.tuples USING: io.files kernel tools.test db db.tuples
db.types continuations namespaces db.postgresql math db.types continuations namespaces db.postgresql math
prettyprint tools.walker ; prettyprint tools.walker db.sqlite ;
! db.sqlite
IN: temporary IN: temporary
TUPLE: person the-id the-name the-number the-real ; TUPLE: person the-id the-name the-number the-real ;
@ -38,13 +37,13 @@ SYMBOL: the-person
! [ ] [ person drop-table ] unit-test ! [ ] [ person drop-table ] unit-test
; ;
! : test-sqlite ( -- ) : test-sqlite ( -- )
! "tuples-test.db" resource-path <sqlite-db> [ "tuples-test.db" resource-path <sqlite-db> [
! test-tuples test-tuples
! ] with-db ; ] with-db ;
: test-postgresql ( -- ) : test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [ { "localhost" "postgres" "" "factor-test" } postgresql-db [
test-tuples test-tuples
] with-db ; ] with-db ;

26
extra/db/tuples/tuples.factor
View File

@ -17,6 +17,11 @@ IN: db.tuples
: db-columns ( class -- obj ) "db-columns" word-prop ; : db-columns ( class -- obj ) "db-columns" word-prop ;
: db-relations ( class -- obj ) "db-relations" 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 ! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj ) HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj )
@ -30,7 +35,10 @@ HOOK: <update-tuples-statement> db ( tuple -- obj )
HOOK: <delete-tuple-statement> db ( tuple -- obj ) HOOK: <delete-tuple-statement> db ( tuple -- obj )
HOOK: <delete-tuples-statement> db ( tuple -- obj ) HOOK: <delete-tuples-statement> db ( tuple -- obj )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple ) : resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class construct-empty [ dup first sql-spec-class construct-empty [
@ -63,10 +71,10 @@ HOOK: row-column-typed db ( result-set n type -- sql )
: insert-native ( tuple -- ) : insert-native ( tuple -- )
dup class <insert-native-statement> dup class <insert-native-statement>
[ bind-tuple ] 2keep query-modify-tuple ; [ bind-tuple ] 2keep insert-tuple* ;
: insert-assigned ( tuple -- ) : insert-assigned ( tuple -- )
dup <insert-assigned-statement> dup class <insert-assigned-statement>
[ bind-tuple ] keep execute-statement ; [ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- ) : insert-tuple ( tuple -- )
@ -83,21 +91,13 @@ HOOK: row-column-typed db ( result-set n type -- sql )
: update-tuples ( seq -- ) : update-tuples ( seq -- )
<update-tuples-statement> execute-statement ; <update-tuples-statement> 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: <select-by-slots-statement> db ( tuple -- tuple )
: setup-select ( tuple -- statement ) : setup-select ( tuple -- statement )
dup dup class <select-by-slots-statement> dup dup class <select-by-slots-statement>
[ bind-tuple ] keep ; [ bind-tuple ] keep ;
: select-tuple ( tuple -- tuple )
setup-select query-tuples first ;
: select-tuples ( tuple -- tuple ) setup-select query-tuples ; : select-tuples ( tuple -- tuple ) setup-select query-tuples ;
: select-tuple ( tuple -- tuple ) select-tuples first ;
! uniqueResult