=head1 VERSION
-Version 1.15
+Version 1.19
=cut
-our $VERSION = '1.15';
+our $VERSION = '1.19';
=head1 DESCRIPTION
=cut
+use Config ();
use File::Spec ();
+use ExtUtils::MM (); # MM->maybe_command()
use Scalar::Util ();
-use Fcntl (); # F_SETFD
-use POSIX (); # SIGKILL
-
-use version ();
+use Fcntl (); # F_SETFD
+use IO::Select;
+use POSIX (); # SIGKILL, _exit()
use base qw<Test::Valgrind::Carp>;
+use Test::Valgrind::Version;
+
=head1 METHODS
=head2 C<new>
if (defined $vg and not ref $vg) {
@paths = ($vg);
} else {
- push @paths, @$vg if $vg and ref $vg eq 'ARRAY';
+ push @paths, @$vg if defined $vg and ref $vg eq 'ARRAY';
my $dirs = delete $args{search_dirs};
- $dirs = [ File::Spec->path ] unless $dirs;
- push @paths, map File::Spec->catfile($_, 'valgrind'), @$dirs
+ $dirs = [ File::Spec->path ] unless defined $dirs;
+ my $exe_name = 'valgrind';
+ $exe_name .= $Config::Config{exe_ext} if defined $Config::Config{exe_ext};
+ push @paths, map File::Spec->catfile($_, $exe_name), @$dirs
if ref $dirs eq 'ARRAY';
}
$class->_croak('Empty valgrind candidates list') unless @paths;
my $min_version = delete $args{min_version};
- defined and not ref and $_ = version->new($_) for $min_version;
+ if (defined $min_version) {
+ $min_version = Test::Valgrind::Version->new(string => $min_version);
+ }
my ($valgrind, $version);
- for (@paths) {
- next unless -x;
- my $ver = qx/$_ --version/;
- if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) {
- if ($min_version) {
- $version = version->new($1);
- next if $version < $min_version;
- } else {
- $version = $1;
- }
- $valgrind = $_;
+ for my $path (@paths) {
+ next unless defined($path) and MM->maybe_command($path);
+ my $output = qx/$path --version/;
+ my $ver = do {
+ local $@;
+ eval { Test::Valgrind::Version->new(command_output => $output) };
+ };
+ if (defined $ver) {
+ next if defined $min_version and $ver < $min_version;
+ $valgrind = $path;
+ $version = $ver;
last;
}
}
my $valgrind_version = $tvs->version;
-The L<version> object associated to the selected C<valgrind>.
-
-=cut
-
-sub version {
- my ($self) = @_;
-
- my $version = $self->{version};
- $self->{version} = $version = version->new($version) unless ref $version;
-
- return $version;
-}
+The L<Test::Valgrind::Version> object associated to the selected C<valgrind>.
=head2 C<regen_def_supp>
eval "sub $_ { \$_[0]->{$_} }" for qw<
valgrind
+ version
regen_def_supp
no_def_supp
allow_no_supp
@supp_args = map "--suppressions=$_", @supp_files;
}
- my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish });
- $self->start;
+ my $error;
+ GUARDED: {
+ my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish });
+ $self->start;
- pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!");
- {
- my $oldfh = select $vrdr;
- $|++;
- select $oldfh;
- }
-
- my $pid = fork;
- $self->_croak("fork(): $!") unless defined $pid;
+ pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!");
+ {
+ my $oldfh = select $vrdr;
+ $|++;
+ select $oldfh;
+ }
- if ($pid == 0) {
+ pipe my $erdr, my $ewtr or $self->_croak("pipe(\$erdr, \$ewtr): $!");
{
- local $@;
- eval { setpgrp(0, 0) };
+ my $oldfh = select $erdr;
+ $|++;
+ select $oldfh;
}
- close $vrdr or $self->_croak("close(\$vrdr): $!");
- fcntl $vwtr, Fcntl::F_SETFD(), 0
+
+ my $pid = fork;
+ $self->_croak("fork(): $!") unless defined $pid;
+
+ if ($pid == 0) {
+ {
+ local $@;
+ eval { setpgrp(0, 0) };
+ }
+
+ close $erdr or POSIX::_exit(255);
+
+ local $@;
+ eval {
+ close $vrdr or $self->_croak("close(\$vrdr): $!");
+
+ fcntl $vwtr, Fcntl::F_SETFD(), 0
or $self->_croak("fcntl(\$vwtr, F_SETFD, 0): $!");
- my @args = (
- $self->valgrind,
- $self->tool->args($self),
- @supp_args,
- $self->parser->args($self, $vwtr),
- $self->command->args($self),
- );
+ my @args = (
+ $self->valgrind,
+ $self->tool->args($self),
+ @supp_args,
+ $self->parser->args($self, $vwtr),
+ $self->command->args($self),
+ );
+
+ {
+ no warnings 'exec';
+ exec { $args[0] } @args;
+ }
+ $self->_croak("exec @args: $!");
+ };
-# $self->report($self->report_class->new_diag("@args"));
+ print $ewtr $@;
+ close $ewtr;
- exec { $args[0] } @args or $self->_croak("exec @args: $!");
- }
+ POSIX::_exit(255);
+ }
+
+ local $@;
+ eval {
+ local $SIG{INT} = sub {
+ die 'valgrind analysis was interrupted';
+ };
+
+ close $vwtr or $self->_croak("close(\$vwtr): $!");
+ close $ewtr or $self->_croak("close(\$ewtr): $!");
+
+ SEL: {
+ my $sel = IO::Select->new($vrdr, $erdr);
+
+ my $child_err;
+ while (my @ready = $sel->can_read) {
+ last SEL if @ready == 1 and fileno $ready[0] == fileno $vrdr;
+
+ my $buf;
+ my $bytes_read = sysread $erdr, $buf, 4096;
+ if (not defined $bytes_read) {
+ $self->_croak("sysread(\$erdr): $!");
+ } elsif ($bytes_read) {
+ $sel->remove($vrdr) unless $child_err;
+ $child_err .= $buf;
+ } else {
+ $sel->remove($erdr);
+ die $child_err if $child_err;
+ }
+ }
+ }
- local $SIG{INT} = sub {
- kill -(POSIX::SIGKILL()) => $pid;
- waitpid $pid, 0;
- die 'valgrind analysis was interrupted';
- };
+ my $aborted = $self->parser->parse($self, $vrdr);
+
+ if ($aborted) {
+ $self->report($self->report_class->new_diag("valgrind has aborted"));
+ return 0;
+ }
- close $vwtr or $self->_croak("close(\$vwtr): $!");
+ 1;
+ } or do {
+ $error = $@;
+ kill -(POSIX::SIGKILL()) => $pid if kill 0 => $pid;
+ close $erdr;
+ close $vrdr;
+ waitpid $pid, 0;
+ # Force the guard destructor to trigger now so that old perls don't lose $@
+ last GUARDED;
+ };
- $self->parser->parse($self, $vrdr);
+ $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
- $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
+ close $erdr or $self->_croak("close(\$erdr): $!");
+ close $vrdr or $self->_croak("close(\$vrdr): $!");
+
+ return;
+ }
- close $vrdr or $self->_croak("close(\$vrdr): $!");
+ die $error if $error;
return;
}
L<Test::Valgrind>, L<Test::Valgrind::Action>, L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Parser>.
-L<version>, L<File::HomeDir>.
+L<File::HomeDir>.
=head1 AUTHOR
=head1 COPYRIGHT & LICENSE
-Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
+Copyright 2009,2010,2011,2013,2015,2016 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
projects / perl / modules / Test-Valgrind.git / blobdiff