Coro/Coro/Socket.pm

=head1 NAME

Coro::Socket - non-blocking socket-io

=head1 SYNOPSIS

 use Coro::Socket;

=head1 DESCRIPTION

This module implements socket-handles in a coroutine-compatible way,
that is, other coroutines can run while reads or writes block on the
handle. L<Coro::Handle>.

=over 4

=cut

package Coro::Socket;

use Errno ();
use Carp qw(croak);
use Socket;

use Coro::Util ();

use base 'Coro::Handle';

$VERSION = 0.45;

sub _proto($) {
   $_proto{$_[0]} ||= do {
      ((getprotobyname $_[0])[2] || (getprotobynumber $_[0])[2])
         or croak "unsupported protocol: $_[0]";
   };
}

sub _port($$) {
   $_port{$_[0],$_[1]} ||= do {
      return $_[0] if $_[0] =~ /^\d+$/;

      $_[0] =~ /([^(]+)\s*(?:\((\d+)\))?/x
         or croak "unparsable port number: $_[0]";
      ((getservbyname $1, $_[1])[2]
        || (getservbyport $1, $_[1])[2]
        || $2)
         or croak "unknown port: $_[0]";
   };
}

sub _sa($$$) {
   my ($host, $port, $proto) = @_;
   my $_proto = _proto($proto);
   my $_port = _port($port, $proto);

   # optimize this a bit for a common case
   if ($host =~ /^(25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
                \.(25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
                \.(25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)
                \.(25[0-5]|2[0-4][0-9]|1[0-9][0-9]|[0-9][0-9]?)$/) {
      return pack_sockaddr_in($_port, inet_aton $host);
   } else {
      my (undef, undef, undef, undef, @host) = Coro::Util::gethostbyname $host
         or croak "unknown host: $host";
      map pack_sockaddr_in($_port,$_), @host;
   }
}

=item $fh = new_inet Coro::Socket param => value, ...

Create a new non-blocking tcp handle and connect to the given host
and port. The parameter names and values are mostly the same as in
IO::Socket::INET (as ugly as I think they are).

If the host is unreachable or otherwise cannot be connected to this method
returns undef. On all other errors ot croak's.

Multihomed is always enabled.

   $fh = new_inet Coro::Socket PeerHost => "localhost", PeerPort => 'finger';

=cut

sub _prepare_socket {
   my ($class, $arg) = @_;
   my $fh;

   socket $fh, PF_INET, $arg->{Type}, _proto($arg->{Proto})
      or return;

   $fh = bless Coro::Handle->new_from_fh($fh, timeout => $arg{Timeout}), $class
      or return;

   if ($arg->{ReuseAddr}) {
      $fh->setsockopt(SOL_SOCKET, SO_REUSEADDR, 1)
         or croak "setsockopt(SO_REUSEADDR): $!";
   }

   if ($arg->{ReusePort}) {
      $fh->setsockopt(SOL_SOCKET, SO_REUSEPORT, 1)
         or croak "setsockopt(SO_REUSEPORT): $!";
   }

   if ($arg->{LocalPort}) {
      my @sa = _sa($arg->{LocalHost} || "0.0.0.0", $arg->{LocalPort}, $arg->{Proto});
      $fh->bind($sa[0])
         or croak "bind($arg->{LocalHost}:$arg->{LocalPort}): $!";
   }

   $fh;
}
   
sub new {
   my $class = shift;
   my %arg = @_;
   my $fh;

   $arg{Proto}     ||= 'tcp';
   $arg{LocalHost} ||= delete $arg{LocalAddr};
   $arg{PeerHost}  ||= delete $arg{PeerAddr};
   defined ($arg{Type}) or $arg{Type} = $arg{Proto} eq "tcp" ? SOCK_STREAM : SOCK_DGRAM;

   if ($arg{PeerHost}) {
      my @sa = _sa($arg{PeerHost}, $arg{PeerPort}, $arg{Proto});

      for (@sa) {
         $fh = $class->_prepare_socket(\%arg)
            or return;

         $! = 0;

         if ($fh->connect($_)) {
            next unless writable $fh;
            $! = unpack "i", $fh->getsockopt(SOL_SOCKET, SO_ERROR);
         }

         $! or last;

         $!{ECONNREFUSED} or $!{ENETUNREACH} or $!{ETIMEDOUT} or $!{EHOSTUNREACH}
            or return;
      }
   } else {
      $fh = $class->_prepare_socket(\%arg)
         or return;
      if (exists $arg{Listen}) {
         $fh->listen($arg{Listen})
            or return;
      }
   }

   $fh;
}

=item connect, listen, bind, getsockopt, setsockopt,
send, recv, getpeername, getsockname

Do the same thing as the perl builtins (but return true on
EINPROGRESS). Remember that these must be method calls.

=cut

sub connect     { connect tied(${$_[0]})->{fh}, $_[1] or $! == Errno::EINPROGRESS }
sub bind        { bind    tied(${$_[0]})->{fh}, $_[1] }
sub listen      { listen  tied(${$_[0]})->{fh}, $_[1] }
sub getsockopt  { getsockopt tied(${$_[0]})->{fh}, $_[1], $_[2] }
sub setsockopt  { setsockopt tied(${$_[0]})->{fh}, $_[1], $_[2], $_[3] }
sub send        { send tied(${$_[0]})->{fh}, $_[1], $_[2], @_ > 2 ? $_[3] : () }
sub recv        { recv tied(${$_[0]})->{fh}, $_[1], $_[2], @_ > 2 ? $_[3] : () }
sub getsockname { getsockname tied(${$_[0]})->{fh} }
sub getpeername { getpeername tied(${$_[0]})->{fh} }

=item ($peername, $fh) = $listen_fh->accept

In scalar context, returns the newly accepted socket (or undef) and in
list context return the ($peername, $fh) pair (or nothing).

=cut

sub accept {
   my ($peername, $fh);
   while () {
      $_[0]->readable or return;

      $peername = accept $fh, tied(${$_[0]})->{fh}
         and return ($peername, $fh = new_from_fh Coro::Socket $fh);

      return unless $!{EAGAIN};
   }
}

1;

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut

Revision:	1.11
Committed:	Sat Aug 11 00:37:32 2001 UTC (22 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.10:	+1 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Coro::Socket - non-blocking socket-io
4
5			=head1 SYNOPSIS
6
7			use Coro::Socket;
8
9			=head1 DESCRIPTION
10
11			This module implements socket-handles in a coroutine-compatible way,
12			that is, other coroutines can run while reads or writes block on the
13			handle. L<Coro::Handle>.
14
15			=over 4
16
17			=cut
18
19			package Coro::Socket;
20
21			use Errno ();
22			use Carp qw(croak);
23			use Socket;
24
25	root	1.6	use Coro::Util ();
26
27	root	1.1	use base 'Coro::Handle';
28
29	root	1.11	$VERSION = 0.45;
30	root	1.1
31			sub _proto($) {
32			$_proto{$_[0]} \|\|= do {
33			((getprotobyname $_[0])[2] \|\| (getprotobynumber $_[0])[2])
34			or croak "unsupported protocol: $_[0]";
35			};
36			}
37
38			sub _port($$) {
39	root	1.9	$_port{$_[0],$_[1]} \|\|= do {
40			return $_[0] if $_[0] =~ /^\d+$/;
41
42			$_[0] =~ /([^(]+)\s*(?:\((\d+)\))?/x
43			or croak "unparsable port number: $_[0]";
44			((getservbyname $1, $_[1])[2]
45			\|\| (getservbyport $1, $_[1])[2]
46			\|\| $2)
47	root	1.1	or croak "unknown port: $_[0]";
48			};
49			}
50
51			sub _sa($$$) {
52			my ($host, $port, $proto) = @_;
53			my $_proto = _proto($proto);
54			my $_port = _port($port, $proto);
55
56	root	1.6	# optimize this a bit for a common case
57			if ($host =~ /^(25[0-5]\|2[0-4][0-9]\|1[0-9][0-9]\|[0-9][0-9]?)
58			\.(25[0-5]\|2[0-4][0-9]\|1[0-9][0-9]\|[0-9][0-9]?)
59			\.(25[0-5]\|2[0-4][0-9]\|1[0-9][0-9]\|[0-9][0-9]?)
60			\.(25[0-5]\|2[0-4][0-9]\|1[0-9][0-9]\|[0-9][0-9]?)$/) {
61			return pack_sockaddr_in($_port, inet_aton $host);
62			} else {
63			my (undef, undef, undef, undef, @host) = Coro::Util::gethostbyname $host
64			or croak "unknown host: $host";
65			map pack_sockaddr_in($_port,$_), @host;
66			}
67	root	1.1	}
68
69			=item $fh = new_inet Coro::Socket param => value, ...
70
71			Create a new non-blocking tcp handle and connect to the given host
72			and port. The parameter names and values are mostly the same as in
73			IO::Socket::INET (as ugly as I think they are).
74
75			If the host is unreachable or otherwise cannot be connected to this method
76			returns undef. On all other errors ot croak's.
77
78			Multihomed is always enabled.
79
80			$fh = new_inet Coro::Socket PeerHost => "localhost", PeerPort => 'finger';
81
82			=cut
83
84			sub _prepare_socket {
85			my ($class, $arg) = @_;
86			my $fh;
87
88			socket $fh, PF_INET, $arg->{Type}, _proto($arg->{Proto})
89			or return;
90
91	root	1.7	$fh = bless Coro::Handle->new_from_fh($fh, timeout => $arg{Timeout}), $class
92	root	1.1	or return;
93
94			if ($arg->{ReuseAddr}) {
95			$fh->setsockopt(SOL_SOCKET, SO_REUSEADDR, 1)
96			or croak "setsockopt(SO_REUSEADDR): $!";
97			}
98
99			if ($arg->{ReusePort}) {
100			$fh->setsockopt(SOL_SOCKET, SO_REUSEPORT, 1)
101			or croak "setsockopt(SO_REUSEPORT): $!";
102			}
103
104	root	1.6	if ($arg->{LocalPort}) {
105			my @sa = _sa($arg->{LocalHost} \|\| "0.0.0.0", $arg->{LocalPort}, $arg->{Proto});
106	root	1.1	$fh->bind($sa[0])
107			or croak "bind($arg->{LocalHost}:$arg->{LocalPort}): $!";
108			}
109
110			$fh;
111			}
112
113	root	1.5	sub new {
114	root	1.1	my $class = shift;
115			my %arg = @_;
116			my $fh;
117
118			$arg{Proto} \|\|= 'tcp';
119			$arg{LocalHost} \|\|= delete $arg{LocalAddr};
120			$arg{PeerHost} \|\|= delete $arg{PeerAddr};
121			defined ($arg{Type}) or $arg{Type} = $arg{Proto} eq "tcp" ? SOCK_STREAM : SOCK_DGRAM;
122
123			if ($arg{PeerHost}) {
124			my @sa = _sa($arg{PeerHost}, $arg{PeerPort}, $arg{Proto});
125
126			for (@sa) {
127			$fh = $class->_prepare_socket(\%arg)
128			or return;
129
130			$! = 0;
131
132			if ($fh->connect($_)) {
133			next unless writable $fh;
134			$! = unpack "i", $fh->getsockopt(SOL_SOCKET, SO_ERROR);
135			}
136
137			$! or last;
138
139			$!{ECONNREFUSED} or $!{ENETUNREACH} or $!{ETIMEDOUT} or $!{EHOSTUNREACH}
140			or return;
141			}
142			} else {
143			$fh = $class->_prepare_socket(\%arg)
144			or return;
145	root	1.7	if (exists $arg{Listen}) {
146			$fh->listen($arg{Listen})
147			or return;
148			}
149	root	1.1	}
150
151			$fh;
152			}
153
154	root	1.10	=item connect, listen, bind, getsockopt, setsockopt,
155	root	1.7	send, recv, getpeername, getsockname
156	root	1.1
157			Do the same thing as the perl builtins (but return true on
158			EINPROGRESS). Remember that these must be method calls.
159
160			=cut
161
162			sub connect { connect tied(${$_[0]})->{fh}, $_[1] or $! == Errno::EINPROGRESS }
163			sub bind { bind tied(${$_[0]})->{fh}, $_[1] }
164			sub listen { listen tied(${$_[0]})->{fh}, $_[1] }
165			sub getsockopt { getsockopt tied(${$_[0]})->{fh}, $_[1], $_[2] }
166			sub setsockopt { setsockopt tied(${$_[0]})->{fh}, $_[1], $_[2], $_[3] }
167			sub send { send tied(${$_[0]})->{fh}, $_[1], $_[2], @_ > 2 ? $_[3] : () }
168			sub recv { recv tied(${$_[0]})->{fh}, $_[1], $_[2], @_ > 2 ? $_[3] : () }
169	root	1.8	sub getsockname { getsockname tied(${$_[0]})->{fh} }
170			sub getpeername { getpeername tied(${$_[0]})->{fh} }
171	root	1.1
172	root	1.10	=item ($peername, $fh) = $listen_fh->accept
173
174			In scalar context, returns the newly accepted socket (or undef) and in
175			list context return the ($peername, $fh) pair (or nothing).
176
177			=cut
178
179	root	1.1	sub accept {
180	root	1.10	my ($peername, $fh);
181	root	1.7	while () {
182			$_[0]->readable or return;
183	root	1.10
184			$peername = accept $fh, tied(${$_[0]})->{fh}
185			and return ($peername, $fh = new_from_fh Coro::Socket $fh);
186
187	root	1.7	return unless $!{EAGAIN};
188			}
189	root	1.1	}
190
191			1;
192
193			=head1 AUTHOR
194
195			Marc Lehmann <pcg@goof.com>
196			http://www.goof.com/pcg/marc/
197
198			=cut
199