! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays assocs classes compiler db hashtables
-io.files kernel math math.parser namespaces prettyprint
-sequences strings classes.tuple alien.c-types continuations
-db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
-math.intervals io nmake accessors vectors math.ranges random
-math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make db.private ;
+USING: accessors classes.tuple combinators db db.private db.queries
+db.sqlite.errors db.sqlite.ffi db.sqlite.lib db.tuples
+db.tuples.private db.types destructors interpolate kernel math
+math.parser namespaces nmake random sequences sequences.deep ;
IN: db.sqlite
TUPLE: sqlite-db path ;
PRIVATE>
-M: sqlite-db db-open ( db -- db-connection )
+M: sqlite-db db-open
path>> sqlite-open <sqlite-db-connection> ;
-M: sqlite-db-connection db-close ( handle -- ) sqlite-close ;
+M: sqlite-db-connection db-close sqlite-close ;
TUPLE: sqlite-statement < statement ;
TUPLE: sqlite-result-set < result-set has-more? ;
-M: sqlite-db-connection <simple-statement> ( str in out -- obj )
+M: sqlite-db-connection <simple-statement>
<prepared-statement> ;
-M: sqlite-db-connection <prepared-statement> ( str in out -- obj )
+M: sqlite-db-connection <prepared-statement>
sqlite-statement new-statement ;
: sqlite-maybe-prepare ( statement -- statement )
>>handle
] unless ;
-M: sqlite-statement dispose ( statement -- )
+M: sqlite-statement dispose
handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
-M: sqlite-result-set dispose ( result-set -- )
+M: sqlite-result-set dispose
f >>handle drop ;
: reset-bindings ( statement -- )
sqlite-maybe-prepare
handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
-M: sqlite-statement low-level-bind ( statement -- )
+M: sqlite-statement low-level-bind
[ handle>> ] [ bind-params>> ] bi
[ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
-M: sqlite-statement bind-statement* ( statement -- )
+M: sqlite-statement bind-statement*
sqlite-maybe-prepare
dup bound?>> [ dup reset-bindings ] when
low-level-bind ;
swap >>value
swap >>key ;
-M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
+M: sql-spec sqlite-bind-conversion
[ column-name>> ":" prepend ]
[ slot-name>> rot get-slot-named ]
[ type>> ] tri <sqlite-low-level-binding> ;
-M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
+M: literal-bind sqlite-bind-conversion
nip [ key>> ] [ value>> ] [ type>> ] tri
<sqlite-low-level-binding> ;
-M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
- tuck
- [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
- rot set-slot-named
- [ [ key>> ] [ type>> ] bi ] dip
- swap <sqlite-low-level-binding> ;
+M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+ generate-bind generator-singleton>> eval-generator :> obj
+ generate-bind slot-name>> :> name
+ obj name tuple set-slot-named
+ generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
-M: sqlite-statement bind-tuple ( tuple statement -- )
+M: sqlite-statement bind-tuple
[
in-params>> [ sqlite-bind-conversion ] with map
] keep bind-statement ;
db-connection get handle>> sqlite3_last_insert_rowid
dup zero? [ sqlite-last-id-fail ] when ;
-M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
+M: sqlite-db-connection insert-tuple-set-key
execute-statement last-insert-id swap set-primary-key ;
-M: sqlite-result-set #columns ( result-set -- n )
+M: sqlite-result-set #columns
handle>> sqlite-#columns ;
-M: sqlite-result-set row-column ( result-set n -- obj )
+M: sqlite-result-set row-column
[ handle>> ] [ sqlite-column ] bi* ;
-M: sqlite-result-set row-column-typed ( result-set n -- obj )
+M: sqlite-result-set row-column-typed
dup pick out-params>> nth type>>
[ handle>> ] 2dip sqlite-column-typed ;
-M: sqlite-result-set advance-row ( result-set -- )
+M: sqlite-result-set advance-row
dup handle>> sqlite-next >>has-more? drop ;
-M: sqlite-result-set more-rows? ( result-set -- ? )
+M: sqlite-result-set more-rows?
has-more?>> ;
-M: sqlite-statement query-results ( query -- result-set )
+M: sqlite-statement query-results
sqlite-maybe-prepare
dup handle>> sqlite-result-set new-result-set
dup advance-row ;
-M: sqlite-db-connection create-sql-statement ( class -- statement )
- [
- dupd
- "create table " 0% 0%
- "(" 0% [ ", " 0% ] [
- dup "sql-spec" set
- dup column-name>> [ "table-id" set ] [ 0% ] bi
- " " 0%
- dup type>> lookup-create-type 0%
- modifiers 0%
- ] interleave
-
- find-primary-key [
- ", " 0%
- "primary key(" 0%
- [ "," 0% ] [ column-name>> 0% ] interleave
- ")" 0%
- ] unless-empty
- ");" 0%
- ] query-make ;
-
-M: sqlite-db-connection drop-sql-statement ( class -- statement )
- [ "drop table " 0% 0% ";" 0% drop ] query-make ;
-
-M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
+M: sqlite-db-connection <insert-db-assigned-statement>
[
"insert into " 0% 0%
"(" 0%
");" 0%
] query-make ;
-M: sqlite-db-connection <insert-user-assigned-statement> ( tuple -- statement )
+M: sqlite-db-connection <insert-user-assigned-statement>
<insert-db-assigned-statement> ;
-M: sqlite-db-connection bind# ( spec obj -- )
+M: sqlite-db-connection bind#
[
[ column-name>> ":" next-sql-counter surround dup 0% ]
[ type>> ] bi
] dip <literal-bind> 1, ;
-M: sqlite-db-connection bind% ( spec -- )
+M: sqlite-db-connection bind%
dup 1, column-name>> ":" prepend 0% ;
-M: sqlite-db-connection persistent-table ( -- assoc )
+M: sqlite-db-connection persistent-table
H{
{ +db-assigned-id+ { "integer" "integer" f } }
{ +user-assigned-id+ { f f f } }
{ +random-id+ { "integer" "integer" f } }
{ +foreign-id+ { "integer" "integer" "references" } }
+ { +primary-key+ { f f "primary key" } }
{ +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } }
} ;
: insert-trigger ( -- string )
- [
- <"
- CREATE TRIGGER fki_${table}_${foreign-table}_id
- BEFORE INSERT ON ${table}
+ "
+ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
+ BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
- ] with-string-writer ;
+ " interpolate>string ;
: insert-trigger-not-null ( -- string )
- [
- <"
- CREATE TRIGGER fki_${table}_${foreign-table}_id
- BEFORE INSERT ON ${table}
+ "
+ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
+ BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE NEW.${foreign-table-id} IS NOT NULL
- AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ SELECT RAISE(ROLLBACK, 'insert on table \"${table-name}\" violates foreign key constraint \"fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
+ WHERE NEW.${table-id} IS NOT NULL
+ AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
- ] with-string-writer ;
+ " interpolate>string ;
: update-trigger ( -- string )
- [
- <"
- CREATE TRIGGER fku_${table}_${foreign-table}_id
- BEFORE UPDATE ON ${table}
+ "
+ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
+ BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
- ] with-string-writer ;
+ " interpolate>string ;
: update-trigger-not-null ( -- string )
- [
- <"
- CREATE TRIGGER fku_${table}_${foreign-table}_id
- BEFORE UPDATE ON ${table}
+ "
+ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
+ BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE NEW.${foreign-table-id} IS NOT NULL
- AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ SELECT RAISE(ROLLBACK, 'update on table \"${table-name}\" violates foreign key constraint \"fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id\"')
+ WHERE NEW.${table-id} IS NOT NULL
+ AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
- "> interpolate
- ] with-string-writer ;
+ " interpolate>string ;
: delete-trigger-restrict ( -- string )
- [
- <"
- CREATE TRIGGER fkd_${table}_${foreign-table}_id
- BEFORE DELETE ON ${foreign-table}
+ "
+ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
+ BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+ 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\"')
+ WHERE (SELECT ${table-id} FROM ${table-name} WHERE ${table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
- "> interpolate
- ] with-string-writer ;
+ " interpolate>string ;
: delete-trigger-cascade ( -- string )
- [
- <"
- CREATE TRIGGER fkd_${table}_${foreign-table}_id
- BEFORE DELETE ON ${foreign-table}
+ "
+ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
+ BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
- DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
+ DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
END;
- "> interpolate
- ] with-string-writer ;
+ " interpolate>string ;
: can-be-null? ( -- ? )
- "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
+ "sql-spec" get modifiers>> [ +not-null+ = ] none? ;
: delete-cascade? ( -- ? )
- "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
+ "sql-spec" get modifiers>> { +on-delete+ +cascade+ } subseq-of? ;
: sqlite-trigger, ( string -- )
{ } { } <simple-statement> 3, ;
can-be-null? [
insert-trigger sqlite-trigger,
update-trigger sqlite-trigger,
- ] [
+ ] [
insert-trigger-not-null sqlite-trigger,
update-trigger-not-null sqlite-trigger,
] if
delete-trigger-restrict sqlite-trigger,
] if ;
-M: sqlite-db-connection compound ( string seq -- new-string )
+: create-db-triggers ( sql-specs -- )
+ [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
+ [
+ [ "sql-spec" set ]
+ [ column-name>> "table-id" set ]
+ [ ] tri
+ modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
+ [
+ [ second db-table-name "foreign-table-name" set ]
+ [ third "foreign-table-id" set ] bi
+ create-sqlite-triggers
+ ] each
+ ] each ;
+
+: sqlite-create-table ( sql-specs class-name -- )
+ [
+ "create table " 0% 0%
+ "(" 0% [ ", " 0% ] [
+ dup "sql-spec" set
+ dup column-name>> [ "table-id" set ] [ 0% ] bi
+ " " 0%
+ dup type>> lookup-create-type 0%
+ modifiers 0%
+ ] interleave
+ ] [
+ drop
+ find-primary-key [
+ ", " 0%
+ "primary key(" 0%
+ [ "," 0% ] [ column-name>> 0% ] interleave
+ ")" 0%
+ ] unless-empty
+ ");" 0%
+ ] 2bi ;
+
+M: sqlite-db-connection create-sql-statement
+ [
+ [ sqlite-create-table ]
+ [ drop create-db-triggers ] 2bi
+ ] query-make ;
+
+M: sqlite-db-connection drop-sql-statement
+ [ nip "drop table " 0% 0% ";" 0% ] query-make ;
+
+M: sqlite-db-connection compound
over {
{ "default" [ first number>string " " glue ] }
- { "references" [
- [ >reference-string ] keep
- first2 [ "foreign-table" set ]
- [ "foreign-table-id" set ] bi*
- create-sqlite-triggers
- ] }
+ { "references" [ >reference-string ] }
[ 2drop ]
} case ;
+
+M: sqlite-db-connection parse-db-error
+ dup sqlite-error? [
+ dup n>> {
+ { 1 [ string>> parse-sqlite-sql-error ] }
+ [ drop ]
+ } case
+ ] when ;