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, $input) = @_;
  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 $input) {
  62                 $ENV{CONTENT_LENGTH} //= length $input;
  63                 $ENV{CONTENT_TYPE} //= 'application/x-www-form-urlencoded';
  64                 close STDIN;
  65                 open STDIN, '<', $input;
  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         die $failure if $failure;
  83
  84         return $output;
  85 }
  86
  87 sub plp_is {
  88         my ($src, $env, $input, $expect, $name) = @_;
  89         my $tb = __PACKAGE__->builder;
  90         local $Test::Builder::Level = $Test::Builder::Level + 1;
  91
  92         my $output = eval { _plp_run($src, $env, $input) };
  93         if (my $failure = $@) {
  94                 $tb->ok(0, $name);
  95                 $tb->diag("    Error: $failure");
  96                 return;
  97         }
  98
  99         if (defined $expect) {
 100                 $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
 101                 return is_string($output, $expect, $name);
 102         }
 103
 104         $tb->ok(defined $output, $name);
 105         return $output;
 106 }
 107
 108 sub _getwarning {
 109         # captures the first warning produced by the given code string
 110         my ($code, $line, $file) = @_;
 111
 112         local $SIG{__WARN__} = sub { die @_ };
 113         # warnings module runs at BEGIN, so we need to use icky expression evals
 114         eval qq(# line $line "$file"\n$code; return);
 115         my $res = $@;
 116         chomp $res;
 117         return $res;
 118 }
 119
 120 sub _getplp {
 121         my ($file, %replace) = @_;
 122
 123         (my $name = $file) =~ s/[.][^.]+$//;
 124         $file = "$name.html";
 125         my $src = delete $replace{-input} // "$name.plp";
 126         my $input = -e "$name.txt" && "$name.txt";
 127         $name =~ s/^(\d*)-// and $name .= " ($1)";
 128         DecodeURI($name);
 129
 130         my $env = delete $replace{-env};
 131
 132         my $output;
 133         if (open my $fh, '<', $file) {
 134                 local $/ = undef;  # slurp
 135                 $output = readline $fh;
 136                 close $fh;
 137         }
 138
 139         if ($output) {
 140                 $replace{HEAD} //= "Content-Type: text/html\nX-PLP-Version: $PLP::VERSION\n";
 141                 $replace{VERSION        } //= $PLP::VERSION;
 142                 $replace{SCRIPT_NAME    } //= $src;
 143                 $replace{SCRIPT_FILENAME} //= "./$src";
 144
 145                 chomp $output;
 146                 $output =~ s/\$$_/$replace{$_}/g for keys %replace;
 147                 $output =~ s{
 148                         <eval \s+ line="([^"]*)"> (.*?) </eval>
 149                 }{ _getwarning($2, $1, $src) }msxge;
 150         }
 151
 152         return ($src, $env, $input, $output, $name);
 153 }
 154
 155 sub plp_ok {
 156         local $Test::Builder::Level = $Test::Builder::Level + 1;
 157         plp_is(_getplp(@_));
 158 }
 159