use Test::More;
BEGIN {
if (eval "use PPI;1") {
plan tests => 25;
} else {
plan skip_all => "PPI not available";
}
}
use strict;
use warnings;
# check output of Devel::DumpTrace module, compare with reference output.
# run code that uses a core module, and see if we are doing what
# we are supposed to about tracing through that core module
my $dmodule = "-d:DumpTrace::PPI";
open T, '>', "$0.pl";
print T <<'EO_T;';
# test program for t/ppi/88-smoke.t
# that contains a C-style for loop,
# a while loop, an until loop, and a
# complex if-elsif-else block.
for (my $i=1; $i<5; $i++) {
$j += 2 * $i - 1;
if ($i < 2) {
$k += $j;
$j = 0;
} elsif ($i > 3) {
$j = 0;
do {
$k += 2 * $j;
$j++;
} until $k > $j;
} elsif ($i == 2) {
until ($j > 50) {
$k -= $j;
$j *= 2;
$j++ if $j == 0;
}
} else {
while ($j > 0) {
$k += sqrt($j);
$j = $j / 2 - 1;
}
}
}
EO_T;
my $level = 3;
my $file = "$0.out.$level";
$ENV{DUMPTRACE_FH} = $file;
$ENV{DUMPTRACE_LEVEL} = $level;
my $c1 = system($^X, $dmodule, "-Iblib/lib", "-Ilib", "$0.pl");
my $keep = $ENV{KEEP} || 0;
ok($c1 == 0, "ran level $level") or $keep++;
open XH, '<', $file;
my @xh = <XH>;
close XH;
# tests:
# C-style for loops:
# for loop statement appears only on first iteration
# on other iterations, there are lines matching
# FOR-UPDATE: {.*} FOR-COND: {.*}
# the FOR-UPDATE ... lines have file/line information
# the lines _after_ FOR-UPDATE ... do not have file/line information
# (*) condition statement for last iteration is not observed
#
# while/until loops
# while / until keyword appears only on first iteration
# on other iterations, there are lines matching
# WHILE:\s*(.*) or UNTIL:\s*(.*)
# WHILE:/UNTIL: lines have file/line information
# lines _after_ WHILE:/UNTIL: ... do not have file/line information
# (*) condition statement for last iteration not observed
#
# if/elsif/else blocks
# line with if keyword has file/line info
# line after if keyword has file/line info
# line with ELSEIF has a condition clause
# line with ELSE or ELSIF either
# has file/line info, or
# is preceded by an ELSIF line
# ELSE/ELSIF line with file/line info is preceded by an if line
#
# do/while do/until
# line with DO-UNTIL/DO-WHILE does not have file and line information
# line before DO-UNTIL/DO-WHILE has file line info
# first iteration, line says "do {"
# appears before all other DO-UNTIL/DO-WHILE statements
my $FILELINE_INFO = qr/$0.pl:\d+:/;
############### C-style for loops ################
my @for_lines = grep {
$xh[$_] =~ /for(each)?\s*\(.*;.*;.*\)\s*\{/
} 0 .. $#xh;
my @for_upds = grep {
$xh[$_] =~ /FOR-UPDATE:\s*\{.*\}\s*FOR-COND:\s*\{.*\}/
} 0 .. $#xh;
ok(@for_lines == 1,
"source for (...;...;...) statement appears only once")
or $keep++;
ok(@for_upds > 1,
"for loop decorators appear and appear more than once")
or $keep++;
ok($for_lines[0] < $for_upds[0],
"keyword for appears first, before decorators")
or $keep++;
ok($xh[$for_upds[0]] =~ $FILELINE_INFO && $xh[$for_upds[-1]] =~ $FILELINE_INFO,
"for loop decorators have file and line information")
or $keep++;
ok($xh[1+$for_upds[0]] !~ $FILELINE_INFO
&& $xh[1+$for_upds[-1]] !~ $FILELINE_INFO,
"lines following for loop decoratorrs do not have file/line info")
or $keep++;
################# while/until loops ##################
my @until_lines = grep {
$xh[$_] =~ /until\s*\(/
} 0 .. $#xh;
my @until_upds = grep {
$xh[$_] =~ /UNTIL:\s*\(.*\)/
} 0 .. $#xh;
ok(@until_lines == 1,
"keyword until appears once, at first iteration")
or $keep++;
ok(@until_upds > 0,
"until decorators appear")
or $keep++;
ok($until_lines[0] < $until_upds[0],
"keyword until appears before until decorators")
or $keep++;
ok($xh[$until_upds[0]] =~ $FILELINE_INFO
&& $xh[$until_upds[-1]] =~ $FILELINE_INFO,
"until decorators have file and line information")
or $keep++;
ok($xh[1+$until_upds[0]] !~ $FILELINE_INFO
&& $xh[1+$until_upds[-1]] !~ $FILELINE_INFO,
"lines after until decorators do not have file/line info")
or $keep++;
my @while_lines = grep {
$xh[$_] =~ /while\s*\(/
} 0 .. $#xh;
my @while_upds = grep {
$xh[$_] =~ /WHILE:\s*\(.*\)/
} 0 .. $#xh;
ok(@while_lines == 1,
"keyword while appears once, at first iteration")
or $keep++;
ok(@while_upds > 0,
"while decorators appear")
or $keep++;
ok($while_lines[0] < $while_upds[0],
"keyword while appears before while decorators")
or $keep++;
ok($xh[$while_upds[0]] =~ $FILELINE_INFO
&& $xh[$while_upds[-1]] =~ $FILELINE_INFO,
"while decorators have file and line information")
or $keep++;
ok($xh[1+$while_upds[0]] !~ $FILELINE_INFO
&& $xh[1+$while_upds[-1]] !~ $FILELINE_INFO,
"lines after while decorators do not have file/line info")
or $keep++;
######################## if-elsif-else #######################
my @if = grep { $xh[$_] =~ /\s*if\s*\(/ } 0 .. $#xh;
my @if_with_fileline_info = grep { $xh[$_] =~ $FILELINE_INFO } @if;
my @after_if_with_fileline_info = grep { $xh[1+$_] =~ $FILELINE_INFO } @if;
my @elseif = grep { $xh[$_] =~ /ELSEIF/ } 0 .. $#xh;
my @elseif_with_condition = grep { $xh[$_] =~ /ELSEIF\s*\(.*\)/ } @elseif;
my @else_and_elseif = grep {
$xh[$_] =~ /ELSEIF/ || $xh[$_] =~ /ELSE/
} 0 .. $#xh;
my @else_and_elseif_with_fileline_info = grep {
$xh[$_] =~ $FILELINE_INFO
} @else_and_elseif;
my @else_and_elseif_preceded_by_elseif = grep {
$xh[$_ - 1] =~ /ELSEIF/
} @else_and_elseif;
my @else_and_elseif_with_fileline_info_preceded_by_if = grep {
$xh[$_ - 1] =~ /if\s*\(/;
} @else_and_elseif_with_fileline_info;
ok(@if == @if_with_fileline_info,
"if line always has file and line information")
or $keep++;
ok(@if == @after_if_with_fileline_info,
"line after if always has file and line information")
or $keep++;
ok(@elseif == @elseif_with_condition,
"ELSEIF line contains condition clause")
or $keep++;
ok(@else_and_elseif == @else_and_elseif_with_fileline_info +
@else_and_elseif_preceded_by_elseif,
"ELSEIF/ELSE either has file/line info, or follows an earlier ELSEIF")
or $keep++;
ok(@else_and_elseif_with_fileline_info ==
@else_and_elseif_with_fileline_info_preceded_by_if,
"ELSEIF/ELSE with file/line info always preceded by if (...)")
or $keep++;
################# do-while / do-until ####################
my @do_whileuntil_lines = grep {
$xh[$_] =~ /DO-[A-Z]{5}/
} 0..$#xh;
my @do_whileuntil_lines_with_fileinfo = grep {
$xh[$_] =~ /$0.pl:\d+:/
} @do_whileuntil_lines;
my @precede_dowhile_lines_with_fileinfo = grep {
$xh[$_ - 1] =~ /$0.pl:\d+:/
} @do_whileuntil_lines;
my @do = grep { $xh[$_] =~ /do\s*\{/ } 0 .. $#xh;
ok(@do_whileuntil_lines > 0,
"output has DO-WHILE/DO-UNTIL decorators") or $keep++;
ok(@do_whileuntil_lines_with_fileinfo == 0,
"lines with DO-WHILE/DO-UNTIL do not have file & line info")
or $keep++;
ok(@precede_dowhile_lines_with_fileinfo == @do_whileuntil_lines,
"lines that precede DO-WHILE/DO-UNTIL have file & line info")
or $keep++;
ok(@do == 1 && $do[0] < $do_whileuntil_lines[0],
"'do' statement appears first")
or $keep++;
unlink "$0.pl", $file unless $keep;