File Coverage

blib/lib/YATT/Lite/Test/XHFTest2.pm
Criterion Covered Total %
statement 53 233 22.7
branch 0 74 0.0
condition 0 39 0.0
subroutine 18 49 36.7
pod 0 29 0.0
total 71 424 16.7


line stmt bran cond sub pod time code
1             package YATT::Lite::Test::XHFTest2; sub Tests () {__PACKAGE__}
2 1     1   6860 use strict;
  1         3  
  1         30  
3 1     1   5 use warnings qw(FATAL all NONFATAL misc);
  1         2  
  1         38  
4 1     1   7 use Exporter qw(import);
  1         2  
  1         26  
5              
6 1     1   5 use File::Basename qw(dirname);
  1         2  
  1         49  
7              
8 1     1   6 use base qw(YATT::Lite::Object);
  1         2  
  1         90  
9 1         8 use fields qw/files cf_dir cf_libdir
10             cf_debug
11 1     1   6 cookie_jar/;
  1         3  
12             use YATT::Lite::Types
13 1         13 (export_default => 1
14             , [File => -fields => [qw(cf_file items
15             cf_REQUIRE cf_USE_COOKIE
16             cf_FILE_READABLE
17             )]]
18             , [Item => -fields => [qw(cf_TITLE cf_FILE cf_METHOD cf_ACTION
19             cf_BREAK
20             cf_SKIP_IF_ERROR
21             cf_SAME_RESULT
22             cf_PERL_MINVER
23             cf_SITE_CONFIG
24 1     1   124 cf_PARAM cf_HEADER cf_BODY cf_ERROR)]]);
  1         1  
25              
26             our @EXPORT;
27             push @EXPORT, qw(trimlast nocr);
28              
29 1     1   8 use Carp;
  1         3  
  1         67  
30 1     1   6 use Test::More;
  1         2  
  1         10  
31 1     1   573 use YATT::Lite::Test::TestUtil;
  1         2  
  1         46  
32 1     1   7 use File::Basename;
  1         2  
  1         49  
33 1     1   5 use List::Util qw(sum);
  1         2  
  1         52  
34              
35 1     1   5 use YATT::Lite::Util qw(lexpand untaint_any rootname);
  1         3  
  1         706  
