]> git.vpit.fr Git - perl/modules/IPC-MorseSignals.git/blob - t/lib/IPC/MorseSignals/TestSuite.pm
Get rid of the indirect notation
[perl/modules/IPC-MorseSignals.git] / t / lib / IPC / MorseSignals / TestSuite.pm
1 package IPC::MorseSignals::TestSuite;
2
3 use strict;
4 use warnings;
5
6 use Data::Dumper;
7 use POSIX qw/pause SIGKILL EXIT_FAILURE/;
8
9 use IPC::MorseSignals::Emitter;
10 use IPC::MorseSignals::Receiver;
11
12 use base qw/Exporter/;
13
14 our @EXPORT_OK = qw/try bench init cleanup/;
15
16 $Data::Dumper::Indent = 0;
17
18 my ($lives, $pid, $rdr);
19
20 sub slaughter;
21 local $SIG{INT} = sub { slaughter };
22
23 sub diag { warn "# @_" }
24
25 sub spawn {
26  --$lives;
27  die 'forked too many times' if $lives < 0;
28  pipe $rdr, my $wtr or die "pipe() failed: $!";
29  $pid = fork;
30  if (!defined $pid) {
31   die "fork() failed: $!";
32  } elsif ($pid == 0) {
33   local %SIG;
34   close $rdr or die "close() failed: $!";
35   select $wtr;
36   $| = 1;
37   my $rcv = IPC::MorseSignals::Receiver->new(\%SIG, done => sub {
38    my $msg = Dumper($_[1]);
39    $msg =~ s/\n\r/ /g;
40    print $wtr "$msg\n";
41   });
42   $SIG{__WARN__} = sub {
43    my $warn = join '', @_;
44    $warn =~ s/\n\r/ /g;
45    print $wtr "!warn:$warn\n";
46   };
47   print $wtr "!ok\n";
48   pause while 1;
49   exit EXIT_FAILURE;
50  }
51  close $wtr or die "close() failed: $!";
52  my $oldfh = select $rdr;
53  $| = 1;
54  select $oldfh;
55  my $t = <$rdr>;
56 }
57
58 sub slaughter {
59  if (defined $rdr) {
60   close $rdr or die "close() falied: $!";
61   undef $rdr;
62  }
63  if ($pid) {
64   kill SIGKILL => $pid;
65   my $kid;
66   do {
67    $kid = waitpid $pid, 0;
68   } while ($kid != $pid && $kid != -1);
69   undef $pid;
70  }
71 }
72
73 sub respawn {
74  diag "respawn ($lives lives left)";
75  slaughter;
76  spawn;
77 }
78
79 sub init {
80  ($lives) = @_;
81  $lives ||= 10;
82  undef $pid;
83  undef $rdr;
84  spawn;
85 }
86
87 sub cleanup { slaughter }
88
89 my $snd = IPC::MorseSignals::Emitter->new;
90
91 sub try {
92  my ($msg) = @_;
93  my $speed = 2 ** 10;
94  my $dump = Dumper($msg);
95  1 while chomp $dump;
96  $dump =~ s/\n\r/ /g; 
97  $snd->reset;
98  my $len = 0;
99  while (($speed /= 2) >= 1) {
100   $snd->post($msg);
101   $len = $snd->len;
102   my $a = 1 + (int($len / $speed) || 1);
103   last unless $a <= 20;
104   $snd->speed($speed);
105   my $r = '';
106   eval {
107    local $SIG{ALRM} = sub { die 'timeout' };
108    local $SIG{__WARN__} = sub { $a = alarm 0; die 'do not want warnings' };
109    alarm $a;
110    $snd->send($pid);
111    $r = <$rdr>;
112    $a = alarm 0;
113   };
114   if (defined $r) {
115    1 while chomp $r;
116    return 1, $speed, $len if $r eq $dump;
117   }
118   $snd->reset;
119   respawn;
120  }
121  return 0, $speed, $len;
122 }
123
124 sub bench {
125  my ($l, $n, $res) = @_;
126  my $speed = 2 ** 16;
127  my $ok = 0;
128  my @alpha = ('a' .. 'z');
129  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
130  my $dump = Dumper($msg);
131  1 while chomp $dump;
132  $dump =~ s/\n\r/ /g;
133  my $desc_base = "$l bytes sent $n time" . ('s' x ($n != 1));
134  while (($ok < $n) && (($speed /= 2) >= 1)) {
135   $ok = 0;
136   my $desc = "$desc_base at $speed bits/s";
137   diag "try $desc...";
138 TRY:
139   for (1 .. $n) {
140    $snd->post($msg);
141    my $a = 1 + (int($snd->len / $speed) || 1);
142    $snd->speed($speed);
143    my $r = '';
144    eval {
145     local $SIG{ALRM} = sub { die 'timeout' };
146     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
147     alarm $a;
148     $snd->send($pid);
149     $r = <$rdr>;
150     alarm 0;
151    };
152    if (defined $r) {
153     1 while chomp $r;
154     if ($r eq $dump) {
155      ++$ok;
156      next TRY;
157     }
158    }
159    $snd->reset;
160    respawn;
161    last TRY;
162   }
163  }
164  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
165  return ($ok == $n);
166 }
167
168 1;