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