File Coverage

blib/lib/App/migrate.pm

Criterion	Covered	Total	%
statement	267	283	94.3
branch	129	150	86.0
condition	26	37	70.2
subroutine	32	35	91.4
pod	6	6	100.0
total	460	511	90.0

package App::migrate;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;
## no critic (RequireCarping)

our $VERSION = 'v0.2.1';

use List::Util qw( first );
use File::Temp qw( tempfile ); # don't use Path::Tiny to have temp files in error $SHELL

use constant KW_DEFINE      => { map {$_=>1} qw( DEFINE DEFINE2 DEFINE4     ) };
use constant KW_VERSION     => { map {$_=>1} qw( VERSION                    ) };
use constant KW_UP          => { map {$_=>1} qw( before_upgrade upgrade     ) };
use constant KW_DOWN        => { map {$_=>1} qw( downgrade after_downgrade  ) };
use constant KW_RESTORE     => { map {$_=>1} qw( RESTORE                    ) };
use constant KW             => { %{&KW_UP}, %{&KW_DOWN}, %{&KW_DEFINE}, %{&KW_RESTORE}, %{&KW_VERSION} };
use constant DEFINE_TOKENS  => 1;
use constant DEFINE2_TOKENS => 2;
use constant DEFINE4_TOKENS => 4;


# cleanup temp files
$SIG{HUP} = $SIG{HUP}     // sub { exit 129 }; ## no critic (RequireLocalizedPunctuationVars ProhibitMagicNumbers)
$SIG{INT} = $SIG{INT}     // sub { exit 130 }; ## no critic (RequireLocalizedPunctuationVars ProhibitMagicNumbers)
$SIG{QUIT}= $SIG{QUIT}    // sub { exit 131 }; ## no critic (RequireLocalizedPunctuationVars ProhibitMagicNumbers)
$SIG{TERM}= $SIG{TERM}    // sub { exit 143 }; ## no critic (RequireLocalizedPunctuationVars ProhibitMagicNumbers)


sub new {
    my ($class) = @_;
    my $self = bless {
        paths   => {},  # {prev_version}{next_version} = \@steps
        on      => {
            BACKUP  => \&_on_backup,
            RESTORE => \&_on_restore,
            VERSION => \&_on_version,
            error   => \&_on_error,
        },
    }, ref $class || $class;
    return $self;
}

sub find_paths {
    my ($self, $from, $to) = @_;
    return $self->_find_paths($to, $from);
}

