vcs.maemo.org Git - pkg-perl/blob - deb-src/libio-socket-ssl-perl/libio-socket-ssl-perl-1.16/t/testlib.pl

   1 use strict;
   2 use warnings;
   3 use IO::Socket;
   4 use 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
  13 if ( 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)
  20 if ( ! 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 STDERR "@_\n"; };
  27         *{'like'} = sub {
  28                 my ( $data,$rx,$desc ) = @_;
  29                 ok( $data =~ $rx ? 1:0, $desc );
  30         };
  31 }
  32
  33 $SIG{ __DIE__ } = sub {
  34         ok( 0,"@_" );
  35         killall();
  36         exit(1);
  37 };
  38
  39 ############################################################################
  40 # kill all process collected by fork_sub
  41 # Args: ?$signal
  42 #  $signal: signal to use, default 9
  43 # Returns: NONE
  44 ############################################################################
  45 my @pids;
  46 sub killall {
  47         my $sig = shift || 9;
  48         kill $sig, @pids;
  49         #diag( "killed @pids with $sig" );
  50         while ( wait() >= 0 ) {} # collect all
  51         @pids = ();
  52 }
  53
  54
  55 ############################################################################
  56 # fork named sub with args and provide fd into subs STDOUT
  57 # Args: ($name,@args)
  58 #  $name: name or ref to sub, if name it will be used for debugging
  59 #  @args: arguments for sub
  60 # Returns: $fh
  61 #  $fh: file handle to read STDOUT of sub
  62 ############################################################################
  63 my %fd2name; # associated sub-name for file descriptor to subs STDOUT
  64 sub fork_sub {
  65         my ($name,@arg) = @_;
  66         my $sub = ref($name) ? $name : UNIVERSAL::can( 'main',$name ) || die;
  67         pipe( my $rh, my $wh ) || die $!;
  68         defined( my $pid = fork() ) || die $!;
  69         if ( ! $pid ) {
  70                 # CHILD, exec sub
  71                 close($rh);
  72                 open( STDOUT,'>&'.fileno($wh) ) || die $!;
  73                 close( $wh );
  74                 open( STDERR,'>&STDOUT' ) || die $!;
  75                 STDOUT->autoflush;
  76                 STDERR->autoflush;
  77                 print "OK\n";
  78                 $sub->(@arg);
  79                 exit(0);
  80         }
  81
  82         push @pids,$pid;
  83         close( $wh );
  84         $fd2name{$rh} = $name;
  85         fd_grep_ok( 'OK',10,$rh ) || die 'startup failed';
  86         return $rh;
  87 }
  88
  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
 100 sub fd_grep {
 101         my $pattern = shift;
 102         my $timeout = 10;
 103         $timeout = shift if !ref($_[0]);
 104         my @fd = @_;
 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);
 109         @fd || return @bad;
 110         my $rin = '';
 111         map { $_->blocking(0); vec( $rin,fileno($_),1 ) = 1 } @fd;
 112         my $end = defined( $timeout ) ? time() + $timeout : undef;
 113
 114         while (@fd) {
 115
 116                 # check existing buf from previous reads
 117                 foreach my $fd (@fd) {
 118                         my $buf = \$fd2buf{$fd};
 119                         $$buf || next;
 120                         if ( $$buf =~s{\A(?:.*?)($pattern)(.*)}{$2}s ) {
 121                                 #diag( "found" );
 122                                 return wantarray ? ( $1,$name ) : $1;
 123                         }
 124                 }
 125
 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);
 135                         my $n;
 136                         if ( defined ($fn)) {
 137                                 vec( $rout,$fn,1 ) || next;
 138                                 my $l = $$buf && length($$buf) || 0;
 139                                 $n = sysread( $fd,$$buf,8192,$l );
 140                         }
 141                         if ( ! $n ) {
 142                                 #diag( "$name >CLOSED<" );
 143                                 delete $fd2buf{$fd};
 144                                 @fd = grep { $_ != $fd } @fd;
 145                                 close($fd);
 146                                 next;
 147                         }
 148                         diag( "$name >> ".substr( $$buf,-$n ). "<<" );
 149                 }
 150         }
 151         return @bad;
 152 }
 153
 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 ############################################################################
 161 sub fd_grep_ok {
 162         my $pattern = shift;
 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;
 167         return $rv;
 168 }
 169
 170
 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(
 179                 LocalAddr => $addr,
 180                 $port ? ( LocalPort => $port ) : (),
 181                 Listen => 10,
 182                 Reuse => 1
 183         ) || die $!;
 184         ($port,$addr) = unpack_sockaddr_in( getsockname($sock) );
 185         return wantarray ? ( $sock, inet_ntoa($addr).':'.$port ) : $sock;
 186 }
 187 1;