env_prefix => 'DBICDH'
});
-use Method::Signatures::Simple;
use Try::Tiny;
use SQL::Translator;
with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
+with 'DBIx::Class::DeploymentHandler::WithApplicatorDumple' => {
+ interface_role => 'DBIx::Class::DeploymentHandler::HandlesMigrationSchema',
+ class_name => 'DBIx::Class::DeploymentHandler::MigrationSchema::SchemaLoader',
+ delegate_name => 'schema_provider',
+ attributes_to_assume => ['schema'],
+ attributes_to_copy => [qw( schema )],
+ };
+
has ignore_ddl => (
isa => 'Bool',
is => 'ro',
lazy_build => 1,
);
-method _build_storage {
+sub _build_storage {
+ my $self = shift;
my $s = $self->schema->storage;
$s->_determine_driver;
$s
# 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 }
+sub _build_schema_version {
+ my $self = shift;
+ $self->schema->schema_version
+}
-method __ddl_consume_with_prefix($type, $versions, $prefix) {
+sub __ddl_consume_with_prefix {
+ my ($self, $type, $versions, $prefix) = @_;
my $base_dir = $self->script_directory;
my $main = catfile( $base_dir, $type );
return [@files{sort keys %files}]
}
-method _ddl_initialize_consume_filenames($type, $version) {
+sub _ddl_initialize_consume_filenames {
+ my ($self, $type, $version) = @_;
$self->__ddl_consume_with_prefix($type, [ $version ], 'initialize')
}
-method _ddl_schema_consume_filenames($type, $version) {
+sub _ddl_schema_consume_filenames {
+ my ($self, $type, $version) = @_;
$self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
}
-method _ddl_protoschema_deploy_consume_filenames($version) {
+sub _ddl_protoschema_deploy_consume_filenames {
+ my ($self, $version) = @_;
my $base_dir = $self->script_directory;
my $dir = catfile( $base_dir, '_source', 'deploy', $version);
return [@files{sort keys %files}]
}
-method _ddl_protoschema_upgrade_consume_filenames($versions) {
+sub _ddl_protoschema_upgrade_consume_filenames {
+ my ($self, $versions) = @_;
my $base_dir = $self->script_directory;
my $dir = catfile( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});
return [@files{sort keys %files}]
}
-method _ddl_protoschema_downgrade_consume_filenames($versions) {
+sub _ddl_protoschema_downgrade_consume_filenames {
+ my ($self, $versions) = @_;
my $base_dir = $self->script_directory;
my $dir = catfile( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});
return [@files{sort keys %files}]
}
-method _ddl_protoschema_produce_filename($version) {
+sub _ddl_protoschema_produce_filename {
+ my ($self, $version) = @_;
my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
mkpath($dirname) unless -d $dirname;
return catfile( $dirname, '001-auto.yml' );
}
-method _ddl_schema_produce_filename($type, $version) {
+sub _ddl_schema_produce_filename {
+ my ($self, $type, $version) = @_;
my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
mkpath($dirname) unless -d $dirname;
return catfile( $dirname, '001-auto.sql' );
}
-method _ddl_schema_upgrade_consume_filenames($type, $versions) {
+sub _ddl_schema_upgrade_consume_filenames {
+ my ($self, $type, $versions) = @_;
$self->__ddl_consume_with_prefix($type, $versions, 'upgrade')
}
-method _ddl_schema_downgrade_consume_filenames($type, $versions) {
+sub _ddl_schema_downgrade_consume_filenames {
+ my ($self, $type, $versions) = @_;
$self->__ddl_consume_with_prefix($type, $versions, 'downgrade')
}
-method _ddl_schema_upgrade_produce_filename($type, $versions) {
+sub _ddl_schema_upgrade_produce_filename {
+ my ($self, $type, $versions) = @_;
my $dir = $self->script_directory;
my $dirname = catfile( $dir, $type, 'upgrade', join q(-), @{$versions});
return catfile( $dirname, '001-auto.sql' );
}
-method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
+sub _ddl_schema_downgrade_produce_filename {
+ my ($self, $type, $versions, $dir) = @_;
my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
mkpath($dirname) unless -d $dirname;
return catfile( $dirname, '001-auto.sql');
}
-method _run_sql_array($sql) {
+sub _run_sql_array {
+ my ($self, $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];
+ $sql = [ _split_sql_chunk( @$sql ) ];
Dlog_trace { "Running SQL $_" } $sql;
foreach my $line (@{$sql}) {
return join "\n", @$sql
}
-method _run_sql($filename) {
+# split a chunk o' SQL into statements
+sub _split_sql_chunk {
+ my @sql = map { split /;\n/, $_ } @_;
+
+ for ( @sql ) {
+ # strip transactions
+ s/^(?:BEGIN|BEGIN TRANSACTION|COMMIT).*//mgi;
+
+ # trim whitespaces
+ s/^\s+|\s+$//mg;
+
+ # remove comments
+ s/^--.*//gm;
+
+ # remove blank lines
+ s/^\n//mg;
+
+ # put on single line
+ s/\n/ /g;
+ }
+
+ return @sql;
+}
+
+sub _run_sql {
+ my ($self, $filename) = @_;
log_debug { "Running SQL from $filename" };
return $self->_run_sql_array($self->_read_sql_file($filename));
}
-method _run_perl($filename, $versions) {
+sub _run_perl {
+ my ($self, $filename, $versions) = @_;
log_debug { "Running Perl from $filename" };
my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
Dlog_trace { "Running Perl $_" } $fn;
if ($@) {
- carp "$filename failed to compile: $@";
+ croak "$filename failed to compile: $@";
} elsif (ref $fn eq 'CODE') {
- $fn->($self->schema, $versions)
+ $fn->($self->migration_schema, $versions)
} else {
- carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
+ croak "$filename should define an anonymouse sub that takes a schema but it didn't!";
}
}
-method _run_sql_and_perl($filenames, $sql_to_run, $versions) {
+sub _run_sql_and_perl {
+ my ($self, $filenames, $sql_to_run, $versions) = @_;
my @files = @{$filenames};
my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
use warnings;
if ($@) {
- carp "$filename failed to compile: $@";
+ croak "$filename failed to compile: $@";
} elsif (ref $fn eq 'CODE') {
$fn->()
} else {
- carp "$filename should define an anonymous sub but it didn't!";
+ croak "$filename should define an anonymous sub but it didn't!";
}
} else {
croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!";
}
}
-method _sqldiff_from_yaml($from_version, $to_version, $db, $direction) {
+sub _sqldiff_from_yaml {
+ my ($self, $from_version, $to_version, $db, $direction) = @_;
my $dir = $self->script_directory;
my $sqltargs = {
add_drop_table => 1,
)];
}
-method _sql_from_yaml($sqltargs, $from_file, $db) {
+sub _sql_from_yaml {
+ my ($self, $sqltargs, $from_file, $db) = @_;
my $schema = $self->schema;
my $version = $self->schema_version;
);
}
-method _coderefs_per_files($files) {
+sub _coderefs_per_files {
+ my ($self, $files) = @_;
no warnings 'redefine';
[map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
}
-method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
+sub _prepare_changegrade {
+ my ($self, $from_version, $to_version, $version_set, $direction) = @_;
my $schema = $self->schema;
my $databases = $self->databases;
my $dir = $self->script_directory;
}
}
-method _read_sql_file($file) {
+sub _read_sql_file {
+ my ($self, $file) = @_;
return unless $file;
+ local $/ = undef; #sluuuuuurp
+
open my $fh, '<', $file;
- my @data = split /;\n/, join '', <$fh>;
- close $fh;
-
- @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;
-
- return \@data;
+ return [ _split_sql_chunk( <$fh> ) ];
}
sub downgrade_single_step {
projects / dbsrgits/DBIx-Class-DeploymentHandler.git / blobdiff