File Coverage

blib/lib/Module/Build/Database.pm

Criterion	Covered	Total	%
statement	28	226	12.3
branch	0	82	0.0
condition	0	14	0.0
subroutine	10	22	45.4
pod	0	9	0.0
total	38	353	10.7

=head1 NAME

Module::Build::Database - Manage database patches in the style of Module::Build.

=head1 SYNOPSIS

 perl Build.PL
 ./Build dbtest
 ./Build dbdist
 ./Build dbfakeinstall
 ./Build dbinstall

In more detail :

 # In Build.PL :

 use Module::Build::Database;

 my $builder = Module::Build::Database->new(
    database_type => "PostgreSQL",
    ...other module build options..
  );

 $builder->create_build_script();

 # Put database patches into db/patches/*.sql.
 # A schema will be autogenerated in db/dist/base.sql.
 # Any data generated by the patches will be put into db/dist/base_data.sql.
 # Documentation will be autogenerated in db/doc/.

 # That is, first do this :
 perl Build.PL

 # Then, test that patches in db/patches/ will apply successfully to
 # the schema in db/dist/ :
 ./Build dbtest

 # The, update the db information in db/dist/ by applying any
 # unapplied patches in db/patches/ to the schema in db/dist/ :
 ./Build dbdist

 # Update the docs in db/docs using the schema in db/dist :
 ./Build dbdocs

 # Install a new database or upgrade an existing one :
 ./Build dbfakeinstall
 ./Build dbinstall

Additionally, when doing

 ./Build install

The content of the C directory will be installed into your distributions
share directory so that it can be retrieved using L.  For example,
assuming your MBD dist is called C, to find the C file from perl:

 use File::ShareDir qw( dist_dir );
 my $base = dist_dir('MyDist') . '/dist/base.sql';

=head1 DESCRIPTION

This is a subclass of Module::Build for modules which depend on a database,
which adds functionality for testing and distributing changes to the database.

Changes are represented as sql files ("patches") which will be fed into a
command line client for the database.

A complete schema is regenerated whenever
L is run.

A list of the patches which have been applied is stored in two places :

=over

=item 1.

the file C

=item 2.

the table C within the target database.

=back

When the L action is
invoked, any patches in (1) but not in (2) are applied.  In order to
determine whether they will apply successfully,
L may be run, which
does the following :

=over

=item 1.

Dumps the schema for an existing instance.

=item 2.

Applies any patches not found in the C table.

=item 3.

Dumps the resulting schema and compares it to the schema in C.

=back

If the comparison in step 3 is the same, then one may conclude that applying
the missing patches will produce the desired schema.

=head1 ACTIONS

=head2 dbdist

This (re-)generates the files C, C,
and C.

It does this by reading patches from C,
applying the ones that are not listed in C,
and then dumping out a new C and C.

In other words :

=over 4

=item 1.

Start a new empty database instance.

=item 2.

Populate the schema using C.

=item 3.

Import any data in C.

=item 4.

For every patch in C :

Is the patch is listed in C?

=over 4

=item Yes?

Skip it.

=item No?

Apply it, and add it to C.

=back

=item 5.

Dump the new schema out to C

=item 6.

Dump any data out into C

=item 7.

Stop the database.

=back

=head2 dbtest

=over 4

=item 1.

Start a new empty database instance.

=item 2.

Apply C.

=item 3.

Apply C.

=item 4.

Apply any patches in C that are
not in C.
For each of the above, the tests will fail if any of the
patches do not apply cleanly.

=item 5.

Shut down the database instance.

If C<--leave_running=1> is passed, step 4 will not be executed.
The "host" for the database can be found in

 Module::Build::Database->current->notes("dbtest_host");

=back

=head2 dbclean

Stop any test daemons that are running and remove any
test databases that have been created.

=head2 dbdocs

=over 4

=item 1.

Start a new empty database instance.

=item 2.

Apply C.

=item 3.

Dump the new schema docs out to C.

=item 4.

Stop the database.

=back

=head2 dbfakeinstall

=over 4

=item 1.

Look for a running database, based on environment variables.

=item 2.

Display the connection information obtained from the above.

=item 3.

Dump the schema from the live database to a temporary directory.

=item 4.

Make a temporary database using the above schema.

=item 5.

Apply patches listed in C that are not
in the C table.

=item 6.

Dump out the resulting schema, and compare it to C.

=back

Note that L must be run to update
C before doing
C or
C.

