File Coverage

blib/lib/SQL/PatchDAG.pm

Criterion	Covered	Total	%
statement	27	102	26.4
branch	9	46	19.5
condition	9	16	56.2
subroutine	7	21	33.3
pod	15	15	100.0
total	67	200	33.5

use strict; use warnings;

package SQL::PatchDAG;

our $VERSION = '0.102';

use File::Spec ();
use Fcntl ();

sub new {
	my $class = shift;
	my $self = bless { binmode => ':unix', patches => {}, @_ }, $class;
	my @applied = @{ delete $self->{'applied'} || [] };
	@{ $self->{'applied'} }{ @applied } = ();
	$self;
}

sub deps_of { @{ $_[0]{'patches'}{ $_[1] } } }
sub patches { sort keys %{ $_[0]{'patches'} } }
sub applied { sort keys %{ $_[0]{'applied'} } }

sub dir             { $_[0]{'dir'} }
sub binmode :method { $_[0]{'binmode'} }
sub readdir :method {
	my $dir = shift->dir;
	opendir my $dh, $dir or die "Couldn't open directory '$dir': $!\n";
	File::Spec->no_upwards( sort readdir $dh );
}
sub open :method {
	my ( $self, $name, $do_rw ) = ( shift, @_ );
	die "Bad patch name '$name'\n" if $name !~ /\A[a-z0-9_][a-z0-9_-]*\z/;
	my $fn = File::Spec->catfile( $self->dir, "$name.sql" );
	my $mode = $do_rw ? Fcntl::O_RDWR() | Fcntl::O_CREAT() : Fcntl::O_RDONLY();
	sysopen my $fh, $fn, $mode  or die "Couldn't open '$fn': $!\n";
	binmode $fh, $self->binmode or die "Couldn't binmode '$fn': $!\n";
	( $fn, $fh );
}

sub from {
	my ( $class, $dir ) = ( shift, shift );
	my $self = $class->new( @_, dir => $dir );
	my @entry = $self->readdir;

	for my $name ( map /(.*)\.sql\z/s, @entry ) {
		my ( $fn, $fh ) = $self->open( $name );
		if ( eof $fh ) { warn "Ignoring empty patch '$fn'\n"; next }
		my $dep = readline $fh;
		$dep =~ s/^-- preceding-patch(?:es)? =(?=(?: \S+)+$)//
			or die "Bad or missing patch dependecies in '$fn'\n";
		$self->{'patches'}{ $name } = [ grep $name ne $_, split ' ', $dep ];
	}

	my @ignore = $self->grep_unknown( map /(.*)\.ignore\z/s, @entry );
	delete @{ $self->{'applied'} }{ @ignore };

	$self;
}

sub grep_unknown   { my $self = shift; grep !exists $self->{'patches'}{ $_ }, @_ }
sub grep_unapplied { my $self = shift; grep !exists $self->{'applied'}{ $_ }, @_ }

sub die_if_not_matching {
	my ( $self, $skip_missing ) = ( shift, @_ );
	my @prob;
	if ( my @u =                      $self->grep_unknown  ( $self->applied ) ) { push @prob, "extraneous: @u" }
	if ( my @u = $skip_missing ? () : $self->grep_unapplied( $self->patches ) ) { push @prob, "missing: @u" }
	( not @prob ) or die sprintf "Database schema does not match patches (%s)\n", join '; ', @prob;
}

sub get_next_unapplied {
	my $self = shift;

	$self->die_if_not_matching( 'skip_missing' );
	( my @missing = $self->grep_unapplied( $self->patches ) ) or return;

	for my $name ( @missing ) {
		if ( not $self->grep_unapplied( $self->deps_of( $name ) ) ) {
			$self->{'applied'}{ $name } = undef;
			my ( $fn, $fh ) = $self->open( $name );
			return ( $name, $fn, do { local $/; readline $fh } );
		}
	}

	die "All missing patches have unsatisfied dependencies: @missing\n";
}

sub create {
	my ( $self, $name, $do_recreate ) = ( shift, @_ );
	my $patches = $self->{'patches'};

	die sprintf "Patch '%s' %s\n", $name, $do_recreate ? 'does not exist' : 'already exists'
		if exists $patches->{ $name } xor !!$do_recreate;

	my ( $fn, $fh ) = $self->open( $name, 'rw' );
	my @content = "\n/* remove this comment and put your DDL statements and other SQL here */\n";

	if ( $do_recreate ) {
		@content = readline $fh;
		shift @content if @content and $content[0] =~ m!^-- preceding-patch(?:es)? = !;
		delete $patches->{ $name };
	}

	my %depended = map +( $_, undef ), map @$_, values %$patches;
	my @dep = sort grep !exists $depended{ $_ }, keys %$patches;
	$patches->{ $name } = \@dep;

	@dep = $name if not @dep;
	seek $fh, 0, 0;
	print $fh "-- preceding-patches = @dep\n", @content;
	truncate $fh, tell $fh;

	$fn;
}

sub run {
	my $self = shift;

	my ( $fn )
		= @_ == 1 && $_[0] !~ /^-/ ? $self->create( $_[0] )
		: @_ == 2 && $_[0] eq '-r' ? $self->create( $_[1], 'recreate' )
		: @_ == 2 && $_[0] eq '-e' ? $self->open( $_[1] )
		: die "usage: $0 [ -r | -e ] \n";

	die "No editor to run, EDITOR environment variable unset\n"
		if do { no warnings 'uninitialized'; '' eq $ENV{'EDITOR'} };

	$self->_exec( $ENV{'EDITOR'}, $fn );
}

sub _exec { shift; exec { $_[0] } @_ }

1;

__END__