t/55-eg: check example pages for warnings

[perl/plp/.git] / lib / Test / PLP.pm

diff --git a/lib/Test/PLP.pm b/lib/Test/PLP.pm
index d1ebb4cd4e740fad2298285a69de240303cb0b4b..519faca92e8dd1c8bfb073c21da06b0513c9a94f 100644 (file)
--- a/lib/Test/PLP.pm
+++ b/lib/Test/PLP.pm
@@ -3,7 +3,6 @@ package Test::PLP;
 use strict;
 use warnings;
 
-use Cwd;
 use PLP::Functions qw( DecodeURI );
 require PLP::Backend::CGI;
 require PerlIO::scalar;
@@ -17,7 +16,6 @@ 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 ($$;$) {
@@ -43,7 +41,7 @@ eval {
 } or 1;
 
 sub _plp_run {
-       my ($src, $env, $in) = @_;
+       my ($src, $env, $input) = @_;
 
        %ENV = (
                REQUEST_METHOD => 'GET',
@@ -52,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;
@@ -81,23 +79,30 @@ 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) {
+       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);
+       }
+
+       $tb->ok(defined $output, $name);
+       return $output;
 }
 
 sub _getwarning {
@@ -112,41 +117,43 @@ sub _getwarning {
        return $res;
 }
 
-sub plp_ok {
+sub _getplp {
        my ($file, %replace) = @_;
-       my $tb = __PACKAGE__->builder;
-       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) {
-               $tb->ok(0, $name);
-               $tb->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{
-               <eval \s+ line="([^"]*)"> (.*?) </eval>
-       }{ _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{
+                       <eval \s+ line="([^"]*)"> (.*?) </eval>
+               }{ _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(@_));
 }