X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FTest-Valgrind.git;a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FSession.pm;h=ca586ea46caa7d4c91a28d57b61f1e73bb0e16c1;hp=3b377fb482d0d3f127cfd6f93b96086bfd89a267;hb=b34179155630f5f4cbea1749af4054a746ded9a4;hpb=8cacc78f5dbd91f8ff36075b44d923edd659541f diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index 3b377fb..ca586ea 100644 --- a/lib/Test/Valgrind/Session.pm +++ b/lib/Test/Valgrind/Session.pm @@ -9,11 +9,11 @@ Test::Valgrind::Session - Test::Valgrind session object. =head1 VERSION -Version 1.15 +Version 1.17 =cut -our $VERSION = '1.15'; +our $VERSION = '1.17'; =head1 DESCRIPTION @@ -25,8 +25,9 @@ It also acts as a dispatcher between the different components. use File::Spec (); use Scalar::Util (); -use Fcntl (); # F_SETFD -use POSIX (); # SIGKILL +use Fcntl (); # F_SETFD +use IO::Select; +use POSIX (); # SIGKILL, _exit() use version (); @@ -230,26 +231,25 @@ If the command is a L object, the action and =cut sub run { - my $self = shift; - - my %args = @_; - - $self->start(%args); - my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish }); + my ($self, %args) = @_; - $self->_run($args{command}); -} - -sub _run { - my ($self, $cmd) = @_; + for (qw) { + my $base = 'Test::Valgrind::' . ucfirst; + my $value = $args{$_}; + $self->_croak("Invalid $_") unless Scalar::Util::blessed($value) + and $value->isa($base); + $self->$_($args{$_}) + } + my $cmd = $self->command; if ($cmd->isa('Test::Valgrind::Command::Aggregate')) { - $self->_run($_) for $cmd->commands; + for my $subcmd ($cmd->commands) { + $args{command} = $subcmd; + $self->run(%args); + } return; } - $self->command($cmd); - $self->report($self->report_class->new_diag( 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind )); @@ -303,48 +303,121 @@ sub _run { @supp_args = map "--suppressions=$_", @supp_files; } - pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!"); - { - my $oldfh = select $vrdr; - $|++; - select $oldfh; - } + my $error; + GUARDED: { + my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish }); + $self->start; - 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) { - eval 'setpgrp 0, 0'; - close $vrdr or $self->_croak("close(\$vrdr): $!"); - fcntl $vwtr, Fcntl::F_SETFD(), 0 + pipe my $erdr, my $ewtr or $self->_croak("pipe(\$erdr, \$ewtr): $!"); + { + my $oldfh = select $erdr; + $|++; + select $oldfh; + } + + 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), + ); -# $self->report($self->report_class->new_diag("@args")); + { + no warnings 'exec'; + exec { $args[0] } @args; + } + $self->_croak("exec @args: $!"); + }; - exec { $args[0] } @args or $self->_croak("exec @args: $!"); - } + print $ewtr $@; + close $ewtr; - local $SIG{INT} = sub { - kill -(POSIX::SIGKILL()) => $pid; - waitpid $pid, 0; - die 'interrupted'; - }; + POSIX::_exit(255); + } - close $vwtr or $self->_croak("close(\$vwtr): $!"); + 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; + } + } + } - $self->parser->parse($self, $vrdr); + my $aborted = $self->parser->parse($self, $vrdr); - $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255; + if ($aborted) { + $self->report($self->report_class->new_diag("valgrind has aborted")); + return 0; + } - close $vrdr or $self->_croak("close(\$vrdr): $!"); + 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->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255; + + close $erdr or $self->_croak("close(\$erdr): $!"); + close $vrdr or $self->_croak("close(\$vrdr): $!"); + + return; + } + + die $error if $error; return; } @@ -458,11 +531,7 @@ sub suppressions { =head2 C - $tvs->start( - action => $action, - tool => $tool, - command => $command, - ); + $tvs->start; Starts the action and tool associated to the current run. It's automatically called at the beginning of L. @@ -472,16 +541,6 @@ It's automatically called at the beginning of L. sub start { my $self = shift; - my %args = @_; - - for (qw) { - my $base = 'Test::Valgrind::' . ucfirst; - my $value = $args{$_}; - $self->_croak("Invalid $_") unless Scalar::Util::blessed($value) - and $value->isa($base); - $self->$_($args{$_}) - } - delete @{$self}{qw}; $self->tool->start($self);