X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler%2FDeployMethod%2FSQL%2FTranslator.pm;h=c2bbc473a7ce10e671b559f3ce1998315f12c206;hb=7e08eddd832a00dbe52d8f1ba90ea486c48f7ab1;hp=b6e78a3a1020552b34b5feb64840c0d9ced2f219;hpb=8465e76797613fa0b9c85365c03d26cacbaab31a;p=dbsrgits%2FDBIx-Class-DeploymentHandler.git diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm index b6e78a3..c2bbc47 100644 --- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm +++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm @@ -79,13 +79,6 @@ has schema_version => ( # is built the same way, but we leave this in place method _build_schema_version { $self->schema->schema_version } -has _json => ( - is => 'ro', - lazy_build => 1, -); - -sub _build__json { require JSON; JSON->new->pretty } - method __ddl_consume_with_prefix($type, $versions, $prefix) { my $base_dir = $self->script_directory; @@ -128,11 +121,18 @@ method _ddl_schema_consume_filenames($type, $version) { $self->__ddl_consume_with_prefix($type, [ $version ], 'schema') } +method _ddl_protoschema_produce_filename($version) { + my $dirname = catfile( $self->script_directory, '_protoschema', $version ); + mkpath($dirname) unless -d $dirname; + + return catfile( $dirname, '001-auto.yml' ); +} + method _ddl_schema_produce_filename($type, $version) { my $dirname = catfile( $self->script_directory, $type, 'schema', $version ); mkpath($dirname) unless -d $dirname; - return catfile( $dirname, '001-auto.sql-json' ); + return catfile( $dirname, '001-auto.sql' ); } method _ddl_schema_up_consume_filenames($type, $versions) { @@ -149,14 +149,15 @@ method _ddl_schema_up_produce_filename($type, $versions) { my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions}); mkpath($dirname) unless -d $dirname; - return catfile( $dirname, '001-auto.sql-json' ); + return catfile( $dirname, '001-auto.sql' + ); } method _ddl_schema_down_produce_filename($type, $versions, $dir) { my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} ); mkpath($dirname) unless -d $dirname; - return catfile( $dirname, '001-auto.sql-json'); + return catfile( $dirname, '001-auto.sql'); } method _run_sql_array($sql) { @@ -170,7 +171,7 @@ method _run_sql_array($sql) { join '', grep { !/^--/ } split /\n/ # remove comments } @$sql]; - Dlog_trace { "[DBICDH] Running SQL $_" } $sql; + Dlog_trace { "Running SQL $_" } $sql; foreach my $line (@{$sql}) { $storage->_query_start($line); # the whole reason we do this is so that we can see the line that was run @@ -186,18 +187,18 @@ method _run_sql_array($sql) { } method _run_sql($filename) { - log_debug { "[DBICDH] Running SQL from $filename" }; + log_debug { "Running SQL from $filename" }; return $self->_run_sql_array($self->_read_sql_file($filename)); } method _run_perl($filename) { - log_debug { "[DBICDH] Running Perl from $filename" }; + log_debug { "Running Perl from $filename" }; my $filedata = do { local( @ARGV, $/ ) = $filename; <> }; no warnings 'redefine'; my $fn = eval "$filedata"; use warnings; - Dlog_trace { "[DBICDH] Running Perl $_" } $fn; + Dlog_trace { "Running Perl $_" } $fn; if ($@) { carp "$filename failed to compile: $@"; @@ -207,15 +208,19 @@ method _run_perl($filename) { carp "$filename should define an anonymouse sub that takes a schema but it didn't!"; } } +{ + my $json; + + method _run_serialized_sql($filename, $type) { + if ($type eq 'json') { + require JSON; + $json ||= JSON->new->pretty; + my @sql = @{$json->decode($filename)}; + } else { + croak "A file ($filename) got to deploy that wasn't sql or perl!"; + } + } -method _run_serialized_sql($filename, $type) { - if (lc $type eq 'json') { - return $self->_run_sql_array($self->_json->decode( - do { local( @ARGV, $/ ) = $filename; <> } # slurp - )) - } else { - croak "$type is not one of the supported serialzed types" - } } method _run_sql_and_perl($filenames) { @@ -243,7 +248,7 @@ method _run_sql_and_perl($filenames) { sub deploy { my $self = shift; my $version = (shift @_ || {})->{version} || $self->schema_version; - log_info { "[DBICDH] deploying version $version" }; + log_info { "deploying version $version" }; return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames( $self->storage->sqlt_type, @@ -255,7 +260,7 @@ sub preinstall { my $self = shift; my $args = shift; my $version = $args->{version} || $self->schema_version; - log_info { "[DBICDH] preinstalling version $version" }; + log_info { "preinstalling version $version" }; my $storage_type = $args->{storage_type} || $self->storage->sqlt_type; my @files = @{$self->_ddl_preinstall_consume_filenames( @@ -295,20 +300,15 @@ sub _prepare_install { my $version = $self->schema_version; my $sqlt = SQL::Translator->new({ - no_comments => 1, add_drop_table => 1, - ignore_constraint_names => 1, - ignore_index_names => 1, - parser => 'SQL::Translator::Parser::DBIx::Class', + parser => 'SQL::Translator::Parser::YAML', %{$sqltargs} }); - my $sqlt_schema = $sqlt->translate( data => $schema ) - or croak($sqlt->error); + my $yaml_filename = $self->_ddl_protoschema_produce_filename($version); foreach my $db (@$databases) { $sqlt->reset; - $sqlt->{schema} = $sqlt_schema; $sqlt->producer($db); my $filename = $self->$to_file($db, $version, $dir); @@ -317,7 +317,7 @@ sub _prepare_install { unlink $filename; } - my $sql = $self->_generate_final_sql($sqlt); + my $sql = $sqlt->translate($yaml_filename); if(!$sql) { carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); next; @@ -328,11 +328,6 @@ sub _prepare_install { } } -method _generate_final_sql($sqlt) { - my @output = $sqlt->translate; - $self->_json->encode(\@output); -} - sub _resultsource_install_filename { my ($self, $source_name) = @_; return sub { @@ -340,7 +335,7 @@ sub _resultsource_install_filename { my $dirname = catfile( $self->script_directory, $type, 'schema', $version ); mkpath($dirname) unless -d $dirname; - return catfile( $dirname, "001-auto-$source_name.sql-json" ); + return catfile( $dirname, "001-auto-$source_name.sql" ); } } @@ -348,7 +343,7 @@ sub install_resultsource { my ($self, $args) = @_; my $source = $args->{result_source}; my $version = $args->{version}; - log_info { '[DBICDH] installing_resultsource ' . $source->source_name . ", version $version" }; + log_info { 'installing_resultsource ' . $source->source_name . ", version $version" }; my $rs_install_file = $self->_resultsource_install_filename($source->source_name); @@ -364,7 +359,7 @@ sub install_resultsource { sub prepare_resultsource_install { my $self = shift; my $source = (shift @_)->{result_source}; - log_info { '[DBICDH] preparing install for resultsource ' . $source->source_name }; + log_info { 'preparing install for resultsource ' . $source->source_name }; my $filename = $self->_resultsource_install_filename($source->source_name); $self->_prepare_install({ @@ -373,16 +368,16 @@ sub prepare_resultsource_install { } sub prepare_deploy { - log_info { '[DBICDH] preparing deploy' }; + log_info { 'preparing deploy' }; my $self = shift; + $self->_generate_protoschema; $self->_prepare_install({}, '_ddl_schema_produce_filename'); } sub prepare_upgrade { my ($self, $args) = @_; log_info { - '[DBICDH] preparing upgrade ' . - "from $args->{from_version} to $args->{to_version}" + "preparing upgrade from $args->{from_version} to $args->{to_version}" }; $self->_prepare_changegrade( $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up' @@ -392,8 +387,7 @@ sub prepare_upgrade { sub prepare_downgrade { my ($self, $args) = @_; log_info { - '[DBICDH] preparing downgrade ' . - "from $args->{from_version} to $args->{to_version}" + "preparing downgrade from $args->{from_version} to $args->{to_version}" }; $self->_prepare_changegrade( $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down' @@ -410,7 +404,6 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction $sqltargs = { add_drop_table => 1, - no_comments => 1, ignore_constraint_names => 1, ignore_index_names => 1, %{$sqltargs} @@ -450,8 +443,7 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction $t->parser( $db ) # could this really throw an exception? or croak($t->error); - my $sql = $self->_default_read_sql_file_as_string($prefilename); - my $out = $t->translate( \$sql ) + my $out = $t->translate( $prefilename ) or croak($t->error); $source_schema = $t->schema; @@ -476,8 +468,7 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction or croak($t->error); my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir); - my $sql = $self->_default_read_sql_file_as_string($filename); - my $out = $t->translate( \$sql ) + my $out = $t->translate( $filename ) or croak($t->error); $dest_schema = $t->schema; @@ -486,23 +477,17 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction unless $dest_schema->name; } + my $diff = SQL::Translator::Diff::schema_diff( + $source_schema, $db, + $dest_schema, $db, + $sqltargs + ); open my $file, q(>), $diff_file; - print {$file} - $self->_generate_final_diff($source_schema, $dest_schema, $db, $sqltargs); + print {$file} $diff; close $file; } } -method _generate_final_diff($source_schema, $dest_schema, $db, $sqltargs) { - $self->_json->encode([ - SQL::Translator::Diff::schema_diff( - $source_schema, $db, - $dest_schema, $db, - $sqltargs - ) - ]) -} - method _read_sql_file($file) { return unless $file; @@ -510,19 +495,21 @@ method _read_sql_file($file) { my @data = split /;\n/, join '', <$fh>; close $fh; - return \@data; -} + @data = grep { + $_ && # remove blank lines + !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's + } map { + s/^\s+//; s/\s+$//; # trim whitespace + join '', grep { !/^--/ } split /\n/ # remove comments + } @data; -method _default_read_sql_file_as_string($file) { - return join q(), map "$_;\n", @{$self->_json->decode( - do { local( @ARGV, $/ ) = $file; <> } # slurp - )}; + return \@data; } sub downgrade_single_step { my $self = shift; my $version_set = (shift @_)->{version_set}; - Dlog_info { qq([DBICDH] downgrade_single_step'ing $_) } $version_set; + Dlog_info { "downgrade_single_step'ing $_" } $version_set; my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames( $self->storage->sqlt_type, @@ -535,7 +522,7 @@ sub downgrade_single_step { sub upgrade_single_step { my $self = shift; my $version_set = (shift @_)->{version_set}; - Dlog_info { qq([DBICDH] upgrade_single_step'ing $_) } $version_set; + Dlog_info { "upgrade_single_step'ing $_" } $version_set; my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames( $self->storage->sqlt_type, @@ -544,6 +531,33 @@ sub upgrade_single_step { return ['', $sql]; } +sub _generate_protoschema { + my $self = shift; + my $filename + = $self->_ddl_protoschema_produce_filename($self->schema_version); + + my $sqlt = SQL::Translator->new({ + parser => 'SQL::Translator::Parser::DBIx::Class', + producer => 'SQL::Translator::Producer::YAML', + parser_args => { package => $self->schema }, + %{ $self->sql_translator_args } + }); + + my $yml = $sqlt->translate; + + croak("Failed to translate to YAML: " . $sqlt->error) + unless $yml; + + if (-e $filename ) { + carp "Overwriting existing DDL-YML file - $filename"; + unlink $filename; + } + + open my $file, q(>), $filename; + print {$file} $yml; + close $file; +} + __PACKAGE__->meta->make_immutable; 1;