view release on metacpan or  search on metacpan

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

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,
    default => 0,
);

sub variables       { %{ shift->_variables }       }
sub set_variables   {    shift->_variables({ @_ }) }
sub clear_variables { %{ shift->_variables } = ()  }

sub default_registry { 'sqitch' }

sub load {
    my ( $class, $p ) = @_;

    # We should have an engine param.
    my $target = $p->{target} or hurl 'Missing "target" parameter to load()';

    # Load the engine class.
    my $ekey = $target->engine_key or hurl engine => __(
        'No engine specified; specify via target or core.engine'
    );

    my $pkg = __PACKAGE__ . '::' . $target->engine_key;
    eval "require $pkg" or hurl engine => __x(
        'Unknown engine: {engine}',
        engine => $ekey,
    );
    return $pkg->new( $p );
}

sub driver { shift->key }

sub key {
    my $class = ref $_[0] || shift;
    hurl engine => __ 'No engine specified; specify via target or core.engine'
        if $class eq __PACKAGE__;
    my $pkg = quotemeta __PACKAGE__;
    $class =~ s/^$pkg\:://;
    return $class;
}

sub name { shift->key }

sub config_vars {
    return (
        target   => 'any',
        registry => 'any',
        client   => 'any'
    );
}

sub use_driver {
    my $self = shift;
    my $driver = $self->driver;

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

            # Begin work and run the revert.
            try {
                # Don't bother displaying the reverting change name.
                # $self->sqitch->info('  - ', $change->format_name_with_tags);
                $self->begin_work($change);
                $self->run_revert($change->revert_file) unless $self->log_only;
            } catch {
                # Oy, the revert failed. Just emit the error.
                $sqitch->vent(eval { $_->message } // $_);
            };
            hurl private => __ 'Deploy failed';
        };
    } finally {
        $self->finish_work($change);
    } catch {
        $self->log_fail_change($change);
        $sqitch->info(__ 'not ok');
        die $_;
    };
}

sub revert_change {
    my ( $self, $change ) = @_;
    my $sqitch = $self->sqitch;
    my $name   = $change->format_name_with_tags;
    $sqitch->info_literal(
        "  - $name ..",
        '.' x ($self->max_name_length - length $name), ' '
    );

    $self->begin_work($change);

    try {
        my $file = $change->revert_file;
        hurl revert => __x(
            'Revert script {file} does not exist',
            file => $file,
        ) unless -e $file;
        $self->run_revert($file) unless $self->log_only;
        try {
            $self->log_revert_change($change);
            $sqitch->info(__ 'ok');
        } catch {
            # Oy, our logging died. Rollback and revert this change.
            $self->sqitch->vent(eval { $_->message } // $_);
            $self->rollback_work($change);
            hurl revert => 'Revert failed';
        };
    } finally {
        $self->finish_work($change);
    } catch {
        $sqitch->info(__ 'not ok');
        die $_;
    };
}

sub lock_destination {
    my $self = shift;

    # Try to acquire the lock without waiting.
    return $self if $self->_locked;
    return $self->_locked(1) if $self->try_lock;

    # Lock not acquired. Tell the user what's happening.
    my $wait = $self->lock_timeout;
    $self->sqitch->info(__x(
        'Blocked by another instance of Sqitch working on {dest}; waiting {secs} seconds...',
        dest => $self->destination,
        secs => $wait,
    ));

    # Try waiting for the lock.
    return $self->_locked(1) if $self->wait_lock;

    # Timed out, so bail.
    hurl engine => __x(
        'Timed out waiting {secs} seconds for another instance of Sqitch to finish work on {dest}',
        dest => $self->destination,
        secs => $wait,
    );
}

sub _timeout {
    my ($self, $code) = @_;
    require Algorithm::Backoff::Exponential;
    my $ab = Algorithm::Backoff::Exponential->new(
        max_actual_duration => $self->lock_timeout,
        initial_delay       => 0.01, # 10 ms
        max_delay           => 10,   # 10 s
    );

    while (1) {
        if (my $ret = $code->()) {
            return 1;
        }
        my $secs = $ab->failure;
        return 0 if $secs < 0;
        sleep $secs;
    }
}

sub try_lock { 1 }
sub wait_lock {
    my $class = ref $_[0] || $_[0];
    hurl "$class has not implemented wait_lock()";
}

sub begin_work  { shift }
sub finish_work { shift }
sub rollback_work { shift }

sub earliest_change {
    my $self = shift;
    my $change_id = $self->earliest_change_id(@_) // return undef;
    return $self->plan->get( $change_id );
}

sub latest_change {
    my $self = shift;
    my $change_id = $self->latest_change_id(@_) // return undef;
    return $self->plan->get( $change_id );
}

sub needs_upgrade {
    my $self = shift;
    $self->registry_version != $self->registry_release;
}

sub _check_registry {
    my $self   = shift;
    my $newver = $self->registry_release;
    my $oldver = $self->registry_version;
    return $self if $newver == $oldver;