view release on metacpan or  search on metacpan

t/lineno-torture.t  view on Meta::CPAN

use warnings;
use strict;

use Test::More;

use Function::Parameters;

fun actual_location_of_line_with($marker) {
    seek DATA, 0, 0 or die "seek DATA: $!";
    my $loc = 0;
    while (my $line = readline DATA) {
        $loc++;
        index($line, $marker) >= 0
            and return $loc;
    }
    undef
}

fun test_loc($marker) {
    my $expected = actual_location_of_line_with $marker;
    defined $expected or die "$marker: something done fucked up";
    my $got = (caller)[2];
    is $got, $expected, "location of '$marker'";
}

sub {
    test_loc 'LT torture begin.';
    use integer;
    my $r = shift;

    my $a = shift;
    my $b = shift;

    test_loc 'LT torture A.';
    @_ = (
        sub {
            my $f = shift;
            test_loc 'LT torture B.';
            @_ = (
                sub {
                    my $f = shift;
                    test_loc 'LT torture C.';
                    @_ = (
                        sub {
                            my $f = shift;
                            test_loc 'LT torture D.';
                            @_ = (
                                sub {
                                    my $n = shift;
                                    test_loc 'LT torture end.';
                                    @_ = $n;
                                    goto &$r;
                                },
                                $b
                            );
                            goto &$f;
                        },
                        $a
                    );
                    goto &$f;
                },
                sub {
                    my $r = shift;
                    my $f = shift;
                    @_ = sub {
                        my $r = shift;
                        my $x = shift;
                        @_ = sub {
                            my $r = shift;
                            my $y = shift;
                            test_loc 'LT torture body.';
                            if ($x && $y) {
                                @_ = (
                                    sub {
                                        my $f = shift;
                                        @_ = ($r, ($x & $y) << 1);
                                        goto &$f;
                                    },
                                    $x ^ $y
                                );
                                goto &$f;
                            }