From a61bac7ab5a158f07d81a71f482538ca5932328a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Feb 2009 18:26:11 -0600 Subject: [PATCH 1/3] fix sqlite foreign triggers create/delete bug ignore-errors only if there is a sql spec defined for the class until database-specific errors are implemented --- basis/db/sqlite/lib/lib.factor | 6 +- basis/db/sqlite/sqlite-tests.factor | 8 +- basis/db/sqlite/sqlite.factor | 135 ++++++++++++++++++++-------- basis/db/tuples/tuples.factor | 37 +++++--- 4 files changed, 130 insertions(+), 56 deletions(-) diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index b1bc9aa1a2..60141bc830 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -5,8 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary io.backend db.errors present urls io.encodings.utf8 -io.encodings.string accessors shuffle io prettyprint -db.private ; +io.encodings.string accessors shuffle io db.private ; IN: db.sqlite.lib ERROR: sqlite-error < db-error n string ; @@ -125,8 +124,7 @@ ERROR: sqlite-sql-error < sql-error n string ; ] if* (sqlite-bind-type) ; : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; -: sqlite-reset ( handle -- ) -"resetting: " write dup . sqlite3_reset sqlite-check-result ; +: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; : sqlite-clear-bindings ( handle -- ) sqlite3_clear_bindings sqlite-check-result ; : sqlite-#columns ( query -- int ) sqlite3_column_count ; diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 5ad4b0c889..677ec17a6e 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -1,6 +1,7 @@ USING: io io.files io.files.temp io.directories io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences -continuations db.types db.tuples unicode.case ; +continuations db.types db.tuples unicode.case accessors arrays +sorting ; IN: db.sqlite.tests : db-path ( -- path ) "test.db" temp-file ; @@ -74,8 +75,9 @@ IN: db.sqlite.tests ] with-db ] unit-test +[ \ swap ensure-table ] must-fail + ! You don't need a primary key -USING: accessors arrays sorting ; TUPLE: things one two ; things "THINGS" { @@ -163,5 +165,3 @@ watch "WATCH" { user>> f user boa select-tuple ] with-db ] unit-test - -[ \ swap ensure-table ] must-fail diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index d006145ea8..62a1b4714f 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -1,12 +1,12 @@ ! 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 +io.files kernel math math.parser namespaces prettyprint fry 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 ; +io.streams.string multiline make db.private sequences.deep ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -126,30 +126,6 @@ M: sqlite-statement query-results ( query -- result-set ) 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 ( tuple -- statement ) [ "insert into " 0% 0% @@ -225,7 +201,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger ( -- string ) [ <" - CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + 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-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -237,7 +213,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + 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-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -247,10 +223,17 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-insert-trigger ( -- string ) + [ + <" + DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : update-trigger ( -- string ) [ <" - CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + 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-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -262,7 +245,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : update-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + 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-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -272,10 +255,17 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-update-trigger ( -- string ) + [ + <" + DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : delete-trigger-restrict ( -- string ) [ <" - CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + 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-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') @@ -284,10 +274,17 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-delete-trigger-restrict ( -- string ) + [ + <" + DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : delete-trigger-cascade ( -- string ) [ <" - CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + 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-name} WHERE ${table-id} = OLD.${foreign-table-id}; @@ -295,6 +292,13 @@ M: sqlite-db-connection persistent-table ( -- assoc ) "> interpolate ] with-string-writer ; +: drop-delete-trigger-cascade ( -- string ) + [ + <" + DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id; + "> interpolate + ] with-string-writer ; + : can-be-null? ( -- ? ) "sql-spec" get modifiers>> [ +not-null+ = ] any? not ; @@ -318,14 +322,69 @@ M: sqlite-db-connection persistent-table ( -- assoc ) delete-trigger-restrict sqlite-trigger, ] if ; +: drop-sqlite-triggers ( -- ) + drop-insert-trigger sqlite-trigger, + drop-update-trigger sqlite-trigger, + delete-cascade? [ + drop-delete-trigger-cascade sqlite-trigger, + ] [ + drop-delete-trigger-restrict sqlite-trigger, + ] if ; + +: db-triggers ( sql-specs word -- ) + '[ + [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter + [ + [ class>> db-table-name "db-table" set ] + [ column-name>> "table-id" set ] + [ + modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter + [ + [ second db-table-name "foreign-table-name" set ] + [ third "foreign-table-id" set ] bi + _ execute + ] each + ] tri + ] each + ] call ; + +: 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 ( class -- statement ) + [ + ! specs name + [ sqlite-create-table ] + [ drop \ create-sqlite-triggers db-triggers ] 2bi + ] query-make ; + +M: sqlite-db-connection drop-sql-statement ( class -- statements ) + [ + [ nip "drop table " 0% 0% ";" 0% ] + [ drop \ drop-sqlite-triggers db-triggers ] 2bi + ] query-make ; + M: sqlite-db-connection compound ( string seq -- new-string ) over { { "default" [ first number>string " " glue ] } - { "references" [ - [ >reference-string ] keep - first2 [ db-table-name "foreign-table-name" set ] - [ "foreign-table-id" set ] bi* - create-sqlite-triggers - ] } + { "references" [ >reference-string ] } [ 2drop ] } case ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 219116aefd..9edd5bac69 100644 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -3,7 +3,8 @@ USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -destructors mirrors sets db.types db.private ; +destructors mirrors sets db.types db.private fry +combinators.short-circuit ; IN: db.tuples HOOK: create-sql-statement db-connection ( class -- object ) @@ -29,7 +30,7 @@ GENERIC: eval-generator ( singleton -- object ) : resulting-tuple ( exemplar-tuple row out-params -- tuple ) rot class new [ - [ [ slot-name>> ] dip set-slot-named ] curry 2each + '[ slot-name>> _ set-slot-named ] 2each ] keep ; : query-tuples ( exemplar-tuple statement -- seq ) @@ -98,33 +99,49 @@ M: query >query clone ; M: tuple >query swap >>tuple ; +ERROR: no-defined-persistent object ; + +: ensure-defined-persistent ( object -- object ) + dup { [ class? ] [ "db-table" word-prop ] } 1&& [ + no-defined-persistent + ] unless ; + : create-table ( class -- ) + ensure-defined-persistent create-sql-statement [ execute-statement ] with-disposals ; : drop-table ( class -- ) + ensure-defined-persistent drop-sql-statement [ execute-statement ] with-disposals ; : recreate-table ( class -- ) + ensure-defined-persistent [ - [ drop-sql-statement [ execute-statement ] with-disposals - ] curry ignore-errors + '[ + _ drop-sql-statement [ execute-statement ] with-disposals + ] ignore-errors ] [ create-table ] bi ; -: ensure-table ( class -- ) [ create-table ] curry ignore-errors ; +: ensure-table ( class -- ) + ensure-defined-persistent + '[ _ create-table ] ignore-errors ; : ensure-tables ( classes -- ) [ ensure-table ] each ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key db-assigned-id-spec? + dup class ensure-defined-persistent + db-columns find-primary-key db-assigned-id-spec? [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ; : update-tuple ( tuple -- ) - dup class + dup class ensure-defined-persistent db-connection get update-statements>> [ ] cache [ bind-tuple ] keep execute-statement ; : delete-tuples ( tuple -- ) - dup dup class [ + dup + dup class ensure-defined-persistent + [ [ bind-tuple ] keep execute-statement ] with-disposal ; @@ -132,8 +149,8 @@ M: tuple >query swap >>tuple ; >query [ tuple>> ] [ query>statement ] bi do-select ; : select-tuple ( query/tuple -- tuple/f ) - >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select - [ f ] [ first ] if-empty ; + >query 1 >>limit [ tuple>> ] [ query>statement ] bi + do-select [ f ] [ first ] if-empty ; : count-tuples ( query/tuple -- n ) >query [ tuple>> ] [ ] bi do-count From dd1587c74582b08267de6d8c2278809e31265088 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 19 Feb 2009 18:52:45 -0600 Subject: [PATCH 2/3] Fixing SQLite unit tests --- basis/db/sqlite/sqlite-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 677ec17a6e..fd730f07ae 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -117,7 +117,7 @@ hi "HELLO" { 1 insert-tuple f select-tuple 1 1 insert-tuple - f select-tuple + f f select-tuple hi drop-table foo drop-table ] with-db @@ -160,6 +160,7 @@ watch "WATCH" { show new insert-tuple show new select-tuple "littledan" f user boa select-tuple + swap [ username>> ] [ id>> ] bi* watch boa insert-tuple watch new select-tuple user>> f user boa select-tuple From d59415d23b606ad7d89e1a6d634d6644658f5a70 Mon Sep 17 00:00:00 2001 From: Jason Merrill Date: Thu, 19 Feb 2009 22:21:31 -0500 Subject: [PATCH 3/3] Fixed help for math.dual. Help is now autogenerated where possible. --- extra/math/dual/dual-docs.factor | 79 -------------------------------- extra/math/dual/dual.factor | 30 ++++++++---- 2 files changed, 21 insertions(+), 88 deletions(-) diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor index 1f24c8217c..67b3d6ae97 100644 --- a/extra/math/dual/dual-docs.factor +++ b/extra/math/dual/dual-docs.factor @@ -10,84 +10,6 @@ HELP: } { $description "Creates a dual number from its ordinary and epsilon parts." } ; -HELP: d* -{ $values - { "x" dual } { "y" dual } - { "x*y" dual } -} -{ $description "Multiply dual numbers." } ; - -HELP: d+ -{ $values - { "x" dual } { "y" dual } - { "x+y" dual } -} -{ $description "Add dual numbers." } ; - -HELP: d- -{ $values - { "x" dual } { "y" dual } - { "x-y" dual } -} -{ $description "Subtract dual numbers." } ; - -HELP: d/ -{ $values - { "x" dual } { "y" dual } - { "x/y" dual } -} -{ $description "Divide dual numbers." } -{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ; - -HELP: d^ -{ $values - { "x" dual } { "y" dual } - { "x^y" dual } -} -{ $description "Raise a dual number to a (possibly dual) power" } ; - -HELP: dabs -{ $values - { "x" dual } - { "|x|" dual } -} -{ $description "Absolute value of a dual number." } ; - -HELP: dacosh -{ $values - { "x" dual } - { "y" dual } -} -{ $description "Inverse hyberbolic cosine of a dual number." } ; - -HELP: dasinh -{ $values - { "x" dual } - { "y" dual } -} -{ $description "Inverse hyberbolic sine of a dual number." } ; - -HELP: datanh -{ $values - { "x" dual } - { "y" dual } -} -{ $description "Inverse hyberbolic tangent of a dual number." } ; - -HELP: dneg -{ $values - { "x" dual } - { "-x" dual } -} -{ $description "Negative of a dual number." } ; - -HELP: drecip -{ $values - { "x" dual } - { "1/x" dual } -} -{ $description "Reciprocal of a dual number." } ; - HELP: define-dual { $values { "word" word } @@ -128,5 +50,4 @@ $nl "Dual numbers are ordered pairs " { $snippet ""} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "* = " } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f() = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "." ; - ABOUT: "math.dual" diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor index c85c23e51d..3e0e5437b4 100644 --- a/extra/math/dual/dual.factor +++ b/extra/math/dual/dual.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Jason W. Merrill. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.derivatives accessors - macros words effects vocabs sequences generalizations fry - combinators.smart generic compiler.units ; + macros generic compiler.units words effects vocabs + sequences arrays assocs generalizations fry make + combinators.smart help help.markup ; IN: math.dual @@ -48,6 +49,19 @@ MACRO: chain-rule ( word -- e ) tri '[ [ @ _ @ ] sum-outputs ] ; +: set-dual-help ( word dword -- ) + [ swap + [ stack-effect [ in>> ] [ out>> ] bi append + [ dual ] { } map>assoc { $values } prepend + ] + [ [ { $description } % "Version of " , + { $link } swap suffix , + " extended to work on dual numbers." , ] + { } make + ] + bi* 2array + ] keep set-word-help ; + PRIVATE> MACRO: dual-op ( word -- ) @@ -58,13 +72,11 @@ MACRO: dual-op ( word -- ) '[ _ @ @ ] ; : define-dual ( word -- ) - [ - [ stack-effect ] - [ name>> "d" prepend "math.dual" create ] - bi [ set-stack-effect ] keep - ] - keep - '[ _ dual-op ] define ; + dup name>> "d" prepend "math.dual" create + [ [ stack-effect ] dip set-stack-effect ] + [ set-dual-help ] + [ swap '[ _ dual-op ] define ] + 2tri ; ! Specialize math functions to operate on dual numbers. [ all-words [ "derivative" word-prop ] filter