File Coverage

blib/lib/Test/Nginx/Socket.pm

Criterion	Covered	Total	%
statement	324	1070	30.2
branch	112	574	19.5
condition	25	185	13.5
subroutine	34	53	64.1
pod	1	30	3.3
total	496	1912	25.9

package Test::Nginx::Socket;

use lib 'lib';
use lib 'inc';

use Test::Base -Base;

our $VERSION = '0.26';

use POSIX qw( SIGQUIT SIGKILL SIGTERM SIGHUP );
use Encode;
#use Data::Dumper;
use Time::HiRes qw(sleep time);
use Test::LongString;
use List::MoreUtils qw( any );
use List::Util qw( sum );
use IO::Select ();
use File::Temp qw( tempfile );
use Digest::MD5 ();
use Digest::SHA ();
use POSIX ":sys_wait_h";

use Test::Nginx::Util;

#use Smart::Comments::JSON '###';
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use POSIX qw(EAGAIN);
use IO::Socket;

#our ($PrevRequest, $PrevConfig);

our @EXPORT = qw( env_to_nginx is_str plan run_tests run_test
  repeat_each config_preamble worker_connections
  master_process_enabled
  no_long_string workers master_on master_off
  log_level no_shuffle no_root_location
  server_name
  server_addr server_root html_dir server_port server_port_for_client
  timeout no_nginx_manager check_accum_error_log
  add_block_preprocessor bail_out add_cleanup_handler
  add_response_body_check
);

our $TotalConnectingTimeouts = 0;
our $PrevNginxPid;

sub send_request ($$$$@);

sub run_filter_helper($$$);
sub run_test_helper ($$);
sub test_stap ($$);

sub error_event_handler ($);
sub read_event_handler ($);
sub write_event_handler ($);
sub transform_response_body ($$$);
sub check_response_body ($$$$$$);
sub fmt_str ($);
sub gen_ab_cmd_from_req ($$@);
sub gen_curl_cmd_from_req ($$);
sub get_linear_regression_slope ($);
sub value_contains ($$);

$RunTestHelper = \&run_test_helper;
$CheckErrorLog = \&check_error_log;

sub set_http_config_filter ($) {
    $FilterHttpConfig = shift;
}

our @ResponseBodyChecks;

sub add_response_body_check ($) {
    push @ResponseBodyChecks, shift;
}

#  This will parse a "request"" string. The expected format is:
# - One line for the HTTP verb (POST, GET, etc.) plus optional relative URL
#   (default is /) plus optional HTTP version (default is HTTP/1.1).
# - More lines considered as the body of the request.
# Most people don't care about headers and this is enough.
#
#  This function will return a reference to a hash with the parsed elements
# plus information on the parsing itself like "how many white spaces were
# skipped before the VERB" (skipped_before_method), "was the version provided"
# (http_ver_size = 0).
sub parse_request ($$) {
    my ( $name, $rrequest ) = @_;
    open my $in, '<', $rrequest;
    my $first = <$in>;
    if ( !$first ) {
        bail_out("$name - Request line should be non-empty");
    }
    #$first =~ s/^\s+|\s+$//gs;
    my ($before_meth, $meth, $after_meth);
    my ($rel_url, $rel_url_size, $after_rel_url);
    my ($http_ver, $http_ver_size, $after_http_ver);
    my $end_line_size;
    if ($first =~ /^(\s*)(\S+)( *)((\S+)( *))?((\S+)( *))?(\s*)$/) {
        $before_meth = defined $1 ? length($1) : undef;
        $meth = $2;
        $after_meth = defined $3 ? length($3) : undef;
        $rel_url = $5;
        $rel_url_size = defined $5 ? length($5) : undef;
        $after_rel_url = defined $6 ? length($6) : undef;
        $http_ver = $8;
        if (!defined $8) {
            $http_ver_size = undef;
        } else {
            $http_ver_size = defined $8 ? length($8) : undef;
        }
        if (!defined $9) {
            $after_http_ver = undef;
        } else {
            $after_http_ver = defined $9 ? length($9) : undef;
        }
        $end_line_size = defined $10 ? length($10) : undef;
    } else {
        bail_out("$name - Request line is not valid. Should be 'meth [url [version]]' but got \"$first\".");
    }
    if ( !defined $rel_url ) {
        $rel_url = '/';
        $rel_url_size = 0;
        $after_rel_url = 0;
    }
    if ( !defined $http_ver ) {
        $http_ver = 'HTTP/1.1';
        $http_ver_size = 0;
        $after_http_ver = 0;
    }

    #my $url = "http://localhost:$ServerPortForClient" . $rel_url;

    my $content = do { local $/; <$in> };
    my $content_size;
    if ( !defined $content ) {
        $content = "";
        $content_size = 0;
    } else {
        $content_size = length($content);
    }

    #warn Dumper($content);

    close $in;

    return {
        method  => $meth,
        url     => $rel_url,
        content => $content,
        http_ver => $http_ver,
        skipped_before_method => $before_meth,
        method_size => length($meth),
        skipped_after_method => $after_meth,
        url_size => $rel_url_size,
        skipped_after_url => $after_rel_url,
        http_ver_size => $http_ver_size,
        skipped_after_http_ver => $after_http_ver + $end_line_size,
        content_size => $content_size,
    };
}

# From a parsed request, builds the "moves" to apply to the original request
# to transform it (e.g. add missing version). Elements of the returned array
# are of 2 types:
# - d : number of characters to remove.
# - s_* : number of characters (s_s) to replace by value (s_v).
sub get_moves($) {
    my ($parsed_req) = @_;
    return ({d => $parsed_req->{skipped_before_method}},
                          {s_s => $parsed_req->{method_size},
                           s_v => $parsed_req->{method}},
                          {d => $parsed_req->{skipped_after_method}},
                          {s_s => $parsed_req->{url_size},
                           s_v => $parsed_req->{url}},
                          {d => $parsed_req->{skipped_after_url}},
                          {s_s => $parsed_req->{http_ver_size},
                           s_v => $parsed_req->{http_ver}},
                          {d => $parsed_req->{skipped_after_http_ver}},
                          {s_s => 0,
                           s_v => $parsed_req->{headers}},
                          {s_s => $parsed_req->{content_size},
                           s_v => $parsed_req->{content}}
                         );
}

