File Coverage

blib/lib/YATT/Lite/Test/TestFCGI.pm
Criterion Covered Total %
statement 66 220 30.0
branch 0 88 0.0
condition 0 12 0.0
subroutine 22 44 50.0
pod 0 15 0.0
total 88 379 23.2


line stmt bran cond sub pod time code
1             # -*- coding: utf-8 -*-
2 1     1   19720 use strict;
  1         2  
  1         31  
3 1     1   5 use warnings qw(FATAL all NONFATAL misc);
  1         2  
  1         38  
4              
5             # For future Test::FCGI::Mechanize...
6              
7 1     1   5 use Test::Builder ();
  1         3  
  1         54  
8             my $Test = Test::Builder->new;
9              
10             {
11             package YATT::Lite::Test::TestFCGI; sub MY () {__PACKAGE__}
12 1     1   6 use parent qw(YATT::Lite::Object File::Spec);
  1         2  
  1         8  
13 1         10 use YATT::Lite::MFields qw/res status ct content cookie_jar last_request
14             sockfile
15             raw_result
16             onerror
17             cf_rootdir cf_fcgiscript
18             cf_debug_fcgi
19             kidpid
20 1     1   87 /; # base form
  1         2  
21              
22 1     1   46 use HTML::Entities ();
  1         5044  
  1         191  
23              
24             sub check_skip_reason {
25 0     0 0   my MY $self = shift;
26              
27 0 0         unless (eval {require FCGI and require CGI::Fast}) {
  0 0          
28 0           return 'FCGI.pm is not installed';
29             }
30              
31 0 0         unless (eval {require HTTP::Response}) {
  0            
32 0           return 'HTTP::Response is not installed';
33             }
34              
35 0 0 0       if (ref $self and not -x $self->{cf_fcgiscript}) {
36 0           return "Can't find cgi-bin/runyatt.cgi"
37             }
38              
39 0           return;
40             }
41              
42             sub plan {
43 0     0 0   shift;
44 0           require Test::More;
45 0           Test::More::plan(@_);
46             }
47              
48             sub skip_all {
49 0     0 0   shift;
50 0           require Test::More;
51 0           Test::More::plan(skip_all => shift);
52             }
53              
54             sub which {
55 0     0 0   my ($pack, $exe) = @_;
56 0           foreach my $path ($pack->path) {
57 0 0         if (-x (my $fn = $pack->join($path, $exe))) {
58 0           return $fn;
59             }
60             }
61             }
62              
63 1     1   33 use IO::Socket::UNIX;
  1         14925  
  1         7  
64 1     1   390 use Fcntl;
  1         2  
  1         220  
65 1     1   33 use POSIX ":sys_wait_h";
  1         3855  
  1         6  
66 1     1   1232 use Time::HiRes qw(usleep);
  1         1466  
  1         4  
67 1     1   160 use File::Basename;
  1         2  
  1         647  
68              
69             sub mkservsock {
70 0     0 0   shift; new IO::Socket::UNIX(Local => shift, Listen => 5);
  0            
71             }
72             sub mkclientsock {
73 0     0 0   shift; new IO::Socket::UNIX(Peer => shift);
  0            
74             }
75              
76             sub fork_server {
77 0     0 0   (my MY $self) = @_;
78              
79 0           my $sessdir = MY->tmpdir . "/fcgitest$$";
80 0 0         unless (mkdir $sessdir, 0700) {
81 0           die "Can't mkdir $sessdir: $!";
82             }
83              
84 0           my $sock = $self->mkservsock($self->{sockfile} = "$sessdir/socket");
85              
86 0 0 0       unless (defined($self->{kidpid} = fork)) {
87 0           die "Can't fork: $!";
88             } elsif (not $self->{kidpid}) {
89             # child
90             open STDIN, '<&', $sock or die "kid: Can't reopen STDIN: $!";
91             open STDOUT, '>&', $sock or die "kid: Can't reopen STDOUT: $!";
92             # open STDERR, '>&', $sock or die "kid: Can't reopen STDERR: $!";
93             # XXX: -MDevel::Cover=$ENV{HARNESS_PERL_SWITCHES}
94             # XXX: Taint?
95             my @opts = qw(-T);
96             if (my $switch = $ENV{HARNESS_PERL_SWITCHES}) {
97             push @opts, split " ", $switch;
98             }
99             exec $^X, @opts, $self->{cf_fcgiscript};
100             die "Can't exec $self->{cf_fcgiscript}: $!";
101             }
102             }
103              
104             DESTROY {
105 0     0     (my MY $self) = @_;
106 0 0         if ($self->{kidpid}) {
107             # print STDERR "# shutting down $self->{kidpid}\n";
108             # Shutdown FCGI fcgiscript. TERM is ng.
109 0           kill USR1 => $self->{kidpid};
110 0           waitpid($self->{kidpid}, 0);
111              
112 0 0         if (-e $self->{sockfile}) {
113             # print STDERR "# removing sockfile $self->{sockfile}\n";
114 0           unlink $self->{sockfile};
115 0           rmdir dirname($self->{sockfile});
116             }
117             }
118             }
119              
120             sub parse_result {
121 0     0 0   my MY $self = shift;
122             # print map {"#[[$_]]\n"} split /\n/, $result;
123 0           my $res = $self->{res} = HTTP::Response->parse(shift);
124 0 0         if (defined $res) {
125 0           $res->request($self->{last_request});
126 0   0       $self->{cookie_jar} //= do {
127 0           require HTTP::Cookies;
128 0           HTTP::Cookies->new();
129             };
130 0           $self->{cookie_jar}->extract_cookies($res);
131             }
132 0           $res;
133             }
134              
135             sub bake_cookies {
136 0     0 0   my MY $self = shift;
137 0 0         return unless $self->{cookie_jar};
138 0           $self->{cookie_jar}->add_cookie_header($self->{last_request});
139 0           $self->{last_request}->header('Cookie');
140             }
141              
142             # Poor-man's emulation of WWW::Mechanize.
143             # These members are readonly from client.
144             # ($self->cookie_jar($x) has no results)
145             sub cookie_jar {
146 0     0 0   my MY $self = shift; $self->{cookie_jar};
  0            
147             }
148              
149             sub content {
150 0     0 0   my MY $self = shift;
151 0 0         unless (defined $self->{res}) {
    0          
152 0           undef;
153 0           } elsif (ref $self->{res}) {
154 0           $self->{res}->content;
155             } else {
156 0           $self->{res};
157             }
158             }
159              
160             sub title {
161 0     0 0   my MY $self = shift;
162 0 0         defined (my $res = $self->content) or return undef;
163 0 0         my ($title) = $res =~ m{(.*?)}s or return $res;
164 0           HTML::Entities::decode_entities($title);
165             }
166              
167             sub decode_entities {
168 0     0 0   (my MY $self, my $str) = @_;
169 0           HTML::Entities::decode_entities($str);
170             }
171              
172             sub content_nocr {
173 0     0 0   my MY $self = shift;
174 0 0         defined (my $res = $self->content)
175             or return undef;
176              
177 0           $res =~ s/\r//g;
178 0           $res =~ s/\n+$/\n/;
179 0           $res;
180             }
181              
182 1     1   8 use Carp;
  1         3  
  1         73  
