X-Git-Url: http://git.shiar.net/gitweb.cgi/perl/plp/.git/blobdiff_plain/095ac3b8fc366cf1dd634bb746d6720d72b7b9da..50d3d2e4e78263d8741706541afafd58f80167fe:/lib/Test/PLP.pm
diff --git a/lib/Test/PLP.pm b/lib/Test/PLP.pm
index edadc87..04bfe2e 100644
--- a/lib/Test/PLP.pm
+++ b/lib/Test/PLP.pm
@@ -3,24 +3,28 @@ 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';
+use Test::Builder::Module;
+use base 'Test::Builder::Module';
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;
+sub is_string ($$;$) {
+ my $tb = __PACKAGE__->builder;
+ $tb->is_eq(@_);
+}
+
eval {
+ # optionally replace unformatted is_string by LongString prettification
require Test::LongString;
Test::LongString->import(max => 128);
@@ -34,10 +38,10 @@ eval {
# align lines to: "____expected: "
return $s;
};
-} or *is_string = \&is; # fallback to ugly unformatted is()
+} or 1;
sub _plp_run {
- my ($src, $env, $in) = @_;
+ my ($src, $env, $input) = @_;
%ENV = (
REQUEST_METHOD => 'GET',
@@ -46,19 +50,19 @@ sub _plp_run {
GATEWAY_INTERFACE => 'CGI/1.1',
SCRIPT_NAME => '/plp.cgi',
- SCRIPT_FILENAME => "$ORGDIR/plp.cgi",
+ SCRIPT_FILENAME => "./plp.cgi",
PATH_INFO => "/$src/test/123",
- PATH_TRANSLATED => "$ORGDIR/$src/test/123",
- DOCUMENT_ROOT => $ORGDIR,
+ PATH_TRANSLATED => "./$src/test/123",
+ DOCUMENT_ROOT => ".",
$env ? %{$env} : (),
); # Apache/2.2.4 CGI environment
- if (defined $in) {
- $ENV{CONTENT_LENGTH} //= length $in;
+ if (defined $input) {
+ $ENV{CONTENT_LENGTH} //= length $input;
$ENV{CONTENT_TYPE} //= 'application/x-www-form-urlencoded';
close STDIN;
- open STDIN, '<', $in;
+ open STDIN, '<', $input;
}
close STDOUT;
@@ -75,22 +79,29 @@ sub _plp_run {
};
my $failure = $@;
select ORGOUT; # return to original STDOUT
+ die $failure if $failure;
- return ($output, $failure);
+ return $output;
}
sub plp_is {
- my ($name, $src, $expect, $env, $in) = @_;
+ my ($src, $env, $input, $expect, $name) = @_;
+ my $tb = __PACKAGE__->builder;
local $Test::Builder::Level = $Test::Builder::Level + 1;
- my ($output, $failure) = _plp_run($src, $env, $in);
- if ($failure) {
- fail($name);
- diag(" Error: $failure");
+ my $output = eval { _plp_run($src, $env, $input) };
+ if (my $failure = $@) {
+ $tb->ok(0, $name);
+ $tb->diag(" Error: $failure");
return;
}
- $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
- is_string($output, $expect, $name);
+
+ if (defined $expect) {
+ $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
+ return is_string($output, $expect, $name);
+ }
+
+ return $tb->ok(defined $output, $name);
}
sub _getwarning {
@@ -105,40 +116,43 @@ sub _getwarning {
return $res;
}
-sub plp_ok {
+sub _getplp {
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";
+ my $src = delete $replace{-input} // "$name.plp";
+ my $input = -e "$name.txt" && "$name.txt";
$name =~ s/^(\d*)-// and $name .= " ($1)";
DecodeURI($name);
- my $out = eval {
+ my $env = delete $replace{-env};
+
+ my $output;
+ if (open my $fh, '<', $file) {
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;
+ $output = readline $fh;
+ close $fh;
}
- 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{
- (.*?)
- }{ _getwarning($2, $1, $infile) }msxge;
-
- plp_is($name, $infile, $out, $env, $addin);
+ if ($output) {
+ $replace{HEAD} //= "Content-Type: text/html\nX-PLP-Version: $PLP::VERSION\n";
+ $replace{VERSION } //= $PLP::VERSION;
+ $replace{SCRIPT_NAME } //= $src;
+ $replace{SCRIPT_FILENAME} //= "./$src";
+
+ chomp $output;
+ $output =~ s/\$$_/$replace{$_}/g for keys %replace;
+ $output =~ s{
+ (.*?)
+ }{ _getwarning($2, $1, $src) }msxge;
+ }
+
+ return ($src, $env, $input, $output, $name);
+}
+
+sub plp_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ plp_is(_getplp(@_));
}