1 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors classes.tuple combinators db db.private db.queries
4 db.sqlite.errors db.sqlite.ffi db.sqlite.lib db.tuples
5 db.tuples.private db.types destructors interpolate kernel math
6 math.parser namespaces nmake random sequences sequences.deep ;
9 TUPLE: sqlite-db path ;
11 : <sqlite-db> ( path -- sqlite-db )
17 TUPLE: sqlite-db-connection < db-connection ;
19 : <sqlite-db-connection> ( handle -- db-connection )
20 sqlite-db-connection new-db-connection
26 path>> sqlite-open <sqlite-db-connection> ;
28 M: sqlite-db-connection db-close sqlite-close ;
30 TUPLE: sqlite-statement < statement ;
32 TUPLE: sqlite-result-set < result-set has-more? ;
34 M: sqlite-db-connection <simple-statement>
35 <prepared-statement> ;
37 M: sqlite-db-connection <prepared-statement>
38 sqlite-statement new-statement ;
40 : sqlite-maybe-prepare ( statement -- statement )
42 db-connection get handle>> over sql>> sqlite-prepare
46 M: sqlite-statement dispose
48 [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
50 M: sqlite-result-set dispose
53 : reset-bindings ( statement -- )
55 handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
57 M: sqlite-statement low-level-bind
58 [ handle>> ] [ bind-params>> ] bi
59 [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
61 M: sqlite-statement bind-statement*
63 dup bound?>> [ dup reset-bindings ] when
66 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
68 TUPLE: sqlite-low-level-binding < low-level-binding key type ;
69 : <sqlite-low-level-binding> ( key value type -- obj )
70 sqlite-low-level-binding new
75 M: sql-spec sqlite-bind-conversion
76 [ column-name>> ":" prepend ]
77 [ slot-name>> rot get-slot-named ]
78 [ type>> ] tri <sqlite-low-level-binding> ;
80 M: literal-bind sqlite-bind-conversion
81 nip [ key>> ] [ value>> ] [ type>> ] tri
82 <sqlite-low-level-binding> ;
84 M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
85 generate-bind generator-singleton>> eval-generator :> obj
86 generate-bind slot-name>> :> name
87 obj name tuple set-slot-named
88 generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
90 M: sqlite-statement bind-tuple
92 in-params>> [ sqlite-bind-conversion ] with map
93 ] keep bind-statement ;
95 ERROR: sqlite-last-id-fail ;
97 : last-insert-id ( -- id )
98 db-connection get handle>> sqlite3_last_insert_rowid
99 dup zero? [ sqlite-last-id-fail ] when ;
101 M: sqlite-db-connection insert-tuple-set-key
102 execute-statement last-insert-id swap set-primary-key ;
104 M: sqlite-result-set #columns
105 handle>> sqlite-#columns ;
107 M: sqlite-result-set row-column
108 [ handle>> ] [ sqlite-column ] bi* ;
110 M: sqlite-result-set row-column-typed
111 dup pick out-params>> nth type>>
112 [ handle>> ] 2dip sqlite-column-typed ;
114 M: sqlite-result-set advance-row
115 dup handle>> sqlite-next >>has-more? drop ;
117 M: sqlite-result-set more-rows?
120 M: sqlite-statement query-results
122 dup handle>> sqlite-result-set new-result-set
125 M: sqlite-db-connection <insert-db-assigned-statement>
129 remove-db-assigned-id
130 dup [ ", " 0% ] [ column-name>> 0% ] interleave
133 dup type>> +random-id+ = [
136 column-name>> ":" prepend dup 0%
138 ] [ type>> ] tri <generator-bind> 1,
146 M: sqlite-db-connection <insert-user-assigned-statement>
147 <insert-db-assigned-statement> ;
149 M: sqlite-db-connection bind#
151 [ column-name>> ":" next-sql-counter surround dup 0% ]
153 ] dip <literal-bind> 1, ;
155 M: sqlite-db-connection bind%
156 dup 1, column-name>> ":" prepend 0% ;
158 M: sqlite-db-connection persistent-table
160 { +db-assigned-id+ { "integer" "integer" f } }
161 { +user-assigned-id+ { f f f } }
162 { +random-id+ { "integer" "integer" f } }
163 { +foreign-id+ { "integer" "integer" "references" } }
164 { +primary-key+ { f f "primary key" } }
166 { +on-update+ { f f "on update" } }
167 { +on-delete+ { f f "on delete" } }
168 { +restrict+ { f f "restrict" } }
169 { +cascade+ { f f "cascade" } }
170 { +set-null+ { f f "set null" } }
171 { +set-default+ { f f "set default" } }
173 { BOOLEAN { "boolean" "boolean" f } }
174 { INTEGER { "integer" "integer" f } }
175 { BIG-INTEGER { "bigint" "bigint" f } }
176 { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
177 { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
178 { TEXT { "text" "text" f } }
179 { VARCHAR { "text" "text" f } }
180 { DATE { "date" "date" f } }
181 { TIME { "time" "time" f } }
182 { DATETIME { "datetime" "datetime" f } }
183 { TIMESTAMP { "timestamp" "timestamp" f } }
184 { DOUBLE { "real" "real" f } }
185 { BLOB { "blob" "blob" f } }
186 { FACTOR-BLOB { "blob" "blob" f } }
187 { URL { "text" "text" f } }
188 { +autoincrement+ { f f "autoincrement" } }
189 { +unique+ { f f "unique" } }
190 { +default+ { f f "default" } }
191 { +null+ { f f "null" } }
192 { +not-null+ { f f "not null" } }
193 { system-random-generator { f f f } }
194 { secure-random-generator { f f f } }
195 { random-generator { f f f } }
198 : insert-trigger ( -- string )
200 CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
201 BEFORE INSERT ON ${table-name}
203 SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
204 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
206 " interpolate>string ;
208 : insert-trigger-not-null ( -- string )
210 CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
211 BEFORE INSERT ON ${table-name}
213 SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
214 WHERE NEW.${table-id} IS NOT NULL
215 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
217 " interpolate>string ;
219 : update-trigger ( -- string )
221 CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
222 BEFORE UPDATE ON ${table-name}
224 SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
225 WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
227 " interpolate>string ;
229 : update-trigger-not-null ( -- string )
231 CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
232 BEFORE UPDATE ON ${table-name}
234 SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
235 WHERE NEW.${table-id} IS NOT NULL
236 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
238 " interpolate>string ;
240 : delete-trigger-restrict ( -- string )
242 CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
243 BEFORE DELETE ON ${foreign-table-name}
245 SELECT RAISE(ROLLBACK, 'delete on table \"${foreign-table-name}\" violates foreign key constraint \"fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
246 WHERE (SELECT ${table-id} FROM ${table-name} WHERE ${table-id} = OLD.${foreign-table-id}) IS NOT NULL;
248 " interpolate>string ;
250 : delete-trigger-cascade ( -- string )
252 CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
253 BEFORE DELETE ON ${foreign-table-name}
255 DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
257 " interpolate>string ;
259 : can-be-null? ( -- ? )
260 "sql-spec" get modifiers>> [ +not-null+ = ] none? ;
262 : delete-cascade? ( -- ? )
263 "sql-spec" get modifiers>> { +on-delete+ +cascade+ } find-subseq? ;
265 : sqlite-trigger, ( string -- )
266 { } { } <simple-statement> 3, ;
268 : create-sqlite-triggers ( -- )
270 insert-trigger sqlite-trigger,
271 update-trigger sqlite-trigger,
273 insert-trigger-not-null sqlite-trigger,
274 update-trigger-not-null sqlite-trigger,
277 delete-trigger-cascade sqlite-trigger,
279 delete-trigger-restrict sqlite-trigger,
282 : create-db-triggers ( sql-specs -- )
283 [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
286 [ column-name>> "table-id" set ]
288 modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
290 [ second db-table-name "foreign-table-name" set ]
291 [ third "foreign-table-id" set ] bi
292 create-sqlite-triggers
296 : sqlite-create-table ( sql-specs class-name -- )
298 "create table " 0% 0%
301 dup column-name>> [ "table-id" set ] [ 0% ] bi
303 dup type>> lookup-create-type 0%
311 [ "," 0% ] [ column-name>> 0% ] interleave
317 M: sqlite-db-connection create-sql-statement
319 [ sqlite-create-table ]
320 [ drop create-db-triggers ] 2bi
323 M: sqlite-db-connection drop-sql-statement
324 [ nip "drop table " 0% 0% ";" 0% ] query-make ;
326 M: sqlite-db-connection compound
328 { "default" [ first number>string " " glue ] }
329 { "references" [ >reference-string ] }
333 M: sqlite-db-connection parse-db-error
336 { 1 [ string>> parse-sqlite-sql-error ] }