From 095ac3b8fc366cf1dd634bb746d6720d72b7b9da Mon Sep 17 00:00:00 2001 From: Mischa POSLAWSKY Date: Thu, 3 Sep 2015 18:16:57 +0200 Subject: [PATCH] t: move i/o testing routines to Test::PLP module Support reuse in distinct test files. --- META.yml | 3 + lib/Test/PLP.pm | 144 ++++++++++++++++++++++++++++++++++++++++++++++++ t/50-cgi.t | 121 +--------------------------------------- 3 files changed, 149 insertions(+), 119 deletions(-) create mode 100644 lib/Test/PLP.pm diff --git a/META.yml b/META.yml index dc4750a..064b712 100644 --- a/META.yml +++ b/META.yml @@ -57,6 +57,9 @@ provides: PLP::Tie::Print: file: lib/PLP/Tie/Print.pm version: 1.00 + Test::PLP: + file: lib/Test/PLP.pm + version: 1.00 generated_by: Mischa POSLAWSKY meta-spec: version: 1.4 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 "$msg$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{ + (.*?) + }{ _getwarning($2, $1, $infile) }msxge; + + plp_is($name, $infile, $out, $env, $addin); +} + diff --git a/t/50-cgi.t b/t/50-cgi.t index aaea969..3ad0deb 100644 --- a/t/50-cgi.t +++ b/t/50-cgi.t @@ -5,134 +5,17 @@ use Cwd; 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 "$msg$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{ - (.*?) - }{ getwarning($2, $1, $infile) }msxge; - - plp_is($name, $infile, $out, $env, $addin); -} +my $ORGDIR = '.'; # Cwd::getcwd(); # 0*: permission checks using generated dummy files SKIP: -- 2.30.0