Padre::DB::Migrate - Extremely light weight SQLite-specific schema migration

  # Build your ORM class using a patch timeline
  # stored in the shared files directory.
  use Padre::DB::Migrate {
      create       => 1,
      file         => 'sqlite.db',
      timeline     => File::Spec->catdir(
          File::ShareDir::module_dir('My::Module'), 'patches',
      ),
      user_version => 8,
  };

  # migrate-1.pl - A trivial schema patch
  #!/usr/bin/perl

  use strict;
  use DBI ();

  # Locate the SQLite database
  my $file = <STDIN>;
  chomp($file);
  unless ( -f $file and -w $file ) {
      die "SQLite file $file does not exist";
  }

  # Connect to the SQLite database
  my $dbh = DBI->connect("dbi:SQLite(RaiseError=>1):$file");
  unless ( $dbh ) {
    die "Failed to connect to $file";
  }

  $dbh->do( <<'END_SQL' );
  create table foo (
      id integer not null primary key,
      name varchar(32) not null
  )
  END_SQL

  migrate-01.pl
  migrate-02.pl
  migrate-03.pl
  migrate-04.pl
  migrate-05.pl
  migrate-06.pl
  migrate-07.pl
  migrate-08.pl
  migrate-09.pl
  migrate-10.pl

package Padre::DB::Migrate;

# See POD at end of file for documentation

use 5.008005;
use strict;
use warnings;
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{@ISA};

our $VERSION = '0.86';

BEGIN {

	@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("Padre::DB::Migrate must be invoked in HASH form");
	} elsif ( Params::Util::_HASH( $_[1] ) ) {
		%params = %{ $_[1] };
	} else {
		Carp::croak("Missing, empty or invalid params HASH");
	}
	$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{timeline} and -d $params{timeline} and -r $params{timeline} ) {
		Carp::croak("Missing or invalid timeline directory");
	}

	# We don't support readonly databases
	if ( $params{readonly} ) {
		Carp::croak("Padre::DB::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;

	# Build the migration plan
	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 File::pushd;
		require Padre::Perl;
		require Padre::DB::Migrate::Patch;

		# Locate the include path we need for Padre::DB::Migrate::Patch,
		# so we can force-include it and be sure they find the right one.
		my $patch_pm = 'Padre/DB/Migrate/Patch.pm';
		my $include = $INC{$patch_pm} or die("Failed to find path");
		$include = substr( $include, 0, length($include) - length($patch_pm) );

		# Execute each script
		my $perl  = Padre::Perl::wxperl();
		my $pushd = File::pushd::pushd($timeline);
		foreach my $patch (@plan) {
			my $stdin = "$file\n";
			if ($DEBUG) {
				print STDERR "Applying schema patch $patch...\n";
			}
			local @ARGV = $file;
			do $patch;

			#my $exit = system( $perl, "-I$include", $patch, $file );
			# if ( $exit == -1 ) {
			# Carp::croak("Migration patch $patch failed, database in unknown state");
			# } elsif ( $? & 127 ) {
			# Carp::croak( sprintf( "Child died with signal %d", ( $? & 127 ) ) );
			# }
		}

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

	local $SIG{__WARN__} = sub { return if $_[0] =~ /Subroutine \w+ redefined at/; warn $_[0] };

	# 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__

# Copyright 2008-2011 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.