view release on metacpan or  search on metacpan

t/comp/retainedlines.t  view on Meta::CPAN

#!./perl -w

# Check that lines from eval are correctly retained by the debugger

# Uncomment this for testing, but don't leave it in for "production", as
# we've not yet verified that use works.
# use strict;

print "1..109\n";
my $test = 0;

sub failed {
    my ($got, $expected, $name) = @_;

    print "not ok $test - $name\n";
    my @caller = caller(1);
    print "# Failed test at $caller[1] line $caller[2]\n";
    if (defined $got) {
	print "# Got '$got'\n";
    } else {
	print "# Got undef\n";
    }
    print "# Expected $expected\n";
    return;
}

sub is($$$) {
    my ($got, $expect, $name) = @_;
    $test = $test + 1;
    if (defined $expect) {
	if (defined $got && $got eq $expect) {
	    print "ok $test - $name\n";
	    return 1;
	}
	failed($got, "'$expect'", $name);
    } else {
	if (!defined $got) {
	    print "ok $test - $name\n";
	    return 1;
	}
	failed($got, 'undef', $name);
    }
}

$^P = 0xA;

my @before = grep { /eval/ } keys %::;

is ((scalar @before), 0, "No evals");

my %seen;

sub check_retained_lines {
    my ($prog, $name) = @_;
    # Is there a more efficient way to write this?
    my @expect_lines = (undef, map ({"$_\n"} split "\n", $prog), "\n", ';');

    # sort in decreasing number so that $keys[0] is the from the most
    # recent eval. In theory we should only have one, but if something
    # breaks we might have more than one, and keys will return them in a
    # random order, so if we dont do this then failing tests will have
    # inconsistent results from run to run.
    my @keys = map { $_->[0] }
               sort { $b->[1] <=> $a->[1] }
               map { (!$seen{$_} and /eval (\d+)/) ? [ $_, $1 ] : ()  }
               keys %::;

    is ((scalar @keys), 1, "1 new eval");

    my @got_lines = @{$::{$keys[0]}};

    is ((scalar @got_lines),
	(scalar @expect_lines), "Right number of lines for $name");

    for (0..$#expect_lines) {
	is ($got_lines[$_], $expect_lines[$_], "Line $_ is correct");
    }
    # if we are "leaking" evals we only want to fail the current test,
    # so we need to mark them all seen (older code only marked $keys[0]
    # seen and this caused tests to fail that actually worked properly.)
    $seen{$_}++ for @keys;
}

my $name = 'foo';

for my $sep (' ', "\0") {