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..75\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 }
 134
 135 # BEGIN blocks that die
 136 for (0xA, 0) {
 137   local $^P = $_;
 138
 139   eval (my $prog = "BEGIN{die}\n");
 140
 141   if ($_) {
 142     check_retained_lines($prog, 'eval that defines BEGIN that dies');
 143   }
 144   else {
 145     my @after = grep { /eval/ } keys %::;
 146
 147     is (scalar @after, 0 + keys %seen,
 148        "evals with BEGIN{die} are correctly cleaned up");
 149   }
 150 }
 151
 152 # [perl #79442] A #line "foo" directive in a string eval was not updating
 153 # *{"_<foo"} in threaded perls, and was not putting the right lines into
 154 # the right elements of @{"_<foo"} in non-threaded perls.
 155 {
 156   local $^P = 0x400|0x100|0x10;
 157   eval qq{#line 42 "hash-line-eval"\n labadalabada()\n};
 158   is $::{"_<hash-line-eval"}[42], " labadalabada()\n",
 159    '#line 42 "foo" in a string eval updates @{"_<foo"}';
 160   eval qq{#line 42 "figgle"\n#line 85 "doggo"\n labadalabada()\n};
 161   is $::{"_<doggo"}[85], " labadalabada()\n",
 162    'subsequent #line 42 "foo" in a string eval updates @{"_<foo"}';
 163 }
 164
 165 # Modifying ${"_<foo"} should not stop lines from being retained.
 166 {
 167   local $^P = 0x400|0x100|0x10;
 168   eval <<'end';
 169 #line 42 "copfilesv-modification"
 170     BEGIN{ ${"_<copfilesv-modification"} = \1 }
 171 #line 52 "copfilesv-modified"
 172     abcdefg();
 173 end
 174   is $::{"_<copfilesv-modified"}[52], "    abcdefg();\n",
 175    '#line 42 "foo" in a str eval is not confused by ${"_<foo"} changing';
 176 }