break sqlite

postgresql create/drop/insert/update/delete/select works
db4
Doug Coleman 2008-02-22 17:06:00 -06:00
parent 014e94aafc
commit 67876e13d9
7 changed files with 277 additions and 270 deletions

View File

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

View File

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

View File

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

View File

@ -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{

View File

@ -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> [

View File

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

View File

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