lib/Test/PLP.pm

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