File Coverage

blib/lib/ORLite/Migrate.pm

Criterion	Covered	Total	%
statement	106	120	88.3
branch	31	58	53.4
condition	12	30	40.0
subroutine	15	15	100.0
pod	0	2	0.0
total	164	225	72.8

package ORLite::Migrate;

# See POD at end of file for documentation

use 5.006;
use strict;
use Carp              ();
use File::Spec 3.2701 ();
use File::Path   2.04 ();
use File::Basename    ();
use Params::Util 0.37 ();
use DBI          1.58 ();
use DBD::SQLite  1.21 ();
use ORLite       1.28 ();

use vars qw{$VERSION @ISA};
BEGIN {
	$VERSION = '1.10';
	@ISA     = 'ORLite';
}

sub import {
	my $class = ref $_[0] || $_[0];

	# Check for debug mode
	my $DEBUG = 0;
	if ( defined Params::Util::_STRING($_[-1]) and $_[-1] eq '-DEBUG' ) {
		$DEBUG = 1;
		pop @_;
	}

	# Check params and apply defaults
	my %params;
	if ( defined Params::Util::_STRING($_[1]) ) {
		# Migrate needs at least two params
		Carp::croak("ORLite::Migrate must be invoked in HASH form");
	} elsif ( Params::Util::_HASH($_[1]) ) {
		%params = %{ $_[1] };
	} else {
		Carp::croak("Missing, empty or invalid params HASH");
	}
	if ( $params{timeline} and not defined $params{create} ) {
		$params{create} = 1;
	}
	$params{create} = $params{create} ? 1 : 0;
	unless (
		defined Params::Util::_STRING($params{file})
		and (
			$params{create}
			or
			-f $params{file}
		)
	) {
		Carp::croak("Missing or invalid file param");
	}
	unless ( defined $params{readonly} ) {
		$params{readonly} = $params{create} ? 0 : ! -w $params{file};
	}
	unless ( defined $params{tables} ) {
		$params{tables} = 1;
	}
	unless ( defined $params{package} ) {
		$params{package} = scalar caller;
	}
	unless ( Params::Util::_CLASS($params{package}) ) {
		Carp::croak("Missing or invalid package class");
	}

	unless (
		Params::Util::_DRIVER($params{timeline}, 'ORLite::Migrate::Timeline')
		or
		($params{timeline} and -d $params{timeline} and -r $params{timeline})
	) {
		Carp::croak("Missing or invalid timeline");
	}

	# We don't support readonly databases
	if ( $params{readonly} ) {
		Carp::croak("ORLite::Migrate does not support readonly databases");
	}

	# Get the schema version
	my $file     = File::Spec->rel2abs($params{file});
	my $created  = ! -f $params{file};
	if ( $created ) {
		# Create the parent directory
		my $dir = File::Basename::dirname($file);
		unless ( -d $dir ) {
			my @dirs = File::Path::mkpath( $dir, { verbose => 0 } );
			$class->prune(@dirs) if $params{prune};
		}
		$class->prune($file) if $params{prune};
	}
	my $dsn      = "dbi:SQLite:$file";
	my $dbh      = DBI->connect($dsn);
	my $version  = $dbh->selectrow_arrayref('pragma user_version')->[0];
	$dbh->disconnect;

	# We're done with the prune setting now
	$params{prune} = 0;

	# Handle the migration class
	if ( Params::Util::_DRIVER($params{timeline}, 'ORLite::Migrate::Timeline') ) {
		my $timeline = $params{timeline}->new(
			dbh => DBI->connect($dsn),
		);
		$timeline->upgrade( $params{user_version} );

	} else {
		my $timeline = File::Spec->rel2abs($params{timeline});
		my @plan     = plan( $params{timeline}, $version );

		# Execute the migration plan
		if ( @plan ) {
			# Does the migration plan reach the required destination
			my $destination = $version + scalar(@plan);
			if (
				exists $params{user_version}
				and
				$destination != $params{user_version}
			) {
				die "Schema migration destination user_version mismatch (got $destination, wanted $params{user_version})";
			}

			# Load the modules needed for the migration
			require Probe::Perl;
			require File::pushd;
			require IPC::Run3;

			# Locate our Perl interpreter
			my $perl = Probe::Perl->find_perl_interpreter;
			unless ( $perl ) {
				Carp::croak("Unable to locate your perl executable");
			}

			# Execute each script
			my $pushd = File::pushd::pushd($timeline);
			foreach my $patch ( @plan ) {
				my $stdin = "$file\n";
				if ( $DEBUG ) {
					print STDERR "Applying schema patch $patch...\n";
				}
				my $ok = IPC::Run3::run3( [ $perl, $patch ], \$stdin, \undef, $DEBUG ? undef : \undef );
				if ( ! $ok or $? != 0 ) {
					Carp::croak("Migration patch $patch failed, database in unknown state");
				}
			}

			# Migration complete, set user_version to new state
			$dbh = DBI->connect($dsn);
			$dbh->do("pragma user_version = $destination");
			$dbh->disconnect;
		}
	}

	# Hand off to the regular constructor
	$class->SUPER::import(
		\%params,
		$DEBUG ? '-DEBUG' : ()
	);
}





#####################################################################
# Simple Methods

sub patches {
	my $dir = shift;

	# Find all files in a directory
	local *DIR;
	opendir( DIR, $dir )       or die "opendir: $!";
	my @files = readdir( DIR ) or die "readdir: $!";
	closedir( DIR )            or die "closedir: $!";

	# Filter to get the patch set
	my @patches = ();
	foreach ( @files ) {
		next unless /^migrate-(\d+)\.pl$/;
		$patches["$1"] = $_;
	}

	return @patches;
}

sub plan {
	my $directory = shift;
	my $version   = shift;

	# Find the list of patches
	my @patches = patches( $directory );

	# Assemble the plan by integer stepping forwards
	# until we run out of timeline hits.
	my @plan = ();
	while ( $patches[++$version] ) {
		push @plan, $patches[$version];
	}

	return @plan;
}

1;

__END__