File Coverage

blib/lib/Test/Nginx/Socket.pm
Criterion Covered Total %
statement 330 1214 27.1
branch 112 658 17.0
condition 25 220 11.3
subroutine 35 57 61.4
pod 1 33 3.0
total 503 2182 23.0


line stmt bran cond sub pod time code
1             package Test::Nginx::Socket;
2              
3 5     5   9402 use lib 'lib';
  5         1414  
  5         27  
4 5     5   704 use lib 'inc';
  5         10  
  5         20  
5              
6 5     5   745 use v5.10.1;
  5         22  
7 5     5   2224 use Test::Base -Base;
  5         16  
  5         37  
8 5     5   68  
  5     5   12  
  5     5   161  
  5     5   28  
  5         9  
  5         198  
  5         25  
  5         14  
  5         89  
  5         20  
  5         12  
  5         352  
9             our $VERSION = '0.28';
10              
11 5     5   3428 use POSIX qw( SIGQUIT SIGKILL SIGTERM SIGHUP );
  5         33482  
  5         30  
12 5     5   10262 use Encode;
  5         76694  
  5         507  
13             #use Data::Dumper;
14 5     5   2986 use Time::HiRes qw(sleep time);
  5         7205  
  5         30  
15 5     5   3496 use Test::LongString;
  5         204  
  5         34  
16 5     5   3636 use List::MoreUtils qw( any );
  5         31088  
  5         44  
17 5     5   5618 use List::Util qw( sum min );
  5         16  
  5         595  
18 5     5   2819 use IO::Select ();
  5         8576  
  5         159  
19 5     5   4059 use File::Temp qw( tempfile );
  5         109610  
  5         347  
20 5     5   38 use Digest::MD5 ();
  5         13  
  5         71  
21 5     5   2860 use Digest::SHA ();
  5         16344  
  5         162  
22 5     5   35 use POSIX ":sys_wait_h";
  5         10  
  5         41  
23              
24 5     5   4577 use Test::Nginx::Util;
  5         26  
  5         1878  
25              
26             #use Smart::Comments::JSON '###';
27 5     5   49 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
  5         10  
  5         290  
28 5     5   37 use POSIX qw(EAGAIN);
  5         12  
  5         44  
29 5     5   426 use IO::Socket;
  5         10  
  5         38  
