File Coverage

blib/lib/DBIx/Migration/Classes.pm

Criterion	Covered	Total	%
statement	18	162	11.1
branch	0	72	0.0
condition	0	15	0.0
subroutine	6	22	27.2
pod	5	5	100.0
total	29	276	10.5

package DBIx::Migration::Classes;

use 5.008009;
use strict;
use warnings;

use DBI;
use Module::Collect;
use Data::Dumper;

our $VERSION = '0.02';

################################################################################

sub new
{
	my ($class, @args) = @_;
	my $self = bless {}, $class;
	return $self->_init(@args);
}

sub _test
{
	my ($self) = @_;
	my @tests = (
		# [,]

		# up
		['NONE', 'HEAD'],
		['MyTestChanges::CreateTableUser', 'HEAD'],
		['MyTestChanges::CreateTableUser', 'MyTestChanges::AddUserName'],
		['MyTestChanges::AddUserName', 'HEAD'],

		# down
		['HEAD', 'NONE'],
		['HEAD', 'MyTestChanges::CreateTableUser'],
		['MyTestChanges::AddUserName', 'MyTestChanges::CreateTableUser'],
		['HEAD', 'MyTestChanges::AddUserName'],

		# same
		['NONE','NONE'],
		['HEAD','HEAD'],
		['MyTestChanges::CreateTableUser','MyTestChanges::CreateTableUser'],
		['MyTestChanges::AddUserName','MyTestChanges::AddUserName'],
	);
	my $t = 0;
	foreach my $test (@tests) {
		_info("\n---( $t )---------------------------------------------\n");
		_info("--- $test->[0] .. $test->[1]\n\n");
		$self->migrate(undef, $test->[0], $test->[1]);
		$t++;
	}
}

sub migrate
{
	my ($self, $targetstate, $_state, $_targetstate) = @_;
	return 1 unless scalar @{$self->{'changeclasses'}};

	my $state = $self->state();

	# for testing purposes
	$state       = $_state       if defined $_state;
	$targetstate = $_targetstate if defined $_targetstate;

	# state = the name of the changeclass which changes were last APPLIED
	#         OR "NONE" if no changeclasses were applied
	#
	# targetstate = the name of the changeclass which is the last one to be APPLIED

	my $first_pos = $self->_get_position_of_changeclass($state);
	my $last_pos  = $self->_get_position_of_changeclass($targetstate);
	return 1 if $first_pos eq $last_pos;

	my $dir = ($first_pos <=> $last_pos); # up = -1, down = 1, same = 0

	$state       = $self->{'changeclasses'}->[$first_pos == -1 ? 0 : $first_pos]->[0];
	$targetstate = $self->{'changeclasses'}->[$last_pos ]->[0];

	_info("migrating database from state $state to $targetstate...\n");

	my @changes = (); # actual database changes perfored by the changeclasses
	if ($dir == 0) { # same
		_info("- doing changes from ".$self->{'changeclasses'}->[$first_pos]->[0]."\n");
		push @changes, $self->{'changeclasses'}->[$first_pos]->[1]->get_changes();
	}
	elsif ($dir == -1) { # up
		for (my $p = $first_pos + 1; $p <= $last_pos; $p++) {
			_info("- doing changes from ".$self->{'changeclasses'}->[$p]->[0]."\n");
			push @changes, $self->{'changeclasses'}->[$p]->[1]->get_changes();
		}
	}
	elsif ($dir == 1) { # down
		for (my $p = $first_pos; $p > $last_pos; $p--) {
			_info("- undoing changes from ".$self->{'changeclasses'}->[$p]->[0]."\n");
			push @changes, $self->{'changeclasses'}->[$p]->[1]->get_changes('undo');
		}
		$targetstate = 'NONE' if $last_pos == -1;
	}

	if (defined $_state) {
		_info("database is now in state '".$self->state()."'\n");
		_info("not applying changes, because this is a test\n");
		return;
	}

	# actually perform all changes
	map { $self->_perform_change($_) } @changes;

	$self->_set_state($targetstate);
	_info("database is now in state '".$self->state()."'\n");
}

sub errstr
{
	my ($self) = @_;
	die "Error: error() method not yet implemented.\n";
}

sub state
{
	my ($self) = @_;
	my $sql = 'select version from `'.$self->{'db-meta-tablename'}.'` limit 1';
	my $sth = $self->_get_dbh()->prepare($sql);
	$sth->execute() or die("Error: Failed to read meta status: $! $@\n");
	my $meta = $sth->fetchrow_arrayref();
	unless ($meta) {
		# set state to 'NONE'
		$self->_query('insert into `meta` values ("NONE")')
			or die "Error: failed to set meta table version.\n";
	}
	return ($meta ? $meta->[0] : 'NONE');
}

sub changes
{
	my ($self) = @_;
	die "Error: changes() method not yet implemented.\n";
}

################################################################################

sub _init
{
	my ($self, %opts) = @_;

	$self->{'namespaces'} = $opts{'namespaces'} || die "Error: no namespace(s) supplied.\n";

	$self->{'changeclasses'} = {}; #  =>
	$self->_collect_changeclasses();

	$self->{'db-name'} 		= $opts{'dbname'} 		|| die "Error: no database name supplied.\n";
	$self->{'db-user'} 		= $opts{'dbuser'} 		|| 'root';
	$self->{'db-password'} = $opts{'dbpassword'} || '';
	$self->{'db-host'} 		= $opts{'dbhost'} 		|| 'localhost';
	$self->{'db-engine'} 	= $opts{'dbengine'} 	|| 'mysql';

	$self->{'db-meta-tablename'} = 'meta';

	$self->{'dbh'} = undef;
	$self->_init_database_metatable();

	return $self;
}

