File Coverage

blib/lib/Migraine.pm

Criterion	Covered	Total	%
statement	27	185	14.5
branch	0	76	0.0
condition	0	14	0.0
subroutine	9	27	33.3
pod	13	16	81.2
total	49	318	15.4

package Migraine;

use strict;

our $VERSION = "0.54"; # ==> ALSO update the version in the pod text below!

use Carp;
use DBI;
use English qw(-no_match_vars);

use constant MIGRATION_REGEX           => qr/^(\d+)-.+\..+/;
use constant MIGRAINE_META_CREATION_SQL =>
                "CREATE TABLE migraine_meta (name  varchar(20),
                                             value varchar(200))";
use constant MIGRAINE_META_UPGRADE_SQL =>
                "ALTER TABLE migraine_meta ADD (name  varchar(20),
                                                value varchar(200))";
use constant MIGRAINE_META_REMOVE_OBSOLETE_SQL =>
                "ALTER TABLE migraine_meta DROP version";
use constant MIGRAINE_MIGRATIONS_CREATION_SQL =>
                "CREATE TABLE migraine_migrations (id integer,
                                                   PRIMARY KEY (id))";

our $SUPPORTED_METADATA_FORMAT = 2;

sub new {
    my ($class, $dsn, %params) = @_;
    my $dbh = DBI->connect($dsn, $params{user},
                                 $params{password},
                                 $params{dbi_options});
    my $attrs = { migrations_dir => "migrations",
                  %params,
                  dbh => $dbh };
    bless $attrs, $class;
}

sub dbh {
    my ($self) = @_;
    $self->{dbh};
}

sub migraine_metadata_present {
    my ($self) = @_;

    return $self->_check_table_exists("migraine_meta");
}

sub migraine_metadata_usable {
    my ($self) = @_;

    return ($self->migraine_metadata_version == $SUPPORTED_METADATA_FORMAT);
}

sub _check_table_exists {
    my ($self, $table_name) = @_;

    my @tables = $self->dbh->tables(undef, undef, $table_name);
    return (scalar grep /$table_name/, @tables);
}