=head2 dbinstall

=over 4

=item 1.

Look for a running database, based on environment variables

=item 2.

Apply any patches in C that are not in the C table.

=item 3.

Add an entry to the C table for each patch applied.

=back

=head2 dbplant

=over 4

=item 1.

Starts a test database based on C and any patches (see
L)

=item 2.

Calls C in L. to generate a static object hierarchy.

=item 3.

Stops the test database.

=back

The default name of the object class will be formed by appending
'::Objects' to the name of the module.  This may be overridden
by setting the build property C.  The directory
name will be formed by prepending C and appending
C, e.g. C<./lib/MyModule/Objects/autolib>.

=head1 NOTES

Patches will be applied in lexicographic order, so their names should start
with a sequence of digits, e.g. C<0010_something.sql>, C<0020_something_else.sql>, etc.

=head1 AUTHOR

Brian Duggan

Graham Ollis [e-mail]

Curt Tilmes

=head1 TODO

Allow L to not interfere with
other running mbd-test databases.  Currently it errs on the side of
cleaning up too much.

=head1 SEE ALSO

L, L, L

=cut

package Module::Build::Database;
use File::Basename qw/basename/;
use File::Path qw/mkpath/;
use Digest::MD5;
use List::MoreUtils qw/uniq/;
use Path::Class qw/file/;
use warnings;
use strict;

use Module::Build::Database::Helpers qw/debug info/;
use base 'Module::Build';

our $VERSION = '0.57';

__PACKAGE__->add_property(database_object_class => default => "");

sub new {
    my $class = shift;
    my %args = @_;

    # add db to the share directory, if it isn't already there
    my $dirs = $args{share_dir}->{dist} // [];
    $dirs = [ $dirs ] unless ref($dirs) eq 'ARRAY';
    push @$dirs, 'db';
    $args{share_dir}->{dist} = $dirs;

    # recursive constructor, fun
    my $driver = delete $args{database_type}
      or return $class->SUPER::new(%args);
    my $subclass = "$class\::$driver";
    eval "use $subclass";
    die $@ if $@;
    my $self = $subclass->new(%args);
    $self->add_to_cleanup(
        'tmp_db_????.sql',
        'postmaster.log',
    );
    $self;
}

# Return an array of patch filenames.
# Send (pending => 1) to omit applied patches.
sub _find_patch_files {
    my $self = shift;
    my %args = @_;
    my $pending = $args{pending};

    my @filenames = sort map { basename $_ } glob $self->base_dir.'/db/patches/*.sql';
    my @bad = grep { $_ !~ /^\d{4}/ } @filenames;
    if (@bad) {
        die "\nBad patch files : @bad\nAll files must start with at least 4 digits.\n";
    }
    return @filenames unless $pending;
    my %applied = $self->_read_patches_applied_file();
    return grep { !exists( $applied{$_} ) } @filenames;
}

# Read patches_applied.txt or $args{filename}, return a hash whose
# keys are the filenames, and whose values are information about
# the patch.
sub _read_patches_applied_file {
    my $self = shift;
    my %args = @_;
    my %h;
    my $readme = $args{filename} || join '/', $self->base_dir, qw(db dist patches_applied.txt);
    return %h unless -e $readme;
    my @lines = file($readme)->slurp;
    for my $line (@lines) {
        my @info = split /\s+/, $line;
        $h{$info[0]} = \@info;
    }
    return %h;
}

sub _diff_files {
    my $self = shift;
    my ($one,$two) = @_;
    return system("diff -B $one $two")==0;
}

sub ACTION_dbtest {
    my $self = shift;

    # 1. Start a new empty database instance.
    warn "# starting test database\n";
    my $host = $self->_start_new_db() or die "could not start the db";
    $self->notes(dbtest_host => $host);

    # 1a. create postgres language extensions, if appropriate
    $self->_create_language_extensions;

    # 2. Apply db/dist/base.sql.
    $self->_apply_base_sql();

    # 2.1 Apply db/dist/base_data.sql
    $self->_apply_base_data();

    # 3. Apply any patches in db/patches/*.sql that are
    #    not in db/dist/patches_applied.txt.
    #    For each of the above, the tests will fail if any of the
    #    patches do not apply cleanly.

    my @todo = $self->_find_patch_files(pending => 1);

    info "no unapplied patches" unless @todo;
    print "1..".@todo."\n" if (@todo && !$ENV{MBD_QUIET});
    my $i = 1;
    my $passes = 0;
    for my $filename (@todo) {
        if ($self->_apply_patch($filename)) {
            print "ok $i - applied $filename\n" unless $ENV{MBD_QUIET};
            $passes++;
        } else {
            print "not ok $i - applied $filename\n" unless $ENV{MBD_QUIET};
        }
        $i++;
    }

    return 1 if $self->runtime_params("leave_running") || $self->notes("leave_running");

    # 4. Shut down the database instance.
    $self->_stop_db();

    # and remove it
    $self->_remove_db();
    $self->notes(dbtest_host => "");

    return $passes==@todo;
}

