view release on metacpan or  search on metacpan

lib/App/Sqitch/Engine.pm  view on Meta::CPAN

use App::Sqitch::X qw(hurl);
use List::Util qw(first max);
use URI::db 0.20;
use App::Sqitch::Types qw(Str Int Num Sqitch Plan Bool HashRef URI Maybe Target);
use namespace::autoclean;
use constant registry_release => '1.1';
use constant default_lock_timeout => 60;

our $VERSION = 'v1.6.1'; # VERSION

has sqitch => (
    is       => 'ro',
    isa      => Sqitch,
    required => 1,
    weak_ref => 1,
);

has target => (
    is       => 'ro',
    isa      => Target,
    required => 1,
    weak_ref => 1,
    handles => {
        uri         => 'uri',
        client      => 'client',
        registry    => 'registry',
        destination => 'name',
    }
);

has username => (
    is      => 'ro',
    isa     => Maybe[Str],
    lazy    => 1,
    default => sub {
        my $self = shift;
        $self->target->username || $self->_def_user
    },
);

has password => (
    is      => 'ro',
    isa     => Maybe[Str],
    lazy    => 1,
    default => sub {
        my $self = shift;
        $self->target->password || $self->_def_pass
    },
);

sub _def_user { }
sub _def_pass { }

sub registry_destination { shift->destination }

has start_at => (
    is  => 'rw',
    isa => Str
);

has no_prompt => (
    is      => 'rw',
    isa     => Bool,
    trigger => sub {
        # Deprecation notice added Feb 2023
        warnings::warnif(
            "deprecated",
            "Engine::no_prompt is deprecated and will be removed in a future release\n"
            . "Use direct arguments to revert() instead",
        );
    }
);

has prompt_accept => (
    is      => 'rw',
    isa     => Bool,
    trigger => sub {
        # Deprecation notice added Feb 2023
        warnings::warnif(
            "deprecated",
            "Engine::prompt_accept is deprecated and will be removed in a future release\n"
            . "Use direct arguments to revert() instead",
        );
    }
);

has log_only => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

has with_verify => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

has max_name_length => (
    is      => 'rw',
    isa     => Int,
    default => 0,
    lazy    => 1,
    default => sub {
        my $plan = shift->plan;
        max map {
            length $_->format_name_with_tags
        } $plan->changes;
    },
);

has plan => (
    is       => 'rw',
    isa      => Plan,
    lazy     => 1,
    default  => sub { shift->target->plan }
);

has _variables => (
    is      => 'rw',
    isa     => HashRef[Str],
    default => sub { {} },
);

# Usually expressed as an integer, but made a number for the purposes of
# shorter test run times.
has lock_timeout => (
    is      => 'rw',
    isa     => Num,
    default => default_lock_timeout,
);

has _locked => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

has _no_registry => (
    is      => 'rw',
    isa     => Bool,

lib/App/Sqitch/Engine.pm  view on Meta::CPAN

            ));
            $self->initialize;
        }
        $self->register_project;

    } else {
        # Make sure that $to_index is greater than the current point.
        hurl deploy => __ 'Cannot deploy to an earlier change; use "revert" instead'
            if $to_index < $position;
        # Upgrade database if it needs it.
        $self->upgrade_registry;
    }

    $sqitch->info(
        defined $to ? __x(
            'Deploying changes through {change} to {destination}',
            change      => $plan->change_at($to_index)->format_name_with_tags,
            destination => $self->destination,
        ) : __x(
            'Deploying changes to {destination}',
            destination => $self->destination,
        )
    );

    $sqitch->debug(__ "Will deploy the following changes:");
    foreach my $will_deploy_position (($plan->position + 1) .. $to_index) {
        $sqitch->debug($plan->change_at($will_deploy_position)->format_name_with_tags);
    }

    # Check that all dependencies will be satisfied.
    $self->check_deploy_dependencies($plan, $to_index);

    # Do it!
    $mode ||= 'all';
    my $meth = $mode eq 'change' ? '_deploy_by_change'
             : $mode eq 'tag'  ? '_deploy_by_tag'
             : $mode eq 'all'  ? '_deploy_all'
             : hurl deploy => __x 'Unknown deployment mode: "{mode}"', mode => $mode;
    ;

    $self->max_name_length(
        max map {
            length $_->format_name_with_tags
        } ($plan->changes)[$position + 1..$to_index]
    );

    $self->$meth( $plan, $to_index );
}

# Do a thing similar to Sqitch::Plan::Change::format_name_with_tags,
# but for an output from $self->deployed_changes or
# $self->deployed_changes_since.
sub _format_deployed_change_name_with_tags($) {
    my ( $self, $change ) = @_;

    return join ' ', $change->{name}, map { '@' . $_ } @{$change->{tags}};
}