36              
37             push @EXPORT, qw(plan is is_deeply like eq_or_diff sum);
38              
39             sub load_tests {
40 0     0 0   my ($pack, $spec) = splice @_, 0, 2;
41 0           my Tests $tests = $pack->new(@$spec);
42 0           foreach my $fn ($tests->list_xhf(@_)) {
43 0           push @{$tests->{files}}, $tests->load_file($fn);
  0            
44             }
45 0           $tests;
46             }
47              
48             sub enter {
49 0     0 0   (my Tests $tests) = @_;
50 0 0         unless (defined $tests->{cf_dir}) {
51 0           croak "dir is undef";
52             }
53 0 0         chdir $tests->{cf_dir} or die "Can't chdir to '$tests->{cf_dir}': $!";
54             }
55              
56             sub test_plan {
57 0     0 0   my Tests $self = shift;
58 0 0 0       unless ($self->{files} and @{$self->{files}}) {
  0            
59 0           return skip_all => "No t/*.xhf are defined";
60             }
61 0           foreach my File $file (@{$self->{files}}) {
  0            
62 0           foreach my $fn (lexpand $file->{cf_FILE_READABLE}) {
63             # Note: This assumes $tests->test_plan is called after $tests->enter.
64 0 0         unless (-r $fn) {
65 0           return skip_all => "FILE $fn is not readable"
66             }
67             }
68 0           foreach my $req (lexpand($file->{cf_REQUIRE})) {
69 0 0         unless (eval qq{require $req}) {
70 0           return skip_all => "$req is not installed.";
71             }
72             }
73             }
74 0           (tests => $self->ntests(@_));
75             }
76              
77             sub load_dispatcher {
78 0     0 0   my Tests $self = shift;
79 0           require YATT::Lite::Factory;
80 0           my $script = do {
81 0 0         if (defined $self->{cf_libdir}) {
    0          
82 0           my $rn = rootname($self->{cf_libdir});
83 0           my @found = grep {-r} map {"$rn.$_"} qw(cgi psgi);
  0            
  0            
84 0           $found[0];
85             } elsif (-r (my $psgi = dirname($self->{cf_dir}) . "/app.psgi")) {
86 0           $psgi;
87             } else {
88 0           undef;
89             }
90             };
91 0 0 0       unless ($script and -r $script) {
92 0           croak "Can't load dispatcher. runyatt.cgi, runyatt.psgi or app.psgi is required";
93             }
94              
95             # $dir/t/../app.psgi => $dir/app.psgi
96 0           (my $realpath = $script) =~ s{/([^\.][^/]*)/\.\.(?:/|$)}{/}g;
97              
98 0           my $dispatcher = YATT::Lite::Factory->load_factory_script($realpath);
99 0           $dispatcher->configure(noheader => 1);
100 0           $dispatcher;
101             }
102              
103             sub ntests {
104 0     0 0   my Tests $tests = shift;
105 0           sum(@_, map {$tests->ntests_per_file($_)} @{$tests->{files}});
  0            
  0            
106             }
107              
108             sub ntests_per_file {
109 0     0 0   (my Tests $tests, my File $file) = @_;
110 0           sum(map {$tests->ntests_per_item($_)} @{$file->{items}});
  0            
  0            
111             }
112              
113             sub ntests_per_item {
114 0     0 0   (my Tests $tests, my Item $item) = @_;
115 0 0         $item->{cf_ACTION} ? 0 : 1;
116             }
117              
118             sub file_title {
119 0     0 0   (my Tests $tests, my File $file) = @_;
120 0           join ';', $tests->{cf_dir}, basename($file->{cf_file});
121             }
122              
123             sub mkpat_by {
124 0     0 0   (my Tests $tests, my $sep) = splice @_, 0, 2;
125 0 0         my $str = join $sep, map {ref $_ ? @$_ : $_} @_;
  0            
126 0           qr{$str}sm;
127             }
128              
129 0     0 0   sub mkpat { shift->mkpat_by('|', @_) }
130 0     0 0   sub mkseqpat { shift->mkpat_by('.*?', @_) }
131              
132             sub list_xhf {
133 0     0 0   my $pack = shift;
134 0 0         unless (@_) {
135 0           <*.xhf>
136             } else {
137             map {
138 0 0         -d $_ ? <$_/*.xhf> : $_
  0            
139             } @_;
140             }
141             }
142              
143 1     1   8 use YATT::Lite::XHF;
  1         6  
  1         281  
144 0     0 0   sub Parser {'YATT::Lite::XHF'}
145             # XXX: Currently, all t/*.xhf is loaded as binary (not Wide char).
146             sub load_file {
147 0     0 0   shift->load_file_into([], @_);
148             }
149              
150             sub load_file_into {
151 0     0 0   my ($pack, $array, $fn) = splice @_, 0, 3;
152 0           _with_loading_file {$pack} $fn, sub {
153 0     0     my File $file = $pack->File->new(file => $fn);
154 0           my $parser = $pack->Parser->new(file => $fn);
155 0 0         if (my @global = $parser->read(skip_comment => 0)) {
156 0           $file->configure(@global);
157             }
158 0           while (my @config = $parser->read) {
159 0 0 0       if (@config == 2 and $config[0] =~ /^include$/i) {
160             $pack->load_file_into($file->{items} //= [], $pack->resolve_in($fn, $_))
161 0   0       for lexpand $config[1];
162             } else {
163 0           push @{$file->{items}}, $pack->Item->new(@config);
  0            
164             }
165             }
166 0           push @$array, @{$file->{items}};
  0            
167 0           $file;
168 0           };
169             }
170              
171             sub resolve_in {
172 0     0 0   my ($pack, $origfn, $newfn) = @_;
173 0           dirname($origfn) . '/' . $newfn;
174             }
175              
176             #========================================
177 1     1   17 use 5.010; no if $] >= 5.017011, warnings => "experimental";
  1     1   4  
  1         5  
  1         3  
  1         10  
178              
179             sub mechanized {
180 0     0 0   (my Tests $tests, my $mech) = @_;
181 0           foreach my File $sect (@{$tests->{files}}) {
  0            
182 0           my $dir = $tests->{cf_dir};
183 0           my $sect_name = $tests->file_title($sect);
184              
185 0           my $last_body;
186 0           foreach my Item $item (@{$sect->{items}}) {
  0            
187              
188 0 0         if (my $action = $item->{cf_ACTION}) {
189 0           my ($method, @args) = @$action;
190 0 0         my $sub = $tests->can("action_$method")
191             or die "No such action: $method";
192 0           $sub->($tests, @args);
193 0           next;
194             }
195              
196 0           my $method = $tests->item_method($item);
197 0           my $error;
198             local $mech->{onerror} = sub {
199 0     0     $error = join " ", @_;
200 0           };
201 0           my $res = $tests->mech_request($mech, $item);
202 0 0         my $T = defined $item->{cf_TITLE} ? "[$item->{cf_TITLE}]" : '';
203              
204             SKIP: {
205 0 0         if (defined $error) {
  0            
206 0 0 0       if (defined $item->{cf_SKIP_IF_ERROR}
207             and $error =~ m{$item->{cf_SKIP_IF_ERROR}}) {
208 0           my $skip_count = $tests->skipcount_for_request_error($item);
209 0           skip $error, $skip_count;
210             } else {
211 0           fail "[$sect_name] $T Unknown error: $error";
212 0           next;
213             }
214             }
215              
216 0 0 0       if ($item->{cf_HEADER} and my @header = @{$item->{cf_HEADER}}) {
  0            
217 0           while (my ($key, $pat) = splice @header, 0, 2) {
218 0           my $title = "[$sect_name] $T HEADER $key of $method $item->{cf_FILE}";
219 0 0         if ($res) {
220 0           like $res->header($key), qr{$pat}s, $title;
221             } else {
222 0           fail "$title - no \$res";
223             }
224             }
225             }
226              
227 0 0         if (my $body = $item->{cf_SAME_RESULT} ? $last_body : $item->{cf_BODY}) {
    0          
    0          
228 0 0         if (ref $body) {
229 0           like nocr($mech->content), $tests->mkseqpat($body)
230             , "[$sect_name] $T BODY of $method $item->{cf_FILE}";
231             } else {
232 0           eq_or_diff trimlast(nocr($mech->content)), $body
233             , "[$sect_name] $T BODY of $method $item->{cf_FILE}";
234             }
235             } elsif (my $errpat = $item->{cf_ERROR}) {
236 0           $errpat =~ s{\^}{^(?:(?i)ERROR: )?};
237              
238             # XXX: It might be better to wrap $mech to have specialized ->title()
239             # for http_localhost.t too.
240             #
241 0   0       like $mech->title // $mech->content, qr{$errpat}
242             , "[$sect_name] $T ERROR of $method $item->{cf_FILE}";
243             }
244             }
245             } continue {
246 0 0         $last_body = $item->{cf_BODY} if $item->{cf_BODY};
247             }
248             }
249             }
250              
251             sub item_method {
252 0     0 0   (my Tests $tests, my ($item)) = @_;
253 0   0       $item->{cf_METHOD} // 'GET';
254             }
255              
256             sub run_psgicb {
257 0     0 0   (my Tests $tests, my ($cb, $item)) = @_;
258 0   0       my $jar = $tests->{cookie_jar} ||= do {
259 0           require HTTP::Cookies;
260 0           HTTP::Cookies->new;
261             };
262 0           my $req = $tests->mkrequest($item);
263 0           my $res = $cb->($req);
264 0           $jar->extract_cookies($res);
265 0           $res;
266             }
267              
268             sub mkrequest {
269 0     0 0   (my Tests $tests, my Item $item) = @_;
270 0           require HTTP::Request::Common;
271 0           my $builder = HTTP::Request::Common->can($item->{cf_METHOD});
272 0           my $req = $builder->($tests->item_url($item)
273             , $tests->mkformref_if_post($item));
274 0 0         if (my $jar = $tests->{cookie_jar}) {
275 0           $jar->add_cookie_header($req);
276             }
277 0           $req;
278             }
279              
280             sub mkformref_if_post {
281 0     0 0   (my Tests $tests, my Item $item) = @_;
282 0 0         return unless $item->{cf_METHOD} eq 'POST';
283             defined (my $ary = $item->{cf_PARAM})
284 0 0         or return;
285 0 0 0       if (ref $ary eq 'ARRAY'
      0        
      0        
286             and grep(ref $_ eq 'HASH', @$ary)
287             or ref $ary eq 'HASH'
288             and grep(ref $_ eq 'HASH', values %$ary)) {
289 0           croak "HASH value is not allowed in PARAM block!";
290             }
291 0           $ary;
292             }
293              
294             sub mech_request {
295 0     0 0   (my Tests $tests, my ($mech, $item)) = @_;
296 0           my $url = $tests->item_url($item);
297 0           given ($tests->item_method($item)) {
298 0           when ('GET') {
299 0           return $mech->get($url);
300             }
301 0           when ('POST') {
302 0           return $mech->post($url, $item->{cf_PARAM});
303             }
304 0           default {
305 0           die "Unknown test method: $_\n";
306             }
307             }
308             }
309              
310             sub item_url {
311 0     0 0   (my Tests $tests, my Item $item) = @_;
312 0           my $url = do {
313 0 0 0       if (($item->{cf_METHOD} // '') eq 'POST') {
314 0           $tests->item_url_file($item)
315             } else {
316 0           join '?', $tests->item_url_file($item), $tests->item_query($item);
317             }
318             };
319 0 0         print STDERR "#item_url: $url\n" if $tests->{cf_debug};
320 0           $url;
321             }
322              
323             sub item_url_file {
324 0     0 0   (my Tests $tests, my Item $item) = @_;
325             $tests->base_url . $item->{cf_FILE}
326 0           }
327              
328 1     1   950 use YATT::Lite::Util qw(encode_query);
  1         3  
  1         204  
329             sub item_query {
330 0     0 0   (my Tests $tests, my Item $item) = @_;
331             my $param = $item->{cf_PARAM}
332 0 0         or return;
333 0           $tests->encode_query($item->{cf_PARAM});
334             }
335              
336             sub skipcount_for_request_error {
337 0     0 0   (my Tests $tests, my Item $item) = @_;
338             lexpand($item->{cf_HEADER})/2
339 0   0       + (defined $item->{cf_BODY} || defined $item->{cf_ERROR});
340             }
341              
342             #========================================
343             sub action_remove {
344 0     0 0   my Tests $tests = shift;
345 0           my @files = glob(shift);
346 0 0         unlink map {untaint_any($_)} @files if @files;
  0            
347             }
348              
349             #========================================
350             sub trimlast {
351 0 0   0 0   return undef unless defined $_[0];
352 0           $_[0] =~ s/\s+$/\n/g;
353 0           $_[0];
354             }
355              
356 1     1   7 use Encode qw(is_utf8 encode);
  1         2  
  1         113  
357             sub nocr {
358 0 0   0 0   return undef unless defined $_[0];
359 0           $_[0] =~ s|\r||g;
360 0 0         if (is_utf8($_[0])) {
361 0           encode(utf8 => $_[0]);
362             } else {
363 0           $_[0];
364             }
365             }
366              
367             1;