1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs classes db kernel namespaces
4 classes.tuple words sequences slots math accessors
5 math.parser io prettyprint continuations
6 destructors mirrors sets db.types db.private fry
7 combinators.short-circuit db.errors ;
10 HOOK: create-sql-statement db-connection ( class -- object )
11 HOOK: drop-sql-statement db-connection ( class -- object )
13 HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
14 HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
15 HOOK: <update-tuple-statement> db-connection ( class -- object )
16 HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
17 HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
18 HOOK: <count-statement> db-connection ( query -- statement )
19 HOOK: query>statement db-connection ( query -- statement )
20 HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
26 : next-sql-counter ( -- str )
27 sql-counter [ inc ] [ get ] bi number>string ;
29 GENERIC: eval-generator ( singleton -- object )
31 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
33 '[ slot-name>> _ set-slot-named ] 2each
36 : query-tuples ( exemplar-tuple statement -- seq )
37 [ out-params>> ] keep query-results [
38 [ sql-row-typed swap resulting-tuple ] 2with query-map
41 : query-modify-tuple ( tuple statement -- )
42 [ query-results [ sql-row-typed ] with-disposal ] keep
44 [ slot-name>> ] dip set-slot-named
47 : with-disposals ( object quotation -- )
49 [ with-disposal ] curry each
54 : insert-db-assigned-statement ( tuple -- )
56 db-connection get insert-statements>>
57 [ <insert-db-assigned-statement> ] cache
58 [ bind-tuple ] 2keep insert-tuple-set-key ;
60 : insert-user-assigned-statement ( tuple -- )
62 db-connection get insert-statements>>
63 [ <insert-user-assigned-statement> ] cache
64 [ bind-tuple ] keep execute-statement ;
66 : do-select ( exemplar-tuple statement -- tuples )
67 [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
69 : do-count ( exemplar-tuple statement -- tuples )
70 [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
75 ERROR: no-slots-named class seq ;
76 : check-columns ( class columns -- )
79 [ all-slots [ name>> ] map ] bi* diff
81 [ drop ] [ throw-no-slots-named ] if-empty ;
83 : define-persistent ( class table columns -- )
86 [ dupd "db-table" set-word-prop dup ] dip
87 [ relation? ] partition swapd
88 dupd [ spec>tuple ] with map
89 "db-columns" set-word-prop
90 "db-relations" set-word-prop ;
92 TUPLE: query tuple group order offset limit ;
94 : <query> ( -- query ) \ query new ;
96 GENERIC: >query ( object -- query )
98 M: query >query clone ;
100 M: tuple >query <query> swap >>tuple ;
102 ERROR: no-defined-persistent object ;
104 : ensure-defined-persistent ( object -- object )
105 dup { [ class? ] [ "db-table" word-prop ] } 1&& [
106 throw-no-defined-persistent
109 : create-table ( class -- )
110 ensure-defined-persistent
111 create-sql-statement [ execute-statement ] with-disposals ;
113 : drop-table ( class -- )
114 ensure-defined-persistent
115 drop-sql-statement [ execute-statement ] with-disposals ;
117 : recreate-table ( class -- )
118 ensure-defined-persistent
122 _ drop-sql-statement [ execute-statement ] with-disposals
123 ] ignore-table-missing
124 ] ignore-function-missing
125 ] [ create-table ] bi ;
127 : ensure-table ( class -- )
128 ensure-defined-persistent
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
159 [ first first string>number ] [ [ first string>number ] map ] if ;