sub revert {
    # $to = revert up to (but not including) this change. May be undefined.
    # $prompt = If true, we ask for confirmation; if false, we don't.
    # $prompt_default = Default if the user just hits enter at the prompt.
    my ( $self, $to, $prompt, $prompt_default ) = @_;

    if (defined $prompt) {
        hurl revert => __('Missing required parameter $prompt_default')
            unless defined $prompt_default;
    } else {
        warnings::warnif(deprecated => join ("\n",
            "Engine::revert() requires the `prompt` and `prompt_default` arguments.",
            'Omitting them will become fatal in a future release.',
        ));

        $prompt = !($self->no_prompt // 0);
        $prompt_default = $self->prompt_accept // 1;
    }

    # Check the registry and, once we know it's there, lock the destination.
    $self->_check_registry;
    $self->lock_destination;

    my $sqitch = $self->sqitch;
    my $plan   = $self->plan;
    my @changes;

    if (defined $to) {
        my ($change) = $self->_load_changes(
            $self->change_for_key($to)
        ) or do {
            # Not deployed. Is it in the plan?
            if ( $plan->find($to) ) {
                # Known but not deployed.
                hurl revert => __x(
                    'Change not deployed: "{change}"',
                    change => $to
                );
            }
            # Never heard of it.
            hurl revert => __x(
                'Unknown change: "{change}"',
                change => $to,
            );
        };

        # NB this is an array of unblessed references, not of
        # Sqitch::Plan::Change references.
        @changes = $self->deployed_changes_since(
            $self->_load_changes($change)
        ) or do {
            $sqitch->info(__x(
                'No changes deployed since: "{change}"',
                change => $to,
            ));
            return $self;
        };
        my @change_descriptions =
            map { $self->_format_deployed_change_name_with_tags($_) } @changes;

        unless ($prompt) {
            $sqitch->info(__x(
                'Reverting changes to {change} from {destination}',
                change      => $change->format_name_with_tags,
                destination => $self->destination,
            ));
            $sqitch->debug(__ 'Will revert the following changes:');
            map { $sqitch->debug($_) } @change_descriptions;
        } else {
            $sqitch->debug(__ 'Would revert the following changes:');
            map { $sqitch->debug($_) } @change_descriptions;
            hurl {
                ident   => 'revert:confirm',
                message => __ 'Nothing reverted',
                exitval => 1,
            } unless $sqitch->ask_yes_no(__x(
                'Revert changes to {change} from {destination}?',
                change      => $change->format_name_with_tags,
                destination => $self->destination,
            ), $prompt_default );
        }
    } else {
        # NB this is an array of unblessed references, not of
        # Sqitch::Plan::Change references.
        @changes = $self->deployed_changes or do {
            $sqitch->info(__ 'Nothing to revert (nothing deployed)');
            return $self;
        };
        my @change_descriptions =
            map { $self->_format_deployed_change_name_with_tags($_) } @changes;

        unless ($prompt) {
            $sqitch->info(__x(
                'Reverting all changes from {destination}',
                destination => $self->destination,
            ));
            $sqitch->debug(__ 'Will revert the following changes:');
            map { $sqitch->debug($_) } @change_descriptions;
        } else {
            $sqitch->debug(__ 'Would revert the following changes:');
            map { $sqitch->debug($_) } @change_descriptions;
            hurl {
                ident   => 'revert',
                message => __ 'Nothing reverted',
                exitval => 1,
            } unless $sqitch->ask_yes_no(__x(
                'Revert all changes from {destination}?',
                destination => $self->destination,
            ), $prompt_default );
        }
    }

    # Make change objects and check that all dependencies will be satisfied.
    @changes = reverse $self->_load_changes( @changes );
    $self->check_revert_dependencies(@changes);

    # Do we want to support modes, where failures would re-deploy to previous
    # tag or all the way back to the starting point? This would be very much
    # like deploy() mode. I'm thinking not, as a failure on a revert is not
    # something you generally want to recover from by deploying back to where
    # you started. But maybe I'm wrong?
    $self->max_name_length(
        max map { length $_->format_name_with_tags } @changes
    );
    $self->revert_change($_) for @changes;

    return $self;
}

sub verify {
    my ( $self, $from, $to ) = @_;
    # $from = verify changes after and including this one, or if undefined starting from the first change.
    # $to = verify changes up to but not including this one, or if undefined up to all changes.

    $self->_check_registry;
    my $sqitch   = $self->sqitch;
    my $plan     = $self->plan;
    my @changes  = $self->_load_changes( $self->deployed_changes );

    $sqitch->info(__x(
        'Verifying {destination}',
        destination => $self->destination,
    ));

    if (!@changes) {
        my $msg = $plan->count
            ? __ 'No changes deployed'
            : __ 'Nothing to verify (no planned or deployed changes)';
        $sqitch->info($msg);
        return $self;
    }

    if ($plan->count == 0) {
        # Oy, there are deployed changes, but not planned!
        hurl verify => __ 'There are deployed changes, but none planned!';
    }

    # Figure out where to start and end relative to the plan.
    my $from_idx = $self->_from_idx('verify', $from, \@changes);
    my $to_idx = $self->_to_idx('verify', $to, \@changes);

    # Run the verify tests.
    if ( my $count = $self->_verify_changes($from_idx, $to_idx, !$to, @changes) ) {
        # Emit a quick report.
        # XXX Consider coloring red.
        my $num_changes = 1 + $to_idx - $from_idx;
        $num_changes = @changes if @changes > $num_changes;
        my $msg = __ 'Verify Summary Report';
        $sqitch->emit("\n", $msg);