use autodie;
use Carp qw( carp croak );
-use DBIx::Class::DeploymentHandler::Logger;
-use Log::Contextual qw(:log :dlog), -package_logger =>
- DBIx::Class::DeploymentHandler::Logger->new({
- env_prefix => 'DBICDH'
- });
+use DBIx::Class::DeploymentHandler::LogImporter qw(:log :dlog);
+use Context::Preserve;
-use Method::Signatures::Simple;
use Try::Tiny;
use SQL::Translator;
require DBIx::Class::Storage; # loaded for type constraint
use DBIx::Class::DeploymentHandler::Types;
-use File::Path 'mkpath';
-use File::Spec::Functions;
+use Path::Class qw(file dir);
with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
);
has schema => (
- isa => 'DBIx::Class::Schema',
is => 'ro',
required => 1,
);
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 );
+ my $main = dir( $base_dir, $type );
my $common =
- catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
+ dir( $base_dir, '_common', $prefix, join q(-), @{$versions} );
+
+ my $common_any =
+ dir( $base_dir, '_common', $prefix, '_any' );
my $dir;
if (-d $main) {
- $dir = catfile($main, $prefix, join q(-), @{$versions})
+ $dir = dir($main, $prefix, join q(-), @{$versions})
} else {
if ($self->ignore_ddl) {
return []
croak "$main does not exist; please write/generate some SQL"
}
}
+ my $dir_any = dir($main, $prefix, '_any');
my %files;
try {
} catch {
die $_ unless $self->ignore_ddl;
};
- if (-d $common) {
- opendir my($dh), $common;
- for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
+ for my $dirname (grep { -d $_ } $common, $common_any, $dir_any) {
+ opendir my($dh), $dirname;
+ for my $filename (grep { /\.(?:sql|pl)$/ && -f file($dirname,$_) } readdir $dh) {
unless ($files{$filename}) {
- $files{$filename} = catfile($common,$filename);
+ $files{$filename} = file($dirname,$filename);
}
}
closedir $dh;
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);
+ my $dir = dir( $base_dir, '_source', 'deploy', $version);
return [] unless -d $dir;
opendir my($dh), $dir;
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});
+ my $dir = dir( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});
return [] unless -d $dir;
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});
+ my $dir = dir( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});
return [] unless -d $dir;
return [@files{sort keys %files}]
}
-method _ddl_protoschema_produce_filename($version) {
- my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
- mkpath($dirname) unless -d $dirname;
+sub _ddl_protoschema_produce_filename {
+ my ($self, $version) = @_;
+ my $dirname = dir( $self->script_directory, '_source', 'deploy', $version );
+ $dirname->mkpath unless -d $dirname;
- return catfile( $dirname, '001-auto.yml' );
+ return "" . file( $dirname, '001-auto.yml' );
}
-method _ddl_schema_produce_filename($type, $version) {
- my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
- mkpath($dirname) unless -d $dirname;
+sub _ddl_schema_produce_filename {
+ my ($self, $type, $version) = @_;
+ my $dirname = dir( $self->script_directory, $type, 'deploy', $version );
+ $dirname->mkpath unless -d $dirname;
- return catfile( $dirname, '001-auto.sql' );
+ return "" . file( $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});
- mkpath($dirname) unless -d $dirname;
+ my $dirname = dir( $dir, $type, 'upgrade', join q(-), @{$versions});
+ $dirname->mkpath unless -d $dirname;
- return catfile( $dirname, '001-auto.sql' );
+ return "" . file( $dirname, '001-auto.sql' );
}
-method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
- my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
- mkpath($dirname) unless -d $dirname;
+sub _ddl_schema_downgrade_produce_filename {
+ my ($self, $type, $versions, $dir) = @_;
+ my $dirname = dir( $dir, $type, 'downgrade', join q(-), @{$versions} );
+ $dirname->mkpath unless -d $dirname;
- return catfile( $dirname, '001-auto.sql');
+ return "" . file( $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+//gm;
+ s/\s+$//gm;
+
+ # remove comments
+ s/^--.*//gm;
+
+ # remove blank lines
+ s/^\n//gm;
+
+ # put on single line
+ s/\n/ /g;
+ }
+
+ return grep $_, @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) {
+sub _load_sandbox {
+ my $_file = shift;
+
+ my $_package = $_file;
+ $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", ord($1))/eg;
+
+ my $fn = eval sprintf <<'END_EVAL', $_package;
+package DBICDH::Sandbox::%s;
+{
+ our $app;
+ $app ||= require $_file;
+ if ( !$app && ( my $error = $@ || $! )) { die $error; }
+ $app;
+}
+END_EVAL
+
+ croak $@ if $@;
+
+ croak "$_file should define an anonymous sub that takes a schema but it didn't!"
+ unless ref $fn && ref $fn eq 'CODE';
+
+ return $fn;
+}
+
+sub _run_perl {
+ my ($self, $filename, $versions) = @_;
log_debug { "Running Perl from $filename" };
- my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
- no warnings 'redefine';
- my $fn = eval "$filedata";
- use warnings;
+ my $fn = _load_sandbox($filename);
+
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!";
- }
+ $fn->($self->schema, $versions)
}
-method _run_sql_and_perl($filenames, $sql_to_run) {
- my @files = @{$filenames};
- my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
+sub txn_do {
+ my ( $self, $code ) = @_;
+ return $code->() unless $self->txn_wrap;
- $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
+ my $guard = $self->schema->txn_scope_guard;
- 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!";
- }
- }
+ return preserve_context { $code->() } after => sub { $guard->commit };
+}
- $guard->commit if $self->txn_wrap;
+sub _run_sql_and_perl {
+ my ($self, $filenames, $sql_to_run, $versions) = @_;
+ my @files = @{$filenames};
+ $self->txn_do(sub {
+ $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 (map file($_), @files) {
+ if ($self->ignore_ddl && $filename->basename =~ /^[^-]*-auto.*\.sql$/) {
+ next FILENAME
+ } elsif ($filename =~ /\.sql$/) {
+ $sql .= $self->_run_sql($filename)
+ } elsif ( $filename =~ /\.pl$/ ) {
+ $self->_run_perl($filename, $versions)
+ } else {
+ croak "A file ($filename) got to deploy that wasn't sql or perl!";
+ }
+ }
- return $sql;
+ return $sql;
+ });
}
sub deploy {
log_info { "deploying version $version" };
my $sqlt_type = $self->storage->sqlt_type;
my $sql;
+ my $sqltargs = $self->sql_translator_args;
if ($self->ignore_ddl) {
- $sql = $self->_sql_from_yaml({},
+ $sql = $self->_sql_from_yaml($sqltargs,
'_ddl_protoschema_deploy_consume_filenames', $sqlt_type
);
}
return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
$sqlt_type,
$version,
- ), $sql);
+ ), $sql, [$version]);
}
sub initialize {
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;
my @sql;
my $actual_file = $self->$from_file($version);
- for my $yaml_filename (@{
+ for my $yaml_filename (@{(
DlogS_trace { "generating SQL from Serialized SQL Files: $_" }
(ref $actual_file?$actual_file:[$actual_file])
- }) {
+ )}) {
my $sqlt = SQL::Translator->new({
add_drop_table => 0,
parser => 'SQL::Translator::Parser::YAML',
}
}
open my $file, q(>), $filename;
- print {$file} join ";\n", @$sql;
+ print {$file} join ";\n", @$sql, '';
close $file;
}
}
my ($self, $source_name) = @_;
return sub {
my ($self, $type, $version) = @_;
- my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
- mkpath($dirname) unless -d $dirname;
+ my $dirname = dir( $self->script_directory, $type, 'deploy', $version );
+ $dirname->mkpath unless -d $dirname;
- return catfile( $dirname, "001-auto-$source_name.sql" );
+ return "" . file( $dirname, "001-auto-$source_name.sql" );
}
}
my ($self, $source_name) = @_;
return sub {
my ($self, $version) = @_;
- my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
- mkpath($dirname) unless -d $dirname;
+ my $dirname = dir( $self->script_directory, '_source', 'deploy', $version );
+ $dirname->mkpath unless -d $dirname;
- return catfile( $dirname, "001-auto-$source_name.yml" );
+ return "" . file( $dirname, "001-auto-$source_name.yml" );
}
}
sub install_resultsource {
my ($self, $args) = @_;
- my $source = $args->{result_source};
- my $version = $args->{version};
+ my $source = $args->{result_source}
+ or die 'result_source must be passed to install_resultsource';
+ my $version = $args->{version}
+ or die 'version must be passed to install_resultsource';
log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
my $rs_install_file =
$self->_resultsource_install_filename($source->source_name);
$version,
)
];
- $self->_run_sql_and_perl($files);
+ $self->_run_sql_and_perl($files, '', [$version]);
}
sub prepare_resultsource_install {
);
}
-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;
- 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;
+ local $/ = undef; #sluuuuuurp
- return \@data;
+ open my $fh, '<', $file;
+ return [ _split_sql_chunk( <$fh> ) ];
}
sub downgrade_single_step {
my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames(
$sqlt_type,
$version_set,
- ), $sql_to_run);
+ ), $sql_to_run, $version_set);
return ['', $sql];
}
my $sql = $self->_run_sql_and_perl($self->_ddl_schema_upgrade_consume_filenames(
$sqlt_type,
$version_set,
- ), $sql_to_run);
+ ), $sql_to_run, $version_set);
return ['', $sql];
}
# 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;
+ my $yml = $sqlt->translate(data => $self->schema);
croak("Failed to translate to YAML: " . $sqlt->error)
unless $yml;
| | `- 002-remove-customers.pl
| `- upgrade
| `- 1-2
- | `- 002-generate-customers.pl
+ | | `- 002-generate-customers.pl
+ | `- _any
+ | `- 999-bump-action.pl
`- MySQL
|- downgrade
| `- 2-1
$dm->upgrade_single_step([1,2])
would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by
-C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>.
+C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>, and
+finally punctuated by
+C<$sql_migration_dir/_common/upgrade/_any/999-bump-action.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 database independent.
your storage type is. If you are not sure what your storage type is, take a
look at the producers listed for L<SQL::Translator>. Also note, C<_common>
is a special case. C<_common> will get merged into whatever other files you
-already have. This directory can containt the following directories itself:
+already have. This directory can contain the following directories itself:
=over 2
=back
+Note that there can be an C<_any> in the place of any of the versions (like
+C<1-2> or C<1>), which means those scripts will be run B<every> time. So if
+you have an C<_any> in C<_common/upgrade>, that script will get run for every
+upgrade.
+
=head1 PERL SCRIPTS
A perl script for this tool is very simple. It merely needs to contain an
-anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
+anonymous sub that takes a L<DBIx::Class::Schema> and the version set as it's
+arguments.
+
A very basic perl script might look like:
#!perl
use strict;
use warnings;
- sub {
+ use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
+ 'schema_from_schema_loader';
+
+ schema_from_schema_loader({ naming => 'v4' }, sub {
my $schema = shift;
+ # [1] for deploy, [1,2] for upgrade or downgrade, probably used with _any
+ my $versions = shift;
+
$schema->resultset('Users')->create({
name => 'root',
password => 'root',
})
- }
+ })
+
+Note that the above uses
+L<DBIx::Class::DeploymentHanlder::DeployMethod::SQL::Translator::ScriptHelpers/schema_from_schema_loader>.
+Using a raw coderef is strongly discouraged as it is likely to break as you
+modify your schema.
=attr ignore_ddl
The version the schema on your harddrive is at. Defaults to
C<< $self->schema->schema_version >>.
+
+=head1 SEE ALSO
+
+This class is an implementation of
+L<DBIx::Class::DeploymentHandler::HandlesDeploy>. Pretty much all the
+documentation is there.
projects / dbsrgits/DBIx-Class-DeploymentHandler.git / blobdiff