1use strict;
2use warnings;
3use IO::Socket;
4use IO::Socket::SSL;
5
6############################################################################
7#
8# small test lib for common tasks:
9# adapted from t/testlib.pl in Net::SIP package
10#
11############################################################################
12
13if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) {
14    print "1..0 # Skipped: fork not implemented on this platform\n";
15    exit
16}
17
18
19# small implementations if not used from Test::More (09_fdleak.t)
20if ( ! defined &ok ) {
21	no strict 'refs';
22	*{'ok'} = sub {
23		my ($bool,$desc) = @_;
24		print $bool ? "ok ":"not ok ", '# ',$desc || '',"\n";
25	};
26	*{'diag'} = sub { print "# @_\n"; };
27	*{'like'} = sub {
28		my ( $data,$rx,$desc ) = @_;
29		ok( $data =~ $rx ? 1:0, $desc );
30	};
31}
32
33$SIG{ __DIE__ } = sub {
34	return if $^S; # Ignore from within evals
35	ok( 0,"@_" );
36	killall();
37	exit(1);
38};
39
40############################################################################
41# kill all process collected by fork_sub
42# Args: ?$signal
43#  $signal: signal to use, default 9
44# Returns: NONE
45############################################################################
46my @pids;
47sub killall {
48	my $sig = shift || 9;
49	kill $sig, @pids;
50	#diag( "killed @pids with $sig" );
51	while ( wait() >= 0 ) {} # collect all
52	@pids = ();
53}
54
55
56############################################################################
57# fork named sub with args and provide fd into subs STDOUT
58# Args: ($name,@args)
59#  $name: name or ref to sub, if name it will be used for debugging
60#  @args: arguments for sub
61# Returns: $fh
62#  $fh: file handle to read STDOUT of sub
63############################################################################
64my %fd2name; # associated sub-name for file descriptor to subs STDOUT
65sub fork_sub {
66	my ($name,@arg) = @_;
67	my $sub = ref($name) ? $name : UNIVERSAL::can( 'main',$name ) || die;
68	pipe( my $rh, my $wh ) || die $!;
69	defined( my $pid = fork() ) || die $!;
70	if ( ! $pid ) {
71		# CHILD, exec sub
72		close($rh);
73		local *STDOUT = local *STDERR = $wh;
74		$wh->autoflush;
75		print "OK\n";
76		$sub->(@arg);
77		exit(0);
78	}
79
80	push @pids,$pid;
81	close( $wh );
82	$fd2name{$rh} = $name;
83	fd_grep_ok( 'OK',10,$rh ) || die 'startup failed';
84	return $rh;
85}
86
87############################################################################
88# grep within fd's for specified regex or substring
89# Args: ($pattern,[ $timeout ],@fd)
90#  $pattern: regex or substring
91#  $timeout: how many seconds to wait for pattern, default 10
92#  @fd: which fds to search, usually fds from fork_sub(..)
93# Returns: $rv| ($rv,$name)
94#  $rv: matched text if pattern is found, else undef
95#  $name: name for file handle
96############################################################################
97my %fd2buf;  # already read data from fd
98sub fd_grep {
99	my $pattern = shift;
100	my $timeout = 10;
101	$timeout = shift if !ref($_[0]);
102	my @fd = @_;
103	$pattern = qr{\Q$pattern} if ! UNIVERSAL::isa( $pattern,'Regexp' );
104	my $name = join( "|", map { $fd2name{$_} || "$_" } @fd );
105	#diag( "look for $pattern in $name" );
106	my @bad = wantarray ? ( undef,$name ):(undef);
107	@fd || return @bad;
108	my $rin = '';
109	map { $_->blocking(0); vec( $rin,fileno($_),1 ) = 1 } @fd;
110	my $end = defined( $timeout ) ? time() + $timeout : undef;
111
112	while (@fd) {
113
114		# check existing buf from previous reads
115		foreach my $fd (@fd) {
116			my $buf = \$fd2buf{$fd};
117			$$buf || next;
118			if ( $$buf =~s{\A(?:.*?)($pattern)}{}s ) {
119				#diag( "found" );
120				return wantarray ? ( $1,$name ) : $1;
121			}
122		}
123
124		# if not found try to read new data
125		$timeout = $end - time() if $end;
126		return @bad if $timeout < 0;
127		select( my $rout = $rin,undef,undef,$timeout );
128		$rout || return @bad; # not found
129		foreach my $fd (@fd) {
130			my $name = $fd2name{$fd} || "$fd";
131			my $buf = \$fd2buf{$fd};
132			my $fn = fileno($fd);
133			my $n;
134			if ( defined ($fn)) {
135				vec( $rout,$fn,1 ) || next;
136				my $l = $$buf && length($$buf) || 0;
137				$n = sysread( $fd,$$buf,8192,$l );
138			}
139			if ( ! $n ) {
140				#diag( "$name >CLOSED<" );
141				delete $fd2buf{$fd};
142				@fd = grep { $_ != $fd } @fd;
143				close($fd);
144				next;
145			}
146			diag( "$name >> ".substr( $$buf,-$n ). "<<" );
147		}
148	}
149	return @bad;
150}
151
152############################################################################
153# like Test::Simple::ok, but based on fd_grep, same as
154# ok( fd_grep( pattern,... ), "[$subname] $pattern" )
155# Args: ($pattern,[ $timeout ],@fd) - see fd_grep
156# Returns: $rv - like in fd_grep
157# Comment: if !$rv and wantarray says void it will die()
158############################################################################
159sub fd_grep_ok {
160	my $pattern = shift;
161	my ($rv,$name) = fd_grep( $pattern, @_ );
162	local $Test::Builder::Level = $Test::Builder::Level || 0 +1;
163	ok( $rv,"[$name] $pattern" );
164	die "fatal error" if !$rv && ! defined wantarray;
165	return $rv;
166}
167
168
169############################################################################
170# create socket on IP
171# return socket and ip:port
172############################################################################
173sub create_listen_socket {
174	my ($addr,$port,$proto) = @_;
175	$addr ||= '127.0.0.1';
176	my $sock = IO::Socket::INET->new(
177		LocalAddr => $addr,
178		$port ? ( LocalPort => $port ) : (),
179		Listen => 10,
180		Reuse => 1
181	) || die $!;
182	($port,$addr) = unpack_sockaddr_in( getsockname($sock) );
183	return wantarray ? ( $sock, inet_ntoa($addr).':'.$port ) : $sock;
184}
1851;
186