add random-id, still needs to retry if insert fails

db4
Doug Coleman 2008-04-19 19:27:54 -05:00
parent b257640f97
commit a81aaa6100
8 changed files with 158 additions and 59 deletions

View File

@ -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 )

View File

@ -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 )

View File

@ -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 ) ;

View File

@ -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 ] }

View File

@ -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" }

View File

@ -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

View File

@ -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

View File

@ -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? [