public
Created

Crude Prototype for Adding Test Coverage Traces for lib/perl5db.pl.

  • Download Gist
add_perl5db_coverage.pl
Perl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
#!/usr/bin/perl
 
use strict;
use warnings;
 
use IO::All;
 
my $func_name = "DB::db_foo_trace";
 
my @lines = io("lib/perl5db.pl")->getlines();
 
my %where_traces_put;
 
my @indexes = (grep { $lines[$_] =~ /\A\s*push/ .. $lines[$_] =~ /;\s*\n?\z/ } keys(@lines));
 
my %ignore = (map { $_ => 1 } @indexes);
 
foreach my $i (keys(@lines))
{
if ($lines[$i] =~ m/;\s*\z/ and
($lines[$i] !~ /\Apackage / or $lines[$i] =~ /\A1;\s*\z/)
)
{
my $j = $i-1;
my $line_num = $i+1;
my $trace = "$func_name($line_num);";
 
my $ws_re = qr/\s*(?:#.*)?\n?/;
while (
exists($ignore{$j}) or
( not (
( $lines[$j] =~ s/(;)($ws_re)\z/$1$trace$2/)
or ( $lines[$j] =~ m/\{$ws_re\z/ and $lines[$j] !~ m/(?:=>)/
and $lines[$j] =~ s/(\{)($ws_re)\z/$1$trace$2/ )
or ( $lines[$j] =~ m/\}$ws_re\z/ and
$lines[$j] !~ m/(?:\{|=>|,)/ and
$lines[$j] =~ s/(\})($ws_re)\z/$1$trace$2/)
)
)
)
{
$j--;
}
$where_traces_put{$line_num} = 1;
}
}
 
io("perl5db_coverage_all_lines.txt")->print(
join '', map { "$_\n"} sort { $a <=> $b } keys(%where_traces_put)
);
 
my $big_string = join('', @lines);
 
my $code_to_add = "sub $func_name " . <<'EOF';
{
my ($line_num) = @_;
open my $append_fh, '>>', 'perl5db_coverage_trace.txt'
or die "Cannot open 'perl5db_coverage_trace.txt' - $!.";
print {$append_fh} "$line_num\n";
close($append_fh);
}
EOF
 
$code_to_add =~ s/\n//g;
 
# $big_string =~ s/\A/BEGIN{ $code_to_add ; };/ms;
$big_string =~ s/\A/$code_to_add ;/ms;
io("lib/perl5db.pl")->print($big_string);

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.