Hello community, here is the log from the commit of package perl-IO-Socket-SSL checked in at Fri Nov 2 01:37:20 CET 2007. -------- --- perl-IO-Socket-SSL/perl-IO-Socket-SSL.changes 2007-10-08 09:49:41.000000000 +0200 +++ /mounts/work_src_done/STABLE/perl-IO-Socket-SSL/perl-IO-Socket-SSL.changes 2007-11-01 15:47:19.000000000 +0100 @@ -1,0 +2,13 @@ +Thu Nov 1 15:42:58 CET 2007 - anicka@suse.cz + +- update to 1.12 + * treat timeouts of 0 for accept_SSL and connect_SSL like + no timeout, like IO::Socket does. + * fixed errors in accept_SSL which would work when called + from start_SSL but not from accept + * start_SSL, accept_SSL and connect_SSL have argument for + Timeout so that the SSL handshake will not block forever. Only + used if the socket is blocking. If not set the Timeout value + from the underlying IO::Socket is used + +------------------------------------------------------------------- Old: ---- IO-Socket-SSL-1.09-store_set_flags.diff IO-Socket-SSL-1.09.tar.bz2 New: ---- IO-Socket-SSL-1.12-store_set_flags.diff IO-Socket-SSL-1.12.tar.bz2 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ perl-IO-Socket-SSL.spec ++++++ --- /var/tmp/diff_new_pack.A24331/_old 2007-11-02 01:36:59.000000000 +0100 +++ /var/tmp/diff_new_pack.A24331/_new 2007-11-02 01:36:59.000000000 +0100 @@ -1,5 +1,5 @@ # -# spec file for package perl-IO-Socket-SSL (Version 1.09) +# spec file for package perl-IO-Socket-SSL (Version 1.12) # # Copyright (c) 2007 SUSE LINUX Products GmbH, Nuernberg, Germany. # This file and all modifications and additions to the pristine @@ -12,7 +12,7 @@ Name: perl-IO-Socket-SSL BuildRequires: perl-Net_SSLeay perl-libwww-perl -Version: 1.09 +Version: 1.12 Release: 1 Provides: p_iossl Obsoletes: p_iossl @@ -65,6 +65,16 @@ %{perl_vendorarch}/auto/IO /var/adm/perl-modules/%{name} %changelog +* Thu Nov 01 2007 - anicka@suse.cz +- update to 1.12 + * treat timeouts of 0 for accept_SSL and connect_SSL like + no timeout, like IO::Socket does. + * fixed errors in accept_SSL which would work when called + from start_SSL but not from accept + * start_SSL, accept_SSL and connect_SSL have argument for + Timeout so that the SSL handshake will not block forever. Only + used if the socket is blocking. If not set the Timeout value + from the underlying IO::Socket is used * Mon Oct 08 2007 - anicka@suse.cz - update to 1.09 * new method stop_SSL as opposite of start_SSL ++++++ IO-Socket-SSL-1.09-store_set_flags.diff -> IO-Socket-SSL-1.12-store_set_flags.diff ++++++ ++++++ IO-Socket-SSL-1.09.tar.bz2 -> IO-Socket-SSL-1.12.tar.bz2 ++++++ diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/IO-Socket-SSL-1.09/Changes new/IO-Socket-SSL-1.12/Changes --- old/IO-Socket-SSL-1.09/Changes 2007-09-13 21:22:05.000000000 +0200 +++ new/IO-Socket-SSL-1.12/Changes 2007-10-26 08:26:27.000000000 +0200 @@ -1,3 +1,14 @@ +v1.12 + - treat timeouts of 0 for accept_SSL and connect_SSL like no timeout, + like IO::Socket does. +v1.11 + - fixed errors in accept_SSL which would work when called from start_SSL + but not from accept +v1.10 + - start_SSL, accept_SSL and connect_SSL have argument for Timeout + so that the SSL handshake will not block forever. Only used if the + socket is blocking. If not set the Timeout value from the underlying + IO::Socket is used v1.09 - new method stop_SSL as opposite of start_SSL based on a idea of Bron Gondwana <brong[AT]fastmail[DOT]fm> diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/IO-Socket-SSL-1.09/MANIFEST new/IO-Socket-SSL-1.12/MANIFEST --- old/IO-Socket-SSL-1.09/MANIFEST 2007-09-13 13:24:51.000000000 +0200 +++ new/IO-Socket-SSL-1.12/MANIFEST 2007-10-26 07:45:27.000000000 +0200 @@ -31,5 +31,8 @@ t/dhe.t t/readline.t t/start-stopssl.t +t/acceptSSL-timeout.t +t/connectSSL-timeout.t +t/testlib.pl util/export_certs.pl META.yml diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/IO-Socket-SSL-1.09/SSL.pm new/IO-Socket-SSL-1.12/SSL.pm --- old/IO-Socket-SSL-1.09/SSL.pm 2007-09-13 21:19:34.000000000 +0200 +++ new/IO-Socket-SSL-1.12/SSL.pm 2007-10-26 08:19:21.000000000 +0200 @@ -17,7 +17,7 @@ use IO::Socket; use Net::SSLeay 1.21; use Exporter (); -use Errno 'EAGAIN'; +use Errno qw( EAGAIN ETIMEDOUT ); use Carp; use strict; @@ -52,7 +52,7 @@ BEGIN { # Declare @ISA, $VERSION, $GLOBAL_CONTEXT_ARGS @ISA = qw(IO::Socket::INET); - $VERSION = '1.09'; + $VERSION = '1.12'; $GLOBAL_CONTEXT_ARGS = {}; #Make $DEBUG another name for $Net::SSLeay::trace @@ -68,6 +68,14 @@ } +sub DEBUG { + $DEBUG or return; + my (undef,undef,$line) = caller; + my $msg = shift; + $msg = sprintf $msg,@_ if @_; + print STDERR "DEBUG: $line: $msg\n"; +} + sub CLONE_SKIP { 1 } # Export some stuff @@ -200,6 +208,7 @@ sub connect_SSL { my $self = shift; + my $args = @_>1 ? {@_}: $_[0]||{}; my ($ssl,$ctx); if ( ! ${*$self}{'_SSL_opening'} ) { @@ -231,29 +240,82 @@ $ssl ||= ${*$self}{'_SSL_object'}; $SSL_ERROR = undef; - #DEBUG( 'calling ssleay::connect' ); - my $rv = Net::SSLeay::connect($ssl); - #DEBUG( "rv=$rv" ); - if ( $rv < 0 ) { - unless ( $self->_set_rw_error( $ssl,$rv )) { - $self->error("SSL connect attempt failed with unknown error"); + my $timeout = exists $args->{Timeout} + ? $args->{Timeout} + : ${*$self}{io_socket_timeout}; # from IO::Socket + if ( defined($timeout) && $timeout>0 && $self->blocking(0) ) { + #DEBUG( "set socket to non-blocking to enforce timeout=$timeout" ); + # timeout was given and socket was blocking + # enforce timeout with now non-blocking socket + } else { + # timeout does not apply because invalid or socket non-blocking + $timeout = undef; + } + + my $start = defined($timeout) && time(); + for my $dummy (1) { + #DEBUG( 'calling ssleay::connect' ); + my $rv = Net::SSLeay::connect($ssl); + #DEBUG( "connect -> rv=$rv" ); + if ( $rv < 0 ) { + unless ( $self->_set_rw_error( $ssl,$rv )) { + $self->error("SSL connect attempt failed with unknown error"); + delete ${*$self}{'_SSL_opening'}; + ${*$self}{'_SSL_opened'} = 1; + #DEBUG( "fatal SSL error: $SSL_ERROR" ); + return $self->fatal_ssl_error(); + } + + #DEBUG( 'ssl handshake in progress' ); + # connect failed because handshake needs to be completed + # if socket was non-blocking or no timeout was given return with this error + return if ! defined($timeout); + + # wait until socket is readable or writable + my $rv; + if ( $timeout>0 ) { + my $vec = ''; + vec($vec,$self->fileno,1) = 1; + #DEBUG( "waiting for fd to become ready: $SSL_ERROR" ); + $rv = + $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : + $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : + undef; + } else { + #DEBUG( "handshake failed because no more time" ); + $! = ETIMEDOUT + } + if ( ! $rv ) { + #DEBUG( "handshake failed because socket did not became ready" ); + # failed because of timeout, return + $! ||= ETIMEDOUT; + delete ${*$self}{'_SSL_opening'}; + ${*$self}{'_SSL_opened'} = 1; + $self->blocking(1); # was blocking before + return + } + + # socket is ready, try non-blocking connect again after recomputing timeout + #DEBUG( "socket ready, retrying connect" ); + my $now = time(); + $timeout -= $now - $start; + $start = $now; + redo; + + } elsif ( $rv == 0 ) { delete ${*$self}{'_SSL_opening'}; + #DEBUG( "connection failed - connect returned 0" ); + $self->error("SSL connect attempt failed because of handshake problems" ); ${*$self}{'_SSL_opened'} = 1; return $self->fatal_ssl_error(); } - #DEBUG( 'ssl handshake in progress' ); - return; - } elsif ( $rv == 0 ) { - delete ${*$self}{'_SSL_opening'}; - $self->error("SSL connect attempt failed because of handshake problems" ); - ${*$self}{'_SSL_opened'} = 1; - return $self->fatal_ssl_error(); } #DEBUG( 'ssl handshake done' ); # ssl connect successful delete ${*$self}{'_SSL_opening'}; ${*$self}{'_SSL_opened'}=1; + $self->blocking(1) if defined($timeout); # was blocking before $ctx ||= ${*$self}{'_SSL_ctx'}; if ( $ctx->has_session_cache ) { @@ -303,8 +365,9 @@ } sub accept_SSL { - my ($self,$socket) = @_; - $socket ||= $self; + my $self = shift; + my $socket = ( @_ && UNIVERSAL::isa( $_[0], 'IO::Handle' )) ? shift : $self; + my $args = @_>1 ? {@_}: $_[0]||{}; my $ssl; if ( ! ${*$self}{'_SSL_opening'} ) { @@ -333,27 +396,74 @@ $SSL_ERROR = undef; #DEBUG( 'calling ssleay::accept' ); - my $rv = Net::SSLeay::accept($ssl); - #DEBUG( 'called ssleay::accept rv='.$rv ); - if ( $rv < 0 ) { - unless ( $socket->_set_rw_error( $ssl,$rv )) { - $socket->error("SSL accept attempt failed with unknown error"); + + my $timeout = exists $args->{Timeout} + ? $args->{Timeout} + : ${*$self}{io_socket_timeout}; # from IO::Socket + if ( defined($timeout) && $timeout>0 && $socket->blocking(0) ) { + # timeout was given and socket was blocking + # enforce timeout with now non-blocking socket + } else { + # timeout does not apply because invalid or socket non-blocking + $timeout = undef; + } + + my $start = defined($timeout) && time(); + for my $dummy (1) { + my $rv = Net::SSLeay::accept($ssl); + #DEBUG( 'called ssleay::accept rv='.$rv ); + if ( $rv < 0 ) { + unless ( $socket->_set_rw_error( $ssl,$rv )) { + $socket->error("SSL accept attempt failed with unknown error"); + delete ${*$self}{'_SSL_opening'}; + ${*$socket}{'_SSL_opened'} = 1; + return $socket->fatal_ssl_error(); + } + + # accept failed because handshake needs to be completed + # if socket was non-blocking or no timeout was given return with this error + return if ! defined($timeout); + + # wait until socket is readable or writable + my $rv; + if ( $timeout>0 ) { + my $vec = ''; + vec($vec,$socket->fileno,1) = 1; + $rv = + $SSL_ERROR == SSL_WANT_READ ? select( $vec,undef,undef,$timeout) : + $SSL_ERROR == SSL_WANT_WRITE ? select( undef,$vec,undef,$timeout) : + undef; + } else { + $! = ETIMEDOUT + } + if ( ! $rv ) { + # failed because of timeout, return + $! ||= ETIMEDOUT; + delete ${*$self}{'_SSL_opening'}; + ${*$socket}{'_SSL_opened'} = 1; + $socket->blocking(1); # was blocking before + return + } + + # socket is ready, try non-blocking accept again after recomputing timeout + my $now = time(); + $timeout -= $now - $start; + $start = $now; + redo; + + } elsif ( $rv == 0 ) { + $socket->error("SSL connect accept failed because of handshake problems" ); delete ${*$self}{'_SSL_opening'}; - ${*$socket}{'_SSL_opened'} = 1; + ${*$socket}{'_SSL_opened'} = 1; return $socket->fatal_ssl_error(); } - return; - } elsif ( $rv == 0 ) { - $socket->error("SSL connect accept failed because of handshake problems" ); - delete ${*$self}{'_SSL_opening'}; - ${*$socket}{'_SSL_opened'} = 1; - return $socket->fatal_ssl_error(); } #DEBUG( 'handshake done, socket ready' ); # socket opened delete ${*$self}{'_SSL_opening'}; ${*$socket}{'_SSL_opened'} = 1; + $socket->blocking(1) if defined($timeout); # was blocking before tie *{$socket}, "IO::Socket::SSL::SSL_HANDLE", $socket; @@ -675,6 +785,7 @@ my ($class,$socket) = (shift,shift); return $class->error("Not a socket") unless(ref($socket)); my $arg_hash = (ref($_[0]) eq 'HASH') ? $_[0] : {@_}; + my %to = exists $arg_hash->{Timeout} ? ( Timeout => delete $arg_hash->{Timeout} ) :(); my $original_class = ref($socket); my $original_fileno = (UNIVERSAL::can($socket, "fileno")) ? $socket->fileno : CORE::fileno($socket); @@ -692,8 +803,8 @@ #DEBUG( "start handshake" ); my $blocking = $socket->blocking(1); my $result = ${*$socket}{'_SSL_arguments'}{SSL_server} - ? $socket->accept_SSL - : $socket->connect_SSL; + ? $socket->accept_SSL(%to) + : $socket->connect_SSL(%to); $socket->blocking(0) if !$blocking; return $result ? $socket : (bless($socket, $original_class) && ()); } else { @@ -757,6 +868,7 @@ sub fatal_ssl_error { my $self = shift; my $error_trap = ${*$self}{'_SSL_arguments'}->{'SSL_error_trap'}; + $@ = $self->errstr; if (defined $error_trap and ref($error_trap) eq 'CODE') { $error_trap->($self, $self->errstr()."\n".$self->get_ssleay_error()); } else { $self->kill_socket; } @@ -1416,6 +1528,10 @@ just upgrade the socket set B<SSL_startHandshake> explicitly to 0. If you call start_SSL w/o this parameter it will revert to blocking behavior for accept_SSL and connect_SSL. +If given the parameter "Timeout" it will stop if after the timeout no SSL connection +was established. This parameter is only used for blocking sockets, if it is not given the +default Timeout from the underlying IO::Socket will be used. + =item B<stop_SSL(...)> This is the opposite of start_SSL(), e.g. it will shutdown the SSL connection diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/IO-Socket-SSL-1.09/t/acceptSSL-timeout.t new/IO-Socket-SSL-1.12/t/acceptSSL-timeout.t --- old/IO-Socket-SSL-1.09/t/acceptSSL-timeout.t 1970-01-01 01:00:00.000000000 +0100 +++ new/IO-Socket-SSL-1.12/t/acceptSSL-timeout.t 2007-10-26 07:45:27.000000000 +0200 @@ -0,0 +1,55 @@ +use strict; +use warnings; +do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; + +$|=1; +print "1..14\n"; + +my ($server,$saddr) = create_listen_socket(); +ok( 'listening' ); + +# first try bad non-SSL client +my $srv = fork_sub( 'server' ); +fd_grep_ok( 'Waiting', $srv ); +my $cl = fork_sub( 'client_no_ssl' ); +fd_grep_ok( 'Connect from',$srv ); +fd_grep_ok( 'Connected', $cl ); +fd_grep_ok( 'SSL Handshake FAILED', $srv ); +killall(); + +# then use SSL client +$srv = fork_sub( 'server' ); +fd_grep_ok( 'Waiting', $srv ); +$cl = fork_sub( 'client_ssl' ); +fd_grep_ok( 'Connect from',$srv ); +fd_grep_ok( 'Connected', $cl ); +fd_grep_ok( 'SSL Handshake OK', $srv ); +fd_grep_ok( 'Hi!', $cl ); +killall(); + + +sub server { + print "Waiting\n"; + my $client = $server->accept || die "accept failed: $!"; + print "Connect from ".$client->peerhost.':'.$client->peerport."\n"; + if ( IO::Socket::SSL->start_SSL( $client, SSL_server => 1, Timeout => 5 )) { + print "SSL Handshake OK\n"; + print $client "Hi!\n"; + } else { + print "SSL Handshake FAILED - $!\n" + } +} + +sub client_no_ssl { + my $c = IO::Socket::INET->new( $saddr ) || die "connect failed: $!"; + print "Connected\n"; + while ( sysread( $c,my $buf,8000 )) {} +} + +sub client_ssl { + my $c = IO::Socket::SSL->new( $saddr ) || die "connect failed: $!"; + print "Connected\n"; + while ( sysread( $c,my $buf,8000 )) { print $buf } +} + + diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/IO-Socket-SSL-1.09/t/connectSSL-timeout.t new/IO-Socket-SSL-1.12/t/connectSSL-timeout.t --- old/IO-Socket-SSL-1.09/t/connectSSL-timeout.t 1970-01-01 01:00:00.000000000 +0100 +++ new/IO-Socket-SSL-1.12/t/connectSSL-timeout.t 2007-10-26 07:45:27.000000000 +0200 @@ -0,0 +1,58 @@ +use strict; +use warnings; +do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; + +$|=1; +print "1..15\n"; + +my ($server,$saddr) = create_listen_socket(); +ok( 'listening' ); + +# first try bad non-SSL client +my $srv = fork_sub( 'server' ); +fd_grep_ok( 'Waiting', $srv ); +my $cl = fork_sub( 'client' ); +fd_grep_ok( 'Connect from',$srv ); +fd_grep_ok( 'Connected', $cl ); +fd_grep_ok( 'SSL Handshake FAILED', $cl ); +killall(); + +# then use SSL client +$srv = fork_sub( 'server','ssl' ); +fd_grep_ok( 'Waiting', $srv ); +$cl = fork_sub( 'client' ); +fd_grep_ok( 'Connect from',$srv ); +fd_grep_ok( 'Connected', $cl ); +fd_grep_ok( 'SSL Handshake OK', $srv ); +fd_grep_ok( 'SSL Handshake OK', $cl ); +fd_grep_ok( 'Hi!', $cl ); +killall(); + + +sub server { + my $behavior = shift || 'nossl'; + print "Waiting\n"; + my $client = $server->accept || die "accept failed: $!"; + print "Connect from ".$client->peerhost.':'.$client->peerport."\n"; + if ( $behavior eq 'ssl' ) { + if ( IO::Socket::SSL->start_SSL( $client, SSL_server => 1, Timeout => 30 )) { + print "SSL Handshake OK\n"; + print $client "Hi!\n"; + } + } else { + while ( sysread( $client, my $buf,8000 )) {} + } +} + +sub client { + my $c = IO::Socket::INET->new( $saddr ) || die "connect failed: $!"; + print "Connected\n"; + if ( IO::Socket::SSL->start_SSL( $c, Timeout => 5 )) { + print "SSL Handshake OK\n"; + print <$c> + } else { + print "SSL Handshake FAILED - $!\n"; + } +} + + diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/IO-Socket-SSL-1.09/t/testlib.pl new/IO-Socket-SSL-1.12/t/testlib.pl --- old/IO-Socket-SSL-1.09/t/testlib.pl 1970-01-01 01:00:00.000000000 +0100 +++ new/IO-Socket-SSL-1.12/t/testlib.pl 2007-10-26 07:45:27.000000000 +0200 @@ -0,0 +1,188 @@ +use strict; +use warnings; +use IO::Socket; +use IO::Socket::SSL; + +############################################################################ +# +# small test lib for common tasks: +# adapted from t/testlib.pl in Net::SIP package +# +############################################################################ + +if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) { + 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 STDERR "@_\n"; }; + *{'like'} = sub { + my ( $data,$rx,$desc ) = @_; + ok( $data =~ $rx ? 1:0, $desc ); + }; +} + +$SIG{ __DIE__ } = sub { + 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); + open( STDOUT,'>&'.fileno($wh) ) || die $!; + close( $wh ); + open( STDERR,'>&STDOUT' ) || die $!; + STDOUT->autoflush; + STDERR->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)(.*)}{$2}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'; + $port ||= 0; + my $sock = IO::Socket::INET->new( + LocalAddr => $addr, + LocalPort => $port, + Listen => 10, + Reuse => 1 + ) || die $!; + ($port,$addr) = unpack_sockaddr_in( getsockname($sock) ); + return wantarray ? ( $sock, inet_ntoa($addr).':'.$port ) : $sock; +} +1; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Remember to have fun... --------------------------------------------------------------------- To unsubscribe, e-mail: opensuse-commit+unsubscribe@opensuse.org For additional commands, e-mail: opensuse-commit+help@opensuse.org