t/comp/retainedlines.t

   1 #!./perl -w
   2
   3 # Check that lines from eval are correctly retained by the debugger
   4
   5 # Uncomment this for testing, but don't leave it in for "production", as
   6 # we've not yet verified that use works.
   7 # use strict;
   8
   9 print "1..65\n";
  10 my $test = 0;
  11
  12 sub failed {
  13     my ($got, $expected, $name) = @_;
  14
  15     print "not ok $test - $name\n";
  16     my @caller = caller(1);
  17     print "# Failed test at $caller[1] line $caller[2]\n";
  18     if (defined $got) {
  19         print "# Got '$got'\n";
  20     } else {
  21         print "# Got undef\n";
  22     }
  23     print "# Expected $expected\n";
  24     return;
  25 }
  26
  27 sub is {
  28     my ($got, $expect, $name) = @_;
  29     $test = $test + 1;
  30     if (defined $expect) {
  31         if (defined $got && $got eq $expect) {
  32             print "ok $test - $name\n";
  33             return 1;
  34         }
  35         failed($got, "'$expect'", $name);
  36     } else {
  37         if (!defined $got) {
  38             print "ok $test - $name\n";
  39             return 1;
  40         }
  41         failed($got, 'undef', $name);
  42     }
  43 }
  44
  45 $^P = 0xA;
  46
  47 my @before = grep { /eval/ } keys %::;
  48
  49 is ((scalar @before), 0, "No evals");
  50
  51 my %seen;
  52
  53 sub check_retained_lines {
  54     my ($prog, $name) = @_;
  55     # Is there a more efficient way to write this?
  56     my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';');
  57
  58     my @keys = grep {!$seen{$_}} grep { /eval/ } keys %::;
  59
  60     is ((scalar @keys), 1, "1 new eval");
  61
  62     my @got_lines = @{$::{$keys[0]}};
  63
  64     is ((scalar @got_lines),
  65         (scalar @expect_lines), "Right number of lines for $name");
  66
  67     for (0..$#expect_lines) {
  68         is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct");
  69     }
  70     $seen{$keys[0]}++;
  71 }
  72
  73 my $name = 'foo';
  74
  75 for my $sep (' ', "\0") {
  76
  77     my $prog = "sub $name {
  78     'Perl${sep}Rules'
  79 };
  80 1;
  81 ";
  82
  83     eval $prog or die;
  84     check_retained_lines($prog, ord $sep);
  85     $name++;
  86 }
  87
  88 {
  89   # This contains a syntax error
  90   my $prog = "sub $name {
  91     'This is $name'
  92   }
  93 1 +
  94 ";
  95
  96   eval $prog and die;
  97
  98   is (eval "$name()", "This is $name", "Subroutine was compiled, despite error")
  99     or print STDERR "# $@\n";
 100
 101   check_retained_lines($prog,
 102                        'eval that defines subroutine but has syntax error');
 103   $name++;
 104 }
 105
 106 foreach my $flags (0x0, 0x800, 0x1000, 0x1800) {
 107     local $^P = $^P | $flags;
 108     # This is easier if we accept that the guts eval will add a trailing \n
 109     # for us
 110     my $prog = "1 + 1 + 1\n";
 111     my $fail = "1 + \n";
 112
 113     is (eval $prog, 3, 'String eval works');
 114     if ($flags & 0x800) {
 115         check_retained_lines($prog, sprintf "%#X", $^P);
 116     } else {
 117         my @after = grep { /eval/ } keys %::;
 118
 119         is (scalar @after, 0 + keys %seen,
 120             "evals that don't define subroutines are correctly cleaned up");
 121     }
 122
 123     is (eval $fail, undef, 'Failed string eval fails');
 124
 125     if ($flags & 0x1000) {
 126         check_retained_lines($fail, sprintf "%#X", $^P);
 127     } else {
 128         my @after = grep { /eval/ } keys %::;
 129
 130         is (scalar @after, 0 + keys %seen,
 131             "evals that fail are correctly cleaned up");
 132     }
 133 }