# 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::AnyEvent::Util; use strict; use warnings; use AnyEvent; use AnyEvent::Util qw(); use English qw( -no_match_vars ); use base 'Exporter'; our @EXPORT_OK = qw(run_cmd); # extension of AnyEvent::Util::run_cmd sub run_cmd { my ($cmd, %options) = @_; my $timeout = delete $options{ timeout }; my $cwd = delete $options{ cwd }; my $on_prepare = delete $options{ on_prepare }; my $retry = delete $options{ retry }; my $croak = delete $options{ 'croak' }; if ($cwd) { my $orig_on_prepare = $on_prepare; $on_prepare = sub { chdir( $cwd ) || warn __PACKAGE__ . "::run_cmd: chdir to $cwd: $!"; if ($orig_on_prepare) { $orig_on_prepare->( @_ ) }; }; } if ($on_prepare) { $options{ on_prepare } = $on_prepare; } # We need to know the pid, but note the caller might have asked for it too. my $pid; my $pid_ref = delete( $options{ '$$' } ) || \$pid; $options{ '$$' } = $pid_ref; my $inner_cv; my $timer; my $outer_cv = AE::cv(); my $run; my $end = sub { my ($status) = @_; undef $timer; # cancel any timer in progress undef $run; # $run refers to itself recursively creating a cycle, break it if ($status && $croak) { local $LIST_SEPARATOR = '] ['; $outer_cv->croak( "command [@{ $cmd }] exited with status $status" ); } else { $outer_cv->send( $status ); } }; my $attempt = 0; $run = sub { $inner_cv = AnyEvent::Util::run_cmd( $cmd, %options ); if ($timeout) { my $timeout_cv = $inner_cv; $timer = AE::timer( $timeout, 0, sub { if (!$timeout_cv->ready()) { # timer expired and process is not yet finished local $LIST_SEPARATOR = '] ['; warn "command [@{ $cmd }] timed out after $timeout seconds\n"; kill( 15, $$pid_ref ); $inner_cv->send( -1 ); } undef $timer; }); } $inner_cv->cb( sub { my $status = shift->recv(); if ($status == 0) { $end->( $status ); } elsif (!$retry || ++$attempt > 5) { $end->( $status ); } else { my $sleep = 2**$attempt; local $LIST_SEPARATOR = '] ['; warn "command [@{ $cmd }] exited with status $status [retry in $sleep]\n"; my $retry_timer; $retry_timer = AE::timer( $sleep, 0, sub { undef $retry_timer; $run->(); }); } } ); }; $run->(); return $outer_cv; } =head1 NAME QtQA::AnyEvent::Util - extensions of AnyEvent::Util methods =head1 METHODS Methods are not exported by default. =over =item $cv = run_cmd $cmd, key => value... Extended version of L::run_cmd, supporting the following additional options: =over =item timeout => $seconds Maximum permitted runtime of the command; if the command has not completed within this time, it is killed (signal 15) and $cv receives a value of -1. =item cwd => $path Working directory used for the subprocess. =item retry => $boolean If true, the command will be repeated a few times (with delays) if it exits with a non-zero exit code. Suitable for commands which may be subject to intermittent errors (e.g. ssh over a flaky network connection). =item croak => $boolean If true, $cv will croak when the command fails. =back =back =cut 1;