1 ! Copyright (C) 2008 Doug Coleman.
2 ! Copyright (C) 2018 Alexander Ilin.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays assocs classes db kernel namespaces
5 classes.tuple words sequences slots math accessors
6 math.parser io prettyprint continuations
7 destructors mirrors sets db.types db.private fry
8 combinators.short-circuit db.errors ;
11 HOOK: create-sql-statement db-connection ( class -- object )
12 HOOK: drop-sql-statement db-connection ( class -- object )
14 HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
15 HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
16 HOOK: <update-tuple-statement> db-connection ( class -- object )
17 HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
18 HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
19 HOOK: <count-statement> db-connection ( query -- statement )
20 HOOK: query>statement db-connection ( query -- statement )
21 HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
27 : next-sql-counter ( -- str )
28 sql-counter [ inc ] [ get ] bi number>string ;
30 GENERIC: eval-generator ( singleton -- object )
32 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
34 '[ slot-name>> _ set-slot-named ] 2each
37 : query-tuples-each ( exemplar-tuple statement quot: ( tuple -- ) -- )
38 [ [ out-params>> ] keep query-results ] dip '[
39 [ sql-row-typed swap resulting-tuple @ ] 2with query-each
40 ] with-disposal ; inline
42 : query-tuples ( exemplar-tuple statement -- seq )
43 [ ] collector [ query-tuples-each ] dip { } like ;
45 : query-modify-tuple ( tuple statement -- )
46 [ query-results [ sql-row-typed ] with-disposal ] keep
47 out-params>> rot '[ slot-name>> _ set-slot-named ] 2each ;
49 : with-disposals ( object quotation -- )
51 over '[ _ dispose-each ] finally
56 : insert-db-assigned-statement ( tuple -- )
58 db-connection get insert-statements>>
59 [ <insert-db-assigned-statement> ] cache
60 [ bind-tuple ] 2keep insert-tuple-set-key ;
62 : insert-user-assigned-statement ( tuple -- )
64 db-connection get insert-statements>>
65 [ <insert-user-assigned-statement> ] cache
66 [ bind-tuple ] keep execute-statement ;
68 : do-each-tuple ( exemplar-tuple statement quot: ( tuple -- ) -- tuples )
69 '[ [ bind-tuple ] [ _ query-tuples-each ] 2bi ] with-disposal
72 : do-select ( exemplar-tuple statement -- tuples )
73 [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
75 : do-count ( exemplar-tuple statement -- tuples )
76 [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
81 ERROR: no-slots-named class seq ;
83 : check-columns ( columns class -- )
86 [ all-slots [ name>> ] map ] bi* diff
88 [ drop ] [ no-slots-named ] if-empty ;
90 : define-persistent ( class table columns -- )
93 [ dupd "db-table" set-word-prop dup ] dip
94 [ relation? ] partition swapd
95 dupd [ spec>tuple ] with map
96 "db-columns" set-word-prop
97 "db-relations" set-word-prop ;
99 TUPLE: query tuple group order offset limit ;
101 : <query> ( -- query ) \ query new ;
103 GENERIC: >query ( object -- query )
105 M: query >query clone ;
107 M: tuple >query <query> swap >>tuple ;
109 ERROR: no-defined-persistent object ;
111 : ensure-defined-persistent ( object -- object )
112 dup { [ class? ] [ "db-table" word-prop ] } 1&& [
113 no-defined-persistent
116 : create-table ( class -- )
117 ensure-defined-persistent
118 create-sql-statement [ execute-statement ] with-disposals ;
120 : drop-table ( class -- )
121 ensure-defined-persistent
122 drop-sql-statement [ execute-statement ] with-disposals ;
124 : recreate-table ( class -- )
125 [ '[ [ _ drop-table ] ignore-table-missing ] ignore-function-missing ]
126 [ create-table ] bi ;
128 : ensure-table ( class -- )
129 '[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
131 : ensure-tables ( classes -- ) [ ensure-table ] each ;
133 : insert-tuple ( tuple -- )
134 dup class-of ensure-defined-persistent db-assigned?
135 [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
137 : update-tuple ( tuple -- )
138 dup class-of ensure-defined-persistent
139 db-connection get update-statements>> [ <update-tuple-statement> ] cache
140 [ bind-tuple ] keep execute-statement ;
142 : delete-tuples ( tuple -- )
144 dup class-of ensure-defined-persistent
145 <delete-tuples-statement> [
146 [ bind-tuple ] keep execute-statement
149 : select-tuples ( query/tuple -- tuples )
150 >query [ tuple>> ] [ query>statement ] bi do-select ;
152 : select-tuple ( query/tuple -- tuple/f )
153 >query 1 >>limit [ tuple>> ] [ query>statement ] bi
156 : count-tuples ( query/tuple -- n )
157 >query [ tuple>> ] [ <count-statement> ] bi do-count
158 [ first string>number ] map dup length 1 = [ first ] when ;
160 : each-tuple ( query/tuple quot: ( tuple -- ) -- )
161 [ >query [ tuple>> ] [ query>statement ] bi ] dip do-each-tuple
164 : update-tuples ( query/tuple quot: ( tuple -- tuple'/f ) -- )
165 '[ @ [ update-tuple ] when* ] each-tuple ; inline
167 : reject-tuples ( query/tuple quot: ( tuple -- ? ) -- )
168 '[ dup @ [ delete-tuples ] [ drop ] if ] each-tuple ; inline