fix teh bugs pl0x

diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index 3fc95fcafebb56c1971105715221a4acbd0b0d34..d270e6f40d8ea6a7a2fa4c67e03f4bfdbac5b179 100755 (executable)
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -72,7 +72,7 @@ M: postgresql-result-null summary ( obj -- str )
 : param-values ( statement -- seq seq2 )
     [ bind-params>> ] [ in-params>> ] bi
     [
-        type>> {
+        >r value>> r> type>> {
             { FACTOR-BLOB [
                 dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
             ] }
@@ -150,6 +150,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
     dup array? [ first ] when
     {
         { +native-id+ [ pq-get-number ] }
+        { +random-id+ [ pq-get-number ] }
         { INTEGER [ pq-get-number ] }
         { BIG-INTEGER [ pq-get-number ] }
         { DOUBLE [ pq-get-number ] }

diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 057c5f51682c5ff4d2e4f94115ef6071a594721e..687146af11db5d8f7dd4918979cb0af95d322c63 100755 (executable)
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -39,16 +39,16 @@ M: postgresql-db dispose ( db -- )
 M: postgresql-statement bind-statement* ( statement -- )
     drop ;
 
-GENERIC: postgresql-bind-conversion
+GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
 
-M: sql-spec postgresql-bind-conversion ( tuple spec -- array )
-    slot-name>> swap get-slot-named ;
+M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
+    slot-name>> swap get-slot-named <low-level-binding> ;
 
-M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- array )
-    nip value>> ;
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
+    nip value>> <low-level-binding> ;
 
-M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- array )
-    nip quot>> call ;
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
+    nip singleton>> eval-generator <low-level-binding> ;
 
 M: postgresql-statement bind-tuple ( tuple statement -- )
     tuck in-params>>
@@ -201,7 +201,16 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
         ")" 0%
 
         " values(" 0%
-        [ ", " 0% ] [ bind% ] interleave
+        [ ", " 0% ] [
+            dup type>> +random-id+ = [
+                [
+                    drop bind-name%
+                    f random-id-generator
+                ] [ type>> ] bi <generator-bind> 1,
+            ] [
+                bind%
+            ] if
+        ] interleave
         ");" 0%
     ] query-make ;
 

diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index f3e6d59eddedebebd72f5e6cb5045499c9d21a5e..e902869d3b80f8e3c4287ae49962382d3042c455 100644 (file)
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -6,6 +6,9 @@ math.bitfields.lib namespaces.lib db db.tuples db.types
 math.intervals ;
 IN: db.queries
 
+GENERIC: eval-generator ( singleton -- obj )
+GENERIC: where ( specs obj -- )
+
 : maybe-make-retryable ( statement -- statement )
     dup in-params>> [ generator-bind? ] contains? [
         make-retryable
@@ -41,10 +44,11 @@ M: db <delete-tuple-statement> ( specs table -- sql )
         dup column-name>> 0% " = " 0% bind%
     ] query-make ;
 
-M: db random-id-quot ( -- quot )
-    [ 63 [ 2^ random ] keep 1 - set-bit ] ;
-
-GENERIC: where ( specs obj -- )
+M: random-id-generator eval-generator ( singleton -- obj )
+    drop
+    system-random-generator get [
+        63 [ 2^ random ] keep 1 - set-bit
+    ] with-random ;
 
 : interval-comparison ( ? str -- str )
     "from" = " >" " <" ? swap [ "= " append ] when ;

diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index f4247cf6d8998c7482e6ef3e089fb7f0119f328a..2175b69f35411b7eee2530a994a962502330aebf 100755 (executable)
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -53,7 +53,7 @@ M: sqlite-result-set dispose ( result-set -- )
 
 M: sqlite-statement low-level-bind ( statement -- )
     [ statement-bind-params ] [ statement-handle ] bi
-    swap [ first3 sqlite-bind-type ] with each ;
+    swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
 
 M: sqlite-statement bind-statement* ( statement -- )
     sqlite-maybe-prepare
@@ -62,16 +62,25 @@ M: sqlite-statement bind-statement* ( statement -- )
 
 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
 
+TUPLE: sqlite-low-level-binding < low-level-binding key type ;
+: <sqlite-low-level-binding> ( key value type -- obj )
+    sqlite-low-level-binding new
+        swap >>type
+        swap >>value
+        swap >>key ;
+
 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
     [ column-name>> ":" prepend ]
     [ slot-name>> rot get-slot-named ]
-    [ type>> ] tri 3array ;
+    [ type>> ] tri <sqlite-low-level-binding> ;
 
 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
-    nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;
+    nip [ key>> ] [ value>> ] [ type>> ] tri
+    <sqlite-low-level-binding> ;
 
 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
-    nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ;
+    nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri
+    <sqlite-low-level-binding> ;
 
 M: sqlite-statement bind-tuple ( tuple statement -- )
     [
@@ -129,14 +138,10 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
         ") values(" 0%
         [ ", " 0% ] [
             dup type>> +random-id+ = [
-                dup modifiers>> find-random-generator
                 [
-                    [
-                        column-name>> ":" prepend
-                        dup 0% random-id-quot
-                    ] with-random
-                ] curry
-                [ type>> ] bi <generator-bind> 1,
+                    column-name>> ":" prepend dup 0%
+                    random-id-generator
+                ] [ type>> ] bi <generator-bind> 1,
             ] [
                 bind%
             ] if

diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 0c52828b2a705daa7419b58c80189ad9b549a10e..1c900edc689252c69c5370f3da7f2b7908bd5e47 100755 (executable)
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -342,14 +342,14 @@ C: <secret> secret
 [ test-bignum ] test-postgresql
 [ test-serialize ] test-postgresql
 [ test-intervals ] test-postgresql
-! [ test-random-id ] test-postgresql
+[ test-random-id ] test-postgresql
 
 TUPLE: does-not-persist ;
 
-! [
-    ! [ does-not-persist create-sql-statement ]
-    ! [ class \ not-persistent = ] must-fail-with
-! ] test-sqlite
+[
+    [ does-not-persist create-sql-statement ]
+    [ class \ not-persistent = ] must-fail-with
+] test-sqlite
 
 [
     [ does-not-persist create-sql-statement ]

diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 1b1e48ddee0e1219a067391a6d295a448e29f5a4..d91e9b2758230c5129691ce8b6f5826d072b8f39 100755 (executable)
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -3,7 +3,7 @@
 USING: arrays assocs classes db kernel namespaces
 classes.tuple words sequences slots math accessors
 math.parser io prettyprint db.types continuations
-mirrors sequences.lib tools.walker combinators.lib ;
+mirrors sequences.lib tools.walker combinators.lib db.queries ;
 IN: db.tuples
 
 : define-persistent ( class table columns -- )
@@ -26,11 +26,12 @@ ERROR: not-persistent ;
 
 : set-primary-key ( key tuple -- )
     [
-        class db-columns find-primary-key sql-spec-slot-name
+        class db-columns find-primary-key slot-name>>
     ] keep set-slot-named ;
 
 SYMBOL: sql-counter
-: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ;
+: next-sql-counter ( -- str )
+    sql-counter [ inc ] [ get ] bi number>string ;
 
 ! returns a sequence of prepared-statements
 HOOK: create-sql-statement db ( class -- obj )
@@ -63,18 +64,12 @@ SINGLETON: retryable
     [ bind-params>> ] [ in-params>> ] bi
     [
         dup generator-bind? [
-            quot>> call over set-second
+            singleton>> eval-generator >>value
         ] [
             drop
         ] if
     ] 2map >>bind-params ;
 
-: handle-random-id ( statement -- )
-    dup in-params>> [ type>> +random-id+ = ] find drop >boolean [
-        retryable >>type
-        random-id-quot >>quot
-    ] when drop ;
-
 M: retryable execute-statement* ( statement type -- )
     drop
     [
@@ -84,21 +79,21 @@ M: retryable execute-statement* ( statement type -- )
     ] curry 10 retry drop ;
 
 : resulting-tuple ( row out-params -- tuple )
-    dup first sql-spec-class new [
+    dup first class>> new [
         [
-            >r sql-spec-slot-name r> set-slot-named
+            >r slot-name>> r> set-slot-named
         ] curry 2each
     ] keep ;
 
 : query-tuples ( statement -- seq )
-    [ statement-out-params ] keep query-results [
+    [ out-params>> ] keep query-results [
         [ sql-row-typed swap resulting-tuple ] with query-map
     ] with-disposal ;
  
 : query-modify-tuple ( tuple statement -- )
     [ query-results [ sql-row-typed ] with-disposal ] keep
-    statement-out-params rot [
-        >r sql-spec-slot-name r> set-slot-named
+    out-params>> rot [
+        >r slot-name>> r> set-slot-named
     ] curry 2each ;
 
 : sql-props ( class -- columns table )

diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index a31713fa35c0de8fb0c4e949dfbe7dc9d64a43b1..110a8a388aa525ebecd81bbb877875c3d43b6e38 100755 (executable)
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -10,15 +10,17 @@ IN: db.types
 HOOK: persistent-table db ( -- hash )
 HOOK: compound db ( str obj -- hash )
 
-HOOK: random-id-quot db ( -- quot )
-
 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 ;
+TUPLE: generator-bind key singleton type ;
 C: <generator-bind> generator-bind
+SINGLETON: random-id-generator
+
+TUPLE: low-level-binding value ;
+C: <low-level-binding> low-level-binding
 
 SINGLETON: +native-id+
 SINGLETON: +assigned-id+