diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 3fc95fcafe..d270e6f40d 100755 --- 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 057c5f5168..687146af11 100755 --- 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 ; -M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- array ) - nip value>> ; +M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj ) + nip value>> ; -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 ; M: postgresql-statement bind-tuple ( tuple statement -- ) tuck in-params>> @@ -201,7 +201,16 @@ M: postgresql-db ( class -- statement ) ")" 0% " values(" 0% - [ ", " 0% ] [ bind% ] interleave + [ ", " 0% ] [ + dup type>> +random-id+ = [ + [ + drop bind-name% + f random-id-generator + ] [ type>> ] bi 1, + ] [ + bind% + ] if + ] interleave ");" 0% ] query-make ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index f3e6d59edd..e902869d3b 100644 --- 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 ( 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 f4247cf6d8..2175b69f35 100755 --- 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 ; +: ( 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 ; M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) - nip [ key>> ] [ value>> ] [ type>> ] tri 3array ; + nip [ key>> ] [ value>> ] [ type>> ] tri + ; M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) - nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ; + nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri + ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ @@ -129,14 +138,10 @@ M: sqlite-db ( 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 1, + column-name>> ":" prepend dup 0% + random-id-generator + ] [ type>> ] bi 1, ] [ bind% ] if diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 0c52828b2a..1c900edc68 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -342,14 +342,14 @@ C: 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 1b1e48ddee..d91e9b2758 100755 --- 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 a31713fa35..110a8a388a 100755 --- 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 -TUPLE: generator-bind key quot type ; +TUPLE: generator-bind key singleton type ; C: generator-bind +SINGLETON: random-id-generator + +TUPLE: low-level-binding value ; +C: low-level-binding SINGLETON: +native-id+ SINGLETON: +assigned-id+