30              
31             #our ($PrevRequest, $PrevConfig);
32              
33             our @EXPORT = qw( env_to_nginx is_str plan run_tests run_test
34             repeat_each config_preamble worker_connections
35             master_process_enabled
36             no_long_string workers master_on master_off
37             log_level no_shuffle no_root_location use_hup
38             server_name
39             server_addr server_root html_dir server_port server_port_for_client
40             timeout no_nginx_manager check_accum_error_log
41             add_block_preprocessor bail_out add_cleanup_handler
42             add_response_body_check
43             );
44              
45             our $CheckLeakCount = $ENV{TEST_NGINX_CHECK_LEAK_COUNT} // 100;
46             our $UseHttp2 = $Test::Nginx::Util::UseHttp2;
47             our $TotalConnectingTimeouts = 0;
48             our $PrevNginxPid;
49              
50             sub send_request ($$$$@);
51             sub send_http2_req ($$$);
52              
53             sub run_filter_helper($$$);
54             sub run_test_helper ($$);
55             sub test_stap ($$);
56              
57             sub error_event_handler ($);
58             sub read_event_handler ($);
59             sub write_event_handler ($);
60             sub transform_response_body ($$$);
61             sub check_response_body ($$$$$$);
62             sub fmt_str ($);
63             sub gen_ab_cmd_from_req ($$@);
64             sub gen_curl_cmd_from_req ($$);
65             sub get_linear_regression_slope ($);
66             sub value_contains ($$);
67              
68             $RunTestHelper = \&run_test_helper;
69             $CheckErrorLog = \&check_error_log;
70             $CheckShutdownErrorLog = \&check_shutdown_error_log;
71              
72             sub set_http_config_filter ($) {
73 0     0 0 0 $FilterHttpConfig = shift;
74             }
75              
76             our @ResponseBodyChecks;
77              
78             sub add_response_body_check ($) {
79 0     0 1 0 push @ResponseBodyChecks, shift;
80             }
81              
82             # This will parse a "request"" string. The expected format is:
83             # - One line for the HTTP verb (POST, GET, etc.) plus optional relative URL
84             # (default is /) plus optional HTTP version (default is HTTP/1.1).
85             # - More lines considered as the body of the request.
86             # Most people don't care about headers and this is enough.
87             #
88             # This function will return a reference to a hash with the parsed elements
89             # plus information on the parsing itself like "how many white spaces were
90             # skipped before the VERB" (skipped_before_method), "was the version provided"
91             # (http_ver_size = 0).
92             sub parse_request ($$) {
93 22     22 0 49 my ( $name, $rrequest ) = @_;
94 22     3   331 open my $in, '<', $rrequest;
  3         21  
  3         6  
  3         20  
95 22         2906 my $first = <$in>;
96 22 50       55 if ( !$first ) {
97 0         0 bail_out("$name - Request line should be non-empty");
98             }
99             #$first =~ s/^\s+|\s+$//gs;
100 22         83 my ($before_meth, $meth, $after_meth);
101 22         0 my ($rel_url, $rel_url_size, $after_rel_url);
102 22         0 my ($http_ver, $http_ver_size, $after_http_ver);
103 22         0 my $end_line_size;
104 22 50       152 if ($first =~ /^(\s*)(\S+)( *)((\S+)( *))?((\S+)( *))?(\s*)$/) {
105 22 50       74 $before_meth = defined $1 ? length($1) : undef;
106 22         43 $meth = $2;
107 22 50       48 $after_meth = defined $3 ? length($3) : undef;
108 22         37 $rel_url = $5;
109 22 100       44 $rel_url_size = defined $5 ? length($5) : undef;
110 22 100       46 $after_rel_url = defined $6 ? length($6) : undef;
111 22         33 $http_ver = $8;
112 22 100       46 if (!defined $8) {
113 18         24 $http_ver_size = undef;
114             } else {
115 4 50       11 $http_ver_size = defined $8 ? length($8) : undef;
116             }
117 22 100       40 if (!defined $9) {
118 18         21 $after_http_ver = undef;
119             } else {
120 4 50       8 $after_http_ver = defined $9 ? length($9) : undef;
121             }
122 22 50       41 $end_line_size = defined $10 ? length($10) : undef;
123             } else {
124 0         0 bail_out("$name - Request line is not valid. Should be 'meth [url [version]]' but got \"$first\".");
125             }
126 22 100       49 if ( !defined $rel_url ) {
127 1         3 $rel_url = '/';
128 1         2 $rel_url_size = 0;
129 1         2 $after_rel_url = 0;
130             }
131 22 100       42 if ( !defined $http_ver ) {
132 18         27 $http_ver = 'HTTP/1.1';
133 18         22 $http_ver_size = 0;
134 18         22 $after_http_ver = 0;
135             }
136              
137             #my $url = "http://localhost:$ServerPortForClient" . $rel_url;
138              
139 22         30 my $content = do { local $/; <$in> };
  22         67  
  22         81  
140 22         28 my $content_size;
141 22 100       39 if ( !defined $content ) {
142 16         19 $content = "";
143 16         21 $content_size = 0;
144             } else {
145 6         9 $content_size = length($content);
146             }
147              
148             #warn Dumper($content);
149              
150 22         44 close $in;
151              
152             return {
153 22         293 method => $meth,
154             url => $rel_url,
155             content => $content,
156             http_ver => $http_ver,
157             skipped_before_method => $before_meth,
158             method_size => length($meth),
159             skipped_after_method => $after_meth,
160             url_size => $rel_url_size,
161             skipped_after_url => $after_rel_url,
162             http_ver_size => $http_ver_size,
163             skipped_after_http_ver => $after_http_ver + $end_line_size,
164             content_size => $content_size,
165             };
166             }
167              
168             # From a parsed request, builds the "moves" to apply to the original request
169             # to transform it (e.g. add missing version). Elements of the returned array
170             # are of 2 types:
171             # - d : number of characters to remove.
172             # - s_* : number of characters (s_s) to replace by value (s_v).
173             sub get_moves($) {
174 14     14 0 27 my ($parsed_req) = @_;
175             return ({d => $parsed_req->{skipped_before_method}},
176             {s_s => $parsed_req->{method_size},
177             s_v => $parsed_req->{method}},
178             {d => $parsed_req->{skipped_after_method}},
179             {s_s => $parsed_req->{url_size},
180             s_v => $parsed_req->{url}},
181             {d => $parsed_req->{skipped_after_url}},
182             {s_s => $parsed_req->{http_ver_size},
183             s_v => $parsed_req->{http_ver}},
184             {d => $parsed_req->{skipped_after_http_ver}},
185             {s_s => 0,
186             s_v => $parsed_req->{headers}},
187             {s_s => $parsed_req->{content_size},
188             s_v => $parsed_req->{content}}
189 14         186 );
190             }
191              
192             # Apply moves (see above) to an array of packets that correspond to a request.
193             # The use of this function is explained in the build_request_from_packets
194             # function.
195             sub apply_moves($$) {
196 20     20 0 49 my ($r_packet, $r_move) = @_;
197 20         33 my $current_packet = shift @$r_packet;
198 20         42 my $current_move = shift @$r_move;
199 20         28 my $in_packet_cursor = 0;
200 20         28 my @result = ();
201 20         43 while (defined $current_packet) {
202 165 100       292 if (!defined $current_move) {
    100          
203 20         35 push @result, $current_packet;
204 20         30 $current_packet = shift @$r_packet;
205 20         42 $in_packet_cursor = 0;
206             } elsif (defined $current_move->{d}) {
207             # Remove stuff from packet
208 61 50       116 if ($current_move->{d} > length($current_packet) - $in_packet_cursor) {
209             # Eat up what is left of packet.
210 0         0 $current_move->{d} -= length($current_packet) - $in_packet_cursor;
211 0 0       0 if ($in_packet_cursor > 0) {
212             # Something in packet from previous iteration.
213 0         0 push @result, $current_packet;
214             }
215 0         0 $current_packet = shift @$r_packet;
216 0         0 $in_packet_cursor = 0;
217             } else {
218             # Remove from current point in current packet
219 61         90 substr($current_packet, $in_packet_cursor, $current_move->{d}) = '';
220 61         128 $current_move = shift @$r_move;
221             }
222             } else {
223             # Substitute stuff
224 84 100       123 if ($current_move->{s_s} > length($current_packet) - $in_packet_cursor) {
225             # {s_s=>3, s_v=>GET} on ['GE', 'T /foo']
226 5         8 $current_move->{s_s} -= length($current_packet) - $in_packet_cursor;
227 5         13 substr($current_packet, $in_packet_cursor) = substr($current_move->{s_v}, 0, length($current_packet) - $in_packet_cursor);
228 5         10 push @result, $current_packet;
229 5         11 $current_move->{s_v} = substr($current_move->{s_v}, length($current_packet) - $in_packet_cursor);
230 5         9 $current_packet = shift @$r_packet;
231 5         11 $in_packet_cursor = 0;
232             } else {
233 79         121 substr($current_packet, $in_packet_cursor, $current_move->{s_s}) = $current_move->{s_v};
234 79         90 $in_packet_cursor += length($current_move->{s_v});
235 79         154 $current_move = shift @$r_move;
236             }
237             }
238             }
239 20         107 return \@result;
240             }
241             # Given a request as an array of packets, will parse it, append the appropriate
242             # headers and return another array of packets.
243             # The function implemented here can be high-level summarized as:
244             # 1 - Concatenate all packets to obtain a string representation of request.
245             # 2 - Parse the string representation
246             # 3 - Get the "moves" from the parsing
247             # 4 - Apply the "moves" to the packets.
248             sub build_request_from_packets($$$$$) {
249 14     14 0 30 my ( $name, $more_headers, $is_chunked, $conn_header, $request_packets ) = @_;
250             # Concatenate packets as a string
251 14         18 my $parsable_request = '';
252 14         16 my @packet_length;
253 14         22 for my $one_packet (@$request_packets) {
254 17         25 $parsable_request .= $one_packet;
255 17         29 push @packet_length, length($one_packet);
256             }
257             # Parse the string representation.
258 14         31 my $parsed_req = parse_request( $name, \$parsable_request );
259              
260             # Append headers
261 14         24 my $len_header = '';
262 14 100 33     100 if ( !$is_chunked
      66        
      66        
263             && defined $parsed_req->{content}
264             && $parsed_req->{content} ne ''
265             && $more_headers !~ /(?:^|\n)Content-Length:/ )
266             {
267 3         15 $parsed_req->{content} =~ s/^\s+|\s+$//gs;
268              
269             $len_header .=
270 3         10 "Content-Length: " . length( $parsed_req->{content} ) . "\r\n";
271             }
272              
273 14         33 $more_headers =~ s/(?
274              
275 14         20 my $headers = '';
276              
277 14 50       28 if ($more_headers !~ /(?:^|\n)Host:/msi) {
278 14         35 $headers .= "Host: $ServerName\r\n";
279             }
280              
281 14 50       25 if ($more_headers !~ /(?:^|\n)Connection/msi) {
282 14         33 $headers .= "Connection: $conn_header\r\n";
283             }
284              
285 14         22 $headers .= "$more_headers$len_header\r\n";
286              
287 14         22 $parsed_req->{method} .= ' ';
288 14         17 $parsed_req->{url} .= ' ';
289 14         20 $parsed_req->{http_ver} .= "\r\n";
290 14         26 $parsed_req->{headers} = $headers;
291              
292             # Get the moves from parsing
293 14         26 my @elements_moves = get_moves($parsed_req);
294             # Apply them to the packets.
295 14         39 return apply_moves($request_packets, \@elements_moves);
296             }
297              
298             sub parse_more_headers ($) {
299 14     14 0 24 my ($in) = @_;
300 14         32 my @headers = split /\n+/, $in;
301 14         17 my $is_chunked;
302 14         18 my $out = '';
303 14         28 for my $header (@headers) {
304 0 0       0 next if $header =~ /^\s*\#/;
305             #warn "HEADER: $header";
306 0         0 my ($key, $val) = split /:\s*/, $header, 2;
307 0 0       0 if (!defined $val) {
308 0         0 $val = '';
309             }
310 0 0 0     0 if (lc($key) eq 'transfer-encoding' and $val eq 'chunked') {
311 0         0 $is_chunked = 1;
312             }
313              
314             #warn "[$key, $val]\n";
315 0         0 $out .= "$key: $val\r\n";
316             }
317 14         33 return $out, $is_chunked;
318             }
319              
320             # Returns an array of array of hashes from the block. Each element of
321             # the first-level array is a request.
322             # Each request is an array of the "packets" to be sent. Each packet is a
323             # string to send, with an (optionnal) delay before sending it.
324             # This function parses (and therefore defines the syntax) of "request*"
325             # sections. See documentation for supported syntax.
326             sub get_req_from_block ($) {
327 9     9 0 39 my ($block) = @_;
328 9         24 my $name = $block->name;
329              
330 9         19 my @req_list = ();
331              
332 9 100       30 if (defined $block->raw_request) {
333              
334             # Should be deprecated.
335 2 100 66     5 if (ref $block->raw_request && ref $block->raw_request eq 'ARRAY') {
336              
337             # User already provided an array. So, he/she specified where the
338             # data should be split. This allows for backward compatibility but
339             # should use request with arrays as it provides the same functionnality.
340 1         3 my @rr_list = ();
341 1         2 for my $elt (@{ $block->raw_request }) {
  1         3  
342 3         8 push @rr_list, {value => $elt};
343             }
344 1         3 push @req_list, \@rr_list;
345              
346             } else {
347 1         3 push @req_list, [{value => $block->raw_request}];
348             }
349              
350             } else {
351 7         12 my $request;
352 7 50       43 if (defined $block->request_eval) {
353              
354 0         0 diag "$name - request_eval DEPRECATED. Use request eval instead.";
355 0         0 $request = eval $block->request_eval;
356 0 0       0 if ($@) {
357 0         0 warn $@;
358             }
359              
360             } else {
361 7         19 $request = $block->request;
362 7 100       19 if (defined $request) {
363 6         42 while ($request =~ s/^\s*\#[^\n]+\s+|^\s+//gs) {
364             # do nothing
365             }
366             }
367             #warn "my req: $request";
368             }
369              
370 7   50     35 my $more_headers = $block->more_headers || '';
371              
372 7 100       23 if ( $block->pipelined_requests ) {
373 1         3 my $reqs = $block->pipelined_requests;
374 1 50 33     7 if (!ref $reqs || ref $reqs ne 'ARRAY') {
375 0         0 bail_out(
376             "$name - invalid entries in --- pipelined_requests");
377             }
378 1         3 my $i = 0;
379 1         11 my $prq = "";
380 1         4 for my $request (@$reqs) {
381 2         3 my $conn_type;
382 2 100       6 if ($i == @$reqs - 1) {
383 1         2 $conn_type = 'close';
384              
385             } else {
386 1         2 $conn_type = 'keep-alive';
387             }
388              
389 2         3 my ($hdr, $is_chunked);
390 2 50       5 if (ref $more_headers eq 'ARRAY') {
391             #warn "Found ", scalar @$more_headers, " entries in --- more_headers.";
392 0         0 $hdr = $more_headers->[$i];
393 0 0       0 if (!defined $hdr) {
394 0         0 bail_out("--- more_headers lacks data for the $i pipelined request");
395             }
396 0         0 ($hdr, $is_chunked) = parse_more_headers($hdr);
397             #warn "more headers: $hdr";
398              
399             } else {
400 2         6 ($hdr, $is_chunked) = parse_more_headers($more_headers);
401             }
402              
403 2         5 my $r_br = build_request_from_packets($name, $hdr,
404             $is_chunked, $conn_type,
405             [$request] );
406 2         5 $prq .= $$r_br[0];
407 2         5 $i++;
408             }
409 1         4 push @req_list, [{value =>$prq}];
410              
411             } else {
412 6         10 my ($is_chunked, $hdr);
413              
414             # request section.
415 6 100       23 if (!ref $request) {
    50          
416 2 50       5 if (ref $more_headers eq 'ARRAY') {
417             #warn "Found ", scalar @$more_headers, " entries in --- more_headers.";
418 0         0 $hdr = $more_headers->[0];
419 0 0       0 if (!defined $hdr) {
420 0         0 bail_out("--- more_headers lacks data for the request");
421             }
422 0         0 ($hdr, $is_chunked) = parse_more_headers($hdr);
423             #warn "more headers: $hdr";
424              
425             } else {
426 2         5 ($hdr, $is_chunked) = parse_more_headers($more_headers);
427             }
428              
429             # One request and it is a good old string.
430 2         9 my $r_br = build_request_from_packets($name, $hdr,
431             $is_chunked, 'close',
432             [$request] );
433 2         12 push @req_list, [{value => $$r_br[0]}];
434              
435             } elsif (ref $request eq 'ARRAY') {
436             # A bunch of requests...
437 4         7 my $i = 0;
438 4         22 for my $one_req (@$request) {
439              
440 10 50       22 if (ref $more_headers eq 'ARRAY') {
441             #warn "Found ", scalar @$more_headers, " entries in --- more_headers.";
442 0         0 $hdr = $more_headers->[$i];
443 0 0       0 if (!defined $hdr) {
444 0         0 bail_out("--- more_headers lacks data for the "
445             . "${i}th request");
446             }
447 0         0 ($hdr, $is_chunked) = parse_more_headers($hdr);
448             #warn "more headers: $hdr";
449              
450             } else {
451 10         23 ($hdr, $is_chunked) = parse_more_headers($more_headers);
452             }
453              
454 10 100       24 if (!ref $one_req) {
    50          
455             # This request is a good old string.
456 7         22 my $r_br = build_request_from_packets($name, $hdr,
457             $is_chunked, 'close',
458             [$one_req] );
459 7         80 push @req_list, [{value => $$r_br[0]}];
460              
461             } elsif (ref $one_req eq 'ARRAY') {
462             # Request expressed as a serie of packets
463 3         4 my @packet_array = ();
464 3         6 for my $one_packet (@$one_req) {
465 6 100       28 if (!ref $one_packet) {
    50          
466             # Packet is a string.
467 3         8 push @packet_array, $one_packet;
468             } elsif (ref $one_packet eq 'HASH'){
469             # Packet is a hash with a value...
470 3         8 push @packet_array, $one_packet->{value};
471             } else {
472 0         0 bail_out "$name - Invalid syntax. $one_packet should be a string or hash with value.";
473             }
474             }
475              
476 3         7 my $transformed_packet_array = build_request_from_packets($name, $hdr,
477             $is_chunked, 'close',
478             \@packet_array);
479 3         5 my @transformed_req = ();
480 3         6 my $idx = 0;
481 3         5 for my $one_transformed_packet (@$transformed_packet_array) {
482 6 100       12 if (!ref $$one_req[$idx]) {
483 3         6 push @transformed_req, {value => $one_transformed_packet};
484             } else {
485             # Is a HASH (checked above as $one_packet)
486 3         5 $$one_req[$idx]->{value} = $one_transformed_packet;
487 3         5 push @transformed_req, $$one_req[$idx];
488             }
489 6         11 $idx++;
490             }
491 3         7 push @req_list, \@transformed_req;
492              
493             } else {
494 0         0 bail_out "$name - Invalid syntax. $one_req should be a string or an array of packets.";
495             }
496              
497 10         24 $i++;
498             }
499              
500             } else {
501 0         0 bail_out(
502             "$name - invalid ---request : MUST be string or array of requests");
503             }
504             }
505              
506             }
507 9         82 return \@req_list;
508             }
509              
510             sub quote_sh_args ($) {
511 0     0 0 0 my ($args) = @_;
512 0         0 for my $arg (@$args) {
513 0 0       0 if ($arg =~ m{^[- "&%;,|?*.+=\w:/()]*$}) {
514 0 0       0 if ($arg =~ /[ "&%;,|?*()]/) {
515 0         0 $arg = "'$arg'";
516             }
517 0         0 next;
518             }
519 0         0 $arg =~ s/\\/\\\\/g;
520 0         0 $arg =~ s/'/\\'/g;
521 0         0 $arg =~ s/\n/\\n/g;
522 0         0 $arg =~ s/\r/\\r/g;
523 0         0 $arg =~ s/\t/\\t/g;
524 0         0 $arg = "\$'$arg'";
525             }
526 0         0 return "@$args";
527             }
528              
529             sub run_filter_helper($$$) {
530 20     20 0 31 my ($block, $filter, $content) = @_;
531              
532 20         37 my $name = $block->name;
533              
534 20 100 66     61 if (ref $filter && ref $filter eq 'CODE') {
    50          
535 4         15 $content = $filter->($content);
536              
537             } elsif (!ref $filter) {
538              
539 16         22 for ($filter) {
540 16 100       48 if ($_ eq 'md5_hex') {
    100          
    100          
    50          
    0          
    0          
    0          
541 3         17 $content = Digest::MD5::md5_hex($content);
542             } elsif ($_ eq 'sha1_hex') {
543 4         37 $content = Digest::SHA::sha1_hex($content);
544             } elsif ($_ eq 'uc') {
545 6         13 $content = uc($content);
546             } elsif ($_ eq 'lc') {
547 3         7 $content = lc($content);
548             } elsif ($_ eq 'ucfirst') {
549 0         0 $content = ucfirst($content);
550             } elsif ($_ eq 'lcfirst') {
551 0         0 $content = lcfirst($content);
552             } elsif ($_ eq 'length') {
553 0         0 $content = length($content);
554             } else {
555 0         0 bail_out("$name - unknown filter, \"$filter\", "
556             . "specified in the --- response_body_filters section");
557             }
558             }
559              
560             } else {
561 0         0 bail_out("$name - the --- response_body_filters section "
562             . "only supports subroutine reference values and string values");
563             }
564              
565 20         56 return $content;
566             }
567              
568             sub run_test_helper ($$) {
569 0     0 0 0 my ($block, $dry_run, $repeated_req_idx) = @_;
570              
571             #warn "repeated req idx: $repeated_req_idx";
572              
573 0         0 my $name = $block->name;
574              
575 0         0 my $r_req_list = get_req_from_block($block);
576              
577 0 0       0 if ( $#$r_req_list < 0 ) {
578 0         0 bail_out("$name - request empty");
579             }
580              
581 0 0       0 if (defined $block->curl) {
582 0         0 my $req = $r_req_list->[0];
583 0         0 my $cmd = gen_curl_cmd_from_req($block, $req);
584 0         0 warn "# ", quote_sh_args($cmd), "\n";
585             }
586              
587 0 0       0 if ($CheckLeak) {
588 0         0 $dry_run = "the \"check leak\" testing mode";
589             }
590              
591 0 0       0 if ($Benchmark) {
592 0         0 $dry_run = "the \"benchmark\" testing mode";
593             }
594              
595 0 0 0     0 if ($Benchmark && !defined $block->no_check_leak) {
596 0         0 warn "$name\n";
597              
598 0         0 my $req = $r_req_list->[0];
599 0         0 my ($nreqs, $concur);
600 0 0       0 if ($Benchmark =~ /^\s*(\d+)(?:\s+(\d+))?\s*$/) {
601 0         0 ($nreqs, $concur) = ($1, $2);
602             }
603              
604 0 0       0 if ($BenchmarkWarmup) {
605 0         0 my $cmd = gen_ab_cmd_from_req($block, $req, $BenchmarkWarmup, $concur);
606 0         0 warn "Warming up with $BenchmarkWarmup requests...\n";
607 0         0 system @$cmd;
608             }
609              
610 0         0 my $cmd = gen_ab_cmd_from_req($block, $req, $nreqs, $concur);
611 0         0 $cmd = quote_sh_args($cmd);
612              
613 0         0 warn "$cmd\n";
614 0         0 system "unbuffer $cmd > /dev/stderr";
615             }
616              
617 0 0 0     0 if ($CheckLeak && !defined $block->no_check_leak) {
618 0         0 warn "$name\n";
619              
620 0         0 my $req = $r_req_list->[0];
621 0         0 my $cmd = gen_ab_cmd_from_req($block, $req);
622              
623             # start a sub-process to run ab or weighttp
624 0         0 my $pid = fork();
625 0 0       0 if (!defined $pid) {
    0          
626 0         0 bail_out("$name - fork() failed: $!");
627              
628             } elsif ($pid == 0) {
629             # child process
630 0         0 exec @$cmd;
631              
632             } else {
633             # main process
634              
635 0         0 $Test::Nginx::Util::ChildPid = $pid;
636              
637 0         0 sleep(1);
638 0         0 my $ngx_pid = get_pid_from_pidfile($name);
639 0 0 0     0 if ($PrevNginxPid && $ngx_pid) {
640 0         0 my $i = 0;
641 0         0 while ($ngx_pid == $PrevNginxPid) {
642 0         0 sleep 0.01;
643 0         0 $ngx_pid = get_pid_from_pidfile($name);
644 0 0       0 if (++$i > 1000) {
645 0         0 bail_out("nginx cannot be started");
646             }
647             }
648             }
649 0         0 $PrevNginxPid = $ngx_pid;
650 0         0 my @rss_list;
651 0         0 for (my $i = 0; $i < $CheckLeakCount; $i++) {
652 0         0 sleep 0.02;
653 0         0 my $out = `ps -eo pid,rss|grep $ngx_pid`;
654 0 0 0     0 if ($? != 0 && !is_running($ngx_pid)) {
655 0 0       0 if (is_running($pid)) {
656 0         0 kill(SIGKILL, $pid);
657 0         0 waitpid($pid, 0);
658             }
659              
660 0         0 my $tb = Test::More->builder;
661 0         0 $tb->no_ending(1);
662              
663 0         0 Test::More::fail("$name - the nginx process $ngx_pid is gone");
664 0         0 last;
665             }
666              
667 0         0 my @lines = grep { $_->[0] eq $ngx_pid }
668 0         0 map { s/^\s+|\s+$//g; [ split /\s+/, $_ ] }
  0         0  
  0         0  
669             split /\n/, $out;
670              
671 0 0       0 if (@lines == 0) {
672 0         0 last;
673             }
674              
675 0 0       0 if (@lines > 1) {
676 0         0 warn "Bad ps output: \"$out\"\n";
677 0         0 next;
678             }
679              
680 0         0 my $ln = shift @lines;
681 0         0 push @rss_list, $ln->[1];
682             }
683              
684             #if ($Test::Nginx::Util::Verbose) {
685 0         0 warn "LeakTest: [@rss_list]\n";
686             #}
687              
688 0 0       0 if (@rss_list == 0) {
689 0         0 warn "LeakTest: k=N/A\n";
690              
691             } else {
692 0         0 my $k = get_linear_regression_slope(\@rss_list);
693 0         0 warn "LeakTest: k=$k\n";
694             #$k = get_linear_regression_slope([1 .. 100]);
695             #warn "K = $k (1 expected)\n";
696             #$k = get_linear_regression_slope([map { $_ * 2 } 1 .. 100]);
697             #warn "K = $k (2 expected)\n";
698             }
699              
700 0 0       0 if (is_running($pid)) {
701 0         0 kill(SIGKILL, $pid);
702 0         0 waitpid($pid, 0);
703             }
704             }
705             }
706              
707             #warn "request: $req\n";
708              
709 0         0 my $timeout = parse_time($block->timeout);
710 0 0       0 if ( !defined $timeout ) {
711 0         0 $timeout = timeout();
712             }
713              
714 0         0 my $res;
715 0         0 my $req_idx = 0;
716 0         0 my ($n, $need_array);
717              
718 0         0 for my $one_req (@$r_req_list) {
719 0         0 my ($raw_resp, $head_req);
720              
721 0 0       0 if ($dry_run) {
722 0         0 $raw_resp = "200 OK HTTP/1.0\r\nContent-Length: 0\r\n\r\n";
723              
724             } else {
725 0         0 ($raw_resp, $head_req) = send_request( $one_req, $block->raw_request_middle_delay,
726             $timeout, $block );
727             }
728              
729             #warn "raw resonse: [$raw_resp]\n";
730              
731 0 0       0 if ($block->pipelined_requests) {
732 0         0 $n = @{ $block->pipelined_requests };
  0         0  
733 0         0 $need_array = 1;
734              
735             } else {
736 0         0 $need_array = $#$r_req_list > 0;
737             }
738              
739             again:
740              
741 0 0       0 if ($Test::Nginx::Util::Verbose) {
742 0         0 warn "!!! resp: [$raw_resp]";
743             }
744              
745 0 0       0 if (!defined $raw_resp) {
746 0         0 $raw_resp = '';
747             }
748              
749 0         0 my ( $raw_headers, $left );
750              
751 0 0       0 if (!defined $block->ignore_response) {
752              
753 0 0       0 if ($Test::Nginx::Util::Verbose) {
754 0         0 warn "parse response\n";
755             }
756              
757 0 0       0 if (defined $block->http09) {
758 0         0 $res = HTTP::Response->new(200, "OK", [], $raw_resp);
759 0         0 $raw_headers = '';
760              
761             } else {
762 0         0 ( $res, $raw_headers, $left ) = parse_response( $name, $raw_resp, $head_req );
763             }
764             }
765              
766 0 0       0 if (!$n) {
767 0 0       0 if ($left) {
768 0         0 my $name = $block->name;
769 0         0 $left =~ s/([\0-\037\200-\377])/sprintf('\x{%02x}',ord $1)/eg;
  0         0  
770 0         0 warn "WARNING: $name - unexpected extra bytes after last chunk in ",
771             "response: \"$left\"\n";
772             }
773              
774             } else {
775 0         0 $raw_resp = $left;
776 0         0 $n--;
777             }
778              
779 0 0       0 if (!defined $block->ignore_response) {
780 0         0 check_error_code($block, $res, $dry_run, $req_idx, $need_array);
781 0         0 check_raw_response_headers($block, $raw_headers, $dry_run, $req_idx, $need_array);
782 0         0 check_response_headers($block, $res, $raw_headers, $dry_run, $req_idx, $need_array);
783 0         0 transform_response_body($block, $res, $req_idx);
784 0         0 check_response_body($block, $res, $dry_run, $req_idx, $repeated_req_idx, $need_array);
785             }
786              
787 0 0 0     0 if ($n || $req_idx < @$r_req_list - 1) {
788 0 0       0 if ($block->wait) {
789 0         0 sleep($block->wait);
790             }
791              
792 0         0 check_error_log($block, $res, $dry_run, $repeated_req_idx, $need_array);
793              
794 0 0       0 if (!defined $block->ignore_response) {
795 0         0 check_access_log($block, $dry_run, $repeated_req_idx);
796             }
797             }
798              
799 0         0 $req_idx++;
800              
801 0 0       0 if ($n) {
802 0         0 goto again;
803             }
804             }
805              
806 0 0       0 if ($block->wait) {
807 0         0 sleep($block->wait);
808             }
809              
810 0 0       0 if ($Test::Nginx::Util::Verbose) {
811 0         0 warn "Testing stap...\n";
812             }
813              
814 0         0 test_stap($block, $dry_run);
815              
816 0         0 check_error_log($block, $res, $dry_run, $repeated_req_idx, $need_array);
817              
818 0 0       0 if (!defined $block->ignore_response) {
819 0         0 check_access_log($block, $dry_run, $repeated_req_idx);
820             }
821             }
822              
823              
824             sub test_stap ($$) {
825 0     0 0 0 my ($block, $dry_run) = @_;
826 0 0       0 return if !$block->{stap};
827              
828 0         0 my $name = $block->name;
829              
830 0         0 my $reason;
831              
832 0 0       0 if ($dry_run) {
833 0         0 $reason = "the lack of directive $dry_run";
834             }
835              
836 0 0       0 if (!$UseStap) {
837 0         0 $dry_run = 1;
838 0   0     0 $reason ||= "env TEST_NGINX_USE_STAP is not set";
839             }
840              
841 0         0 my $fname = stap_out_fname();
842              
843 0 0 0     0 if ($fname && ($fname eq '/dev/stdout' || $fname eq '/dev/stderr')) {
      0        
844 0         0 $dry_run = 1;
845 0   0     0 $reason ||= "TEST_NGINX_TAP_OUT is set to $fname";
846             }
847              
848 0         0 my $stap_out = $block->stap_out;
849 0         0 my $stap_out_like = $block->stap_out_like;
850 0         0 my $stap_out_unlike = $block->stap_out_unlike;
851              
852             SKIP: {
853 0 0       0 skip "$name - stap_out - tests skipped due to $reason", 1 if $dry_run;
  0         0  
854              
855 0         0 my $fh = stap_out_fh();
856 0 0       0 if (!$fh) {
857 0         0 bail_out("no stap output file handle found");
858             }
859              
860 0         0 my $out = '';
861 0         0 for (1..2) {
862 0 0       0 if (sleep_time() < 0.2) {
863 0         0 sleep 0.2;
864              
865             } else {
866 0         0 sleep sleep_time();
867             }
868              
869 0         0 while (<$fh>) {
870 0         0 $out .= $_;
871             }
872              
873 0 0       0 if ($out) {
874 0         0 last;
875             }
876             }
877              
878 0 0       0 if ($Test::Nginx::Util::Verbose) {
879 0         0 warn "stap out: $out\n";
880             }
881              
882 0 0       0 if (defined $stap_out) {
883 0 0       0 if ($NoLongString) {
884 0         0 is($out, $block->stap_out, "$name - stap output expected");
885             } else {
886 0         0 is_string($out, $block->stap_out, "$name - stap output expected");
887             }
888             }
889              
890 0 0       0 if (defined $stap_out_like) {
891 0   0     0 like($out || '', qr/$stap_out_like/sm,
892             "$name - stap output should match the pattern");
893             }
894              
895 0 0       0 if (defined $stap_out_unlike) {
896 0   0     0 unlike($out || '', qr/$stap_out_unlike/sm,
897             "$name - stap output should not match the pattern");
898             }
899             }
900             }
901              
902              
903             # Helper function to retrieve a "check" (e.g. error_code) section. This also
904             # checks that tests with arrays of requests are arrays themselves.
905             sub get_indexed_value($$$$) {
906 16     16 0 32 my ($name, $value, $req_idx, $need_array) = @_;
907 16 100       36 if ($need_array) {
908 6 50 33     26 if (ref $value && ref $value eq 'ARRAY') {
909 6         16 return $$value[$req_idx];
910             }
911              
912 0         0 bail_out("$name - You asked for many requests, the expected results should be arrays as well.");
913              
914             } else {
915             # One element but still provided as an array.
916 10 100 66     31 if (ref $value && ref $value eq 'ARRAY') {
917 1 50       4 if ($req_idx != 0) {
918 0         0 bail_out("$name - SHOULD NOT HAPPEN: idx != 0 and don't need array.");
919             }
920              
921 1         4 return $$value[0];
922             }
923              
924 9         17 return $value;
925             }
926             }
927              
928             sub check_error_code ($$$$$) {
929 0     0 0 0 my ($block, $res, $dry_run, $req_idx, $need_array) = @_;
930              
931 0         0 my $name = $block->name;
932             SKIP: {
933 0 0       0 skip "$name - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
934              
935 0 0       0 if ( defined $block->error_code_like ) {
    0          
936              
937 0         0 my $val = get_indexed_value($name, $block->error_code_like, $req_idx, $need_array);
938 0   0     0 like( ($res && $res->code) || '',
939             qr/$val/sm,
940             "$name - status code ok" );
941              
942             } elsif ( defined $block->error_code ) {
943 0   0     0 is( ($res && $res->code) || '',
944             get_indexed_value($name, $block->error_code, $req_idx, $need_array),
945             "$name - status code ok" );
946              
947             } else {
948 0   0     0 is( ($res && $res->code) || '', 200, "$name - status code ok" );
949             }
950             }
951             }
952              
953             sub check_raw_response_headers($$$$$) {
954 0     0 0 0 my ($block, $raw_headers, $dry_run, $req_idx, $need_array) = @_;
955 0         0 my $name = $block->name;
956 0 0       0 if (defined $block->raw_response_headers_like) {
957             SKIP: {
958 0 0       0 skip "$name - raw_response_headers_like - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
959 0         0 my $expected = get_indexed_value($name,
960             $block->raw_response_headers_like,
961             $req_idx,
962             $need_array);
963 0         0 like $raw_headers, qr/$expected/s, "$name - raw resp headers like";
964             }
965             }
966              
967 0 0       0 if (defined $block->raw_response_headers_unlike) {
968             SKIP: {
969 0 0       0 skip "$name - raw_response_headers_unlike - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
970 0         0 my $expected = get_indexed_value($name,
971             $block->raw_response_headers_unlike,
972             $req_idx,
973             $need_array);
974 0         0 unlike $raw_headers, qr/$expected/s, "$name - raw resp headers unlike";
975             }
976             }
977             }
978              
979             sub check_response_headers($$$$$) {
980 0     0 0 0 my ($block, $res, $raw_headers, $dry_run, $req_idx, $need_array) = @_;
981 0         0 my $name = $block->name;
982 0 0       0 if ( defined $block->response_headers ) {
    0          
983 0         0 my $headers = parse_headers( get_indexed_value($name,
984             $block->response_headers,
985             $req_idx,
986             $need_array));
987 0         0 while ( my ( $key, $val ) = each %$headers ) {
988 0 0       0 if ( !defined $val ) {
989              
990             #warn "HIT";
991             SKIP: {
992 0 0       0 skip "$name - response_headers - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
993 0         0 unlike $raw_headers, qr/^\s*\Q$key\E\s*:/ms,
994             "$name - header $key not present in the raw headers";
995             }
996 0         0 next;
997             }
998              
999 0         0 $val =~ s/\$ServerPort\b/$ServerPort/g;
1000 0         0 $val =~ s/\$ServerPortForClient\b/$ServerPortForClient/g;
1001              
1002 0 0       0 my $actual_val = $res ? $res->header($key) : undef;
1003 0 0       0 if ( !defined $actual_val ) {
1004 0         0 $actual_val = '';
1005             }
1006              
1007             SKIP: {
1008 0 0       0 skip "$name - response_headers - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1009 0         0 is $actual_val, $val, "$name - header $key ok";
1010             }
1011             }
1012             }
1013             elsif ( defined $block->response_headers_like ) {
1014 0         0 my $headers = parse_headers( get_indexed_value($name,
1015             $block->response_headers_like,
1016             $req_idx,
1017             $need_array) );
1018 0         0 while ( my ( $key, $val ) = each %$headers ) {
1019 0         0 my $expected_val = $res->header($key);
1020 0 0       0 if ( !defined $expected_val ) {
1021 0         0 $expected_val = '';
1022             }
1023             SKIP: {
1024 0 0       0 skip "$name - response_headers_like - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1025 0         0 like $expected_val, qr/^$val$/, "$name - header $key like ok";
1026             }
1027             }
1028             }
1029             }
1030              
1031             sub value_contains ($$) {
1032 0     0 0 0 my ($val, $pat) = @_;
1033              
1034 0 0 0     0 if (!ref $val || ref $val eq 'Regexp') {
1035 0         0 return $val =~ /\Q$pat\E/;
1036             }
1037              
1038 0 0       0 if (ref $val eq 'ARRAY') {
1039 0         0 for my $v (@$val) {
1040 0 0       0 if (value_contains($v, $pat)) {
1041 0         0 return 1;
1042             }
1043             }
1044             }
1045              
1046 0         0 return undef;
1047             }
1048              
1049             sub check_access_log ($$$) {
1050 0     0 0 0 my ($block, $dry_run, $repeated_req_idx) = @_;
1051 0         0 my $name = $block->name;
1052 0         0 my $lines;
1053              
1054 0 0       0 if (defined $block->access_log) {
1055 0         0 my $pats = $block->access_log;
1056              
1057 0 0       0 if (!ref $pats) {
    0          
1058 0         0 chomp $pats;
1059 0         0 my @lines = split /\n+/, $pats;
1060 0         0 $pats = \@lines;
1061              
1062             } elsif (ref $pats eq 'Regexp') {
1063 0         0 $pats = [$pats];
1064              
1065             } else {
1066 0         0 my @clone = @$pats;
1067 0         0 $pats = \@clone;
1068             }
1069              
1070 0   0     0 $lines ||= access_log_data();
1071 0         0 for my $line (@$lines) {
1072 0         0 for my $pat (@$pats) {
1073 0 0       0 next if !defined $pat;
1074 0 0 0     0 if (ref $pat && $line =~ /$pat/ || $line =~ /\Q$pat\E/) {
      0        
1075             SKIP: {
1076 0 0       0 skip "$name - access_log - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1077 0         0 pass("$name - pattern \"$pat\" matches a line in access.log (req $repeated_req_idx)");
1078             }
1079 0         0 undef $pat;
1080             }
1081             }
1082             }
1083              
1084 0         0 for my $pat (@$pats) {
1085 0 0       0 if (defined $pat) {
1086             SKIP: {
1087 0 0       0 skip "$name - access_log - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1088 0         0 fail("$name - pattern \"$pat\" should match a line in access.log (req $repeated_req_idx)");
1089             #die join("", @$lines);
1090             }
1091             }
1092             }
1093             }
1094             }
1095              
1096             sub check_error_log ($$$$) {
1097 0     0 0 0 my ($block, $res, $dry_run, $repeated_req_idx, $need_array) = @_;
1098 0         0 my $name = $block->name;
1099 0         0 my $lines;
1100              
1101 0         0 my $check_write_guard_message = 1;
1102 0         0 my $check_alert_message = 1;
1103 0         0 my $check_crit_message = 1;
1104 0         0 my $check_emerg_message = 1;
1105              
1106 0         0 my $grep_pat;
1107 0         0 my $grep_pats = $block->grep_error_log;
1108 0 0       0 if (defined $grep_pats) {
1109 0 0 0     0 if (ref $grep_pats && ref $grep_pats eq 'ARRAY') {
1110 0         0 $grep_pat = $grep_pats->[$repeated_req_idx];
1111              
1112             } else {
1113 0         0 $grep_pat = $grep_pats;
1114             }
1115             }
1116              
1117 0 0       0 if (defined $grep_pat) {
1118 0         0 my $expected = $block->grep_error_log_out;
1119 0 0       0 if (!defined $expected) {
1120 0         0 bail_out("$name - No --- grep_error_log_out defined but --- grep_error_log is defined");
1121             }
1122              
1123             #warn "ref grep error log: ", ref $expected;
1124              
1125 0 0 0     0 if (ref $expected && ref $expected eq 'ARRAY') {
1126             #warn "grep error log out is an ARRAY";
1127 0         0 $expected = $expected->[$repeated_req_idx];
1128             }
1129              
1130             SKIP: {
1131 0 0       0 skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1132              
1133 0   0     0 $lines ||= error_log_data();
1134              
1135 0         0 my $matched_lines = '';
1136 0         0 for my $line (@$lines) {
1137 0 0 0     0 if (ref $grep_pat && $line =~ /$grep_pat/ || $line =~ /\Q$grep_pat\E/) {
      0        
1138 0         0 my $matched = $&;
1139 0 0       0 if ($matched !~ /\n/) {
1140 0         0 $matched_lines .= $matched . "\n";
1141             }
1142             }
1143             }
1144              
1145 0 0       0 if (ref $expected eq 'Regexp') {
1146 0         0 like($matched_lines, $expected, "$name - grep_error_log_out (req $repeated_req_idx)");
1147              
1148             } else {
1149 0 0       0 if ($NoLongString) {
1150 0         0 is($matched_lines, $expected,
1151             "$name - grep_error_log_out (req $repeated_req_idx)" );
1152             } else {
1153 0         0 is_string($matched_lines, $expected,
1154             "$name - grep_error_log_out (req $repeated_req_idx)");
1155             }
1156             }
1157             }
1158             }
1159              
1160 0 0       0 if (defined $block->error_log) {
1161 0         0 my $pats = $block->error_log;
1162              
1163 0 0       0 if (value_contains($pats,
1164             "writing a global lua variable"))
1165             {
1166 0         0 undef $check_write_guard_message;
1167             }
1168              
1169 0 0       0 if (value_contains($pats, "[alert")) {
1170 0         0 undef $check_alert_message;
1171             }
1172              
1173 0 0       0 if (value_contains($pats, "[crit")) {
1174 0         0 undef $check_crit_message;
1175             }
1176              
1177 0 0       0 if (value_contains($pats, "[emerg")) {
1178 0         0 undef $check_emerg_message;
1179             }
1180              
1181 0 0       0 if (!ref $pats) {
    0          
1182 0         0 chomp $pats;
1183 0         0 my @lines = split /\n+/, $pats;
1184 0         0 $pats = \@lines;
1185              
1186             } elsif (ref $pats eq 'Regexp') {
1187 0         0 $pats = [$pats];
1188              
1189             } else {
1190 0         0 my @clone = @$pats;
1191 0         0 $pats = \@clone;
1192             }
1193              
1194 0   0     0 $lines ||= error_log_data();
1195             #warn "error log data: ", join "\n", @$lines;
1196 0         0 for my $line (@$lines) {
1197 0         0 for my $pat (@$pats) {
1198 0 0       0 next if !defined $pat;
1199 0 0 0     0 if (ref $pat && $line =~ /$pat/ || $line =~ /\Q$pat\E/) {
      0        
1200             SKIP: {
1201 0 0       0 skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1202 0         0 pass("$name - pattern \"$pat\" matches a line in error.log (req $repeated_req_idx)");
1203             }
1204 0         0 undef $pat;
1205             }
1206             }
1207             }
1208              
1209 0         0 for my $pat (@$pats) {
1210 0 0       0 if (defined $pat) {
1211             SKIP: {
1212 0 0       0 skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1213 0         0 fail("$name - pattern \"$pat\" should match a line in error.log (req $repeated_req_idx)");
1214             #die join("", @$lines);
1215             }
1216             }
1217             }
1218             }
1219              
1220 0 0       0 if (defined $block->no_error_log) {
1221             #warn "HERE";
1222 0         0 my $pats = $block->no_error_log;
1223              
1224 0 0       0 if (value_contains($pats,
1225             "writing a global lua variable"))
1226             {
1227 0         0 undef $check_write_guard_message;
1228             }
1229              
1230 0 0       0 if (value_contains($pats, "[alert")) {
1231 0         0 undef $check_alert_message;
1232             }
1233              
1234 0 0       0 if (value_contains($pats, "[crit")) {
1235 0         0 undef $check_crit_message;
1236             }
1237              
1238 0 0       0 if (value_contains($pats, "[emerg")) {
1239 0         0 undef $check_emerg_message;
1240             }
1241              
1242 0 0       0 if (!ref $pats) {
    0          
1243 0         0 chomp $pats;
1244 0         0 my @lines = split /\n+/, $pats;
1245 0         0 $pats = \@lines;
1246              
1247             } elsif (ref $pats eq 'Regexp') {
1248 0         0 $pats = [$pats];
1249              
1250             } else {
1251 0         0 my @clone = @$pats;
1252 0         0 $pats = \@clone;
1253             }
1254              
1255 0         0 my %found;
1256 0   0     0 $lines ||= error_log_data();
1257 0         0 my $i = 0;
1258 0         0 for my $line (@$lines) {
1259 0         0 for my $pat (@$pats) {
1260 0 0       0 next if !defined $pat;
1261             #warn "test $pat\n";
1262 0 0 0     0 if ((ref $pat && $line =~ /$pat/) || $line =~ /\Q$pat\E/) {
      0        
1263 0 0       0 if ($found{$pat}) {
1264 0         0 my $tb = Test::More->builder;
1265 0         0 $tb->no_ending(1);
1266              
1267             } else {
1268 0         0 $found{$pat} = 1;
1269             }
1270              
1271             SKIP: {
1272 0 0       0 skip "$name - no_error_log - tests skipped due to $dry_run ($line)", 1 if $dry_run;
  0         0  
1273 0         0 my $ln = fmt_str($line);
1274 0         0 my $p = fmt_str($pat);
1275 0         0 my @more_lines;
1276 0         0 for (my $j = $i + 1; $j < min($i + 10, @$lines - 1); $j++) {
1277 0         0 push @more_lines, $lines->[$j];
1278             }
1279              
1280 0         0 fail("$name - pattern \"$p\" should not match any line in error.log but matches line \"$ln\" (req $repeated_req_idx)\n"
1281             . join "", @more_lines);
1282             }
1283             }
1284             }
1285              
1286             } continue {
1287 0         0 $i++;
1288             }
1289              
1290 0         0 for my $pat (@$pats) {
1291 0 0       0 next if $found{$pat};
1292 0 0       0 if (defined $pat) {
1293             SKIP: {
1294 0 0       0 skip "$name - no_error_log - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1295 0         0 my $p = fmt_str($pat);
1296 0         0 pass("$name - pattern \"$p\" does not match a line in error.log (req $repeated_req_idx)");
1297             }
1298             }
1299             }
1300             }
1301              
1302 0 0 0     0 if ($check_write_guard_message && !$dry_run) {
1303 0   0     0 $lines ||= error_log_data();
1304 0         0 for my $line (@$lines) {
1305             #warn "test $pat\n";
1306 0 0       0 if ($line =~ /writing a global lua variable/) {
1307 0         0 my $ln = fmt_str($line);
1308 0         0 warn("WARNING: $name - $ln\n");
1309             }
1310             }
1311             }
1312              
1313 0 0 0     0 if ($check_alert_message && !$dry_run) {
1314 0   0     0 $lines ||= error_log_data();
1315 0         0 for my $line (@$lines) {
1316             #warn "test $pat\n";
1317 0 0       0 if ($line =~ /\[alert\]/) {
1318 0         0 my $ln = fmt_str($line);
1319 0         0 warn("WARNING: $name - $ln\n");
1320             }
1321             }
1322             }
1323              
1324 0 0 0     0 if ($check_crit_message && !$dry_run) {
1325 0   0     0 $lines ||= error_log_data();
1326 0         0 for my $line (@$lines) {
1327             #warn "test $pat\n";
1328 0 0       0 if ($line =~ /\[crit\]/) {
1329 0         0 my $ln = fmt_str($line);
1330 0         0 warn("WARNING: $name - $ln\n");
1331             }
1332             }
1333             }
1334              
1335 0 0 0     0 if ($check_emerg_message && !$dry_run) {
1336 0   0     0 $lines ||= error_log_data();
1337 0         0 for my $line (@$lines) {
1338             #warn "test $pat\n";
1339 0 0       0 if ($line =~ /\[emerg\]/) {
1340 0         0 my $ln = fmt_str($line);
1341 0         0 warn("WARNING: $name - $ln");
1342             }
1343             }
1344             }
1345              
1346 0         0 for my $line (@$lines) {
1347             #warn "test $pat\n";
1348 0 0       0 if ($line =~ /\bAssertion .*?failed\b/) {
1349 0         0 my $tb = Test::More->builder;
1350 0         0 $tb->no_ending(1);
1351              
1352 0         0 chomp $line;
1353 0         0 fail("$name - $line\n");
1354             }
1355             }
1356             }
1357              
1358             sub check_shutdown_error_log ($$) {
1359 0     0 0 0 my ($block, $dry_run) = @_;
1360 0         0 my $name = $block->name;
1361 0         0 my $lines;
1362              
1363 0         0 my $pats = $block->shutdown_error_log;
1364              
1365 0 0       0 if (!ref $pats) {
    0          
1366 0         0 chomp $pats;
1367 0         0 my @lines = split /\n+/, $pats;
1368 0         0 $pats = \@lines;
1369              
1370             } elsif (ref $pats eq 'Regexp') {
1371 0         0 $pats = [$pats];
1372              
1373             } else {
1374 0         0 my @clone = @$pats;
1375 0         0 $pats = \@clone;
1376             }
1377              
1378 0 0       0 if (defined $block->no_shutdown_error_log) {
1379             # warn "HERE";
1380 0         0 my $pats = $block->no_shutdown_error_log;
1381              
1382 0 0       0 if (!ref $pats) {
    0          
1383 0         0 chomp $pats;
1384 0         0 my @lines = split /\n+/, $pats;
1385 0         0 $pats = \@lines;
1386              
1387             } elsif (ref $pats eq 'Regexp') {
1388 0         0 $pats = [$pats];
1389              
1390             } else {
1391 0         0 my @clone = @$pats;
1392 0         0 $pats = \@clone;
1393             }
1394              
1395 0         0 my %found;
1396 0   0     0 $lines ||= error_log_data();
1397             # warn "error log data: ", join "\n", @$lines;
1398 0         0 for my $line (@$lines) {
1399 0         0 for my $pat (@$pats) {
1400 0 0       0 next if !defined $pat;
1401             #warn "test $pat\n";
1402 0 0 0     0 if ((ref $pat && $line =~ /$pat/) || $line =~ /\Q$pat\E/) {
      0        
1403 0 0       0 if ($found{$pat}) {
1404 0         0 my $tb = Test::More->builder;
1405 0         0 $tb->no_ending(1);
1406              
1407             } else {
1408 0         0 $found{$pat} = 1;
1409             }
1410              
1411             SKIP: {
1412 0 0       0 skip "$name - no_shutdown_error_log - tests skipped due to $dry_run ($line)", 1 if $dry_run;
  0         0  
1413 0         0 my $ln = fmt_str($line);
1414 0         0 my $p = fmt_str($pat);
1415 0         0 fail("$name - pattern \"$p\" should not match any line in error.log but matches line \"$ln\"");
1416             }
1417             }
1418             }
1419             }
1420              
1421 0         0 for my $pat (@$pats) {
1422 0 0       0 next if $found{$pat};
1423 0 0       0 if (defined $pat) {
1424             SKIP: {
1425 0 0       0 skip "$name - no_shutdown_error_log - tests skipped due to $dry_run", 1 if $dry_run;
  0         0  
1426 0         0 my $p = fmt_str($pat);
1427 0         0 pass("$name - pattern \"$p\" does not match a line in error.log");
1428             }
1429             }
1430             }
1431             }
1432              
1433 0   0     0 $lines ||= error_log_data();
1434             #warn "error log data: ", join "\n", @$lines;
1435 0         0 for my $line (@$lines) {
1436 0         0 for my $pat (@$pats) {
1437 0 0       0 next if !defined $pat;
1438              
1439 0 0 0     0 if (ref $pat && $line =~ /$pat/ || $line =~ /\Q$pat\E/) {
      0        
1440             SKIP: {
1441 0 0       0 skip "$name - shutdown_error_log - tests skipped due to dry_run", 1 if $dry_run;
  0         0  
1442 0         0 pass("$name - pattern \"$pat\" matches a line in error.log");
1443             }
1444 0         0 undef $pat;
1445             }
1446             }
1447             }
1448              
1449 0         0 for my $pat (@$pats) {
1450 0 0       0 if (defined $pat) {
1451             SKIP: {
1452 0 0       0 skip "$name - shutdown_error_log - tests skipped due to dry_run", 1 if $dry_run;
  0         0  
1453 0         0 fail("$name - pattern \"$pat\" should match a line in error.log");
1454             #die join("", @$lines);
1455             }
1456             }
1457             }
1458              
1459 0         0 for my $line (@$lines) {
1460             #warn "test $line\n";
1461 0 0       0 if ($line =~ /\bAssertion .*? failed\.$/) {
1462 0         0 my $tb = Test::More->builder;
1463 0         0 $tb->no_ending(1);
1464              
1465 0         0 chomp $line;
1466 0         0 fail("$name - $line");
1467             }
1468             }
1469             }
1470              
1471             sub fmt_str ($) {
1472 0     0 0 0 my $str = shift;
1473 0         0 chomp $str;
1474 0         0 $str =~ s/"/\\"/g;
1475 0         0 $str =~ s/\r/\\r/g;
1476 0         0 $str =~ s/\n/\\n/g;
1477 0         0 $str;
1478             }
1479              
1480             sub transform_response_body ($$$) {
1481 15     15 0 62 my ($block, $res, $req_idx) = @_;
1482              
1483 15 50       22 return unless defined $res;
1484              
1485 15         29 my $content = $res->content;
1486 15 50       155 return unless defined $content;
1487              
1488 15         19 my $is_2d_array = 0;
1489 15         33 my $name = $block->name;
1490 15         31 my $response_body_filters = $block->response_body_filters;
1491              
1492 15 50       32 if (defined $response_body_filters) {
1493              
1494 15 100       38 if (!ref $response_body_filters) {
    100          
1495 4         19 $response_body_filters =~ s/^\s+|\s+$//gs;
1496 4         15 $response_body_filters = [split /\s+/, $response_body_filters];
1497              
1498             } elsif (ref $response_body_filters ne 'ARRAY') {
1499 1         3 $response_body_filters = [$response_body_filters];
1500             }
1501              
1502 15 50       39 if (ref $response_body_filters eq 'ARRAY') {
1503              
1504 15 100       33 if (ref $response_body_filters->[0] eq 'ARRAY') {
1505 8         10 $is_2d_array = 1;
1506              
1507 8         15 for my $elem (@$response_body_filters) {
1508 22 50       39 if (ref $elem ne "ARRAY") {
1509 0         0 bail_out("$name - the --- response_body_filters two-dimensional array "
1510             . "only be like [[uc], [lc]] not [[uc], lc]");
1511             }
1512             }
1513             }
1514             }
1515              
1516 15         21 my $new = $content;
1517 15         17 my $filter = $response_body_filters;
1518              
1519 15 100       32 if ($is_2d_array) {
1520 8         11 $filter = $response_body_filters->[$req_idx];
1521              
1522 8 50       12 bail_out("$name - the ---response_body_filters two-dimensional array "
1523             . "unmatch the specified request($req_idx)") unless defined $filter;
1524             }
1525              
1526 15 50 33     56 if (ref $filter && ref $filter eq 'ARRAY') {
1527              
1528 15         29 for my $f (@$filter) {
1529 20         39 $new = run_filter_helper($block, $f, $new);
1530             }
1531              
1532             } else {
1533 0         0 $new = run_filter_helper($block, $filter, $new);
1534             }
1535              
1536 15         31 $res->content($new);
1537             }
1538              
1539             }
1540              
1541             sub check_response_body ($$$$$$) {
1542 16     16 0 393 my ($block, $res, $dry_run, $req_idx, $repeated_req_idx, $need_array) = @_;
1543 16         41 my $name = $block->name;
1544 16 100 66     50 if ( defined $block->response_body
    50 33        
1545             || defined $block->response_body_eval )
1546             {
1547 9 50       22 my $content = $res ? $res->content : undef;
1548 9 50       100 if ( defined $content ) {
1549 9         17 $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms;
1550 9         13 $content =~ s/^Connection: TE, close\r\n//gms;
1551             }
1552              
1553 9         11 my $expected;
1554 9 50       46 if ( $block->response_body_eval ) {
1555 0         0 diag "$name - response_body_eval is DEPRECATED. Use response_body eval instead.";
1556 0         0 $expected = eval get_indexed_value($name,
1557             $block->response_body_eval,
1558             $req_idx,
1559             $need_array);
1560 0 0       0 if ($@) {
1561 0         0 warn $@;
1562             }
1563             }
1564             else {
1565 9         20 $expected = get_indexed_value($name,
1566             $block->response_body,
1567             $req_idx,
1568             $need_array);
1569             }
1570              
1571 9 50       44 if ( $block->charset ) {
1572 0         0 Encode::from_to( $expected, 'UTF-8', $block->charset );
1573             }
1574              
1575 9 50 33     35 unless (!defined $expected || ref $expected) {
1576 9         16 $expected =~ s/\$ServerPort\b/$ServerPort/g;
1577 9         17 $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g;
1578             }
1579              
1580             #warn show_all_chars($content);
1581              
1582             #warn "no long string: $NoLongString";
1583             SKIP: {
1584 9 50       12 skip "$name - response_body - tests skipped due to $dry_run", 1 if $dry_run;
  9         13  
1585 9 50       15 if (ref $expected) {
1586 0         0 like $content, $expected, "$name - response_body - like (repeated req $repeated_req_idx, req $req_idx)";
1587              
1588             } else {
1589 9 50       15 if ($NoLongString) {
1590 0         0 is( $content, $expected,
1591             "$name - response_body - response is expected (repeated req $repeated_req_idx, req $req_idx)" );
1592             }
1593             else {
1594 9         49 is_string( $content, $expected,
1595             "$name - response_body - response is expected (repeated req $repeated_req_idx, req $req_idx)" );
1596             }
1597             }
1598             }
1599              
1600             } elsif (defined $block->response_body_like
1601             || defined $block->response_body_unlike)
1602             {
1603 7         17 my $patterns;
1604             my $type;
1605 7         0 my $cmp;
1606 7 50       14 if (defined $block->response_body_like) {
1607 7         14 $patterns = $block->response_body_like;
1608 7         12 $type = "like";
1609 7         13 $cmp = \&like;
1610              
1611             } else {
1612 0         0 $patterns = $block->response_body_unlike;
1613 0         0 $type = "unlike";
1614 0         0 $cmp = \&unlike;
1615             }
1616              
1617 7 50       24 my $content = $res ? $res->content : undef;
1618 7 50       81 if ( defined $content ) {
1619 7         19 $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms;
1620 7         10 $content =~ s/^Connection: TE, close\r\n//gms;
1621             }
1622 7         27 my $expected_pat = get_indexed_value($name,
1623             $patterns,
1624             $req_idx,
1625             $need_array);
1626 7         15 $expected_pat =~ s/\$ServerPort\b/$ServerPort/g;
1627 7         11 $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g;
1628 7         23 my $summary = trim($content);
1629 7 50       17 if (!defined $summary) {
1630 0         0 $summary = "";
1631             }
1632              
1633             SKIP: {
1634 7 50       8 skip "$name - response_body_$type - tests skipped due to $dry_run", 1 if $dry_run;
  7         13  
1635 7         105 $cmp->( $content, qr/$expected_pat/s,
1636             "$name - response_body_$type - response is expected ($summary)"
1637             );
1638             }
1639             }
1640              
1641 16         319 for my $check (@ResponseBodyChecks) {
1642 0         0 $check->($block, $res->content, $req_idx, $repeated_req_idx, $dry_run);
1643             }
1644             }
1645              
1646             sub parse_response($$$) {
1647 16     16 0 173 my ( $name, $raw_resp, $head_req ) = @_;
1648              
1649 16         20 my $left;
1650              
1651 16         25 my $raw_headers = '';
1652 16 50       96 if ( $raw_resp =~ /(.*?\r\n)\r\n/s ) {
1653              
1654             #warn "\$1: $1";
1655 16         97 $raw_headers = $1;
1656             }
1657              
1658             #warn "raw headers: $raw_headers\n";
1659              
1660 16         72 my $res = HTTP::Response->parse($raw_resp);
1661              
1662 16         3884 my $code = $res->code;
1663              
1664 16         180 my $enc = $res->header('Transfer-Encoding');
1665 16         728 my $len = $res->header('Content-Length');
1666              
1667 16 50 33     726 if ($code && $code !~ /^\d+$/) {
1668 0         0 undef $code;
1669 0         0 $res->code(undef);
1670             }
1671              
1672 16 50 33     92 if ($code && ($code == 304 || $code == 101)) {
      33        
1673 0         0 return $res, $raw_headers
1674             }
1675              
1676 16 50 33     130 if ( defined $enc && $enc eq 'chunked' ) {
    50 33        
      33        
1677              
1678             #warn "Found chunked!";
1679 0         0 my $raw = $res->content;
1680 0 0       0 if ( !defined $raw ) {
1681 0         0 $raw = '';
1682             }
1683              
1684 0         0 my $decoded = '';
1685 0         0 while (1) {
1686 0 0       0 if ( $raw =~ /\G 0 [\ \t]* \r\n \r\n /gcsx ) {
1687 0 0       0 if ( $raw =~ /\G (.+) /gcsx ) {
1688 0         0 $left = $1;
1689             }
1690              
1691 0         0 last;
1692             }
1693              
1694 0 0       0 if ( $raw =~ m{ \G [\ \t]* ( [A-Fa-f0-9]+ ) [\ \t]* \r\n }gcsx ) {
    0          
1695 0         0 my $rest = hex($1);
1696              
1697             #warn "chunk size: $rest\n";
1698 0         0 my $bit_sz = 32765;
1699 0         0 while ( $rest > 0 ) {
1700 0 0       0 my $bit = $rest < $bit_sz ? $rest : $bit_sz;
1701              
1702             #warn "bit: $bit\n";
1703 0 0       0 if ( $raw =~ /\G(.{$bit})/gcs ) {
1704 0         0 $decoded .= $1;
1705              
1706             #warn "decoded: [$1]\n";
1707              
1708             } else {
1709 0         0 my $tb = Test::More->builder;
1710 0         0 $tb->no_ending(1);
1711              
1712 0         0 fail("$name - invalid chunked data received "
1713             ."(not enought octets for the data section)"
1714             );
1715 0         0 return;
1716             }
1717              
1718 0         0 $rest -= $bit;
1719             }
1720              
1721 0 0       0 if ( $raw !~ /\G\r\n/gcs ) {
1722 0         0 my $tb = Test::More->builder;
1723 0         0 $tb->no_ending(1);
1724              
1725 0         0 fail(
1726             "$name - invalid chunked data received (expected CRLF)."
1727             );
1728 0         0 return;
1729             }
1730              
1731             } elsif ( $raw =~ /\G.+/gcs ) {
1732 0         0 my $tb = Test::More->builder;
1733 0         0 $tb->no_ending(1);
1734              
1735 0         0 fail "$name - invalid chunked body received: $&";
1736 0         0 return;
1737              
1738             } else {
1739 0         0 my $tb = Test::More->builder;
1740 0         0 $tb->no_ending(1);
1741              
1742 0         0 fail "$name - no last chunk found - $raw";
1743 0         0 return;
1744             }
1745             }
1746              
1747             #warn "decoded: $decoded\n";
1748 0         0 $res->content($decoded);
1749              
1750             } elsif (defined $len && $len ne '' && $len >= 0) {
1751 16         46 my $raw = $res->content;
1752 16 50       211 if (length $raw < $len) {
    50          
1753 0 0       0 if (!$head_req) {
1754 0         0 warn "WARNING: $name - response body truncated: ",
1755             "$len expected, but got ", length $raw, "\n";
1756             }
1757              
1758             } elsif (length $raw > $len) {
1759 0         0 my $content = substr $raw, 0, $len;
1760 0         0 $left = substr $raw, $len;
1761 0         0 $res->content($content);
1762             #warn "parsed body: [", $res->content, "]\n";
1763             }
1764             }
1765              
1766 16         51 return ( $res, $raw_headers, $left );
1767             }
1768              
1769             sub send_http2_req ($$$) {
1770 0     0 0 0 my ($block, $req, $timeout) = @_;
1771              
1772 0         0 my $name = $block->name;
1773              
1774 0         0 my $cmd = gen_curl_cmd_from_req($block, $req);
1775              
1776 0 0       0 if ($Test::Nginx::Util::Verbose) {
1777 0         0 warn "running cmd @$cmd";
1778             }
1779              
1780 0         0 my $ok = IPC::Run::run($cmd, \(my $in), \(my $out), \(my $err),
1781             IPC::Run::timeout($timeout));
1782              
1783 0 0       0 if (!defined $ok) {
1784 0   0     0 fail "failed to run curl: $?: " . ($err // '');
1785 0         0 return;
1786             }
1787              
1788 0 0       0 if (!$out) {
1789 0 0       0 if ($err) {
1790 0         0 fail "$name - command \"@$cmd\" generates stderr output: $err";
1791 0         0 return;
1792             }
1793              
1794 0         0 fail "$name - curl command \"@$cmd\" generates no stdout output";
1795 0         0 return;
1796             }
1797              
1798 0 0       0 if ($err) {
1799 0         0 warn "WARNING: $name - command \"@$cmd\" generates stderr output: $err";
1800             }
1801              
1802 0         0 return $out;
1803             }
1804              
1805             sub send_request ($$$$@) {
1806 0     0 0 0 my ( $req, $middle_delay, $timeout, $block, $tries ) = @_;
1807              
1808 0         0 my $name = $block->name;
1809              
1810             #warn "connecting...\n";
1811              
1812 0         0 my $server_addr = $block->server_addr_for_client;
1813              
1814 0 0       0 if (!defined $server_addr) {
1815 0         0 $server_addr = $ServerAddr;
1816             }
1817              
1818 0         0 my $sock = IO::Socket::INET->new(
1819             PeerAddr => $server_addr,
1820             PeerPort => $ServerPortForClient,
1821             Proto => 'tcp',
1822             #ReuseAddr => 1,
1823             #ReusePort => 1,
1824             Blocking => 0,
1825             Timeout => $timeout,
1826             );
1827              
1828 0 0       0 if (!defined $sock) {
1829 0   0     0 $tries ||= 1;
1830 0 0       0 my $total_tries = $TotalConnectingTimeouts ? 20 : 50;
1831 0 0       0 if ($tries <= $total_tries) {
1832 0         0 my $wait = (sleep_time() + sleep_time() * $tries) * $tries / 2;
1833 0 0       0 if ($wait >= 1) {
1834 0         0 $wait = 1;
1835             }
1836              
1837 0 0       0 if (defined $Test::Nginx::Util::ChildPid) {
1838 0         0 my $errcode = $!;
1839 0 0       0 if (waitpid($Test::Nginx::Util::ChildPid, WNOHANG) == -1) {
1840 0         0 warn "WARNING: Child process $Test::Nginx::Util::ChildPid is already gone.\n";
1841 0         0 warn `tail -n20 $Test::Nginx::Util::ErrLogFile`;
1842              
1843 0         0 my $tb = Test::More->builder;
1844 0         0 $tb->no_ending(1);
1845              
1846 0         0 fail("$name - Can't connect to $ServerAddr:$ServerPortForClient: $errcode (aborted)\n");
1847 0         0 return;
1848             }
1849             }
1850              
1851 0 0       0 if ($wait >= 0.6) {
1852 0         0 warn "$name - Can't connect to $ServerAddr:$ServerPortForClient: $!\n";
1853 0 0       0 if ($tries + 1 <= $total_tries) {
1854 0         0 warn "\tRetry connecting after $wait sec\n";
1855             }
1856             }
1857              
1858 0         0 sleep $wait;
1859              
1860             #warn "sending request";
1861 0         0 return send_request($req, $middle_delay, $timeout, $block, $tries + 1);
1862              
1863             }
1864              
1865 0         0 my $msg = "$name - Can't connect to $ServerAddr:$ServerPortForClient: $! (aborted)\n";
1866 0 0       0 if (++$TotalConnectingTimeouts < 3) {
1867 0         0 my $tb = Test::More->builder;
1868 0         0 $tb->no_ending(1);
1869 0         0 fail($msg);
1870              
1871             } else {
1872 0         0 bail_out($msg);
1873             }
1874              
1875 0         0 return;
1876             }
1877              
1878             #warn "connected";
1879              
1880 0 0       0 my @req_bits = ref $req ? @$req : ($req);
1881              
1882 0         0 my $head_req = 0;
1883             {
1884 0         0 my $req = join '', map { $_->{value} } @req_bits;
  0         0  
  0         0  
1885             #warn "Request: $req\n";
1886 0 0       0 if ($req =~ /^\s*HEAD\s+/) {
1887             #warn "Found HEAD request!\n";
1888 0         0 $head_req = 1;
1889             }
1890             }
1891              
1892 0 0       0 if (use_http2($block)) {
1893 0         0 return send_http2_req($block, $req, $timeout), $head_req;
1894             }
1895              
1896             #my $flags = fcntl $sock, F_GETFL, 0
1897             #or die "Failed to get flags: $!\n";
1898              
1899             #fcntl $sock, F_SETFL, $flags | O_NONBLOCK
1900             #or die "Failed to set flags: $!\n";
1901              
1902             my $ctx = {
1903             resp => '',
1904             write_offset => 0,
1905             buf_size => 1024,
1906             req_bits => \@req_bits,
1907 0         0 write_buf => (shift @req_bits)->{"value"},
1908             middle_delay => $middle_delay,
1909             sock => $sock,
1910             name => $name,
1911             block => $block,
1912             };
1913              
1914 0         0 my $readable_hdls = IO::Select->new($sock);
1915 0         0 my $writable_hdls = IO::Select->new($sock);
1916 0         0 my $err_hdls = IO::Select->new($sock);
1917              
1918 0         0 while (1) {
1919 0 0 0     0 if ( $readable_hdls->count == 0
      0        
1920             && $writable_hdls->count == 0
1921             && $err_hdls->count == 0 )
1922             {
1923 0         0 last;
1924             }
1925              
1926             #warn "doing select...\n";
1927              
1928 0         0 my ($new_readable, $new_writable, $new_err) =
1929             IO::Select->select($readable_hdls, $writable_hdls, $err_hdls,
1930             $timeout);
1931              
1932 0 0 0     0 if (!defined $new_err
      0        
1933             && !defined $new_readable
1934             && !defined $new_writable)
1935             {
1936              
1937             # timed out
1938 0         0 timeout_event_handler($ctx);
1939 0         0 last;
1940             }
1941              
1942 0         0 for my $hdl (@$new_err) {
1943 0 0       0 next if !defined $hdl;
1944              
1945 0         0 error_event_handler($ctx);
1946              
1947 0 0       0 if ( $err_hdls->exists($hdl) ) {
1948 0         0 $err_hdls->remove($hdl);
1949             }
1950              
1951 0 0       0 if ( $readable_hdls->exists($hdl) ) {
1952 0         0 $readable_hdls->remove($hdl);
1953             }
1954              
1955 0 0       0 if ( $writable_hdls->exists($hdl) ) {
1956 0         0 $writable_hdls->remove($hdl);
1957             }
1958              
1959 0         0 for my $h (@$readable_hdls) {
1960 0 0       0 next if !defined $h;
1961 0 0       0 if ( $h eq $hdl ) {
1962 0         0 undef $h;
1963 0         0 last;
1964             }
1965             }
1966              
1967 0         0 for my $h (@$writable_hdls) {
1968 0 0       0 next if !defined $h;
1969 0 0       0 if ( $h eq $hdl ) {
1970 0         0 undef $h;
1971 0         0 last;
1972             }
1973             }
1974              
1975 0         0 close $hdl;
1976             }
1977              
1978 0         0 for my $hdl (@$new_readable) {
1979 0 0       0 next if !defined $hdl;
1980              
1981 0         0 my $res = read_event_handler($ctx);
1982 0 0       0 if ( !$res ) {
1983              
1984             # error occured
1985 0 0       0 if ( $err_hdls->exists($hdl) ) {
1986 0         0 $err_hdls->remove($hdl);
1987             }
1988              
1989 0 0       0 if ( $readable_hdls->exists($hdl) ) {
1990 0         0 $readable_hdls->remove($hdl);
1991             }
1992              
1993 0 0       0 if ( $writable_hdls->exists($hdl) ) {
1994 0         0 $writable_hdls->remove($hdl);
1995             }
1996              
1997 0         0 for my $h (@$writable_hdls) {
1998 0 0       0 next if !defined $h;
1999 0 0       0 if ( $h eq $hdl ) {
2000 0         0 undef $h;
2001 0         0 last;
2002             }
2003             }
2004              
2005 0         0 close $hdl;
2006             }
2007             }
2008              
2009 0         0 for my $hdl (@$new_writable) {
2010 0 0       0 next if !defined $hdl;
2011              
2012 0         0 my $res = write_event_handler($ctx);
2013 0 0       0 if ( !$res ) {
    0          
2014              
2015             # error occured
2016 0 0       0 if ( $err_hdls->exists($hdl) ) {
2017 0         0 $err_hdls->remove($hdl);
2018             }
2019              
2020 0 0       0 if ( $readable_hdls->exists($hdl) ) {
2021 0         0 $readable_hdls->remove($hdl);
2022             }
2023              
2024 0 0       0 if ( $writable_hdls->exists($hdl) ) {
2025 0         0 $writable_hdls->remove($hdl);
2026             }
2027              
2028 0         0 close $hdl;
2029              
2030             } elsif ( $res == 2 ) {
2031             # all data has been written
2032              
2033 0         0 my $shutdown = $block->shutdown;
2034 0 0       0 if (defined $shutdown) {
2035 0 0       0 if ($shutdown =~ /^$/s) {
2036 0         0 $shutdown = 1;
2037             }
2038              
2039             #warn "shutting down with $shutdown";
2040 0         0 shutdown($sock, $shutdown);
2041             }
2042              
2043 0 0       0 if ( $writable_hdls->exists($hdl) ) {
2044 0         0 $writable_hdls->remove($hdl);
2045             }
2046             }
2047             }
2048             }
2049              
2050 0         0 return ($ctx->{resp}, $head_req);
2051             }
2052              
2053             sub timeout_event_handler ($) {
2054 0     0 0 0 my $ctx = shift;
2055              
2056 0         0 close($ctx->{sock});
2057              
2058 0 0       0 if (!defined $ctx->{block}->abort) {
2059 0         0 my $tb = Test::More->builder;
2060 0         0 $tb->no_ending(1);
2061              
2062 0         0 fail("ERROR: client socket timed out - $ctx->{name}\n");
2063              
2064             } else {
2065 0         0 sleep 0.005;
2066             }
2067             }
2068              
2069             sub error_event_handler ($) {
2070 0     0 0 0 warn "exception occurs on the socket: $!\n";
2071             }
2072              
2073             sub write_event_handler ($) {
2074 0     0 0 0 my ($ctx) = @_;
2075              
2076 0         0 while (1) {
2077 0 0       0 return undef if !defined $ctx->{write_buf};
2078              
2079 0         0 my $rest = length( $ctx->{write_buf} ) - $ctx->{write_offset};
2080              
2081             #warn "offset: $write_offset, rest: $rest, length ", length($write_buf), "\n";
2082             #die;
2083              
2084 0 0       0 if ( $rest > 0 ) {
2085 0         0 my $bytes;
2086 0         0 eval {
2087             $bytes = syswrite(
2088             $ctx->{sock}, $ctx->{write_buf},
2089             $rest, $ctx->{write_offset}
2090 0         0 );
2091             };
2092              
2093 0 0       0 if ($@) {
2094 0         0 my $errmsg = "write failed: $@";
2095 0         0 warn "$errmsg\n";
2096 0         0 $ctx->{resp} = $errmsg;
2097 0         0 return undef;
2098             }
2099              
2100 0 0       0 if ( !defined $bytes ) {
2101 0 0       0 if ( $! == EAGAIN ) {
2102              
2103             #warn "write again...";
2104             #sleep 0.002;
2105 0         0 return 1;
2106             }
2107 0         0 my $errmsg = "write failed: $!";
2108 0         0 warn "$errmsg\n";
2109 0 0       0 if ( !$ctx->{resp} ) {
2110 0         0 $ctx->{resp} = "$errmsg";
2111             }
2112 0         0 return undef;
2113             }
2114              
2115             #warn "wrote $bytes bytes.\n";
2116 0         0 $ctx->{write_offset} += $bytes;
2117              
2118             } else {
2119             # $rest == 0
2120              
2121 0         0 my $next_send = shift @{ $ctx->{req_bits} };
  0         0  
2122              
2123 0 0       0 if (!defined $next_send) {
2124 0         0 return 2;
2125             }
2126              
2127 0         0 $ctx->{write_buf} = $next_send->{'value'};
2128 0         0 $ctx->{write_offset} = 0;
2129              
2130 0         0 my $wait_time;
2131              
2132 0 0       0 if (!defined $next_send->{'delay_before'}) {
2133 0 0       0 if (defined $ctx->{middle_delay}) {
2134 0         0 $wait_time = $ctx->{middle_delay};
2135             }
2136              
2137             } else {
2138 0         0 $wait_time = $next_send->{'delay_before'};
2139             }
2140              
2141 0 0       0 if ($wait_time) {
2142             #warn "sleeping..";
2143 0         0 sleep $wait_time;
2144             }
2145             }
2146             }
2147              
2148             # impossible to reach here...
2149 0         0 return undef;
2150             }
2151              
2152             sub read_event_handler ($) {
2153 0     0 0 0 my ($ctx) = @_;
2154 0         0 while (1) {
2155 0         0 my $read_buf;
2156 0         0 my $bytes = sysread( $ctx->{sock}, $read_buf, $ctx->{buf_size} );
2157              
2158 0 0       0 if ( !defined $bytes ) {
2159 0 0       0 if ( $! == EAGAIN ) {
2160              
2161             #warn "read again...";
2162             #sleep 0.002;
2163 0         0 return 1;
2164             }
2165 0         0 warn "WARNING: $ctx->{name} - HTTP response read failure: $!";
2166 0         0 return undef;
2167             }
2168              
2169 0 0       0 if ( $bytes == 0 ) {
2170 0         0 return undef; # connection closed
2171             }
2172              
2173 0         0 $ctx->{resp} .= $read_buf;
2174              
2175             #warn "read $bytes ($read_buf) bytes.\n";
2176             }
2177              
2178             # impossible to reach here...
2179 0         0 return undef;
2180             }
2181              
2182             sub gen_curl_cmd_from_req ($$) {
2183 0     0 0 0 my ($block, $req) = @_;
2184              
2185 0         0 my $name = $block->name;
2186              
2187 0         0 $req = join '', map { $_->{value} } @$req;
  0         0  
2188              
2189             #use JSON::XS;
2190             #warn "Req: ", JSON::XS->new->encode([$req]), "\n";
2191              
2192 0         0 my ($meth, $uri, $http_ver);
2193 0 0       0 if ($req =~ m{^\s*(\w+)\s+(\S+)\s+HTTP/(\S+)\r?\n}smig) {
    0          
2194 0         0 ($meth, $uri, $http_ver) = ($1, $2, $3);
2195              
2196             } elsif ($req =~ m{^\s*(\w+)\s+(.*\S)\r?\n}smig) {
2197 0         0 ($meth, $uri) = ($1, $2);
2198 0         0 $http_ver = '0.9';
2199              
2200             } else {
2201 0         0 bail_out "$name - cannot parse the status line in the request: $req";
2202             }
2203              
2204 0         0 my @args = ('curl', '-i');
2205              
2206 0 0       0 if ($Test::Nginx::Util::Verbose) {
2207 0         0 push @args, "-vv";
2208              
2209             } else {
2210 0         0 push @args, '-sS';
2211             }
2212              
2213 0 0       0 if (use_http2($block)) {
2214 0         0 push @args, '--http2', '--http2-prior-knowledge';
2215             }
2216              
2217 0 0       0 if ($meth eq 'HEAD') {
2218 0         0 push @args, '-I';
2219              
2220             } else {
2221 0         0 push @args, "-X", $meth;
2222             }
2223              
2224 0 0       0 if ($http_ver ne '1.1') {
2225             # HTTP 1.0 or HTTP 0.9
2226 0         0 push @args, '-0';
2227             }
2228              
2229 0         0 my @headers;
2230 0 0       0 if ($http_ver ge '1.0') {
2231 0 0       0 if ($req =~ m{\G(.*?)\r?\n\r?\n}gcs) {
2232 0         0 my $headers = $1;
2233             #warn "raw headers: $headers\n";
2234             @headers = grep {
2235 0   0     0 !/^Connection\s*:/i
  0         0  
2236             && !/^Host: \Q$ServerName\E$/i
2237             && !/^Content-Length\s*:/i
2238             } split /\r\n/, $headers;
2239              
2240             } else {
2241 0         0 bail_out "cannot parse the header entries in the request: $req";
2242             }
2243             }
2244              
2245             #warn "headers: @headers ", scalar(@headers), "\n";
2246              
2247 0         0 my $found_content_type;
2248              
2249 0         0 for my $h (@headers) {
2250             #warn "h: $h\n";
2251 0 0       0 if ($h =~ /^\s*User-Agent\s*:\s*(.*\S)/i) {
2252 0         0 push @args, '-A', $1;
2253              
2254             } else {
2255 0 0       0 if ($h =~ /^\s*Content-Type\s*:/i) {
2256 0         0 $found_content_type = 1;
2257             }
2258              
2259 0         0 push @args, '-H', $h;
2260             }
2261             }
2262              
2263 0 0       0 if ($req =~ m{\G(.+)}gcsm) {
2264             #warn "!! POST body data len: ", length($1);
2265 0 0       0 if (!$found_content_type) {
2266 0         0 push @args, "-H", 'Content-Type: ';
2267             }
2268 0         0 push @args, '--data-binary', $1;
2269             }
2270              
2271 0         0 my $timeout = $block->timeout;
2272 0 0       0 if (!$timeout) {
2273 0         0 $timeout = timeout();
2274             }
2275              
2276 0         0 push @args, '--connect-timeout', $timeout;
2277              
2278 0         0 my $link;
2279             {
2280 0         0 my $server = $ServerAddr;
  0         0  
2281 0         0 my $port = $ServerPortForClient;
2282 0         0 $link = "http://$server:$port$uri";
2283             }
2284              
2285 0         0 push @args, $link;
2286              
2287 0         0 return \@args;
2288             }
2289              
2290             sub gen_ab_cmd_from_req ($$@) {
2291 0     0 0 0 my ($block, $req, $nreqs, $concur) = @_;
2292              
2293 0   0     0 $nreqs ||= 100000;
2294 0   0     0 $concur ||= 2;
2295              
2296 0 0       0 if ($nreqs < $concur) {
2297 0         0 $concur = $nreqs;
2298             }
2299              
2300 0         0 my $name = $block->name;
2301              
2302 0         0 $req = join '', map { $_->{value} } @$req;
  0         0  
2303              
2304             #use JSON::XS;
2305             #warn "Req: ", JSON::XS->new->encode([$req]), "\n";
2306              
2307 0         0 my ($meth, $uri, $http_ver);
2308 0 0       0 if ($req =~ m{^\s*(\w+)\s+(\S+)\s+HTTP/(\S+)\r?\n}smig) {
    0          
2309 0         0 ($meth, $uri, $http_ver) = ($1, $2, $3);
2310              
2311             } elsif ($req =~ m{^\s*(\w+)\s+(.*\S)\r?\n}smig) {
2312 0         0 ($meth, $uri) = ($1, $2);
2313 0         0 $http_ver = '0.9';
2314              
2315             } else {
2316 0         0 bail_out "$name - cannot parse the status line in the request: $req";
2317             }
2318              
2319             #warn "HTTP version: $http_ver\n";
2320              
2321 0         0 my @opts = ("-c$concur", '-k', "-n$nreqs");
2322              
2323 0         0 my $prog;
2324 0 0 0     0 if ($http_ver eq '1.1' && $meth eq 'GET') {
2325 0         0 $prog = 'weighttp';
2326              
2327             } else {
2328             # HTTP 1.0 or HTTP 0.9
2329 0         0 $prog = 'ab';
2330 0         0 unshift @opts, '-r', '-d', '-S';
2331             }
2332              
2333 0         0 my @headers;
2334 0 0       0 if ($http_ver ge '1.0') {
2335 0 0       0 if ($req =~ m{\G(.*?)\r?\n\r?\n}gcs) {
2336 0         0 my $headers = $1;
2337             #warn "raw headers: $headers\n";
2338             @headers = grep {
2339 0   0     0 !/^Connection\s*:/i
  0         0  
2340             && !/^Host: \Q$ServerName\E$/i
2341             && !/^Content-Length\s*:/i
2342             } split /\r\n/, $headers;
2343              
2344             } else {
2345 0         0 bail_out "cannot parse the header entries in the request: $req";
2346             }
2347             }
2348              
2349             #warn "headers: @headers ", scalar(@headers), "\n";
2350              
2351 0         0 for my $h (@headers) {
2352             #warn "h: $h\n";
2353 0 0 0     0 if ($prog eq 'ab' && $h =~ /^\s*Content-Type\s*:\s*(.*\S)/i) {
2354 0         0 my $type = $1;
2355 0         0 push @opts, '-T', $type;
2356              
2357             } else {
2358 0         0 push @opts, '-H', $h;
2359             }
2360             }
2361              
2362 0         0 my $bodyfile;
2363              
2364 0 0 0     0 if ($req =~ m{\G.+}gcs || $meth eq 'POST' || $meth eq 'PUT') {
      0        
2365 0         0 my $body = $&;
2366              
2367 0 0       0 if (!defined $body) {
2368 0         0 $body = '';
2369             }
2370              
2371 0         0 my ($out, $bodyfile) = tempfile("bodyXXXXXXX", UNLINK => 1,
2372             SUFFIX => '.temp', TMPDIR => 1);
2373 0         0 print $out $body;
2374 0         0 close $out;
2375              
2376 0 0       0 if ($meth eq 'PUT') {
    0          
    0          
2377 0         0 push @opts, '-u', $bodyfile;
2378              
2379             } elsif ($meth eq 'POST') {
2380 0         0 push @opts, '-p', $bodyfile;
2381              
2382             } elsif ($meth eq 'GET') {
2383 0         0 warn "WARNING: method $meth not supported for ab when taking a request body\n";
2384              
2385             } else {
2386 0         0 warn "WARNING: method $meth not supported for ab when taking a request body\n";
2387 0         0 $meth = 'PUT';
2388 0         0 push @opts, '-p', $bodyfile;
2389             }
2390             }
2391              
2392 0 0       0 if ($meth eq 'HEAD') {
2393 0         0 unshift @opts, '-i';
2394             }
2395              
2396 0         0 my $link;
2397             {
2398 0         0 my $server = $ServerAddr;
  0         0  
2399 0         0 my $port = $ServerPortForClient;
2400 0         0 $link = "http://$server:$port$uri";
2401             }
2402              
2403 0         0 my @cmd = ($prog, @opts, $link);
2404              
2405 0 0       0 if ($Test::Nginx::Util::Verbose) {
2406 0         0 warn "command: @cmd\n";
2407             }
2408              
2409 0         0 return \@cmd;
2410             }
2411              
2412             sub get_linear_regression_slope ($) {
2413 0     0 0 0 my $list = shift;
2414              
2415 0         0 my $n = @$list;
2416 0         0 my $avg_x = ($n + 1) / 2;
2417 0         0 my $avg_y = sum(@$list) / $n;
2418              
2419 0         0 my $x = 0;
2420 0         0 my $avg_xy = sum(map { $x++; $x * $_ } @$list) / $n;
  0         0  
  0         0  
2421 0         0 my $avg_x2 = sum(map { $_ * $_ } 1 .. $n) / $n;
  0         0  
2422 0         0 my $denom = $avg_x2 - $avg_x * $avg_x;
2423 0 0       0 if ($denom == 0) {
2424 0         0 return 'Inf';
2425             }
2426 0         0 my $k = ($avg_xy - $avg_x * $avg_y) / $denom;
2427 0         0 return sprintf("%.01f", $k);
2428             }
2429              
2430             1;
2431             __END__