sub get_steps {
    my ($self, $path) = @_;
    my @path = @{ $path // [] };
    croak 'Path must contain at least 2 versions' if 2 > @path;
    my @all_steps;
    for (; 2 <= @path; shift @path) {
        my ($prev, $next) = @path;
        croak "Unknown version '$prev'" if !$self->{paths}{$prev};
        croak "No one-step migration from '$prev' to '$next'" if !$self->{paths}{$prev}{$next};
        push @all_steps, @{ $self->{paths}{$prev}{$next} };
    }
    return @all_steps;
}

sub load {
    my ($self, $file) = @_;

    open my $fh, '<:encoding(UTF-8)', $file or croak "open($file): $!";
    croak "'$file' is not a plain file" if !-f $file;
    my @op = _preprocess(_tokenize($fh, { file => $file, line => 0 }));
    close $fh or croak "close($file): $!";

    my ($prev_version, $next_version, @steps) = (q{}, q{});
    while (@op) {
        my $op = shift @op;
        if (KW_VERSION->{$op->{op}}) {
            $next_version = $op->{args}[0];
            if ($prev_version ne q{}) {
                $self->{paths}{ $prev_version }{ $next_version } ||= [
                    (grep { $_->{type} eq 'before_upgrade'  } @steps),
                    (grep { $_->{type} eq 'upgrade'         } @steps),
                    {
                        type            => 'VERSION',
                        version         => $next_version,
                    },
                ];
                my $restore = first { KW_RESTORE->{$_->{type}} } @steps;
                $self->{paths}{ $next_version }{ $prev_version } ||= [
                  $restore ? (
                    $restore,
                  ) : (
                    (grep { $_->{type} eq 'downgrade'       } reverse @steps),
                    (grep { $_->{type} eq 'after_downgrade' } reverse @steps),
                  ),
                    {
                        type            => 'VERSION',
                        version         => $prev_version,
                    },
                ];
                for (@{ $self->{paths}{ $prev_version }{ $next_version } }) {
                    $_->{prev_version} = $prev_version;
                    $_->{next_version} = $next_version;
                }
                for (@{ $self->{paths}{ $next_version }{ $prev_version } }) {
                    $_->{prev_version} = $next_version;
                    $_->{next_version} = $prev_version;
                }
            }
            ($prev_version, $next_version, @steps) = ($next_version, q{});
        }
        elsif (KW_UP->{$op->{op}}) {
            die _e($op, "Need 'VERSION' before '$op->{op}'") if $prev_version eq q{};
            my ($cmd1, @args1) = @{ $op->{args} };
            push @steps, {
                type            => $op->{op},
                cmd             => $cmd1,
                args            => \@args1,
            };
            die _e($op, "Need 'RESTORE' or 'downgrade' or 'after_downgrade' after '$op->{op}'")
                if !( @op && (KW_DOWN->{$op[0]{op}} || KW_RESTORE->{$op[0]{op}}) );
            my $op2 = shift @op;
            if (KW_RESTORE->{$op2->{op}}) {
                push @steps, {
                    type            => 'RESTORE',
                    version         => $prev_version,
                };
            }
            else {
                my ($cmd2, @args2) = @{ $op2->{args} };
                push @steps, {
                    type            => $op2->{op},
                    cmd             => $cmd2,
                    args            => \@args2,
                };
            }
        }
        else {
            die _e($op, "Need 'before_upgrade' or 'upgrade' before '$op->{op}'");
        }
    }

    return $self;
}

sub on {
    my ($self, $e, $code) = @_;
    croak "Unknown event $e" if !$self->{on}{$e};
    $self->{on}{$e} = $code;
    return $self;
}

sub run {
    my ($self, $path) = @_;
    $self->get_steps($path);  # validate full @path before starting
    my @path = @{ $path };
    my $from;
    eval {
        my $just_restored = 0;
        for (; 2 <= @path; shift @path) {
            my ($prev, $next) = @path;
            if (!$just_restored) {
                $self->_do({
                    type            => 'BACKUP',    # internal step type
                    version         => $prev,
                    prev_version    => $prev,
                    next_version    => $next,
                });
            }
            $just_restored = 0;
            $from = $prev;
            for my $step ($self->get_steps([$prev, $next])) {
                $self->_do($step);
                if ($step->{type} eq 'RESTORE') {
                    $just_restored = 1;
                }
            }
        }
        1;
    }
    or do {
        my $err = $@;
        if ($from) {
            eval {
                $self->_do({
                    type            => 'RESTORE',   # internal step type
                    version         => $from,
                    prev_version    => $from,
                    next_version    => $path[-1],
                }, 1);
                warn "Successfully undone interrupted migration by RESTORE $from\n";
                1;
            } or warn "Failed to RESTORE $from: $@";
        }
        die $err;
    };
    return;
}

sub _data2arg {
    my ($data) = @_;

    return if $data eq q{};

    my ($fh, $file) = tempfile('migrate.XXXXXX', TMPDIR=>1, UNLINK=>1);
    print {$fh} $data;
    close $fh or croak "close($file): $!";

    return $file;
}

sub _do {
    my ($self, $step, $is_fatal) = @_;
    local $ENV{MIGRATE_PREV_VERSION} = $step->{prev_version};
    local $ENV{MIGRATE_NEXT_VERSION} = $step->{next_version};
    eval {
        if ($step->{type} eq 'BACKUP' or $step->{type} eq 'RESTORE' or $step->{type} eq 'VERSION') {
            $self->{on}{ $step->{type} }->($step);
        }
        else {
            my $cmd = $step->{cmd};
            if ($cmd =~ /\A#!/ms) {
                $cmd = _data2arg($cmd);
                chmod 0700, $cmd or croak "chmod($cmd): $!";    ## no critic (ProhibitMagicNumbers)
            }
            system($cmd, @{ $step->{args} }) == 0 or die "'$step->{type}' failed: $cmd @{ $step->{args} }\n";
            print "\n";
        }
        1;
    }
    or do {
        die $@ if $is_fatal;
        warn $@;
        $self->{on}{error}->($step);
    };
    return;
}

sub _e {
    my ($t, $msg, $near) = @_;
    return "parse error: $msg at $t->{loc}{file}:$t->{loc}{line}"
      . (length $near ? " near '$near'\n" : "\n");
}

sub _find_paths {
    my ($self, $to, @from) = @_;
    my $p = $self->{paths}{ $from[-1] } || {};
    return [@from, $to] if $p->{$to};
    my %seen = map {$_=>1} @from;
    return map {$self->_find_paths($to,@from,$_)} grep {!$seen{$_}} keys %{$p};
}

sub _on_backup {
    croak 'You need to define how to make BACKUP';
}

sub _on_restore {
    croak 'You need to define how to RESTORE from backup';
}

sub _on_version {
    # do nothing
}

sub _on_error {
    warn <<'ERROR';

YOU NEED TO MANUALLY FIX THIS ISSUE RIGHT NOW
When done, use:
   exit        to continue migration
   exit 1      to interrupt migration and RESTORE from backup

ERROR
    system($ENV{SHELL} // '/bin/sh') == 0 or die "Migration interrupted\n";
    return;
}

sub _preprocess { ## no critic (ProhibitExcessComplexity)
    my @tokens = @_;
    my @op;
    my %macro;
    while (@tokens) {
        my $t = shift @tokens;
        if ($t->{op} =~ /\ADEFINE[24]?\z/ms) {
            die _e($t, "'$t->{op}' must have one param", "@{$t->{args}}") if 1 != @{$t->{args}};
            die _e($t, "Bad name for '$t->{op}'", $t->{args}[0]) if $t->{args}[0] !~ /\A(?!#)\S+\z/ms;
            die _e($t, "No data allowed for '$t->{op}'", $t->{data}) if $t->{data} ne q{};
            my $name = $t->{args}[0];
            die _e($t, "Can't redefine keyword '$name'") if KW->{$name};
            die _e($t, "'$name' is already defined") if $macro{$name};
            if ($t->{op} eq 'DEFINE') {
                die _e($t, q{Need operation after 'DEFINE'}) if @tokens < DEFINE_TOKENS;
                my $t1 = shift @tokens;
                die _e($t1, q{First operation after 'DEFINE' must be 'before_upgrade' or 'upgrade' or 'downgrade' or 'after_downgrade'}, $t1->{op}) if !( KW_UP->{$t1->{op}} || KW_DOWN->{$t1->{op}} );
                $macro{$name} = [ $t1 ];
            }
            elsif ($t->{op} eq 'DEFINE2') {
                die _e($t, q{Need two operations after 'DEFINE2'}) if @tokens < DEFINE2_TOKENS;
                my $t1 = shift @tokens;
                my $t2 = shift @tokens;
                die _e($t1,  q{First operation after 'DEFINE2' must be 'before_upgrade' or 'upgrade'},      $t1->{op}) if !KW_UP->{$t1->{op}};
                die _e($t2, q{Second operation after 'DEFINE2' must be 'downgrade' or 'after_downgrade'},   $t2->{op}) if !KW_DOWN->{$t2->{op}};
                $macro{$name} = [ $t1, $t2 ];
            }
            elsif ($t->{op} eq 'DEFINE4') {
                die _e($t, q{Need four operations after 'DEFINE4'}) if @tokens < DEFINE4_TOKENS;
                my $t1 = shift @tokens;
                my $t2 = shift @tokens;
                my $t3 = shift @tokens;
                my $t4 = shift @tokens;
                die _e($t1,  q{First operation after 'DEFINE4' must be 'before_upgrade'},  $t1->{op}) if $t1->{op} ne 'before_upgrade';
                die _e($t2, q{Second operation after 'DEFINE4' must be 'upgrade'},         $t2->{op}) if $t2->{op} ne 'upgrade';
                die _e($t3,  q{Third operation after 'DEFINE4' must be 'downgrade'},       $t3->{op}) if $t3->{op} ne 'downgrade';
                die _e($t4, q{Fourth operation after 'DEFINE4' must be 'after_downgrade'}, $t4->{op}) if $t4->{op} ne 'after_downgrade';
                $macro{$name} = [ $t1, $t4, $t2, $t3 ];
            }
        }
        elsif (KW_VERSION->{$t->{op}}) {
            die _e($t, q{'VERSION' must have one param}, "@{$t->{args}}") if 1 != @{$t->{args}};
            die _e($t, q{Bad value for 'VERSION'}, $t->{args}[0])
                if $t->{args}[0] !~ /\A\S+\z/ms || $t->{args}[0] =~ /[\x00-\x1F\x7F \/?*`"'\\]/ms;
            die _e($t, q{No data allowed for 'VERSION'}, $t->{data}) if $t->{data} ne q{};
            push @op, {
                loc     => $t->{loc},
                op      => $t->{op},
                args    => [ $t->{args}[0] ],
            };
        }
        elsif (KW_RESTORE->{$t->{op}}) {
            die _e($t, q{'RESTORE' must have no params}, "@{$t->{args}}") if 0 != @{$t->{args}};
            die _e($t, q{No data allowed for 'RESTORE'}, $t->{data}) if $t->{data} ne q{};
            push @op, {
                loc     => $t->{loc},
                op      => $t->{op},
                args    => [],
            };
        }
        elsif (KW_UP->{$t->{op}} || KW_DOWN->{$t->{op}}) {
            die _e($t, "'$t->{op}' require command or data") if !@{$t->{args}} && $t->{data} !~ /\S/ms;
            push @op, {
                loc     => $t->{loc},
                op      => $t->{op},
                args    => [
                    @{$t->{args}}           ? (@{$t->{args}}, _data2arg($t->{data}))
                  :                           _shebang($t->{data})
                ],
            };
        }
        elsif ($macro{ $t->{op} }) {
            for (@{ $macro{ $t->{op} } }) {
                my @args
                  = @{$_->{args}}           ? (@{$_->{args}}, _data2arg($_->{data}))
                  : $_->{data} =~ /\S/ms    ? _shebang($_->{data})
                  :                           ()
                  ;
                @args
                  = @args                   ? (@args, @{$t->{args}}, _data2arg($t->{data}))
                  : @{$t->{args}}           ? (@{$t->{args}}, _data2arg($t->{data}))
                  : $t->{data} =~ /\S/ms    ? _shebang($t->{data})
                  :                           ()
                  ;
                die _e($t, "'$t->{op}' require command or data") if !@args;
                push @op, {
                    loc     => $t->{loc},
                    op      => $_->{op},
                    args    => \@args,
                };
            }
        }
        else {
            die _e($t, "Unknown operation '$t->{op}'");
        }
    }
    return @op;
}

sub _shebang {
    my ($script) = @_;
    state $bin = (grep { -x "$_/bash" } split /:/ms, $ENV{PATH})[0] or die 'bash not found';
    return $script =~ /\A#!/ms ? $script : "#!$bin/bash -ex\n$script";
}

sub _tokenize {
    my ($fh, $loc) = @_;
    state $QUOTED = {
        q{\\}   => q{\\},
        q{"}    => q{\"},
        'n'     => "\n",
        'r'     => "\r",
        't'     => "\t",
    };
    my @tokens;
    while (<$fh>) {
        $loc->{line}++;
        if (/\A#/ms) {
            # skip comments
        }
        elsif (/\A(\S+)\s*(.*)\z/ms) {
            # parse token's op and args
            my ($op, $args) = ($1, $2);
            my @args;
            while ($args =~ /\G([^\s"\\]+|"[^"\\]*(?:\\[\\"nrt][^"\\]*)*")(?:\s+|\z)/msgc) {
                my $param = $1;
                if ($param =~ s/\A"(.*)"\z/$1/ms) {
                    $param =~ s/\\([\\"nrt])/$QUOTED->{$1}/msg;
                }
                push @args, $param;
            }
            die _e({loc=>$loc}, 'Bad operation param', $1) if $args =~ /\G(.+)\z/msgc; ## no critic (ProhibitCaptureWithoutTest)
            push @tokens, {
                loc => {%{ $loc }},
                op  => $op,
                args=> \@args,
                data=> q{},
            };
        }
        elsif (/\A(?:\r?\n|[ ][ ].*)\z/ms) {
            if (@tokens) {
                $tokens[-1]{data} .= $_;
            }
            elsif (/\S/ms) {
                die _e({loc=>$loc}, 'Data before operation', $_);
            }
            else {
                # skip /^\s*$/ before first token
            }
        }
        else {
            die _e({loc=>$loc}, 'Bad token', $_);
        }
    }
    # post-process data
    for (@tokens) {
        $_->{data} =~ s/(\A(?:.*?\n)??)(?:\r?\n)*\z/$1/ms;
        $_->{data} =~ s/^[ ][ ]//msg;
    }
    return @tokens;
}


1; # Magic true value required at end of module
__END__