From: Vincent Pit <vince@profvince.com>
Date: Tue, 14 Apr 2009 14:20:38 +0000 (+0200)
Subject: Factor the agnostic part of Test::Valgrind->import out to a new ->analyse
X-Git-Tag: v1.01~5
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=6d0c733b0b8ab2f10413a7b1c2906a7f28824f77;p=perl%2Fmodules%2FTest-Valgrind.git

Factor the agnostic part of Test::Valgrind->import out to a new ->analyse
---

diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm
index 4b33486..601a949 100644
--- a/lib/Test/Valgrind.pm
+++ b/lib/Test/Valgrind.pm
@@ -39,9 +39,11 @@ Due to the nature of perl's memory allocator, this module can't track leaks of P
 This includes non-mortalized scalars and memory cycles. However, it can track leaks of chunks of memory allocated in XS extensions with C<Newx> and friends or C<malloc>.
 As such, it's complementary to the other very good leak detectors listed in the L</SEE ALSO> section.
 
-=head1 CONFIGURATION
+=head1 METHODS
 
-You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
+=head2 C<analyse [ %options ]>
+
+Run a C<valgrind> analysis configured by C<%options> :
 
 =over 4
 
@@ -71,9 +73,11 @@ Defaults to L<Test::Valgrind::Action::Test>.
 
 =item *
 
-C<< diag => $bool >>
+C<< file => $file >>
 
-If true, print the output of the test script as diagnostics.
+The file name of the script to analyse.
+
+Ignored if you supply your own custom C<command>, but mandatory otherwise.
 
 =item *
 
@@ -82,7 +86,15 @@ C<< callers => $number >>
 Specify the maximum stack depth studied when valgrind encounters an error.
 Raising this number improves granularity.
 
-Default is 12.
+Ignored if you supply your own custom C<tool>, otherwise defaults to C<12>.
+
+=item *
+
+C<< diag => $bool >>
+
+If true, print the output of the test script as diagnostics.
+
+Ignored if you supply your own custom C<action>, otherwise defaults to false.
 
 =item *
 
@@ -90,60 +102,25 @@ C<< extra_supps => \@files >>
 
 Also use suppressions from C<@files> besides C<perl>'s.
 
+Defaults to empty.
+
 =item *
 
 C<< no_def_supp => $bool >>
 
 If true, do not use the default suppression file.
 
+Defaults to false.
+
 =back
 
 =cut
 
-# We use as little modules as possible in run mode so that they don't pollute
-# the analysis. Hence all the requires.
-
-my $run;
-
-sub import {
+sub analyse {
  shift;
 
- if (@_ % 2) {
-  require Carp;
-  Carp::croak('Optional arguments must be passed as key => value pairs');
- }
  my %args = @_;
 
- if (defined $args{run} or $run) {
-  require Perl::Destruct::Level;
-  Perl::Destruct::Level::set_destruct_level(3);
-  {
-   my $oldfh = select STDOUT;
-   $|++;
-   select $oldfh;
-  }
-  $run = 1;
-  return;
- }
-
- my ($file, $pm, $next);
- my $l = 0;
- while ($l < 1000) {
-  $next = (caller $l++)[1];
-  last unless defined $next;
-  next if $next eq '-e' or $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/ or !-f $next;
-  if ($next =~ /\.pm$/) {
-   $pm   = $next;
-  } else {
-   $file = $next;
-  }
- }
- unless (defined($file) or defined($file = $pm)) {
-  require Test::Builder;
-  Test::Builder->new->diag('Couldn\'t find a valid source file');
-  return;
- }
-
  my $instanceof = sub {
   require Scalar::Util;
   Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
@@ -154,7 +131,7 @@ sub import {
   require Test::Valgrind::Command;
   $cmd = Test::Valgrind::Command->new(
    command => $cmd || 'PerlScript',
-   file    => $file,
+   file    => delete $args{file},
    args    => [ '-MTest::Valgrind=run,1' ],
   );
  }
@@ -164,7 +141,7 @@ sub import {
   require Test::Valgrind::Tool;
   $tool = Test::Valgrind::Tool->new(
    tool     => $tool || 'memcheck',
-   callers  => delete($args{callers}),
+   callers  => delete $args{callers},
   );
  }
 
@@ -173,7 +150,7 @@ sub import {
   require Test::Valgrind::Action;
   $action = Test::Valgrind::Action->new(
    action => $action || 'Test',
-   diag   => delete($args{diag}),
+   diag   => delete $args{diag},
   );
  }
 
@@ -186,7 +163,7 @@ sub import {
  };
  unless ($sess) {
   $action->abort($sess, $@);
-  exit $action->status($sess);
+  return $action->status($sess);
  }
 
  eval {
@@ -204,7 +181,67 @@ sub import {
  my $status = $sess->status;
  $status = 255 unless defined $status;
 
- exit $status;
+ return $status;
+}
+
+=head2 C<import [ %options ]>
+
+In the parent process, L</import> calls L</analyse> with the arguments it received itself - except that if no C<file> option was supplied, it tries to pick the highest caller context that looks like a script.
+When the analyse finishes, it exists with the status that was returned.
+
+In the child process, it just C<return>s so that the calling code is actually run under C<valgrind>.
+
+=cut
+
+# We use as little modules as possible in run mode so that they don't pollute
+# the analysis. Hence all the requires.
+
+my $run;
+
+sub import {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ if (@_ % 2) {
+  require Carp;
+  Carp::croak('Optional arguments must be passed as key => value pairs');
+ }
+ my %args = @_;
+
+ if (defined delete $args{run} or $run) {
+  require Perl::Destruct::Level;
+  Perl::Destruct::Level::set_destruct_level(3);
+  {
+   my $oldfh = select STDOUT;
+   $|++;
+   select $oldfh;
+  }
+  $run = 1;
+  return;
+ }
+
+ my ($file, $pm, $next);
+ my $l = 0;
+ while ($l < 1000) {
+  $next = (caller $l++)[1];
+  last unless defined $next;
+  next if $next eq '-e' or $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/ or !-f $next;
+  if ($next =~ /\.pm$/) {
+   $pm   = $next;
+  } else {
+   $file = $next;
+  }
+ }
+ unless (defined($file) or defined($file = $pm)) {
+  require Test::Builder;
+  Test::Builder->new->diag('Couldn\'t find a valid source file');
+  return;
+ }
+
+ exit $class->analyse(
+  file => $file,
+  %args,
+ );
 }
 
 END {