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 classes words shuffle arrays
6 destructors continuations db.tuples.private prettyprint
7 db.private byte-arrays ;
10 GENERIC: where ( specs obj -- )
13 : make-retryable ( obj -- obj' )
15 [ make-retryable ] map
21 : maybe-make-retryable ( statement -- statement )
22 dup in-params>> [ generator-bind? ] any?
23 [ make-retryable ] when ;
25 : regenerate-params ( statement -- statement )
27 [ bind-params>> ] [ in-params>> ] bi
30 generator-singleton>> eval-generator >>value
34 ] 2map >>bind-params ;
36 M: retryable execute-statement* ( statement type -- )
40 [ query-results dispose t ]
42 [ regenerate-params bind-statement* f ] cleanup
44 ] bi attempt-all drop ;
46 : sql-props ( class -- columns table )
47 [ db-columns ] [ db-table-name ] bi ;
49 : query-make ( class quot -- statements )
50 #! query, input, outputs, secondary queries
51 over db-table-name "table-name" set
53 [ 0 sql-counter rot with-variable ] curry
54 { "" { } { } { } } nmake
55 [ <simple-statement> maybe-make-retryable ] dip
56 [ [ 1array ] dip append ] unless-empty ; inline
58 : where-primary-key% ( specs -- )
63 dup column-name>> 0% " = " 0% bind%
66 M: db-connection <update-tuple-statement> ( class -- statement )
71 [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
75 M: random-id-generator eval-generator ( singleton -- obj )
77 system-random-generator get [
78 63 [ random-bits ] keep 1- set-bit
81 : interval-comparison ( ? str -- str )
82 "from" = " >" " <" ? swap [ "= " append ] when ;
84 : (infinite-interval?) ( interval -- ?1 ?2 )
85 [ from>> ] [ to>> ] bi
86 [ first fp-infinity? ] bi@ ;
88 : double-infinite-interval? ( obj -- ? )
89 dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
91 : infinite-interval? ( obj -- ? )
92 dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
94 : where-interval ( spec obj from/to -- )
95 over first fp-infinity? [
99 [ first2 ] dip interval-comparison 0%
103 : in-parens ( quot -- )
104 "(" 0% call ")" 0% ; inline
106 M: interval where ( spec obj -- )
108 [ from>> "from" where-interval ] [
109 nip infinite-interval? [ " and " 0% ] unless
110 ] [ to>> "to" where-interval ] 2tri
113 M: sequence where ( spec obj -- )
115 [ " or " 0% ] [ dupd where ] interleave drop
118 M: byte-array where ( spec obj -- )
119 over column-name>> 0% " = " 0% bind# ;
121 M: NULL where ( spec obj -- )
122 drop column-name>> 0% " is NULL" 0% ;
124 : object-where ( spec obj -- )
125 over column-name>> 0% " = " 0% bind# ;
127 M: object where ( spec obj -- ) object-where ;
129 M: integer where ( spec obj -- ) object-where ;
131 M: string where ( spec obj -- ) object-where ;
133 : filter-slots ( tuple specs -- specs' )
135 slot-name>> swap get-slot-named
136 dup double-infinite-interval? [ drop f ] when
139 : many-where ( tuple seq -- )
143 2dup slot-name>> swap get-slot-named where
146 : where-clause ( tuple specs -- )
147 dupd filter-slots [ drop ] [ many-where ] if-empty ;
149 M: db-connection <delete-tuples-statement> ( tuple table -- sql )
155 ERROR: all-slots-ignored class ;
157 M: db-connection <select-by-slots-statement> ( tuple class -- statement )
160 [ dupd filter-ignores ] dip
161 over empty? [ all-slots-ignored ] when
164 [ dup column-name>> 0% 2, ] interleave
169 : do-group ( tuple groups -- )
170 dup string? [ 1array ] when
171 [ ", " join " group by " glue ] curry change-sql drop ;
173 : do-order ( tuple order -- )
174 dup string? [ 1array ] when
175 [ ", " join " order by " glue ] curry change-sql drop ;
177 : do-offset ( tuple n -- )
178 [ number>string " offset " glue ] curry change-sql drop ;
180 : do-limit ( tuple n -- )
181 [ number>string " limit " glue ] curry change-sql drop ;
183 : make-query* ( tuple query -- tuple' )
186 [ group>> [ drop ] [ do-group ] if-empty ]
187 [ order>> [ drop ] [ do-order ] if-empty ]
188 [ limit>> [ do-limit ] [ drop ] if* ]
189 [ offset>> [ do-offset ] [ drop ] if* ]
192 M: db-connection query>statement ( query -- tuple )
193 [ tuple>> dup class ] keep
194 [ <select-by-slots-statement> ] dip make-query* ;
196 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
198 M: db-connection <count-statement> ( query -- statement )
199 [ tuple>> dup class ] keep
200 [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
203 : create-index ( index-name table-name columns -- )
205 [ [ "create index " % % ] dip " on " % % ] dip "(" %
207 ] "" make sql-command ;
209 : drop-index ( index-name -- )
210 [ "drop index " % % ] "" make sql-command ;