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.00
  13
  14 =cut
  15
  16 our $VERSION = '1.00';
  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 # All these modules are required at configure time.
  26
  27 BEGIN {
  28  require File::Spec;
  29  require Scalar::Util;
  30
  31  require Fcntl; # F_SETFD
  32  require POSIX; # SIGKILL
  33
  34  require version;
  35 }
  36
  37 use base qw/Test::Valgrind::Carp/;
  38
  39 use Test::Valgrind::Report;
  40
  41 =head1 METHODS
  42
  43 =head2 C<< new search_dirs => \@search_dirs, valgrind => [ $valgrind | \@valgrind ], min_version => $min_version, no_def_supp => $no_def_supp, extra_supps => \@extra_supps >>
  44
  45 The package constructor, which takes several options :
  46
  47 =over 4
  48
  49 =item *
  50
  51 All the directories from C<@search_dirs> will have F<valgrind> appended to create a list of candidates for the C<valgrind> executable.
  52
  53 Defaults to the current C<PATH> environment variable.
  54
  55 =item *
  56
  57 If a simple scalar C<$valgrind> is passed as the value to C<'valgrind'>, it will be the only candidate.
  58 C<@search_dirs> will then be ignored.
  59
  60 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>.
  61
  62 =item *
  63
  64 C<$min_version> specifies the minimal C<valgrind> version required.
  65 The constructor will croak if it's not able to find an adequate C<valgrind> from the supplied candidates list and search path.
  66
  67 Defaults to none.
  68
  69 =item *
  70
  71 If C<$no_def_supp> is false, C<valgrind> won't read the default suppression file associated with the tool and the command.
  72
  73 Defaults to false.
  74
  75 =item *
  76
  77 C<$extra_supps> is a reference to an array of optional suppression files that will be passed to C<valgrind>.
  78
  79 Defaults to none.
  80
  81 =back
  82
  83 =cut
  84
  85 sub new {
  86  my $class = shift;
  87  $class = ref($class) || $class;
  88
  89  my %args = @_;
  90
  91  my @paths;
  92  my $vg = delete $args{vg};
  93  if (defined $vg and not ref $vg) {
  94   @paths = ($vg);
  95  } else {
  96   push @paths, @$vg if $vg and ref $vg eq 'ARRAY';
  97   my $dirs = delete $args{search_dirs};
  98   $dirs = [ File::Spec->path ] unless $dirs;
  99   push @paths, map File::Spec->catfile($_, 'valgrind'), @$dirs
 100                                                         if ref $dirs eq 'ARRAY';
 101  }
 102  $class->_croak('Empty valgrind candidates list') unless @paths;
 103
 104  my $min_version = delete $args{min_version};
 105  defined and not ref and $_ = version->new($_) for $min_version;
 106
 107  my ($valgrind, $version);
 108  for (@paths) {
 109   next unless -x;
 110   my $ver = qx/$_ --version/;
 111   if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) {
 112    $version = version->new($1);
 113    next if $min_version and $version < $min_version;
 114    $valgrind = $_;
 115    last;
 116   }
 117  }
 118  $class->_croak('No appropriate valgrind executable could be found')
 119                                                        unless defined $valgrind;
 120
 121  my $extra_supps = delete $args{extra_supps};
 122  $extra_supps    = [ ] unless $extra_supps and ref $extra_supps eq 'ARRAY';
 123  @$extra_supps   = grep { defined && -f $_ && -r _ } @$extra_supps;
 124
 125  bless {
 126   valgrind    => $valgrind,
 127   version     => $version,
 128   no_def_supp => delete($args{no_def_supp}),
 129   extra_supps => $extra_supps,
 130  }, $class;
 131 }
 132
 133 =head2 C<valgrind>
 134
 135 The path to the selected C<valgrind> executable.
 136
 137 =head2 C<version>
 138
 139 The L<version> object associated to the selected C<valgrind>.
 140
 141 =head2 C<no_def_supp>
 142
 143 Read-only accessor for the C<no_def_supp> option.
 144
 145 =cut
 146
 147 eval "sub $_ { \$_[0]->{$_} }" for qw/valgrind version no_def_supp/;
 148
 149 =head2 C<extra_supps>
 150
 151 Read-only accessor for the C<extra_supps> option.
 152
 153 =cut
 154
 155 sub extra_supps { @{$_[0]->{extra_supps} || []} }
 156
 157 =head2 C<< run action => $action, tool => $tool, command => $command >>
 158
 159 Runs the command C<$command> through C<valgrind> with the tool C<$tool>, which will report to the action C<$action>.
 160
 161 =cut
 162
 163 sub run {
 164  my $self = shift;
 165
 166  $self->start(@_);
 167  my $guard = bless sub { $self->finish } => 'Test::Valgrind::Session::Guard';
 168
 169  $self->report(Test::Valgrind::Report->new_diag(
 170   'Using valgrind ' . $self->version . ' located at ' . $self->valgrind
 171  ));
 172
 173  my $env = $self->command->env($self);
 174
 175  my @supp_args;
 176  if ($self->do_suppressions) {
 177   push @supp_args, '--gen-suppressions=all';
 178  } else {
 179   my @supps;
 180   if (not $self->no_def_supp) {
 181    my $def_supp = $self->def_supp_file;
 182    if (defined $def_supp and not -e $def_supp) {
 183     $self->report(Test::Valgrind::Report->new_diag("Generating suppressions..."));
 184     require Test::Valgrind::Suppressions;
 185     Test::Valgrind::Suppressions->generate(
 186      tool    => $self->tool,
 187      command => $self->command,
 188      target  => $def_supp,
 189     );
 190     $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp;
 191     $self->report(Test::Valgrind::Report->new_diag("Suppressions for this perl stored in $def_supp"));
 192    }
 193   }
 194   push @supp_args, '--suppressions=' . $_ for $self->suppressions;
 195  }
 196
 197  pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!");
 198  {
 199   my $oldfh = select $vrdr;
 200   $|++;
 201   select $oldfh;
 202  }
 203
 204  my $pid = fork;
 205  $self->_croak("fork(): $!") unless defined $pid;
 206
 207  if ($pid == 0) {
 208   eval 'setpgrp 0, 0';
 209   close $vrdr or $self->_croak("close(\$vrdr): $!");
 210   fcntl $vwtr, Fcntl::F_SETFD(), 0
 211                               or $self->_croak("fcntl(\$vwtr, F_SETFD, 0): $!");
 212
 213   my @args = (
 214    $self->valgrind,
 215    '--log-fd=' . fileno($vwtr),
 216    $self->tool->args($self),
 217    @supp_args,
 218    $self->command->args($self),
 219   );
 220
 221 #  $self->report(Test::Valgrind::Report->new_diag("@args"));
 222
 223   exec { $args[0] } @args or $self->_croak("exec @args: $!");
 224  }
 225
 226  local $SIG{INT} = sub {
 227   kill -(POSIX::SIGKILL()) => $pid;
 228   waitpid $pid, 0;
 229   die 'interrupted';
 230  };
 231
 232  close $vwtr or $self->_croak("close(\$vwtr): $!");
 233
 234  $self->tool->parse($self, $vrdr);
 235
 236  $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
 237
 238  close $vrdr or $self->_croak("close(\$vrdr): $!");
 239
 240  return;
 241 }
 242
 243 sub Test::Valgrind::Session::Guard::DESTROY { $_[0]->() }
 244
 245 =head2 C<action>
 246
 247 Read-only accessor for the C<action> associated to the current run.
 248
 249 =head2 C<tool>
 250
 251 Read-only accessor for the C<tool> associated to the current run.
 252
 253 =head2 C<command>
 254
 255 Read-only accessor for the C<command> associated to the current run.
 256
 257 =cut
 258
 259 my @members;
 260 BEGIN {
 261  @members = qw/action tool command/;
 262  for (@members) {
 263   eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }";
 264   die if $@;
 265  }
 266 }
 267
 268 =head2 C<do_suppressions>
 269
 270 Forwards to C<< ->action->do_suppressions >>.
 271
 272 =cut
 273
 274 sub do_suppressions { $_[0]->action->do_suppressions }
 275
 276 =head2 C<report_class>
 277
 278 Calls C<< ->action->report_class >> with the current session object as the sole argument.
 279
 280 =cut
 281
 282 sub report_class { $_[0]->tool->report_class($_[0]) }
 283
 284 =head2 C<def_supp_file>
 285
 286 Returns an absolute path to the default suppression file associated to the current session.
 287 C<undef> will be returned as soon as any of C<< ->tool->suppressions_tag >> or C<< ->tool->suppressions_tag >> are also C<undef>.
 288 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 >>.
 289
 290 =cut
 291
 292 sub def_supp_file {
 293  my ($self) = @_;
 294
 295  my $tool_tag = $self->tool->suppressions_tag($self);
 296  return unless defined $tool_tag;
 297
 298  my $cmd_tag = $self->command->suppressions_tag($self);
 299  return unless defined $cmd_tag;
 300
 301  require File::HomeDir; # So that it's not needed at configure time.
 302
 303  return File::Spec->catfile(
 304   File::HomeDir->my_home,
 305   '.perl',
 306   'Test-Valgrind',
 307   'suppressions',
 308   $VERSION,
 309   "$tool_tag-$cmd_tag.supp",
 310  );
 311 }
 312
 313 =head2 C<suppressions>
 314
 315 Returns the list of all the suppressions that will be passed to C<valgrind>.
 316 Honors L</no_def_supp> and L</extra_supps>.
 317
 318 =cut
 319
 320 sub suppressions {
 321  my ($self) = @_;
 322
 323  my @supps;
 324  unless ($self->no_def_supp) {
 325   my $def_supp = $self->def_supp_file;
 326   push @supps, $def_supp if defined $def_supp;
 327  }
 328  push @supps, $self->extra_supps;
 329
 330  return @supps;
 331 }
 332
 333 =head2 C<start>
 334
 335 Starts the action and tool associated to the current run.
 336 It's automatically called at the beginning of L</run>.
 337
 338 =cut
 339
 340 sub start {
 341  my $self = shift;
 342
 343  my %args = @_;
 344
 345  for (@members) {
 346   my $base = 'Test::Valgrind::' . ucfirst;
 347   my $value = $args{$_};
 348   $self->_croak("Invalid $_") unless Scalar::Util::blessed($value)
 349                                                          and $value->isa($base);
 350   $self->$_($args{$_})
 351  }
 352
 353  delete @{$self}{qw/last_status exit_code/};
 354
 355  $self->tool->start($self);
 356  $self->action->start($self);
 357
 358  return;
 359 }
 360
 361 =head2 C<abort $msg>
 362
 363 Forwards to C<< ->action->abort >> after unshifting the session object to the argument list.
 364
 365 =cut
 366
 367 sub abort {
 368  my $self = shift;
 369  $self->action->abort($self, @_);
 370 }
 371
 372 =head2 C<report $report>
 373
 374 Forwards to C<< ->action->report >> after unshifting the session object to the argument list.
 375
 376 =cut
 377
 378 sub report {
 379  my $self = shift;
 380  $self->action->report($self, @_);
 381 }
 382
 383 =head2 C<finish>
 384
 385 Finishes the action and tool associated to the current run.
 386 It's automatically called at the end of L</run>.
 387
 388 =cut
 389
 390 sub finish {
 391  my ($self) = @_;
 392
 393  my $action = $self->action;
 394  $action->finish($self);
 395  $self->tool->finish($self);
 396
 397  my $status = $action->status($self);
 398  $self->{last_status} = defined $status ? $status : $self->{exit_code};
 399
 400  $self->$_(undef) for @members;
 401
 402  return;
 403 }
 404
 405 =head2 C<status>
 406
 407 Returns the status code of the last run of the session.
 408
 409 =cut
 410
 411 sub status { $_[0]->{last_status} }
 412
 413 =head1 SEE ALSO
 414
 415 L<Test::Valgrind>, L<Test::Valgrind::Action>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Command>.
 416
 417 L<version>, L<File::HomeDir>.
 418
 419 =head1 AUTHOR
 420
 421 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 422
 423 You can contact me by mail or on C<irc.perl.org> (vincent).
 424
 425 =head1 BUGS
 426
 427 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>.
 428 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 429
 430 =head1 SUPPORT
 431
 432 You can find documentation for this module with the perldoc command.
 433
 434     perldoc Test::Valgrind::Session
 435
 436 =head1 COPYRIGHT & LICENSE
 437
 438 Copyright 2009 Vincent Pit, all rights reserved.
 439
 440 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 441
 442 =cut
 443
 444 1; # End of Test::Valgrind::Session