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=95aaa011b9bf7e3c414b27da8e27306f5da89879;hb=b34179155630f5f4cbea1749af4054a746ded9a4;hpb=1b06adb9788085e8aad3af42ea384153cd0a4fe6 diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index 95aaa01..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.02 +Version 1.17 =cut -our $VERSION = '1.02'; +our $VERSION = '1.17'; =head1 DESCRIPTION @@ -22,23 +22,31 @@ It also acts as a dispatcher between the different components. =cut -# All these modules are required at configure time. +use File::Spec (); +use Scalar::Util (); -BEGIN { - require File::Spec; - require Scalar::Util; - - require Fcntl; # F_SETFD - require POSIX; # SIGKILL -} +use Fcntl (); # F_SETFD +use IO::Select; +use POSIX (); # SIGKILL, _exit() -use base qw/Test::Valgrind::Carp/; +use version (); -use Test::Valgrind::Report; +use base qw; =head1 METHODS -=head2 C<< new search_dirs => \@search_dirs, valgrind => [ $valgrind | \@valgrind ], min_version => $min_version, no_def_supp => $no_def_supp, extra_supps => \@extra_supps >> +=head2 C + + my $tvs = Test::Valgrind::Session->new( + search_dirs => \@search_dirs, + valgrind => $valgrind, # One candidate + valgrind => \@valgrind, # Several candidates + min_version => $min_version, + regen_def_supp => $regen_def_supp, + no_def_supp => $no_def_supp, + allow_no_supp => $allow_no_supp, + extra_supps => \@extra_supps, + ); The package constructor, which takes several options : @@ -66,7 +74,19 @@ Defaults to none. =item * -If C<$no_def_supp> is false, C won't read the default suppression file associated with the tool and the command. +If C<$regen_def_supp> is true, the default suppression file associated with the tool and the command will be forcefully regenerated. + +Defaults to false. + +=item * + +If C<$no_def_supp> is true, C won't read the default suppression file associated with the tool and the command. + +Defaults to false. + +=item * + +If C<$allow_no_supp> is true, the command will always be run into C even if no appropriate suppression file is available. Defaults to false. @@ -80,11 +100,6 @@ Defaults to none. =cut -my $build_version = sub { - require version; - version->new($_[0]); -}; - sub new { my $class = shift; $class = ref($class) || $class; @@ -92,7 +107,7 @@ sub new { my %args = @_; my @paths; - my $vg = delete $args{vg}; + my $vg = delete $args{valgrind}; if (defined $vg and not ref $vg) { @paths = ($vg); } else { @@ -105,7 +120,7 @@ sub new { $class->_croak('Empty valgrind candidates list') unless @paths; my $min_version = delete $args{min_version}; - defined and not ref and $_ = $build_version->($_) for $min_version; + defined and not ref and $_ = version->new($_) for $min_version; my ($valgrind, $version); for (@paths) { @@ -113,7 +128,7 @@ sub new { my $ver = qx/$_ --version/; if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) { if ($min_version) { - $version = $build_version->($1); + $version = version->new($1); next if $version < $min_version; } else { $version = $1; @@ -130,19 +145,25 @@ sub new { @$extra_supps = grep { defined && -f $_ && -r _ } @$extra_supps; bless { - valgrind => $valgrind, - version => $version, - no_def_supp => delete($args{no_def_supp}), - extra_supps => $extra_supps, + valgrind => $valgrind, + version => $version, + regen_def_supp => delete($args{regen_def_supp}), + no_def_supp => delete($args{no_def_supp}), + allow_no_supp => delete($args{allow_no_supp}), + extra_supps => $extra_supps, }, $class; } =head2 C + my $valgrind_path = $tvs->valgrind; + The path to the selected C executable. =head2 C + my $valgrind_version = $tvs->version; + The L object associated to the selected C. =cut @@ -151,28 +172,57 @@ sub version { my ($self) = @_; my $version = $self->{version}; - $self->{version} = $version = $build_version->($version) unless ref $version; + $self->{version} = $version = version->new($version) unless ref $version; return $version; } +=head2 C + + my $regen_def_supp = $tvs->regen_def_supp; + +Read-only accessor for the C option. + +=cut + =head2 C + my $no_def_supp = $tvs->no_def_supp; + Read-only accessor for the C option. +=head2 C + + my $allow_no_supp = $tvs->allow_no_supp; + +Read-only accessor for the C option. + =cut -eval "sub $_ { \$_[0]->{$_} }" for qw/valgrind no_def_supp/; +eval "sub $_ { \$_[0]->{$_} }" for qw< + valgrind + regen_def_supp + no_def_supp + allow_no_supp +>; =head2 C + my @extra_supps = $tvs->extra_supps; + Read-only accessor for the C option. =cut sub extra_supps { @{$_[0]->{extra_supps} || []} } -=head2 C<< run action => $action, tool => $tool, command => $command >> +=head2 C + + $tvs->run( + action => $action, + tool => $tool, + command => $command, + ); Runs the command C<$command> through C with the tool C<$tool>, which will report to the action C<$action>. @@ -181,27 +231,26 @@ If the command is a L object, the action and =cut sub run { - my $self = shift; + my ($self, %args) = @_; - my %args = @_; - - $self->start(%args); - my $guard = bless sub { $self->finish } => 'Test::Valgrind::Session::Guard'; - - $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(Test::Valgrind::Report->new_diag( + $self->report($self->report_class->new_diag( 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind )); @@ -211,11 +260,17 @@ sub _run { if ($self->do_suppressions) { push @supp_args, '--gen-suppressions=all'; } else { - my @supps; - if (not $self->no_def_supp) { + if (!$self->no_def_supp) { my $def_supp = $self->def_supp_file; + my $forced; + if ($self->regen_def_supp and -e $def_supp) { + 1 while unlink $def_supp; + $forced = 1; + } if (defined $def_supp and not -e $def_supp) { - $self->report(Test::Valgrind::Report->new_diag("Generating suppressions...")); + $self->report($self->report_class->new_diag( + 'Generating suppressions' . ($forced ? ' (forced)' : '') . '...' + )); require Test::Valgrind::Suppressions; Test::Valgrind::Suppressions->generate( tool => $self->tool, @@ -223,59 +278,153 @@ sub _run { target => $def_supp, ); $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp; - $self->report(Test::Valgrind::Report->new_diag("Suppressions for this perl stored in $def_supp")); + $self->report($self->report_class->new_diag( + "Suppressions for this perl stored in $def_supp" + )); } } - push @supp_args, '--suppressions=' . $_ for $self->suppressions; + my @supp_files = grep { + -e $_ and $self->command->check_suppressions_file($_) + } $self->suppressions; + if (@supp_files > 1) { + my $files_list = join "\n", map " $_", @supp_files; + $self->report($self->report_class->new_diag( + "Using suppressions from:\n$files_list" + )); + } elsif (@supp_files) { + $self->report($self->report_class->new_diag( + "Using suppressions from $supp_files[0]" + )); + } elsif ($self->allow_no_supp) { + $self->report($self->report_class->new_diag("No suppressions used")); + } else { + $self->_croak("No compatible suppressions available"); + } + @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, - '--log-fd=' . fileno($vwtr), - $self->tool->args($self), - @supp_args, - $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(Test::Valgrind::Report->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; + + 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; + } + } + } + + my $aborted = $self->parser->parse($self, $vrdr); + + if ($aborted) { + $self->report($self->report_class->new_diag("valgrind has aborted")); + return 0; + } - local $SIG{INT} = sub { - kill -(POSIX::SIGKILL()) => $pid; - waitpid $pid, 0; - die 'interrupted'; - }; + 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; + }; - close $vwtr or $self->_croak("close(\$vwtr): $!"); + $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255; - $self->tool->parse($self, $vrdr); + close $erdr or $self->_croak("close(\$erdr): $!"); + close $vrdr or $self->_croak("close(\$vrdr): $!"); - $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255; + return; + } - close $vrdr or $self->_croak("close(\$vrdr): $!"); + die $error if $error; return; } -sub Test::Valgrind::Session::Guard::DESTROY { $_[0]->() } +sub Test::Valgrind::Session::Guard::new { bless \($_[1]), $_[0] } + +sub Test::Valgrind::Session::Guard::DESTROY { ${$_[0]}->() } =head2 C @@ -285,6 +434,10 @@ Read-only accessor for the C associated to the current run. Read-only accessor for the C associated to the current run. +=head2 C + +Read-only accessor for the C associated to the current tool. + =head2 C Read-only accessor for the C associated to the current run. @@ -293,7 +446,7 @@ Read-only accessor for the C associated to the current run. my @members; BEGIN { - @members = qw/action tool command/; + @members = qw; for (@members) { eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"; die if $@; @@ -308,9 +461,17 @@ Forwards to C<< ->action->do_suppressions >>. sub do_suppressions { $_[0]->action->do_suppressions } +=head2 C + +Calls C<< ->tool->parser_class >> with the current session object as the unique argument. + +=cut + +sub parser_class { $_[0]->tool->parser_class($_[0]) } + =head2 C -Calls C<< ->action->report_class >> with the current session object as the sole argument. +Calls C<< ->tool->report_class >> with the current session object as the unique argument. =cut @@ -348,6 +509,8 @@ sub def_supp_file { =head2 C + my @suppressions = $tvs->suppressions; + Returns the list of all the suppressions that will be passed to C. Honors L and L. @@ -368,6 +531,8 @@ sub suppressions { =head2 C + $tvs->start; + Starts the action and tool associated to the current run. It's automatically called at the beginning of L. @@ -376,25 +541,18 @@ It's automatically called at the beginning of L. sub start { my $self = shift; - my %args = @_; - - for (@members) { - 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/last_status exit_code/}; + delete @{$self}{qw}; $self->tool->start($self); + $self->parser($self->parser_class->new)->start($self); $self->action->start($self); return; } -=head2 C +=head2 C + + $tvs->abort($msg); Forwards to C<< ->action->abort >> after unshifting the session object to the argument list. @@ -402,10 +560,13 @@ Forwards to C<< ->action->abort >> after unshifting the session object to the ar sub abort { my $self = shift; + $self->action->abort($self, @_); } -=head2 C +=head2 C + + $tvs->report($report); Forwards to C<< ->action->report >> after unshifting the session object to the argument list. @@ -416,14 +577,18 @@ sub report { return unless defined $report; - $report = $self->command->filter($self, $report); - return unless defined $report; + for my $handler (qw) { + $report = $self->$handler->filter($self, $report); + return unless defined $report; + } $self->action->report($self, $report); } =head2 C + $tvs->finish; + Finishes the action and tool associated to the current run. It's automatically called at the end of L. @@ -433,7 +598,9 @@ sub finish { my ($self) = @_; my $action = $self->action; + $action->finish($self); + $self->parser->finish($self); $self->tool->finish($self); my $status = $action->status($self); @@ -446,6 +613,8 @@ sub finish { =head2 C + my $status = $tvs->status; + Returns the status code of the last run of the session. =cut @@ -454,7 +623,7 @@ sub status { $_[0]->{last_status} } =head1 SEE ALSO -L, L, L, L. +L, L, L, L, L. L, L. @@ -477,7 +646,7 @@ You can find documentation for this module with the perldoc command. =head1 COPYRIGHT & LICENSE -Copyright 2009 Vincent Pit, all rights reserved. +Copyright 2009,2010,2011,2013,2015 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.