#  Apply moves (see above) to an array of packets that correspond to a request.
# The use of this function is explained in the build_request_from_packets
# function.
sub apply_moves($$) {
    my ($r_packet, $r_move) = @_;
    my $current_packet = shift @$r_packet;
    my $current_move = shift @$r_move;
    my $in_packet_cursor = 0;
    my @result = ();
    while (defined $current_packet) {
        if (!defined $current_move) {
            push @result, $current_packet;
            $current_packet = shift @$r_packet;
            $in_packet_cursor = 0;
        } elsif (defined $current_move->{d}) {
            # Remove stuff from packet
            if ($current_move->{d} > length($current_packet) - $in_packet_cursor) {
                # Eat up what is left of packet.
                $current_move->{d} -= length($current_packet) - $in_packet_cursor;
                if ($in_packet_cursor > 0) {
                    # Something in packet from previous iteration.
                    push @result, $current_packet;
                }
                $current_packet = shift @$r_packet;
                $in_packet_cursor = 0;
            } else {
                # Remove from current point in current packet
                substr($current_packet, $in_packet_cursor, $current_move->{d}) = '';
                $current_move = shift @$r_move;
            }
        } else {
            # Substitute stuff
            if ($current_move->{s_s} > length($current_packet) - $in_packet_cursor) {
                #   {s_s=>3, s_v=>GET} on ['GE', 'T /foo']
                $current_move->{s_s} -= length($current_packet) - $in_packet_cursor;
                substr($current_packet, $in_packet_cursor) = substr($current_move->{s_v}, 0, length($current_packet) - $in_packet_cursor);
                push @result, $current_packet;
                $current_move->{s_v} = substr($current_move->{s_v}, length($current_packet) - $in_packet_cursor);
                $current_packet = shift @$r_packet;
                $in_packet_cursor = 0;
            } else {
                substr($current_packet, $in_packet_cursor, $current_move->{s_s}) = $current_move->{s_v};
                $in_packet_cursor += length($current_move->{s_v});
                $current_move = shift @$r_move;
            }
        }
    }
    return \@result;
}
#  Given a request as an array of packets, will parse it, append the appropriate
# headers and return another array of packets.
#  The function implemented here can be high-level summarized as:
#   1 - Concatenate all packets to obtain a string representation of request.
#   2 - Parse the string representation
#   3 - Get the "moves" from the parsing
#   4 - Apply the "moves" to the packets.
sub build_request_from_packets($$$$$) {
    my ( $name, $more_headers, $is_chunked, $conn_header, $request_packets ) = @_;
    # Concatenate packets as a string
    my $parsable_request = '';
    my @packet_length;
    for my $one_packet (@$request_packets) {
        $parsable_request .= $one_packet;
        push @packet_length, length($one_packet);
    }
    #  Parse the string representation.
    my $parsed_req = parse_request( $name, \$parsable_request );

    # Append headers
    my $len_header = '';
    if (   !$is_chunked
        && defined $parsed_req->{content}
        && $parsed_req->{content} ne ''
        && $more_headers !~ /(?:^|\n)Content-Length:/ )
    {
        $parsed_req->{content} =~ s/^\s+|\s+$//gs;

        $len_header .=
          "Content-Length: " . length( $parsed_req->{content} ) . "\r\n";
    }

    $more_headers =~ s/(?

    my $headers = '';

    if ($more_headers !~ /(?:^|\n)Host:/msi) {
        $headers .= "Host: $ServerName\r\n";
    }

    if ($more_headers !~ /(?:^|\n)Connection/msi) {
        $headers .= "Connection: $conn_header\r\n";
    }

    $headers .= "$more_headers$len_header\r\n";

    $parsed_req->{method} .= ' ';
    $parsed_req->{url} .= ' ';
    $parsed_req->{http_ver} .= "\r\n";
    $parsed_req->{headers} = $headers;

    #  Get the moves from parsing
    my @elements_moves = get_moves($parsed_req);
    # Apply them to the packets.
    return apply_moves($request_packets, \@elements_moves);
}

sub parse_more_headers ($) {
    my ($in) = @_;
    my @headers = split /\n+/, $in;
    my $is_chunked;
    my $out = '';
    for my $header (@headers) {
        next if $header =~ /^\s*\#/;
        #warn "HEADER: $header";
        my ($key, $val) = split /:\s*/, $header, 2;
        if (!defined $val) {
            $val = '';
        }
        if (lc($key) eq 'transfer-encoding' and $val eq 'chunked') {
            $is_chunked = 1;
        }

        #warn "[$key, $val]\n";
        $out .= "$key: $val\r\n";
    }
    return $out, $is_chunked;
}

#  Returns an array of array of hashes from the block. Each element of
# the first-level array is a request.
#  Each request is an array of the "packets" to be sent. Each packet is a
# string to send, with an (optionnal) delay before sending it.
#  This function parses (and therefore defines the syntax) of "request*"
# sections. See documentation for supported syntax.
sub get_req_from_block ($) {
    my ($block) = @_;
    my $name = $block->name;

    my @req_list = ();

    if (defined $block->raw_request) {

        # Should be deprecated.
        if (ref $block->raw_request && ref $block->raw_request eq 'ARRAY') {

            #  User already provided an array. So, he/she specified where the
            # data should be split. This allows for backward compatibility but
            # should use request with arrays as it provides the same functionnality.
            my @rr_list = ();
            for my $elt (@{ $block->raw_request }) {
                push @rr_list, {value => $elt};
            }
            push @req_list, \@rr_list;

        } else {
            push @req_list, [{value => $block->raw_request}];
        }

    } else {
        my $request;
        if (defined $block->request_eval) {

            diag "$name - request_eval DEPRECATED. Use request eval instead.";
            $request = eval $block->request_eval;
            if ($@) {
                warn $@;
            }

        } else {
            $request = $block->request;
            if (defined $request) {
                while ($request =~ s/^\s*\#[^\n]+\s+|^\s+//gs) {
                   # do nothing
                }
            }
            #warn "my req: $request";
        }

        my $more_headers = $block->more_headers || '';

        if ( $block->pipelined_requests ) {
            my $reqs = $block->pipelined_requests;
            if (!ref $reqs || ref $reqs ne 'ARRAY') {
                bail_out(
                    "$name - invalid entries in --- pipelined_requests");
            }
            my $i = 0;
            my $prq = "";
            for my $request (@$reqs) {
                my $conn_type;
                if ($i == @$reqs - 1) {
                    $conn_type = 'close';

                } else {
                    $conn_type = 'keep-alive';
                }

                my ($hdr, $is_chunked);
                if (ref $more_headers eq 'ARRAY') {
                    #warn "Found ", scalar @$more_headers, " entries in --- more_headers.";
                    $hdr = $more_headers->[$i];
                    if (!defined $hdr) {
                        bail_out("--- more_headers lacks data for the $i pipelined request");
                    }
                    ($hdr, $is_chunked) = parse_more_headers($hdr);
                    #warn "more headers: $hdr";

                } else {
                    ($hdr, $is_chunked)  = parse_more_headers($more_headers);
                }

                my $r_br = build_request_from_packets($name, $hdr,
                                      $is_chunked, $conn_type,
                                      [$request] );
                $prq .= $$r_br[0];
                $i++;
            }
            push @req_list, [{value =>$prq}];

        } else {
            my ($is_chunked, $hdr);

            # request section.
            if (!ref $request) {
                if (ref $more_headers eq 'ARRAY') {
                    #warn "Found ", scalar @$more_headers, " entries in --- more_headers.";
                    $hdr = $more_headers->[0];
                    if (!defined $hdr) {
                        bail_out("--- more_headers lacks data for the request");
                    }
                    ($hdr, $is_chunked) = parse_more_headers($hdr);
                    #warn "more headers: $hdr";

                } else {
                    ($hdr, $is_chunked)  = parse_more_headers($more_headers);
                }

                # One request and it is a good old string.
                my $r_br = build_request_from_packets($name, $hdr,
                                                      $is_chunked, 'close',
                                                      [$request] );
                push @req_list, [{value => $$r_br[0]}];

            } elsif (ref $request eq 'ARRAY') {
                # A bunch of requests...
                my $i = 0;
                for my $one_req (@$request) {

                    if (ref $more_headers eq 'ARRAY') {
                        #warn "Found ", scalar @$more_headers, " entries in --- more_headers.";
                        $hdr = $more_headers->[$i];
                        if (!defined $hdr) {
                            bail_out("--- more_headers lacks data for the "
                                     . "${i}th request");
                        }
                        ($hdr, $is_chunked) = parse_more_headers($hdr);
                        #warn "more headers: $hdr";

                    } else {
                        ($hdr, $is_chunked)  = parse_more_headers($more_headers);
                    }

                    if (!ref $one_req) {
                        # This request is a good old string.
                        my $r_br = build_request_from_packets($name, $hdr,
                                                      $is_chunked, 'close',
                                                      [$one_req] );
                        push @req_list, [{value => $$r_br[0]}];

                    } elsif (ref $one_req eq 'ARRAY') {
                        # Request expressed as a serie of packets
                        my @packet_array = ();
                        for my $one_packet (@$one_req) {
                            if (!ref $one_packet) {
                                # Packet is a string.
                                push @packet_array, $one_packet;
                            } elsif (ref $one_packet eq 'HASH'){
                                # Packet is a hash with a value...
                                push @packet_array, $one_packet->{value};
                            } else {
                                bail_out "$name - Invalid syntax. $one_packet should be a string or hash with value.";
                            }
                        }

                        my $transformed_packet_array = build_request_from_packets($name, $hdr,
                                                   $is_chunked, 'close',
                                                   \@packet_array);
                        my @transformed_req = ();
                        my $idx = 0;
                        for my $one_transformed_packet (@$transformed_packet_array) {
                            if (!ref $$one_req[$idx]) {
                                push @transformed_req, {value => $one_transformed_packet};
                            } else {
                                # Is a HASH (checked above as $one_packet)
                                $$one_req[$idx]->{value} = $one_transformed_packet;
                                push @transformed_req, $$one_req[$idx];
                            }
                            $idx++;
                        }
                        push @req_list, \@transformed_req;

                    } else {
                        bail_out "$name - Invalid syntax. $one_req should be a string or an array of packets.";
                    }

                    $i++;
                }

            } else {
                bail_out(
                    "$name - invalid ---request : MUST be string or array of requests");
            }
        }

    }
    return \@req_list;
}

sub quote_sh_args ($) {
    my ($args) = @_;
    for my $arg (@$args) {
       if ($arg =~ m{^[- "&%;,|?*.+=\w:/()]*$}) {
          if ($arg =~ /[ "&%;,|?*()]/) {
             $arg = "'$arg'";
          }
          next;
       }
       $arg =~ s/\\/\\\\/g;
       $arg =~ s/'/\\'/g;
       $arg =~ s/\n/\\n/g;
       $arg =~ s/\r/\\r/g;
       $arg =~ s/\t/\\t/g;
       $arg = "\$'$arg'";
    }
    return "@$args";
}

sub run_filter_helper($$$) {
    my ($block, $filter, $content) = @_;

    my $name = $block->name;

    if (ref $filter && ref $filter eq 'CODE') {
        $content = $filter->($content);

    } elsif (!ref $filter) {

        for ($filter) {
            if ($_ eq 'md5_hex') {
                $content = Digest::MD5::md5_hex($content);
            } elsif ($_ eq 'sha1_hex') {
                $content = Digest::SHA::sha1_hex($content);
            } elsif ($_ eq 'uc') {
                $content = uc($content);
            } elsif ($_ eq 'lc') {
                $content = lc($content);
            } elsif ($_ eq 'ucfirst') {
                $content = ucfirst($content);
            } elsif ($_ eq 'lcfirst') {
                $content = lcfirst($content);
            } elsif ($_ eq 'length') {
                $content = length($content);
            } else {
                bail_out("$name - unknown filter, \"$filter\", "
                         . "specified in the --- response_body_filters section");
            }
        }

    } else {
        bail_out("$name - the --- response_body_filters section "
                 . "only supports subroutine reference values and string values");
    }

    return $content;
}

sub run_test_helper ($$) {
    my ($block, $dry_run, $repeated_req_idx) = @_;

    #warn "repeated req idx: $repeated_req_idx";

    my $name = $block->name;

    my $r_req_list = get_req_from_block($block);

    if ( $#$r_req_list < 0 ) {
        bail_out("$name - request empty");
    }

    if (defined $block->curl) {
        my $req = $r_req_list->[0];
        my $cmd = gen_curl_cmd_from_req($block, $req);
        warn "# ", quote_sh_args($cmd), "\n";
    }

    if ($CheckLeak) {
        $dry_run = "the \"check leak\" testing mode";
    }

    if ($Benchmark) {
        $dry_run = "the \"benchmark\" testing mode";
    }

    if ($Benchmark && !defined $block->no_check_leak) {
        warn "$name\n";

        my $req = $r_req_list->[0];
        my ($nreqs, $concur);
        if ($Benchmark =~ /^\s*(\d+)(?:\s+(\d+))?\s*$/) {
            ($nreqs, $concur) = ($1, $2);
        }

        if ($BenchmarkWarmup) {
            my $cmd = gen_ab_cmd_from_req($block, $req, $BenchmarkWarmup, $concur);
            warn "Warming up with $BenchmarkWarmup requests...\n";
            system @$cmd;
        }

        my $cmd = gen_ab_cmd_from_req($block, $req, $nreqs, $concur);
        $cmd = quote_sh_args($cmd);

        warn "$cmd\n";
        system "unbuffer $cmd > /dev/stderr";
    }

    if ($CheckLeak && !defined $block->no_check_leak) {
        warn "$name\n";

        my $req = $r_req_list->[0];
        my $cmd = gen_ab_cmd_from_req($block, $req);

        # start a sub-process to run ab or weighttp
        my $pid = fork();
        if (!defined $pid) {
            bail_out("$name - fork() failed: $!");

        } elsif ($pid == 0) {
            # child process
            exec @$cmd;

        } else {
            # main process

            $Test::Nginx::Util::ChildPid = $pid;

            sleep(1);
            my $ngx_pid = get_pid_from_pidfile($name);
            if ($PrevNginxPid && $ngx_pid) {
                my $i = 0;
                while ($ngx_pid == $PrevNginxPid) {
                    sleep 0.01;
                    $ngx_pid = get_pid_from_pidfile($name);
                    if (++$i > 1000) {
                        bail_out("nginx cannot be started");
                    }
                }
            }
            $PrevNginxPid = $ngx_pid;
            my @rss_list;
            for (my $i = 0; $i < 100; $i++) {
                sleep 0.02;
                my $out = `ps -eo pid,rss|grep $ngx_pid`;
                if ($? != 0 && !is_running($ngx_pid)) {
                    if (is_running($pid)) {
                        kill(SIGKILL, $pid);
                        waitpid($pid, 0);
                    }

                    my $tb = Test::More->builder;
                    $tb->no_ending(1);

                    Test::More::fail("$name - the nginx process $ngx_pid is gone");
                    last;
                }

                my @lines = grep { $_->[0] eq $ngx_pid }
                                 map { s/^\s+|\s+$//g; [ split /\s+/, $_ ] }
                                 split /\n/, $out;

                if (@lines == 0) {
                    last;
                }

                if (@lines > 1) {
                    warn "Bad ps output: \"$out\"\n";
                    next;
                }

                my $ln = shift @lines;
                push @rss_list, $ln->[1];
            }

            #if ($Test::Nginx::Util::Verbose) {
            warn "LeakTest: [@rss_list]\n";
            #}

            if (@rss_list == 0) {
                warn "LeakTest: k=N/A\n";

            } else {
                my $k = get_linear_regression_slope(\@rss_list);
                warn "LeakTest: k=$k\n";
                #$k = get_linear_regression_slope([1 .. 100]);
                #warn "K = $k (1 expected)\n";
                #$k = get_linear_regression_slope([map { $_ * 2 } 1 .. 100]);
                #warn "K = $k (2 expected)\n";
            }

            if (is_running($pid)) {
                kill(SIGKILL, $pid);
                waitpid($pid, 0);
            }
        }
    }

    #warn "request: $req\n";

    my $timeout = parse_time($block->timeout);
    if ( !defined $timeout ) {
        $timeout = timeout();
    }

    my $res;
    my $req_idx = 0;
    my ($n, $need_array);

    for my $one_req (@$r_req_list) {
        my ($raw_resp, $head_req);

        if ($dry_run) {
            $raw_resp = "200 OK HTTP/1.0\r\nContent-Length: 0\r\n\r\n";

        } else {
            ($raw_resp, $head_req) = send_request( $one_req, $block->raw_request_middle_delay,
                $timeout, $block );
        }

        #warn "raw resonse: [$raw_resp]\n";

        if ($block->pipelined_requests) {
            $n = @{ $block->pipelined_requests };
            $need_array = 1;

        } else {
            $need_array = $#$r_req_list > 0;
        }

again:

        if ($Test::Nginx::Util::Verbose) {
            warn "!!! resp: [$raw_resp]";
        }

        if (!defined $raw_resp) {
            $raw_resp = '';
        }

        my ( $raw_headers, $left );

        if (!defined $block->ignore_response) {

            if ($Test::Nginx::Util::Verbose) {
                warn "parse response\n";
            }

            if (defined $block->http09) {
                $res = HTTP::Response->new(200, "OK", [], $raw_resp);
                $raw_headers = '';

            } else {
                ( $res, $raw_headers, $left ) = parse_response( $name, $raw_resp, $head_req );
            }
        }

        if (!$n) {
            if ($left) {
                my $name = $block->name;
                $left =~ s/([\0-\037\200-\377])/sprintf('\x{%02x}',ord $1)/eg;
                warn "WARNING: $name - unexpected extra bytes after last chunk in ",
                    "response: \"$left\"\n";
            }

        } else {
            $raw_resp = $left;
            $n--;
        }

        if (!defined $block->ignore_response) {
            check_error_code($block, $res, $dry_run, $req_idx, $need_array);
            check_raw_response_headers($block, $raw_headers, $dry_run, $req_idx, $need_array);
            check_response_headers($block, $res, $raw_headers, $dry_run, $req_idx, $need_array);
            transform_response_body($block, $res, $req_idx);
            check_response_body($block, $res, $dry_run, $req_idx, $repeated_req_idx, $need_array);
        }

        if ($n || $req_idx < @$r_req_list - 1) {
            if ($block->wait) {
                sleep($block->wait);
            }

            check_error_log($block, $res, $dry_run, $repeated_req_idx, $need_array);
        }

        $req_idx++;

        if ($n) {
            goto again;
        }
    }

    if ($block->wait) {
        sleep($block->wait);
    }

    if ($Test::Nginx::Util::Verbose) {
        warn "Testing stap...\n";
    }

    test_stap($block, $dry_run);

    check_error_log($block, $res, $dry_run, $repeated_req_idx, $need_array);
}


sub test_stap ($$) {
    my ($block, $dry_run) = @_;
    return if !$block->{stap};

    my $name = $block->name;

    my $reason;

    if ($dry_run) {
        $reason = "the lack of directive $dry_run";
    }

    if (!$UseStap) {
        $dry_run = 1;
        $reason ||= "env TEST_NGINX_USE_STAP is not set";
    }

    my $fname = stap_out_fname();

    if ($fname && ($fname eq '/dev/stdout' || $fname eq '/dev/stderr')) {
        $dry_run = 1;
        $reason ||= "TEST_NGINX_TAP_OUT is set to $fname";
    }

    my $stap_out = $block->stap_out;
    my $stap_out_like = $block->stap_out_like;
    my $stap_out_unlike = $block->stap_out_unlike;

    SKIP: {
        skip "$name - stap_out - tests skipped due to $reason", 1 if $dry_run;

        my $fh = stap_out_fh();
        if (!$fh) {
            bail_out("no stap output file handle found");
        }

        my $out = '';
        for (1..2) {
            if (sleep_time() < 0.2) {
                sleep 0.2;

            } else {
                sleep sleep_time();
            }

            while (<$fh>) {
                $out .= $_;
            }

            if ($out) {
                last;
            }
        }

        if ($Test::Nginx::Util::Verbose) {
            warn "stap out: $out\n";
        }

        if (defined $stap_out) {
            if ($NoLongString) {
                is($out, $block->stap_out, "$name - stap output expected");
            } else {
                is_string($out, $block->stap_out, "$name - stap output expected");
            }
        }

        if (defined $stap_out_like) {
            like($out || '', qr/$stap_out_like/sm,
                 "$name - stap output should match the pattern");
        }

        if (defined $stap_out_unlike) {
            unlike($out || '', qr/$stap_out_unlike/sm,
                   "$name - stap output should not match the pattern");
        }
    }
}


#  Helper function to retrieve a "check" (e.g. error_code) section. This also
# checks that tests with arrays of requests are arrays themselves.
sub get_indexed_value($$$$) {
    my ($name, $value, $req_idx, $need_array) = @_;
    if ($need_array) {
        if (ref $value && ref $value eq 'ARRAY') {
            return $$value[$req_idx];
        }

        bail_out("$name - You asked for many requests, the expected results should be arrays as well.");

    } else {
        # One element but still provided as an array.
        if (ref $value && ref $value eq 'ARRAY') {
            if ($req_idx != 0) {
                bail_out("$name - SHOULD NOT HAPPEN: idx != 0 and don't need array.");
            }

            return $$value[0];
        }

        return $value;
    }
}

sub check_error_code ($$$$$) {
    my ($block, $res, $dry_run, $req_idx, $need_array) = @_;

    my $name = $block->name;
    SKIP: {
        skip "$name - tests skipped due to $dry_run", 1 if $dry_run;

        if ( defined $block->error_code_like ) {

            my $val = get_indexed_value($name, $block->error_code_like, $req_idx, $need_array);
            like( ($res && $res->code) || '',
                qr/$val/sm,
                "$name - status code ok" );

        } elsif ( defined $block->error_code ) {
            is( ($res && $res->code) || '',
                get_indexed_value($name, $block->error_code, $req_idx, $need_array),
                "$name - status code ok" );

        } else {
            is( ($res && $res->code) || '', 200, "$name - status code ok" );
        }
    }
}

sub check_raw_response_headers($$$$$) {
    my ($block, $raw_headers, $dry_run, $req_idx, $need_array) = @_;
    my $name = $block->name;
    if (defined $block->raw_response_headers_like) {
        SKIP: {
            skip "$name - raw_response_headers_like - tests skipped due to $dry_run", 1 if $dry_run;
            my $expected = get_indexed_value($name,
                                             $block->raw_response_headers_like,
                                             $req_idx,
                                             $need_array);
            like $raw_headers, qr/$expected/s, "$name - raw resp headers like";
        }
    }

    if (defined $block->raw_response_headers_unlike) {
        SKIP: {
            skip "$name - raw_response_headers_unlike - tests skipped due to $dry_run", 1 if $dry_run;
            my $expected = get_indexed_value($name,
                                             $block->raw_response_headers_unlike,
                                             $req_idx,
                                             $need_array);
            unlike $raw_headers, qr/$expected/s, "$name - raw resp headers unlike";
        }
    }
}

sub check_response_headers($$$$$) {
    my ($block, $res, $raw_headers, $dry_run, $req_idx, $need_array) = @_;
    my $name = $block->name;
    if ( defined $block->response_headers ) {
        my $headers = parse_headers( get_indexed_value($name,
                                                       $block->response_headers,
                                                       $req_idx,
                                                       $need_array));
        while ( my ( $key, $val ) = each %$headers ) {
            if ( !defined $val ) {

                #warn "HIT";
                SKIP: {
                    skip "$name - response_headers - tests skipped due to $dry_run", 1 if $dry_run;
                    unlike $raw_headers, qr/^\s*\Q$key\E\s*:/ms,
                      "$name - header $key not present in the raw headers";
                }
                next;
            }

            $val =~ s/\$ServerPort\b/$ServerPort/g;
            $val =~ s/\$ServerPortForClient\b/$ServerPortForClient/g;

            my $actual_val = $res ? $res->header($key) : undef;
            if ( !defined $actual_val ) {
                $actual_val = '';
            }

            SKIP: {
                skip "$name - response_headers - tests skipped due to $dry_run", 1 if $dry_run;
                is $actual_val, $val, "$name - header $key ok";
            }
        }
    }
    elsif ( defined $block->response_headers_like ) {
        my $headers = parse_headers( get_indexed_value($name,
                                                       $block->response_headers_like,
                                                       $req_idx,
                                                       $need_array) );
        while ( my ( $key, $val ) = each %$headers ) {
            my $expected_val = $res->header($key);
            if ( !defined $expected_val ) {
                $expected_val = '';
            }
            SKIP: {
                skip "$name - response_headers_like - tests skipped due to $dry_run", 1 if $dry_run;
                like $expected_val, qr/^$val$/, "$name - header $key like ok";
            }
        }
    }
}

sub value_contains ($$) {
    my ($val, $pat) = @_;

    if (!ref $val || ref $val eq 'Regexp') {
        return $val =~ /\Q$pat\E/;
    }

    if (ref $val eq 'ARRAY') {
        for my $v (@$val) {
            if (value_contains($v, $pat)) {
                return 1;
            }
        }
    }

    return undef;
}

sub check_error_log ($$$$) {
    my ($block, $res, $dry_run, $repeated_req_idx, $need_array) = @_;
    my $name = $block->name;
    my $lines;

    my $check_alert_message = 1;
    my $check_crit_message = 1;
    my $check_emerg_message = 1;

    my $grep_pat;
    my $grep_pats = $block->grep_error_log;
    if (defined $grep_pats) {
        if (ref $grep_pats && ref $grep_pats eq 'ARRAY') {
            $grep_pat = $grep_pats->[$repeated_req_idx];

        } else {
            $grep_pat = $grep_pats;
        }
    }

    if (defined $grep_pat) {
        my $expected = $block->grep_error_log_out;
        if (!defined $expected) {
            bail_out("$name - No --- grep_error_log_out defined but --- grep_error_log is defined");
        }

        #warn "ref grep error log: ", ref $expected;

        if (ref $expected && ref $expected eq 'ARRAY') {
            #warn "grep error log out is an ARRAY";
            $expected = $expected->[$repeated_req_idx];
        }

        SKIP: {
            skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run;

            $lines ||= error_log_data();

            my $matched_lines = '';
            for my $line (@$lines) {
                if (ref $grep_pat && $line =~ /$grep_pat/ || $line =~ /\Q$grep_pat\E/) {
                    my $matched = $&;
                    if ($matched !~ /\n/) {
                        $matched_lines .= $matched . "\n";
                    }
                }
            }

            if (ref $expected eq 'Regexp') {
                like($matched_lines, $expected, "$name - grep_error_log_out (req $repeated_req_idx)");

            } else {
                if ($NoLongString) {
                    is($matched_lines, $expected,
                       "$name - grep_error_log_out (req $repeated_req_idx)" );
                } else {
                    is_string($matched_lines, $expected,
                              "$name - grep_error_log_out (req $repeated_req_idx)");
                }
            }
        }
    }

    if (defined $block->error_log) {
        my $pats = $block->error_log;

        if (value_contains($pats, "[alert")) {
            undef $check_alert_message;
        }

        if (value_contains($pats, "[crit")) {
            undef $check_crit_message;
        }

        if (value_contains($pats, "[emerg")) {
            undef $check_emerg_message;
        }

        if (!ref $pats) {
            chomp $pats;
            my @lines = split /\n+/, $pats;
            $pats = \@lines;

        } elsif (ref $pats eq 'Regexp') {
            $pats = [$pats];

        } else {
            my @clone = @$pats;
            $pats = \@clone;
        }

        $lines ||= error_log_data();
        #warn "error log data: ", join "\n", @$lines;
        for my $line (@$lines) {
            for my $pat (@$pats) {
                next if !defined $pat;
                if (ref $pat && $line =~ /$pat/ || $line =~ /\Q$pat\E/) {
                    SKIP: {
                        skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run;
                        pass("$name - pattern \"$pat\" matches a line in error.log (req $repeated_req_idx)");
                    }
                    undef $pat;
                }
            }
        }

        for my $pat (@$pats) {
            if (defined $pat) {
                SKIP: {
                    skip "$name - error_log - tests skipped due to $dry_run", 1 if $dry_run;
                    fail("$name - pattern \"$pat\" should match a line in error.log (req $repeated_req_idx)");
                    #die join("", @$lines);
                }
            }
        }
    }

    if (defined $block->no_error_log) {
        #warn "HERE";
        my $pats = $block->no_error_log;

        if (value_contains($pats, "[alert")) {
            undef $check_alert_message;
        }

        if (value_contains($pats, "[crit")) {
            undef $check_crit_message;
        }

        if (value_contains($pats, "[emerg")) {
            undef $check_emerg_message;
        }

        if (!ref $pats) {
            chomp $pats;
            my @lines = split /\n+/, $pats;
            $pats = \@lines;

        } elsif (ref $pats eq 'Regexp') {
            $pats = [$pats];

        } else {
            my @clone = @$pats;
            $pats = \@clone;
        }

        my %found;
        $lines ||= error_log_data();
        for my $line (@$lines) {
            for my $pat (@$pats) {
                next if !defined $pat;
                #warn "test $pat\n";
                if ((ref $pat && $line =~ /$pat/) || $line =~ /\Q$pat\E/) {
                    if ($found{$pat}) {
                        my $tb = Test::More->builder;
                        $tb->no_ending(1);

                    } else {
                        $found{$pat} = 1;
                    }

                    SKIP: {
                        skip "$name - no_error_log - tests skipped due to $dry_run ($line)", 1 if $dry_run;
                        my $ln = fmt_str($line);
                        my $p = fmt_str($pat);
                        fail("$name - pattern \"$p\" should not match any line in error.log but matches line \"$ln\" (req $repeated_req_idx)");
                    }
                }
            }
        }

        for my $pat (@$pats) {
            next if $found{$pat};
            if (defined $pat) {
                SKIP: {
                    skip "$name - no_error_log - tests skipped due to $dry_run", 1 if $dry_run;
                    my $p = fmt_str($pat);
                    pass("$name - pattern \"$p\" does not match a line in error.log (req $repeated_req_idx)");
                }
            }
        }
    }

    if ($check_alert_message && !$dry_run) {
        $lines ||= error_log_data();
        for my $line (@$lines) {
            #warn "test $pat\n";
            if ($line =~ /\[alert\]/) {
                my $ln = fmt_str($line);
                warn("WARNING: $name - $ln");
            }
        }
    }

    if ($check_crit_message && !$dry_run) {
        $lines ||= error_log_data();
        for my $line (@$lines) {
            #warn "test $pat\n";
            if ($line =~ /\[crit\]/) {
                my $ln = fmt_str($line);
                warn("WARNING: $name - $ln");
            }
        }
    }

    if ($check_emerg_message && !$dry_run) {
        $lines ||= error_log_data();
        for my $line (@$lines) {
            #warn "test $pat\n";
            if ($line =~ /\[emerg\]/) {
                my $ln = fmt_str($line);
                warn("WARNING: $name - $ln");
            }
        }
    }

    for my $line (@$lines) {
        #warn "test $pat\n";
        if ($line =~ /\bAssertion .*? failed\.$/) {
            my $tb = Test::More->builder;
            $tb->no_ending(1);

            chomp $line;
            fail("$name - $line");
        }
    }
}

sub fmt_str ($) {
    my $str = shift;
    chomp $str;
    $str =~ s/"/\\"/g;
    $str =~ s/\r/\\r/g;
    $str =~ s/\n/\\n/g;
    $str;
}

sub transform_response_body ($$$) {
    my ($block, $res, $req_idx) = @_;

    return unless defined $res;

    my $content = $res->content;
    return unless defined $content;

    my $is_2d_array = 0;
    my $name = $block->name;
    my $response_body_filters = $block->response_body_filters;

    if (defined $response_body_filters) {

        if (!ref $response_body_filters) {
            $response_body_filters =~ s/^\s+|\s+$//gs;
            $response_body_filters = [split /\s+/, $response_body_filters];

        } elsif (ref $response_body_filters ne 'ARRAY') {
            $response_body_filters = [$response_body_filters];
        }

        if (ref $response_body_filters eq 'ARRAY') {

            if (ref $response_body_filters->[0] eq 'ARRAY') {
                $is_2d_array = 1;

                for my $elem (@$response_body_filters) {
                    if (ref $elem ne "ARRAY") {
                        bail_out("$name - the --- response_body_filters two-dimensional array "
                           . "only be like [[uc], [lc]] not [[uc], lc]");
                    }
                }
            }
        }

        my $new = $content;
        my $filter = $response_body_filters;

        if ($is_2d_array) {
            $filter = $response_body_filters->[$req_idx];

            bail_out("$name - the ---response_body_filters two-dimensional array "
              . "unmatch the specified request($req_idx)") unless defined $filter;
        }

        if (ref $filter && ref $filter eq 'ARRAY') {

            for my $f (@$filter) {
                $new = run_filter_helper($block, $f, $new);
            }

        } else {
            $new = run_filter_helper($block, $filter, $new);
        }

        $res->content($new);
    }

}

sub check_response_body ($$$$$$) {
    my ($block, $res, $dry_run, $req_idx, $repeated_req_idx, $need_array) = @_;
    my $name = $block->name;
    if (   defined $block->response_body
        || defined $block->response_body_eval )
    {
        my $content = $res ? $res->content : undef;
        if ( defined $content ) {
            $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms;
            $content =~ s/^Connection: TE, close\r\n//gms;
        }

        my $expected;
        if ( $block->response_body_eval ) {
            diag "$name - response_body_eval is DEPRECATED. Use response_body eval instead.";
            $expected = eval get_indexed_value($name,
                                               $block->response_body_eval,
                                               $req_idx,
                                               $need_array);
            if ($@) {
                warn $@;
            }
        }
        else {
            $expected = get_indexed_value($name,
                                          $block->response_body,
                                          $req_idx,
                                          $need_array);
        }

        if ( $block->charset ) {
            Encode::from_to( $expected, 'UTF-8', $block->charset );
        }

        unless (!defined $expected || ref $expected) {
            $expected =~ s/\$ServerPort\b/$ServerPort/g;
            $expected =~ s/\$ServerPortForClient\b/$ServerPortForClient/g;
        }

        #warn show_all_chars($content);

        #warn "no long string: $NoLongString";
        SKIP: {
            skip "$name - response_body - tests skipped due to $dry_run", 1 if $dry_run;
            if (ref $expected) {
                like $content, $expected, "$name - response_body - like (repeated req $repeated_req_idx, req $req_idx)";

            } else {
                if ($NoLongString) {
                    is( $content, $expected,
                        "$name - response_body - response is expected (repeated req $repeated_req_idx, req $req_idx)" );
                }
                else {
                    is_string( $content, $expected,
                        "$name - response_body - response is expected (repeated req $repeated_req_idx, req $req_idx)" );
                }
            }
        }

    } elsif (defined $block->response_body_like
             || defined $block->response_body_unlike)
    {
        my $patterns;
        my $type;
        my $cmp;
        if (defined $block->response_body_like) {
            $patterns = $block->response_body_like;
            $type = "like";
            $cmp = \&like;

        } else {
            $patterns = $block->response_body_unlike;
            $type = "unlike";
            $cmp = \&unlike;
        }

        my $content = $res ? $res->content : undef;
        if ( defined $content ) {
            $content =~ s/^TE: deflate,gzip;q=0\.3\r\n//gms;
            $content =~ s/^Connection: TE, close\r\n//gms;
        }
        my $expected_pat = get_indexed_value($name,
                                             $patterns,
                                             $req_idx,
                                             $need_array);
        $expected_pat =~ s/\$ServerPort\b/$ServerPort/g;
        $expected_pat =~ s/\$ServerPortForClient\b/$ServerPortForClient/g;
        my $summary = trim($content);
        if (!defined $summary) {
            $summary = "";
        }

        SKIP: {
            skip "$name - response_body_$type - tests skipped due to $dry_run", 1 if $dry_run;
            $cmp->( $content, qr/$expected_pat/s,
                "$name - response_body_$type - response is expected ($summary)"
            );
        }
    }

    for my $check (@ResponseBodyChecks) {
        $check->($block, $res->content, $req_idx, $repeated_req_idx, $dry_run);
    }
}

sub parse_response($$$) {
    my ( $name, $raw_resp, $head_req ) = @_;

    my $left;

    my $raw_headers = '';
    if ( $raw_resp =~ /(.*?\r\n)\r\n/s ) {

        #warn "\$1: $1";
        $raw_headers = $1;
    }

    #warn "raw headers: $raw_headers\n";

    my $res = HTTP::Response->parse($raw_resp);

    my $code = $res->code;

    my $enc = $res->header('Transfer-Encoding');
    my $len = $res->header('Content-Length');

    if ($code && $code !~ /^\d+$/) {
       undef $code;
       $res->code(undef);
    }

    if ($code && ($code == 304 || $code == 101)) {
        return $res, $raw_headers
    }

    if ( defined $enc && $enc eq 'chunked' ) {

        #warn "Found chunked!";
        my $raw = $res->content;
        if ( !defined $raw ) {
            $raw = '';
        }

        my $decoded = '';
        while (1) {
            if ( $raw =~ /\G 0 [\ \t]* \r\n \r\n /gcsx ) {
                if ( $raw =~ /\G (.+) /gcsx ) {
                    $left = $1;
                }

                last;
            }

            if ( $raw =~ m{ \G [\ \t]* ( [A-Fa-f0-9]+ ) [\ \t]* \r\n }gcsx ) {
                my $rest = hex($1);

                #warn "chunk size: $rest\n";
                my $bit_sz = 32765;
                while ( $rest > 0 ) {
                    my $bit = $rest < $bit_sz ? $rest : $bit_sz;

                    #warn "bit: $bit\n";
                    if ( $raw =~ /\G(.{$bit})/gcs ) {
                        $decoded .= $1;

                        #warn "decoded: [$1]\n";

                    } else {
                        my $tb = Test::More->builder;
                        $tb->no_ending(1);

                        fail("$name - invalid chunked data received "
                                ."(not enought octets for the data section)"
                        );
                        return;
                    }

                    $rest -= $bit;
                }

                if ( $raw !~ /\G\r\n/gcs ) {
                    my $tb = Test::More->builder;
                    $tb->no_ending(1);

                    fail(
                        "$name - invalid chunked data received (expected CRLF)."
                    );
                    return;
                }

            } elsif ( $raw =~ /\G.+/gcs ) {
                my $tb = Test::More->builder;
                $tb->no_ending(1);

                fail "$name - invalid chunked body received: $&";
                return;

            } else {
                my $tb = Test::More->builder;
                $tb->no_ending(1);

                fail "$name - no last chunk found - $raw";
                return;
            }
        }

        #warn "decoded: $decoded\n";
        $res->content($decoded);

    } elsif (defined $len && $len ne '' && $len >= 0) {
        my $raw = $res->content;
        if (length $raw < $len) {
            if (!$head_req) {
                warn "WARNING: $name - response body truncated: ",
                    "$len expected, but got ", length $raw, "\n";
            }

        } elsif (length $raw > $len) {
            my $content = substr $raw, 0, $len;
            $left = substr $raw, $len;
            $res->content($content);
            #warn "parsed body: [", $res->content, "]\n";
        }
    }

    return ( $res, $raw_headers, $left );
}

sub send_request ($$$$@) {
    my ( $req, $middle_delay, $timeout, $block, $tries ) = @_;

    my $name = $block->name;

    #warn "connecting...\n";

    my $server_addr = $block->server_addr_for_client;

    if (!defined $server_addr) {
        $server_addr = $ServerAddr;
    }

    my $sock = IO::Socket::INET->new(
        PeerAddr  => $server_addr,
        PeerPort  => $ServerPortForClient,
        Proto     => 'tcp',
        #ReuseAddr => 1,
        #ReusePort => 1,
        Blocking  => 0,
        Timeout   => $timeout,
    );

    if (!defined $sock) {
        $tries ||= 1;
        my $total_tries = $TotalConnectingTimeouts ? 20 : 50;
        if ($tries <= $total_tries) {
            my $wait = (sleep_time() + sleep_time() * $tries) * $tries / 2;
            if ($wait >= 1) {
                $wait = 1;
            }

            if (defined $Test::Nginx::Util::ChildPid) {
                my $errcode = $!;
                if (waitpid($Test::Nginx::Util::ChildPid, WNOHANG) == -1) {
                    warn "WARNING: Child process $Test::Nginx::Util::ChildPid is already gone.\n";
                    warn `tail -n20 $Test::Nginx::Util::ErrLogFile`;

                    my $tb = Test::More->builder;
                    $tb->no_ending(1);

                    fail("$name - Can't connect to $ServerAddr:$ServerPortForClient: $errcode (aborted)\n");
                    return;
                }
            }

            if ($wait >= 0.6) {
                warn "$name - Can't connect to $ServerAddr:$ServerPortForClient: $!\n";
                if ($tries + 1 <= $total_tries) {
                    warn "\tRetry connecting after $wait sec\n";
                }
            }

            sleep $wait;

            #warn "sending request";
            return send_request($req, $middle_delay, $timeout, $block, $tries + 1);

        }

        my $msg = "$name - Can't connect to $ServerAddr:$ServerPortForClient: $! (aborted)\n";
        if (++$TotalConnectingTimeouts < 3) {
            my $tb = Test::More->builder;
            $tb->no_ending(1);
            fail($msg);

        } else {
            bail_out($msg);
        }

        return;
    }

    #warn "connected";

    my @req_bits = ref $req ? @$req : ($req);

    my $head_req = 0;
    {
        my $req = join '', map { $_->{value} } @req_bits;
        #warn "Request: $req\n";
        if ($req =~ /^\s*HEAD\s+/) {
            #warn "Found HEAD request!\n";
            $head_req = 1;
        }
    }

    #my $flags = fcntl $sock, F_GETFL, 0
    #or die "Failed to get flags: $!\n";

    #fcntl $sock, F_SETFL, $flags | O_NONBLOCK
    #or die "Failed to set flags: $!\n";

    my $ctx = {
        resp         => '',
        write_offset => 0,
        buf_size     => 1024,
        req_bits     => \@req_bits,
        write_buf    => (shift @req_bits)->{"value"},
        middle_delay => $middle_delay,
        sock         => $sock,
        name         => $name,
        block        => $block,
    };

    my $readable_hdls = IO::Select->new($sock);
    my $writable_hdls = IO::Select->new($sock);
    my $err_hdls      = IO::Select->new($sock);

    while (1) {
        if (   $readable_hdls->count == 0
            && $writable_hdls->count == 0
            && $err_hdls->count == 0 )
        {
            last;
        }

        #warn "doing select...\n";

        my ($new_readable, $new_writable, $new_err) =
          IO::Select->select($readable_hdls, $writable_hdls, $err_hdls,
            $timeout);

        if (!defined $new_err
            && !defined $new_readable
            && !defined $new_writable)
        {

            # timed out
            timeout_event_handler($ctx);
            last;
        }

        for my $hdl (@$new_err) {
            next if !defined $hdl;

            error_event_handler($ctx);

            if ( $err_hdls->exists($hdl) ) {
                $err_hdls->remove($hdl);
            }

            if ( $readable_hdls->exists($hdl) ) {
                $readable_hdls->remove($hdl);
            }

            if ( $writable_hdls->exists($hdl) ) {
                $writable_hdls->remove($hdl);
            }

            for my $h (@$readable_hdls) {
                next if !defined $h;
                if ( $h eq $hdl ) {
                    undef $h;
                    last;
                }
            }

            for my $h (@$writable_hdls) {
                next if !defined $h;
                if ( $h eq $hdl ) {
                    undef $h;
                    last;
                }
            }

            close $hdl;
        }

        for my $hdl (@$new_readable) {
            next if !defined $hdl;

            my $res = read_event_handler($ctx);
            if ( !$res ) {

                # error occured
                if ( $err_hdls->exists($hdl) ) {
                    $err_hdls->remove($hdl);
                }

                if ( $readable_hdls->exists($hdl) ) {
                    $readable_hdls->remove($hdl);
                }

                if ( $writable_hdls->exists($hdl) ) {
                    $writable_hdls->remove($hdl);
                }

                for my $h (@$writable_hdls) {
                    next if !defined $h;
                    if ( $h eq $hdl ) {
                        undef $h;
                        last;
                    }
                }

                close $hdl;
            }
        }

        for my $hdl (@$new_writable) {
            next if !defined $hdl;

            my $res = write_event_handler($ctx);
            if ( !$res ) {

                # error occured
                if ( $err_hdls->exists($hdl) ) {
                    $err_hdls->remove($hdl);
                }

                if ( $readable_hdls->exists($hdl) ) {
                    $readable_hdls->remove($hdl);
                }

                if ( $writable_hdls->exists($hdl) ) {
                    $writable_hdls->remove($hdl);
                }

                close $hdl;

            } elsif ( $res == 2 ) {
                # all data has been written

                my $shutdown = $block->shutdown;
                if (defined $shutdown) {
                    if ($shutdown =~ /^$/s) {
                        $shutdown = 1;
                    }

                    #warn "shutting down with $shutdown";
                    shutdown($sock, $shutdown);
                }

                if ( $writable_hdls->exists($hdl) ) {
                    $writable_hdls->remove($hdl);
                }
            }
        }
    }

    return ($ctx->{resp}, $head_req);
}

sub timeout_event_handler ($) {
    my $ctx = shift;

    close($ctx->{sock});

    if (!defined $ctx->{block}->abort) {
        my $tb = Test::More->builder;
        $tb->no_ending(1);

        fail("ERROR: client socket timed out - $ctx->{name}\n");

    } else {
        sleep 0.005;
    }
}

sub error_event_handler ($) {
    warn "exception occurs on the socket: $!\n";
}

sub write_event_handler ($) {
    my ($ctx) = @_;

    while (1) {
        return undef if !defined $ctx->{write_buf};

        my $rest = length( $ctx->{write_buf} ) - $ctx->{write_offset};

  #warn "offset: $write_offset, rest: $rest, length ", length($write_buf), "\n";
  #die;

        if ( $rest > 0 ) {
            my $bytes;
            eval {
                $bytes = syswrite(
                    $ctx->{sock}, $ctx->{write_buf},
                    $rest,        $ctx->{write_offset}
                );
            };

            if ($@) {
                my $errmsg = "write failed: $@";
                warn "$errmsg\n";
                $ctx->{resp} =  $errmsg;
                return undef;
            }

            if ( !defined $bytes ) {
                if ( $! == EAGAIN ) {

                    #warn "write again...";
                    #sleep 0.002;
                    return 1;
                }
                my $errmsg = "write failed: $!";
                warn "$errmsg\n";
                if ( !$ctx->{resp} ) {
                    $ctx->{resp} = "$errmsg";
                }
                return undef;
            }

            #warn "wrote $bytes bytes.\n";
            $ctx->{write_offset} += $bytes;

        } else {
            # $rest == 0

            my $next_send = shift @{ $ctx->{req_bits} };

            if (!defined $next_send) {
                return 2;
            }

            $ctx->{write_buf} = $next_send->{'value'};
            $ctx->{write_offset} = 0;

            my $wait_time;

            if (!defined $next_send->{'delay_before'}) {
                if (defined $ctx->{middle_delay}) {
                    $wait_time = $ctx->{middle_delay};
                }

            } else {
                $wait_time = $next_send->{'delay_before'};
            }

            if ($wait_time) {
                #warn "sleeping..";
                sleep $wait_time;
            }
        }
    }

    # impossible to reach here...
    return undef;
}

sub read_event_handler ($) {
    my ($ctx) = @_;
    while (1) {
        my $read_buf;
        my $bytes = sysread( $ctx->{sock}, $read_buf, $ctx->{buf_size} );

        if ( !defined $bytes ) {
            if ( $! == EAGAIN ) {

                #warn "read again...";
                #sleep 0.002;
                return 1;
            }
            warn "WARNING: $ctx->{name} - HTTP response read failure: $!";
            return undef;
        }

        if ( $bytes == 0 ) {
            return undef;    # connection closed
        }

        $ctx->{resp} .= $read_buf;

        #warn "read $bytes ($read_buf) bytes.\n";
    }

    # impossible to reach here...
    return undef;
}

sub gen_curl_cmd_from_req ($$) {
    my ($block, $req) = @_;

    my $name = $block->name;

    $req = join '', map { $_->{value} } @$req;

    #use JSON::XS;
    #warn "Req: ",  JSON::XS->new->encode([$req]), "\n";

    my ($meth, $uri, $http_ver);
    if ($req =~ m{^\s*(\w+)\s+(\S+)\s+HTTP/(\S+)\r?\n}smig) {
        ($meth, $uri, $http_ver) = ($1, $2, $3);

    } elsif ($req =~ m{^\s*(\w+)\s+(.*\S)\r?\n}smig) {
        ($meth, $uri) = ($1, $2);
        $http_ver = '0.9';

    } else {
        bail_out "$name - cannot parse the status line in the request: $req";
    }

    my @args = ('curl', '-i');

    if ($meth eq 'HEAD') {
        push @args, '-I';

    } elsif ($meth ne 'GET') {
        warn "WARNING: --- curl: request method $meth not supported yet.\n";
    }

    if ($http_ver ne '1.1') {
        # HTTP 1.0 or HTTP 0.9
        push @args, '-0';
    }

    my @headers;
    if ($http_ver ge '1.0') {
        if ($req =~ m{\G(.*?)\r?\n\r?\n}gcs) {
            my $headers = $1;
            #warn "raw headers: $headers\n";
            @headers = grep {
                !/^Connection\s*:/i
                && !/^Host: \Q$ServerName\E$/i
                && !/^Content-Length\s*:/i
            } split /\r\n/, $headers;

        } else {
            bail_out "cannot parse the header entries in the request: $req";
        }
    }

    #warn "headers: @headers ", scalar(@headers), "\n";

    for my $h (@headers) {
        #warn "h: $h\n";
        if ($h =~ /^\s*User-Agent\s*:\s*(.*\S)/i) {
            push @args, '-A', $1;

        } else {
            push @args, '-H', $h;
        }
    }

    if ($req =~ m{\G.+}gcs) {
        warn "WARNING: --- curl: request body not supported.\n";
    }

    my $link;
    {
        my $server = $ServerAddr;
        my $port = $ServerPortForClient;
        $link = "http://$server:$port$uri";
    }

    push @args, $link;

    return \@args;
}

sub gen_ab_cmd_from_req ($$@) {
    my ($block, $req, $nreqs, $concur) = @_;

    $nreqs ||= 100000;
    $concur ||= 2;

    if ($nreqs < $concur) {
        $concur = $nreqs;
    }

    my $name = $block->name;

    $req = join '', map { $_->{value} } @$req;

    #use JSON::XS;
    #warn "Req: ",  JSON::XS->new->encode([$req]), "\n";

    my ($meth, $uri, $http_ver);
    if ($req =~ m{^\s*(\w+)\s+(\S+)\s+HTTP/(\S+)\r?\n}smig) {
        ($meth, $uri, $http_ver) = ($1, $2, $3);

    } elsif ($req =~ m{^\s*(\w+)\s+(.*\S)\r?\n}smig) {
        ($meth, $uri) = ($1, $2);
        $http_ver = '0.9';

    } else {
        bail_out "$name - cannot parse the status line in the request: $req";
    }

    #warn "HTTP version: $http_ver\n";

    my @opts = ("-c$concur", '-k', "-n$nreqs");

    my $prog;
    if ($http_ver eq '1.1' && $meth eq 'GET') {
        $prog = 'weighttp';

    } else {
        # HTTP 1.0 or HTTP 0.9
        $prog = 'ab';
        unshift @opts, '-r', '-d', '-S';
    }

    my @headers;
    if ($http_ver ge '1.0') {
        if ($req =~ m{\G(.*?)\r?\n\r?\n}gcs) {
            my $headers = $1;
            #warn "raw headers: $headers\n";
            @headers = grep {
                !/^Connection\s*:/i
                && !/^Host: \Q$ServerName\E$/i
                && !/^Content-Length\s*:/i
            } split /\r\n/, $headers;

        } else {
            bail_out "cannot parse the header entries in the request: $req";
        }
    }

    #warn "headers: @headers ", scalar(@headers), "\n";

    for my $h (@headers) {
        #warn "h: $h\n";
        if ($prog eq 'ab' && $h =~ /^\s*Content-Type\s*:\s*(.*\S)/i) {
            my $type = $1;
            push @opts, '-T', $type;

        } else {
            push @opts, '-H', $h;
        }
    }

    my $bodyfile;

    if ($req =~ m{\G.+}gcs || $meth eq 'POST' || $meth eq 'PUT') {
        my $body = $&;

        if (!defined $body) {
            $body = '';
        }

        my ($out, $bodyfile) = tempfile("bodyXXXXXXX", UNLINK => 1,
                                        SUFFIX => '.temp', TMPDIR => 1);
        print $out $body;
        close $out;

        if ($meth eq 'PUT') {
            push @opts, '-u', $bodyfile;

        } elsif ($meth eq 'POST') {
            push @opts, '-p', $bodyfile;

        } elsif ($meth eq 'GET') {
            warn "WARNING: method $meth not supported for ab when taking a request body\n";

        } else {
            warn "WARNING: method $meth not supported for ab when taking a request body\n";
            $meth = 'PUT';
            push @opts, '-p', $bodyfile;
        }
    }

    if ($meth eq 'HEAD') {
        unshift @opts, '-i';
    }

    my $link;
    {
        my $server = $ServerAddr;
        my $port = $ServerPortForClient;
        $link = "http://$server:$port$uri";
    }

    my @cmd = ($prog, @opts, $link);

    if ($Test::Nginx::Util::Verbose) {
        warn "command: @cmd\n";
    }

    return \@cmd;
}

sub get_linear_regression_slope ($) {
    my $list = shift;

    my $n = @$list;
    my $avg_x = ($n + 1) / 2;
    my $avg_y = sum(@$list) / $n;

    my $x = 0;
    my $avg_xy = sum(map { $x++; $x * $_ } @$list) / $n;
    my $avg_x2 = sum(map { $_ * $_ } 1 .. $n) / $n;
    my $denom = $avg_x2 - $avg_x * $avg_x;
    if ($denom == 0) {
        return 'Inf';
    }
    my $k = ($avg_xy - $avg_x * $avg_y) / $denom;
    return sprintf("%.01f", $k);
}

1;
__END__