X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-DeploymentHandler.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler%2FDeployMethod%2FSQL%2FTranslator.pm;h=3dc9d9be94cece03e4c067177e2661978750335c;hp=02684fdc856556d71ec31f6684ac6f6102b756c4;hb=f9c6ab503d63cc70fa884cadb7ed5f105f1a7bc8;hpb=ff7f0e7d4be69cb76ad7fc18ac22249a189126a5 diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm index 02684fd..3dc9d9b 100644 --- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm +++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm @@ -1,22 +1,40 @@ package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator; use Moose; + +# ABSTRACT: Manage your SQL and Perl migrations in nicely laid out directories + +use autodie; +use Carp qw( carp croak ); +use DBIx::Class::DeploymentHandler::Logger; +use Log::Contextual qw(:log :dlog), -default_logger => + DBIx::Class::DeploymentHandler::Logger->new({ + env_prefix => 'DBICDH' + }); + use Method::Signatures::Simple; use Try::Tiny; + use SQL::Translator; require SQL::Translator::Diff; + require DBIx::Class::Storage; # loaded for type constraint -use autodie; -use File::Path; +use DBIx::Class::DeploymentHandler::Types; + +use File::Path 'mkpath'; +use File::Spec::Functions; with 'DBIx::Class::DeploymentHandler::HandlesDeploy'; -use Carp 'carp'; +has ignore_ddl => ( + isa => 'Bool', + is => 'ro', + default => undef, +); has schema => ( isa => 'DBIx::Class::Schema', is => 'ro', required => 1, - handles => [qw( schema_version )], ); has storage => ( @@ -31,12 +49,12 @@ method _build_storage { $s } -has sqltargs => ( +has sql_translator_args => ( isa => 'HashRef', is => 'ro', default => sub { {} }, ); -has upgrade_directory => ( +has script_directory => ( isa => 'Str', is => 'ro', required => 1, @@ -50,36 +68,56 @@ has databases => ( default => sub { [qw( MySQL SQLite PostgreSQL )] }, ); -has _filedata => ( - isa => 'ArrayRef[Str]', - is => 'rw', +has txn_wrap => ( + is => 'ro', + isa => 'Bool', + default => 1, ); -method __ddl_in_with_prefix($type, $versions, $prefix) { - my $base_dir = $self->upgrade_directory; +has schema_version => ( + is => 'ro', + isa => 'Str', + lazy_build => 1, +); + +# this will probably never get called as the DBICDH +# will be passing down a schema_version normally, which +# is built the same way, but we leave this in place +method _build_schema_version { $self->schema->schema_version } + +method __ddl_consume_with_prefix($type, $versions, $prefix) { + my $base_dir = $self->script_directory; - my $main = File::Spec->catfile( $base_dir, $type ); - my $generic = File::Spec->catfile( $base_dir, '_generic' ); - my $common = File::Spec->catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} ); + my $main = catfile( $base_dir, $type ); + my $generic = catfile( $base_dir, '_generic' ); + my $common = + catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} ); my $dir; if (-d $main) { - $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions}) + $dir = catfile($main, $prefix, join q(-), @{$versions}) } elsif (-d $generic) { - $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions}) + $dir = catfile($generic, $prefix, join q(-), @{$versions}); } else { - die 'PREPARE TO SQL' + croak "neither $main or $generic exist; please write/generate some SQL"; } - opendir my($dh), $dir; - my %files = map { $_ => "$dir/$_" } grep { /\.sql$/ && -f "$dir/$_" } readdir($dh); - closedir $dh; - + my %files; + try { + opendir my($dh), $dir; + %files = + map { $_ => "$dir/$_" } + grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" } + readdir $dh; + closedir $dh; + } catch { + die $_ unless $self->ignore_ddl; + }; if (-d $common) { opendir my($dh), $common; - for my $filename (grep { /\.sql$/ && -f "$common/$_" } readdir($dh)) { + for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) { unless ($files{$filename}) { - $files{$filename} = "$common/$_"; + $files{$filename} = catfile($common,$filename); } } closedir $dh; @@ -88,326 +126,419 @@ method __ddl_in_with_prefix($type, $versions, $prefix) { return [@files{sort keys %files}] } -method _ddl_schema_in_filenames($type, $version) { - $self->__ddl_in_with_prefix($type, [ $version ], 'schema') +method _ddl_preinstall_consume_filenames($type, $version) { + $self->__ddl_consume_with_prefix($type, [ $version ], 'preinstall') } -method _ddl_schema_out_filename($type, $version, $dir) { - my $dirname = File::Spec->catfile( - $dir, $type, 'schema', $version - ); - File::Path::mkpath($dirname) unless -d $dirname; - - return File::Spec->catfile( - $dirname, '001-auto.sql' - ); +method _ddl_schema_consume_filenames($type, $version) { + $self->__ddl_consume_with_prefix($type, [ $version ], 'schema') } -method _ddl_schema_up_in_filenames($type, $versions, $dir) { - $self->__ddl_in_with_prefix($type, $versions, 'up') -} +method _ddl_protoschema_up_consume_filenames($versions) { + my $base_dir = $self->script_directory; + + my $dir = catfile( $base_dir, '_protoschema', 'up', join q(-), @{$versions}); -method _ddl_schema_down_in_filenames($type, $versions, $dir) { - $self->__ddl_in_with_prefix($type, $versions, 'down') + return [] unless -d $dir; + + opendir my($dh), $dir; + my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh; + closedir $dh; + + return [@files{sort keys %files}] } -method _ddl_schema_up_out_filename($type, $versions, $dir) { - my $dirname = File::Spec->catfile( - $dir, $type, 'up', join( q(-), @{$versions} ) - ); - File::Path::mkpath($dirname) unless -d $dirname; +method _ddl_protoschema_down_consume_filenames($versions) { + my $base_dir = $self->script_directory; - return File::Spec->catfile( - $dirname, '001-auto.sql' - ); + my $dir = catfile( $base_dir, '_protoschema', 'down', join q(-), @{$versions}); + + return [] unless -d $dir; + + opendir my($dh), $dir; + my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh; + closedir $dh; + + return [@files{sort keys %files}] } -method _ddl_schema_down_out_filename($type, $versions, $dir) { - my $dirname = File::Spec->catfile( - $dir, $type, 'down', join( q(-), @{$versions} ) - ); - File::Path::mkpath($dirname) unless -d $dirname; +method _ddl_protoschema_produce_filename($version) { + my $dirname = catfile( $self->script_directory, '_protoschema', 'schema', $version ); + mkpath($dirname) unless -d $dirname; - return File::Spec->catfile( - $dirname, '001-auto.sql' - ); + return catfile( $dirname, '001-auto.yml' ); } -method _deployment_statements { - my $dir = $self->upgrade_directory; - my $schema = $self->schema; - my $type = $self->storage->sqlt_type; - my $sqltargs = $self->sqltargs; - my $version = $self->schema_version; +method _ddl_schema_produce_filename($type, $version) { + my $dirname = catfile( $self->script_directory, $type, 'schema', $version ); + mkpath($dirname) unless -d $dirname; - my @filenames = @{$self->_ddl_schema_in_filenames($type, $version)}; + return catfile( $dirname, '001-auto.sql' ); +} - for my $filename (@filenames) { - if(-f $filename) { - my $file; - open $file, q(<), $filename - or carp "Can't open $filename ($!)"; - my @rows = <$file>; - close $file; - return join '', @rows; - } - } +method _ddl_schema_up_consume_filenames($type, $versions) { + $self->__ddl_consume_with_prefix($type, $versions, 'up') +} - # sources needs to be a parser arg, but for simplicty allow at top level - # coming in - $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} - if exists $sqltargs->{sources}; +method _ddl_schema_down_consume_filenames($type, $versions) { + $self->__ddl_consume_with_prefix($type, $versions, 'down') +} - my $tr = SQL::Translator->new( - producer => "SQL::Translator::Producer::${type}", - %$sqltargs, - parser => 'SQL::Translator::Parser::DBIx::Class', - data => $schema, - ); +method _ddl_schema_up_produce_filename($type, $versions) { + my $dir = $self->script_directory; -#< frew> now note that deploy in the same file calls deployment_statements -#< ribasushi> right -#< frew> ALWAYS in array context -#< ribasushi> right, that's the only way -#< ribasushi> but create_ddl_dir -#< ribasushi> calls in scalar -#< ribasushi> because this is how you get stuff writable to a file -#< ribasushi> in list you get individual statements for dbh->do -#< frew> right -#< frew> ok... -#< frew> so for *me* I need it *always* in scalar -#< frew> because I *only* use it to generate the file -#< ribasushi> correct - my @ret; - my $wa = wantarray; - if ($wa) { - @ret = $tr->translate; - } - else { - $ret[0] = $tr->translate; - } + my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions}); + mkpath($dirname) unless -d $dirname; - $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error) - unless (@ret && defined $ret[0]); + 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 $wa ? @ret : $ret[0]; + return catfile( $dirname, '001-auto.sql'); } -sub _deploy { - my $self = shift; - my $storage = $self->storage; - - my $deploy = sub { - my $line = shift; -#< frew> k, also, we filter out comments and transaction stuff and blank lines -#< frew> is that really necesary? -#< frew> and what if I want to run my upgrade in a txn? seems like something you'd -# always want to do really -#< ribasushi> again - some stuff chokes -#< frew> ok, so I see filtering out -- and \s* -#< frew> but I think the txn filtering should be optional and default to NOT filter it -# out -#< ribasushi> then you have a problem -#< frew> tell me -#< ribasushi> someone runs a deploy in txn_do -#< ribasushi> the inner begin will blow up -#< frew> because it's a nested TXN? -#< ribasushi> (you an't begin twice on most dbs) -#< ribasushi> right -#< ribasushi> on sqlite - for sure -#< frew> so...read the docs and set txn_filter to true? -#< ribasushi> more like wrap deploy in a txn -#< frew> I like that better -#< ribasushi> and make sure the ddl has no literal txns in them -#< frew> sure -#< ribasushi> this way you have stuff under control -#< frew> so we have txn_wrap default to true -#< frew> and if people wanna do that by hand they can - - return if(!$line || $line =~ /^--|^BEGIN TRANSACTION|^COMMIT|^\s+$/); +method _run_sql_array($sql) { + my $storage = $self->storage; + + $sql = [grep { + $_ && # remove blank lines + !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's + } map { + s/^\s+//; s/\s+$//; # trim whitespace + join '', grep { !/^--/ } split /\n/ # remove comments + } @$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 try { - # do a dbh_do cycle here, as we need some error checking in - # place (even though we will ignore errors) $storage->dbh_do (sub { $_[1]->do($line) }); } catch { - carp "$_ (running '${line}')" + die "$_ (running line '$line')" } $storage->_query_end($line); - }; - my @statements = $self->_deployment_statements(); - if (@statements > 1) { - foreach my $statement (@statements) { - $deploy->( $statement ); - } } - elsif (@statements == 1) { - foreach my $line ( split(";\n", $statements[0])) { - $deploy->( $line ); + return join "\n", @$sql +} + +method _run_sql($filename) { + log_debug { "Running SQL from $filename" }; + return $self->_run_sql_array($self->_read_sql_file($filename)); +} + +method _run_perl($filename) { + log_debug { "Running Perl from $filename" }; + my $filedata = do { local( @ARGV, $/ ) = $filename; <> }; + + no warnings 'redefine'; + my $fn = eval "$filedata"; + use warnings; + Dlog_trace { "Running Perl $_" } $fn; + + if ($@) { + carp "$filename failed to compile: $@"; + } elsif (ref $fn eq 'CODE') { + $fn->($self->schema) + } else { + carp "$filename should define an anonymouse sub that takes a schema but it didn't!"; + } +} + +method _run_sql_and_perl($filenames, $sql_to_run) { + my @files = @{$filenames}; + my $guard = $self->schema->txn_scope_guard if $self->txn_wrap; + + $self->_run_sql_array($sql_to_run) if $self->ignore_ddl; + + my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:''; + FILENAME: + for my $filename (@files) { + if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) { + next FILENAME + } elsif ($filename =~ /\.sql$/) { + $sql .= $self->_run_sql($filename) + } elsif ( $filename =~ /\.pl$/ ) { + $self->_run_perl($filename) + } else { + croak "A file ($filename) got to deploy that wasn't sql or perl!"; } } + + $guard->commit if $self->txn_wrap; + + return $sql; } -sub prepare_install { +sub deploy { my $self = shift; - my $schema = $self->schema; - my $databases = $self->databases; - my $dir = $self->upgrade_directory; - my $sqltargs = $self->sqltargs; - my $version = $schema->schema_version; - - unless( -d $dir ) { - carp "Upgrade directory $dir does not exist, using ./\n"; - $dir = './'; + my $version = (shift @_ || {})->{version} || $self->schema_version; + log_info { "deploying version $version" }; + my $sqlt_type = $self->storage->sqlt_type; + my $sql; + if ($self->ignore_ddl) { + $sql = $self->_sql_from_yaml({}, + '_ddl_protoschema_produce_filename', $sqlt_type + ); } + return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames( + $sqlt_type, + $version, + ), $sql); +} +sub preinstall { + my $self = shift; + my $args = shift; + my $version = $args->{version} || $self->schema_version; + log_info { "preinstalling version $version" }; + my $storage_type = $args->{storage_type} || $self->storage->sqlt_type; - my $sqlt = SQL::Translator->new({ - add_drop_table => 1, + my @files = @{$self->_ddl_preinstall_consume_filenames( + $storage_type, + $version, + )}; + + for my $filename (@files) { + # We ignore sql for now (till I figure out what to do with it) + if ( $filename =~ /^(.+)\.pl$/ ) { + my $filedata = do { local( @ARGV, $/ ) = $filename; <> }; + + no warnings 'redefine'; + my $fn = eval "$filedata"; + use warnings; + + if ($@) { + carp "$filename failed to compile: $@"; + } elsif (ref $fn eq 'CODE') { + $fn->() + } else { + carp "$filename should define an anonymous sub but it didn't!"; + } + } else { + croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!"; + } + } +} + +method _sqldiff_from_yaml($from_version, $to_version, $db, $direction) { + my $dir = $self->script_directory; + my $sqltargs = { + add_drop_table => 1, ignore_constraint_names => 1, - ignore_index_names => 1, - parser => 'SQL::Translator::Parser::DBIx::Class', - %{$sqltargs || {}} - }); + ignore_index_names => 1, + %{$self->sql_translator_args} + }; - my $sqlt_schema = $sqlt->translate({ data => $schema }) - or $self->throw_exception ($sqlt->error); + my $source_schema; + { + my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir); - foreach my $db (@$databases) { - $sqlt->reset; - $sqlt->{schema} = $sqlt_schema; - $sqlt->producer($db); + # should probably be a croak + carp("No previous schema file found ($prefilename)") + unless -e $prefilename; - my $filename = $self->_ddl_schema_out_filename($db, $version, $dir); - if (-e $filename ) { - carp "Overwriting existing DDL file - $filename"; - unlink $filename; - } + my $t = SQL::Translator->new({ + %{$sqltargs}, + debug => 0, + trace => 0, + parser => 'SQL::Translator::Parser::YAML', + }); - my $output = $sqlt->translate; - if(!$output) { - carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); - next; - } - my $file; - unless( open $file, q(>), $filename ) { - $self->throw_exception("Can't open $filename for writing ($!)"); - next; - } - print {$file} $output; - close $file; + my $out = $t->translate( $prefilename ) + or croak($t->error); + + $source_schema = $t->schema; + + $source_schema->name( $prefilename ) + unless $source_schema->name; } -} -sub prepare_upgrade { - my ($self, $from_version, $to_version, $version_set) = @_; + my $dest_schema; + { + my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir); - $from_version ||= $self->db_version; - $to_version ||= $self->schema_version; + # should probably be a croak + carp("No next schema file found ($filename)") + unless -e $filename; - # for updates prepared automatically (rob's stuff) - # one would want to explicitly set $version_set to - # [$to_version] - $version_set ||= [$from_version, $to_version]; - my $schema = $self->schema; - my $databases = $self->databases; - my $dir = $self->upgrade_directory; - my $sqltargs = $self->sqltargs; + my $t = SQL::Translator->new({ + %{$sqltargs}, + debug => 0, + trace => 0, + parser => 'SQL::Translator::Parser::YAML', + }); - unless( -d $dir ) { - carp "Upgrade directory $dir does not exist, using ./\n"; - $dir = "./"; + my $out = $t->translate( $filename ) + or croak($t->error); + + $dest_schema = $t->schema; + + $dest_schema->name( $filename ) + unless $dest_schema->name; } - my $schema_version = $schema->schema_version; + my $transform_files_method = "_ddl_protoschema_${direction}_consume_filenames"; + my $transforms = $self->_coderefs_per_files( + $self->$transform_files_method([$from_version, $to_version]) + ); + $_->($source_schema, $dest_schema) for @$transforms; + + return [SQL::Translator::Diff::schema_diff( + $source_schema, $db, + $dest_schema, $db, + $sqltargs + )]; +} - $sqltargs = { - add_drop_table => 1, - ignore_constraint_names => 1, - ignore_index_names => 1, - %{$sqltargs} - }; +method _sql_from_yaml($sqltargs, $from_file, $db) { + my $schema = $self->schema; + my $version = $self->schema_version; - my $sqlt = SQL::Translator->new( $sqltargs ); + my $sqlt = SQL::Translator->new({ + add_drop_table => 0, + parser => 'SQL::Translator::Parser::YAML', + %{$sqltargs}, + producer => $db, + }); - $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); - my $sqlt_schema = $sqlt->translate({ data => $schema }) - or $self->throw_exception ($sqlt->error); + my $yaml_filename = $self->$from_file($version); + + my @sql = $sqlt->translate($yaml_filename); + if(!@sql) { + carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); + return undef; + } + return \@sql; +} + +sub _prepare_install { + my $self = shift; + my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} }; + my $from_file = shift; + my $to_file = shift; + my $dir = $self->script_directory; + my $databases = $self->databases; + my $version = $self->schema_version; foreach my $db (@$databases) { - $sqlt->reset; - $sqlt->{schema} = $sqlt_schema; - $sqlt->producer($db); - - my $prefilename = $self->_ddl_schema_out_filename($db, $from_version, $dir); - unless(-e $prefilename) { - carp("No previous schema file found ($prefilename)"); - next; - } + my $sql = $self->_sql_from_yaml($sqltargs, $from_file, $db ) or next; - my $diff_file = $self->_ddl_schema_up_out_filename($db, $version_set, $dir ); - if(-e $diff_file) { - carp("Overwriting existing up-diff file - $diff_file"); - unlink $diff_file; + my $filename = $self->$to_file($db, $version, $dir); + if (-e $filename ) { + carp "Overwriting existing DDL file - $filename"; + unlink $filename; } + open my $file, q(>), $filename; + print {$file} join ";\n", @$sql; + close $file; + } +} - my $source_schema; - { - my $t = SQL::Translator->new({ - %{$sqltargs}, - debug => 0, - trace => 0, - }); +sub _resultsource_install_filename { + my ($self, $source_name) = @_; + return sub { + my ($self, $type, $version) = @_; + my $dirname = catfile( $self->script_directory, $type, 'schema', $version ); + mkpath($dirname) unless -d $dirname; - $t->parser( $db ) # could this really throw an exception? - or $self->throw_exception ($t->error); + return catfile( $dirname, "001-auto-$source_name.sql" ); + } +} - my $out = $t->translate( $prefilename ) - or $self->throw_exception ($t->error); +sub _resultsource_protoschema_filename { + my ($self, $source_name) = @_; + return sub { + my ($self, $version) = @_; + my $dirname = catfile( $self->script_directory, '_protoschema', $version ); + mkpath($dirname) unless -d $dirname; - $source_schema = $t->schema; + return catfile( $dirname, "001-auto-$source_name.yml" ); + } +} - $source_schema->name( $prefilename ) - unless $source_schema->name; - } +sub install_resultsource { + my ($self, $args) = @_; + my $source = $args->{result_source}; + my $version = $args->{version}; + log_info { 'installing_resultsource ' . $source->source_name . ", version $version" }; + my $rs_install_file = + $self->_resultsource_install_filename($source->source_name); + + my $files = [ + $self->$rs_install_file( + $self->storage->sqlt_type, + $version, + ) + ]; + $self->_run_sql_and_perl($files); +} - # The "new" style of producers have sane normalization and can support - # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't - # And we have to diff parsed SQL against parsed SQL. - my $dest_schema = $sqlt_schema; +sub prepare_resultsource_install { + my $self = shift; + my $source = (shift @_)->{result_source}; + log_info { 'preparing install for resultsource ' . $source->source_name }; + + my $install_filename = $self->_resultsource_install_filename($source->source_name); + my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name); + $self->prepare_protoschema({ + parser_args => { sources => [$source->source_name], } + }, $proto_filename); + $self->_prepare_install({}, $proto_filename, $install_filename); +} - unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) { - my $t = SQL::Translator->new({ - %{$sqltargs}, - debug => 0, - trace => 0, - }); +sub prepare_deploy { + log_info { 'preparing deploy' }; + my $self = shift; + $self->prepare_protoschema({}, '_ddl_protoschema_produce_filename'); + $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename'); +} - $t->parser( $db ) # could this really throw an exception? - or $self->throw_exception ($t->error); +sub prepare_upgrade { + my ($self, $args) = @_; + log_info { + "preparing upgrade from $args->{from_version} to $args->{to_version}" + }; + $self->_prepare_changegrade( + $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up' + ); +} - my $filename = $self->_ddl_schema_out_filename($db, $to_version, $dir); - my $out = $t->translate( $filename ) - or $self->throw_exception ($t->error); +sub prepare_downgrade { + my ($self, $args) = @_; + log_info { + "preparing downgrade from $args->{from_version} to $args->{to_version}" + }; + $self->_prepare_changegrade( + $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down' + ); +} - $dest_schema = $t->schema; +method _coderefs_per_files($files) { + no warnings 'redefine'; + [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files] +} - $dest_schema->name( $filename ) - unless $dest_schema->name; - } +method _prepare_changegrade($from_version, $to_version, $version_set, $direction) { + my $schema = $self->schema; + my $databases = $self->databases; + my $dir = $self->script_directory; - my $diff = SQL::Translator::Diff::schema_diff( - $source_schema, $db, - $dest_schema, $db, - $sqltargs - ); - my $file; - unless(open $file, q(>), $diff_file) { - $self->throw_exception("Can't write to $diff_file ($!)"); - next; + my $schema_version = $self->schema_version; + my $diff_file_method = "_ddl_schema_${direction}_produce_filename"; + foreach my $db (@$databases) { + my $diff_file = $self->$diff_file_method($db, $version_set, $dir ); + if(-e $diff_file) { + carp("Overwriting existing $direction-diff file - $diff_file"); + unlink $diff_file; } - print {$file} $diff; + + open my $file, q(>), $diff_file; + print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)}; close $file; } } @@ -415,60 +546,333 @@ sub prepare_upgrade { method _read_sql_file($file) { return unless $file; - open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)"); - my @data = split /\n/, join '', <$fh>; + open my $fh, '<', $file; + my @data = split /;\n/, join '', <$fh>; close $fh; @data = grep { - $_ && - !/^--/ && - !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m - } split /;/, - join '', @data; + $_ && # remove blank lines + !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's + } map { + s/^\s+//; s/\s+$//; # trim whitespace + join '', grep { !/^--/ } split /\n/ # remove comments + } @data; return \@data; } -sub _upgrade_single_step { +sub downgrade_single_step { my $self = shift; - my @version_set = @{ shift @_ }; - my @upgrade_files = @{$self->_ddl_schema_up_in_filenames( - $self->storage->sqlt_type, - \@version_set, - )}; + my $version_set = (shift @_)->{version_set}; + Dlog_info { "downgrade_single_step'ing $_" } $version_set; + + my $sqlt_type = $self->storage->sqlt_type; + my $sql_to_run; + if ($self->ignore_ddl) { + $sql_to_run = $self->_sqldiff_from_yaml( + $version_set->[0], $version_set->[1], $sqlt_type, 'down', + ); + } + my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames( + $sqlt_type, + $version_set, + ), $sql_to_run); - for my $upgrade_file (@upgrade_files) { - unless (-f $upgrade_file) { - # croak? - carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n"; - return; - } + return ['', $sql]; +} - $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22 - $self->schema->txn_do(sub { $self->_do_upgrade }); +sub upgrade_single_step { + my $self = shift; + my $version_set = (shift @_)->{version_set}; + Dlog_info { "upgrade_single_step'ing $_" } $version_set; + + my $sqlt_type = $self->storage->sqlt_type; + my $sql_to_run; + if ($self->ignore_ddl) { + $sql_to_run = $self->_sqldiff_from_yaml( + $version_set->[0], $version_set->[1], $sqlt_type, 'up', + ); } + my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames( + $sqlt_type, + $version_set, + ), $sql_to_run); + return ['', $sql]; } -method _do_upgrade { $self->_run_upgrade(qr/.*?/) } +sub prepare_protoschema { + my $self = shift; + my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} }; + my $to_file = shift; + my $filename + = $self->$to_file($self->schema_version); + + # we do this because the code that uses this sets parser args, + # so we just need to merge in the package + $sqltargs->{parser_args}{package} = $self->schema; + my $sqlt = SQL::Translator->new({ + parser => 'SQL::Translator::Parser::DBIx::Class', + producer => 'SQL::Translator::Producer::YAML', + %{ $sqltargs }, + }); + + my $yml = $sqlt->translate; -method _run_upgrade($stm) { - return unless $self->_filedata; - my @statements = grep { $_ =~ $stm } @{$self->_filedata}; + croak("Failed to translate to YAML: " . $sqlt->error) + unless $yml; - for (@statements) { - $self->storage->debugobj->query_start($_) if $self->storage->debug; - $self->_apply_statement($_); - $self->storage->debugobj->query_end($_) if $self->storage->debug; + if (-e $filename ) { + carp "Overwriting existing DDL-YML file - $filename"; + unlink $filename; } -} -method _apply_statement($statement) { - # croak? - $self->storage->dbh->do($_) or carp "SQL was: $_" + open my $file, q(>), $filename; + print {$file} $yml; + close $file; } +__PACKAGE__->meta->make_immutable; + 1; +# vim: ts=2 sw=2 expandtab + __END__ -vim: ts=2 sw=2 expandtab +=head1 DESCRIPTION + +This class is the meat of L. It takes care +of generating serialized schemata as well as sql files to move from one +version of a schema to the rest. One of the hallmark features of this class +is that it allows for multiple sql files for deploy and upgrade, allowing +developers to fine tune deployment. In addition it also allows for perl +files to be run at any stage of the process. + +For basic usage see L. What's +documented here is extra fun stuff or private methods. + +=head1 DIRECTORY LAYOUT + +Arguably this is the best feature of L. It's +heavily based upon L, but has some extensions and +modifications, so even if you are familiar with it, please read this. I feel +like the best way to describe the layout is with the following example: + + $sql_migration_dir + |- SQLite + | |- down + | | `- 2-1 + | | `- 001-auto.sql + | |- schema + | | `- 1 + | | `- 001-auto.sql + | `- up + | |- 1-2 + | | `- 001-auto.sql + | `- 2-3 + | `- 001-auto.sql + |- _common + | |- down + | | `- 2-1 + | | `- 002-remove-customers.pl + | `- up + | `- 1-2 + | `- 002-generate-customers.pl + |- _generic + | |- down + | | `- 2-1 + | | `- 001-auto.sql + | |- schema + | | `- 1 + | | `- 001-auto.sql + | `- up + | `- 1-2 + | |- 001-auto.sql + | `- 002-create-stored-procedures.sql + `- MySQL + |- down + | `- 2-1 + | `- 001-auto.sql + |- preinstall + | `- 1 + | |- 001-create_database.pl + | `- 002-create_users_and_permissions.pl + |- schema + | `- 1 + | `- 001-auto.sql + `- up + `- 1-2 + `- 001-auto.sql + +So basically, the code + + $dm->deploy(1) + +on an C database that would simply run +C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>. Next, + + $dm->upgrade_single_step([1,2]) + +would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by +C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>. + +C<.pl> files don't have to be in the C<_common> directory, but most of the time +they should be, because perl scripts are generally be database independent. + +C<_generic> exists for when you for some reason are sure that your SQL is +generic enough to run on all databases. Good luck with that one. + +Note that unlike most steps in the process, C will not run SQL, as +there may not even be an database at preinstall time. It will run perl scripts +just like the other steps in the process, but nothing is passed to them. +Until people have used this more it will remain freeform, but a recommended use +of preinstall is to have it prompt for username and password, and then call the +appropriate C<< CREATE DATABASE >> commands etc. + +=head1 PERL SCRIPTS + +A perl script for this tool is very simple. It merely needs to contain an +anonymous sub that takes a L as it's only argument. +A very basic perl script might look like: + + #!perl + + use strict; + use warnings; + + sub { + my $schema = shift; + + $schema->resultset('Users')->create({ + name => 'root', + password => 'root', + }) + } + +=attr schema + +The L (B) that is used to talk to the database +and generate the DDL. + +=attr storage + +The L that is I used to talk to the database +and generate the DDL. This is automatically created with L. + +=attr sql_translator_args + +The arguments that get passed to L when it's used. + +=attr script_directory + +The directory (default C<'sql'>) that scripts are stored in + +=attr databases + +The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to +generate files for + +=attr txn_wrap + +Set to true (which is the default) to wrap all upgrades and deploys in a single +transaction. + +=attr schema_version + +The version the schema on your harddrive is at. Defaults to +C<< $self->schema->schema_version >>. + +=begin comment + +=head2 __ddl_consume_with_prefix + + $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' ) + +This is the meat of the multi-file upgrade/deploy stuff. It returns a list of +files in the order that they should be run for a generic "type" of upgrade. +You should not be calling this in user code. + +=head2 _ddl_schema_consume_filenames + + $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] ) + +Just a curried L. Get's a list of files for an +initial deploy. + +=head2 _ddl_schema_produce_filename + + $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] ) + +Returns a single file in which an initial schema will be stored. + +=head2 _ddl_schema_up_consume_filenames + + $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] ) + +Just a curried L. Get's a list of files for an +upgrade. + +=head2 _ddl_schema_down_consume_filenames + + $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] ) + +Just a curried L. Get's a list of files for a +downgrade. + +=head2 _ddl_schema_up_produce_filenames + + $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] ) + +Returns a single file in which the sql to upgrade from one schema to another +will be stored. + +=head2 _ddl_schema_down_produce_filename + + $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] ) + +Returns a single file in which the sql to downgrade from one schema to another +will be stored. + +=head2 _resultsource_install_filename + + my $filename_fn = $dm->_resultsource_install_filename('User'); + $dm->$filename_fn('SQLite', '1.00') + +Returns a function which in turn returns a single filename used to install a +single resultsource. Weird interface is convenient for me. Deal with it. + +=head2 _run_sql_and_perl + + $dm->_run_sql_and_perl([qw( list of filenames )]) + +Simply put, this runs the list of files passed to it. If the file ends in +C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file. + +Depending on L all of the files run will be wrapped in a single +transaction. + +=head2 _prepare_install + + $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' }) + +Generates the sql file for installing the database. First arg is simply +L args and the second is a coderef that returns the filename +to store the sql in. + +=head2 _prepare_changegrade + + $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up') + +Generates the sql file for migrating from one schema version to another. First +arg is the version to start from, second is the version to go to, third is the +L, and last is the +direction of the changegrade, be it 'up' or 'down'. + +=head2 _read_sql_file + + $dm->_read_sql_file('foo.sql') + +Reads a sql file and returns lines in an C. Strips out comments, +transactions, and blank lines. + +=end comment