Revision control
Copy as Markdown
# Copyright (C) 2017 The Qt Company Ltd.
# SPDX-License-Identifier: LicenseRef-Qt-Commercial OR GPL-3.0-only WITH Qt-GPL-exception-1.0
package QtQA::Proc::Reliable;
use strict;
use warnings;
use feature 'state';
use English qw( -no_match_vars );
use Carp;
use File::Basename;
use QtQA::Proc::Reliable::Strategy;
use Readonly;
BEGIN {
# On Windows, Proc::Reliable is unreliable.
# Instead we use a stub that we've written,
# which avoids any emulated fork().
if ($OSNAME =~ m{win32}i) {
require QtQA::Proc::Reliable::Win32;
QtQA::Proc::Reliable::Win32->import( );
}
else {
require AutoLoader;
require Proc::Reliable;
Proc::Reliable->import( );
}
}
Readonly my $WINDOWS => ($OSNAME =~ m{win32}i);
Readonly my $TIMEOUT
=> 60*60*24*30; # a long time, but not forever (because Proc::Reliable doesn't support that)
sub new
{
my ($class, $arg_ref, @command) = @_;
my $reliable = $arg_ref->{ reliable };
# If reliable mode is not requested, nothing to do ...
if (!$reliable) {
return;
}
# Likewise, if there is no command, there is nothing to do...
if (!@command) {
return;
}
my $strat_possible = __PACKAGE__->_available_strategies( );
my @strat_selected;
# A reliable mode of 1 means `auto', so we try to find a strategy for
# the command being run, which is guessed as the basename of $command[0]
if (1 eq $reliable) {
$reliable = basename( $command[0] );
if (! exists $strat_possible->{ $reliable }) {
# No auto-strategy for this command, nothing to do...
return;
}
}
# $reliable may be:
#
# [ 'cmd1', 'cmd2', ... ]
#
# or just:
#
# 'cmd1'
#
if (ref($reliable) eq 'ARRAY') {
@strat_selected = @{ $reliable };
}
else {
@strat_selected = ( $reliable );
}
# Check that all the selected strategies really exist, and create them.
my @strat_objects;
foreach my $strat (@strat_selected) {
croak(
__PACKAGE__ . ": requested strategy `$strat' does not exist! Available strategies: "
. join( ',', keys( %{ $strat_possible } ) )
) if (! exists $strat_possible->{ $strat });
my $strat_object = $strat_possible->{ $strat }->new( );
__PACKAGE__->_check_strategy({ name => $strat, object => $strat_object });
push @strat_objects, $strat_object;
}
# OK, all strategies were valid, we're ready to go!
return bless({
strategies => \@strat_objects,
command => \@command,
}, $class);
}
sub run
{
my ($self) = @_;
$self->_reset( );
my $attempt = 1;
my $proc = $self->_create_proc( );
$self->_run_proc( $proc );
while ($proc->status() && (my $why = $self->_should_retry( $proc ))) {
$self->_activate_retry_cb({
proc => $self, # caller sees QtQA::Reliable::Proc (not Reliable::Proc) as $proc
status => $proc->status( ),
reason => $why,
attempt => $attempt++,
});
$self->_run_proc( $proc );
}
return $proc->status( );
}
sub retry_cb
{
my ($self, $callback) = @_;
my $out = $self->{ retry_cb };
if ($callback) {
$self->{ retry_cb } = $callback;
}
return $out;
}
sub command
{
my ($self) = @_;
return @{$self->{ command }};
}
#==================================== internals ===================================================
sub _create_proc
{
my ($self) = @_;
my $proc;
if ($WINDOWS) {
$proc = $self->_create_proc_win32( );
}
else {
$proc = Proc::Reliable->new( );
$proc->stdin_error_ok( 1 ); # OK if child does not read all stdin
$proc->num_tries( 1 ); # don't automatically retry on error
$proc->child_exit_time( 0 ); # don't consider it an error if the test
# doesn't quit soon after closing stdout
$proc->time_per_try( $TIMEOUT ); # don't run for longer than this
$proc->maxtime( $TIMEOUT ); # ...and again (need to set both)
$proc->want_single_list( 0 ); # force stdout/stderr handled separately
}
$proc->stdout_cb( sub { $self->_handle_stdout( @_ ) } );
$proc->stderr_cb( sub { $self->_handle_stderr( @_ ) } );
return $proc;
}
sub _create_proc_win32
{
my ($self) = @_;
return QtQA::Proc::Reliable::Win32->new( );
}
sub _run_proc
{
my ($self, $proc) = @_;
# Inform all strategies that we are about to run.
# In most cases, this will do nothing, but it may be used e.g. to reset some internal
# context to a clean state
$self->_foreach_strategy( sub { shift->about_to_run( ) } );
$proc->run( $self->{ command } );
return;
}
sub _foreach_strategy
{
my ($self, $sub) = @_;
my @out;
foreach my $strategy (@{$self->{ strategies }}) {
push @out, $sub->( $strategy );
}
return @out;
}
sub _reset
{
my ($self) = @_;
# not yet implemented
return;
}
sub _handle_stdout
{
my ($self, $handle, $text) = @_;
$handle->printflush( $text );
$self->_foreach_strategy( sub { shift->process_stdout( $text ) } );
return;
}
sub _handle_stderr
{
my ($self, $handle, $text) = @_;
$handle->printflush( $text );
$self->_foreach_strategy( sub { shift->process_stderr( $text ) } );
return;
}
sub _should_retry
{
my ($self, $proc) = @_;
my @why = $self->_foreach_strategy( sub { shift->should_retry() } );
# For now, we just return the "first" reason why we should retry.
# It's unclear if there is any benefit in attempting to combine the reasons
# (e.g. in the case where multiple strategies flag an error as transient).
return shift @why;
}
sub _activate_retry_cb
{
my ($self, $why_ref) = @_;
if ($self->{ retry_cb }) {
$self->{ retry_cb }->( $why_ref );
}
return;
}
#==================================== static functions ============================================
# Returns a hashref of all available strategies.
# Keys are strategy names, values are strategy classes.
# The return value is calculated only once, and cached for subsequent calls.
sub _available_strategies
{
state $strategies = __PACKAGE__->_find_available_strategies( );
return $strategies;
}
# Returns a hashref of all available strategies,
# exactly as _available_strategies, but not cached.
sub _find_available_strategies
{
my $out = {};
# foreach subclass, which is the last part of the name, e.g. `Git', `Network' ...
foreach my $subclass (QtQA::Proc::Reliable::Strategy->subclasses( )) {
# full class is the full class name, e.g. 'QtQA::Proc::Reliable::Strategy::Git'
my $fullclass = "QtQA::Proc::Reliable::Strategy::$subclass";
# strategy name is the short class name in lowercase, e.g. 'git'
my $strategy = lc $subclass;
# Make sure it can be loaded
eval "use $fullclass"; ## no critic - unavoidable (block form won't work)
confess( __PACKAGE__ . ": internal error: while loading $fullclass: $@" ) if ($@);
$out->{ $strategy } = $fullclass;
}
return $out;
}
# Dies if the given strategy does not appear to implement the correct strategy interface
sub _check_strategy
{
my ($class, $arg_ref) = @_;
my $name = $arg_ref->{ name };
my $object = $arg_ref->{ object };
confess( "$class: internal error: strategy `$name' could not be created; "
."did someone forget to implement the `new' sub?" )
if (! defined $object);
my @required_subs = qw(
process_stdout
process_stderr
should_retry
about_to_run
);
foreach my $sub (@required_subs) {
next if $object->can( $sub );
confess( "$class: internal error: strategy `$name' is missing required sub `$sub'" );
}
return;
}
=head1 NAME
QtQA::Proc::Reliable - reliably execute processes
=head1 SYNOPSIS
use QtQA::Proc::Reliable;
my $proc = QtQA::Proc::Reliable->new({ reliable => 1 }, @cmd);
my $status;
if (!$proc) {
# no `reliable' strategy available, fall back to plain ol' system
$status = system(@cmd);
}
else {
# $proc may automatically retry for certain errors
$proc->retry_cb( sub { warn "Retrying @cmd ..." } );
$status = $proc->run();
}
confess "@cmd exited with status $status" if ($status != 0);
This example will attempt to find a "reliable strategy" for the git command.
If it does, the command may be run via the B<run>() function, which will
automatically retry the command several times in the case of e.g. temporary
network timeouts.
=head1 DESCRIPTION
This class is a logical extension of the highly useful L<Proc::Reliable> module.
That module provides a generic toolkit with many options for running external
processes reliably; this module further wraps L<Proc::Reliable> with appropriate
settings for a variety of commands, with heuristics based on experience running
these commands in Qt's automated test infrastructure.
This class is primarily considered an implementation detail of the
L<QtQA::TestScript> B<exe> function, and generally won't be used directly.
=head1 METHODS
=over
=item B<new>( OPTIONS, COMMAND )
Create a new object with the given OPTIONS and COMMAND.
If a strategy cannot be found, returns undef. Otherwise, returns an object.
These parameters are interpreted exactly as for the L<QtQA::TestScript> B<exe>
function. Please read the documentation for that function for more details.
=item B<command>
Returns the command encapsulated by this object, as a list.
=item B<retry_cb>( SUBREF )
=item B<retry_cb>
Set or get a callback which is executed each time the process is retried.
If set, the callback will be called between each try of the command,
with a single hashref containing the following:
=over
=item proc
Reference to the QtQA::Reliable::Proc object.
=item status
Exit status of the process (e.g. as returned by B<system>).
=item reason
A human-readable string explaining the reason why the command is about to be
retried. This is suitable to print to a log, for example.
=item attempt
The number of the attempt which has failed. Counting starts from 1 for the
first attempt.
=back
=back
=head1 SEE ALSO
L<Proc::Reliable>, L<QtQA::Proc::Reliable::Strategy>, B<exe> function in L<QtQA::TestScript>
=cut
1;