1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel math namespaces make sequences random
4 strings math.parser math.intervals combinators math.bitwise
5 nmake db db.tuples db.types db.sql classes words shuffle arrays
6 destructors continuations ;
9 GENERIC: where ( specs obj -- )
12 : make-retryable ( obj -- obj' )
14 [ make-retryable ] map
20 : maybe-make-retryable ( statement -- statement )
21 dup in-params>> [ generator-bind? ] contains?
22 [ make-retryable ] when ;
24 : regenerate-params ( statement -- statement )
26 [ bind-params>> ] [ in-params>> ] bi
29 generator-singleton>> eval-generator >>value
33 ] 2map >>bind-params ;
35 M: retryable execute-statement* ( statement type -- )
39 [ query-results dispose t ]
41 [ regenerate-params bind-statement* f ] cleanup
43 ] bi attempt-all drop ;
45 : sql-props ( class -- columns table )
46 [ db-columns ] [ db-table ] bi ;
48 : query-make ( class quot -- )
50 [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
51 <simple-statement> maybe-make-retryable ; inline
53 : where-primary-key% ( specs -- )
55 find-primary-key dup column-name>> 0% " = " 0% bind% ;
57 M: db <update-tuple-statement> ( class -- statement )
62 [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
66 M: random-id-generator eval-generator ( singleton -- obj )
68 system-random-generator get [
69 63 [ random-bits ] keep 1- set-bit
72 : interval-comparison ( ? str -- str )
73 "from" = " >" " <" ? swap [ "= " append ] when ;
75 : (infinite-interval?) ( interval -- ?1 ?2 )
76 [ from>> ] [ to>> ] bi
77 [ first fp-infinity? ] bi@ ;
79 : double-infinite-interval? ( obj -- ? )
80 dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
82 : infinite-interval? ( obj -- ? )
83 dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
85 : where-interval ( spec obj from/to -- )
86 over first fp-infinity? [
90 >r first2 r> interval-comparison 0%
94 : in-parens ( quot -- )
95 "(" 0% call ")" 0% ; inline
97 M: interval where ( spec obj -- )
99 [ from>> "from" where-interval ] [
100 nip infinite-interval? [ " and " 0% ] unless
101 ] [ to>> "to" where-interval ] 2tri
104 M: sequence where ( spec obj -- )
106 [ " or " 0% ] [ dupd where ] interleave drop
109 : object-where ( spec obj -- )
110 over column-name>> 0% " = " 0% bind# ;
112 M: object where ( spec obj -- ) object-where ;
114 M: integer where ( spec obj -- ) object-where ;
116 M: string where ( spec obj -- ) object-where ;
118 : filter-slots ( tuple specs -- specs' )
120 slot-name>> swap get-slot-named
121 dup double-infinite-interval? [ drop f ] when
124 : where-clause ( tuple specs -- )
131 2dup slot-name>> swap get-slot-named where
135 M: db <delete-tuples-statement> ( tuple table -- sql )
141 M: db <select-by-slots-statement> ( tuple class -- statement )
145 [ dup column-name>> 0% 2, ] interleave
151 : do-group ( tuple groups -- )
153 ", " join " group by " swap 3append
154 ] curry change-sql drop ;
156 : do-order ( tuple order -- )
158 ", " join " order by " swap 3append
159 ] curry change-sql drop ;
161 : do-offset ( tuple n -- )
163 number>string " offset " swap 3append
164 ] curry change-sql drop ;
166 : do-limit ( tuple n -- )
168 number>string " limit " swap 3append
169 ] curry change-sql drop ;
171 : make-query ( tuple query -- tuple' )
174 [ group>> [ drop ] [ do-group ] if-empty ]
175 [ order>> [ drop ] [ do-order ] if-empty ]
176 [ limit>> [ do-limit ] [ drop ] if* ]
177 [ offset>> [ do-offset ] [ drop ] if* ]
180 M: db <query> ( tuple class query -- tuple )
181 [ <select-by-slots-statement> ] dip make-query ;
183 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
185 : select-tuples* ( tuple -- statement )
189 dup class db-columns [ ", " 0, ]
190 [ dup column-name>> 0, 2, ] interleave
193 ] { { } { } { } } nmake
194 >r >r parse-sql 4drop r> r>
195 <simple-statement> maybe-make-retryable do-select ;
197 M: db <count-statement> ( tuple class groups -- statement )
200 [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
203 : create-index ( index-name table-name columns -- )
205 >r >r "create index " % % r> " on " % % r> "(" %
207 ] "" make sql-command ;
209 : drop-index ( index-name -- )
210 [ "drop index " % % ] "" make sql-command ;