add random-id, still needs to retry if insert fails
parent
b257640f97
commit
a81aaa6100
|
@ -36,7 +36,7 @@ HOOK: db-close db ( handle -- )
|
|||
] with-variable ;
|
||||
|
||||
! TUPLE: sql sql in-params out-params ;
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? type quot ;
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? type ;
|
||||
TUPLE: simple-statement < statement ;
|
||||
TUPLE: prepared-statement < statement ;
|
||||
|
||||
|
@ -62,13 +62,9 @@ SINGLETON: retryable
|
|||
over sequence? [
|
||||
[ make-retryable ] curry map
|
||||
] [
|
||||
>>quot
|
||||
retryable >>type
|
||||
] if ;
|
||||
|
||||
: handle-random-id ( statement -- )
|
||||
drop ;
|
||||
|
||||
TUPLE: result-set sql in-params out-params handle n max ;
|
||||
|
||||
: construct-statement ( sql in out class -- statement )
|
||||
|
|
|
@ -38,7 +38,7 @@ DEFER: sql%
|
|||
{ \ select [ "(select" sql% sql% ")" sql% ] }
|
||||
{ \ table [ sql% ] }
|
||||
{ \ set [ "set" "," sql-interleave ] }
|
||||
{ \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] }
|
||||
{ \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
|
||||
{ \ count [ "count" sql-function, ] }
|
||||
{ \ sum [ "sum" sql-function, ] }
|
||||
{ \ avg [ "avg" sql-function, ] }
|
||||
|
@ -47,7 +47,7 @@ DEFER: sql%
|
|||
[ sql% [ sql% ] each ]
|
||||
} case ;
|
||||
|
||||
TUPLE: no-sql-match ;
|
||||
ERROR: no-sql-match ;
|
||||
: sql% ( obj -- )
|
||||
{
|
||||
{ [ dup string? ] [ " " 0% 0% ] }
|
||||
|
@ -56,7 +56,7 @@ TUPLE: no-sql-match ;
|
|||
{ [ dup symbol? ] [ unparse sql% ] }
|
||||
{ [ dup word? ] [ unparse sql% ] }
|
||||
{ [ dup quotation? ] [ call ] }
|
||||
[ T{ no-sql-match } throw ]
|
||||
[ no-sql-match ]
|
||||
} cond ;
|
||||
|
||||
: parse-sql ( obj -- sql in-spec out-spec in out )
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
! An interface to the sqlite database. Tested against sqlite v3.1.3.
|
||||
! Not all functions have been wrapped.
|
||||
USING: alien compiler kernel math namespaces sequences strings alien.syntax
|
||||
system combinators ;
|
||||
system combinators alien.c-types ;
|
||||
IN: db.sqlite.ffi
|
||||
|
||||
<< "sqlite" {
|
||||
|
@ -112,11 +112,14 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt
|
|||
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
|
||||
FUNCTION: sqlite3_uint64 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 ) ;
|
||||
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
|
||||
"int" "sqlite" "sqlite3_bind_int64"
|
||||
{ "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
|
||||
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 ) ;
|
||||
|
@ -126,6 +129,9 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
|
|||
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
|
||||
: sqlite3-column-uint64 ( pStmt col -- uint64 )
|
||||
"sqlite3_uint64" "sqlite" "sqlite3_column_int64"
|
||||
{ "sqlite3_stmt*" "int" } alien-invoke ;
|
||||
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
|
||||
|
|
|
@ -52,6 +52,9 @@ IN: db.sqlite.lib
|
|||
: sqlite-bind-int64 ( handle i n -- )
|
||||
sqlite3_bind_int64 sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-uint64 ( handle i n -- )
|
||||
sqlite3-bind-uint64 sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-double ( handle i x -- )
|
||||
sqlite3_bind_double sqlite-check-result ;
|
||||
|
||||
|
@ -69,7 +72,10 @@ IN: db.sqlite.lib
|
|||
parameter-index sqlite-bind-int ;
|
||||
|
||||
: sqlite-bind-int64-by-name ( handle name int64 -- )
|
||||
parameter-index sqlite-bind-int ;
|
||||
parameter-index sqlite-bind-int64 ;
|
||||
|
||||
: sqlite-bind-uint64-by-name ( handle name int64 -- )
|
||||
parameter-index sqlite-bind-uint64 ;
|
||||
|
||||
: sqlite-bind-double-by-name ( handle name double -- )
|
||||
parameter-index sqlite-bind-double ;
|
||||
|
@ -86,6 +92,8 @@ IN: db.sqlite.lib
|
|||
{
|
||||
{ INTEGER [ sqlite-bind-int-by-name ] }
|
||||
{ BIG-INTEGER [ sqlite-bind-int64-by-name ] }
|
||||
{ SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
|
||||
{ UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
|
||||
{ TEXT [ sqlite-bind-text-by-name ] }
|
||||
{ VARCHAR [ sqlite-bind-text-by-name ] }
|
||||
{ DOUBLE [ sqlite-bind-double-by-name ] }
|
||||
|
@ -99,6 +107,7 @@ IN: db.sqlite.lib
|
|||
sqlite-bind-blob-by-name
|
||||
] }
|
||||
{ +native-id+ [ sqlite-bind-int-by-name ] }
|
||||
{ +random-id+ [ sqlite-bind-int64-by-name ] }
|
||||
{ NULL [ sqlite-bind-null-by-name ] }
|
||||
[ no-sql-type ]
|
||||
} case ;
|
||||
|
@ -121,10 +130,12 @@ IN: db.sqlite.lib
|
|||
: sqlite-column-typed ( handle index type -- obj )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ +native-id+ [ sqlite3_column_int64 ] }
|
||||
{ +random-id+ [ sqlite3_column_int64 ] }
|
||||
{ +native-id+ [ sqlite3_column_int64 ] }
|
||||
{ +random-id+ [ sqlite3-column-uint64 ] }
|
||||
{ INTEGER [ sqlite3_column_int ] }
|
||||
{ BIG-INTEGER [ sqlite3_column_int64 ] }
|
||||
{ SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
|
||||
{ UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
|
||||
{ DOUBLE [ sqlite3_column_double ] }
|
||||
{ TEXT [ sqlite3_column_text ] }
|
||||
{ VARCHAR [ sqlite3_column_text ] }
|
||||
|
|
|
@ -5,7 +5,8 @@ hashtables 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 combinators.lib db.types combinators math.intervals
|
||||
io namespaces.lib accessors vectors math.ranges ;
|
||||
io namespaces.lib accessors vectors math.ranges random
|
||||
math.bitfields.lib ;
|
||||
USE: tools.walker
|
||||
IN: db.sqlite
|
||||
|
||||
|
@ -65,6 +66,9 @@ M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
|
|||
M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
|
||||
nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;
|
||||
|
||||
M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
|
||||
nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ;
|
||||
|
||||
M: sqlite-statement bind-tuple ( tuple statement -- )
|
||||
[
|
||||
in-params>> [ sqlite-bind-conversion ] with map
|
||||
|
@ -105,8 +109,7 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
|
|||
: sqlite-make ( class quot -- )
|
||||
>r sql-props r>
|
||||
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
|
||||
<simple-statement>
|
||||
dup handle-random-id ; inline
|
||||
<simple-statement> ;
|
||||
|
||||
M: sqlite-db create-sql-statement ( class -- statement )
|
||||
[
|
||||
|
@ -129,7 +132,21 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
|
|||
maybe-remove-id
|
||||
dup [ ", " 0% ] [ column-name>> 0% ] interleave
|
||||
") values(" 0%
|
||||
[ ", " 0% ] [ bind% ] interleave
|
||||
[ ", " 0% ] [
|
||||
dup type>> +random-id+ = [
|
||||
break
|
||||
dup modifiers>> find-random-generator
|
||||
[
|
||||
[
|
||||
column-name>> ":" prepend
|
||||
dup 0% random-id-quot
|
||||
] with-random
|
||||
] curry
|
||||
[ type>> ] bi 10 <generator-bind> 1,
|
||||
] [
|
||||
bind%
|
||||
] if
|
||||
] interleave
|
||||
");" 0%
|
||||
] sqlite-make ;
|
||||
|
||||
|
@ -219,6 +236,9 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
|
|||
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
|
||||
] sqlite-make ;
|
||||
|
||||
M: sqlite-db random-id-quot ( -- quot )
|
||||
[ 64 [ 2^ random ] keep 1 - set-bit ] ;
|
||||
|
||||
M: sqlite-db modifier-table ( -- hashtable )
|
||||
H{
|
||||
{ +native-id+ "primary key" }
|
||||
|
@ -229,6 +249,9 @@ M: sqlite-db modifier-table ( -- hashtable )
|
|||
{ +default+ "default" }
|
||||
{ +null+ "null" }
|
||||
{ +not-null+ "not null" }
|
||||
{ system-random-generator "" }
|
||||
{ secure-random-generator "" }
|
||||
{ random-generator "" }
|
||||
} ;
|
||||
|
||||
M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
|
||||
|
@ -244,6 +267,9 @@ M: sqlite-db type-table ( -- assoc )
|
|||
{ +native-id+ "integer primary key" }
|
||||
{ +random-id+ "integer primary key" }
|
||||
{ INTEGER "integer" }
|
||||
{ BIG-INTEGER "bigint" }
|
||||
{ SIGNED-BIG-INTEGER "bigint" }
|
||||
{ UNSIGNED-BIG-INTEGER "bigint" }
|
||||
{ TEXT "text" }
|
||||
{ VARCHAR "text" }
|
||||
{ DATE "date" }
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files kernel tools.test db db.tuples
|
||||
USING: io.files kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
prettyprint tools.walker db.sqlite calendar
|
||||
math.intervals db.postgresql ;
|
||||
prettyprint tools.walker db.sqlite calendar sequences
|
||||
math.intervals db.postgresql accessors random math.bitfields.lib ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
|
@ -290,8 +290,37 @@ TUPLE: exam id name score ;
|
|||
|
||||
[ test-intervals ] test-sqlite
|
||||
|
||||
: test-ranges
|
||||
;
|
||||
TUPLE: bignum-test id m n o ;
|
||||
: <bignum-test> ( m n o -- obj )
|
||||
bignum-test new
|
||||
swap >>o
|
||||
swap >>n
|
||||
swap >>m ;
|
||||
|
||||
: test-bignum
|
||||
bignum-test "BIGNUM_TEST"
|
||||
{
|
||||
{ "id" "ID" +native-id+ }
|
||||
{ "m" "M" BIG-INTEGER }
|
||||
{ "n" "N" UNSIGNED-BIG-INTEGER }
|
||||
{ "o" "O" SIGNED-BIG-INTEGER }
|
||||
} define-persistent
|
||||
[ bignum-test drop-table ] ignore-errors
|
||||
[ ] [ bignum-test ensure-table ] unit-test
|
||||
[ ] [ 63 2^ dup dup <bignum-test> insert-tuple ] unit-test
|
||||
|
||||
[ T{ bignum-test f 1
|
||||
-9223372036854775808 9223372036854775808 -9223372036854775808 } ]
|
||||
[ T{ bignum-test f 1 } select-tuple ] unit-test ;
|
||||
|
||||
[ test-bignum ] test-sqlite
|
||||
|
||||
TUPLE: does-not-persist ;
|
||||
|
||||
[
|
||||
[ does-not-persist create-sql-statement ]
|
||||
[ class \ not-persistent = ] must-fail-with
|
||||
] test-sqlite
|
||||
|
||||
TUPLE: secret n message ;
|
||||
C: <secret> secret
|
||||
|
@ -299,14 +328,26 @@ C: <secret> secret
|
|||
: test-random-id
|
||||
secret "SECRET"
|
||||
{
|
||||
{ "n" "ID" +random-id+ }
|
||||
{ "n" "ID" +random-id+ system-random-generator }
|
||||
{ "message" "MESSAGE" TEXT }
|
||||
} define-persistent
|
||||
|
||||
[ ] [ secret ensure-table ] unit-test
|
||||
|
||||
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
|
||||
[ ] [ T{ secret } select-tuples ] unit-test
|
||||
;
|
||||
|
||||
[ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
|
||||
|
||||
[ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ secret } select-tuples
|
||||
first message>> "kilroy was here" head?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ secret } select-tuples length 3 =
|
||||
] unit-test ;
|
||||
|
||||
[ test-random-id ] test-sqlite
|
||||
[ native-person-schema test-tuples ] test-sqlite
|
||||
|
|
|
@ -13,9 +13,16 @@ IN: db.tuples
|
|||
"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 ;
|
||||
ERROR: not-persistent ;
|
||||
|
||||
: db-table ( class -- obj )
|
||||
"db-table" word-prop [ not-persistent ] unless* ;
|
||||
|
||||
: db-columns ( class -- obj )
|
||||
"db-columns" word-prop ;
|
||||
|
||||
: db-relations ( class -- obj )
|
||||
"db-relations" word-prop ;
|
||||
|
||||
: set-primary-key ( key tuple -- )
|
||||
[
|
||||
|
@ -61,7 +68,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
|
|||
] curry 2each ;
|
||||
|
||||
: sql-props ( class -- columns table )
|
||||
dup db-columns swap db-table ;
|
||||
[ db-columns ] [ db-table ] bi ;
|
||||
|
||||
: with-disposals ( seq quot -- )
|
||||
over sequence? [
|
||||
|
@ -88,17 +95,13 @@ HOOK: insert-tuple* db ( tuple statement -- )
|
|||
[ bind-tuple ] 2keep insert-tuple* ;
|
||||
|
||||
: insert-nonnative ( tuple -- )
|
||||
! TODO logic here for unique ids
|
||||
dup class
|
||||
db get db-insert-statements [ <insert-nonnative-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
dup class db-columns find-primary-key nonnative-id? [
|
||||
insert-nonnative
|
||||
] [
|
||||
insert-native
|
||||
] if ;
|
||||
dup class db-columns find-primary-key nonnative-id?
|
||||
[ insert-nonnative ] [ insert-native ] if ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
dup class
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser
|
|||
sequences continuations sequences.deep sequences.lib
|
||||
words namespaces tools.walker slots slots.private classes
|
||||
mirrors classes.tuple combinators calendar.format symbols
|
||||
classes.singleton ;
|
||||
classes.singleton accessors quotations random ;
|
||||
IN: db.types
|
||||
|
||||
HOOK: modifier-table db ( -- hash )
|
||||
|
@ -12,12 +12,16 @@ 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 )
|
||||
HOOK: random-id-quot db ( -- quot )
|
||||
|
||||
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
|
||||
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
|
||||
|
||||
TUPLE: literal-bind key type value ;
|
||||
C: <literal-bind> literal-bind
|
||||
|
||||
TUPLE: generator-bind key quot type retries ;
|
||||
C: <generator-bind> generator-bind
|
||||
|
||||
SINGLETON: +native-id+
|
||||
SINGLETON: +assigned-id+
|
||||
SINGLETON: +random-id+
|
||||
|
@ -27,6 +31,15 @@ UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
|
|||
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
|
||||
+foreign-id+ +has-many+ ;
|
||||
|
||||
: find-random-generator ( seq -- obj )
|
||||
[
|
||||
{
|
||||
random-generator
|
||||
system-random-generator
|
||||
secure-random-generator
|
||||
} member?
|
||||
] find nip [ system-random-generator ] unless* ;
|
||||
|
||||
: primary-key? ( spec -- ? )
|
||||
sql-spec-primary-key +primary-key+? ;
|
||||
|
||||
|
@ -51,26 +64,27 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
|
|||
|
||||
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
|
||||
|
||||
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
|
||||
DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
|
||||
: handle-random-id ( statement -- )
|
||||
dup in-params>> [ type>> +random-id+ = ] find drop >boolean [
|
||||
retryable >>type
|
||||
random-id-quot >>quot
|
||||
] when drop ;
|
||||
|
||||
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
|
||||
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
|
||||
FACTOR-BLOB NULL ;
|
||||
|
||||
: 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
|
||||
set-sql-spec-modifiers
|
||||
} sql-spec construct
|
||||
3 f pad-right
|
||||
[ first3 ] keep 3 tail
|
||||
sql-spec new
|
||||
swap >>modifiers
|
||||
swap >>type
|
||||
swap >>column-name
|
||||
swap >>slot-name
|
||||
swap >>class
|
||||
dup normalize-spec ;
|
||||
|
||||
TUPLE: no-sql-type ;
|
||||
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
|
||||
|
||||
TUPLE: no-sql-modifier ;
|
||||
: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
|
||||
|
||||
: number>string* ( n/str -- str )
|
||||
dup number? [ number>string ] when ;
|
||||
|
||||
|
@ -88,13 +102,15 @@ TUPLE: no-sql-modifier ;
|
|||
! PostgreSQL Types:
|
||||
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
|
||||
|
||||
ERROR: unknown-modifier ;
|
||||
|
||||
: lookup-modifier ( obj -- str )
|
||||
dup array? [
|
||||
unclip lookup-modifier swap compound-modifier
|
||||
] [
|
||||
modifier-table at*
|
||||
[ "unknown modifier" throw ] unless
|
||||
] if ;
|
||||
{
|
||||
{ [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] }
|
||||
[ modifier-table at* [ unknown-modifier ] unless ]
|
||||
} cond ;
|
||||
|
||||
ERROR: no-sql-type ;
|
||||
|
||||
: lookup-type* ( obj -- str )
|
||||
dup array? [
|
||||
|
|
Loading…
Reference in New Issue