183 1     1   9 use YATT::Lite::Util qw(encode_query);
  1         2  
  1         134  
184             sub is_coverage_mode {
185 0     0 0   my ($pack) = @_;
186 0           my $symtab = (my $root = \%::);
187 0           foreach my $ns (qw(Devel:: Cover::)) {
188 0 0         my $glob = $symtab->{$ns}
189             or return 0;
190 0           $symtab = *{$glob}{HASH}
191 0 0         or return 0;
192             }
193 0           return 1;
194             }
195             }
196              
197             #========================================
198             {
199             package
200             YATT::Lite::Test::TestFCGI::Auto; sub MY () {__PACKAGE__}
201 1     1   7 use parent qw(YATT::Lite::Test::TestFCGI);
  1         2  
  1         8  
202              
203             sub class {
204 0     0     my $pack = shift;
205 0 0         if (eval {require FCGI::Client}) {
  0 0          
206 0           'YATT::Lite::Test::TestFCGI::FCGIClient';
207             } elsif ($pack->which('cgi-fcgi')) {
208 0           'YATT::Lite::Test::TestFCGI::cgi_fcgi';
209             }
210             }
211             }
212              
213             {
214             package
215             YATT::Lite::Test::TestFCGI::FCGIClient; sub MY () {__PACKAGE__}
216 1     1   141 use parent qw(YATT::Lite::Test::TestFCGI);
  1         2  
  1         9  
217 1     1   54 use YATT::Lite::MFields qw(connection raw_error);
  1         2  
  1         8  
218              
219             sub fork_server {
220 0     0     my $self = shift;
221 0           local $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
222 0           $self->SUPER::fork_server(@_);
223             }
224              
225             sub check_skip_reason {
226 0     0     my MY $self = shift;
227              
228 0           my $reason = $self->SUPER::check_skip_reason;
229 0 0         return $reason if $reason;
230              
231 0 0         unless (eval {require FCGI::Client}) {
  0            
232 0           return 'FCGI::Client is not installed';
233             }
234             return
235 0           }
236              
237 1     1   8 use Carp;
  1         2  
  1         53  
238 1     1   6 use YATT::Lite::Util qw(terse_dump);
  1         2  
  1         551  
239             sub request {
240 0     0     (my MY $self, my ($method, $path, $query, $want_error)) = @_;
241 0 0         croak "Should run fork_server before request" unless $self->{kidpid};
242              
243 0           require FCGI::Client;
244             my $client = FCGI::Client::Connection->new
245             (sock => $self->mkclientsock($self->{sockfile})
246 0 0         , timeout => ($self->is_coverage_mode ? 120 : 10));
247              
248             my $env = {REQUEST_METHOD => uc($method)
249             , GATEWAY_INTERFACE => "FCGI::Client"
250             , REQUEST_URI => $path
251             , PATH_INFO => $path
252             , DOCUMENT_ROOT => $self->{cf_rootdir}
253 0           , PATH_TRANSLATED => "$self->{cf_rootdir}$path"
254             , REDIRECT_STATUS => 200
255             };
256 0           my @content;
257 0 0         if (defined $query) {
258 0 0         if ($env->{REQUEST_METHOD} eq 'GET') {
    0          
259 0           $env->{QUERY_STRING} = $self->encode_query($query);
260             } elsif ($env->{REQUEST_METHOD} eq 'POST') {
261 0           $env->{CONTENT_TYPE} = 'application/x-www-form-urlencoded';
262 0           my $enc = $self->encode_query($query);
263 0           push @content, $enc;
264 0           $env->{CONTENT_LENGTH} = length($enc);
265             }
266             }
267              
268 0           $self->{last_request} = do {
269 0           require HTTP::Request;
270             my $req = HTTP::Request->new($env->{REQUEST_METHOD}
271 0           , "http://localhost$path");
272             };
273              
274 0 0         if (my $cookies = $self->bake_cookies()) {
275 0           $env->{HTTP_COOKIE} = $cookies;
276             }
277              
278             print STDERR "# FCGI_REQUEST: ", terse_dump($env, @content), "\n"
279 0 0         if $self->{cf_debug_fcgi};
280              
281 0           ($self->{raw_result}, $self->{raw_error}) = $client->request
282             ($env, @content);
283              
284             print STDERR "# FCGI_RAW_RESULT: ", terse_dump($self->{raw_result}), "\n"
285 0 0         if $self->{cf_debug_fcgi};
286             print STDERR "# FCGI_RAW_ERROR: ", terse_dump($self->{raw_error}), "\n"
287 0 0         if $self->{cf_debug_fcgi};
288              
289 0 0 0       if (defined $self->{raw_error} and $self->{raw_error} ne '') {
290 0 0         if ($want_error) {
291 0           $self->{res} = $self->{raw_error};
292 0           return;
293             }
294 0           print STDERR map {"# ERR: $_\n"} split /\r?\n/, $self->{raw_error};
  0            
295 0           die "error occured: " . terse_dump($method, $path, $query);
296             }
297              
298             # print STDERR "# ANS: ", terse_dump($self->{raw_result}, $self->{raw_error}), "\n";
299              
300 0 0         unless (defined $self->{raw_result}) {
301 0           $self->{res} = undef;
302 0           return;
303             }
304              
305             # Status line を補う。
306 0           my $res = do {
307 0 0         if ($self->{raw_result} =~ m{^HTTP/\d+\.\d+ \d+ }) {
    0          
308             $self->{raw_result}
309 0           } elsif ($self->{raw_result} =~ /^Status: (\d+ .*)/) {
310 0           "HTTP/1.0 $1\x0d\x0a$self->{raw_result}"
311             } else {
312 0           "HTTP/1.0 200 Faked OK\x0d\x0a$self->{raw_result}"
313             }
314             };
315 0           $self->parse_result($res);
316             }
317              
318             }
319              
320             #========================================
321             {
322             package
323             YATT::Lite::Test::TestFCGI::cgi_fcgi; sub MY () {__PACKAGE__}
324 1     1   8 use parent qw(YATT::Lite::Test::TestFCGI);
  1         2  
  1         8  
325 1     1   62 use YATT::Lite::MFields qw(wrapper);
  1         2  
  1         4  
326              
327             sub check_skip_reason {
328 0     0     my MY $self = shift;
329              
330 0           my $reason = $self->SUPER::check_skip_reason;
331 0 0         return $reason if $reason;
332              
333 0 0         $self->{wrapper} = MY->which('cgi-fcgi')
334             or return 'cgi-fcgi is not installed';
335              
336 0 0         unless (-x $self->{cf_fcgiscript}) {
337 0           return 'fcgi fcgiscript is not runnable';
338             }
339              
340 0           return;
341             }
342              
343 1     1   8 use File::Basename;
  1         3  
  1         52  
344 1     1   32 use IPC::Open2;
  1         3019  
  1         238  
345              
346             sub request {
347 0     0     (my MY $self, my ($method, $path, $query)) = @_;
348             # local $ENV{SERVER_SOFTWARE} = 'PERL_TEST_FCGI';
349 0           local $ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
350 0           my $is_post = (local $ENV{REQUEST_METHOD} = uc($method)
351             =~ m{^(POST|PUT)$});
352 0           local $ENV{REQUEST_URI} = $path;
353 0           local $ENV{DOCUMENT_ROOT} = $self->{cf_rootdir};
354 0           local $ENV{PATH_TRANSLATED} = "$self->{cf_rootdir}$path";
355 0 0         local $ENV{QUERY_STRING} = $self->encode_query($query)
356             unless $is_post;
357 0 0         local $ENV{CONTENT_TYPE} = 'application/x-www-form-urlencoded'
358             if $is_post;
359 0           my $enc = $self->encode_query($query);
360 0 0         local $ENV{CONTENT_LENGTH} = length $enc
361             if $is_post;
362              
363             # XXX: open3
364             my $kid = open2 my $read, my $write
365             , $self->{wrapper}, qw(-bind -connect) => $self->{sockfile}
366 0 0         or die "Can't invoke $self->{wrapper}: $!";
367 0 0         if ($is_post) {
368 0           print $write $enc;
369             }
370 0           close $write;
371              
372             #XXX: Status line?
373             #XXX: waitpid
374 0           $self->parse_result(do {local $/; <$read>});
  0            
  0            
375             }
376             }
377              
378             1;