view release on metacpan or  search on metacpan

lib/Test/Database/Migrator.pm  view on Meta::CPAN

    return;
}

sub _write_perl_sub_migration {
    my $self = shift;

    my $dir = $self->_migrations_dir->subdir('03-third');
    $dir->mkpath;

    my $file = $dir->file('migrate.pl'),

        my $migration = <<'EOF';
use strict;
use warnings;

sub {
    my ($migrator) = @_;
    my $sql = 'CREATE TABLE myperlsub (id INTEGER)';
    $migrator->dbh->do($sql);
    return;
}
EOF

    $self->_write_ddl_file(
        $file,
        $migration,
    );

    return;
}

# This program generates a warning and so causes a failure.
sub _write_perl_program_migration {
    my $self = shift;

    my $dir = $self->_migrations_dir->subdir('04-fourth');
    $dir->mkpath;

    my $file = $dir->file('migrate.pl'),

        my $migration = <<'EOF';
#!/usr/bin/env perl

use strict;
use warnings;

sub main {
    my $x;
    print "hello $x\n";
    return 1;
}

exit(main() ? 0 : 1);
EOF

    $self->_write_ddl_file(
        $file,
        $migration,
    );

    chmod 0755, $file->stringify;

    return;
}

sub _new_migrator {
    my $self = shift;

    return $self->class()->new(
        database        => $self->database(),
        migration_table => 'applied_migration',
        schema_file     => $self->_schema_file(),
        migrations_dir  => $self->_migrations_dir(),
        logger          => _logger(),
    );
}

sub _logger {
    return Log::Dispatch->new(
        outputs => [ [ 'TestDiag', min_level => 'info' ] ],
    );
}

sub _build_migrations_dir {
    my $self = shift;

    my $dir = $self->_tempdir()->subdir('migrations');
    ## no critic (Lax::ProhibitLeadingZeros::ExceptChmod, ValuesAndExpressions::ProhibitLeadingZeros)
    $dir->mkpath( 0, 0755 );
    ## use critic

    return $dir;
}

sub _build_dbh {
    my $self = shift;

    return $self->_new_migrator()->dbh();
}

sub DEMOLISH {
    my $self = shift;

    if ( $ENV{DATABASE_MIGRATOR_TEST_WAIT} ) {
        print "\n  Waiting to clean up the test database\n\n"
            or die $!;
        ## no critic (InputOutput::ProhibitExplicitStdin)
        my $x = <STDIN>;
    }

    $self->_dbh()->disconnect() if $self->_has_dbh();

    $self->_new_migrator()->_drop_database();
}

=for Pod::Coverage .*

=cut

__PACKAGE__->meta()->make_immutable();