diff --git a/.github/workflows/matrix.yaml b/.github/workflows/matrix.yaml index b530bc48..2f1a9a14 100644 --- a/.github/workflows/matrix.yaml +++ b/.github/workflows/matrix.yaml @@ -13,7 +13,7 @@ jobs: os: - ubuntu-latest raku-version: - - "2022.07" + - "2026.07" runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v3 diff --git a/META6.json b/META6.json index b32eb916..0b5467b7 100644 --- a/META6.json +++ b/META6.json @@ -47,11 +47,13 @@ "Red::AST::Constraints": "lib/Red/AST/Constraints.rakumod", "Red::AST::CreateColumn": "lib/Red/AST/CreateColumn.rakumod", "Red::AST::CreateTable": "lib/Red/AST/CreateTable.rakumod", + "Red::AST::CreateTableCli": "lib/Red/AST/CreateTableCli.rakumod", "Red::AST::CreateView": "lib/Red/AST/CreateView.rakumod", "Red::AST::DateTimeFuncs": "lib/Red/AST/DateTimeFuncs.rakumod", "Red::AST::Delete": "lib/Red/AST/Delete.rakumod", "Red::AST::Divisible": "lib/Red/AST/Divisible.rakumod", "Red::AST::DropColumn": "lib/Red/AST/DropColumn.rakumod", + "Red::AST::DropTable": "lib/Red/AST/DropTable.rakumod", "Red::AST::Empty": "lib/Red/AST/Empty.rakumod", "Red::AST::Function": "lib/Red/AST/Function.rakumod", "Red::AST::Generic::Infix": "lib/Red/AST/Generic/Infix.rakumod", @@ -88,6 +90,7 @@ "Red::Cli::Column": "lib/Red/Cli/Column.rakumod", "Red::Cli::Relationship": "lib/Red/Cli/Relationship.rakumod", "Red::Cli::Table": "lib/Red/Cli/Table.rakumod", + "Red::Cli::UniqueConstraint": "lib/Red/Cli/UniqueConstraint.rakumod", "Red::Column": "lib/Red/Column.rakumod", "Red::ColumnMethods": "lib/Red/ColumnMethods.rakumod", "Red::Config": "lib/Red/Config.rakumod", diff --git a/bin/red b/bin/red index 850a6feb..0cf348b1 100755 --- a/bin/red +++ b/bin/red @@ -1,7 +1,9 @@ #!env perl6 +use Red; use Red::Cli; use Red::Do; use Red::Database; +use Red::Configuration; my %*SUB-MAIN-OPTS = :named-anywhere, @@ -9,6 +11,14 @@ my %*SUB-MAIN-OPTS = my $*RED-DEBUG = False; +sub _config(:$config-file = "./red.rakuconfig", Bool :$debug, :$driver, *%pars) { + my $config = single-config-run file => $config-file; + $GLOBAL::RED-DB = $config.driver; + $GLOBAL::RED-DB = database ($driver // $config.driver-name), |%pars if $driver || %pars; + $GLOBAL::RED-DEBUG = $debug // $config.debug; + $config +} + proto MAIN(Str :$I, Bool :$debug, |) { dyn-lib .split: "," with $I; $*RED-DEBUG = $debug; @@ -18,70 +28,188 @@ proto MAIN(Str :$I, Bool :$debug, |) { #| List tables in database multi MAIN( "list-tables", - Str :$driver!, + :$config-file, + Str :$driver, + Bool :$debug, *%pars ) { - my $*RED-DB = database($driver, |%pars); + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; .say for list-tables :$driver, |%pars } #| Generate stub code to access models from database schema multi MAIN( "print-stub", + :$config-file, Str :$schema-class, - Str :$driver!, + Str :$driver, + Bool :$debug, *%pars ) { - my $*RED-DB = database($driver, |%pars); - say gen-stub-code :$schema-class, :$driver, |%pars + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; + say gen-stub-code :$schema-class, driver => $config.driver-name, |%pars } #| Generates migration plan to upgrade database schema multi MAIN( "migration-plan", - Str :$model!, + Str :$model, Str :$require = $model, - Str :$driver!, + Str :$driver, + :I($lib-path), + :$config-file, + Bool :$debug, *%pars ) { - my $*RED-DB = database($driver, |%pars); - migration-plan :$model, :$require, :$driver, |%pars + "use lib '$lib-path'".EVAL; + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; + migration-plan model => ($model // $config.models.head), :$require, driver => $config.driver-name, |%pars } #| Generates models' code from database schema multi MAIN( "generate-code", - Str :$path! where { not .defined or .IO.d or $_ eq "-" or fail "Path $_ does not exist." }, - Str :$from-sql where { not .defined or .IO.f or $_ eq "-" or fail "SQL $_ do not exist." }, + Str :$path! where { not .defined or .IO.d or $_ eq "-" }, + Str :$from-sql where { not .defined or .IO.f or $_ eq "-" }, Str :$schema-class, Bool :$print-stub = False, Bool :$no-relationships = False, #Bool :$stub-only, - Str :$driver!, + Str :$driver, + :$config-file, + Bool :$debug, *%pars ) { - my $*RED-DB = database($driver, |%pars); + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; generate-code - :$path, - :$from-sql, - :$schema-class, - :$print-stub, - :$no-relationships, - :$driver, - |%pars + :$path, + :$from-sql, + :$schema-class, + :$print-stub, + :$no-relationships, + :$driver, + |%pars } #| Prepare database multi MAIN( - "prepare-database", - Bool :$populate, - Str :$models!, - Str :$driver!, - *%pars + "prepare-database", + Bool :$populate, + Str :$models, + Str :$driver, + :I($lib-path), + :$config-file, + Bool :$debug, + *%pars +) { + "use lib '$lib-path'".EVAL; + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; + prepare-database :$populate, models => ($models // $config.models), driver => $config.driver-name, |%pars +} + +multi show(@_, %attrs) { + qq|[ { @_.join: ", " }, ]| +} +multi show(IO $_, %attrs) { qq|"{ .absolute }".IO| } +multi show(Red::Driver $_, %attrs) { + qq|database "{ + .^shortname + }"{ + ", " ~ %attrs.pairs.map({ + "{.key} => {.value.raku}" + }).join: ", " if %attrs:exists + }| +} +multi show(Red::Schema $_, %attrs) { qq|schema { .models.keys.join: ", " }| } +multi show($_, %attrs) { .raku } + +#| Config +multi MAIN( + "config", + :@models, + :@requires = |@models, + :$config-file, + :$driver, + :I($lib-path), + Bool :$debug, + *%pars, +) { + my %attrs = + models => @models, + requires => @requires, + driver-name => $driver, + driver-attrs => %pars, + debug => $debug, + schema => schema(@models), + ; + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; + say "use Red;"; + say "use Red::Config;"; + say "use lib '{ $lib-path }';"; + for @requires { + say "use $_;"; + } + say "\nconfig \{"; + for $config.^attributes -> $attr { + next unless $attr.has_accessor; + my $name = $attr.name.substr: 2; + say ".{ $name } = { show (%attrs{$name} // $config."$name"()), %attrs };".indent: 4 + } + say "}"; +} + +#| Diff model from DB +multi MAIN( + "diff-from-db", + +@models, + :$config-file, + :$driver, + Bool :$debug, + *%pars, +) { + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; + say tree prepare-tree diff-from-db ( @models || $config.models ); +} + +#| Diff model to DB +multi MAIN( + "diff-to-db", + +@models, + :$config-file, + :$driver, + Bool :$debug, + *%pars, +) { + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; + say tree prepare-tree diff-to-db ( @models || $config.models ); +} + +#| Update DB with models +multi MAIN( + "sync", + # +@models, + Bool :$dev where { .so }, + :$config-file, + :$driver, + Bool :$debug, + *%pars, +) { + my $config = _config |(:$config-file with $config-file), |(:$debug with $debug), :$driver, |%pars; + $config.schema.update +} + +#| Update DB with models +multi MAIN( + "prepare", + # +@models, + :$config-file, + :$driver, + Bool :$debug, + *%pars, ) { - $GLOBAL::RED-DB = database $driver, |%pars; - prepare-database :$populate, :$models, :$driver, |%pars + my $config = _config |(:$config-file with $config-file),|(:$debug with $debug), :$driver, |%pars; + .say for $config.schema.plan } sub dyn-lib(@libs) { diff --git a/lib/MetamodelX/Red/Describable.rakumod b/lib/MetamodelX/Red/Describable.rakumod index a97bffa9..5fbd35b6 100644 --- a/lib/MetamodelX/Red/Describable.rakumod +++ b/lib/MetamodelX/Red/Describable.rakumod @@ -2,6 +2,7 @@ use Red::DB; use Red::Utils; use Red::Cli::Table; use Red::Cli::Column; +use Red::Model; =head2 MetamodelX::Red::Describable @@ -11,7 +12,7 @@ method !create-column($_ --> Red::Cli::Column) { Red::Cli::Column.new: :name(.column-name // self.column-formatter: .attr-name), :formated-name(.attr-name), - :type(get-RED-DB.default-type-for($_)), + :type(.type // get-RED-DB.default-type-for($_)), :perl-type(.type), :nullable(.nullable), :pk(.id), @@ -21,21 +22,37 @@ method !create-column($_ --> Red::Cli::Column) { #| Returns an object of type `Red::Cli::Table` that represents #| a database table of the caller. method describe(\model --> Red::Cli::Table) { + my @constraints = model.^unique-constraints; Red::Cli::Table.new: :name(self.table(model)), :model-name(self.name(model)), - :columns(self.columns>>.column.map({self!create-column($_)}).cache) + :columns(self.columns>>.column.map({self!create-column($_)}).cache), + :@constraints } #| Returns the difference to transform this model to the database version. method diff-to-db(\model) { - model.^describe.diff: $*RED-DB.schema-reader.table-definition: model.^table + my Str $table = model.^table; + my $b = $*RED-DB.schema-reader.table-definition: $table; + model.^describe.diff: $b } #| Returns the difference to transform the DB table into this model. method diff-from-db(\model) { - $*RED-DB.schema-reader.table-definition(model.^table).diff: model.^describe + my $schema-reader = $*RED-DB.schema-reader; + my $from-db = $schema-reader.table-definition: model.^table; + $from-db.diff: model.^describe } #| Returns the difference between two models. -method diff(\model, \other-model) { - model.^describe.diff: other-model.^describe +multi method diff(\model, Red::Model \other-model) { + model.^diff: other-model.^describe +} + +#| Returns the difference between two models. +multi method diff(\model, Red::Cli::Table \other-model) { + model.^describe.diff: other-model +} + +#| Returns the difference between two models. +multi method diff(\model, \other-model) { + model.^describe.diff: other-model } diff --git a/lib/Red/AST/CreateTableCli.rakumod b/lib/Red/AST/CreateTableCli.rakumod new file mode 100644 index 00000000..c620b7a4 --- /dev/null +++ b/lib/Red/AST/CreateTableCli.rakumod @@ -0,0 +1,11 @@ +use Red::AST; +use Red::Cli::Table; + +#| Represents a create table +unit class Red::AST::CreateTableCli does Red::AST; + +has Red::Cli::Table $.table; + +method returns { Nil } +method args { |$!table.columns } +method find-column-name {} diff --git a/lib/Red/AST/DropTable.rakumod b/lib/Red/AST/DropTable.rakumod new file mode 100644 index 00000000..06e77cca --- /dev/null +++ b/lib/Red/AST/DropTable.rakumod @@ -0,0 +1,10 @@ +use Red::AST; + +#| Represents an alter table drop column +unit class Red::AST::DropTable does Red::AST; + +has Str $.table is required; + +method find-column-name {} +method args {} +method returns {} diff --git a/lib/Red/Cli.rakumod b/lib/Red/Cli.rakumod index 128dc59c..ccbfaafc 100644 --- a/lib/Red/Cli.rakumod +++ b/lib/Red/Cli.rakumod @@ -1,6 +1,7 @@ unit class Red::Cli; use Red::Database; use Red::Do; +use Red::DB; use Red::Schema; use Red::Utils; use Red::AST::CreateColumn; @@ -10,12 +11,11 @@ use Red::AST::DropColumn; #| Lists tables from database schema multi list-tables( - Str :$driver!, + Str :$driver, *%pars ) is export { my $schema-reader = $*RED-DB.schema-reader; - - $schema-reader.tables-names.do-it + $schema-reader.tables-names } sub gen-stub(:@includes, :@models, :$driver, :%pars) { @@ -35,7 +35,7 @@ sub gen-stub(:@includes, :@models, :$driver, :%pars) { #| Generates stub code to access models from database schema multi gen-stub-code( Str :$schema-class, - Str :$driver!, + Str :$driver, *%pars ) is export { my $schema-reader = $*RED-DB.schema-reader; @@ -60,16 +60,17 @@ multi gen-stub-code( multi migration-plan( Str :$model!, Str :$require = $model, - Str :$driver!, + Str :$driver, *%pars ) is export { my %steps; require ::($require); - for $*RED-DB.diff-to-ast: ::($model).^diff-from-db -> @data { + for get-RED-DB.diff-to-ast: ::($model).^diff-from-db -> @data { say "Step ", ++$, ":"; - #say @data.join("\n").indent: 4 - # $*RED-DB.translate($_).key.indent(4).say for Red::AST::ChangeColumn.optimize: @data - $*RED-DB.translate($_).key.indent(4).say for @data + for @data { + my @trans = get-RED-DB.translate($_); + say "{.key};".indent(4) for @trans + } } } @@ -81,7 +82,7 @@ multi generate-code( Bool :$print-stub = False, Bool :$no-relationships = False, #Bool :$stub-only, - Str :$driver!, + Str :$driver, *%pars ) is export { my $schema-reader = $*RED-DB.schema-reader; @@ -136,11 +137,69 @@ multi generate-code( #| Prepare database multi prepare-database( - Bool :$populate, + Bool :$populate = False, Str :$models!, - Str :$driver!, + Str :$driver, + *%pars +) is export { + my $schema = schema($models.split: ","); + prepare-database :$populate, :$schema, |(:$driver with $driver) +} + +#| Prepare database +multi prepare-database( + Bool :$populate, + Red::Model :$models!, + Str :$driver, + *%pars +) is export { + prepare-database :$populate, :models[ $models, ], |(:$driver with $driver) +} + +#| Prepare database +multi prepare-database( + Bool :$populate, + :@models! where { .are: Red::Model }, + Str :$driver, + *%pars +) is export { + my $schema = schema(@models); + prepare-database :$populate, :$schema, |(:$driver with $driver) +} + +#| Prepare database +multi prepare-database( + Bool :$populate, + :$schema!, + Str :$driver, *%pars ) is export { - my @m = schema($models.split: ",").create.models.values; + my @m = $schema.create.models.values; @m.map: { .^populate } if $populate } + +multi tree(@changes) is export { + @changes.map({"$_\n"}).join +} + +multi tree(%tree) is export { + join "", do for %tree.kv -> $key, $value { + "$key:\n{ tree($value).indent(4) }" + } +} + +sub prepare-tree(@data) is export { + @data.classify: :as{ .skip: 3 }, *.head: 3 +} + +#| Diff from DB +multi diff-from-db(+@models, Red::Schema :$schema is copy) is export { + $schema //= schema @models; + $schema.diff-from-db +} + +#| Diff from DB +multi diff-to-db(+@models, Red::Schema :$schema is copy) is export { + $schema //= schema @models; + $schema.diff-to-db +} diff --git a/lib/Red/Cli/Column.rakumod b/lib/Red/Cli/Column.rakumod index b2f68235..d3eb7b4b 100644 --- a/lib/Red/Cli/Column.rakumod +++ b/lib/Red/Cli/Column.rakumod @@ -2,26 +2,40 @@ use Red::Utils; use Red::DB; unit class Red::Cli::Column; -has $.table is rw; -has Str $.name is required; +has $.table is rw; +has Str $.name is required; has Str $.formated-name = snake-to-kebab-case $!name; -has Str $.type is required; -has Str $.perl-type = get-RED-DB.type-for-sql: $!type.lc; -has Bool $.nullable = True; -has Bool $.pk = False; -has Bool $.unique = False; -has $.references = {}; +has Str $.type is required; +has Str $.perl-type = get-RED-DB.type-for-sql: $!type.lc; +has Bool $.nullable = True; +has Bool $.pk = False; +has Bool $.unique is rw = False; +has Bool $.auto-increment = False; +has $.references = {}; +has Str $.comment; multi method new($name, $type, $nullable, $pk, $unique, $references) { self.bless: :$name, :$type, :nullble(?$nullable), :pk(?$pk), :unique(?$unique), :$references } multi method gist(::?CLASS:D:) { - "Red::Cli::Column.new(:name($!name), :type($!type), :nullable($!nullable), :pk($!pk), :unique($!unique), { - ":references($_)" with $!references + "Red::Cli::Column.new(:name<$!name>, :type<$!type>{ + ", :nullable" if $!nullable + }{ + ", :pk" if $!pk + }{ + ", :unique" if $!unique + }{ + ", :references({$!references}.{$!references})" if $!references } #`( table => $!table.name() ))" } +method Str { $.gist } + +multi method WHICH(::?CLASS:D:) { + ValueObjAt.new: $.gist +} + method !modifier(Str :$schema-class) { do given self { when ?.pk { "id" } diff --git a/lib/Red/Cli/Table.rakumod b/lib/Red/Cli/Table.rakumod index a467951f..ff04e64b 100644 --- a/lib/Red/Cli/Table.rakumod +++ b/lib/Red/Cli/Table.rakumod @@ -6,18 +6,30 @@ unit class Red::Cli::Table; has Str $.name; has Str $.model-name = try { snake-to-camel-case $!name }; has @.columns; +has @.constraints; has @.relationships; has Bool $.exists = True; -submethod TWEAK(:@columns) { +submethod TWEAK(:@columns, :@constraints) { + my @single-constraints; + for @constraints -> @cols { + @single-constraints.push: @cols.head.column.name if +@cols == 1 + } + my %single := set @single-constraints; for @columns -> $col { $col.table = self; + $col.unique = True if %single{$col.name}; with $col.references { @!relationships.push: Red::Cli::Relationship.new: :id($col) } } } +multi method gist(::?CLASS:U:) { "({ self.^name})" } +multi method gist(::?CLASS:D:) { + "{self.^name}.new(:name<{$!name}>, :columns[{ @!columns>>.gist.join: ", " }])" +} + multi method model-definition($ where so *) { "unit model { $!model-name };\n" } multi method model-definition($ where not *) { "model { $!model-name } \{" } multi method model-end($ where so *) { "" } @@ -37,33 +49,44 @@ method to-code(Str :$schema-class, Bool :$no-relationships) { END } -method diff(::?CLASS $b) { +method diff($b) { my @diffs; - if $!name ne $b.name { - @diffs.push: [ $!name, "+", "name", $b.name ]; - @diffs.push: [ $!name, "-", "name", $!name ]; - } - if @!columns != $b.columns { - @diffs.push: [ $!name, "+", "n-of-cols", $b.columns.elems ]; - @diffs.push: [ $!name, "-", "n-of-cols", @!columns.elems ]; + my Str $a-name = self.defined ?? $!name // "" !! ""; + my Str $b-name = $b.defined ?? $b.name // Str !! Str; + + my @a = self ?? @!columns.sort: *.name !! (); + my @b = $b ?? $b.columns.sort: *.name !! (); + + if $a-name ne ($b-name // "") { + if !self.defined && !$b-name.defined { + die "No from and to table... it should never happen..." + } + if !self.defined || !$!name.defined { + @diffs.push: [ $a-name, "+", "table", $b ]; + return @diffs + } elsif !$b-name.defined { + @diffs.push: [ $a-name, "-", "table", self ]; + return @diffs + } else { + @diffs.push: [ $a-name, "+", "name", $b-name ]; + @diffs.push: [ $a-name, "-", "name", $a-name ]; + } } - my @a = @!columns.sort: *.name; - my @b = $b.columns.sort: *.name; while @a > 0 and @b > 0 { if @a.head.name eq @b.head.name { my $a = @a.shift; my $b = @b.shift; for $a.diff: $b -> @d { - @diffs.push: [ $!name, |@d ] + @diffs.push: [ $a-name, |@d ] } - } elsif @b.head lt @a.head { - @diffs.push: [ $!name, "+", "col", @b.shift ]; - } elsif @a.head lt @b.head { - @diffs.push: [ $!name, "-", "col", @a.shift ]; + } elsif @b.head.name lt @a.head.name { + @diffs.push: [ $a-name, "+", "col", @b.shift ]; + } elsif @a.head.name lt @b.head.name { + @diffs.push: [ $a-name, "-", "col", @a.shift ]; } } - @diffs.push: [ $!name, "+", "col", $_ ] for @b; - @diffs.push: [ $!name, "-", "col", $_ ] for @a; + @diffs.push: [ $a-name, "+", "col", $_ ] for @b; + @diffs.push: [ $a-name, "-", "col", $_ ] for @a; @diffs } diff --git a/lib/Red/Cli/UniqueConstraint.rakumod b/lib/Red/Cli/UniqueConstraint.rakumod new file mode 100644 index 00000000..c5b72e2a --- /dev/null +++ b/lib/Red/Cli/UniqueConstraint.rakumod @@ -0,0 +1,26 @@ +use Red::Utils; +use Red::DB; +use Red::Cli::Column; +unit class Red::Cli::UniqueConstraint; + +has $.table is rw; +has Str $.name is required; +has Str @.columns; + +multi method new($name, @columns) { + self.bless: :$name, :@columns +} + +multi method gist(::?CLASS:D:) { + "Red::Cli::UniqueConstraint.new(:name($!name), :columns<{ @!columns.join: " " }> #`( table => $!table.name() ))" +} + +method Str { $.gist } + +multi method WHICH(::?CLASS:D:) { + ValueObjAt.new: $.gist +} + +method to-code(Str :$schema-class) { + die "NYI"; +} diff --git a/lib/Red/Configuration.rakumod b/lib/Red/Configuration.rakumod new file mode 100644 index 00000000..5491a256 --- /dev/null +++ b/lib/Red/Configuration.rakumod @@ -0,0 +1,14 @@ +use Red; + +class Red::Configuration { + has Bool() $.debug = True; + has IO() $.lib-path = ".".IO; + has Str $.driver-name = "SQLite"; + has %.driver-attrs is Map; + has Red::Driver $.driver = database $!driver-name, |%!driver-attrs; + has @.requires; + has @.models; + has Red::Schema $.schema = schema @!models; +} + +use Configuration Red::Configuration; diff --git a/lib/Red/Driver/CommonSQL.rakumod b/lib/Red/Driver/CommonSQL.rakumod index a25c66ab..0cccaea2 100644 --- a/lib/Red/Driver/CommonSQL.rakumod +++ b/lib/Red/Driver/CommonSQL.rakumod @@ -16,11 +16,13 @@ use Red::AST::Between; use Red::AST::Divisible; use Red::AST::IsDefined; use Red::AST::CreateTable; +use Red::AST::CreateTableCli; use Red::AST::CreateView; use Red::AST::LastInsertedRow; use Red::AST::CreateColumn; use Red::AST::ChangeColumn; use Red::AST::DropColumn; +use Red::AST::DropTable; use Red::AST::TableComment; use Red::AST::StringFuncs; use Red::AST::DateTimeFuncs; @@ -30,6 +32,7 @@ use Red::AST::RollbackTransaction; use Red::AST::Generic::Prefix; use Red::AST::Generic::Postfix; use Red::AST::AddForeignKeyOnTable; +use Red::Cli::Table; use Red::Cli::Column; use Red::FromRelationship; use Red::Driver; @@ -113,6 +116,14 @@ has &.table-formatter is rw; method table-name-wrapper($name) { qq["$name"] } +multi method diff-to-ast($, "-", "table", Red::Cli::Table $_ --> Hash()) { + 10 => Red::AST::DropTable.new: table => .name +} + +multi method diff-to-ast($, "+", "table", Red::Cli::Table $_ --> Hash()) { + 0 => Red::AST::CreateTableCli.new: table => $_ +} + multi method diff-to-ast($table, "+", "col", Red::Cli::Column $_ --> Hash()) { 1 => Red::AST::CreateColumn.new( :$table, @@ -173,7 +184,7 @@ multi method diff-to-ast($table, "-", "col", Red::Cli::Column $_ --> Hash()) { ; } multi method diff-to-ast(@diff) { - @diff.map({ |self.diff-to-ast(|$_).pairs }).classify(|*.key, :as{ |.value }).sort.map: *.value + @diff.map({ |self.diff-to-ast(|$_).pairs }).classify(+*.key, :as{ |.value }).sort.map: *.value } method table-name-formatter($data) { @@ -705,6 +716,46 @@ multi method translate(Red::Column $_, "pk") { .name => [] } +multi method translate(Red::Cli::Column $_, "column-comment") { + (.comment ?? " COMMENT '$_'" !! "") => [] +} + +multi method translate(Red::Cli::Column $ (:$references where {!.keys}), "column-references") { + ("references { .
}({ . })" => []) with .references +} + +multi method translate(Red::Cli::Column $_, "column-references") { + "" => [] +} + +multi method translate(Red::Cli::Column $_, "column-auto-increment") { + (.auto-increment ?? "auto_increment" !! "") => [] +} + +multi method translate(Red::Cli::Column $_, "column-pk") { + (.pk ?? "primary key" !! "") => [] +} + +multi method translate(Red::Cli::Column $_, "nullable-column") { + (.nullable ?? "NULL" !! "NOT NULL") => [] +} + +multi method translate(Red::Cli::Column $_, "column-type") { + .type => [] +} + +multi method translate(Red::Cli::Column $_, "create-table-column-name") { + .name => [] +} + +multi method translate(Red::Cli::Column $_, "unique") { + .name => [] +} + +multi method translate(Red::Cli::Column $_, "pk") { + .name => [] +} + multi method translate(Red::AST::Cast $_, $context?) { when Red::AST::Value { .bind ?? self.translate(.value, "bind") !! qq|'{ .value }'| => [] @@ -794,6 +845,41 @@ multi method translate(Red::Column $_, "create-table") { .subst(/\s ** 2..*/, " ", :g) => [] } +multi method translate(Red::Cli::Column $_, "create-table") { + # has $.table is rw; + # has Str $.name is required; + # has Str $.formated-name = snake-to-kebab-case $!name; + # has Str $.type is required; + # has Str $.perl-type = get-RED-DB.type-for-sql: $!type.lc; + # has Bool $.nullable = True; + # has Bool $.pk = False; + # has Bool $.unique is rw = False; + # has $.references = {}; + ( + "create-table-column-name", + "column-type", + # ( + # .default + # ?? "column-default" + # !! "nullable-column" + # ), + "nullable-column", + (|( + "column-pk", + "column-auto-increment", + ) if .pk), + |("column-references" unless $*RED-IGNORE-REFERENCE), + |("column-comment" if self.comment-on-same-statement), + ) + .map(-> $context { + my $trans = self.translate($_, $context); + $trans.key + }) + .grep( *.defined ) + .join(" ") + .subst(/\s ** 2..*/, " ", :g) => [] +} + multi method translate(Red::Column $_, "column-name") { .name // "" => [] } multi method translate(Red::Column $_, "column-type") { @@ -853,6 +939,20 @@ multi method translate(Red::AST::CreateView $_, $context?) { }, } +multi method translate(Red::AST::DropTable $_, $context?) { + "DROP TABLE IF EXISTS { self.table-name-wrapper: .name }" => [], +} + +multi method translate(Red::AST::CreateTableCli $ (:table($_)), $context?) { + "CREATE TABLE { + self.table-name-wrapper: .name + } (\n{ + ( + |.columns.map({ self.translate($_, "create-table").key }), + ).join(",\n").indent: 3 + }\n)" => [], +} + multi method translate(Red::AST::CreateTable $_, $context?) { "CREATE{ " TEMPORARY" if .temp } TABLE { self.table-name-wrapper: .name diff --git a/lib/Red/Driver/SQLite.rakumod b/lib/Red/Driver/SQLite.rakumod index 90172784..db56b4ed 100644 --- a/lib/Red/Driver/SQLite.rakumod +++ b/lib/Red/Driver/SQLite.rakumod @@ -74,6 +74,16 @@ multi method join-type("right") { die "'RIGHT JOIN' is not supported by SQLite" #| Does this driver accept drop table cascade? multi method should-drop-cascade { False } +multi method translate(Red::AST::ChangeColumn $_, $context?) { + "ALTER TABLE { + .table + } ALTER COLUMN { + .name + } { + .nullable ?? "DROP NOT NULL" !! "SET NOT NULL" + }" => [] +} + multi method translate(Red::AST::Value $_ where .type ~~ Bool, $context? where $_ ne "bind") { (.value ?? 1 !! 0) => [] } diff --git a/lib/Red/Driver/SQLite/SQLiteMaster.rakumod b/lib/Red/Driver/SQLite/SQLiteMaster.rakumod index ba2086fa..834510dd 100644 --- a/lib/Red/Driver/SQLite/SQLiteMaster.rakumod +++ b/lib/Red/Driver/SQLite/SQLiteMaster.rakumod @@ -9,7 +9,7 @@ has Str $.sql is column; has ::?CLASS @.children is relationship{ .table } method tables(::?CLASS:U:) { - self.^all.grep: *.is-table + self.^all.grep: { .is-table && .name ne "sqlite_sequence" } } multi method indexes(::?CLASS:U:) { ::?CLASS.^all.grep: *.is-index } diff --git a/lib/Red/Driver/SQLite/SchemaReader.rakumod b/lib/Red/Driver/SQLite/SchemaReader.rakumod index c2280bef..c64818e6 100644 --- a/lib/Red/Driver/SQLite/SchemaReader.rakumod +++ b/lib/Red/Driver/SQLite/SchemaReader.rakumod @@ -1,3 +1,4 @@ +use Red::Operators; use Red::SchemaReader; use Red::Driver::SQLite::SQLiteMaster; @@ -11,9 +12,11 @@ method sqlite-master { Red::Driver::SQLite::SQLiteMaster } grammar SQL::CreateTable { rule TOP { :i + %% ";" } rule create-table { :i CREATE TABLE '(' ~ ')' + %% [ "," ] } - token name { :i \w+ } + proto token name {*} + multi token name:sym { :i \w+ } + multi token name:sym { '"' ~ '"' $=[<-["]>+] } rule type { :i ["(" ~ ")" \d+]? } - rule column { :i ? ? ? } + rule column { :i [ | | ]* } rule auto-increment { :i "AUTOINCREMENT" } proto rule modifier {*} multi rule modifier: { :i NULL } @@ -33,33 +36,36 @@ class SQL::CreateTable::Action { use Red::Cli::Column; method TOP($/) { make $».made } method create-table($/) { make Red::Cli::Table.new: name => $.made, columns => $».made } - method name($/) { make ~$/ } + method name:sym($/) { make ~$/ } + method name:sym($/) { make ~$ } method type($/) { make $/.Str.trim} method column($/) { + my %modifier is Map = $.map: *.made; + my %index-mod is Map = $.map: *.made; make Red::Cli::Column.new( - $.made, - $.made, - ($.made // True), - |$.made + name => $.made, + type => $.made, + |%modifier, + |%index-mod, ) } - method auto-increment { make ( :auto-increment ) } + method auto-increment($/) { make ( :auto-increment ) } method modifier:($/) { make ( :nullable ) } method modifier:($/) { make ( :!nullable ) } method index-mod:($/) { make ( :pk ) } method index-mod:($/) { make ( :references( %( table => $.made, column => $.made ) ) ) } method index-mod:($/) { make ( :unique ) } - method index:($/) { ... } + method index:($/) { make ( :id ) } method index:($/) { ... } method index:($/) { ... } } method tables-names { self.sqlite-master.tables.map: *.name } method indexes-of($table) { self.sqlite-master.find-table($table).indexes } -method table-definition($table) { +method table-definition($table --> Red::Cli::Table) { my $sql = self.sqlite-master.find-table($table).sql; my $list = self.table-definition-from-create-table($sql); - return unless $list; + return Red::Cli::Table unless $list; $list.head } multi method table-definition-from-create-table(Str:D $sql) { diff --git a/lib/Red/Schema.rakumod b/lib/Red/Schema.rakumod index c3230e67..fb42775d 100644 --- a/lib/Red/Schema.rakumod +++ b/lib/Red/Schema.rakumod @@ -68,3 +68,42 @@ method create(:$where) { } self } + +method plan(:$where is copy --> Array[Str]()) { + $where //= get-RED-DB; + my @sql; + my $diff = self.diff-from-db; + for $where.diff-to-ast: $diff -> @ast { + for @ast -> $ast { + @sql.push: .key for $where.translate: $ast + } + } + return @sql +} + +method update(:$where) { + red-do (:$where with $where), :transaction, { + do for $.plan[] -> Str $sql { + .execute: $sql + } + } + self +} + +method diff-from-db { + [ + |do for %!models.values -> $model { + next unless $model ~~ Red::Model; + |($model.^diff-from-db // []) + } + ] +} + +method diff-to-db { + [ + |do for %!models.values -> $model { + next unless $model ~~ Red::Model; + |($model.^diff-to-db // []) + } + ] +} diff --git a/t/01-tdd.rakutest b/t/01-tdd.rakutest index e226db8e..1507a583 100644 --- a/t/01-tdd.rakutest +++ b/t/01-tdd.rakutest @@ -437,11 +437,20 @@ ok !$cx-red-bool.value; is $cx-red-bool.message, ""; lives-ok { + my $*RED-DB = database "SQLite"; ok X.^describe; isa-ok X.^describe, Red::Cli::Table; - #ok X.^diff-to-db; - #ok X.^diff-from-db; + my @from-db = X.^diff-from-db; + is @from-db.elems, 1, "tabela ausente: uma entrada só"; + is @from-db[0][0..2], ["", "+", "table"], "sinal e kind corretos"; + isa-ok @from-db[0][3], Red::Cli::Table, "payload é a Table inteira"; + is @from-db[0][3].name, "x", "e é a tabela certa"; + + my @to-db = X.^diff-to-db; + is @to-db.elems, 1, "mesma coisa no sentido oposto"; + is @to-db[0][0..2], ["x", "-", "table"]; + isa-ok @to-db[0][3], Red::Cli::Table; model Y is table is rw { has Int $.int is column{:nullable} diff --git a/t/87-diff.rakutest b/t/87-diff.rakutest new file mode 100644 index 00000000..8f858e76 --- /dev/null +++ b/t/87-diff.rakutest @@ -0,0 +1,163 @@ +use v6; +use Test; +use Red; + +use lib $?FILE.IO.parent(1).add('lib'); + +my $*RED-DEBUG = $_ with %*ENV; +my $*RED-DEBUG-RESPONSE = $_ with %*ENV; +my @conf = (%*ENV // "SQLite").split(" "); +my $driver = @conf.shift; +my $*RED-DB = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => val .[1] } } ); + +my multi replace("+") { "-" } +my multi replace("-") { "+" } + +sub inversable-diff(Red::Model $a, Red::Model $b) is test-assertion { + subtest "inversable-diff $a.^name(), $b.^name()" => { + my @diff1 = sort $a.^diff: $b; + my @diff2 = sort $b.^diff: $a; + + is +@diff1, +@diff2, "diffs of same size"; + for (@diff1 Z @diff2) -> (@d1, @d2) { + is @(@d1.duckmap(&replace)), @d2, "the diff is inversible"; + } + } +} + +sub renamed-table-diff(Red::Model $a, Red::Model $b) is test-assertion { + subtest "renamed-table-diff $a.^name() ($a.^table()), $b.^name() ($b.^table())" => { + is $a.^diff($b)[0], [$a.^table, "+", "name", $b.^table], "{ $b.^table } created"; + is $a.^diff($b)[1], [$a.^table, "-", "name", $a.^table], "{ $a.^table } removed"; + is $b.^diff($a)[0], [$b.^table, "+", "name", $a.^table], "{ $a.^table } created"; + is $b.^diff($a)[1], [$b.^table, "-", "name", $b.^table], "{ $b.^table } removed"; + } +} + +sub renamed-column-diff(Red::Model $a, Red::Model $b, Str $c1, Str $c2) is test-assertion { + subtest "renamed-column-diff $a.^name(), $b.^name(), $c1, $c2" => { + my @a2b = $a.^diff: $b; + my @b2a = $b.^diff: $a; + is @a2b[0].tail.name, $c1, "$c1 removed"; + is @a2b[1].tail.name, $c2, "$c2 created"; + is @b2a[0].tail.name, $c1, "$c1 created"; + is @b2a[1].tail.name, $c2, "$c2 removed"; + } +} + +sub retyped-column-diff(Red::Model $a, Red::Model $b) is test-assertion { + subtest "retyped-column-diff $a.^name(), $b.^name()" => { + my @a2b = sort $a.^diff: $b; + my @b2a = sort duckmap &replace, $b.^diff: $a; + is +@a2b, 2, "has 2 differences"; + is +@b2a, 2, "has 2 differences"; + is @a2b, @b2a, "retyped reversible"; + } +} + +sub reflagged-column-diff(Red::Model $a, Red::Model $b, Str $flag) is test-assertion { + subtest "reflagged-column-diff $a.^name(), $b.^name(), $flag" => { + my @a2b = sort $a.^diff: $b; + my @b2a = sort duckmap &replace, $b.^diff: $a; + is +@a2b, 2, "has 2 differences"; + is +@b2a, 2, "has 2 differences"; + is .[3], $flag, "$flag has changed" for |@a2b, |@b2a; + is @a2b, @b2a, "reflagged reversible"; + } +} + +model E1 is table { + has UInt $.id is serial; + has Str $.a is column; +} + +is E1.^diff(E1), [], "no diff"; + +model E2 is table { + has UInt $.id is serial; + has Str $.a is column; + has Str $.b is column; +} + +model E3 is table { + has UInt $.id is serial; + has Str $.a is column; + has Str $.b is column; + has Str $.c is column; +} + +inversable-diff E1, E2; +inversable-diff E1, E3; +inversable-diff E2, E3; + +model E1-renamed is table { + has UInt $.id is serial; + has Str $.a is column; +} + +renamed-table-diff E1, E1-renamed; + +model E1-a-renamed is table { + has UInt $.id is serial; + has Str $.a2 is column; +} + +renamed-column-diff E1, E1-a-renamed, "a", "a2"; + +model E1-a-retyped is table { + has UInt $.id is serial; + has Int $.a is column; +} + +model E1-a-retyped2 is table { + has UInt $.id is serial; + has Str $.a is column{ :type }; +} + +retyped-column-diff E1, E1-a-retyped; +retyped-column-diff E1, E1-a-retyped2; + +model E1-a-nullable is table { + has UInt $.id is serial; + has Str $.a is column{ :nullable }; +} + +model E1-a-pk is table { + has UInt $.id is serial; + has Str $.a is serial; +} + +model E1-a-unique is table { + has UInt $.id is serial; + has Str $.a is unique; +} + +reflagged-column-diff E1, E1-a-nullable, "nullable"; +reflagged-column-diff E1, E1-a-pk, "pk"; +reflagged-column-diff E1, E1-a-unique, "unique"; + +schema(E1).drop; +E1.^create-table: :if-not-exists; + +is E1.^diff-from-db, [], "no difference from db"; +is E1.^diff-to-db, [], "no difference to db"; + +my @models = E1, E2, E3, E1-a-renamed, E1-a-retyped, E1-a-retyped2, E1-a-nullable, E1-a-pk, E1-a-unique; +for @models -> $model { + is $model.^diff-from-db, E1.^diff($model), "same diff if using models or DB"; + is $model.^diff-to-db, $model.^diff(E1), "same diff if using models or DB"; +} + +schema(E1).drop; + +for @models X @models -> ($a, $b) { + diag "create-table $a.^table() ($a.^name())"; + todo("SchemaReaders pk NYI", 2) if $a.^name ~~ /"-pk"$/; + todo("SchemaReaders unique NYI", 2) if $a.^name ~~ /"-unique"$/; + $a.^create-table; + is (try $b.^diff-from-db), $a.^diff($b), "$b.^name().^diff-from-db ~~ $a.^name().^diff\($b.^name())"; + is (try $b.^diff-to-db), $b.^diff($a), "$b.^name().^diff-from-db ~~ $b.^name().^diff\($a.^name())"; + schema($a).drop; +} + +done-testing; diff --git a/t/88-red-diff.rakutest b/t/88-red-diff.rakutest new file mode 100644 index 00000000..b53e03c6 --- /dev/null +++ b/t/88-red-diff.rakutest @@ -0,0 +1,28 @@ +use v6; +use Test; +use Red; +use Red::Cli; + +use lib $?FILE.IO.parent(1).add('lib'); + +my $*RED-DEBUG = $_ with %*ENV; +my $*RED-DEBUG-RESPONSE = $_ with %*ENV; +my @conf = (%*ENV // "SQLite").split(" "); +my $driver = @conf.shift; +my $*RED-DB = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => val .[1] } } ); + +model E1 is table { + has UInt $.id is serial; + has Str $.a is column; +} + +schema(E1).drop; + +lives-ok { prepare-database :models(E1) } + +is list-tables, ; + +is diff-to-db(E1), [], "No changes"; +is diff-from-db(E1), [], "No changes"; + +done-testing diff --git a/t/89-schema-update.rakutest b/t/89-schema-update.rakutest new file mode 100644 index 00000000..b9426540 --- /dev/null +++ b/t/89-schema-update.rakutest @@ -0,0 +1,84 @@ +use v6; +use Test; +use Red; + +plan 12; + +use lib $?FILE.IO.parent(1).add('lib'); + +my $*RED-DEBUG = $_ with %*ENV; +my $*RED-DEBUG-RESPONSE = $_ with %*ENV; +my @conf = (%*ENV // "SQLite").split(" "); +my $driver = @conf.shift; +my $*RED-DB = database $driver, |%( @conf.map: { do given .split: "=" { .[0] => val .[1] } } ); + +my Version() $ver = $*RED-DB.execute("select sqlite_version() as version").row.values.head; + +if $ver < v3.53 { + skip-rest "This SQLite version does not accept alter table alter column"; + exit +} + +model A { has UInt $.id is serial } + +model E1 is table { + has UInt $.id is serial; + has Str $.a is column; +} + +model E2 is table { + has UInt $.id is serial; + has Str $.a is column; + has Str $.b is column; +} + +model E3 is table { + has UInt $.id is serial; + has Str $.a is column; + has Str $.b is column; + has Str $.c is column; +} + +model E1-renamed is table { + has UInt $.id is serial; + has Str $.a is column; +} + +model E1-a-renamed is table { + has UInt $.id is serial; + has Str $.a2 is column; +} + +model E1-a-retyped is table { + has UInt $.id is serial; + has Int $.a is column; +} + +model E1-a-retyped2 is table { + has UInt $.id is serial; + has Str $.a is column{ :type }; +} + +model E1-a-nullable is table { + has UInt $.id is serial; + has Str $.a is column{ :nullable }; +} + +model E1-a-pk is table { + has UInt $.id is serial; + has Str $.a is serial; +} + +model E1-a-unique is table { + has UInt $.id is serial; + has Str $.a is unique; +} + +schema(E1).drop; +for E1, E2, E3 -> $model { + my $s1 = schema($model); + lives-ok({ $s1.plan }, "schema($model.^name()).plan lives"); + lives-ok({ $s1.update }, "schema($model.^name()).update lives"); + is $s1.diff-to-db, [], "schema($model.^name()).diff-to-db is []"; + is $s1.diff-from-db, [], "schema($model.^name()).diff-from-db is []"; +}