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