#!perl -w

use strict;
use warnings;

use IO::Pipe;
use Time::HiRes 'time','sleep';
use LWP::UserAgent;

use constant CLIENTS   => 4;
use constant DEBUG     => 1;

# buffering a bad idea when fork()ing
$|=1; 

my @kids=();
my $pid=$$;
my $parentpid=0;

##############################################################################
# Main
##############################################################################

# open a pipe so that child processes can send results to parent.
my $pipe = IO::Pipe->new || die "Can't pipe: $!";

# create a LWP::UserAgent instance for the children to inherit
my $ua = LWP::UserAgent->new(env_proxy => 1,
                             keep_alive => 1,
                             timeout => 30,
                            );

my $start = time();

Forker(CLIENTS);

if ($parentpid) 
{
    Work(1);
}
else 
{ 
    $pipe->reader; # use the pipe for reading from childs

    # read stats from childs
    my $s;
    while (<$pipe>) {
        chomp;
        my ($child,$time,$bytes,$code) = split("\t");
        $s->{count}++;
        $s->{status}->{$code}++;
        $s->{trans_time} += $time;
        $s->{bytes} += $bytes;
    }

    # Parent does cleanup duty
    Reaper();
    
    $s->{elapsed} = time() - $start;

    # print results
    my $throughput       = sprintf "%3.2f",$s->{bytes}      / $s->{elapsed};
    my $resp_time        = sprintf "%3.2f",$s->{trans_time} / $s->{count};
    my $trans_rate       = sprintf "%3.2f",$s->{count}      / $s->{elapsed};
    my $concurrency      = sprintf "%3.1f",$s->{trans_time} / $s->{elapsed};
    my $elapsed          = sprintf "%3.3f",$s->{elapsed};
    print STDOUT <<EOF;
Transactions:           $s->{count}
Elapsed time:           $elapsed sec
Bytes Transferred:      $s->{bytes} bytes
Response Time:          $resp_time sec
Transaction Rate:       $trans_rate trans/sec
Throughput:             $throughput bytes/sec
Concurrency:            $concurrency
EOF
    for my $code (sort {$a <=> $b} keys %{$s->{status}}) {
        print "Status Code $code:        $s->{status}->{$code}\n";
    }

}

warn "$$ exiting\n" if DEBUG;
if ($parentpid) {
    #kids exit here
    exit(0);
}
else {
    #parent exits here
    exit(0);
}
die; #wont happen

##############################################################################
# Function to fork a given number of workers
##############################################################################
sub Forker 
{
    my $clients=shift;

    # fork childs
    my $i=0;
    while ($i++ < $clients) 
    {
        my $newpid = fork();
        if (! defined $newpid) 
        { 
            #error
            die "Could not fork: $!\n";
        }
        elsif ($newpid == 0) 
        { 
            #child
            $parentpid = $pid;
            $pid = $$;
            @kids = (); #don't inhert the kids
            $pipe->writer; select $pipe; # use the pipe for writing to parent
            warn "$$ child of $parentpid\n" if DEBUG;
            last;
        }
        else 
        { 
            #parent (defined $newpid)
            warn "$$ spawned $newpid\n" if DEBUG;
            push(@kids, $newpid);
        }
    }
}

##############################################################################
# Worker Funktion that does all the requests.
##############################################################################
sub Work 
{
    my $doit = shift;
    warn "$$ Entering Work()\n" if DEBUG;
    
    my $start = time();
    my ($status,$message,$contents);
    
    ($status,$message,$contents) = fetch('http://127.0.0.1/') if $doit;
    #($status,$message,$contents) = (200,'','')        unless $doit;
    
    my $elapsed = time() - $start;
    my $bytes = length($contents);

    # write result back to parent
    print join("\t",$$,$elapsed,$bytes,$status),"\n";
}

##############################################################################
# Reaper Function to collect all kids
##############################################################################
sub Reaper 
{
    while (my $kid = shift(@kids)) 
    {
        warn "$$ to reap $kid\n" if DEBUG;
        my $reaped = waitpid($kid,0);
        unless ($reaped == $kid) 
        {
            warn "waitpid $reaped: $?\n" if DEBUG;
        }
    }
}

##############################################################################
# Function to do the actual HTTP operations
##############################################################################
sub fetch
{
    my ($url,$content,$content_type) = @_;
    $content_type ||= 'application/octet-stream' if $content;

    # Send GET or POST request    
    my $response;
    if (defined $content) 
    {
        # POST
        $ua->post($url);
    } 
    else 
    {
        # GET
        $response = $ua->get($url);
    }

    # return HTTP response code, message and document body if available. 
    my $doc_body = '';
    if ($response->is_success) 
    {
        $doc_body = $response->content;
    }
    my $status = $response->code;
    my $message = $response->message;
    
    undef $response;
    undef $ua;
    
    return ($status,$message,$doc_body);
}

##############################################################################
# EOF
##############################################################################