lib/Test/Valgrind/Session.pm

   1 package Test::Valgrind::Session;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind::Session - Test::Valgrind session object.
   9
  10 =head1 VERSION
  11
  12 Version 1.17
  13
  14 =cut
  15
  16 our $VERSION = '1.17';
  17
  18 =head1 DESCRIPTION
  19
  20 This class supervises the execution of the C<valgrind> process.
  21 It also acts as a dispatcher between the different components.
  22
  23 =cut
  24
  25 use Config       ();
  26 use File::Spec   ();
  27 use ExtUtils::MM (); # MM->maybe_command()
  28 use Scalar::Util ();
  29
  30 use Fcntl       (); # F_SETFD
  31 use IO::Select;
  32 use POSIX       (); # SIGKILL, _exit()
  33
  34 use base qw<Test::Valgrind::Carp>;
  35
  36 use Test::Valgrind::Version;
  37
  38 =head1 METHODS
  39
  40 =head2 C<new>
  41
  42     my $tvs = Test::Valgrind::Session->new(
  43      search_dirs    => \@search_dirs,
  44      valgrind       => $valgrind,  # One candidate
  45      valgrind       => \@valgrind, # Several candidates
  46      min_version    => $min_version,
  47      regen_def_supp => $regen_def_supp,
  48      no_def_supp    => $no_def_supp,
  49      allow_no_supp  => $allow_no_supp,
  50      extra_supps    => \@extra_supps,
  51     );
  52
  53 The package constructor, which takes several options :
  54
  55 =over 4
  56
  57 =item *
  58
  59 All the directories from C<@search_dirs> will have F<valgrind> appended to create a list of candidates for the C<valgrind> executable.
  60
  61 Defaults to the current C<PATH> environment variable.
  62
  63 =item *
  64
  65 If a simple scalar C<$valgrind> is passed as the value to C<'valgrind'>, it will be the only candidate.
  66 C<@search_dirs> will then be ignored.
  67
  68 If an array refernce C<\@valgrind> is passed, its values will be I<prepended> to the list of the candidates resulting from C<@search_dirs>.
  69
  70 =item *
  71
  72 C<$min_version> specifies the minimal C<valgrind> version required.
  73 The constructor will croak if it's not able to find an adequate C<valgrind> from the supplied candidates list and search path.
  74
  75 Defaults to none.
  76
  77 =item *
  78
  79 If C<$regen_def_supp> is true, the default suppression file associated with the tool and the command will be forcefully regenerated.
  80
  81 Defaults to false.
  82
  83 =item *
  84
  85 If C<$no_def_supp> is true, C<valgrind> won't read the default suppression file associated with the tool and the command.
  86
  87 Defaults to false.
  88
  89 =item *
  90
  91 If C<$allow_no_supp> is true, the command will always be run into C<valgrind> even if no appropriate suppression file is available.
  92
  93 Defaults to false.
  94
  95 =item *
  96
  97 C<$extra_supps> is a reference to an array of optional suppression files that will be passed to C<valgrind>.
  98
  99 Defaults to none.
 100
 101 =back
 102
 103 =cut
 104
 105 sub new {
 106  my $class = shift;
 107  $class = ref($class) || $class;
 108
 109  my %args = @_;
 110
 111  my @paths;
 112  my $vg = delete $args{valgrind};
 113  if (defined $vg and not ref $vg) {
 114   @paths = ($vg);
 115  } else {
 116   push @paths, @$vg if defined $vg and ref $vg eq 'ARRAY';
 117   my $dirs = delete $args{search_dirs};
 118   $dirs = [ File::Spec->path ] unless defined $dirs;
 119   my $exe_name = 'valgrind';
 120   $exe_name   .= $Config::Config{exe_ext} if defined $Config::Config{exe_ext};
 121   push @paths, map File::Spec->catfile($_, $exe_name), @$dirs
 122                                                         if ref $dirs eq 'ARRAY';
 123  }
 124  $class->_croak('Empty valgrind candidates list') unless @paths;
 125
 126  my $min_version = delete $args{min_version};
 127  if (defined $min_version) {
 128   $min_version = Test::Valgrind::Version->new(string => $min_version);
 129  }
 130
 131  my ($valgrind, $version);
 132  for my $path (@paths) {
 133   next unless defined($path) and MM->maybe_command($path);
 134   my $output = qx/$path --version/;
 135   $version   = do {
 136    local $@;
 137    eval { Test::Valgrind::Version->new(command_output => $output) };
 138   };
 139   if (defined $version) {
 140    next if defined $min_version and $version < $min_version;
 141    $valgrind = $path;
 142    last;
 143   }
 144  }
 145  $class->_croak('No appropriate valgrind executable could be found')
 146                                                        unless defined $valgrind;
 147
 148  my $extra_supps = delete $args{extra_supps};
 149  $extra_supps    = [ ] unless $extra_supps and ref $extra_supps eq 'ARRAY';
 150  @$extra_supps   = grep { defined && -f $_ && -r _ } @$extra_supps;
 151
 152  bless {
 153   valgrind       => $valgrind,
 154   version        => $version,
 155   regen_def_supp => delete($args{regen_def_supp}),
 156   no_def_supp    => delete($args{no_def_supp}),
 157   allow_no_supp  => delete($args{allow_no_supp}),
 158   extra_supps    => $extra_supps,
 159  }, $class;
 160 }
 161
 162 =head2 C<valgrind>
 163
 164     my $valgrind_path = $tvs->valgrind;
 165
 166 The path to the selected C<valgrind> executable.
 167
 168 =head2 C<version>
 169
 170     my $valgrind_version = $tvs->version;
 171
 172 The L<Test::Valgrind::Version> object associated to the selected C<valgrind>.
 173
 174 =head2 C<regen_def_supp>
 175
 176     my $regen_def_supp = $tvs->regen_def_supp;
 177
 178 Read-only accessor for the C<regen_def_supp> option.
 179
 180 =cut
 181
 182 =head2 C<no_def_supp>
 183
 184     my $no_def_supp = $tvs->no_def_supp;
 185
 186 Read-only accessor for the C<no_def_supp> option.
 187
 188 =head2 C<allow_no_supp>
 189
 190     my $allow_no_supp = $tvs->allow_no_supp;
 191
 192 Read-only accessor for the C<allow_no_supp> option.
 193
 194 =cut
 195
 196 eval "sub $_ { \$_[0]->{$_} }" for qw<
 197  valgrind
 198  version
 199  regen_def_supp
 200  no_def_supp
 201  allow_no_supp
 202 >;
 203
 204 =head2 C<extra_supps>
 205
 206     my @extra_supps = $tvs->extra_supps;
 207
 208 Read-only accessor for the C<extra_supps> option.
 209
 210 =cut
 211
 212 sub extra_supps { @{$_[0]->{extra_supps} || []} }
 213
 214 =head2 C<run>
 215
 216     $tvs->run(
 217      action  => $action,
 218      tool    => $tool,
 219      command => $command,
 220     );
 221
 222 Runs the command C<$command> through C<valgrind> with the tool C<$tool>, which will report to the action C<$action>.
 223
 224 If the command is a L<Test::Valgrind::Command::Aggregate> object, the action and the tool will be initialized once before running all the aggregated commands.
 225
 226 =cut
 227
 228 sub run {
 229  my ($self, %args) = @_;
 230
 231  for (qw<action tool command>) {
 232   my $base = 'Test::Valgrind::' . ucfirst;
 233   my $value = $args{$_};
 234   $self->_croak("Invalid $_") unless Scalar::Util::blessed($value)
 235                                                          and $value->isa($base);
 236   $self->$_($args{$_})
 237  }
 238
 239  my $cmd = $self->command;
 240  if ($cmd->isa('Test::Valgrind::Command::Aggregate')) {
 241   for my $subcmd ($cmd->commands) {
 242    $args{command} = $subcmd;
 243    $self->run(%args);
 244   }
 245   return;
 246  }
 247
 248  $self->report($self->report_class->new_diag(
 249   'Using valgrind ' . $self->version . ' located at ' . $self->valgrind
 250  ));
 251
 252  my $env = $self->command->env($self);
 253
 254  my @supp_args;
 255  if ($self->do_suppressions) {
 256   push @supp_args, '--gen-suppressions=all';
 257  } else {
 258   if (!$self->no_def_supp) {
 259    my $def_supp = $self->def_supp_file;
 260    my $forced;
 261    if ($self->regen_def_supp and -e $def_supp) {
 262     1 while unlink $def_supp;
 263     $forced = 1;
 264    }
 265    if (defined $def_supp and not -e $def_supp) {
 266     $self->report($self->report_class->new_diag(
 267      'Generating suppressions' . ($forced ? ' (forced)' : '') . '...'
 268     ));
 269     require Test::Valgrind::Suppressions;
 270     Test::Valgrind::Suppressions->generate(
 271      tool    => $self->tool,
 272      command => $self->command,
 273      target  => $def_supp,
 274     );
 275     $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp;
 276     $self->report($self->report_class->new_diag(
 277      "Suppressions for this perl stored in $def_supp"
 278     ));
 279    }
 280   }
 281   my @supp_files = grep {
 282    -e $_ and $self->command->check_suppressions_file($_)
 283   } $self->suppressions;
 284   if (@supp_files > 1) {
 285    my $files_list = join "\n", map "    $_", @supp_files;
 286    $self->report($self->report_class->new_diag(
 287     "Using suppressions from:\n$files_list"
 288    ));
 289   } elsif (@supp_files) {
 290    $self->report($self->report_class->new_diag(
 291     "Using suppressions from $supp_files[0]"
 292    ));
 293   } elsif ($self->allow_no_supp) {
 294    $self->report($self->report_class->new_diag("No suppressions used"));
 295   } else {
 296    $self->_croak("No compatible suppressions available");
 297   }
 298   @supp_args = map "--suppressions=$_", @supp_files;
 299  }
 300
 301  my $error;
 302  GUARDED: {
 303   my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish });
 304   $self->start;
 305
 306   pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!");
 307   {
 308    my $oldfh = select $vrdr;
 309    $|++;
 310    select $oldfh;
 311   }
 312
 313   pipe my $erdr, my $ewtr or $self->_croak("pipe(\$erdr, \$ewtr): $!");
 314   {
 315    my $oldfh = select $erdr;
 316    $|++;
 317    select $oldfh;
 318   }
 319
 320   my $pid = fork;
 321   $self->_croak("fork(): $!") unless defined $pid;
 322
 323   if ($pid == 0) {
 324    {
 325     local $@;
 326     eval { setpgrp(0, 0) };
 327    }
 328
 329    close $erdr or POSIX::_exit(255);
 330
 331    local $@;
 332    eval {
 333     close $vrdr or $self->_croak("close(\$vrdr): $!");
 334
 335     fcntl $vwtr, Fcntl::F_SETFD(), 0
 336                               or $self->_croak("fcntl(\$vwtr, F_SETFD, 0): $!");
 337
 338     my @args = (
 339      $self->valgrind,
 340      $self->tool->args($self),
 341      @supp_args,
 342      $self->parser->args($self, $vwtr),
 343      $self->command->args($self),
 344     );
 345
 346     {
 347      no warnings 'exec';
 348      exec { $args[0] } @args;
 349     }
 350     $self->_croak("exec @args: $!");
 351    };
 352
 353    print $ewtr $@;
 354    close $ewtr;
 355
 356    POSIX::_exit(255);
 357   }
 358
 359   local $@;
 360   eval {
 361    local $SIG{INT} = sub {
 362     die 'valgrind analysis was interrupted';
 363    };
 364
 365    close $vwtr or $self->_croak("close(\$vwtr): $!");
 366    close $ewtr or $self->_croak("close(\$ewtr): $!");
 367
 368    SEL: {
 369     my $sel = IO::Select->new($vrdr, $erdr);
 370
 371     my $child_err;
 372     while (my @ready = $sel->can_read) {
 373      last SEL if @ready == 1 and fileno $ready[0] == fileno $vrdr;
 374
 375      my $buf;
 376      my $bytes_read = sysread $erdr, $buf, 4096;
 377      if (not defined $bytes_read) {
 378       $self->_croak("sysread(\$erdr): $!");
 379      } elsif ($bytes_read) {
 380       $sel->remove($vrdr) unless $child_err;
 381       $child_err .= $buf;
 382      } else {
 383       $sel->remove($erdr);
 384       die $child_err if $child_err;
 385      }
 386     }
 387    }
 388
 389    my $aborted = $self->parser->parse($self, $vrdr);
 390
 391    if ($aborted) {
 392     $self->report($self->report_class->new_diag("valgrind has aborted"));
 393     return 0;
 394    }
 395
 396    1;
 397   } or do {
 398    $error = $@;
 399    kill -(POSIX::SIGKILL()) => $pid if kill 0 => $pid;
 400    close $erdr;
 401    close $vrdr;
 402    waitpid $pid, 0;
 403    # Force the guard destructor to trigger now so that old perls don't lose $@
 404    last GUARDED;
 405   };
 406
 407   $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
 408
 409   close $erdr or $self->_croak("close(\$erdr): $!");
 410   close $vrdr or $self->_croak("close(\$vrdr): $!");
 411
 412   return;
 413  }
 414
 415  die $error if $error;
 416
 417  return;
 418 }
 419
 420 sub Test::Valgrind::Session::Guard::new     { bless \($_[1]), $_[0] }
 421
 422 sub Test::Valgrind::Session::Guard::DESTROY { ${$_[0]}->() }
 423
 424 =head2 C<action>
 425
 426 Read-only accessor for the C<action> associated to the current run.
 427
 428 =head2 C<tool>
 429
 430 Read-only accessor for the C<tool> associated to the current run.
 431
 432 =head2 C<parser>
 433
 434 Read-only accessor for the C<parser> associated to the current tool.
 435
 436 =head2 C<command>
 437
 438 Read-only accessor for the C<command> associated to the current run.
 439
 440 =cut
 441
 442 my @members;
 443 BEGIN {
 444  @members = qw<action tool command parser>;
 445  for (@members) {
 446   eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }";
 447   die if $@;
 448  }
 449 }
 450
 451 =head2 C<do_suppressions>
 452
 453 Forwards to C<< ->action->do_suppressions >>.
 454
 455 =cut
 456
 457 sub do_suppressions { $_[0]->action->do_suppressions }
 458
 459 =head2 C<parser_class>
 460
 461 Calls C<< ->tool->parser_class >> with the current session object as the unique argument.
 462
 463 =cut
 464
 465 sub parser_class { $_[0]->tool->parser_class($_[0]) }
 466
 467 =head2 C<report_class>
 468
 469 Calls C<< ->tool->report_class >> with the current session object as the unique argument.
 470
 471 =cut
 472
 473 sub report_class { $_[0]->tool->report_class($_[0]) }
 474
 475 =head2 C<def_supp_file>
 476
 477 Returns an absolute path to the default suppression file associated to the current session.
 478
 479 C<undef> will be returned as soon as any of C<< ->command->suppressions_tag >> or C<< ->tool->suppressions_tag >> are also C<undef>.
 480 Otherwise, the file part of the name is builded by joining those two together, and the directory part is roughly F<< File::HomeDir->my_home / .perl / Test-Valgrind / suppressions / $VERSION >>.
 481
 482 =cut
 483
 484 sub def_supp_file {
 485  my ($self) = @_;
 486
 487  my $tool_tag = $self->tool->suppressions_tag($self);
 488  return unless defined $tool_tag;
 489
 490  my $cmd_tag = $self->command->suppressions_tag($self);
 491  return unless defined $cmd_tag;
 492
 493  require File::HomeDir; # So that it's not needed at configure time.
 494
 495  return File::Spec->catfile(
 496   File::HomeDir->my_home,
 497   '.perl',
 498   'Test-Valgrind',
 499   'suppressions',
 500   $VERSION,
 501   "$tool_tag-$cmd_tag.supp",
 502  );
 503 }
 504
 505 =head2 C<suppressions>
 506
 507     my @suppressions = $tvs->suppressions;
 508
 509 Returns the list of all the suppressions that will be passed to C<valgrind>.
 510 Honors L</no_def_supp> and L</extra_supps>.
 511
 512 =cut
 513
 514 sub suppressions {
 515  my ($self) = @_;
 516
 517  my @supps;
 518  unless ($self->no_def_supp) {
 519   my $def_supp = $self->def_supp_file;
 520   push @supps, $def_supp if defined $def_supp;
 521  }
 522  push @supps, $self->extra_supps;
 523
 524  return @supps;
 525 }
 526
 527 =head2 C<start>
 528
 529     $tvs->start;
 530
 531 Starts the action and tool associated to the current run.
 532 It's automatically called at the beginning of L</run>.
 533
 534 =cut
 535
 536 sub start {
 537  my $self = shift;
 538
 539  delete @{$self}{qw<last_status exit_code>};
 540
 541  $self->tool->start($self);
 542  $self->parser($self->parser_class->new)->start($self);
 543  $self->action->start($self);
 544
 545  return;
 546 }
 547
 548 =head2 C<abort>
 549
 550     $tvs->abort($msg);
 551
 552 Forwards to C<< ->action->abort >> after unshifting the session object to the argument list.
 553
 554 =cut
 555
 556 sub abort {
 557  my $self = shift;
 558
 559  $self->action->abort($self, @_);
 560 }
 561
 562 =head2 C<report>
 563
 564     $tvs->report($report);
 565
 566 Forwards to C<< ->action->report >> after unshifting the session object to the argument list.
 567
 568 =cut
 569
 570 sub report {
 571  my ($self, $report) = @_;
 572
 573  return unless defined $report;
 574
 575  for my $handler (qw<tool command>) {
 576   $report = $self->$handler->filter($self, $report);
 577   return unless defined $report;
 578  }
 579
 580  $self->action->report($self, $report);
 581 }
 582
 583 =head2 C<finish>
 584
 585     $tvs->finish;
 586
 587 Finishes the action and tool associated to the current run.
 588 It's automatically called at the end of L</run>.
 589
 590 =cut
 591
 592 sub finish {
 593  my ($self) = @_;
 594
 595  my $action = $self->action;
 596
 597  $action->finish($self);
 598  $self->parser->finish($self);
 599  $self->tool->finish($self);
 600
 601  my $status = $action->status($self);
 602  $self->{last_status} = defined $status ? $status : $self->{exit_code};
 603
 604  $self->$_(undef) for @members;
 605
 606  return;
 607 }
 608
 609 =head2 C<status>
 610
 611     my $status = $tvs->status;
 612
 613 Returns the status code of the last run of the session.
 614
 615 =cut
 616
 617 sub status { $_[0]->{last_status} }
 618
 619 =head1 SEE ALSO
 620
 621 L<Test::Valgrind>, L<Test::Valgrind::Action>, L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Parser>.
 622
 623 L<File::HomeDir>.
 624
 625 =head1 AUTHOR
 626
 627 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 628
 629 You can contact me by mail or on C<irc.perl.org> (vincent).
 630
 631 =head1 BUGS
 632
 633 Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.
 634 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 635
 636 =head1 SUPPORT
 637
 638 You can find documentation for this module with the perldoc command.
 639
 640     perldoc Test::Valgrind::Session
 641
 642 =head1 COPYRIGHT & LICENSE
 643
 644 Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
 645
 646 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 647
 648 =cut
 649
 650 1; # End of Test::Valgrind::Session