From afaab57f8356b77e7dd9547ecf46bd6e8f8ac638 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 18 Apr 2008 12:43:21 -0500 Subject: [PATCH] interval, range queries in sqlite --- extra/db/sqlite/sqlite.factor | 62 +++++++++++++++++------------ extra/db/tuples/tuples-tests.factor | 28 +++++++++++-- extra/db/tuples/tuples.factor | 3 ++ extra/db/types/types.factor | 4 +- 4 files changed, 67 insertions(+), 30 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 02bf314a0a..de5c245517 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ 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 ; +io namespaces.lib accessors vectors math.ranges ; USE: tools.walker IN: db.sqlite @@ -104,7 +104,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> - { "" { } { } } nmake ; inline + [ 0 sql-counter rot with-variable ] { "" { } { } } nmake + ; inline M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -134,6 +135,12 @@ M: sqlite-db ( tuple -- statement ) M: sqlite-db ( tuple -- statement ) ; +M: sqlite-db bind# ( spec obj -- ) + >r + [ column-name>> ":" swap next-sql-counter 3append dup 0% ] + [ type>> ] bi + r> 1, ; + M: sqlite-db bind% ( spec -- ) dup 1, column-name>> ":" prepend 0% ; @@ -141,38 +148,44 @@ M: sqlite-db bind% ( spec -- ) " where " 0% find-primary-key dup column-name>> 0% " = " 0% bind% ; -! : where-object ( tuple specs -- ) - ! [ dup column-name>> get-slot-named ] keep - ! dup column-name>> 0% " = " 0% bind% ; - -GENERIC: where-object ( specs obj -- ) +GENERIC: where ( specs obj -- ) : interval-comparison ( ? str -- str ) "from" = " >" " <" ? swap [ "= " append ] when ; -: where-interval ( spec val ? from/to -- ) - roll [ - column-name>> - [ 0% interval-comparison 0% ] - [ ":" spin 3append dup 0% ] 2bi - swap - ] [ - type>> - ] bi literal-bind boa 1, ; +: where-interval ( spec obj from/to -- ) + pick column-name>> 0% + >r first2 r> interval-comparison 0% + bind# ; -M: interval where-object ( specs obj -- ) - [ from>> first2 "from" where-interval " and " 0% ] - [ to>> first2 "to" where-interval ] 2bi ; +: in-parens ( quot -- ) + "(" 0% call ")" 0% ; inline -M: object where-object ( specs obj -- ) - drop - dup column-name>> 0% " = " 0% bind% ; +M: interval where ( spec obj -- ) + [ + [ from>> "from" where-interval " and " 0% ] + [ to>> "to" where-interval ] 2bi + ] in-parens ; + +M: sequence where ( spec obj -- ) + [ + [ " or " 0% ] [ dupd where ] interleave drop + ] in-parens ; + +: object-where ( spec obj -- ) + over column-name>> 0% " = " 0% bind# ; + +M: object where ( spec obj -- ) object-where ; + +M: integer where ( spec obj -- ) object-where ; + +M: string where ( spec obj -- ) object-where ; : where-clause ( tuple specs -- ) " where " 0% [ " and " 0% ] [ - 2dup slot-name>> swap get-slot-named where-object + 2dup slot-name>> swap get-slot-named where ] interleave drop ; M: sqlite-db ( class -- statement ) @@ -193,9 +206,6 @@ M: sqlite-db ( specs table -- sql ) dup column-name>> 0% " = " 0% bind% ] sqlite-make ; -! : select-interval ( interval name -- ) ; -! : select-sequence ( seq name -- ) ; - M: sqlite-db ( tuple class -- statement ) [ "select " 0% diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 36a8d4cd3f..691cc6f687 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples -db.types continuations namespaces math +db.types continuations namespaces math math.ranges prettyprint tools.walker db.sqlite calendar math.intervals db.postgresql ; IN: db.tuples.tests @@ -217,7 +217,7 @@ TUPLE: serialize-me id data ; TUPLE: exam id name score ; -: test-ranges ( -- ) +: test-intervals ( -- ) exam "EXAM" { { "id" "ID" +native-id+ } @@ -267,9 +267,31 @@ TUPLE: exam id name score ; } ] [ T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + } + ] [ + T{ exam f f { "Stan" "Kyle" } } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + T{ exam f 3 "Kenny" 60 } + } + ] [ + T{ exam f T{ range f 1 3 1 } } select-tuples ] unit-test ; -[ test-ranges ] test-sqlite +[ test-intervals ] test-sqlite + +: test-ranges + ; TUPLE: secret n message ; C: secret diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 311f18daa9..32431b4ddc 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -22,6 +22,9 @@ IN: db.tuples class db-columns find-primary-key sql-spec-slot-name ] keep set-slot-named ; +SYMBOL: sql-counter +: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ; + ! returns a sequence of prepared-statements HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index bea81f422b..9959e894a7 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -15,7 +15,8 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; -TUPLE: literal-bind key value type ; +TUPLE: literal-bind key type value ; +C: literal-bind SINGLETON: +native-id+ SINGLETON: +assigned-id+ @@ -132,6 +133,7 @@ TUPLE: no-sql-modifier ; dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) +HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) class "slots" word-prop slot-named slot-spec-offset ;