add db.types, db.tuples and some code in progress
create-sql works for a limited test case in sqlitedb4
Doug Coleman
parent
577e18b854
commit
afa71627ee
|
|
@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math
|
|||
namespaces sequences sequences.lib tuples words ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db handle ;
|
||||
C: <db> db ( handle -- obj )
|
||||
TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
|
||||
: <db> ( handle -- obj )
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
H{ } clone
|
||||
db construct-boa ;
|
||||
|
||||
! HOOK: db-create db ( str -- )
|
||||
! HOOK: db-drop db ( str -- )
|
||||
GENERIC: db-open ( db -- )
|
||||
HOOK: db-close db ( handle -- )
|
||||
|
||||
: dispose-statements [ dispose drop ] assoc-each ;
|
||||
|
||||
: 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-select-statements dispose-statements
|
||||
db-handle db-close
|
||||
] with-variable ;
|
||||
|
||||
TUPLE: statement sql params handle bound? ;
|
||||
|
||||
|
|
@ -43,6 +58,8 @@ GENERIC: #columns ( result-set -- n )
|
|||
GENERIC# row-column 1 ( result-set n -- obj )
|
||||
GENERIC: advance-row ( result-set -- ? )
|
||||
|
||||
HOOK: last-id db ( -- id )
|
||||
|
||||
: init-result-set ( result-set -- )
|
||||
dup #rows over set-result-set-max
|
||||
-1 swap set-result-set-n ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,6 @@ M: mysql-db db-open ( mysql-db -- )
|
|||
M: mysql-db dispose ( mysql-db -- )
|
||||
mysql-db-handle mysql_close ;
|
||||
|
||||
|
||||
M: mysql-db <simple-statement> ( str -- statement )
|
||||
;
|
||||
|
||||
|
|
|
|||
|
|
@ -106,6 +106,8 @@ IN: db.sqlite.ffi
|
|||
|
||||
TYPEDEF: void sqlite3
|
||||
TYPEDEF: void sqlite3_stmt
|
||||
TYPEDEF: longlong sqlite3_int64
|
||||
TYPEDEF: ulonglong sqlite3_uint64
|
||||
|
||||
LIBRARY: sqlite
|
||||
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
|
||||
|
|
@ -116,7 +118,9 @@ FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
|
|||
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
|
||||
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
|
||||
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
|
||||
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
|
||||
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
|
||||
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
|
||||
|
|
|
|||
|
|
@ -21,9 +21,6 @@ TUPLE: sqlite-error n message ;
|
|||
: sqlite-close ( db -- )
|
||||
sqlite3_close sqlite-check-result ;
|
||||
|
||||
: sqlite-last-insert-rowid ( db -- rowid )
|
||||
sqlite3_last_insert_rowid ;
|
||||
|
||||
: sqlite-prepare ( db sql -- statement )
|
||||
#! TODO: Support multiple statements in the SQL string.
|
||||
dup length "void*" <c-object> "void*" <c-object>
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
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 ;
|
||||
continuations db.sqlite.lib db.sqlite.ffi db.tuples
|
||||
words combinators.lib db.types ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
|
|
@ -13,10 +14,10 @@ M: sqlite-db db-open ( db -- )
|
|||
dup sqlite-db-path sqlite-open <db>
|
||||
swap set-delegate ;
|
||||
|
||||
M: sqlite-db dispose ( obj -- )
|
||||
dup db-handle sqlite-close
|
||||
f over set-db-handle
|
||||
f swap set-delegate ;
|
||||
M: sqlite-db db-close ( handle -- )
|
||||
sqlite-close ;
|
||||
|
||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
||||
|
||||
: with-sqlite ( path quot -- )
|
||||
>r <sqlite-db> r> with-db ; inline
|
||||
|
|
@ -72,3 +73,105 @@ M: sqlite-db commit-transaction ( -- )
|
|||
|
||||
M: sqlite-db rollback-transaction ( -- )
|
||||
"ROLLBACK" sql-command ;
|
||||
|
||||
M: sqlite-db create-sql ( columns table -- sql )
|
||||
[
|
||||
"create table " % %
|
||||
" (" % [ ", " % ] [
|
||||
dup second % " " %
|
||||
dup third >sql-type % " " %
|
||||
sql-modifiers " " join %
|
||||
] interleave ")" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db insert-sql* ( columns table -- sql )
|
||||
[
|
||||
"insert into " %
|
||||
%
|
||||
"(" %
|
||||
dup [ ", " % ] [ second % ] interleave
|
||||
") " %
|
||||
" values (" %
|
||||
[ ", " % ] [ ":" % second % ] interleave
|
||||
")" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db update-sql* ( columns table -- sql )
|
||||
[
|
||||
"update " %
|
||||
%
|
||||
" set " %
|
||||
dup remove-id
|
||||
[ ", " % ] [ second dup % " = :" % % ] interleave
|
||||
" where " %
|
||||
[ primary-key? ] find nip second dup % " = :" % %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db delete-sql* ( columns table -- sql )
|
||||
[
|
||||
break
|
||||
"delete from " %
|
||||
%
|
||||
" where " %
|
||||
first second dup % " = :" % %
|
||||
] "" make dup . ;
|
||||
|
||||
M: sqlite-db select-sql* ( columns table -- sql )
|
||||
[
|
||||
"select ROWID, " %
|
||||
swap [ ", " % ] [ second % ] interleave
|
||||
" from " %
|
||||
%
|
||||
" where ROWID = :ID" %
|
||||
] "" make ;
|
||||
|
||||
M: sqlite-db tuple>params ( columns tuple -- obj )
|
||||
[
|
||||
>r [ second ":" swap append ] keep first r> get-slot-named
|
||||
number>string*
|
||||
] curry { } map>assoc ;
|
||||
|
||||
M: sqlite-db last-id ( -- id )
|
||||
db get db-handle sqlite3_last_insert_rowid ;
|
||||
|
||||
|
||||
: sqlite-db-modifiers ( -- hashtable )
|
||||
H{
|
||||
{ +native-id+ "primary key" }
|
||||
{ +assigned-id+ "primary key" }
|
||||
{ +autoincrement+ "autoincrement" }
|
||||
{ +unique+ "unique" }
|
||||
{ +default+ "default" }
|
||||
{ +null+ "null" }
|
||||
{ +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 ;
|
||||
|
||||
: sqlite-type-hash ( -- assoc )
|
||||
H{
|
||||
{ INTEGER "integer" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "text" }
|
||||
} ;
|
||||
|
||||
M: sqlite-db >sql-type ( obj -- str )
|
||||
dup pair? [
|
||||
first >sql-type
|
||||
] [
|
||||
sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
|
||||
] if ;
|
||||
|
||||
! HOOK: get-column-value ( n result-set type -- )
|
||||
! M: sqlite get-column-value { { "TEXT" get-text-column } {
|
||||
! "INTEGER" get-integer-column } ... } case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
USING: io.files kernel tools.test db db.sqlite db.tuples ;
|
||||
IN: temporary
|
||||
|
||||
TUPLE: person the-id the-name the-number ;
|
||||
: <person> ( name age -- person )
|
||||
{ set-person-the-name set-person-the-number } person construct ;
|
||||
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ROWID" INTEGER +native-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
} define-persistent
|
||||
|
||||
|
||||
: test-tuples ( -- )
|
||||
f "billy" 100 person construct-boa dup insert-tuple
|
||||
|
||||
[ 1 ] [ dup person-id ] unit-test
|
||||
|
||||
200 over set-person-the-number
|
||||
|
||||
[ ] [ dup update-tuple ] unit-test
|
||||
|
||||
[ ] [ delete-tuple ] unit-test ;
|
||||
|
||||
: test-sqlite ( -- )
|
||||
"tuples-test.db" resource-path <sqlite-db> [
|
||||
test-tuples
|
||||
] with-db ;
|
||||
|
||||
test-sqlite
|
||||
|
||||
! : test-postgres ( -- )
|
||||
! resource-path <postgresql-db> [
|
||||
! test-tuples
|
||||
! ] with-db ;
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
USING: arrays assocs classes db kernel namespaces
|
||||
tuples words sequences slots slots.private math
|
||||
math.parser io prettyprint db.types ;
|
||||
USE: continuations
|
||||
IN: db.tuples
|
||||
|
||||
! only take a tuple if you have to extract things from it
|
||||
! otherwise take a class
|
||||
! primary-key vs primary-key-spec
|
||||
! define-persistent should enforce a primary key
|
||||
! in sqlite, defining a new primary key makes it an alias for rowid, _rowid_, and oid
|
||||
! -sql outputs sql code
|
||||
! table - string
|
||||
! columns - seq of column specifiers
|
||||
|
||||
: db-columns ( class -- obj )
|
||||
"db-columns" word-prop ;
|
||||
|
||||
: db-table ( class -- obj )
|
||||
"db-table" word-prop ;
|
||||
|
||||
|
||||
: slot-spec-named ( str class -- slot-spec )
|
||||
"slots" word-prop [ slot-spec-name = ] with find nip ;
|
||||
|
||||
: offset-of-slot ( str obj -- n )
|
||||
class slot-spec-named slot-spec-offset ;
|
||||
|
||||
: get-slot-named ( str obj -- value )
|
||||
tuck offset-of-slot slot ;
|
||||
|
||||
: set-slot-named ( value str obj -- )
|
||||
tuck offset-of-slot 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 first ] 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 -- sql )
|
||||
HOOK: drop-sql db ( columns table -- sql )
|
||||
HOOK: insert-sql* db ( columns table -- sql )
|
||||
HOOK: update-sql* db ( columns table -- sql )
|
||||
HOOK: delete-sql* db ( columns table -- sql )
|
||||
HOOK: select-sql* db ( columns table -- sql )
|
||||
|
||||
: insert-sql ( columns class -- statement )
|
||||
db get db-insert-statements [ insert-sql* ] cache-statement ;
|
||||
|
||||
: update-sql ( columns class -- statement )
|
||||
db get db-update-statements [ update-sql* ] cache-statement ;
|
||||
|
||||
: delete-sql ( columns class -- statement )
|
||||
db get db-delete-statements [ delete-sql* ] cache-statement ;
|
||||
|
||||
: select-sql ( columns class -- statement )
|
||||
db get db-select-statements [ select-sql* ] cache-statement ;
|
||||
|
||||
HOOK: tuple>params db ( columns tuple -- obj )
|
||||
|
||||
: tuple-statement ( columns tuple quot -- statement )
|
||||
>r [ tuple>params ] 2keep class r> call
|
||||
[ bind-statement ] keep ;
|
||||
|
||||
: do-tuple-statement ( tuple columns-quot statement-quot -- )
|
||||
>r [ class db-columns ] swap compose keep
|
||||
r> tuple-statement dup . execute-statement ;
|
||||
|
||||
: create-table ( class -- )
|
||||
dup db-columns swap db-table create-sql sql-command ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
[
|
||||
[ maybe-remove-id ] [ insert-sql ] do-tuple-statement
|
||||
last-id
|
||||
] keep set-primary-key ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
[ ] [ update-sql ] do-tuple-statement ;
|
||||
|
||||
: delete-tuple ( tuple -- )
|
||||
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
|
||||
|
||||
! : select-tuple ( tuple -- )
|
||||
! [ select-sql ] bind-tuple do-query ;
|
||||
|
||||
: persist ( tuple -- )
|
||||
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
|
||||
|
||||
! PERSISTENT:
|
||||
|
||||
: define-persistent ( class table columns -- )
|
||||
>r dupd "db-table" set-word-prop r>
|
||||
"db-columns" set-word-prop ;
|
||||
|
||||
: define-relation ( spec -- )
|
||||
drop ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
USING: arrays assocs db kernel math math.parser
|
||||
sequences continuations ;
|
||||
IN: db.types
|
||||
|
||||
|
||||
! id serial not null primary key,
|
||||
! ID is the Primary key
|
||||
SYMBOL: +native-id+
|
||||
SYMBOL: +assigned-id+
|
||||
|
||||
: primary-key? ( spec -- ? )
|
||||
[ { +native-id+ +assigned-id+ } member? ] contains? ;
|
||||
|
||||
! Same concept, SQLite has autoincrement, PostgreSQL has serial
|
||||
SYMBOL: +autoincrement+
|
||||
SYMBOL: +serial+
|
||||
SYMBOL: +unique+
|
||||
|
||||
SYMBOL: +default+
|
||||
SYMBOL: +null+
|
||||
SYMBOL: +not-null+
|
||||
SYMBOL: +has-many+
|
||||
|
||||
! SQLite Types
|
||||
! http://www.sqlite.org/datatype3.html
|
||||
! SYMBOL: NULL
|
||||
! SYMBOL: INTEGER
|
||||
! SYMBOL: REAL
|
||||
! SYMBOL: TEXT
|
||||
! SYMBOL: BLOB
|
||||
|
||||
SYMBOL: INTEGER
|
||||
SYMBOL: DOUBLE
|
||||
SYMBOL: BOOLEAN
|
||||
|
||||
SYMBOL: TEXT
|
||||
SYMBOL: VARCHAR
|
||||
|
||||
SYMBOL: TIMESTAMP
|
||||
SYMBOL: DATE
|
||||
|
||||
SYMBOL: BIG_INTEGER
|
||||
|
||||
! SYMBOL: LOCALE
|
||||
! SYMBOL: TIMEZONE
|
||||
! SYMBOL: CURRENCY
|
||||
|
||||
|
||||
! PostgreSQL Types
|
||||
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
|
||||
|
||||
|
||||
: number>string* ( num/str -- str )
|
||||
dup number? [ number>string ] when ;
|
||||
|
||||
TUPLE: no-sql-type ;
|
||||
HOOK: sql-modifiers* db ( modifiers -- str )
|
||||
HOOK: >sql-type db ( obj -- str )
|
||||
|
||||
|
||||
|
||||
|
||||
: maybe-remove-id ( columns -- obj )
|
||||
[ +native-id+ swap member? not ] subset ;
|
||||
|
||||
: remove-id ( columns -- obj )
|
||||
[ primary-key? not ] subset ;
|
||||
|
||||
: sql-modifiers ( spec -- seq )
|
||||
3 tail sql-modifiers* ;
|
||||
Loading…
Reference in New Issue