sub _set_state
{
	my ($self, $state) = @_;
	$self->_query('update `'.$self->{'db-meta-tablename'}.'` set version = "'.$state.'"')
		or die "Error: failed to update meta table.\n";
	return 1;
}

sub _perform_change
{
	my ($self, $change) = @_;
	my ($action, %opts) = @{$change};
	#print Dumper($change);

	if ($action eq 'create_table') {
		$self->_query('create table `'.$opts{'name'}.'` (`dummy` tinyint null)')
			or die "Error: failed to create table '$opts{'name'}': ".$self->_get_dbh()->errstr."\n";
	}
	elsif ($action eq 'drop_table') {
		$self->_query('drop table `'.$opts{'name'}.'`')
			or die "Error: failed to drop table '$opts{'name'}': ".$self->_get_dbh()->errstr."\n";
	}
	elsif ($action eq 'alter_table_add_column') {
		$self->_query('alter table `'.$opts{'tablename'}.'` add column `'.$opts{'name'}.'` '.$opts{'type'})
			or die "Error: failed to add column '$opts{'name'}': ".$self->_get_dbh()->errstr."\n";
	}
	elsif ($action eq 'alter_table_drop_column') {
		$self->_query('alter table `'.$opts{'tablename'}.'` drop column `'.$opts{'name'}.'`')
			or die "Error: failed to drop column '$opts{'name'}': ".$self->_get_dbh()->errstr."\n";
	}
	else {
		die "Error: action '$action' (change type) not yet implemented/supported.\n";
	}
	return 1;
}

sub _query
{
	my ($self, $sql) = @_;
	my $sth = $self->_get_dbh()->prepare($sql);
	return $sth->execute();
}

sub _get_position_of_changeclass
{
	my ($self, $classname) = @_;
	return -1 if $classname eq 'NONE';
	return scalar @{$self->{'changeclasses'}} - 1 if $classname eq 'HEAD';
	foreach my $p (0.. scalar @{$self->{'changeclasses'}}) {
		return $p if $self->{'changeclasses'}->[$p]->[0] eq $classname;
	}
	die "Error: failed to find change class '$classname'.\n";
}

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

	# find all classes
	my $classes = {};
	foreach my $path (@INC) {
		#print "$path:\n";
		foreach my $namespace (@{$self->{'namespaces'}}) {
			#print "  $namespace:\n";
			my $c = Module::Collect->new(path => $path, prefix => $namespace, multiple => 0);
			for my $module (@{$c->modules}) {
				my $classname = $module->package;
				next if exists $classes->{$classname};
				$module->require;
				eval('$classes->{$classname} = '.$classname.'->new()');
				$classes->{$classname}->perform(); # register actual changes (no effect in db)
				die "Error: error while loading change class '$classname': $! $@\n" if $@;
			}
		}
  }

  # store classes in execute order
  $self->{'changeclasses'} = []; # [,], ...

  # find first one with after()=""
  foreach my $classname (keys %{$classes}) {
  	my $class = $classes->{$classname};
  	if ($class->after() eq '') {
  		$self->{'changeclasses'}->[0] = [ $classname, $class ];
  		delete $classes->{$classname};
  		last;
  	}
  }
  while (scalar keys %{$classes}) {
  	# find one coming after last one
  	my $found = 0;
		foreach my $classname (keys %{$classes}) {
			my $class = $classes->{$classname};
			if ($class->after() eq $self->{'changeclasses'}->[-1]->[0]) {
				push @{$self->{'changeclasses'}}, [ $classname, $class ];
				delete $classes->{$classname};
				$found = 1;
				last;
			}
		}
		die "Error: failed to find a successor change class for '".
			$self->{'changeclasses'}->[-1]->[0]."'.\n"
				unless $found;
  }
	#print Dumper($self);
}

sub _get_dbh
{
	my ($self) = @_;
	if (!defined $self->{'dbh'} || !$self->{'dbh'}->ping()) {
		_info("(re)connecting to database...\n");
		$self->{'dbh'} = $self->_connect_db()
	}
	return $self->{'dbh'};
}

sub _connect_db
{
	my ($self) = @_;
	my $dbh =
		DBI->connect(
				"DBI:".$self->{'db-engine'}.":".$self->{'db-name'}.":".$self->{'db-host'},
				$self->{'db-user'}, $self->{'db-password'},
				{ PrintError => 0 },
			)
		or die("Error: Could not connect to database: $! $@\n");

	die("Error: could not connect to database: $! $@\n")
		unless defined $dbh;
	return $dbh;
}

sub _init_database_metatable
{
	my ($self) = @_;
	# create db tables if nessessary
	my $sth = $self->_get_dbh()->table_info("", $self->{'db-name'}, $self->{'db-meta-tablename'}, "TABLE");
	unless ($sth->fetch()) {
		_info("creating metatable in database...\n");
		my $sql = 'create table `'.$self->{'db-meta-tablename'}.'` (`version` varchar(255))';
		$self->_query($sql) or die "Error: failed to create meta table: $! $@\n";
	}
}

sub _info
{
	my (@msg) = @_;
	print STDERR join('', @msg);
}

################################################################################
1;
__END__