t/12-unicode.t

   1 #!perl -T
   2
   3 use Test::More tests => 7 * 3;
   4
   5 use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
   6
   7 use IPC::MorseSignals qw/msend mrecv mreset/;
   8
   9 use utf8;
  10
  11 my $lives = 5;
  12
  13 sub spawn {
  14  --$lives;
  15  die 'forked too many times' if $lives < 0;
  16  pipe my $rdr, my $wtr or die "pipe() failed: $!";
  17  my $pid = fork;
  18  if (!defined $pid) {
  19   die "fork() failed: $!";
  20  } elsif ($pid == 0) {
  21   close $rdr or die "close() failed: $!";
  22   binmode $wtr, ':utf8';
  23   my $block = 0;
  24   my $s = mrecv local %SIG, cb => sub {
  25    if ($block) {
  26     $block = 0;
  27    } else {
  28     select $wtr; $| = 1;
  29     print $wtr $_[1], "\n";
  30     select $wtr; $| = 1;
  31    }
  32   };
  33   $SIG{HUP} = sub { mreset $s };
  34   $SIG{__WARN__} = sub { $block = 1 };
  35   1 while 1;
  36   exit EXIT_FAILURE;
  37  }
  38  close $wtr or die "close() failed: $!";
  39  binmode $rdr, ':utf8';
  40  return ($pid, $rdr);
  41 }
  42
  43 sub slaughter {
  44  my ($pid) = @_;
  45  kill SIGINT  => $pid;
  46  kill SIGTERM => $pid;
  47  kill SIGKILL => $pid;
  48  waitpid $pid, 0;
  49 }
  50
  51 my ($pid, $rdr) = spawn;
  52
  53 sub trysend8 {
  54  my ($msg, $desc) = @_;
  55  my $speed = 2 ** 16;
  56  my $ok = 0;
  57  $desc .= ' (unicode)';
  58  while (!$ok && (($speed /= 2) >= 1)) {
  59   my $r = '';
  60   eval {
  61    local $SIG{ALRM} = sub { die 'timeout' };
  62    local $SIG{__WARN__} = sub { die 'do not want warnings' };
  63    my $a = (int(100 * (3 * length $msg) / $speed) || 1);
  64    $a = 10 if $a > 10;
  65    alarm $a;
  66    kill SIGHUP => $pid;
  67    msend $msg => $pid, speed => $speed, utf8 => 1, sign => 0;
  68    $r = <$rdr>;
  69   };
  70   kill SIGHUP => $pid if $@;
  71   alarm 0;
  72   if (!defined $r) { # Something bad happened, respawn
  73    close $rdr or die "close() failed: $!";
  74    slaughter $pid;
  75    ($pid, $rdr) = spawn;
  76    $speed *= 2;       # Retry this speed
  77   } else {
  78    chomp $r;
  79    if ($r eq $msg) {
  80     $ok = 1;
  81    } else {
  82     kill SIGHUP => $pid;
  83    }
  84   }
  85  }
  86  ok($ok, $desc);
  87 }
  88
  89 for (1 .. 3) {
  90  trysend8 'hello', 'ascii';
  91  trysend8 "\0" x 10, 'few bits';
  92  trysend8 "\x{FF}" x 10, 'lots of bits';
  93  trysend8 "a\0b", 'null character';
  94  trysend8 'éàùçà', 'extended';
  95  trysend8 '€€€', 'unicode';
  96  trysend8 'a€bécàd€e', 'mixed';
  97 }
  98
  99 slaughter $pid;