1# -*- perl -*- 2# 3# $Id: threadm.t,v 1.3 2007/05/16 13:58 mhn $ 4# 5 6require 5.004; 7use strict; 8 9use IO::Socket (); 10use Config (); 11use Net::Daemon::Test (); 12use Fcntl (); 13use Config (); 14 15 16$| = 1; 17$^W = 1; 18 19 20if (!$Config::Config{'usethreads'} || 21 $Config::Config{'usethreads'} ne 'define' || 22 !eval { require Thread }) { 23 print "1..0\n"; 24 exit 0; 25} 26 27 28my($handle, $port); 29if (@ARGV) { 30 $port = shift @ARGV; 31} else { 32 ($handle, $port) = Net::Daemon::Test->Child 33 (10, $^X, '-Iblib/lib', '-Iblib/arch', 't/server', 34 '--mode=threads', 'logfile=stderr', 'debug'); 35} 36 37 38my $regexpLock = 1; 39sub IsNum { 40 # 41 # Regular expressions aren't thread safe, as of 5.00502 :-( 42 # 43 my $lock = lock($regexpLock); 44 my $str = shift; 45 (defined($str) && $str =~ /(\d+)/) ? $1 : undef; 46} 47 48 49sub ReadWrite { 50 my $fh = shift; my $i = shift; my $j = shift; 51 die "Child $i: Error while writing $j: $!" 52 unless $fh->print("$j\n") and $fh->flush(); 53 my $line = $fh->getline(); 54 die "Child $i: Error while reading: " . $fh->error() . " ($!)" 55 unless defined($line); 56 my $num = IsNum($line); 57 die "Child $i: Cannot parse result: $line" 58 unless defined($num); 59 die "Child $i: Expected " . ($j*2) . ", got $num" 60 unless ($num == $j*2); 61} 62 63 64sub MyChild { 65 my $i = shift; 66 67 eval { 68 my $fh = IO::Socket::INET->new('PeerAddr' => '127.0.0.1', 69 'PeerPort' => $port); 70 die "Cannot connect: $!" unless defined($fh); 71 for (my $j = 0; $j < 1000; $j++) { 72 ReadWrite($fh, $i, $j); 73 } 74 }; 75 if ($@) { 76 print STDERR $@; 77 return 0; 78 } 79 return 1; 80} 81 82my @threads = (); 83 84if (!$Config::Config{'usethreads'} || 85 $Config::Config{'usethreads'} ne 'define') { 86 87 for (my $i = 0; $i < 10; $i++) { 88 #print "Spawning child $i.\n"; 89 my $tid = Thread->new(\&MyChild, $i); 90 if (!$tid) { 91 print STDERR "Failed to create new thread: $!\n"; 92 exit 1; 93 } 94 push(@threads, $tid); 95 } 96 97} 98eval { alarm 1; alarm 0 }; 99alarm 120 unless $@; 100for (my $i = 1; $i <= 10; $i++) { 101 if (@threads) { 102 my $tid = shift @threads; 103 if ($tid->join()) { 104 print "ok $i\n"; 105 } else { 106 print "not ok $i\n"; 107 } 108 } else { 109 print "ok $i\n"; # Fake output for Windows when 110 # Perl -V reveals usethreads 111 } 112} 113 114END { 115 if ($handle) { 116 print "Terminating server.\n"; 117 $handle->Terminate(); 118 undef $handle; 119 } 120 unlink "ndtest.prt"; 121} 122