sub migraine_metadata_version {
    my ($self) = @_;

    if ($self->migraine_metadata_present) {
        my ($old_raise, $old_print) = ($self->dbh->{RaiseError},
                                       $self->dbh->{PrintError});
        $self->dbh->{RaiseError} = $self->dbh->{PrintError} = 0;
        my $sth = $self->dbh->prepare("SELECT value
                                         FROM migraine_meta
                                        WHERE name = 'metadata_version'");
        my $r = $sth->execute;
        $self->dbh->{RaiseError} = $old_raise;
        $self->dbh->{PrintError} = $old_print;
        if ($r) {
            my $results = $sth->fetchrow_hashref;
            if (defined $results->{value}) {
                return 0 + $results->{value};     # Force number
            }
            else {
                croak "Inconsistent or unknown migraine_meta";
            }
        }
        else {
            my $old_raise = $self->dbh->{RaiseError};
            $self->dbh->{RaiseError} = 0;
            $sth = $self->dbh->prepare("SELECT version FROM migraine_meta");
            $r = $sth->execute;
            $self->dbh->{RaiseError} = $old_raise;
            if ($r) {
                return 1;
            }
            else {
                croak "Inconsistent or unknown migraine_meta";
            }
        }
    }
    else {
        return 0;
    }
}

sub create_migraine_metadata {
    my ($self) = @_;

    unless ($self->migraine_metadata_present) {
        my $sth = $self->dbh->prepare(MIGRAINE_META_CREATION_SQL);
        $sth->execute ||
            croak "Couldn't create migraine_meta table: $DBI::errstr\n";
        $sth = $self->dbh->prepare(MIGRAINE_MIGRATIONS_CREATION_SQL);
        $sth->execute ||
            croak "Couldn't create migraine_migrations table: $DBI::errstr\n";
        $sth = $self->dbh->prepare("INSERT INTO migraine_meta (name, value)
                                                       VALUES (?, ?)");
        $sth->execute('metadata_version', $SUPPORTED_METADATA_FORMAT) ||
            croak "Couldn't insert migraine_meta information.";
    }
    return 1;
}

sub upgrade_migraine_metadata {
    my ($self) = @_;

    my $df = $self->migraine_metadata_version;
    if ($df == 0) {
        return $self->create_migraine_metadata;
    }
    elsif ($df == 1) {
        my $dbh = $self->dbh;
        $dbh->do(MIGRAINE_META_UPGRADE_SQL) ||
            croak "Couldn't upgrade the migraine_meta table: $DBI::errstr\n";
        # Store how many migrations had been applied and remove obsolete record
        my $res = $dbh->selectall_arrayref("SELECT version FROM migraine_meta");
        my $version = $res->[0]->[0];
        $dbh->do("DELETE FROM migraine_meta");  # Remove obsolete record
        $dbh->do(MIGRAINE_META_REMOVE_OBSOLETE_SQL) ||
            croak "Couldn't remove obsolete fields from migraine_meta table: $DBI::errstr\n";
        $dbh->do("INSERT INTO migraine_meta (name, value)
                                     VALUES ('metadata_version', '2')");
        $dbh->do(MIGRAINE_MIGRATIONS_CREATION_SQL) ||
            croak "Couldn't create migraine_migrations table: $DBI::errstr\n";
        for (my $v = 1; $v <= $version; $v++) {
            $dbh->do("INSERT INTO migraine_migrations (id) VALUES ($v)");
        }
        return 1;
    }
    elsif ($df == 2) {
        return 1;
    }
    else {
        croak "Sorry, I don't know how to upgrade from version $df";
    }
}

sub latest_version {
    my ($self) = @_;

    opendir D, $self->{migrations_dir};
    my ($higher_version) = reverse sort { $a <=> $b }
                                        map { $_ =~ MIGRATION_REGEX;
                                              int($1); }
                                            grep { $_ =~ MIGRATION_REGEX }
                                                 readdir D;
    closedir D;
    $higher_version || 0;
}

sub current_version {
    my ($self) = @_;

    if ($self->migraine_metadata_present) {
        my $sth = $self->dbh->prepare("SELECT id FROM migraine_migrations
                                             ORDER BY id DESC
                                                LIMIT 1");
        if (defined $sth && $sth->execute) {
            $sth->bind_columns(\my $version);
            $sth->fetch;
            return $version || 0;
        }
        else {
            croak "Can't query migraine_meta table?! ".$self->dbh->errstr;
        }
    }
    else {
        return 0;
    }
}

sub migration_applied {
    my ($self, $migration_id) = @_;

    return unless $self->migraine_metadata_usable;
    my $sth = $self->dbh->prepare("SELECT id FROM migraine_migrations
                                            WHERE id = ?");
    if (defined $sth && $sth->execute($migration_id)) {
        $sth->bind_columns(\my $version);
        $sth->fetch;
        if (defined $version && $version == $migration_id) {
            return 1;
        }
    }
    else {
        return 0;
    }
}

sub migrate {
    my ($self, %user_params) = @_;
    my %params = (no_act => 0, %user_params);

    my $up_to_version = $params{version} || $self->latest_version;

    # Create migraine metadata if it's not there
    $self->create_migraine_metadata unless $params{no_act};

    for (my $cnt = 1; $cnt <= $up_to_version; $cnt++) {
        next if $self->migration_applied($cnt);
        $self->apply_migration($cnt, before_migrate => $params{before_migrate},
                                     after_migrate  => $params{after_migrate},
                                     no_act         => $params{no_act},
                                     skip_missing_migrations =>
                                            $params{skip_missing_migrations});
    }
}

sub _mark_migration_as_applied {
    my ($self, $version) = @_;

    my $sth = $self->dbh->prepare("INSERT INTO migraine_migrations (id)
                                                            VALUES (?)");
    $sth->execute($version);
}

sub apply_migration {
    my ($self, $version, %user_options) = @_;
    my %options = (no_act                  => 0,
                   skip_missing_migrations => 0,
                   %user_options);

    if ($self->migration_applied($version)) {
        croak "Migration $version already applied";
    }

    my $contents;
    eval {
        if ($options{before_migrate}) {
            $options{before_migrate}->($version,
                                       $self->get_migration_path($version));
        }
        $contents = $self->get_migration($version);
    };
    if ($EVAL_ERROR) {
        if ($options{skip_missing_migrations}) {
            print STDERR "Skipping migration $version: $EVAL_ERROR";
            return;
        }
        else {
            die $EVAL_ERROR;
        }
    }

    if (defined $contents) {
        unless ($options{no_act}) {
            foreach my $query (split(/;\s*\n/, $contents)) {
                my $sth = $self->dbh->prepare($query);
                if ($sth) {
                    my $r;
                    eval { $r = $sth->execute };
                    $r || croak "Couldn't execute migration $version ($query): ".$self->dbh->errstr;
                }
                else {
                    croak "Can't prepare migration $version: ".$self->dbh->errstr;
                }
            }
            $self->_mark_migration_as_applied($version);
        }

        if ($options{after_migrate}) {
            $options{after_migrate}->($version,
                                      $self->get_migration_path($version));
        }
    }
}

sub applied_migrations {
    my ($self) = @_;

    if ($self->migraine_metadata_usable) {
        my $res = $self->dbh->selectall_arrayref("SELECT id
                                                    FROM migraine_migrations
                                                ORDER BY id");
        return map { $_->[0] } @$res;
    }
    else {
        return;
    }
}

sub applied_migration_ranges {
    my ($self) = @_;

    my @ordered_migrations = $self->applied_migrations;
    return if scalar @ordered_migrations == 0;
    my $range_first_item = $ordered_migrations[0];
    my $last_item        = $range_first_item;
    my @r = ();
    foreach my $id (@ordered_migrations) {
        if ($id > $last_item + 1) {
            push @r,
                 ($last_item != $range_first_item ?
                     "$range_first_item-$last_item" :
                     "$range_first_item");
            $range_first_item = $id;
        }
        $last_item = $id;
    }

    # Take care of the last range/element
    push @r,
         ($last_item != $range_first_item ?
             "$range_first_item-$last_item" :
             "$range_first_item");

    return @r;
}

sub get_migration_path {
    my ($self, $version) = @_;

    opendir D, $self->{migrations_dir};
    my @migrations = map { "$self->{migrations_dir}/$_" }
                         grep /^0*$version-.+\..+$/,
                              readdir D;
    closedir D;

    @migrations || die "Can't find migration $version\n";
    scalar @migrations == 1 || die "More than one migration '$version'?!\n";
    return $migrations[0];
}

sub get_migration {
    my ($self, $version) = @_;

    # This will throw an exception if it's not there, there is more than one or
    # whatever. So we can assume everything was right.
    my $path = $self->get_migration_path($version);

    open F, $path;
    my $contents = join("", );
    close F;
    return $contents;
}

1;

__END__