samples/bench.pl

   1 #!/usr/bin/perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
   7
   8 use lib qw{blib/lib};
   9
  10 use IPC::MorseSignals qw/msend mrecv mreset/;
  11
  12 my $lives = 100;
  13
  14 sub spawn {
  15  --$lives;
  16  die 'forked too many times' if $lives < 0;
  17  pipe my $rdr, my $wtr or die "pipe() failed: $!";
  18  my $pid = fork;
  19  if (!defined $pid) {
  20   die "fork() failed: $!";
  21  } elsif ($pid == 0) {
  22   local %SIG;
  23   close $rdr or die "close() failed: $!";
  24   select $wtr;
  25   $| = 1;
  26   my $rcv = mrecv %SIG, cb => sub { print $wtr $_[1], "\n" };
  27   my $ppid = getppid;
  28   $SIG{ALRM} = sub { alarm 1; kill SIGHUP => $ppid };
  29   alarm 1;
  30   $SIG{HUP}  = sub { alarm 0; mreset $rcv };
  31   1 while 1;
  32   exit EXIT_FAILURE;
  33  }
  34  my $ready = 0;
  35  local $SIG{HUP} = sub { $ready = 1 };
  36  sleep 1 until $ready;
  37  close $wtr or die "close() failed: $!";
  38  my $oldfh = select $rdr;
  39  $| = 1;
  40  select $oldfh;
  41  return ($pid, $rdr);
  42 }
  43
  44 sub slaughter {
  45  my ($pid, $rdr) = @_;
  46  if (defined $rdr) {
  47   close $rdr or die "close() failed: $!";
  48  }
  49  if (defined $pid) {
  50   kill SIGINT  => $pid;
  51   kill SIGTERM => $pid;
  52   kill SIGKILL => $pid;
  53   waitpid $pid, 0;
  54  }
  55 }
  56
  57 my @res;
  58
  59 my ($pid, $rdr) = spawn;
  60
  61 sub tryspeed {
  62  my ($l, $n) = @_;
  63  my $speed = 2 ** 16;
  64  my $ok = 0;
  65  my @alpha = ('a' .. 'z');
  66  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
  67  while (($ok < $n) && (($speed /= 2) >= 1)) {
  68   print STDERR "$n sends of $l bytes at $speed bits/s";
  69 TRY:
  70   for (1 .. $n) {
  71    print STDERR '.';
  72    my $r = '';
  73    eval {
  74     local $SIG{ALRM} = sub { print STDERR "timeout\n"; die };
  75     my $a = (int(100 * (3 * $l) / $speed) || 1);
  76     $a = 10 if $a > 10;
  77     alarm $a;
  78     msend $msg => $pid, speed => $speed;
  79     $r = <$rdr>;
  80    };
  81    kill SIGHUP => $pid if $@;
  82    alarm 0;
  83    if (!defined $r) { # Something bad happened, respawn
  84     print STDERR "oops\n";
  85     slaughter $pid, $rdr;
  86     ($pid, $rdr) = spawn;
  87     redo TRY;         # Retry this send
  88    } else {
  89     chomp $r;
  90     if ($r eq $msg) {
  91      ++$ok;
  92     } else {
  93      print STDERR "transfer error\n";
  94      kill SIGHUP => $pid;
  95      last TRY;
  96     }
  97    }
  98   }
  99  }
 100  my $desc = "$l bytes sent $n times";
 101  if ($speed >= 1) {
 102   print STDERR " OK\n\n";
 103   push @res, "$desc at $speed bits/s";
 104  } else {
 105   print STDERR " FAILED\n\n";
 106   push @res, "$desc FAILED";
 107  }
 108 }
 109
 110 tryspeed 4,    1;
 111 tryspeed 4,    4;
 112 tryspeed 4,    16;
 113 tryspeed 4,    64;
 114 tryspeed 4,    256;
 115 tryspeed 16,   1;
 116 tryspeed 16,   4;
 117 tryspeed 16,   16;
 118 tryspeed 16,   64;
 119 tryspeed 64,   1;
 120 tryspeed 64,   4;
 121 tryspeed 64,   16;
 122 tryspeed 256,  1;
 123 tryspeed 256,  4;
 124 tryspeed 1024, 1;
 125
 126 print STDERR "=== Summary ===\n";
 127 print STDERR "$_\n" for @res;