1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel math namespaces sequences random
4 strings math.parser math.intervals combinators
5 math.bitfields.lib namespaces.lib db db.tuples db.types
6 sequences.lib db.sql classes words shuffle arrays ;
9 GENERIC: where ( specs obj -- )
11 : maybe-make-retryable ( statement -- statement )
12 dup in-params>> [ generator-bind? ] contains?
13 [ make-retryable ] when ;
15 : query-make ( class quot -- )
17 [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
18 <simple-statement> maybe-make-retryable ; inline
20 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
21 M: db commit-transaction ( -- ) "COMMIT" sql-command ;
22 M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
24 : where-primary-key% ( specs -- )
26 find-primary-key dup column-name>> 0% " = " 0% bind% ;
28 M: db <update-tuple-statement> ( class -- statement )
33 [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
37 M: random-id-generator eval-generator ( singleton -- obj )
39 system-random-generator get [
40 63 [ 2^ random ] keep 1 - set-bit
43 : interval-comparison ( ? str -- str )
44 "from" = " >" " <" ? swap [ "= " append ] when ;
46 : fp-infinity? ( float -- ? )
48 double>bits -52 shift 11 2^ 1- [ bitand ] keep =
53 : (infinite-interval?) ( interval -- ?1 ?2 )
54 [ from>> ] [ to>> ] bi
55 [ first fp-infinity? ] bi@ ;
57 : double-infinite-interval? ( obj -- ? )
58 dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
60 : infinite-interval? ( obj -- ? )
61 dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
63 : where-interval ( spec obj from/to -- )
64 over first fp-infinity? [
68 >r first2 r> interval-comparison 0%
72 : in-parens ( quot -- )
73 "(" 0% call ")" 0% ; inline
75 M: interval where ( spec obj -- )
77 [ from>> "from" where-interval ] [
78 nip infinite-interval? [ " and " 0% ] unless
79 ] [ to>> "to" where-interval ] 2tri
82 M: sequence where ( spec obj -- )
84 [ " or " 0% ] [ dupd where ] interleave drop
87 : object-where ( spec obj -- )
88 over column-name>> 0% " = " 0% bind# ;
90 M: object where ( spec obj -- ) object-where ;
92 M: integer where ( spec obj -- ) object-where ;
94 M: string where ( spec obj -- ) object-where ;
96 : filter-slots ( tuple specs -- specs' )
98 slot-name>> swap get-slot-named
99 dup double-infinite-interval? [ drop f ] when
102 : where-clause ( tuple specs -- )
109 2dup slot-name>> swap get-slot-named where
113 M: db <delete-tuples-statement> ( tuple table -- sql )
119 M: db <select-by-slots-statement> ( tuple class -- statement )
123 [ dup column-name>> 0% 2, ] interleave
129 : do-group ( tuple groups -- )
131 ", " join " group by " prepend append
132 ] curry change-sql drop ;
134 : do-order ( tuple order -- )
136 ", " join " order by " prepend append
137 ] curry change-sql drop ;
139 : do-offset ( tuple n -- )
141 number>string " offset " prepend append
142 ] curry change-sql drop ;
144 : do-limit ( tuple n -- )
146 number>string " limit " prepend append
147 ] curry change-sql drop ;
149 : make-query ( tuple query -- tuple' )
152 [ group>> [ do-group ] [ drop ] if-seq ]
153 [ order>> [ do-order ] [ drop ] if-seq ]
154 [ limit>> [ do-limit ] [ drop ] if* ]
155 [ offset>> [ do-offset ] [ drop ] if* ]
158 M: db <query> ( tuple class query -- tuple )
159 [ <select-by-slots-statement> ] dip make-query ;
161 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
163 : select-tuples* ( tuple -- statement )
167 dup class db-columns [ ", " 0, ]
168 [ dup column-name>> 0, 2, ] interleave
171 ] { { } { } { } } nmake
172 >r >r parse-sql 4drop r> r>
173 <simple-statement> maybe-make-retryable do-select ;
175 M: db <count-statement> ( tuple class groups -- statement )
178 [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
181 : where-clause* ( tuple specs -- )
186 [ 2dup slot-name>> swap get-slot-named where ] map 2array 0,
190 : delete-tuple* ( tuple -- sql )
193 delete 0, from 0, dup class db-table 0,
194 dup class db-columns where-clause*
195 ] { { } { } { } } nmake
196 >r >r parse-sql 4drop r> r>
197 <simple-statement> maybe-make-retryable do-select ;
199 : create-index ( index-name table-name columns -- )
201 >r >r "create index " % % r> " on " % % r> "(" %
203 ] "" make sql-command ;
205 : drop-index ( index-name -- )
206 [ "drop index " % % ] "" make sql-command ;