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