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 => 21;
  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) = @_;
  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         close STDOUT;
  58         open STDOUT, '>', \my $output;  # STDOUT buffered to scalar
  59         select STDOUT;  # output before start() (which selects PLPOUT)
  60         eval {
  61                 local $SIG{__WARN__} = sub {
  62                         # include warnings in stdout (but modified to distinguish)
  63                         my $msg = shift;
  64                         my $eol = $msg =~ s/(\s*\z)// && $1;
  65                         print "<warning>$msg</warning>$eol"
  66                 };
  67                 PLP::everything();
  68         };
  69         my $failure = $@;
  70         select ORGOUT;  # return to original STDOUT
  71
  72         if ($failure) {
  73                 fail($test);
  74                 diag("    Error: $failure");
  75                 return;
  76         }
  77         $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
  78         is_string($output, $expect, $test);
  79 }
  80
  81 sub getwarning {
  82         # captures the first warning produced by the given code string
  83         my ($code, $line, $file) = @_;
  84
  85         local $SIG{__WARN__} = sub { die @_ };
  86         # warnings module runs at BEGIN, so we need to use icky expression evals
  87         eval qq(# line $line "$file"\n$code; return);
  88         my $res = $@;
  89         chomp $res;
  90         return $res;
  91 }
  92
  93 sub plp_ok {
  94         my ($file, %replace) = @_;
  95
  96         (my $name = $file) =~ s/[.][^.]+$//;
  97         $file = "$name.html";
  98         my $infile = delete $replace{-input} // "$name.plp";
  99         $name =~ s/^(\d*)-// and $name .= " ($1)";
 100
 101         my $out = eval {
 102                 local $/ = undef;  # slurp
 103                 open my $fh, '<', $file or die "$!\n";
 104                 return readline $fh;
 105         };
 106         if (not defined $out) {
 107                 fail($name);
 108                 diag("error reading output from $file: $@");
 109                 return;
 110         }
 111
 112         my $env = delete $replace{-env};
 113         $replace{HEAD} //= "Content-Type: text/html\nX-PLP-Version: $PLP::VERSION\n";
 114         $replace{VERSION        } //= $PLP::VERSION;
 115         $replace{SCRIPT_NAME    } //= $infile;
 116         $replace{SCRIPT_FILENAME} //= "$ORGDIR/$infile";
 117
 118         chomp $out;
 119         $out =~ s/\$$_/$replace{$_}/g for keys %replace;
 120         $out =~ s{
 121                 <eval \s+ line="([^"]*)"> (.*?) </eval>
 122         }{ getwarning($2, $1, $infile) }msxge;
 123
 124         plp_is($name, $infile, $out, $env);
 125 }
 126
 127 # 0*: permission checks using generated dummy files
 128 SKIP:
 129 for my $file (glob '0*.html') {
 130         $file =~ s/[.]html$/.plp/;
 131         my ($mode) = $file =~ /^..-(\d*)\b/;
 132         eval {
 133                 if ($mode eq 404) {
 134                         return 1;  # do not create
 135                 }
 136
 137                 # prepare input
 138                 open my $out, '>', $file or die "cannot generate source file ($!)\n";
 139                 print {$out} 'ok';
 140
 141                 if ($mode eq 403) {
 142                         chmod 0244, $file or die "cannot change permissions ($!)\n";
 143                 }
 144
 145                 return -e $file;
 146         } or chomp $@, skip("$file: $@", 1);  # ignore generation failure
 147
 148         plp_ok($file);
 149         eval { unlink $file };  # clean up
 150 }
 151
 152 # 1*-2*: generic tests with standard environment
 153 plp_ok($_) for glob '[12]*.html';
 154
 155 # 3*: error tests depending on warning message
 156 SKIP: {
 157         my @inctests = glob '3*.html';
 158
 159         my $INCFILE = File::Spec->rel2abs("$ORGDIR/missinginclude");
 160         if (open my $dummy, "<", $INCFILE) {  # like PLP::source will
 161                 fail("file missinginclude shouldn't exist");
 162                 skip("missinginclude tests (3*)", @inctests - 1);
 163         }
 164         my $INCWARN = qq{Can't open "$INCFILE" ($!)};
 165
 166         plp_ok($_, INCWARN => $INCWARN) for @inctests;
 167 }
 168
 169 # 4*-7*: apache environment (default)
 170 plp_ok($_) for glob '[4-7]*.html';
 171
 172 #TODO: %post
 173 #TODO: %fields
 174 #TODO: %cookie
 175
 176 # 8*: lighttpd environment
 177 plp_ok($_, -env => {
 178         # lighttpd/1.4.7 CGI environment
 179         REQUEST_METHOD => 'GET',
 180         REQUEST_URI => "/$_/test/123",
 181         QUERY_STRING => 'test=1&test=2',
 182         GATEWAY_INTERFACE => 'CGI/1.1',
 183
 184         SCRIPT_NAME => "/$_", #XXX: .plp?
 185         SCRIPT_FILENAME => "$ORGDIR/$_",
 186         PATH_INFO => '/test/123',
 187         PATH_TRANSLATED => undef,
 188         DOCUMENT_ROOT => undef,
 189 }) for glob '8*.plp';
 190