6 ############################################################################
8 # small test lib for common tasks:
9 # adapted from t/testlib.pl in Net::SIP package
11 ############################################################################
13 if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) {
14 print "1..0 # Skipped: fork not implemented on this platform\n";
19 # small implementations if not used from Test::More (09_fdleak.t)
20 if ( ! defined &ok ) {
23 my ($bool,$desc) = @_;
24 print $bool ? "ok ":"not ok ", '# ',$desc || '',"\n";
26 *{'diag'} = sub { print STDERR "@_\n"; };
28 my ( $data,$rx,$desc ) = @_;
29 ok( $data =~ $rx ? 1:0, $desc );
33 $SIG{ __DIE__ } = sub {
39 ############################################################################
40 # kill all process collected by fork_sub
42 # $signal: signal to use, default 9
44 ############################################################################
49 #diag( "killed @pids with $sig" );
50 while ( wait() >= 0 ) {} # collect all
55 ############################################################################
56 # fork named sub with args and provide fd into subs STDOUT
58 # $name: name or ref to sub, if name it will be used for debugging
59 # @args: arguments for sub
61 # $fh: file handle to read STDOUT of sub
62 ############################################################################
63 my %fd2name; # associated sub-name for file descriptor to subs STDOUT
66 my $sub = ref($name) ? $name : UNIVERSAL::can( 'main',$name ) || die;
67 pipe( my $rh, my $wh ) || die $!;
68 defined( my $pid = fork() ) || die $!;
72 open( STDOUT,'>&'.fileno($wh) ) || die $!;
74 open( STDERR,'>&STDOUT' ) || die $!;
84 $fd2name{$rh} = $name;
85 fd_grep_ok( 'OK',10,$rh ) || die 'startup failed';
89 ############################################################################
90 # grep within fd's for specified regex or substring
91 # Args: ($pattern,[ $timeout ],@fd)
92 # $pattern: regex or substring
93 # $timeout: how many seconds to wait for pattern, default 10
94 # @fd: which fds to search, usually fds from fork_sub(..)
95 # Returns: $rv| ($rv,$name)
96 # $rv: matched text if pattern is found, else undef
97 # $name: name for file handle
98 ############################################################################
99 my %fd2buf; # already read data from fd
103 $timeout = shift if !ref($_[0]);
105 $pattern = qr{\Q$pattern} if ! UNIVERSAL::isa( $pattern,'Regexp' );
106 my $name = join( "|", map { $fd2name{$_} || "$_" } @fd );
107 #diag( "look for $pattern in $name" );
108 my @bad = wantarray ? ( undef,$name ):(undef);
111 map { $_->blocking(0); vec( $rin,fileno($_),1 ) = 1 } @fd;
112 my $end = defined( $timeout ) ? time() + $timeout : undef;
116 # check existing buf from previous reads
117 foreach my $fd (@fd) {
118 my $buf = \$fd2buf{$fd};
120 if ( $$buf =~s{\A(?:.*?)($pattern)(.*)}{$2}s ) {
122 return wantarray ? ( $1,$name ) : $1;
126 # if not found try to read new data
127 $timeout = $end - time() if $end;
128 return @bad if $timeout < 0;
129 select( my $rout = $rin,undef,undef,$timeout );
130 $rout || return @bad; # not found
131 foreach my $fd (@fd) {
132 my $name = $fd2name{$fd} || "$fd";
133 my $buf = \$fd2buf{$fd};
134 my $fn = fileno($fd);
136 if ( defined ($fn)) {
137 vec( $rout,$fn,1 ) || next;
138 my $l = $$buf && length($$buf) || 0;
139 $n = sysread( $fd,$$buf,8192,$l );
142 #diag( "$name >CLOSED<" );
144 @fd = grep { $_ != $fd } @fd;
148 diag( "$name >> ".substr( $$buf,-$n ). "<<" );
154 ############################################################################
155 # like Test::Simple::ok, but based on fd_grep, same as
156 # ok( fd_grep( pattern,... ), "[$subname] $pattern" )
157 # Args: ($pattern,[ $timeout ],@fd) - see fd_grep
158 # Returns: $rv - like in fd_grep
159 # Comment: if !$rv and wantarray says void it will die()
160 ############################################################################
163 my ($rv,$name) = fd_grep( $pattern, @_ );
164 local $Test::Builder::Level = $Test::Builder::Level || 0 +1;
165 ok( $rv,"[$name] $pattern" );
166 die "fatal error" if !$rv && ! defined wantarray;
171 ############################################################################
172 # create socket on IP
173 # return socket and ip:port
174 ############################################################################
175 sub create_listen_socket {
176 my ($addr,$port,$proto) = @_;
177 $addr ||= '127.0.0.1';
178 my $sock = IO::Socket::INET->new(
180 $port ? ( LocalPort => $port ) : (),
184 ($port,$addr) = unpack_sockaddr_in( getsockname($sock) );
185 return wantarray ? ( $sock, inet_ntoa($addr).':'.$port ) : $sock;