lib/Test/PLP.pm

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