--- /dev/null
+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);
+}
+
use File::Basename qw( dirname );
use File::Spec;
use Test::More;
-use PLP::Functions qw( DecodeURI );
-
-eval {
- require Test::LongString;
- Test::LongString->import(max => 128);
-
- no warnings 'redefine'; # override module to not escape newlines
- my $formatter = *Test::LongString::_display;
- my $parent = \&{$formatter};
- *{$formatter} = sub {
- my $s = &{$parent};
- $s =~ s/\Q\x{0a}/\n /g; # revert newline quoting
- return $s;
- };
-} or *is_string = \&is; # fallback to ugly unformatted is()
-
-eval { require PerlIO::scalar };
-plan skip_all => "PerlIO required (perl 5.8) to test PLP" if $@;
plan tests => 25;
-require_ok('PLP::Backend::CGI') or BAIL_OUT();
+use_ok('Test::PLP');
$PLP::use_cache = 0 if $PLP::use_cache;
#TODO: caching on (change file names)
chdir File::Spec->catdir(dirname($0), '50-cgi')
or BAIL_OUT('cannot change to test directory ./50-cgi/');
-my $ORGDIR = Cwd::getcwd();
-open ORGOUT, '>&', *STDOUT;
-
-sub plp_is {
- my ($test, $src, $expect, $env, $in) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- %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
-
- if ($failure) {
- fail($test);
- diag(" Error: $failure");
- return;
- }
- $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
- is_string($output, $expect, $test);
-}
-
-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) = @_;
-
- (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);
-}
+my $ORGDIR = '.'; # Cwd::getcwd();
# 0*: permission checks using generated dummy files
SKIP:
git.shiar.nl / perl / plp / .git / commitdiff