1 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien arrays assocs classes compiler db hashtables
4 io.files kernel math math.parser namespaces prettyprint
5 sequences strings classes.tuple alien.c-types continuations
6 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
7 math.intervals io nmake accessors vectors math.ranges random
8 math.bitwise db.queries destructors db.tuples.private interpolate
9 io.streams.string multiline make ;
12 TUPLE: sqlite-db < db path ;
14 M: sqlite-db make-db* ( path db -- db )
17 M: sqlite-db db-open ( db -- db )
18 dup path>> sqlite-open >>handle ;
20 M: sqlite-db db-close ( handle -- ) sqlite-close ;
21 M: sqlite-db dispose ( db -- ) db-dispose ;
23 TUPLE: sqlite-statement < statement ;
25 TUPLE: sqlite-result-set < result-set has-more? ;
27 M: sqlite-db <simple-statement> ( str in out -- obj )
28 <prepared-statement> ;
30 M: sqlite-db <prepared-statement> ( str in out -- obj )
31 sqlite-statement new-statement ;
33 : sqlite-maybe-prepare ( statement -- statement )
35 db get handle>> over sql>> sqlite-prepare
39 M: sqlite-statement dispose ( statement -- )
41 [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
43 M: sqlite-result-set dispose ( result-set -- )
46 : reset-bindings ( statement -- )
48 handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
50 M: sqlite-statement low-level-bind ( statement -- )
51 [ bind-params>> ] [ handle>> ] bi
52 [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
54 M: sqlite-statement bind-statement* ( statement -- )
56 dup bound?>> [ dup reset-bindings ] when
59 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
61 TUPLE: sqlite-low-level-binding < low-level-binding key type ;
62 : <sqlite-low-level-binding> ( key value type -- obj )
63 sqlite-low-level-binding new
68 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
69 [ column-name>> ":" prepend ]
70 [ slot-name>> rot get-slot-named ]
71 [ type>> ] tri <sqlite-low-level-binding> ;
73 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
74 nip [ key>> ] [ value>> ] [ type>> ] tri
75 <sqlite-low-level-binding> ;
77 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
79 [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
81 >r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
83 M: sqlite-statement bind-tuple ( tuple statement -- )
85 in-params>> [ sqlite-bind-conversion ] with map
86 ] keep bind-statement ;
88 : last-insert-id ( -- id )
89 db get handle>> sqlite3_last_insert_rowid
90 dup zero? [ "last-id failed" throw ] when ;
92 M: sqlite-db insert-tuple-set-key ( tuple statement -- )
93 execute-statement last-insert-id swap set-primary-key ;
95 M: sqlite-result-set #columns ( result-set -- n )
96 handle>> sqlite-#columns ;
98 M: sqlite-result-set row-column ( result-set n -- obj )
99 [ handle>> ] [ sqlite-column ] bi* ;
101 M: sqlite-result-set row-column-typed ( result-set n -- obj )
102 dup pick out-params>> nth type>>
103 >r >r handle>> r> r> sqlite-column-typed ;
105 M: sqlite-result-set advance-row ( result-set -- )
106 dup handle>> sqlite-next >>has-more? drop ;
108 M: sqlite-result-set more-rows? ( result-set -- ? )
111 M: sqlite-statement query-results ( query -- result-set )
113 dup handle>> sqlite-result-set new-result-set
116 M: sqlite-db create-sql-statement ( class -- statement )
119 "create table " 0% 0%
122 dup column-name>> [ "table-id" set ] [ 0% ] bi
124 dup type>> lookup-create-type 0%
131 [ "," 0% ] [ column-name>> 0% ] interleave
135 M: sqlite-db drop-sql-statement ( class -- statement )
136 [ "drop table " 0% 0% ";" 0% drop ] query-make ;
138 M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
142 remove-db-assigned-id
143 dup [ ", " 0% ] [ column-name>> 0% ] interleave
146 dup type>> +random-id+ = [
149 column-name>> ":" prepend dup 0%
151 ] [ type>> ] tri <generator-bind> 1,
159 M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
160 <insert-db-assigned-statement> ;
162 M: sqlite-db bind# ( spec obj -- )
164 [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
166 r> <literal-bind> 1, ;
168 M: sqlite-db bind% ( spec -- )
169 dup 1, column-name>> ":" prepend 0% ;
171 M: sqlite-db persistent-table ( -- assoc )
173 { +db-assigned-id+ { "integer" "integer" f } }
174 { +user-assigned-id+ { f f f } }
175 { +random-id+ { "integer" "integer" f } }
176 { +foreign-id+ { "integer" "integer" "references" } }
178 { +on-delete+ { f f "on delete" } }
179 { +restrict+ { f f "restrict" } }
180 { +cascade+ { f f "cascade" } }
181 { +set-null+ { f f "set null" } }
182 { +set-default+ { f f "set default" } }
184 { INTEGER { "integer" "integer" f } }
185 { BIG-INTEGER { "bigint" "bigint" f } }
186 { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
187 { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
188 { TEXT { "text" "text" f } }
189 { VARCHAR { "text" "text" f } }
190 { DATE { "date" "date" f } }
191 { TIME { "time" "time" f } }
192 { DATETIME { "datetime" "datetime" f } }
193 { TIMESTAMP { "timestamp" "timestamp" f } }
194 { DOUBLE { "real" "real" f } }
195 { BLOB { "blob" "blob" f } }
196 { FACTOR-BLOB { "blob" "blob" f } }
197 { URL { "text" "text" f } }
198 { +autoincrement+ { f f "autoincrement" } }
199 { +unique+ { f f "unique" } }
200 { +default+ { f f "default" } }
201 { +null+ { f f "null" } }
202 { +not-null+ { f f "not null" } }
203 { system-random-generator { f f f } }
204 { secure-random-generator { f f f } }
205 { random-generator { f f f } }
208 : insert-trigger ( -- string )
211 CREATE TRIGGER fki_${table}_${foreign-table}_id
212 BEFORE INSERT ON ${table}
214 SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
215 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
218 ] with-string-writer ;
220 : insert-trigger-not-null ( -- string )
223 CREATE TRIGGER fki_${table}_${foreign-table}_id
224 BEFORE INSERT ON ${table}
226 SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
227 WHERE NEW.${foreign-table-id} IS NOT NULL
228 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
231 ] with-string-writer ;
233 : update-trigger ( -- string )
236 CREATE TRIGGER fku_${table}_${foreign-table}_id
237 BEFORE UPDATE ON ${table}
239 SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
240 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
243 ] with-string-writer ;
245 : update-trigger-not-null ( -- string )
248 CREATE TRIGGER fku_${table}_${foreign-table}_id
249 BEFORE UPDATE ON ${table}
251 SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
252 WHERE NEW.${foreign-table-id} IS NOT NULL
253 AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
256 ] with-string-writer ;
258 : delete-trigger-restrict ( -- string )
261 CREATE TRIGGER fkd_${table}_${foreign-table}_id
262 BEFORE DELETE ON ${foreign-table}
264 SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
265 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
268 ] with-string-writer ;
270 : delete-trigger-cascade ( -- string )
273 CREATE TRIGGER fkd_${table}_${foreign-table}_id
274 BEFORE DELETE ON ${foreign-table}
276 DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
279 ] with-string-writer ;
281 : can-be-null? ( -- ? )
282 "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
284 : delete-cascade? ( -- ? )
285 "sql-spec" get modifiers>> [ +cascade+ = ] contains? ;
287 : sqlite-trigger, ( string -- )
288 { } { } <simple-statement> 3, ;
290 : create-sqlite-triggers ( -- )
292 insert-trigger sqlite-trigger,
293 update-trigger sqlite-trigger,
295 insert-trigger-not-null sqlite-trigger,
296 update-trigger-not-null sqlite-trigger,
299 delete-trigger-cascade sqlite-trigger,
301 delete-trigger-restrict sqlite-trigger,
304 M: sqlite-db compound ( string seq -- new-string )
306 { "default" [ first number>string join-space ] }
308 [ >reference-string ] keep
309 first2 [ "foreign-table" set ]
310 [ "foreign-table-id" set ] bi*
311 create-sqlite-triggers