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