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