view release on metacpan or  search on metacpan

t/test.pl  view on Meta::CPAN

            undef $current;
        } else {
            if (!defined $current) {
                $lineno = $.;
            }
            $current .= $_;
        }
    }
    if (defined $current) {
        push @these, $lineno, $current;
    }
    ((scalar @these) / 2 - 1, @these);
}

sub setup_multiple_progs {
    my ($tests, @prgs);
    foreach my $file (@_) {
        next if $file =~ /(?:~|\.orig|,v)$/;
        next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio');
        next if -d $file;

        open my $fh, '<', $file or die "Cannot open $file: $!\n" ;
        my $found;
        while (<$fh>) {
            if (/^__END__/) {
                $found = $found + 1; # don't use ++
                last;
            }
        }
        # This is an internal error, and should never happen. All bar one of
        # the files had an __END__ marker to signal the end of their preamble,
        # although for some it wasn't technically necessary as they have no
        # tests. It might be possible to process files without an __END__ by
        # seeking back to the start and treating the whole file as tests, but
        # it's simpler and more reliable just to make the rule that all files
        # must have __END__ in. This should never fail - a file without an
        # __END__ should not have been checked in, because the regression tests
        # would not have passed.
        die "Could not find '__END__' in $file"
            unless $found;

        my ($t, @p) = _setup_one_file($fh, $file);
        $tests += $t;
        push @prgs, @p;

        close $fh
            or die "Cannot close $file: $!\n";
    }
    return ($tests, @prgs);
}

sub run_multiple_progs {
    my $up = shift;
    my @prgs;
    if ($up) {
	# The tests in lib run in a temporary subdirectory of t, and always
	# pass in a list of "programs" to run
	@prgs = @_;
    } else {
        # The tests below t run in t and pass in a file handle. In theory we
        # can pass (caller)[1] as the second argument to report errors with
        # the filename of our caller, as the handle is always DATA. However,
        # line numbers in DATA count from the __END__ token, so will be wrong.
        # Which is more confusing than not providing line numbers. So, for now,
        # don't provide line numbers. No obvious clean solution - one hack
        # would be to seek DATA back to the start and read to the __END__ token,
        # but that feels almost like we should just open $0 instead.

        # Not going to rely on undef in list assignment.
        my $dummy;
        ($dummy, @prgs) = _setup_one_file(shift);
    }

    my $tmpfile = tempfile();

    my ($file, $line);
  PROGRAM:
    while (defined ($line = shift @prgs)) {
        $_ = shift @prgs;
        unless ($line) {
            $file = $_;
            if (defined $file) {
                print "# From $file\n";
            }
	    next;
	}
	my $switch = "";
	my @temps ;
	my @temp_path;
	if (s/^(\s*-\w+)//) {
	    $switch = $1;
	}
	my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2);

	my %reason;
	foreach my $what (qw(skip todo)) {
	    $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1;
	    # If the SKIP reason starts ? then it's taken as a code snippet to
	    # evaluate. This provides the flexibility to have conditional SKIPs
	    if ($reason{$what} && $reason{$what} =~ s/^\?//) {
		my $temp = eval $reason{$what};
		if ($@) {
		    die "# In \U$what\E code reason:\n# $reason{$what}\n$@";
		}
		$reason{$what} = $temp;
	    }
	}

	my $name = '';
	if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) {
	    $name = $1;
	}

	if ($reason{skip}) {
	SKIP:
	  {
	    skip($name ? "$name - $reason{skip}" : $reason{skip}, 1);
	  }
	  next PROGRAM;
	}