sub ACTION_dbclean {
    my $self = shift;

    if (my $host = $self->notes("dbtest_host")) {
        $self->_stop_db($host);
        $self->_remove_db($host);
    }

    # Remove any test databases created, stop any daemons.
    $self->_cleanup_old_dbs; # NB: this may conflict with other running tests
    $self->notes(dbtest_host => "");
    $self->notes(already_started => 0);
}

sub ACTION_dbdist {
    my $self = shift;
    my $dbdist  = $self->base_dir . '/db/dist';

    if (! -e "$dbdist/base.sql" && -e "$dbdist/patches_applied.txt") {
        die "No base.sql : remove patches_applied.txt to apply all patches\n";
    };

    # 1. Start a new empty database instance.
    $self->_start_new_db();

    # 1a. create postgres language extensions, if appropriate
    $self->_create_language_extensions;

    # 2. Populate the schema using db/dist/base.sql.
    # If there is no base.sql, we will create it from the patches.
    if ($self->_apply_base_sql()) {
        warn "updating base.sql\n";
    } else {
        warn "creating new base.sql\n";
    }

    # 2.1 Apply base data
    $self->_apply_base_data();

    # 3. For every pending patch, apply, and add to patches_applied.txt.
    my %applied = $self->_read_patches_applied_file();
    my @todo    = $self->_find_patch_files( pending => 1 );
    -d $dbdist or mkpath $dbdist;
    my $patches_file = "$dbdist/patches_applied.txt";
    my $fp = IO::File->new(">>$patches_file") or die "error: $!";
    for my $filename (@todo) {
        my $hash = Digest::MD5->new()->addfile(
                    IO::File->new( "<" .$self->base_dir . '/db/patches/' . $filename ) )
                  ->hexdigest;
        $self->_apply_patch($filename) or die "Failed to apply $filename";
        print ${fp} (join "\t", $filename, $hash)."\n";
        info "Applied patch $filename";
    }
    $fp->close;
    info "Wrote $patches_file" if @todo;

    # 4. Dump the new schema out to db/dist/base.sql
    $self->_dump_base_sql();
    info "Wrote $dbdist/base.sql";

    # 4.1 Dump any data out to db/dist/base_data.dump
    $self->_dump_base_data();
    info "Wrote $dbdist/base_data.sql";

    # 5. Stop the database.
    $self->_stop_db();

    # 6. Wipe it.
    $self->_remove_db();
    $self->notes(dbtest_host => "");
}

sub ACTION_dbdocs {
    my $self = shift;

    my $docdir = $self->base_dir."/db/dist/docs";
    mkpath $docdir;
    $self->_generate_docs(dir => $docdir);
}

