t/comp/retainedlines.t

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