File Coverage

blib/lib/Devel/Command/Tdump.pm

Criterion	Covered	Total	%
statement	44	46	95.6
branch	16	18	88.8
condition	5	5	100.0
subroutine	6	7	85.7
pod	1	5	20.0
total	72	81	88.8

package Devel::Command::Tdump;
use strict;
use base qw(Devel::Command);

$Devel::Command::Tdump::VERSION = "1.1";
my %test_names = map { $_ => 1 } get_test_names();

# Preload Test::More
sub afterinit {
  push @DB::typeahead, "use Test::More qw(no_plan)";
}

# Dump just the tests
sub command {
  my ($cmd) = @_;
  my @tests;
  my $tfh;

  my(undef, $outfile) = split(/\s+/,$cmd);
  $outfile = "unnamed_test.t" unless defined $outfile;;

  my $first_test = $DB::_first_test || 0;

  print DB::OUT "Recording tests for this session in $outfile ...";
  unless (open $tfh, ">$outfile") {
     print DB::OUT " can't write history: $!\n";
  }
  else {
    my @output;
    my $test_count = 0;
    my @lines = @DB::hist;

    while (@lines) {
      my $line = shift @lines;
      my $forced_capture = 0;
      # Following lines are comments?
      if (@lines) {
        while ($lines[0] =~ /^\s*#/) {
          # Yes. Print and discard.
          push @output, $lines[0],"\n";
          $forced_capture = 1;
          shift @lines;
        }
      }
      # skip this one unless we are supposed to keep it
      # or it's a test
      my $is_test;
      next unless $forced_capture or
        ($is_test = is_a_test($line, \%test_names));
      $test_count++ if $is_test;
      $line = "$line;" unless $line =~ /;$/;
      push @output, "$line\n";
    }
    unshift @output, "use Test::More tests=>$test_count;\n";
    print $tfh @output;
    close $tfh;
    my $s = ($test_count == 1 ? "" : "s");
    print DB::OUT " done ($test_count test$s).\n";
    $DB::_first_test = $#DB::hist;
  }
}

# Get the names defined in Test::More that are the names of tests
# and save them in a debugger global.
sub get_test_names {
  my @names = keys %Test::More::;
  grep { is_a_sub($_) } @names;
}


# Returns true if this is a sub in Test::More, false otherwise
sub is_a_sub {
  local $_ = shift;
  (!/^_/) and eval "defined &Test::More::$_";
}

# Returns true if this line of history is a Test::More test.
sub is_a_test {
  local $_    = shift;
  my    $map  = shift;
  if (my($possible, $paren) = /^\s*(\w+)\(/) {
    return $map->{$possible};
  }
}

1;

__END__