Doug Coleman
parent
014e94aafc
commit
67876e13d9
|
|
@ -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 ;
|
||||
: <db> ( 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? ;
|
||||
: <statement> ( sql in out -- statement )
|
||||
{
|
||||
set-statement-sql
|
||||
set-statement-in-params
|
||||
set-statement-out-params
|
||||
} statement construct ;
|
||||
|
||||
TUPLE: simple-statement ;
|
||||
TUPLE: prepared-statement ;
|
||||
|
||||
HOOK: <simple-statement> db ( str -- statement )
|
||||
HOOK: <prepared-statement> db ( str -- statement )
|
||||
HOOK: <simple-statement> db ( str in out -- statement )
|
||||
HOOK: <prepared-statement> 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 )
|
||||
<simple-statement> [ do-query ] with-disposal ;
|
||||
f f <simple-statement> [ default-query ] with-disposal ;
|
||||
|
||||
: sql-command ( sql -- )
|
||||
dup string? [
|
||||
<simple-statement> [ execute-statement ] with-disposal
|
||||
f f <simple-statement> [ execute-statement ] with-disposal
|
||||
] [
|
||||
! [
|
||||
[ sql-command ] each
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ IN: temporary
|
|||
] [
|
||||
test-db [
|
||||
"select * from person where name = $1 and country = $2"
|
||||
<simple-statement> [
|
||||
f f <simple-statement> [
|
||||
{ { "Jane" TEXT } { "New Zealand" TEXT } }
|
||||
over do-bound-query
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ IN: db.postgresql
|
|||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
TUPLE: postgresql-statement ;
|
||||
TUPLE: postgresql-result-set ;
|
||||
: <postgresql-statement> ( statement -- postgresql-statement )
|
||||
: <postgresql-statement> ( statement in out -- postgresql-statement )
|
||||
<statement>
|
||||
postgresql-statement construct-delegate ;
|
||||
|
||||
: <postgresql-db> ( host user pass db -- obj )
|
||||
|
|
@ -39,11 +40,17 @@ M: postgresql-db dispose ( db -- )
|
|||
>r <postgresql-db> 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 <simple-statement> ( sql -- statement )
|
||||
{ set-statement-sql } statement construct
|
||||
M: postgresql-db <simple-statement> ( sql in out -- statement )
|
||||
<postgresql-statement> ;
|
||||
|
||||
M: postgresql-db <prepared-statement> ( triple -- statement )
|
||||
?first3
|
||||
{
|
||||
set-statement-sql
|
||||
set-statement-in-params
|
||||
set-statement-out-params
|
||||
} statement construct <postgresql-statement> ;
|
||||
M: postgresql-db <prepared-statement> ( sql in out -- statement )
|
||||
<postgresql-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 <postgresql-statement> ;
|
||||
|
||||
:: 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 <insert-native-statement> ( tuple -- statement )
|
||||
[
|
||||
"select add_" 0% 0%
|
||||
"(" 0%
|
||||
dup find-primary-key 2,
|
||||
remove-id
|
||||
[ ", " 0% ] [ bind% ] interleave
|
||||
");" 0%
|
||||
] postgresql-make ;
|
||||
|
||||
M: postgresql-db <insert-assigned-statement> ( 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 <update-tuple-statement> ( 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 <delete-tuple-statement> ( 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 <select-by-slots-statement> ( 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{
|
||||
|
|
|
|||
|
|
@ -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 <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> [
|
||||
|
|
|
|||
|
|
@ -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: <insert-native-statement> db ( tuple -- obj )
|
||||
HOOK: <insert-assigned-statement> db ( tuple -- obj )
|
||||
|
||||
: offset-of-slot ( str obj -- n )
|
||||
class slot-spec-named slot-spec-offset ;
|
||||
HOOK: <update-tuple-statement> db ( tuple -- obj )
|
||||
HOOK: <update-tuples-statement> 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
|
||||
[ <prepared-statement> ] 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: <delete-tuple-statement> db ( tuple -- obj )
|
||||
HOOK: <delete-tuples-statement> 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 <insert-native-statement>
|
||||
[ 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 <insert-assigned-statement>
|
||||
[ 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 ;
|
||||
<update-tuple-statement> execute-statement ;
|
||||
|
||||
: delete-tuple ( tuple -- )
|
||||
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
|
||||
: update-tuples ( seq -- )
|
||||
<update-tuples-statement> 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> 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: <select-by-slots-statement> db ( tuple -- tuple )
|
||||
|
||||
SYMBOL: building-seq
|
||||
: get-building-seq ( n -- seq )
|
||||
building-seq get nth ;
|
||||
: select-tuple ( tuple -- tuple )
|
||||
dup dup class <select-by-slots-statement>
|
||||
[ 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 <select-by-slots-statement>
|
||||
[ bind-tuple ] 2keep query-tuples ;
|
||||
|
|
|
|||
|
|
@ -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> 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue