intermediate work on db, everything is broken
Doug Coleman
parent
fa5b621257
commit
d6ede4dda5
|
|
@ -1,8 +1,9 @@
|
|||
! You will need to run 'createdb factor-test' to create the database.
|
||||
! Set username and password in the 'connect' word.
|
||||
|
||||
USING: kernel db.postgresql alien continuations io prettyprint
|
||||
sequences namespaces tools.test db db.types ;
|
||||
USING: kernel db.postgresql alien continuations io classes
|
||||
prettyprint sequences namespaces tools.test db
|
||||
db.tuples db.types unicode.case ;
|
||||
IN: temporary
|
||||
|
||||
IN: scratchpad
|
||||
|
|
@ -108,3 +109,48 @@ IN: temporary
|
|||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
|
||||
|
||||
! TEST TUPLE DB
|
||||
|
||||
TUPLE: puppy id name age ;
|
||||
: <puppy> ( name age -- puppy )
|
||||
{ set-puppy-name set-puppy-age } puppy construct ;
|
||||
|
||||
puppy "PUPPY" {
|
||||
{ "id" "ID" +native-id+ }
|
||||
{ "name" "NAME" TEXT }
|
||||
{ "age" "AGE" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: kitty id name age ;
|
||||
: <kitty> ( name age -- kitty )
|
||||
{ set-kitty-name set-kitty-age } kitty construct ;
|
||||
|
||||
kitty "KITTY" {
|
||||
{ "id" "ID" +native-id+ }
|
||||
{ "name" "NAME" TEXT }
|
||||
{ "age" "AGE" INTEGER }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: basket id puppies kitties ;
|
||||
basket "BASKET"
|
||||
{
|
||||
{ "id" "ID" +native-id+ }
|
||||
{ "location" "LOCATION" TEXT }
|
||||
{ "puppies" { +has-many+ puppy } }
|
||||
{ "kitties" { +has-many+ kitty } }
|
||||
} define-persistent
|
||||
|
||||
[
|
||||
{ "name" "age" }
|
||||
! "insert into table puppy(name, age) values($1, $2);"
|
||||
"select add_puppy($1, $2, $3);"
|
||||
] [
|
||||
T{ postgresql-db } db [
|
||||
"Mr Clunkers" 3 <puppy>
|
||||
class dup db-columns swap db-table insert-sql* >lower
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays assocs alien alien.syntax continuations io
|
|||
kernel math math.parser namespaces prettyprint quotations
|
||||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators ;
|
||||
combinators sequences.lib classes ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
|
|
@ -117,52 +117,13 @@ M: postgresql-db commit-transaction ( -- )
|
|||
M: postgresql-db rollback-transaction ( -- )
|
||||
"ROLLBACK" sql-command ;
|
||||
|
||||
: postgresql-type-hash* ( -- assoc )
|
||||
H{
|
||||
{ SERIAL "serial" }
|
||||
} ;
|
||||
|
||||
: postgresql-type-hash ( -- assoc )
|
||||
H{
|
||||
{ INTEGER "integer" }
|
||||
{ SERIAL "integer" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "varchar" }
|
||||
{ DOUBLE "real" }
|
||||
} ;
|
||||
|
||||
: enquote ( str -- newstr ) "(" swap ")" 3append ;
|
||||
|
||||
: postgresql-type ( str n/str -- newstr )
|
||||
" " swap number>string* enquote 3append ;
|
||||
|
||||
: >sql-type* ( obj -- str )
|
||||
dup pair? [
|
||||
first2 >r >sql-type* r> postgresql-type
|
||||
] [
|
||||
dup postgresql-type-hash* at* [
|
||||
nip
|
||||
] [
|
||||
drop >sql-type
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: postgresql-db >sql-type ( hash obj -- str )
|
||||
dup pair? [
|
||||
first2 >r >sql-type r> postgresql-type
|
||||
] [
|
||||
postgresql-type-hash at* [
|
||||
no-sql-type
|
||||
] unless
|
||||
] if ;
|
||||
|
||||
: insert-function ( columns table -- sql )
|
||||
: insert-function ( columns table -- sql types )
|
||||
[
|
||||
>r remove-id r>
|
||||
"create function add_" % dup %
|
||||
"(" %
|
||||
over [ "," % ]
|
||||
[ third dup array? [ first ] when >sql-type % ] interleave
|
||||
[ third dup array? [ first ] when >sql-type-string % ] interleave
|
||||
")" %
|
||||
" returns bigint as '" %
|
||||
|
||||
|
|
@ -177,31 +138,31 @@ M: postgresql-db >sql-type ( hash obj -- str )
|
|||
|
||||
"select currval(''" % % "_id_seq'');' language sql;" %
|
||||
drop
|
||||
] "" make ;
|
||||
] "" make f ;
|
||||
|
||||
: drop-function ( columns table -- sql )
|
||||
[
|
||||
>r remove-id r>
|
||||
"drop function add_" % %
|
||||
"(" %
|
||||
[ "," % ] [ third >sql-type % ] interleave
|
||||
[ "," % ] [ third >sql-type-string % ] interleave
|
||||
")" %
|
||||
] "" make ;
|
||||
] "" nmake ;
|
||||
|
||||
M: postgresql-db create-sql ( columns table -- seq )
|
||||
[
|
||||
[
|
||||
2dup
|
||||
"create table " % %
|
||||
" (" % [ ", " % ] [
|
||||
dup second % " " %
|
||||
dup third >sql-type* % " " %
|
||||
sql-modifiers " " join %
|
||||
] interleave "); " %
|
||||
] "" make ,
|
||||
|
||||
over native-id? [ insert-function , ] [ 2drop ] if
|
||||
] { } make ;
|
||||
! M: postgresql-db create-sql ( columns table -- seq )
|
||||
! [
|
||||
! [
|
||||
! 2dup
|
||||
! "create table " % %
|
||||
! " (" % [ ", " % ] [
|
||||
! dup second % " " %
|
||||
! dup third >sql-type-string % " " %
|
||||
! sql-modifiers " " join %
|
||||
! ] interleave "); " %
|
||||
! ] "" make ,
|
||||
!
|
||||
! over native-id? [ insert-function , ] [ 2drop ] if
|
||||
! ] { } make ;
|
||||
|
||||
M: postgresql-db drop-sql ( columns table -- seq )
|
||||
[
|
||||
|
|
@ -211,15 +172,15 @@ M: postgresql-db drop-sql ( columns table -- seq )
|
|||
over native-id? [ drop-function , ] [ 2drop ] if
|
||||
] { } make ;
|
||||
|
||||
M: postgresql-db insert-sql* ( columns table -- slot-names sql )
|
||||
M: postgresql-db insert-sql* ( columns table -- sql slots )
|
||||
[
|
||||
"select add_" % %
|
||||
"(" %
|
||||
length [1,b] [ ", " % ] [ "$" % # ] interleave
|
||||
")" %
|
||||
dup length [1,b] [ ", " % ] [ "$" % # ] interleave
|
||||
");" %
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db update-sql* ( columns table -- slot-names sql )
|
||||
M: postgresql-db update-sql* ( columns table -- sql slots )
|
||||
[
|
||||
"update " %
|
||||
%
|
||||
|
|
@ -239,8 +200,42 @@ M: postgresql-db delete-sql* ( columns table -- slot-names sql )
|
|||
first second % " = $1" %
|
||||
] "" make ;
|
||||
|
||||
M: postgresql-db select-sql ( columns table -- slot-names sql )
|
||||
drop ;
|
||||
: column-name% ( spec -- )
|
||||
dup sql-spec-column-name 0%
|
||||
sql-spec-type >sql-type-string 1, ;
|
||||
|
||||
: column-names% ( class -- )
|
||||
db-columns [ "," 0, ] [ column-name% ] interleave ;
|
||||
|
||||
M: postgresql-db column-bind% ( spec -- )
|
||||
|
||||
|
||||
;
|
||||
|
||||
|
||||
! : select-foreign-table-sql ( tuple relation -- )
|
||||
! ! select id, name, age from puppy, basket where puppy.basket_id = basket.id
|
||||
! "select " 0%
|
||||
! ;
|
||||
! TODO
|
||||
: select-relations-sql ( tuple -- seq )
|
||||
! seq -- { sql types }
|
||||
dup class db-relations [
|
||||
[
|
||||
! select-foreign-table-sql
|
||||
] { "" { } } 2 nmake
|
||||
] with { } map>assoc ;
|
||||
|
||||
! TODO
|
||||
: select-by-slots-sql ( tuple -- sql )
|
||||
dup tuple>filled-slots
|
||||
;
|
||||
|
||||
|
||||
M: postgresql-db select-sql ( tuple -- sql slot-names )
|
||||
[
|
||||
|
||||
] { } 2 nmake ;
|
||||
|
||||
M: postgresql-db tuple>params ( columns tuple -- obj )
|
||||
[ >r dup third swap first r> get-slot-named swap ]
|
||||
|
|
@ -248,7 +243,8 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
|
|||
|
||||
: postgresql-db-modifiers ( -- hashtable )
|
||||
H{
|
||||
{ +native-id+ "not null primary key" }
|
||||
{ +native-id+ "primary key" }
|
||||
{ +foreign-key+ "" }
|
||||
{ +assigned-id+ "primary key" }
|
||||
{ +autoincrement+ "autoincrement" }
|
||||
{ +unique+ "unique" }
|
||||
|
|
@ -257,13 +253,16 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
|
|||
{ +not-null+ "not null" }
|
||||
} ;
|
||||
|
||||
M: postgresql-db sql-modifiers* ( modifiers -- str )
|
||||
postgresql-db-modifiers swap [
|
||||
dup array? [
|
||||
first2
|
||||
>r swap at r> number>string*
|
||||
" " swap 3append
|
||||
] [
|
||||
swap at
|
||||
] if
|
||||
] with map [ ] subset ;
|
||||
! M: postgresql-db sql-modifier>string ( modifier -- str )
|
||||
! dup array? [
|
||||
! first2
|
||||
! >r swap at r> number>string*
|
||||
! " " swap 3append
|
||||
! ] [
|
||||
! swap at
|
||||
! ] if ;
|
||||
!
|
||||
! M: postgresql-db sql-modifiers* ( modifiers -- str )
|
||||
! postgresql-db-modifiers swap [
|
||||
! sql-modifier>string
|
||||
! ] with map [ ] subset ;
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ person "PERSON"
|
|||
"billy" 10 3.14 <person> the-person set
|
||||
|
||||
! test-sqlite
|
||||
test-postgresql
|
||||
! test-postgresql
|
||||
|
||||
! person "PERSON"
|
||||
! {
|
||||
|
|
@ -68,3 +68,42 @@ person "PERSON"
|
|||
|
||||
! test-sqlite
|
||||
! test-postgresql
|
||||
|
||||
TUPLE: paste n summary author channel mode contents timestamp annotations ;
|
||||
TUPLE: annotation n paste-id summary author mode contents ;
|
||||
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "n" "ID" SERIAL +native-id+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "channel" "CHANNEL" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
{ "date" "DATE" TIMESTAMP }
|
||||
{ "annotations" { +has-many+ annotation } }
|
||||
} define-persistent
|
||||
|
||||
! n
|
||||
! NO: drop insert
|
||||
! YES: create update delete select
|
||||
! annotations
|
||||
! NO: create drop insert update delete
|
||||
! YES: select
|
||||
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" SERIAL +native-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-key+ paste "n" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "mode" "MODE" TEXT }
|
||||
{ "contents" "CONTENTS" TEXT }
|
||||
} define-persistent
|
||||
|
||||
"localhost" "postgres" "" "factor-test" <postgresql-db> [
|
||||
! paste drop-table
|
||||
! annotation drop-table
|
||||
paste create-table
|
||||
annotation create-table
|
||||
] with-db
|
||||
|
|
|
|||
|
|
@ -2,11 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes db kernel namespaces
|
||||
tuples words sequences slots slots.private math
|
||||
math.parser io prettyprint db.types continuations ;
|
||||
math.parser io prettyprint db.types continuations
|
||||
mirrors sequences.lib ;
|
||||
IN: db.tuples
|
||||
|
||||
: db-columns ( class -- obj ) "db-columns" 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 ;
|
||||
|
|
@ -41,26 +43,15 @@ TUPLE: no-slot-named ;
|
|||
HOOK: create-sql db ( columns table -- seq )
|
||||
HOOK: drop-sql db ( columns table -- seq )
|
||||
|
||||
HOOK: insert-sql* db ( columns table -- slot-names sql )
|
||||
HOOK: update-sql* db ( columns table -- slot-names sql )
|
||||
HOOK: delete-sql* db ( columns table -- slot-names sql )
|
||||
HOOK: select-sql db ( tuple -- statement )
|
||||
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: 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 )
|
||||
|
||||
|
||||
HOOK: make-slot-names* db ( quot -- seq )
|
||||
HOOK: column-slot-name% db ( spec -- )
|
||||
HOOK: column-bind-name% db ( spec -- )
|
||||
|
||||
: make-slots-names ( quot -- seq str )
|
||||
[ make-slot-names* ] "" make ; inline
|
||||
: slot-name% ( seq -- ) first % ;
|
||||
: column-name% ( seq -- ) second % ;
|
||||
: column-type% ( seq -- ) third % ;
|
||||
|
||||
: insert-sql ( columns class -- statement )
|
||||
db get db-insert-statements [ insert-sql* ] cache-statement ;
|
||||
|
||||
|
|
@ -108,8 +99,37 @@ HOOK: column-bind-name% db ( spec -- )
|
|||
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
|
||||
|
||||
: define-persistent ( class table columns -- )
|
||||
>r dupd "db-table" set-word-prop r>
|
||||
"db-columns" set-word-prop ;
|
||||
>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 ;
|
||||
|
||||
: define-relation ( spec -- )
|
||||
drop ;
|
||||
: tuple>filled-slots ( tuple -- alist )
|
||||
dup <mirror> mirror-slots [ slot-spec-name ] map
|
||||
swap tuple-slots 2array flip [ nip ] assoc-subset ;
|
||||
|
||||
! [ tuple>filled-slots ] keep
|
||||
! [ >r first r> get-slot-named ] curry each
|
||||
|
||||
SYMBOL: building-seq
|
||||
: get-building-seq ( n -- seq )
|
||||
building-seq get nth ;
|
||||
|
||||
: n, get-building-seq push ;
|
||||
: n% get-building-seq push-all ;
|
||||
|
||||
: 0, 0 n, ;
|
||||
: 0% 0 n% ;
|
||||
: 1, 1 n, ;
|
||||
: 1% 1 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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs db kernel math math.parser
|
||||
sequences continuations ;
|
||||
sequences continuations sequences.deep sequences.lib ;
|
||||
IN: db.types
|
||||
|
||||
! ID is the Primary key
|
||||
|
|
@ -17,6 +17,8 @@ SYMBOL: +assigned-id+
|
|||
: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
|
||||
: native-id? ( columns -- ? ) +native-id+ contains-id? ;
|
||||
|
||||
SYMBOL: +foreign-key+
|
||||
|
||||
! Same concept, SQLite has autoincrement, PostgreSQL has serial
|
||||
SYMBOL: +autoincrement+
|
||||
SYMBOL: +serial+
|
||||
|
|
@ -28,9 +30,13 @@ SYMBOL: +not-null+
|
|||
|
||||
SYMBOL: +has-many+
|
||||
|
||||
SYMBOL: SERIAL
|
||||
: relation? ( spec -- ? )
|
||||
[ +has-many+ = ] deep-find* nip ;
|
||||
|
||||
SYMBOL: INTEGER
|
||||
SYMBOL: BIG_INTEGER
|
||||
SYMBOL: DOUBLE
|
||||
|
||||
SYMBOL: BOOLEAN
|
||||
|
||||
SYMBOL: TEXT
|
||||
|
|
@ -39,29 +45,50 @@ SYMBOL: VARCHAR
|
|||
SYMBOL: TIMESTAMP
|
||||
SYMBOL: DATE
|
||||
|
||||
SYMBOL: BIG_INTEGER
|
||||
|
||||
TUPLE: no-sql-type ;
|
||||
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
|
||||
|
||||
HOOK: sql-modifiers* db ( modifiers -- str )
|
||||
HOOK: >sql-type db ( obj -- str )
|
||||
|
||||
! HOOK: >factor-type db ( obj -- obj )
|
||||
|
||||
: number>string* ( n/str -- str )
|
||||
dup number? [ number>string ] when ;
|
||||
|
||||
: maybe-remove-id ( columns -- obj )
|
||||
[ +native-id+ swap member? not ] subset ;
|
||||
|
||||
: remove-relations ( columns -- newcolumns )
|
||||
[ relation? not ] subset ;
|
||||
|
||||
: remove-id ( columns -- obj )
|
||||
[ primary-key? not ] subset ;
|
||||
|
||||
: sql-modifiers ( spec -- seq )
|
||||
3 tail sql-modifiers* ;
|
||||
|
||||
! SQLite Types: http://www.sqlite.org/datatype3.html
|
||||
! NULL INTEGER REAL TEXT BLOB
|
||||
! PostgreSQL Types:
|
||||
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
|
||||
|
||||
TUPLE: sql-spec slot-name column-name type modifiers ;
|
||||
|
||||
: spec>tuple ( spec -- tuple )
|
||||
[ ?first3 ] keep 3 ?tail* sql-spec construct-boa ;
|
||||
|
||||
: sql-type-hash ( -- assoc )
|
||||
H{
|
||||
{ INTEGER "integer" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "varchar" }
|
||||
{ DOUBLE "real" }
|
||||
{ TIMESTAMP "timestamp" }
|
||||
} ;
|
||||
|
||||
! HOOK: sql-type-hash db ( -- obj )
|
||||
! HOOK: >sql-type-string db ( obj -- str )
|
||||
|
||||
: >sql-type-string ( obj -- str/f )
|
||||
dup pair? [
|
||||
first >sql-type-string
|
||||
] [
|
||||
sql-type-hash at* [ drop "" ] unless
|
||||
] if ;
|
||||
|
||||
: full-sql-type-string ( obj -- str )
|
||||
[ >sql-type-string ] keep second
|
||||
number>string " " swap 3append ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue