add foreign key integrity to sqlite
Doug Coleman
parent
b5664733ed
commit
34ce3e13e4
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors kernel math namespaces make sequences random
|
||||
strings math.parser math.intervals combinators math.bitwise
|
||||
nmake db db.tuples db.types db.sql classes words shuffle arrays
|
||||
destructors continuations db.tuples.private ;
|
||||
destructors continuations db.tuples.private prettyprint ;
|
||||
IN: db.queries
|
||||
|
||||
GENERIC: where ( specs obj -- )
|
||||
|
|
@ -45,11 +45,16 @@ M: retryable execute-statement* ( statement type -- )
|
|||
: sql-props ( class -- columns table )
|
||||
[ db-columns ] [ db-table ] bi ;
|
||||
|
||||
: query-make ( class quot -- )
|
||||
: query-make ( class quot -- statements )
|
||||
#! query, input, outputs, secondary queries
|
||||
over unparse "table" set
|
||||
[ sql-props ] dip
|
||||
[ 0 sql-counter rot with-variable ] curry
|
||||
{ "" { } { } } nmake
|
||||
<simple-statement> maybe-make-retryable ; inline
|
||||
{ "" { } { } { } } nmake
|
||||
[ <simple-statement> maybe-make-retryable ] dip
|
||||
[
|
||||
[ 1array ] dip append
|
||||
] unless-empty ; inline
|
||||
|
||||
: where-primary-key% ( specs -- )
|
||||
" where " 0%
|
||||
|
|
@ -152,25 +157,20 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
where-clause
|
||||
] query-make ;
|
||||
|
||||
: splice ( string1 string2 string3 -- string )
|
||||
swap 3append ;
|
||||
|
||||
: do-group ( tuple groups -- )
|
||||
[
|
||||
", " join " group by " swap 3append
|
||||
] curry change-sql drop ;
|
||||
[ ", " join " group by " splice ] curry change-sql drop ;
|
||||
|
||||
: do-order ( tuple order -- )
|
||||
[
|
||||
", " join " order by " swap 3append
|
||||
] curry change-sql drop ;
|
||||
[ ", " join " order by " splice ] curry change-sql drop ;
|
||||
|
||||
: do-offset ( tuple n -- )
|
||||
[
|
||||
number>string " offset " swap 3append
|
||||
] curry change-sql drop ;
|
||||
[ number>string " offset " splice ] curry change-sql drop ;
|
||||
|
||||
: do-limit ( tuple n -- )
|
||||
[
|
||||
number>string " limit " swap 3append
|
||||
] curry change-sql drop ;
|
||||
[ number>string " limit " splice ] curry change-sql drop ;
|
||||
|
||||
: make-query* ( tuple query -- tuple' )
|
||||
dupd
|
||||
|
|
|
|||
|
|
@ -1,42 +0,0 @@
|
|||
USING: kernel namespaces db.sql sequences math ;
|
||||
IN: db.sql.tests
|
||||
|
||||
! TUPLE: person name age ;
|
||||
: insert-1
|
||||
{ insert
|
||||
{
|
||||
{ table "person" }
|
||||
{ columns "name" "age" }
|
||||
{ values "erg" 26 }
|
||||
}
|
||||
} ;
|
||||
|
||||
: update-1
|
||||
{ update "person"
|
||||
{ set { "name" "erg" }
|
||||
{ "age" 6 } }
|
||||
{ where { "age" 6 } }
|
||||
} ;
|
||||
|
||||
: select-1
|
||||
{ select
|
||||
{ columns
|
||||
"branchno"
|
||||
{ count "staffno" as "mycount" }
|
||||
{ sum "salary" as "mysum" } }
|
||||
{ from "staff" "lol" }
|
||||
{ where
|
||||
{ "salary" > all
|
||||
{ select
|
||||
{ columns "salary" }
|
||||
{ from "staff" }
|
||||
{ where { "branchno" = "b003" } }
|
||||
}
|
||||
}
|
||||
{ "branchno" > 3 } }
|
||||
{ group-by "branchno" "lol2" }
|
||||
{ having { count "staffno" > 1 } }
|
||||
{ order-by "branchno" }
|
||||
{ offset 40 }
|
||||
{ limit 20 }
|
||||
} ;
|
||||
|
|
@ -1,172 +0,0 @@
|
|||
USING: kernel parser quotations classes.tuple words math.order
|
||||
nmake namespaces sequences arrays combinators
|
||||
prettyprint strings math.parser math symbols db ;
|
||||
IN: db.sql
|
||||
|
||||
SYMBOLS: insert update delete select distinct columns from as
|
||||
where group-by having order-by limit offset is-null desc all
|
||||
any count avg table values ;
|
||||
|
||||
: input-spec, ( obj -- ) 1, ;
|
||||
: output-spec, ( obj -- ) 2, ;
|
||||
: input, ( obj -- ) 3, ;
|
||||
: output, ( obj -- ) 4, ;
|
||||
|
||||
DEFER: sql%
|
||||
|
||||
: (sql-interleave) ( seq sep -- )
|
||||
[ sql% ] curry [ sql% ] interleave ;
|
||||
|
||||
: sql-interleave ( seq str sep -- )
|
||||
swap sql% (sql-interleave) ;
|
||||
|
||||
: sql-function, ( seq function -- )
|
||||
sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
|
||||
|
||||
: sql-where, ( seq -- )
|
||||
[
|
||||
[ second 0, ]
|
||||
[ first 0, ]
|
||||
[ third 1, \ ? 0, ] tri
|
||||
] each ;
|
||||
|
||||
HOOK: sql-create db ( object -- )
|
||||
M: db sql-create ( object -- )
|
||||
drop
|
||||
"create table" sql% ;
|
||||
|
||||
HOOK: sql-drop db ( object -- )
|
||||
M: db sql-drop ( object -- )
|
||||
drop
|
||||
"drop table" sql% ;
|
||||
|
||||
HOOK: sql-insert db ( object -- )
|
||||
M: db sql-insert ( object -- )
|
||||
drop
|
||||
"insert into" sql% ;
|
||||
|
||||
HOOK: sql-update db ( object -- )
|
||||
M: db sql-update ( object -- )
|
||||
drop
|
||||
"update" sql% ;
|
||||
|
||||
HOOK: sql-delete db ( object -- )
|
||||
M: db sql-delete ( object -- )
|
||||
drop
|
||||
"delete" sql% ;
|
||||
|
||||
HOOK: sql-select db ( object -- )
|
||||
M: db sql-select ( object -- )
|
||||
"select" sql% "," (sql-interleave) ;
|
||||
|
||||
HOOK: sql-columns db ( object -- )
|
||||
M: db sql-columns ( object -- )
|
||||
"," (sql-interleave) ;
|
||||
|
||||
HOOK: sql-from db ( object -- )
|
||||
M: db sql-from ( object -- )
|
||||
"from" "," sql-interleave ;
|
||||
|
||||
HOOK: sql-where db ( object -- )
|
||||
M: db sql-where ( object -- )
|
||||
"where" 0, sql-where, ;
|
||||
|
||||
HOOK: sql-group-by db ( object -- )
|
||||
M: db sql-group-by ( object -- )
|
||||
"group by" "," sql-interleave ;
|
||||
|
||||
HOOK: sql-having db ( object -- )
|
||||
M: db sql-having ( object -- )
|
||||
"having" "," sql-interleave ;
|
||||
|
||||
HOOK: sql-order-by db ( object -- )
|
||||
M: db sql-order-by ( object -- )
|
||||
"order by" "," sql-interleave ;
|
||||
|
||||
HOOK: sql-offset db ( object -- )
|
||||
M: db sql-offset ( object -- )
|
||||
"offset" sql% sql% ;
|
||||
|
||||
HOOK: sql-limit db ( object -- )
|
||||
M: db sql-limit ( object -- )
|
||||
"limit" sql% sql% ;
|
||||
|
||||
! GENERIC: sql-subselect db ( object -- )
|
||||
! M: db sql-subselectselect ( object -- )
|
||||
! "(select" sql% sql% ")" sql% ;
|
||||
|
||||
HOOK: sql-table db ( object -- )
|
||||
M: db sql-table ( object -- )
|
||||
sql% ;
|
||||
|
||||
HOOK: sql-set db ( object -- )
|
||||
M: db sql-set ( object -- )
|
||||
"set" "," sql-interleave ;
|
||||
|
||||
HOOK: sql-values db ( object -- )
|
||||
M: db sql-values ( object -- )
|
||||
"values(" sql% "," (sql-interleave) ")" sql% ;
|
||||
|
||||
HOOK: sql-count db ( object -- )
|
||||
M: db sql-count ( object -- )
|
||||
"count" sql-function, ;
|
||||
|
||||
HOOK: sql-sum db ( object -- )
|
||||
M: db sql-sum ( object -- )
|
||||
"sum" sql-function, ;
|
||||
|
||||
HOOK: sql-avg db ( object -- )
|
||||
M: db sql-avg ( object -- )
|
||||
"avg" sql-function, ;
|
||||
|
||||
HOOK: sql-min db ( object -- )
|
||||
M: db sql-min ( object -- )
|
||||
"min" sql-function, ;
|
||||
|
||||
HOOK: sql-max db ( object -- )
|
||||
M: db sql-max ( object -- )
|
||||
"max" sql-function, ;
|
||||
|
||||
: sql-array% ( array -- )
|
||||
unclip
|
||||
{
|
||||
{ \ create [ sql-create ] }
|
||||
{ \ drop [ sql-drop ] }
|
||||
{ \ insert [ sql-insert ] }
|
||||
{ \ update [ sql-update ] }
|
||||
{ \ delete [ sql-delete ] }
|
||||
{ \ select [ sql-select ] }
|
||||
{ \ columns [ sql-columns ] }
|
||||
{ \ from [ sql-from ] }
|
||||
{ \ where [ sql-where ] }
|
||||
{ \ group-by [ sql-group-by ] }
|
||||
{ \ having [ sql-having ] }
|
||||
{ \ order-by [ sql-order-by ] }
|
||||
{ \ offset [ sql-offset ] }
|
||||
{ \ limit [ sql-limit ] }
|
||||
{ \ table [ sql-table ] }
|
||||
{ \ set [ sql-set ] }
|
||||
{ \ values [ sql-values ] }
|
||||
{ \ count [ sql-count ] }
|
||||
{ \ sum [ sql-sum ] }
|
||||
{ \ avg [ sql-avg ] }
|
||||
{ \ min [ sql-min ] }
|
||||
{ \ max [ sql-max ] }
|
||||
[ sql% [ sql% ] each ]
|
||||
} case ;
|
||||
|
||||
ERROR: no-sql-match ;
|
||||
: sql% ( obj -- )
|
||||
{
|
||||
{ [ dup string? ] [ 0, ] }
|
||||
{ [ dup array? ] [ sql-array% ] }
|
||||
{ [ dup number? ] [ number>string sql% ] }
|
||||
{ [ dup symbol? ] [ unparse sql% ] }
|
||||
{ [ dup word? ] [ unparse sql% ] }
|
||||
{ [ dup quotation? ] [ call ] }
|
||||
[ no-sql-match ]
|
||||
} cond ;
|
||||
|
||||
: parse-sql ( obj -- sql in-spec out-spec in out )
|
||||
[ [ sql% ] each ] { { } { } { } } nmake
|
||||
[ " " join ] 2dip ;
|
||||
|
|
@ -5,7 +5,8 @@ io.files kernel math math.parser namespaces prettyprint
|
|||
sequences strings classes.tuple alien.c-types continuations
|
||||
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
|
||||
math.intervals io nmake accessors vectors math.ranges random
|
||||
math.bitwise db.queries destructors db.tuples.private ;
|
||||
math.bitwise db.queries destructors db.tuples.private interpolate
|
||||
io.streams.string multiline make ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db < db path ;
|
||||
|
|
@ -117,7 +118,8 @@ M: sqlite-db create-sql-statement ( class -- statement )
|
|||
dupd
|
||||
"create table " 0% 0%
|
||||
"(" 0% [ ", " 0% ] [
|
||||
dup column-name>> 0%
|
||||
dup "sql-spec" set
|
||||
dup column-name>> [ "table-id" set ] [ 0% ] bi
|
||||
" " 0%
|
||||
dup type>> lookup-create-type 0%
|
||||
modifiers 0%
|
||||
|
|
@ -203,9 +205,110 @@ M: sqlite-db persistent-table ( -- assoc )
|
|||
{ random-generator { f f f } }
|
||||
} ;
|
||||
|
||||
: insert-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
||||
BEFORE INSERT ON ${table}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: insert-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
||||
BEFORE INSERT ON ${table}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: update-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
||||
BEFORE UPDATE ON ${table}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: update-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
||||
BEFORE UPDATE ON ${table}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: delete-trigger-restrict ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
||||
BEFORE DELETE ON ${foreign-table}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: delete-trigger-cascade ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
||||
BEFORE DELETE ON ${foreign-table}
|
||||
FOR EACH ROW BEGIN
|
||||
DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: can-be-null? ( -- ? )
|
||||
"sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
|
||||
|
||||
: delete-cascade? ( -- ? )
|
||||
"sql-spec" get modifiers>> [ +cascade+ = ] contains? ;
|
||||
|
||||
: sqlite-trigger, ( string -- )
|
||||
{ } { } <simple-statement> 3, ;
|
||||
|
||||
: create-sqlite-triggers ( -- )
|
||||
can-be-null? [
|
||||
insert-trigger sqlite-trigger,
|
||||
update-trigger sqlite-trigger,
|
||||
] [
|
||||
insert-trigger-not-null sqlite-trigger,
|
||||
update-trigger-not-null sqlite-trigger,
|
||||
] if
|
||||
delete-cascade? [
|
||||
delete-trigger-cascade sqlite-trigger,
|
||||
] [
|
||||
delete-trigger-restrict sqlite-trigger,
|
||||
] if ;
|
||||
|
||||
M: sqlite-db compound ( string seq -- new-string )
|
||||
over {
|
||||
{ "default" [ first number>string join-space ] }
|
||||
{ "references" [ >reference-string ] }
|
||||
{ "references" [
|
||||
[ >reference-string ] keep
|
||||
first2 [ "foreign-table" set ]
|
||||
[ "foreign-table-id" set ] bi*
|
||||
create-sqlite-triggers
|
||||
] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -176,26 +176,49 @@ SYMBOL: person4
|
|||
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
|
||||
|
||||
|
||||
TUPLE: paste n summary author channel mode contents timestamp annotations ;
|
||||
TUPLE: annotation n paste-id summary author mode contents ;
|
||||
|
||||
: db-assigned-paste-schema ( -- )
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "channel" "CHANNEL" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
{ "timestamp" "DATE" TIMESTAMP }
|
||||
{ "annotations" { +has-many+ annotation } }
|
||||
} define-persistent
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "channel" "CHANNEL" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
{ "timestamp" "DATE" TIMESTAMP }
|
||||
{ "annotations" { +has-many+ annotation } }
|
||||
} define-persistent
|
||||
|
||||
: annotation-schema-foreign-key ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: annotation-schema-foreign-key-not-null ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: annotation-schema-cascade ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
|
||||
+on-delete+ +cascade+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
|
|
@ -203,8 +226,18 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: annotation-schema-restrict ( -- )
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent ;
|
||||
|
||||
: test-paste-schema ( -- )
|
||||
[ ] [ db-assigned-paste-schema ] unit-test
|
||||
[ ] [ paste ensure-table ] unit-test
|
||||
[ ] [ annotation ensure-table ] unit-test
|
||||
[ ] [ annotation drop-table ] unit-test
|
||||
|
|
@ -229,14 +262,38 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
"erg" >>author
|
||||
"annotation contents" >>contents
|
||||
insert-tuple
|
||||
] unit-test
|
||||
] unit-test ;
|
||||
|
||||
[ ] [
|
||||
] unit-test
|
||||
;
|
||||
: test-foreign-key ( -- )
|
||||
[ ] [ annotation-schema-foreign-key ] unit-test
|
||||
test-paste-schema
|
||||
[ paste new 1 >>n delete-tuples ] must-fail ;
|
||||
|
||||
[ test-paste-schema ] test-sqlite
|
||||
[ test-paste-schema ] test-postgresql
|
||||
: test-foreign-key-not-null ( -- )
|
||||
[ ] [ annotation-schema-foreign-key-not-null ] unit-test
|
||||
test-paste-schema
|
||||
[ paste new 1 >>n delete-tuples ] must-fail ;
|
||||
|
||||
: test-cascade ( -- )
|
||||
[ ] [ annotation-schema-cascade ] unit-test
|
||||
test-paste-schema
|
||||
[ ] [ paste new 1 >>n delete-tuples ] unit-test
|
||||
[ 0 ] [ paste new select-tuples length ] unit-test ;
|
||||
|
||||
: test-restrict ( -- )
|
||||
[ ] [ annotation-schema-restrict ] unit-test
|
||||
test-paste-schema
|
||||
[ paste new 1 >>n delete-tuples ] must-fail ;
|
||||
|
||||
[ test-foreign-key ] test-sqlite
|
||||
[ test-foreign-key-not-null ] test-sqlite
|
||||
[ test-cascade ] test-sqlite
|
||||
[ test-restrict ] test-sqlite
|
||||
|
||||
[ test-foreign-key ] test-postgresql
|
||||
[ test-foreign-key-not-null ] test-postgresql
|
||||
[ test-cascade ] test-postgresql
|
||||
[ test-restrict ] test-postgresql
|
||||
|
||||
: test-repeated-insert
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
|
|
|
|||
|
|
@ -87,16 +87,17 @@ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
|
|||
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
|
||||
FACTOR-BLOB NULL URL ;
|
||||
|
||||
: spec>tuple ( class spec -- tuple )
|
||||
3 f pad-right
|
||||
[ first3 ] keep 3 tail
|
||||
: <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
|
||||
sql-spec new
|
||||
swap >>modifiers
|
||||
swap >>type
|
||||
swap >>column-name
|
||||
swap >>slot-name
|
||||
swap >>class
|
||||
dup normalize-spec ;
|
||||
dup normalize-spec ;
|
||||
|
||||
: spec>tuple ( class spec -- tuple )
|
||||
3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
|
||||
|
||||
: number>string* ( n/string -- string )
|
||||
dup number? [ number>string ] when ;
|
||||
|
|
@ -115,7 +116,6 @@ FACTOR-BLOB NULL URL ;
|
|||
! PostgreSQL Types:
|
||||
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
|
||||
|
||||
|
||||
: ?at ( obj assoc -- value/obj ? )
|
||||
dupd at* [ [ nip ] [ drop ] if ] keep ;
|
||||
|
||||
|
|
@ -159,8 +159,11 @@ ERROR: no-sql-type type ;
|
|||
HOOK: bind% db ( spec -- )
|
||||
HOOK: bind# db ( spec obj -- )
|
||||
|
||||
ERROR: no-column column ;
|
||||
|
||||
: >reference-string ( string pair -- string )
|
||||
first2
|
||||
[ [ unparse join-space ] [ db-columns ] bi ] dip
|
||||
swap [ slot-name>> = ] with find nip
|
||||
swap [ column-name>> = ] with find nip
|
||||
[ no-column ] unless*
|
||||
column-name>> paren append ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue