#!/usr/bin/perl -Tw

# tcp (http) benchmark, client and server
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Perl Artistic Licence
#
# see also:
# iperf -s -N >/dev/null & sleep 1; iperf -c localhost -f M -t 10
#
# optional /etc/xinetd.d/tcpbm :
#
# service tcpbm
# {
#         socket_type             = stream
#         wait                    = no
#         type                    = unlisted
#         protocol                = tcp
#         port                    = 591
#        #flags                   = IPv6
#         cps                     = 10 2
#         user                    = nobody
#         groups                  = no
#         server                  = /usr/local/bin/tcpbm
#         nice                    = 0
#         disable                 = no
# }

use 5.006;
use Config;
use strict qw(vars subs);
use Cwd qw(abs_path);
use Socket qw(IPPROTO_TCP TCP_NODELAY);
use File::Basename;
use IO::Handle;
use IO::Socket::INET;
use Getopt::Std;
use Time::HiRes qw(time);

use constant kB => 2**10;
use constant MB => 2**20;

our $servertest = 1; # allow server to server test via webinterface

our ($windoof);
our ($SH,$IN,$OUT);
our ($server,$port);
our @header;
our $ra;

my $host = '-';
my $proxy = '';
my $proxy_prefix = '';
my $timeout = 30;
my $tty = -t STDOUT;
my $version = 20231024;

my $_0 = untaint(abs_path($0));
my $prg = $0;
my @_ARGV = untaint(@ARGV);

$| = 1;

$ENV{LANGUAGE} = 'en';
$ENV{LC_MESSAGES} = 'C';
$ENV{IFS} = " \t\n";
$ENV{PATH} = untaint($ENV{PATH});
$ENV{BASH_ENV} = untaint($ENV{BASH_ENV}) if $ENV{BASH_ENV};

if ($Config{osname} =~ /^mswin/i) {
  $windoof = $Config{osname};
  $prg =~ s:.*\\::;
  $prg =~ s/.exe$//;
} else {
  $prg =~ s:.*/::;
}

$0 = "$prg @ARGV";

my $usage = <<EOD;
tcpbm: tcp benchmark sending and receiving via HTTP (upload/download speed)

client usage: tcpbm [-v] [-4] [-6] [-a] [-N] [-R] [-b BLOCKSIZE ] [-P PROXY] \\
                    [-m MB[:MB]] [-s SECONDS] [-d] [-u] SERVER[:PORT]
server usage: tcpbm [-v] [-b BLOCKSIZE ] -p PORT

options: -v              : verbose mode
         -4              : use IPv4
         -6              : use IPv6
         -a              : test all server IP addresses
         -N              : set TCP_NODELAY (disable Nagle\'s algorithm)
         -R              : use random strings instead of fixed string 
                           (better results on auto-compressing network links)
         -d              : test download (receiving)
         -u              : test upload (sending)
         -b BLOCKSIZE    : blocksize in kB (default dynamic)
         -P PROXY        : HTTP-proxy SERVER:PORT
         -s SECONDS      : number of seconds to test (default 10)
         -m MB[:MB]      : number of MBs to receive [:send]
         -p PORT         : local server port

arguments: SERVER[:PORT] : server name or IP to connect (default PORT=591)

examples: tcpbm flupp.belwue.de
          tcpbm -a -m 10:100 flupp.belwue.de
          tcpbm -4 -P webproxy:8080 -s 30 fex.belwue.de:80

see also: http://tcpbm.belwue.de:591/
EOD

autoflush STDOUT;
autoflush STDERR;

unless ($version) {
  my @d = localtime((stat $_0)[9]);
  $version = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3])
}

our $opt_v = 0;
our $opt_h = 0;
our $opt_p = 0;
our $opt_b = 0;
our $opt_x = 0;
our $opt_s = 0;
our $opt_m = 0;
our $opt_N = 0;
our $opt_R = 0;
our $opt_4 = 0;
our $opt_6 = 0;
our $opt_a = 0;
our $opt_d = 0;
our $opt_u = 0;
our $opt_P = '';

getopts('hvxNR46adup:P:b:s:m:') or die $usage;

if ($opt_h) {
  print $usage;
  exit;
}

if ($opt_4 and $opt_6) {
  die "$prg: cannot use options -4 -6 together\n";
}

if ($opt_P and ($opt_a or $opt_4 or $opt_6)) {
  die "$prg: cannot use option -P together with options -4 -6 -a\n";
}

if ($opt_s and $opt_m) {
  die "$prg: cannot use options -s -m together\n";
}

unless ($opt_d or $opt_u) {
  $opt_d = $opt_u = 1;
}

# xinetd
unless (@ARGV) {
  $opt_x ||= $ENV{REMOTE_HOST} || $ENV{REMOTE_ADDR};
}

$SIG{ALRM} = sub { die "\nTIMEOUT\n" };

if ($opt_p) {
  $timeout = 0;
  for (;;) { &server }
} elsif ($opt_x) {
  &server;
} else {
  &client;
}

exit;


sub client {
  local ($server,$port);
  my (@ipv4,@ipv6);
  my $mbout = 0;
  my $mbin = 0;
  my $cmd;

  if ($opt_P) {
    if ($opt_P =~ /^[\w.-]+:\d+/) {
      $proxy = $opt_P;
    } else {
      die "$prg: proxy must be: SERVER:PORT\n";
    }
  }

  $server = shift @ARGV or die $usage;
  $server = untaint($server);
  if ($server =~ s/:(\d+)$//) { $port = $1 }
  else                        { $port = 591 }
  $server =~ s/^\[([\w:]+)\]$/$1/; # [IPv6 address]

  if ($opt_m and not @ARGV) {
    @ARGV = ($opt_m);
  }

  $_ = "@ARGV";
  if (/^(\d+)$/) {
    $mbout = $mbin = $1;
  } elsif (/^(\d+):(\d+)$/) {
    $mbin =  $1;
    $mbout = $2;
  } elsif (/^$/) {
    # no second argument
    ## die $usage if $proxy;
    $opt_s ||= 10; # time based benchmarking
  } else {
    die $usage;
  }

  if ($opt_a and $server !~ /^(\d+\.\d+\.\d+\.\d+)$|:.*:/) {
    unless ($cmd = searchpath('host','nslookup')) {
      die "$prg: no host or nslookup command available\n";
    }

    warn "\$ $cmd $server\n" if $opt_v;
    $_ = `$cmd $server`;
    s/.*?Name://s;
    push @ipv4,$1 while s/\b(\d+\.\d+\.\d+\.\d+)\b//;
    push @ipv6,$1 while s/\b([a-f\d]*:[a-f\d]*:[a-f\d:]*)\b//;

    if (@ipv6) {
      eval 'use IO::Socket::INET6';
      if ($@) {
        warn "$prg: missing IO::Socket::INET6 Perl module, cannot test IPv6 addresses\n";
        @ipv6 = ();
      }
    }
    foreach my $ip (@ipv4) {
      bmserver($ip,$port,$mbout,$mbin);
      sleep 1;
    }
    foreach my $ip (@ipv6) {
      bmserver($ip,$port,$mbout,$mbin);
      sleep 1;
    }
  } else {
    bmserver($server,$port,$mbout,$mbin);
  }
  exit;
}


sub bmserver {
  my ($server,$port,$mbout,$mbin) = @_;
  my ($size,$buf,$bs);
  my ($t,$bt,$t0,$t1,$t2,$tt,$B,$kBs,$MBs);

  $bs = ($opt_b||64)*kB;

  my $serverconnect = sub {
    if ($proxy) {
      if ($port == 80)  { $proxy_prefix = "http://$server" }
      else              { $proxy_prefix = "http://$server:$port" }
      $SH = tcpconnect(split(':',$proxy));
    } else {
      $SH = tcpconnect($server,$port);
      if (not $SH and $port == 591) {
        # fex service?
        $SH = tcpconnect($server,80) and $port = 80;
      }
    }

    unless ($SH) {
      $server = "[$server]" if $server =~ /:.*:/;
      die "$prg: cannot connect $server:$port - $@\n";
    }

    if ($opt_N) {
      setsockopt($SH,IPPROTO_TCP,TCP_NODELAY,1)
        or warn "$prg: cannot setsockopt TCP_NODELAY - $@\n";
    }

    $OUT = $SH;
  };

  &$serverconnect;

  unless ($SH) {
    if ($server =~ /:/) {
      warn "$prg: cannot connect [$server]:$port - $@\n";
    } else {
      warn "$prg: cannot connect $server:$port - $@\n";
    }
    return;
  }

  if ($opt_a) {
    writeheader(
      "GET $proxy_prefix/tcpbm/ip HTTP/1.0",
      "Host: $::server:$port",
      "User-Agent: $prg",
    );

    # is there a tcpbm/fexsrv ?
    getserverreply("$server:$port");

    $_ = getaline($SH)||'';
    print "<-- $_\n" if $opt_v;
    if (/^(\d+\.\d+\.\d+\.\d+|[a-f\d:]*:[a-f\d:]*:[a-f\d:]*)$/) {
      print "\nTesting $server with local ip $_\n";
    } else {
      print "\nTesting $server\n";
    }

    close $SH;
    undef $SH;
  }

  if ($mbin or $opt_s and $opt_d) {

    unless ($SH) {
      sleep 1;
      &$serverconnect;
    }

    $size = $mbin*MB;
    $size = -1 if $opt_s;

    my $dd = '9999999.dd';
    $dd =~ s/dd/rd/ if $opt_R;
    writeheader(
      "GET $proxy_prefix/tcpbm/$dd HTTP/1.0",
      "Host: $::server:$port",
      "User-Agent: $prg",
      "X-Blocksize: $opt_b",
    );

    my $response = getserverreply("$server:$port");
    if ($response !~ /^HTTP.1...200/) {
      $response =~ s/HTTP.[\d\s.]+//;
      die "$prg: server reply: $response\n";
    }

    $size = $mbin*MB;
    $bs = ($opt_b||64)*kB;
    $t0 = $t2 = time;
    $t1 = $bt = $tt = $B = 0;

    while ($opt_s and $tt < $opt_s or $mbin and $B < $size) {
      $b = sysread $SH,$buf,$bs or last;
      $B += $b;
      $bt += $b;
      $t2 = time;
      $tt = ($t2-$t0)||1;
      if ($t2-$t1 > 1) {
        alarm($timeout);
        if ($t1) {
          status($tty?'receiving':'received',$B,$size,$tt,$bt/($t2-$t1));
          unless ($opt_b) {
            # adjust block size depending on link speed
            if ($bs>4096 and $B/$tt<65536) {
              $bs = 4096;
            } elsif ($bs<MB and $B/$tt>MB) {
              $bs = 4*MB;
            }
          }
        }
        $t1 = $t2;
        $bt = 0;
      }
    }
    $tt = (time-$t0)||1;
    close $SH;
    undef $SH;
    alarm(0);
    status("received",$B,$size,$tt,$B/$tt) if $tty;
  }

  if ($mbout or $opt_s and $opt_u) {

    unless ($SH) {
      sleep 1;
      &$serverconnect;
    }

    $size = $mbout*MB;
    $size = -1 if $opt_s;

    writeheader(
      "POST $proxy_prefix/tcpbm?$mbout HTTP/1.0",
      "Host: $::server:$port",
      "User-Agent: $prg",
      "Content-Length: ".($opt_s ? 999999999999999 : $size),
      "Content-Type: application/octet-stream",
      "X-Blocksize: $opt_b",
    );

    $bs = ($opt_b||64)*kB;
    $buf = stringgen($bs);
    $t0 = $t2 = time;
    $t1 = 0;
    $B = 0;

    alarm($timeout*10);
    while ($B < $size or $opt_s) {
#     $buf = stringgen($bs) if $opt_R; # slow!
      unless (syswrite $SH,$buf) {
        last if $opt_s;
        $_ = <$SH>||'';
        if ($opt_v) {
          print "\n<-- $_";
        } else {
          s/HTTP.[\d\s.]+//;
          s/[\r\n]+$//;
          warn "\n$prg: server reply: $_\n";
        }
        die "$prg: server has closed the connection\n";
      }
      $B += $bs;
      $bt += $bs;
      $t2 = time;
      $tt = ($t2-$t0)||1;
      if ($t2-$t1 > 1) {
        alarm($timeout);
        if ($t1) {
          status($tty?'sending':'sent',$B,$size,$tt,$bt/($t2-$t1));
          unless ($opt_b) {
            # adjust block size depending on link speed
            if ($bs>4096 and $B/$tt<65536) {
              $bs = 4096;
              $buf = stringgen($bs);
            } elsif ($bs<MB and $B/$tt>MB) {
              $bs = 4*MB;
              $buf = stringgen($bs);
            }
          }
        }
        $t1 = $t2;
        $bt = 0;
      }
      if ($opt_s) {
        last if $tt >= $opt_s;
      } elsif ($B+$bs > $size) {
        $bs = $size-$B;
        $buf = stringgen($bs);
      }
    }
    $tt = (time-$t0)||1;
    close $SH;
    undef $SH;
    alarm(0);
    status("sent",$B,$size,$tt,$B/$tt);
  }

}


sub server {
  my ($rh,$peer,$req);
  my ($t0,$t1,$t2,$tt,$B,$bt,$kBs);
  my ($buf,$mbin,$mbout,$upload,$sa,$iaddr);
  my $bs = ($opt_b||64)*kB;
  my $xbs = 0;
  my $size = 0;
  my $port = $opt_p;
  my $ua = '-';
  my $referer = '-';
  my $log;

  $ENV{PATH} = dirname($_0);

  chdir dirname($_0);

  if ($opt_x) {
    open $IN,'<-' or die "$prg: cannot open STDIN - $!\n";
    open $OUT,'>-' or die "$prg: cannot open STDOUT - $!\n";
    $log = $_0.'.log';
    $log = '' unless -w $log;

    $sa = getpeername(STDIN) or die "$prg: no network stream on STDIN\n";
  } else {
    my $sock = new IO::Socket::INET(
      LocalPort	=> $port,
      Proto	=> 'tcp',
      Listen	=> 1,
      Reuse	=> 1,
    ) or die "$prg: cannot bind to port $port - $!\n";

    print "$prg: bound to port $port, waiting for connection\n" if $tty;

    $IN = $OUT = $SH = $sock->accept();
    $sa = getpeername($SH) or die "$prg: no network stream\n";
  }

  if ($ENV{REMOTE_ADDR} and $ENV{REMOTE_HOST}) {
    # from fexsrv
    $ra = $ENV{REMOTE_ADDR};
    $rh = $ENV{REMOTE_HOST};
  } elsif (sockaddr_family($sa) == AF_INET) {
    (undef,$iaddr) = sockaddr_in($sa);
    $ra = inet_ntoa($iaddr);
    $rh = gethostbyaddr($iaddr,AF_INET)||'';
  } elsif (sockaddr_family($sa) == AF_INET6) {
    $^W = 0; eval 'use Socket6'; $^W = 1;
    die "$prg: $@\n" if $@;
    (undef,$iaddr) = unpack_sockaddr_in6($sa);
    $ra = inet_ntop(AF_INET6,$iaddr);
    $rh = gethostbyaddr($iaddr,AF_INET6)||'';
  } else {
    die "$prg: unknown internet protocol\n";
  }
  $ra =~ s/.*:// if $ra =~ /\./;

  $peer = $rh.'['.$ra.']';
  print "connect from $peer\n" if $tty;
  alarm($timeout);

  if (my $hh = $ENV{HTTP_HEADER}) {
    # coming from fexsrv
    $hh =~ s/\r//g;
    ($req,@header) = split("\n",$hh);
    while ($_ = shift @header) {
      if (/^Content-Length:\s+(-?\d+)/i) { $size = $1 }
      if (/^Host:\s+(.+)/i)              { $host = $1 }
      if (/^User-Agent:\s+(.+)/i)        { $ua = $1 }
      if (/^X-Blocksize:\s+(\d+)/i)      { $xbs = $1 }
    }
  } else {
    $req = getaline($IN) or die "$: no request\n";
    print "<-- $req\n" if $opt_v;
    while (defined($_ = getaline($IN))) {
      print "<-- $_\n" if $opt_v;
      last if /^\s*$/;
      if (/^Content-Length:\s+(-?\d+)/i) { $size = $1 }
      if (/^Host:\s+(.+)/i)              { $host = $1 }
      if (/^User-Agent:\s+(.+)/i)        { $ua = $1 }
      if (/^X-Blocksize:\s+(\d+)/i)      { $xbs = $1 }
      if (/^Referer:\s+(.+)/i)           { $referer = $1 }
      push @header,$_;
    }
  }

  if ($log and open $log,'>>',$log) {
    printf {$log} "%s %s %d %s %s %s\n",&isodate,$peer,$size,$req,$ua,$referer;
    close $log;
  }

  my $xx = $_0.".xx";
  require $xx if -f $xx;

  if ($req =~ m:^GET (/tcpbm)?/(ip|version) HTTP/1:) {
    my $a = ($2 eq 'ip') ? "$ra\n" : "$version\n";
    $size = length $a;
    writeheader(
      'HTTP/1.0 200 OK',
      "Server: tcpbm-$version",
      "Content-Length: $size",
      'Content-Type: text/plain',
      'Cache-Control: no-cache, no-store, must-revalidate',
      'Pragma: no-cache',
      'Expires: 0',
    );
    syswrite $OUT,$a;
    return;
  }

  if ($req =~ /^GET\s+(.+)\s+HTTP\/1/) {
    dop($1,$xbs);
    return;
  }

  if ($req =~ /^POST\s+\/tcpbm(\?(\d+))? HTTP\/1/) {
    $mbin = $2;
  } elsif ($req =~ /^POST\s+\/tcpbm\?upload HTTP\/1/) {
    $upload = $req;
  } else {
    nvtprint(
      'HTTP/1.0 400 Bad Request',
      "Server: tcpbm-$version",
      '',
      "Bad Request $req"
    );
    exit;
  }

  if ($size) {

    $t0 = $t1 = $t2 = time;
    $tt = $B = 0;

    while ($B < $size or $size < 0) {
      $b = sysread $IN,$buf,$bs;
      unless ($b) {
        if ($opt_p) {
          status('received',$B,0,$tt,$B/$tt);
          warn "\n$prg: client has closed the connection\n";
        }
        return;
      }
      $B += $b;
      $bt += $b;
      $t2 = time;
      $tt = ($t2-$t0)||1;
      if ($t2-$t1>1) {
        alarm($timeout);
        if ($t1) {
          status($tty?'receiving':'received',$B,0,$tt,$bt/($t2-$t1));
          unless ($opt_b) {
            # adjust block size depending on link speed
            if ($bs>4096 and $B/$tt<65536) {
              $bs = 4096;
            } elsif ($bs<MB and $B/$tt>MB) {
              $bs = 4*MB;
            }
          }
        }
        $t1 = $t2;
        $bt = 0;
      }
    }

    status('received',$size,0,$tt,$size/$tt) if $opt_p;

    if ($upload) {
      my $data;
      if ($size < MB) {
        $data = sprintf "%d kB data received in %d s with %d kB/s",
          $size/kB,$tt,int($B/kB/$tt);
      } else {
        $data = sprintf "%d MB data received in %d s with %d kB/s",
          $size/MB,$tt,int($B/kB/$tt);
      }
      nvtprint(
        'HTTP/1.0 200 OK',
        "Server: tcpbm-$version",
        'Content-Type: text/html',
        ''
      );
      pq("
	<HTML>
	<HEAD><TITLE>tcpbm $host</TITLE></HEAD>
	<BODY>
	<h1>tcpbm upload test</h1>
	$data
	</BODY><HTML>
      ");
      exit;
    }

    return;
  }

  # GET request - now handled by dop(), see above
  if (defined $mbout) {
    $size = $mbout*MB if $mbout;

    # HTTP header
    writeheader(
      "HTTP/1.0 200 OK",
      "Server: tcpbm-$version",
      "Content-Length: $size",
      "Content-Type: application/octet-stream",
      "Cache-Control: no-cache, no-store, must-revalidate",
      "Pragma: no-cache",
      "Expires: 0",
    );

    alarm($timeout);

    $buf = stringgen($bs);
    $t0 = $t2 = time;
    $t1 = 0;
    $B = $bt = 0;

    while ($B < $size or $size < 0) {
#     $buf = stringgen($bs) if $opt_R; # slow!
      unless (syswrite $OUT,$buf) {
        last if $size < 0;
        die "\n$prg: client has closed the connection\n";
      }
      $B += $bs;
      $bt += $bs;
      $t2 = time;
      if ($t2-$t1>1) {
        $tt = ($t2-$t0)||1;
        alarm($timeout);
        status('sending',$B,$size,$tt,$bt/($t2-$t1));
        unless ($opt_b) {
          # smaller block size is better on slow links
          if ($t1 and $bs>4096 and $B/$tt<65536) {
            $bs = 4096;
            $buf = stringgen($bs);
          }
        }
        $t1 = $t2;
        $bt = 0;
      }
    }

    $tt = ($t2-$t0)||1;
    $size = $B if $size < 0;
    status("sent",$B,$size,$tt,$B/$tt);
    return;
  }
}


sub stringgen {
  my $c = shift;
  local $_;

  my @charset = split('',
    'ABCDEFGHIJKLAMOPQRSTUVWXYZ'.
    'abcdefghijklamopqrstuvwxyz'.
    '0123456789'.
    '{}[]()?!@#$%^~:;_=*+-|/'
  );

  if ($opt_R) {
    my $n = scalar(@charset);
    for (my $i=1; $i<=$c; $i++) {
      $_ .= $charset[int(rand($n))];
    }
  } else {
    $_ = '#' x $c;
  }
# s/.$/\n/;

  return $_;
}


# set up tcp/ip connection
sub tcpconnect {
  my ($server,$port) = @_;
  my $SH;

  $server = untaint($server);
  $port = untaint($port);

  unless ($opt_4 or $opt_6) {
    eval 'use Net::INET6Glue::INET_is_INET6';
  }

  if ($opt_6 or $server =~ /:.*:/) {
    eval 'use IO::Socket::INET6';
    if ($@) {
      die "$prg: missing IO::Socket::INET6 Perl module\n";
    }
    $SH = IO::Socket::INET6->new(
      Domain   => AF_INET6,
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
      Timeout  => 3,
    ) or return;
  } else {
    $SH = IO::Socket::INET->new(
      PeerAddr => $server,
      PeerPort => $port,
      Proto    => 'tcp',
      Timeout  => 3,
    ) or return;
  }

  autoflush $SH 1;
  print "TCPCONNECT to $server:$port\n" if $opt_v;
  return $SH;
}


sub mtime {
  my @d = localtime((stat shift)[9]);
  return sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
}


sub untaint {
  my @a = ();
  local $_;
  foreach (@_) {
    /(.*)/;
    push @a,$1;
  }
  if (scalar(@a) == 1) {
    return $a[0];
  } else {
    return @a;
  }
}


# read one text line unbuffered
sub getaline {
  my $s = shift;
  my $line = '';
  my $c;

  # must use sysread to avoid perl line buffering
  while (sysread $s,$c,1) {
    $line .= $c;
    last if $c eq "\n";
  }

  $line =~ s/[\r\n]//g;
  return $line;
}


sub getserverreply {
  my $sp = shift;
  my $nbs = '';
  my $response = '';;
  local $_;

  while (defined($_ = getaline($SH))) {
    $response ||= $_;
    $nbs = $_ if /^Server: (tcpbm|fexsrv)/;
    print "<-- $_\n" if $opt_v;
    last if /^\s*$/;
  }

  die "$prg: no tcpbm server on $sp\n" unless $nbs;
  return $response;
}


sub status {
  my ($text,$B,$size,$s,$Bs) = @_;
  my ($kBs,$MBs,$cr);

  return if $opt_x; # xinetd!

  $kBs = int($Bs/kB);
  $MBs = int($Bs/MB);
  $text .= ':';

  if ($tty) {
    if ($text =~ /ing:$/) {
      if ($kBs>9999) {
        if ($size > 0) {
          printf "%-10s %8s MB of %d MB in %d s, %d MB/s        \r",
            $text,int($B/MB),$size/MB,$s,$MBs;
        } else {
          printf "%-10s %8s MB in %d s, %d MB/s        \r",
            $text,int($B/MB),$s,$MBs;
        }
      } else {
        if ($size > 0) {
          printf "%-10s %8s MB of %d MB in %d s, %d kB/s        \r",
            $text,int($B/MB),$size/MB,$s,$kBs;
        } else {
          printf "%-10s %8s MB in %d s, %d kB/s        \r",
            $text,int($B/MB),$s,$kBs;
        }
      }
    } else {
      if ($kBs>9999) {
        printf "%-10s %8s MB in %3d s = %6d MB/s                 \n",
          $text,int($B/MB),$s,$MBs;
      } else {
        printf "%-10s %8s MB in %3d s = %6d kB/s                 \n",
          $text,int($B/MB),$s,$kBs;
      }
    }
  } elsif (int($B/MB) or int($s)) {
    printf "%-10s %5d MB in %2d s = %4d MB/s\n",$text,$B/MB,$s,$MBs;
  }
}


sub dop {
  my $doc = shift;
  my $xbs = shift;
  my $bs = ($xbs||$opt_b||64)*kB;
  my $port = $ENV{PORT}||591;
  my ($size,$file,$hp,$xr,$public);
  local $_;

  $host =~ /:(\d+)/ and $port = $1;
  $host =~ s/:591$//;
  $hp = ($port == 80) ? $host : "$host:$port";

  # http://stackoverflow.com/questions/49547/making-sure-a-web-page-is-not-cached-across-all-browsers

  if ($doc =~ /\/((\d+)\.(dd|rd))$/) {
    $file = $1;
    $size = $2*MB;
    if ($opt_R = $3 eq 'rd') {
      $xr = "X-Random: yes";
    } else {
      $xr = "X-Random: no";
    }

    writeheader(
      'HTTP/1.0 200 OK',
      "Server: tcpbm-$version",
      "Content-Disposition: attachment; filename=\"$file\"",
      "Content-Length: $size",
      'Content-Type: application/octet-stream',
      'Cache-Control: no-cache, no-store, must-revalidate',
      'Pragma: no-cache',
      'Expires: 0',
      "X-Blocksize: $xbs",
      $xr
    );

    $SIG{ALRM} = sub { die "TIMEOUT\n" };
    my $buf = stringgen($bs);
    my $B = 0;
    my $tt = 0;
    my $t0 = time;
    my $t1 = $t0;
    my $t2 = $t0;
    
    $buf =~ s/.$/\n/;
    
    for (;;) {
#     $buf = stringgen($bs) if $opt_R; # slow!
      syswrite $OUT,$buf or last;
      $B += $bs;
      $t2 = time;
      if ($t2-$t1 > 1) {
        alarm($timeout);
        $tt = ($t2-$t0)||1;
        status('sending',$B,0,$tt,$B/$tt);
        $t1 = $t2;
        unless ($opt_b) {
          # adjust block size depending on link speed
          if ($bs>4096 and $B/$tt<65536) {
            $bs = 4096;
            $buf = stringgen($bs);
          } elsif ($bs<MB and $B/$tt>MB) {
            $bs = 4*MB;
            $buf = stringgen($bs);
          }
        }
      }
      last if $B >= $size;
    }
    $tt = (time-$t0)||1;
    status("sent",$B,$size,$tt,$B/$tt);
    return;
  }

  if ($doc =~ /\/((\d+)\.html)$/) {
    my $mb = $2;
    $size = $2*MB;
    my $kbs = $bs/kB;
    writeheader(
      'HTTP/1.0 200 OK',
      "Server: tcpbm-$version",
      'Content-Type: text/html',
      'Cache-Control: no-cache, no-store, must-revalidate',
      'Pragma: no-cache',
      'Expires: 0',
    );
    pq("
      <HTML>
      <HEAD><TITLE>tcpbm $host</TITLE></HEAD>
      <BODY>
      <script>
        var t0 = Date.now();
        var kB = $size/1024;
      </script>
      <h1>tcpbm : $mb MB</h1>
      This page has $mb MB in size.
      <p>
      Downloading ... ($kbs kB each #)<br>
    ");

    # http://www.fileformat.info/info/unicode/char/200b/index.htm
    $_ = '<!-- '.stringgen($bs-17).' -->#&#8203;';
    $SIG{ALRM} = sub { die "TIMEOUT\n" };
    my $s = 0;
    my $t0 = time;
    my $t1 = $t0;
    my $t2 = $t0;
    for ($s = 0; $s < $size; $s += $bs) {
      if ($t2 = time > $t1) {
        alarm($timeout);
        $t1 = $t2;
      }
      syswrite $OUT,$_ or exit;
    }
    my $tt = time-$t0;
    my $kBs = int($size/kB/$tt);
    $tt = int($tt);
    pq(qq'
      <br>
      ready!<p>
      Transfer time: <label id="tt">$tt</label> s<br>
      Transfer speed: <label id="kbs">$kBs</label> kB/s<br>
      Your ip: $ra<br>
      <script>
        var tt = (Date.now()-t0)/1000;
        document.getElementById("tt").innerHTML = Math.floor(tt);
        document.getElementById("kbs").innerHTML = Math.floor(kB/tt);
      </script>
      </BODY></HTML>
    ');
    return;
  }

  if ($servertest and $doc =~ /test=(\w[\w.:-]+)$/) {
    my $server = $1;
    writeheader(
      'HTTP/1.0 200 OK',
      "Server: tcpbm-$version",
      'Content-Type: text/html',
      'Cache-Control: no-cache, no-store, must-revalidate',
      'Pragma: no-cache',
      'Expires: 0',
    );
    pq("
      <HTML>
      <HEAD><TITLE>tcpbm $host</TITLE></HEAD>
      <BODY>
      <h1>tcpbm $server</h1>
      <p>
      <pre>
    ");
    $| = 1;
    alarm(0);
    if (open my $tcpbm,'-|',$_0,'-s','10',$server) {
      while (<$tcpbm>) {
        print;
      }
      close $tcpbm;
    }
    return;
  }

  if ($doc =~ /\/tcpbm.pl$/) {
    open $_0,$_0 or error_404($doc,$hp);
    local $/;
    $_ = <$_0>;
    close $_0;
    my @d = gmtime((stat $_0)[9]);
    $version = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
    s/version = 20240124/version = $version/;
    my $size = length;
    writeheader(
      'HTTP/1.0 200 OK',
      "Server: tcpbm-$version",
      "Content-Length: $size",
      'Content-Type: application/octet-stream',
    );
    print;
    return;
  }

  if ($doc =~ /\/tcpbm.exe$/) {
    my $exe = basename($_0).'.exe';
    $size = -s $exe;
    open $exe,$exe or error_404($doc,$hp);
    writeheader(
      'HTTP/1.0 200 OK',
      "Server: tcpbm-$version",
      "Content-Length: $size",
      'Content-Type: application/octet-stream',
    );
    while (read $exe,$_,$bs) { syswrite $OUT,$_ }
    return;
  }

  # http://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.xhtml?&page=11

  if ($doc =~ /\/([\w_-]+\.html|tcpbm)?$/) {
    my $html = $1||'tcpbm';
    my $thp = ($port == 80 or $port == 591) ? $host : "$host:$port";
    my $whp; # = ($port == 80) ? $host : "$host:$port";
    local $/;
    $html =~ s/(\.html)?$/.html/;
    if (open $html,$html) {
      $_ = <$html>;
      close $html;
    } else {
      $_ = <DATA>;
    }

    if ($port == 80) {
      $whp = "http://$host";
    } elsif ($port == 443) {
      $whp = "https://$host";
    } else {
      $whp = "http://$host:$port";
    }

    if ($ENV{STUNNEL}) {
      $public = 'https://flupp.belwue.de/tcpbm/public.html';
    } else {
      $public = 'http://flupp.belwue.de:591/public.html';
    }
    $public = qq'<iframe width="100%" height="100%" frameborder="0" src="$public"></iframe>';

    s/\$public\$/$public/;
    s/\$host\$/$host/g;
    s/\$thp\$/$thp/g;
    s/\$whp\$/$whp/g;

    $size = length;
    writeheader(
      'HTTP/1.0 200 OK',
      "Server: tcpbm-$version",
      "Content-Length: $size",
      'Content-Type: text/html',
    );
    syswrite $OUT,$_;
    return;
  }

  error_404($doc,$hp);
}

sub nvtprint {
  local $_;
  foreach (@_) {
    syswrite $OUT,"$_\r\n";
  }
}


sub error_404 {
  my $uri = shift;
  my $hp = shift;
  $uri =~ s/&/&amp;/g;
  $uri =~ s/</&lt;/g;
  nvtprint(
    'HTTP/1.0 404 Not Found',
    "Server: tcpbm-$version",
    'Content-Type: text/plain',
    '',
    "ERROR 404: The requested URI $uri was not found on $hp"
  );
  exit;
}


sub pq {
  local $_ = shift;
  s/^\n//;
  s/^\s+//mg;
  syswrite $OUT,$_;
}


sub isodate {
  my @d = localtime time;
  return sprintf('%d-%02d-%02d %02d:%02d:%02d',
                 $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
}


sub writeheader {
  my @hh = @_;
  local $_;

  push @hh,'';

  foreach (@hh) {
    print "--> $_\n" if $opt_v;
    syswrite $OUT,"$_\r\n" or die "$prg: peer has closed the connection\n";
  }
}


sub searchpath {
  my ($prg,$path,@PATH);

  @PATH = split(':',$ENV{PATH});
  foreach $prg (@_) {
    foreach $path (@PATH) {
      return $prg if -x "$path/$prg";
    }
  }
  return '';
}


__END__

<HTML>
<HEAD><TITLE>tcpbm $host$</TITLE></HEAD>
<BODY>
<h1>tcp (http) benchmark send&receive</h1>
<pre>
<a href ="https://fex.belwue.de/fstools/tcpbm.html">usage</a>: tcpbm $thp$

example:

framstag@tux:~: <b>tcpbm $thp$</b>
received: 1122 MB in 10 s = 112 MB/s
sent:      913 MB in 10 s =  91 MB/s

</pre>
<p>
<a href ="/tcpbm/tcpbm.pl">download tcpbm</a><br>
<p><hr><p>
<a href ="/tcpbm/1.html">Test download of 1 MB<a><br>
<a href ="/tcpbm/10.html">Test download of 10 MB<a><br>
<a href ="/tcpbm/100.html">Test download of 100 MB<a><br>
<a href ="/tcpbm/500.html">Test download of 500 MB<a><br>
<p><hr><p>
You may also use $whp$/tcpbm/NUMBER.dd to download any number of
MB dummy data, for example:
<pre>
wget -O /dev/null $whp$/tcpbm/100.dd

curl $whp$/tcpbm/100.dd >/dev/null
</pre>
<p>
To force random data and to achieve more realistic benchmark rates on
auto-compression network links like VPN, use NUMBER.rd, for example:
<pre>
wget -O /dev/null $whp$/tcpbm/100.rd

curl $whp$/tcpbm/100.rd >/dev/null
</pre>
<p><hr><p>
<form action="/tcpbm?upload" method="post" enctype="multipart/form-data">
  Test upload: <input type="file" name="file" size="80"><br>
  <input type="submit" value="submit">
</form>
</BODY></HTML>