lib/Test/PLP.pm

   1 package Test::PLP;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Cwd;
   7 use Test::More;
   8 use PLP::Functions qw( DecodeURI );
   9 require PLP::Backend::CGI;
  10 require PerlIO::scalar;
  11
  12 our $VERSION = '1.00';
  13
  14 use base 'Exporter';
  15 our @EXPORT = qw( plp_is plp_ok );
  16
  17 $PLP::use_cache = 0 if $PLP::use_cache;
  18 #TODO: caching on (change file names)
  19
  20 my $ORGDIR = '.'; # Cwd::getcwd();
  21 open ORGOUT, '>&', *STDOUT;
  22
  23 eval {
  24         require Test::LongString;
  25         Test::LongString->import(max => 128);
  26
  27         # override output method to not escape newlines
  28         no warnings 'redefine';
  29         my $formatter = *Test::LongString::_display;
  30         my $parent = \&{$formatter};
  31         *{$formatter} = sub {
  32                 my $s = &{$parent};
  33                 $s =~ s/\Q\x{0a}/\n              /g;
  34                 # align lines to: "____expected: "
  35                 return $s;
  36         };
  37 } or *is_string = \&is;  # fallback to ugly unformatted is()
  38
  39 sub _plp_run {
  40         my ($src, $env, $in) = @_;
  41
  42         %ENV = (
  43                 REQUEST_METHOD => 'GET',
  44                 REQUEST_URI => "/$src/test/123",
  45                 QUERY_STRING => 'test=1&test=2',
  46                 GATEWAY_INTERFACE => 'CGI/1.1',
  47
  48                 SCRIPT_NAME => '/plp.cgi',
  49                 SCRIPT_FILENAME => "$ORGDIR/plp.cgi",
  50                 PATH_INFO => "/$src/test/123",
  51                 PATH_TRANSLATED => "$ORGDIR/$src/test/123",
  52                 DOCUMENT_ROOT => $ORGDIR,
  53
  54                 $env ? %{$env} : (),
  55         ); # Apache/2.2.4 CGI environment
  56
  57         if (defined $in) {
  58                 $ENV{CONTENT_LENGTH} //= length $in;
  59                 $ENV{CONTENT_TYPE} //= 'application/x-www-form-urlencoded';
  60                 close STDIN;
  61                 open STDIN, '<', $in;
  62         }
  63
  64         close STDOUT;
  65         open STDOUT, '>', \my $output;  # STDOUT buffered to scalar
  66         select STDOUT;  # output before start() (which selects PLPOUT)
  67         eval {
  68                 local $SIG{__WARN__} = sub {
  69                         # include warnings in stdout (but modified to distinguish)
  70                         my $msg = shift;
  71                         my $eol = $msg =~ s/(\s*\z)// && $1;
  72                         print "<warning>$msg</warning>$eol"
  73                 };
  74                 PLP::everything();
  75         };
  76         my $failure = $@;
  77         select ORGOUT;  # return to original STDOUT
  78
  79         return ($output, $failure);
  80 }
  81
  82 sub plp_is {
  83         my ($name, $src, $expect, $env, $in) = @_;
  84         local $Test::Builder::Level = $Test::Builder::Level + 1;
  85
  86         my ($output, $failure) = _plp_run($src, $env, $in);
  87         if ($failure) {
  88                 fail($name);
  89                 diag("    Error: $failure");
  90                 return;
  91         }
  92         $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
  93         is_string($output, $expect, $name);
  94 }
  95
  96 sub _getwarning {
  97         # captures the first warning produced by the given code string
  98         my ($code, $line, $file) = @_;
  99
 100         local $SIG{__WARN__} = sub { die @_ };
 101         # warnings module runs at BEGIN, so we need to use icky expression evals
 102         eval qq(# line $line "$file"\n$code; return);
 103         my $res = $@;
 104         chomp $res;
 105         return $res;
 106 }
 107
 108 sub plp_ok {
 109         my ($file, %replace) = @_;
 110         local $Test::Builder::Level = $Test::Builder::Level + 1;
 111
 112         (my $name = $file) =~ s/[.][^.]+$//;
 113         $file = "$name.html";
 114         my $infile = delete $replace{-input} // "$name.plp";
 115         my $addin = -e "$name.txt" && "$name.txt";
 116         $name =~ s/^(\d*)-// and $name .= " ($1)";
 117         DecodeURI($name);
 118
 119         my $out = eval {
 120                 local $/ = undef;  # slurp
 121                 open my $fh, '<', $file or die "$!\n";
 122                 return readline $fh;
 123         };
 124         if (not defined $out) {
 125                 fail($name);
 126                 diag("error reading output from $file: $@");
 127                 return;
 128         }
 129
 130         my $env = delete $replace{-env};
 131         $replace{HEAD} //= "Content-Type: text/html\nX-PLP-Version: $PLP::VERSION\n";
 132         $replace{VERSION        } //= $PLP::VERSION;
 133         $replace{SCRIPT_NAME    } //= $infile;
 134         $replace{SCRIPT_FILENAME} //= "$ORGDIR/$infile";
 135
 136         chomp $out;
 137         $out =~ s/\$$_/$replace{$_}/g for keys %replace;
 138         $out =~ s{
 139                 <eval \s+ line="([^"]*)"> (.*?) </eval>
 140         }{ _getwarning($2, $1, $infile) }msxge;
 141
 142         plp_is($name, $infile, $out, $env, $addin);
 143 }
 144