X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler%2FDeployMethod%2FSQL%2FTranslator.pm;h=c45dafdb0c226432539c71831dded86540d6931a;hb=91adde755e5808a1ec12bcf00e683e3754964cc9;hp=7d5f622ba067e4c0493715ba5b22d8ea5be6da46;hpb=7d0b0f2bd537805cbb09311fb23804d37b481de7;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 7d5f622..c45dafd 100644 --- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm +++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm @@ -43,7 +43,7 @@ has sql_translator_args => ( is => 'ro', default => sub { {} }, ); -has upgrade_directory => ( +has script_directory => ( isa => 'Str', is => 'ro', required => 1, @@ -65,13 +65,14 @@ has txn_wrap => ( has schema_version => ( is => 'ro', + isa => 'Str', lazy_build => 1, ); method _build_schema_version { $self->schema->schema_version } method __ddl_consume_with_prefix($type, $versions, $prefix) { - my $base_dir = $self->upgrade_directory; + my $base_dir = $self->script_directory; my $main = catfile( $base_dir, $type ); my $generic = catfile( $base_dir, '_generic' ); @@ -113,7 +114,7 @@ method _ddl_schema_consume_filenames($type, $version) { } method _ddl_schema_produce_filename($type, $version) { - my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version ); + my $dirname = catfile( $self->script_directory, $type, 'schema', $version ); mkpath($dirname) unless -d $dirname; return catfile( $dirname, '001-auto.sql' ); @@ -128,7 +129,7 @@ method _ddl_schema_down_consume_filenames($type, $versions) { } method _ddl_schema_up_produce_filename($type, $versions) { - my $dir = $self->upgrade_directory; + my $dir = $self->script_directory; my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions}); mkpath($dirname) unless -d $dirname; @@ -176,9 +177,9 @@ method _run_sql_and_perl($filenames) { my $fn = eval "$filedata"; use warnings; - if ($@) { + if ($@) { carp "$filename failed to compile: $@"; - } elsif (ref $fn eq 'CODE') { + } elsif (ref $fn eq 'CODE') { $fn->($self->schema) } else { carp "$filename should define an anonymouse sub that takes a schema but it didn't!"; @@ -195,7 +196,7 @@ method _run_sql_and_perl($filenames) { sub deploy { my $self = shift; - my $version = shift || $self->schema_version; + my $version = (shift @_ || {})->{version} || $self->schema_version; return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames( $self->storage->sqlt_type, @@ -203,12 +204,14 @@ sub deploy { )); } -sub preinstall_scripts { - my $self = shift; - my $version = shift || $self->schema_version; +sub preinstall { + my $self = shift; + my $args = shift; + my $version = $args->{version} || $self->schema_version; + my $storage_type = $args->{storage_type} || $self->storage->sqlt_type; my @files = @{$self->_ddl_preinstall_consume_filenames( - $self->storage->sqlt_type, + $storage_type, $version, )}; @@ -217,13 +220,13 @@ sub preinstall_scripts { if ( $filename =~ /^(.+)\.pl$/ ) { my $filedata = do { local( @ARGV, $/ ) = $filename; <> }; - no warnings 'redefine'; + no warnings 'redefine'; my $fn = eval "$filedata"; use warnings; - if ($@) { + if ($@) { carp "$filename failed to compile: $@"; - } elsif (ref $fn eq 'CODE') { + } elsif (ref $fn eq 'CODE') { $fn->() } else { carp "$filename should define an anonymous sub but it didn't!"; @@ -240,7 +243,7 @@ sub _prepare_install { my $to_file = shift; my $schema = $self->schema; my $databases = $self->databases; - my $dir = $self->upgrade_directory; + my $dir = $self->script_directory; my $version = $self->schema_version; my $sqlt = SQL::Translator->new({ @@ -280,7 +283,7 @@ sub _resultsource_install_filename { my ($self, $source_name) = @_; return sub { my ($self, $type, $version) = @_; - my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version ); + my $dirname = catfile( $self->script_directory, $type, 'schema', $version ); mkpath($dirname) unless -d $dirname; return catfile( $dirname, "001-auto-$source_name.sql" ); @@ -288,8 +291,9 @@ sub _resultsource_install_filename { } sub install_resultsource { - my ($self, $source, $version) = @_; - + my ($self, $args) = @_; + my $source = $args->{result_source}; + my $version = $args->{version}; my $rs_install_file = $self->_resultsource_install_filename($source->source_name); @@ -304,7 +308,7 @@ sub install_resultsource { sub prepare_resultsource_install { my $self = shift; - my $source = shift; + my $source = (shift @_)->{result_source}; my $filename = $self->_resultsource_install_filename($source->source_name); $self->_prepare_install({ @@ -318,20 +322,23 @@ sub prepare_deploy { } sub prepare_upgrade { - my ($self, $from_version, $to_version, $version_set) = @_; - $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up'); + my ($self, $args) = @_; + $self->_prepare_changegrade( + $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up' + ); } sub prepare_downgrade { - my ($self, $from_version, $to_version, $version_set) = @_; - - $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down'); + my ($self, $args) = @_; + $self->_prepare_changegrade( + $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down' + ); } method _prepare_changegrade($from_version, $to_version, $version_set, $direction) { my $schema = $self->schema; my $databases = $self->databases; - my $dir = $self->upgrade_directory; + my $dir = $self->script_directory; my $sqltargs = $self->sql_translator_args; my $schema_version = $self->schema_version; @@ -442,7 +449,7 @@ method _read_sql_file($file) { sub downgrade_single_step { my $self = shift; - my $version_set = shift @_; + my $version_set = (shift @_)->{version_set}; my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames( $self->storage->sqlt_type, @@ -454,7 +461,7 @@ sub downgrade_single_step { sub upgrade_single_step { my $self = shift; - my $version_set = shift @_; + my $version_set = (shift @_)->{version_set}; my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames( $self->storage->sqlt_type, @@ -493,7 +500,7 @@ like the best way to describe the layout is with the following example: $sql_migration_dir |- SQLite | |- down - | | `- 1-2 + | | `- 2-1 | | `- 001-auto.sql | |- schema | | `- 1 @@ -505,14 +512,14 @@ like the best way to describe the layout is with the following example: | `- 001-auto.sql |- _common | |- down - | | `- 1-2 + | | `- 2-1 | | `- 002-remove-customers.pl | `- up | `- 1-2 | `- 002-generate-customers.pl |- _generic | |- down - | | `- 1-2 + | | `- 2-1 | | `- 001-auto.sql | |- schema | | `- 1 @@ -523,8 +530,12 @@ like the best way to describe the layout is with the following example: | `- 002-create-stored-procedures.sql `- MySQL |- down - | `- 1-2 + | `- 2-1 | `- 001-auto.sql + |- preinstall + | `- 1 + | |- 001-create_database.pl + | `- 002-create_users_and_permissions.pl |- schema | `- 1 | `- 001-auto.sql @@ -551,6 +562,13 @@ 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 @@ -585,9 +603,9 @@ and generate the DDL. This is automatically created with L. The arguments that get passed to L when it's used. -=attr upgrade_directory +=attr script_directory -The directory (default C<'sql'>) that upgrades are stored in +The directory (default C<'sql'>) that scripts are stored in =attr databases