package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
-use Moose;
+use Moo;
# ABSTRACT: Manage your SQL and Perl migrations in nicely laid out directories
+use Sub::Quote 'quote_sub';
+use MooX::Types::MooseLike::Base qw(ArrayRef Bool HashRef Str);
+
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 Try::Tiny;
use SQL::Translator;
require SQL::Translator::Diff;
-require DBIx::Class::Storage; # loaded for type constraint
-use DBIx::Class::DeploymentHandler::Types;
+use DBIx::Class::DeploymentHandler::Types 'Storage';
use File::Path 'mkpath';
use File::Spec::Functions;
with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
has ignore_ddl => (
- isa => 'Bool',
+ isa => Bool,
is => 'ro',
- default => undef,
);
has force_overwrite => (
- isa => 'Bool',
+ isa => Bool,
is => 'ro',
- default => undef,
);
has schema => (
- isa => 'DBIx::Class::Schema',
is => 'ro',
required => 1,
);
has storage => (
- isa => 'DBIx::Class::Storage',
+ isa => Storage,
is => 'ro',
- lazy_build => 1,
+ builder => '_build_storage',
);
sub _build_storage {
}
has sql_translator_args => (
- isa => 'HashRef',
+ isa => HashRef,
is => 'ro',
- default => sub { {} },
+ default => quote_sub(q( {} )),
);
+
has script_directory => (
- isa => 'Str',
+ isa => Str,
is => 'ro',
- required => 1,
- default => 'sql',
+ default => quote_sub(q{ 'sql' }),
);
has databases => (
- coerce => 1,
- isa => 'DBIx::Class::DeploymentHandler::Databases',
is => 'ro',
- default => sub { [qw( MySQL SQLite PostgreSQL )] },
+ #isa => ArrayRef[Str],
+ #coerce => quote_sub(q{
+ #if (ref(\$_[0]) eq 'SCALAR') {
+ #return [$_[0]]
+ #} else {
+ #return $_[0]
+ #}
+ #}),
+ default => quote_sub(q{ [qw( MySQL SQLite PostgreSQL )] }),
);
has txn_wrap => (
is => 'ro',
- isa => 'Bool',
- default => 1,
+ isa => Bool,
+ default => quote_sub(q{ 1 }),
);
has schema_version => (
is => 'ro',
- isa => 'Str',
- lazy_build => 1,
+ isa => Str,
+ builder => '_build_schema_version',
);
# 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
-sub _build_schema_version {
+sub _build_schema_version {
my $self = shift;
- $self->schema->schema_version
+ $self->schema->schema_version
}
sub __ddl_consume_with_prefix {
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
}
+# 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));
}
+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 ($@) {
- croak "$filename failed to compile: $@";
- } elsif (ref $fn eq 'CODE') {
- $fn->($self->schema, $versions)
- } else {
- croak "$filename should define an anonymouse sub that takes a schema but it didn't!";
- }
+ $fn->($self->schema, $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;
+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, $versions)
- } 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 (@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, $versions)
+ } else {
+ croak "A file ($filename) got to deploy that wasn't sql or perl!";
+ }
+ }
- return $sql;
+ return $sql;
+ });
}
sub deploy {
my $from_file = shift;
my $to_file = shift;
my $dir = $self->script_directory;
- my $databases = $self->databases;
+ my $databases = ref $self->databases ? $self->databases : [$self->databases];
my $version = $self->schema_version;
foreach my $db (@$databases) {
sub _prepare_changegrade {
my ($self, $from_version, $to_version, $version_set, $direction) = @_;
my $schema = $self->schema;
- my $databases = $self->databases;
+ my $databases = ref $self->databases ? $self->databases : [$self->databases];
my $dir = $self->script_directory;
my $schema_version = $self->schema_version;
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 {
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
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