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

diff --git a/extra/db/db.factor b/extra/db/db.factor
index 7a28dea558241c2128932440773b8501c816e040..ce6232f414209011a3d262689cd1ff0240392b4b 100755 (executable)
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -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 )

diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor
index d7ef986ea6b3c541106e9d2173caa92f7cbe2138..4561424a9dc21b692579435452acd7a23a7de865 100755 (executable)
--- a/extra/db/sql/sql.factor
+++ b/extra/db/sql/sql.factor
@@ -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 )

diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index c724025874f5d79be4f10f852eaba0ecf05834ff..6b94c02c65fdf9381ea9c36687660aaed305b654 100755 (executable)
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -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 ) ;

diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index b6221e5a1ebbd967351f1058afeca1b16c151963..61070b078b3162dbf0a2a9207607e2707864271c 100755 (executable)
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -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 ] }

diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index e2ea28fe9a1e98ea4116381546c11ef5340c1bcb..5f8247f67b8d569eaa04b0ad4d6dce953d57640e 100755 (executable)
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -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" }

diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 56e401d5eceab85fc9fcf76f32c8627ba10f0a31..083cf059c91564b9894a3b794de0f9c91fd5b323 100755 (executable)
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -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

diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 32431b4ddc8462876633ef2804014f1273bf2810..e0b4fce2f3e53086c6059a3e55acea03edc7990e 100755 (executable)
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -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

diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 9959e894a76feeae7d3c926152586bfb90ec3ed2..b8855ce2961d42e7f3e8dea2bf6677670cab5839 100755 (executable)
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -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? [