7 use PLP::Functions qw( DecodeURI );
8 require PLP::Backend::CGI;
9 require PerlIO::scalar;
11 our $VERSION = '1.00';
13 use Test::Builder::Module;
14 use base 'Test::Builder::Module';
15 our @EXPORT = qw( plp_is plp_ok );
17 $PLP::use_cache = 0 if $PLP::use_cache;
18 #TODO: caching on (change file names)
20 my $ORGDIR = '.'; # Cwd::getcwd();
21 open ORGOUT, '>&', *STDOUT;
23 sub is_string ($$;$) {
24 my $tb = __PACKAGE__->builder;
29 # optionally replace unformatted is_string by LongString prettification
30 require Test::LongString;
31 Test::LongString->import(max => 128);
33 # override output method to not escape newlines
34 no warnings 'redefine';
35 my $formatter = *Test::LongString::_display;
36 my $parent = \&{$formatter};
39 $s =~ s/\Q\x{0a}/\n /g;
40 # align lines to: "____expected: "
46 my ($src, $env, $in) = @_;
49 REQUEST_METHOD => 'GET',
50 REQUEST_URI => "/$src/test/123",
51 QUERY_STRING => 'test=1&test=2',
52 GATEWAY_INTERFACE => 'CGI/1.1',
54 SCRIPT_NAME => '/plp.cgi',
55 SCRIPT_FILENAME => "$ORGDIR/plp.cgi",
56 PATH_INFO => "/$src/test/123",
57 PATH_TRANSLATED => "$ORGDIR/$src/test/123",
58 DOCUMENT_ROOT => $ORGDIR,
61 ); # Apache/2.2.4 CGI environment
64 $ENV{CONTENT_LENGTH} //= length $in;
65 $ENV{CONTENT_TYPE} //= 'application/x-www-form-urlencoded';
71 open STDOUT, '>', \my $output; # STDOUT buffered to scalar
72 select STDOUT; # output before start() (which selects PLPOUT)
74 local $SIG{__WARN__} = sub {
75 # include warnings in stdout (but modified to distinguish)
77 my $eol = $msg =~ s/(\s*\z)// && $1;
78 print "<warning>$msg</warning>$eol"
83 select ORGOUT; # return to original STDOUT
85 return ($output, $failure);
89 my ($name, $src, $expect, $env, $in) = @_;
90 my $tb = __PACKAGE__->builder;
91 local $Test::Builder::Level = $Test::Builder::Level + 1;
93 my ($output, $failure) = _plp_run($src, $env, $in);
96 $tb->diag(" Error: $failure");
99 $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
100 is_string($output, $expect, $name);
104 # captures the first warning produced by the given code string
105 my ($code, $line, $file) = @_;
107 local $SIG{__WARN__} = sub { die @_ };
108 # warnings module runs at BEGIN, so we need to use icky expression evals
109 eval qq(# line $line "$file"\n$code; return);
116 my ($file, %replace) = @_;
117 my $tb = __PACKAGE__->builder;
118 local $Test::Builder::Level = $Test::Builder::Level + 1;
120 (my $name = $file) =~ s/[.][^.]+$//;
121 $file = "$name.html";
122 my $infile = delete $replace{-input} // "$name.plp";
123 my $addin = -e "$name.txt" && "$name.txt";
124 $name =~ s/^(\d*)-// and $name .= " ($1)";
128 local $/ = undef; # slurp
129 open my $fh, '<', $file or die "$!\n";
132 if (not defined $out) {
134 $tb->diag("error reading output from $file: $@");
138 my $env = delete $replace{-env};
139 $replace{HEAD} //= "Content-Type: text/html\nX-PLP-Version: $PLP::VERSION\n";
140 $replace{VERSION } //= $PLP::VERSION;
141 $replace{SCRIPT_NAME } //= $infile;
142 $replace{SCRIPT_FILENAME} //= "$ORGDIR/$infile";
145 $out =~ s/\$$_/$replace{$_}/g for keys %replace;
147 <eval \s+ line="([^"]*)"> (.*?) </eval>
148 }{ _getwarning($2, $1, $infile) }msxge;
150 plp_is($name, $infile, $out, $env, $addin);