sub ACTION_dbfakeinstall {
    my $self = shift;

    -e $self->base_dir.'/db/dist' or die "no db/dist dir, cannot fakeinstall";

    # 1. Look for a running database, based on environment variables.
    # 2. Display the connection information obtained from the above.

    $self->_show_live_db();

    # 3. Dump the schema from the live database to a temporary directory.
    my $existing_schema = File::Temp->new(TEMPLATE => "tmp_db_XXXX", SUFFIX => '.sql');
    $existing_schema->close;
    if ($self->_is_fresh_install()) {
        info "Ready to create the base database.";
        return;
    } else {
        $self->_dump_base_sql(outfile => "$existing_schema");
    }

    # 4. Dump the patch table.
    my $tmp = File::Temp->new(); $tmp->close;
    if ($self->_patch_table_exists()) {
        $self->_dump_patch_table(outfile => "$tmp");
    } else {
        info "There is no patch table, it will be created.";
        unlink "$tmp" or die "error unlinking $tmp: $!";
    }

    # 4. Apply patches listed in db/dist/patches_applied.txt that are not
    #    in the patches_applied table.
    # 4a. Determine list of patches to apply.
    my %db_patches = $self->_read_patches_applied_file(filename => "$tmp");
    my %base_patches  = $self->_read_patches_applied_file();
    my @todo = grep { !$db_patches{$_} } sort keys %base_patches;
    debug "patches todo : @todo";
    for my $patch (sort keys %db_patches) {
        unless (exists $base_patches{$patch}) {
            info "WARNING: patch $patch in db is not in patches_applied.txt";
            next;
        }
        next if "@{ $db_patches{$patch} }" eq "@{ $base_patches{$patch} }";
        info "WARNING: @{ $db_patches{$patch} } != @{ $base_patches{$patch} }";
    }
    for my $patch (@todo) {
        info "Will apply patch $patch";
    }

    # 5a. Start a temporary database, apply the live schema.
    # 5b. Apply the pending patches to that one.
    # 5c. Remove the patches_applied table.
    # 5d. Dump out the resulting schema.
    # 5e. Compare that to base.sql.

    $tmp = File::Temp->new();$tmp->close;
    $self->_start_new_db();
    $self->_create_language_extensions;
    $self->_apply_base_sql("$existing_schema") # NB: contains patches_applied table
        or do { $existing_schema->unlink_on_destroy(0); die "error with existing schema" };
    do { $self->_apply_patch($_) or die "patch $_ failed" } for @todo;
    $self->_remove_patches_applied_table();
    $self->_dump_base_sql(outfile => "$tmp");
    $self->_diff_files("$tmp", $self->base_dir. "/db/dist/base.sql")
        or warn "Applying patches will not result in a schema identical to base.sql\n";
}

sub ACTION_dbinstall {
    my $self = shift;

    -e $self->base_dir.'/db/dist' or die "no db/dist dir, cannot install";

    if ($self->_is_fresh_install()) {
        info "Fresh install.";
        $self->_create_database() or die "could not create database\n";
        $self->_create_language_extensions();
        $self->_apply_base_sql() or die "could not apply base sql\n";
        $self->_apply_base_data() or die "could not apply base_data sql\n";
    } else {
        $self->_create_language_extensions();
    }

    my %base_patches = $self->_read_patches_applied_file();
    unless ($self->_patch_table_exists()) {
        # add records for all patches which have been applied to the base
        info "Creating a new patch table";
        $self->_create_patch_table() or die "could not create patch table\n";
        for my $patch (sort keys %base_patches) {
            $self->_insert_patch_record($base_patches{$patch});
        }
    }
    #  1. Look for a running instance, based on environment variables
    #  2. Apply any patches in db/patches/ that are not in the patches_applied table.
    #  3. Add an entry to the patches_applied table for each patch applied.

    my $outfile = File::Temp->new(); $outfile->close;
    $self->_dump_patch_table(outfile => "$outfile");
    my %db_patches = $self->_read_patches_applied_file(filename => "$outfile");
    for my $patch (sort keys %base_patches) {
        if (exists($db_patches{$patch})) {
            next if "@{$base_patches{$patch}}" eq "@{$db_patches{$patch}}";
            warn "patch $patch: @{$base_patches{$patch}} != @{$db_patches{$patch}}\n";
            next;
        }
        warn "Applying $patch\n";
        $self->_apply_patch($patch) or die "error applying $patch";
        $self->_insert_patch_record($base_patches{$patch});
    }
}

sub ACTION_dbplant {
    my $self = shift;
    eval {
        require Rose::Planter;
    };
    if ($@) {
        die "Rose::Planter not found, install it to run dbplant";
    }
    $self->notes(leave_running => 1);
    $self->depends_on('dbtest'); # run dbtest
    my $obj_class = $self->database_object_class;
    unless ($obj_class) {
        $obj_class = join '::', $self->module_name, 'Objects';
        info "Using default database_object_class : $obj_class";
    }
    my $autodir = $obj_class;
    $autodir =~ s[::][/]g;
    $autodir .= '/autolib';
    $autodir = './lib/'.$autodir;
    info "Writing to $autodir";
    unshift @INC, './lib';
    $ENV{HARNESS_ACTIVE} = 1;
    Rose::Planter->plant($obj_class => $autodir);
    $self->depends_on('dbclean');
}

sub hash_properties {
    uniq(Module::Build->hash_properties, shift->SUPER::hash_properties);
}

sub _create_language_extensions { }

1;