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
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 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
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