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
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 ;

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

@ -8,7 +8,7 @@ IN: temporary
IN: scratchpad
: test-db ( -- postgresql-db )
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
{ "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 <insert-native-statement>
] 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 <insert-assigned-statement>
] 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 <update-tuple-statement> >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 <update-tuple-statement> >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 <delete-tuple-statement> >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 <delete-tuple-statement>
] with-variable
] unit-test
@ -359,6 +351,6 @@ basket "BASKET"
] [
T{ postgresql-db } db [
T{ puppy f f "Mr. Clunkers" }
select-by-slots-sql
<select-by-slots-statement>
] with-variable
] unit-test

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

@ -14,16 +14,18 @@ TUPLE: postgresql-result-set ;
<statement>
postgresql-statement construct-delegate ;
: <postgresql-db> ( 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 <postgresql-db> 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 <insert-native-statement> ( tuple -- statement )
M: postgresql-db <insert-native-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
@ -196,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( tuple -- statement )
");" 0%
] postgresql-make ;
M: postgresql-db <insert-assigned-statement> ( tuple -- statement )
M: postgresql-db <insert-assigned-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
@ -208,6 +207,9 @@ M: postgresql-db <insert-assigned-statement> ( tuple -- statement )
");" 0%
] postgresql-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db <update-tuple-statement> ( class -- statement )
[
"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
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set has-more? ;
@ -31,9 +30,15 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle over sqlite-prepare
{ set-statement-sql set-statement-handle } statement construct
<sqlite-statement> [ 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 <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 <simple-statement> ;
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 <insert-native-statement> ( 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 <insert-assigned-statement> ( tuple -- statement )
<insert-native-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 <update-tuple-statement> ( 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 <delete-tuple-statement> ( 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 <select-by-slots-statement> ( 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{

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

@ -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 <sqlite-db> [
! test-tuples
! ] with-db ;
: test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [
test-tuples
] with-db ;
: test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [
{ "localhost" "postgres" "" "factor-test" } postgresql-db [
test-tuples
] 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-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: <update-tuples-statement> db ( tuple -- obj )
HOOK: <delete-tuple-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: 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 <insert-native-statement>
[ bind-tuple ] 2keep query-modify-tuple ;
[ bind-tuple ] 2keep insert-tuple* ;
: insert-assigned ( tuple -- )
dup <insert-assigned-statement>
dup class <insert-assigned-statement>
[ 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 -- )
<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 )
dup dup class <select-by-slots-statement>
[ 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 ;