t/50-cgi.t

   1 use strict;
   2 use warnings;
   3
   4 use Cwd;
   5 use File::Basename qw( dirname );
   6 use File::Spec;
   7 use Test::More;
   8 use PLP::Functions qw( DecodeURI );
   9
  10 eval {
  11         require Test::LongString;
  12         Test::LongString->import(max => 128);
  13
  14         no warnings 'redefine';  # override module to not escape newlines
  15         my $formatter = *Test::LongString::_display;
  16         my $parent = \&{$formatter};
  17         *{$formatter} = sub {
  18                 my $s = &{$parent};
  19                 $s =~ s/\Q\x{0a}/\n              /g;  # revert newline quoting
  20                 return $s;
  21         };
  22 } or *is_string = \&is;  # fallback to ugly unformatted is()
  23
  24 eval { require PerlIO::scalar };
  25 plan skip_all => "PerlIO required (perl 5.8) to test PLP" if $@;
  26
  27 plan tests => 25;
  28
  29 require_ok('PLP::Backend::CGI') or BAIL_OUT();
  30
  31 $PLP::use_cache = 0 if $PLP::use_cache;
  32 #TODO: caching on (change file names)
  33
  34 chdir File::Spec->catdir(dirname($0), '50-cgi')
  35         or BAIL_OUT('cannot change to test directory ./50-cgi/');
  36 my $ORGDIR = Cwd::getcwd();
  37 open ORGOUT, '>&', *STDOUT;
  38
  39 sub plp_is {
  40         my ($test, $src, $expect, $env, $in) = @_;
  41         local $Test::Builder::Level = $Test::Builder::Level + 1;
  42
  43         %ENV = (
  44                 REQUEST_METHOD => 'GET',
  45                 REQUEST_URI => "/$src/test/123",
  46                 QUERY_STRING => 'test=1&test=2',
  47                 GATEWAY_INTERFACE => 'CGI/1.1',
  48
  49                 SCRIPT_NAME => '/plp.cgi',
  50                 SCRIPT_FILENAME => "$ORGDIR/plp.cgi",
  51                 PATH_INFO => "/$src/test/123",
  52                 PATH_TRANSLATED => "$ORGDIR/$src/test/123",
  53                 DOCUMENT_ROOT => $ORGDIR,
  54
  55                 $env ? %{$env} : (),
  56         ); # Apache/2.2.4 CGI environment
  57
  58         if (defined $in) {
  59                 $ENV{CONTENT_LENGTH} //= length $in;
  60                 $ENV{CONTENT_TYPE} //= 'application/x-www-form-urlencoded';
  61                 close STDIN;
  62                 open STDIN, '<', $in;
  63         }
  64
  65         close STDOUT;
  66         open STDOUT, '>', \my $output;  # STDOUT buffered to scalar
  67         select STDOUT;  # output before start() (which selects PLPOUT)
  68         eval {
  69                 local $SIG{__WARN__} = sub {
  70                         # include warnings in stdout (but modified to distinguish)
  71                         my $msg = shift;
  72                         my $eol = $msg =~ s/(\s*\z)// && $1;
  73                         print "<warning>$msg</warning>$eol"
  74                 };
  75                 PLP::everything();
  76         };
  77         my $failure = $@;
  78         select ORGOUT;  # return to original STDOUT
  79
  80         if ($failure) {
  81                 fail($test);
  82                 diag("    Error: $failure");
  83                 return;
  84         }
  85         $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
  86         is_string($output, $expect, $test);
  87 }
  88
  89 sub getwarning {
  90         # captures the first warning produced by the given code string
  91         my ($code, $line, $file) = @_;
  92
  93         local $SIG{__WARN__} = sub { die @_ };
  94         # warnings module runs at BEGIN, so we need to use icky expression evals
  95         eval qq(# line $line "$file"\n$code; return);
  96         my $res = $@;
  97         chomp $res;
  98         return $res;
  99 }
 100
 101 sub plp_ok {
 102         my ($file, %replace) = @_;
 103
 104         (my $name = $file) =~ s/[.][^.]+$//;
 105         $file = "$name.html";
 106         my $infile = delete $replace{-input} // "$name.plp";
 107         my $addin = -e "$name.txt" && "$name.txt";
 108         $name =~ s/^(\d*)-// and $name .= " ($1)";
 109         DecodeURI($name);
 110
 111         my $out = eval {
 112                 local $/ = undef;  # slurp
 113                 open my $fh, '<', $file or die "$!\n";
 114                 return readline $fh;
 115         };
 116         if (not defined $out) {
 117                 fail($name);
 118                 diag("error reading output from $file: $@");
 119                 return;
 120         }
 121
 122         my $env = delete $replace{-env};
 123         $replace{HEAD} //= "Content-Type: text/html\nX-PLP-Version: $PLP::VERSION\n";
 124         $replace{VERSION        } //= $PLP::VERSION;
 125         $replace{SCRIPT_NAME    } //= $infile;
 126         $replace{SCRIPT_FILENAME} //= "$ORGDIR/$infile";
 127
 128         chomp $out;
 129         $out =~ s/\$$_/$replace{$_}/g for keys %replace;
 130         $out =~ s{
 131                 <eval \s+ line="([^"]*)"> (.*?) </eval>
 132         }{ getwarning($2, $1, $infile) }msxge;
 133
 134         plp_is($name, $infile, $out, $env, $addin);
 135 }
 136
 137 # 0*: permission checks using generated dummy files
 138 SKIP:
 139 for my $file (glob '0*.html') {
 140         $file =~ s/[.]html$/.plp/;
 141         my ($mode) = $file =~ /^..-(\d*)\b/;
 142         eval {
 143                 if ($mode eq 404) {
 144                         return 1;  # do not create
 145                 }
 146
 147                 # prepare input
 148                 open my $out, '>', $file or die "cannot generate source file ($!)\n";
 149                 print {$out} 'ok';
 150
 151                 if ($mode eq 403) {
 152                         chmod 0244, $file or die "cannot change permissions ($!)\n";
 153                 }
 154
 155                 return -e $file;
 156         } or chomp $@, skip("$file: $@", 1);  # ignore generation failure
 157
 158         plp_ok($file);
 159         eval { unlink $file };  # clean up
 160 }
 161
 162 # 1*-2*: generic tests with standard environment
 163 plp_ok($_) for glob '[12]*.html';
 164
 165 # 3*: error tests depending on warning message
 166 SKIP: {
 167         my @inctests = glob '3*.html';
 168
 169         my $INCFILE = File::Spec->rel2abs("$ORGDIR/missinginclude");
 170         if (open my $dummy, "<", $INCFILE) {  # like PLP::source will
 171                 fail("file missinginclude shouldn't exist");
 172                 skip("missinginclude tests (3*)", @inctests - 1);
 173         }
 174         my $INCWARN = qq{Can't open "$INCFILE" ($!)};
 175
 176         plp_ok($_, INCWARN => $INCWARN) for @inctests;
 177 }
 178
 179 # 4*-6*: apache environment (default)
 180 plp_ok($_) for glob '[4-6]*.html';
 181
 182 #TODO: %fields
 183 #TODO: %cookie
 184
 185 # 7*: multipart posts
 186 TODO: {
 187         local $TODO = 'future feature';
 188         plp_ok($_, -env => {
 189                 CONTENT_TYPE => 'multipart/form-data; boundary=knip',
 190         }) for glob '7*.html';
 191 }
 192
 193 # 8*: lighttpd environment
 194 plp_ok($_, -env => {
 195         # lighttpd/1.4.7 CGI environment
 196         REQUEST_METHOD => 'GET',
 197         REQUEST_URI => "/$_/test/123",
 198         QUERY_STRING => 'test=1&test=2',
 199         GATEWAY_INTERFACE => 'CGI/1.1',
 200
 201         SCRIPT_NAME => "/$_", #XXX: .plp?
 202         SCRIPT_FILENAME => "$ORGDIR/$_",
 203         PATH_INFO => '/test/123',
 204         PATH_TRANSLATED => undef,
 205         DOCUMENT_ROOT => undef,
 206 }) for glob '8*.plp';
 207