t/comp/retainedlines.t

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