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 db.types continuations
6 destructors mirrors sets db.types ;
9 HOOK: create-sql-statement db ( class -- object )
10 HOOK: drop-sql-statement db ( class -- object )
12 HOOK: <insert-db-assigned-statement> db ( class -- object )
13 HOOK: <insert-user-assigned-statement> db ( class -- object )
14 HOOK: <update-tuple-statement> db ( class -- object )
15 HOOK: <delete-tuples-statement> db ( tuple class -- object )
16 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
17 HOOK: <count-statement> db ( query -- statement )
18 HOOK: query>statement db ( query -- statement )
19 HOOK: insert-tuple-set-key db ( tuple statement -- )
25 : next-sql-counter ( -- str )
26 sql-counter [ inc ] [ get ] bi number>string ;
28 GENERIC: eval-generator ( singleton -- object )
30 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
32 [ [ slot-name>> ] dip set-slot-named ] curry 2each
35 : query-tuples ( exemplar-tuple statement -- seq )
36 [ out-params>> ] keep query-results [
37 [ sql-row-typed swap resulting-tuple ] with with query-map
40 : query-modify-tuple ( tuple statement -- )
41 [ query-results [ sql-row-typed ] with-disposal ] keep
43 [ slot-name>> ] dip set-slot-named
46 : with-disposals ( object quotation -- )
48 [ with-disposal ] curry each
53 : insert-db-assigned-statement ( tuple -- )
55 db get insert-statements>> [ <insert-db-assigned-statement> ] cache
56 [ bind-tuple ] 2keep insert-tuple-set-key ;
58 : insert-user-assigned-statement ( tuple -- )
60 db get insert-statements>> [ <insert-user-assigned-statement> ] cache
61 [ bind-tuple ] keep execute-statement ;
63 : do-select ( exemplar-tuple statement -- tuples )
64 [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
66 : do-count ( exemplar-tuple statement -- tuples )
67 [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
72 ERROR: no-slots-named class seq ;
73 : check-columns ( class columns -- )
76 [ all-slots [ name>> ] map ] bi* diff
77 [ drop ] [ no-slots-named ] if-empty ;
79 : define-persistent ( class table columns -- )
82 [ dupd "db-table" set-word-prop dup ] dip
83 [ relation? ] partition swapd
84 dupd [ spec>tuple ] with map
85 "db-columns" set-word-prop
86 "db-relations" set-word-prop ;
88 TUPLE: query tuple group order offset limit ;
90 : <query> ( -- query ) \ query new ;
92 GENERIC: >query ( object -- query )
94 M: query >query clone ;
96 M: tuple >query <query> swap >>tuple ;
98 : create-table ( class -- )
99 create-sql-statement [ execute-statement ] with-disposals ;
101 : drop-table ( class -- )
102 drop-sql-statement [ execute-statement ] with-disposals ;
104 : recreate-table ( class -- )
106 [ drop-sql-statement [ execute-statement ] with-disposals
107 ] curry ignore-errors
108 ] [ create-table ] bi ;
110 : ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
112 : ensure-tables ( classes -- ) [ ensure-table ] each ;
114 : insert-tuple ( tuple -- )
115 dup class db-columns find-primary-key db-assigned-id-spec?
116 [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
118 : update-tuple ( tuple -- )
120 db get update-statements>> [ <update-tuple-statement> ] cache
121 [ bind-tuple ] keep execute-statement ;
123 : delete-tuples ( tuple -- )
124 dup dup class <delete-tuples-statement> [
125 [ bind-tuple ] keep execute-statement
128 : select-tuples ( query/tuple -- tuples )
129 >query [ tuple>> ] [ query>statement ] bi do-select ;
131 : select-tuple ( query/tuple -- tuple/f )
132 >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
133 [ f ] [ first ] if-empty ;
135 : count-tuples ( query/tuple -- n )
136 >query [ tuple>> ] [ <count-statement> ] bi do-count
138 [ first first string>number ] [ [ first string>number ] map ] if ;