6 use PLP::Functions qw( DecodeURI );
7 require PLP::Backend::CGI;
8 require PerlIO::scalar;
10 our $VERSION = '1.00';
12 use Test::Builder::Module;
13 use base 'Test::Builder::Module';
14 our @EXPORT = qw( plp_is plp_ok );
16 $PLP::use_cache = 0 if $PLP::use_cache;
17 #TODO: caching on (change file names)
19 open ORGOUT, '>&', *STDOUT;
21 sub is_string ($$;$) {
22 my $tb = __PACKAGE__->builder;
27 # optionally replace unformatted is_string by LongString prettification
28 require Test::LongString;
29 Test::LongString->import(max => 128);
31 # override output method to not escape newlines
32 no warnings 'redefine';
33 my $formatter = *Test::LongString::_display;
34 my $parent = \&{$formatter};
37 $s =~ s/\Q\x{0a}/\n /g;
38 # align lines to: "____expected: "
44 my ($src, $env, $input) = @_;
47 REQUEST_METHOD => 'GET',
48 REQUEST_URI => "/$src/test/123",
49 QUERY_STRING => 'test=1&test=2',
50 GATEWAY_INTERFACE => 'CGI/1.1',
52 SCRIPT_NAME => '/plp.cgi',
53 SCRIPT_FILENAME => "./plp.cgi",
54 PATH_INFO => "/$src/test/123",
55 PATH_TRANSLATED => "./$src/test/123",
59 ); # Apache/2.2.4 CGI environment
62 $ENV{CONTENT_LENGTH} //= length $input;
63 $ENV{CONTENT_TYPE} //= 'application/x-www-form-urlencoded';
65 open STDIN, '<', $input;
69 open STDOUT, '>', \my $output; # STDOUT buffered to scalar
70 select STDOUT; # output before start() (which selects PLPOUT)
72 local $SIG{__WARN__} = sub {
73 # include warnings in stdout (but modified to distinguish)
75 my $eol = $msg =~ s/(\s*\z)// && $1;
76 print "<warning>$msg</warning>$eol"
81 select ORGOUT; # return to original STDOUT
82 die $failure if $failure;
88 my ($src, $env, $input, $expect, $name) = @_;
89 my $tb = __PACKAGE__->builder;
90 local $Test::Builder::Level = $Test::Builder::Level + 1;
92 my $output = eval { _plp_run($src, $env, $input) };
93 if (my $failure = $@) {
95 $tb->diag(" Error: $failure");
99 if (defined $expect) {
100 $output =~ s{((?:.+\n)*)}{ join "", sort split /(?<=\n)/, $1 }e; # order headers
101 return is_string($output, $expect, $name);
104 $tb->ok(defined $output, $name);
109 # captures the first warning produced by the given code string
110 my ($code, $line, $file) = @_;
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);
121 my ($file, %replace) = @_;
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)";
130 my $env = delete $replace{-env};
133 if (open my $fh, '<', $file) {
134 local $/ = undef; # slurp
135 $output = readline $fh;
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";
146 $output =~ s/\$$_/$replace{$_}/g for keys %replace;
148 <eval \s+ line="([^"]*)"> (.*?) </eval>
149 }{ _getwarning($2, $1, $src) }msxge;
152 return ($src, $env, $input, $output, $name);
156 local $Test::Builder::Level = $Test::Builder::Level + 1;