X-Git-Url: http://git.shiar.net/perl/plp/.git/blobdiff_plain/552db5b79604f6c669eb0a63069b3a5501135e9e..095ac3b8fc366cf1dd634bb746d6720d72b7b9da:/lib/Test/PLP.pm

diff --git a/lib/Test/PLP.pm b/lib/Test/PLP.pm
new file mode 100644
index 0000000..edadc87
--- /dev/null
+++ b/lib/Test/PLP.pm
@@ -0,0 +1,144 @@
+package Test::PLP;
+
+use strict;
+use warnings;
+
+use Cwd;
+use Test::More;
+use PLP::Functions qw( DecodeURI );
+require PLP::Backend::CGI;
+require PerlIO::scalar;
+
+our $VERSION = '1.00';
+
+use base 'Exporter';
+our @EXPORT = qw( plp_is plp_ok );
+
+$PLP::use_cache = 0 if $PLP::use_cache;
+#TODO: caching on (change file names)
+
+my $ORGDIR = '.'; # Cwd::getcwd();
+open ORGOUT, '>&', *STDOUT;
+
+eval {
+	require Test::LongString;
+	Test::LongString->import(max => 128);
+
+	# override output method to not escape newlines
+	no warnings 'redefine';
+	my $formatter = *Test::LongString::_display;
+	my $parent = \&{$formatter};
+	*{$formatter} = sub {
+		my $s = &{$parent};
+		$s =~ s/\Q\x{0a}/\n              /g;
+		# align lines to: "____expected: "
+		return $s;
+	};
+} or *is_string = \&is;  # fallback to ugly unformatted is()
+
+sub _plp_run {
+	my ($src, $env, $in) = @_;
+
+	%ENV = (
+		REQUEST_METHOD => 'GET',
+		REQUEST_URI => "/$src/test/123",
+		QUERY_STRING => 'test=1&test=2',
+		GATEWAY_INTERFACE => 'CGI/1.1',
+		
+		SCRIPT_NAME => '/plp.cgi',
+		SCRIPT_FILENAME => "$ORGDIR/plp.cgi",
+		PATH_INFO => "/$src/test/123",
+		PATH_TRANSLATED => "$ORGDIR/$src/test/123",
+		DOCUMENT_ROOT => $ORGDIR,
+		
+		$env ? %{$env} : (),
+	); # Apache/2.2.4 CGI environment
+
+	if (defined $in) {
+		$ENV{CONTENT_LENGTH} //= length $in;
+		$ENV{CONTENT_TYPE} //= 'application/x-www-form-urlencoded';
+		close STDIN;
+		open STDIN, '<', $in;
+	}
+
+	close STDOUT;
+	open STDOUT, '>', \my $output;  # STDOUT buffered to scalar
+	select STDOUT;  # output before start() (which selects PLPOUT)
+	eval {
+		local $SIG{__WARN__} = sub {
+			# include warnings in stdout (but modified to distinguish)
+			my $msg = shift;
+			my $eol = $msg =~ s/(\s*\z)// && $1;
+			print "<warning>$msg</warning>$eol"
+		};
+		PLP::everything();
+	};
+	my $failure = $@;
+	select ORGOUT;  # return to original STDOUT
+
+	return ($output, $failure);
+}
+
+sub plp_is {
+	my ($name, $src, $expect, $env, $in) = @_;
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+	my ($output, $failure) = _plp_run($src, $env, $in);
+	if ($failure) {
+		fail($name);
+		diag("    Error: $failure");
+		return;
+	}
+	$output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
+	is_string($output, $expect, $name);
+}
+
+sub _getwarning {
+	# captures the first warning produced by the given code string
+	my ($code, $line, $file) = @_;
+
+	local $SIG{__WARN__} = sub { die @_ };
+	# warnings module runs at BEGIN, so we need to use icky expression evals
+	eval qq(# line $line "$file"\n$code; return);
+	my $res = $@;
+	chomp $res;
+	return $res;
+}
+
+sub plp_ok {
+	my ($file, %replace) = @_;
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+	(my $name = $file) =~ s/[.][^.]+$//;
+	$file = "$name.html";
+	my $infile = delete $replace{-input} // "$name.plp";
+	my $addin = -e "$name.txt" && "$name.txt";
+	$name =~ s/^(\d*)-// and $name .= " ($1)";
+	DecodeURI($name);
+
+	my $out = eval {
+		local $/ = undef;  # slurp
+		open my $fh, '<', $file or die "$!\n";
+		return readline $fh;
+	};
+	if (not defined $out) {
+		fail($name);
+		diag("error reading output from $file: $@");
+		return;
+	}
+
+	my $env = delete $replace{-env};
+	$replace{HEAD} //= "Content-Type: text/html\nX-PLP-Version: $PLP::VERSION\n";
+	$replace{VERSION        } //= $PLP::VERSION;
+	$replace{SCRIPT_NAME    } //= $infile;
+	$replace{SCRIPT_FILENAME} //= "$ORGDIR/$infile";
+
+	chomp $out;
+	$out =~ s/\$$_/$replace{$_}/g for keys %replace;
+	$out =~ s{
+		<eval \s+ line="([^"]*)"> (.*?) </eval>
+	}{ _getwarning($2, $1, $infile) }msxge;
+
+	plp_is($name, $infile, $out, $env, $addin);
+}
+