1# -*- perl -*- 2# 3# $Id: Test.pm,v 1.2 1999/08/12 14:28:57 joe Exp $ 4# 5# Net::Daemon - Base class for implementing TCP/IP daemons 6# 7# Copyright (C) 1998, Jochen Wiedmann 8# Am Eisteich 9 9# 72555 Metzingen 10# Germany 11# 12# Phone: +49 7123 14887 13# Email: joe@ispsoft.de 14# 15# 16# This module is free software; you can redistribute it and/or modify 17# it under the terms of the GNU General Public License as published by 18# the Free Software Foundation; either version 2 of the License, or 19# (at your option) any later version. 20# 21# This module is distributed in the hope that it will be useful, 22# but WITHOUT ANY WARRANTY; without even the implied warranty of 23# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 24# GNU General Public License for more details. 25# 26# You should have received a copy of the GNU General Public License 27# along with this module; if not, write to the Free Software 28# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 29# 30############################################################################ 31 32package Net::Daemon::Test; 33 34use strict; 35require 5.004; 36 37use Net::Daemon (); 38use Symbol (); 39use File::Basename (); 40 41 42$Net::Daemon::Test::VERSION = '0.03'; 43@Net::Daemon::Test::ISA = qw(Net::Daemon); 44 45 46=head1 NAME 47 48Net::Daemon::Test - support functions for testing Net::Daemon servers 49 50 51=head1 SYNOPSIS 52 53 # This is the server, stored in the file "servertask". 54 # 55 # Create a subclass of Net::Daemon::Test, which in turn is 56 # a subclass of Net::Daemon 57 use Net::Daemon::Test (); 58 package MyDaemon; 59 @MyDaemon::ISA = qw(Net::Daemon::Test); 60 61 sub Run { 62 # Overwrite this and other methods, as you like. 63 } 64 65 my $self = Net::Daemon->new(\%attr, \@options); 66 eval { $self->Bind() }; 67 if ($@) { 68 die "Server cannot bind: $!"; 69 } 70 eval { $self->Run() }; 71 if ($@) { 72 die "Unexpected server termination: $@"; 73 } 74 75 76 # This is the client, the real test script, note we call the 77 # "servertask" file below: 78 # 79 # Call the Child method to spawn a child. Don't forget to use 80 # the timeout option. 81 use Net::Daemon::Test (); 82 83 my($handle, $port) = eval { 84 Net::Daemon::Test->Child(5, # Number of subtests 85 'servertask', '--timeout', '20') 86 }; 87 if ($@) { 88 print "not ok 1 $@\n"; 89 exit 0; 90 } 91 print "ok 1\n"; 92 93 # Real tests following here 94 ... 95 96 # Terminate the server 97 $handle->Terminate(); 98 99 100=head1 DESCRIPTION 101 102This module is a frame for creating test scripts of Net::Daemon based 103server packages, preferrably using Test::Harness, but that's your 104choice. 105 106A test consists of two parts: The client part and the server part. 107The test is executed by the child part which invokes the server part, 108by spawning a child process and invoking an external Perl script. 109(Of course we woultn't need this external file with fork(), but that's 110the best possibility to make the test scripts portable to Windows 111without requiring threads in the test script.) 112 113The server part is a usual Net::Daemon application, for example a script 114like dbiproxy. The only difference is that it derives from 115Net::Daemon::Test and not from Net::Daemon, the main difference is that 116the B<Bind> method attempts to allocate a port automatically. Once a 117port is allocated, the number is stored in the file "ndtest.prt". 118 119After spawning the server process, the child will wait ten seconds 120(hopefully sufficient) for the creation of ndtest.prt. 121 122 123=head1 AVAILABLE METHODS 124 125=head2 Server part 126 127=over 8 128 129=item Options 130 131Adds an option B<--timeout> to Net::Daemon: The server's Run method 132will die after at most 20 seconds. 133 134=cut 135 136sub Options ($) { 137 my $self = shift; 138 my $options = $self->SUPER::Options(); 139 $options->{'timeout'} = { 140 'template' => 'timeout=i', 141 'description' => '--timeout <secs> ' 142 . "The server will die if the test takes longer\n" 143 . ' than this number of seconds.' 144 }; 145 $options; 146} 147 148 149=pod 150 151=item Bind 152 153(Instance method) This is mainly the default Bind method, but it attempts 154to find and allocate a free port in two ways: First of all, it tries to 155call Bind with port 0, most systems will automatically choose a port in 156that case. If that seems to fail, ports 30000-30049 are tried. We 157hope, one of these will succeed. :-) 158 159=cut 160 161sub Bind ($) { 162 # First try: Pass unmodified options to Net::Daemon::Bind 163 my $self = shift; 164 my($port, $socket); 165 $self->{'proto'} ||= $self->{'localpath'} ? 'unix' : 'tcp'; 166 if ($self->{'proto'} eq 'unix') { 167 $port = $self->{'localpath'} || die "Missing option: localpath"; 168 $socket = eval { 169 IO::Socket::UNIX->new('Local' => $port, 170 'Listen' => $self->{'listen'} || 10); 171 } 172 } else { 173 my @socket_args = 174 ( 'LocalAddr' => $self->{'localaddr'}, 175 'LocalPort' => $self->{'localport'}, 176 'Proto' => $self->{'proto'} || 'tcp', 177 'Listen' => $self->{'listen'} || 10, 178 'Reuse' => 1 179 ); 180 $socket = eval { IO::Socket::INET->new(@socket_args) }; 181 if ($socket) { 182 $port = $socket->sockport(); 183 } else { 184 $port = 30049; 185 while (!$socket && $port++ < 30060) { 186 $socket = eval { IO::Socket::INET->new(@socket_args, 187 'LocalPort' => $port) }; 188 } 189 } 190 } 191 if (!$socket) { 192 die "Cannot create socket: " . ($@ || $!); 193 } 194 195 # Create the "ndtest.prt" file so that the child knows to what 196 # port it may connect. 197 my $fh = Symbol::gensym(); 198 if (!open($fh, ">ndtest.prt") || 199 !(print $fh $port) || 200 !close($fh)) { 201 die "Error while creating 'ndtest.prt': $!"; 202 } 203 $self->Debug("Created ndtest.prt with port $port\n"); 204 $self->{'socket'} = $socket; 205 206 if (my $timeout = $self->{'timeout'}) { 207 eval { alarm $timeout }; 208 } 209 210 $self->SUPER::Bind(); 211} 212 213 214=pod 215 216=item Run 217 218(Instance method) Overwrites the Net::Daemon's method by adding a timeout. 219 220=back 221 222sub Run ($) { 223 my $self = shift; 224 $self->Run(); 225} 226 227 228=head2 Client part 229 230=over 8 231 232=item Child 233 234(Class method) Attempts to spawn a server process. The server process is 235expected to create the file 'ndtest.prt' with the port number. 236 237The method returns a process handle and a port number. The process handle 238offers a method B<Terminate> that may later be used to stop the server 239process. 240 241=back 242 243=cut 244 245sub Child ($$@) { 246 my $self = shift; my $numTests = shift; 247 my($handle, $pid); 248 249 my $args = join(" ", @_); 250 print "Starting server: $args\n"; 251 252 unlink 'ndtest.prt'; 253 254 if ($args =~ /\-\-mode=(?:ithread|thread|single)/ && $^O =~ /mswin32/i) { 255 require Win32; 256 require Win32::Process; 257 my $proc = $_[0]; 258 259 # Win32::Process seems to require an absolute path; this includes 260 # a program extension like ".exe" 261 my $path; 262 my @pdirs; 263 264 File::Basename::fileparse_set_fstype("MSWin32"); 265 if (File::Basename::basename($proc) !~ /\./) { 266 $proc .= ".exe"; 267 } 268 if ($proc !~ /^\w\:\\/ && $proc !~ /^\\/) { 269 # Doesn't look like an absolute path 270 foreach my $dir (@pdirs = split(/;/, $ENV{'PATH'})) { 271 if (-x "$dir/$proc") { 272 $path = "$dir/$proc"; 273 last; 274 } 275 } 276 if (!$path) { 277 print STDERR ("Cannot find $proc in the following" 278 , " directories:\n"); 279 foreach my $dir (@pdirs) { 280 print STDERR " $dir\n"; 281 } 282 print STDERR "Terminating.\n"; 283 exit 1; 284 } 285 } else { 286 $path = $proc; 287 } 288 289 print "Starting process: proc = $path, args = ", join(" ", @_), "\n"; 290 if (!&Win32::Process::Create($pid, $path, 291 join(" ", @_), 0, 292 Win32::Process::DETACHED_PROCESS(), 293 ".")) { 294 die "Cannot create child process: " 295 . Win32::FormatMessage(Win32::GetLastError()); 296 } 297 $handle = bless(\$pid, "Net::Daemon::Test::Win32"); 298 } else { 299 $pid = eval { fork() }; 300 if (defined($pid)) { 301 # Aaaah, Unix! :-) 302 if (!$pid) { 303 # This is the child process, spawn the server. 304 exec @_; 305 } 306 $handle = bless(\$pid, "Net::Daemon::Test::Fork"); 307 } else { 308 print "1..0\n"; 309 exit 0; 310 } 311 } 312 313 print "1..$numTests\n" if defined($numTests); 314 for (my $secs = 20; $secs && ! -s 'ndtest.prt'; $secs -= sleep 1) { 315 } 316 if (! -s 'ndtest.prt') { 317 die "Server process didn't create a file 'ndtest.prt'."; 318 } 319 # Sleep another second in case the server is still creating the 320 # file with the port number ... 321 sleep 1; 322 my $fh = Symbol::gensym(); 323 my $port; 324 if (!open($fh, "<ndtest.prt") || 325 !defined($port = <$fh>)) { 326 die "Error while reading 'ndtest.prt': $!"; 327 } 328 ($handle, $port); 329} 330 331 332package Net::Daemon::Test::Fork; 333 334sub Terminate ($) { 335 my $self = shift; 336 my $pid = $$self; 337 kill 'TERM', $pid; 338} 339 340package Net::Daemon::Test::Win32; 341 342sub Terminate ($) { 343 my $self = shift; 344 my $pid = $$self; 345 $pid->Kill(0); 346} 347 3481; 349 350=head1 AUTHOR AND COPYRIGHT 351 352 Net::Daemon is Copyright (C) 1998, Jochen Wiedmann 353 Am Eisteich 9 354 72555 Metzingen 355 Germany 356 357 Phone: +49 7123 14887 358 Email: joe@ispsoft.de 359 360 All rights reserved. 361 362You may distribute under the terms of either the GNU General Public 363License or the Artistic License, as specified in the Perl README file. 364 365 366=head1 SEE ALSO 367 368L<Net::Daemon(3)>, L<Test::Harness(3)> 369 370=cut 371