steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

sql is correctly generated for sqlite and postgresql up to basic selects

db4
Doug Coleman 2008-02-20 11:30:48 -06:00
parent efb68a3565
commit 779bd8c8d9
9 changed files with 269 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/db/db.factor
View File

@ -23,7 +23,7 @@ HOOK: db-close db ( handle -- )
db-handle db-close
] with-variable ;
TUPLE: statement handle sql slot-names bind-params bound? ;
TUPLE: statement handle sql slot-names bound? in-params out-params ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
@ -47,7 +47,7 @@ GENERIC: more-rows? ( result-set -- ? )
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-bind-params ] keep
[ set-statement-in-params ] keep
t swap set-statement-bound? ;
: init-result-set ( result-set -- )
@ -55,7 +55,7 @@ GENERIC: more-rows? ( result-set -- ? )
0 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-bind-params } get-slots r>
>r >r { statement-sql statement-in-params } get-slots r>
{
set-result-set-sql
set-result-set-params

4
extra/db/postgresql/lib/lib.factor
View File

@ -37,8 +37,8 @@ IN: db.postgresql.lib
: do-postgresql-bound-statement ( statement -- res )
>r db get db-handle r>
[ statement-sql ] keep
[ statement-bind-params length f ] keep
statement-bind-params
[ statement-in-params length f ] keep
statement-in-params
[ first number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [

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

@ -39,7 +39,7 @@ M: postgresql-db dispose ( db -- )
>r <postgresql-db> r> with-disposal ;
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-bind-params ;
set-statement-in-params ;
M: postgresql-statement reset-statement ( statement -- )
drop ;
@ -68,7 +68,7 @@ M: postgresql-statement insert-statement ( statement -- id )
query-results [ 0 row-column ] with-disposal string>number ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-bind-params [
dup statement-in-params [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
@ -96,7 +96,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
dup statement-sql swap statement-bind-params
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
@ -118,12 +118,6 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
: modifiers% ( spec -- )
sql-spec-modifiers
[ lookup-modifier ] map
" " join
dup empty? [ drop ] [ " " % % ] if ;
SYMBOL: postgresql-counter
: bind% ( spec -- )
1,
@ -274,6 +268,7 @@ M: postgresql-db type-table ( -- hash )
{ TEXT "text" }
{ VARCHAR "varchar" }
{ INTEGER "integer" }
{ TIMESTAMP "timestamp" }
} ;
M: postgresql-db create-type-table ( -- hash )
@ -282,16 +277,24 @@ M: postgresql-db create-type-table ( -- hash )
} ;
: postgresql-compound ( str n -- newstr )
dup number? [ "compound -- not a number" throw ] unless
number>string " " swap 3append ;
over {
{ "varchar" [ first number>string join-space ] }
{ "references"
[
first2 >r [ unparse join-space ] keep db-columns r>
swap [ sql-spec-slot-name = ] with find nip sql-spec-column-name paren append
] }
[ "no compound found" 3array throw ]
} case ;
M: postgresql-db compound-modifier ( str n -- newstr )
M: postgresql-db compound-modifier ( str seq -- newstr )
postgresql-compound ;
M: postgresql-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +foreign-id+ "references" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }

4
extra/db/sqlite/lib/lib.factor
View File

@ -78,7 +78,7 @@ IN: db.sqlite.lib
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
{ SERIAL [ sqlite-bind-int-by-name ] }
{ TIMESTAMP [ sqlite-bind-double-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
@ -102,6 +102,8 @@ IN: db.sqlite.lib
{ BIG_INTEGER [ sqlite3_column_int64 ] }
{ TEXT [ sqlite3_column_text ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TIMESTAMP [ sqlite3_column_double ] }
[ no-sql-type ]
} case ;
! TODO

157
extra/db/sqlite/sqlite-tests.factor
View File

@ -1,6 +1,6 @@
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db sequences
continuations db.types ;
continuations db.types db.tuples unicode.case ;
IN: temporary
: test.db "extra/db/sqlite/test.db" resource-path ;
@ -89,3 +89,158 @@ IN: temporary
"select * from person" sql-query length
] with-sqlite
] 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+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "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" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id integer primary key not null, name varchar 256, age integer);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table basket(id integer primary key not null, location text);"
] [
T{ sqlite-db } db [
basket dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ sqlite-db } db [
puppy db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ sqlite-db } db [
kitty db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ sqlite-db } db [
basket db-table drop-sql >lower
] with-variable
] unit-test
! Insert
[
"insert into puppy(name, age) values(:name, :age);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values(:id, :name, :age);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
! Update
[
"update puppy set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
[
"update kitty set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
[
"delete from kitty where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
! Select
[
"select from puppy id, name, age where name = :name;"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ sqlite-db } db [
T{ puppy f f "Mr. Clunkers" }
select-sql >r >lower r>
] with-variable
] unit-test

107
extra/db/sqlite/sqlite.factor
View File

@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types ;
words combinators.lib db.types combinators ;
IN: db.sqlite
TUPLE: sqlite-db path ;
@ -86,54 +86,53 @@ M: sqlite-db commit-transaction ( -- )
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: sqlite-db create-sql ( columns table -- sql )
M: sqlite-db create-sql ( specs table -- sql )
[
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type % " " %
sql-modifiers " " join %
] interleave ")" %
"(" % [ ", " % ] [
dup sql-spec-column-name %
" " %
dup sql-spec-type t lookup-type %
modifiers%
] interleave ");" %
] "" make ;
M: sqlite-db drop-sql ( columns table -- sql )
M: sqlite-db drop-sql ( specs table -- sql )
[
"drop table " % %
drop
"drop table " % % ";" %
] "" make ;
M: sqlite-db insert-sql* ( columns table -- sql )
M: sqlite-db insert-sql* ( specs table -- sql )
[
"insert into " %
%
"insert into " % %
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
[ ", " % ] [ ":" % second % ] interleave
")" %
maybe-remove-id
dup [ ", " % ] [ sql-spec-column-name % ] interleave
") values(" %
[ ", " % ] [ ":" % sql-spec-column-name % ] interleave
");" %
] "" make ;
: where-primary-key% ( columns -- )
: where-primary-key% ( specs -- )
" where " %
[ primary-key? ] find nip second dup % " = :" % % ;
find-primary-key sql-spec-column-name dup % " = :" % % ;
M: sqlite-db update-sql* ( columns table -- sql )
M: sqlite-db update-sql* ( specs table -- sql )
[
"update " %
%
" set " %
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
[ ", " % ] [ sql-spec-column-name dup % " = :" % % ] interleave
where-primary-key%
] "" make ;
M: sqlite-db delete-sql* ( columns table -- sql )
M: sqlite-db delete-sql* ( specs table -- sql )
[
"delete from " %
%
"delete from " % %
" where " %
first second dup % " = :" % %
find-primary-key
sql-spec-column-name dup % " = :" % %
] "" make ;
: select-interval ( interval name -- )
@ -142,22 +141,32 @@ M: sqlite-db delete-sql* ( columns table -- sql )
: select-sequence ( seq name -- )
;
M: sqlite-db select-sql ( columns table -- sql )
: select-by-slots-sql ( tuple -- sql out-specs )
[
"select ROWID, " %
over [ ", " % ] [ second % ] interleave
" from " % %
" where " %
] "" make ;
"select from " 0% dup class db-table 0%
" " 0%
dup class db-columns [ ", " 0% ]
[ dup sql-spec-column-name 0% 1, ] interleave
M: sqlite-db tuple>params ( columns tuple -- obj )
dup class db-columns
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ sql-spec-column-name dup 0% " = :" 0% 0% ] interleave
";" 0%
] { "" { } } nmake ;
M: sqlite-db select-sql ( tuple -- sql )
select-by-slots-sql ;
M: sqlite-db tuple>params ( specs tuple -- obj )
[
>r [ second ":" swap append ] keep r>
dupd >r first r> get-slot-named swap
third 3array
] curry map ;
: sqlite-db-modifiers ( -- hashtable )
M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
@ -168,32 +177,24 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
M: sqlite-db sql-modifiers* ( modifiers -- str )
sqlite-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
M: sqlite-db compound-type ( str seq -- )
over {
{ "varchar" [ first number>string join-space ] }
[ 2drop "" ] ! "no sqlite compound data type" 3array throw ]
} case ;
: sqlite-type-hash ( -- assoc )
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ VARCHAR "varchar" }
{ TIMESTAMP "timestamp" }
{ DOUBLE "real" }
} ;
M: sqlite-db >sql-type ( obj -- str )
dup pair? [
first >sql-type
] [
sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
] if ;
M: sqlite-db create-type-table
type-table ;
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {

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

@ -1,7 +1,8 @@
! 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
db.types continuations namespaces db.postgresql math ;
db.types continuations namespaces db.postgresql math
prettyprint ;
! tools.time ;
IN: temporary
@ -45,7 +46,7 @@ SYMBOL: the-person
person "PERSON"
{
{ "the-id" "ID" SERIAL +native-id+ }
{ "the-id" "ID" +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
@ -53,7 +54,7 @@ person "PERSON"
"billy" 10 3.14 <person> the-person set
! test-sqlite
test-sqlite
! test-postgresql
! person "PERSON"
@ -74,7 +75,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
paste "PASTE"
{
{ "n" "ID" SERIAL +native-id+ }
{ "n" "ID" +native-id+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "channel" "CHANNEL" TEXT }
@ -84,17 +85,10 @@ paste "PASTE"
{ "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" } }
{ "n" "ID" +native-id+ }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "mode" "MODE" TEXT }
@ -102,8 +96,10 @@ annotation "ANNOTATION"
} define-persistent
"localhost" "postgres" "" "factor-test" <postgresql-db> [
! paste drop-table
! annotation drop-table
[ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover
[ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover
paste create-table
annotation create-table
] with-db

1
extra/db/tuples/tuples.factor
View File

@ -65,7 +65,6 @@ HOOK: tuple>params db ( columns tuple -- obj )
: tuple-statement ( columns tuple quot -- statement )
>r [ tuple>params ] 2keep class r> call
2dup . .
[ bind-statement ] keep ;
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )

33
extra/db/types/types.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words ;
words namespaces ;
IN: db.types
TUPLE: sql-spec slot-name column-name type modifiers primary-key ;
@ -34,7 +34,7 @@ SYMBOL: +assigned-id+
: assigned-id? ( spec -- ? )
sql-spec-primary-key +assigned-id+ = ;
SYMBOL: +foreign-key+
SYMBOL: +foreign-id+
! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+
@ -107,23 +107,27 @@ TUPLE: no-sql-modifier ;
HOOK: modifier-table db ( -- hash )
HOOK: compound-modifier db ( str n -- hash )
HOOK: compound-modifier db ( str seq -- hash )
: lookup-modifier ( obj -- str )
dup pair? [
first2 >r lookup-modifier r> compound-modifier
dup array? [
unclip lookup-modifier swap compound-modifier
] [
modifier-table at*
[ "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 pair? [
dup array? [
first lookup-type*
] [
type-table at*
@ -131,12 +135,25 @@ HOOK: compound-type db ( str n -- hash )
] if ;
: lookup-create-type ( obj -- str )
dup pair? [
first2 >r lookup-create-type r> compound-type
dup array? [
unclip lookup-create-type swap compound-type
] [
dup create-type-table at*
[ nip ] [ drop lookup-type* ] if
] if ;
USE: prettyprint
: lookup-type ( obj create? -- str )
[ lookup-create-type ] [ lookup-type* ] if ;
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
: double-quote ( str -- newstr )
"\"" swap "\"" 3append ;
: paren ( str -- newstr )
"(" swap ")" 3append ;
: join-space ( str1 str2 -- newstr )
" " swap 3append ;