...
 
Commits (10)
......@@ -20,9 +20,8 @@ use strict;
use warnings;
use autodie;
use Capture::Tiny qw(capture);
use IO::Async::Loop;
use List::MoreUtils qw(first_index none);
use Try::Tiny;
use Lintian::Command qw(safe_qx);
use Lintian::Data;
......@@ -49,20 +48,32 @@ sub run {
# Run ar t on the *.deb file. deb will be a symlink to it.
my $failed; # set to one when something is so bad that we can't continue
my $error;
my ($stdout, $stderr) = capture {
try {
my @command = ('ar', 't', $deb);
system(@command) == 0
or die "system @command failed: $?";
}
catch {
# catch any error
$error = $_;
};
};
my $loop = IO::Async::Loop->new;
my $future = $loop->new_future;
my @command = ('ar', 't', $deb);
my $stdout = EMPTY;
my $stderr = EMPTY;
$loop->open_process(
command => [@command],
stdout => { into => \$stdout },
stderr => { into => \$stderr },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
$future->fail(
"Non-zero status $status from @comand");
return;
}
$future->done("Done with @command");
return;
});
$loop->await($future);
unless (length $error) {
if ($future->is_done) {
my @members = split(NEWLINE, $stdout);
my $count = scalar(@members);
my ($ctrl_member, $data_member);
......
......@@ -1365,16 +1365,24 @@ sub script_is_evil_and_wrong {
sub check_script_syntax {
my ($interpreter, $path) = @_;
my $fs_path = $path->fs_path;
my $pid = do_fork();
if ($pid == 0) {
open(STDOUT, '>', '/dev/null');
open(STDERR, '>&', \*STDOUT);
exec $interpreter, '-n', $fs_path
or internal_error("cannot exec $interpreter: $!");
} else {
waitpid $pid, 0;
}
return $?;
my $error;
my (undef, $stderr, $status) = capture {
try {
my @command = ($interpreter, '-n', $fs_path);
system(@command) == 0
or die "system @command failed: $?";
}
catch {
# catch any error
$error = $_;
};
};
print $stderr
if length $stderr;
return $status;
}
sub remove_comments {
......
......@@ -45,6 +45,12 @@ sub collect {
my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new($pkg, $type, $dir);
my $outfile = "$dir/file-info.gz";
if (-e $outfile) {
unlink($outfile);
}
chdir("$dir/unpacked");
my $prehelper = EMPTY;
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
# Copyright (C) 2010 Raphael Geissert <atomo64@gmail.com>
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 2 of the License, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
# more details.
#
# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>.
package Lintian::Command::Simple;
use strict;
use warnings;
use Exporter qw(import);
use POSIX qw(:sys_wait_h);
our @EXPORT_OK = qw(wait_any kill_all);
=head1 NAME
Lintian::Command::Simple - Run commands without pipes
=head1 SYNOPSIS
use Lintian::Command::Simple qw(wait_any);
my %pid_info;
my $pid = fork() // die("fork: $!");
exec('do', 'something') if $pid == 0;
$pid_info{$pid} = "A useful value associated with $pid";
my ($termiated_pid, $value) = wait_any(\%pid_info);
...;
=head1 DESCRIPTION
Lintian::Command::Simple allows running commands with the capability of
running them "in the background" (asynchronously.)
Pipes are not handled at all, except for those handled internally by
the shell. See 'perldoc -f exec's note about shell metacharacters.
If you want to pipe to/from Perl, look at Lintian::Command instead.
=over 4
=item wait_any (hashref[, nohang])
When starting multiple processes asynchronously, it is common to wait
until the first is done. While the CORE::wait() function is usually
used for that very purpose, it does not provide the desired results
when the processes were started via the OO interface.
To help with this task, wait_any() can take a hash ref where the key
of each entry is the pid of that command. There are no requirements
for the value (which can be used for any application specific
purpose).
Under this mode, wait_any() waits until any child process is done.
The key (and value) associated the pid of the reaped child will then
be removed from the hashref. The exitcode of the child is available
via C<$?> as usual.
The results and return value are undefined when under this mode
wait_any() "accidentally" reaps a process not listed in the hashref.
The return value in scalar context is value associated with the pid of
the reaped processed. In list context, the pid and value are returned
as a pair.
Whenever waitpid() would return -1, wait_any() returns undef or a null
value so that it is safe to:
while($cmd = wait_any(\%hash)) { something; }
The same is true whenever the hash reference points to an empty hash.
If C<nohang> is also given, wait_any will attempt to reap any child
process non-blockingly. If no child can be reaped, it will
immediately return (like there were no more processes left) instead of
waiting.
=cut
sub wait_any {
my ($jobs, $nohang) = @_;
my $reaped_pid;
my $extra;
$nohang = WNOHANG if $nohang;
$nohang //= 0;
return unless scalar keys %$jobs;
$reaped_pid = waitpid(-1, $nohang);
if ($reaped_pid == -1 or ($nohang and $reaped_pid == 0)) {
return;
}
# Did we reap some other pid?
return unless exists $jobs->{$reaped_pid};
$extra = delete $jobs->{$reaped_pid};
return ($reaped_pid, $extra) if wantarray;
return $extra;
}
=item kill_all(hashref[, signal])
In a similar way to wait_any(), it is possible to pass a hash
reference to kill_all(). It will then kill all of the processes
(default signal being "TERM") followed by a reaping of the processes.
All reaped processes (and their values) will be removed from the set.
Any entries remaining in the hashref are processes that did not
terminate (or did not terminate yet).
=cut
sub kill_all {
my ($jobs, $signal) = @_;
my $count = 0;
my @jobs;
$signal //= 'TERM';
foreach my $pid (keys %$jobs) {
push @jobs, $pid if kill $signal, $pid;
}
foreach my $pid (@jobs) {
if (waitpid($pid, 0) == $pid) {
$count++;
delete $jobs->{$pid};
}
}
return scalar @jobs;
}
1;
__END__
=back
=head1 NOTES
Unless specified by prefixing the package name, every reference to a
function/method in this documentation refers to the functions/methods
provided by this package itself.
=head1 CAVEATS
Combining asynchronous jobs (e.g. via Lintian::Command) and calls to
wait_any() can lead to unexpected results.
=head1 AUTHOR
Originally written by Raphael Geissert <atomo64@gmail.com> for Lintian.
=cut
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
......@@ -264,8 +264,7 @@ sub create {
if (not -d $base_dir) {
# In the pool we may have to create multiple directories. On
# error we only remove the "top dir" and that is enough.
system('mkdir', '-p', $base_dir) == 0
or croak "mkdir -p $base_dir failed";
path($base_dir)->mkpath;
$madedir = 1;
} else {
# If $base_dir exists, then check if the entry exists
......
......@@ -393,6 +393,26 @@ sub do_fork() {
return $pid;
}
=item system_env (CMD)
Behaves like system (CMD) except that the environment of CMD is
cleaned (as defined by L</clean_env>(1)).
=cut
sub system_env {
my $pid = do_fork;
if (not defined $pid) {
return -1;
} elsif ($pid == 0) {
clean_env(1);
exec @_ or die("exec of $_[0] failed: $!\n");
} else {
waitpid $pid, 0;
return $?;
}
}
=item clean_env ([CLOC])
Destructively cleans %ENV - removes all variables %ENV except a
......
......@@ -56,8 +56,9 @@ use File::Basename;
use File::Find::Rule;
use File::Path;
use File::stat;
use Path::Tiny;
use File::Temp qw(tempfile);
use IO::Async::Loop;
use Path::Tiny;
use Text::Template;
use constant NEWLINE => qq{\n};
......@@ -132,8 +133,33 @@ sub calibrate {
my ($hook, $actual, $expected, $calibrated) = @_;
if (-x $hook) {
system($hook, $expected, $actual, $calibrated) == 0
or croak "Hook $hook failed on $actual: $!";
my $loop = IO::Async::Loop->new;
my $future = $loop->new_future;
my @command = ($hook, $expected, $actual, $calibrated);
my $stdout;
$loop->open_process(
command => [@command],
stdout => { into => \$stdout },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
$future->fail(
"Non-zero status $status from @comand");
return;
}
$future->done("Done with @command");
return;
});
$loop->await($future);
croak $future->get
unless $future->is_done;
croak "No calibrated tags created in $calibrated"
unless -f $calibrated;
return $calibrated;
......
......@@ -13,15 +13,6 @@ plan skip_all => 'Need newer version of aspell-en (>= 7.1)'
use Test::Lintian;
BEGIN {
# If IPCRUNDEBUG is set to 'none', reset to 0. Unfortunately,
# IPC::Run and IPC::Run3 reads the variables different and we end
# up loading IPC::Run via Test::Lintian.
$ENV{'IPCRUNDEBUG'} = 0
if exists($ENV{'IPCRUNDEBUG'})
&& $ENV{'IPCRUNDEBUG'} eq 'none';
}
eval 'use Test::Spelling';
plan skip_all => 'Pod spell checking requires Test::Spelling' if $@;
......