# IO::Socket.pm
#
# Copyright (c) 1997-8 Graham Barr . All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket;
use 5.008_001;
use IO::Handle;
use Socket 1.3;
use Carp;
use strict;
use Exporter;
use Errno;
# legacy
require IO::Socket::INET;
require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
our @ISA = qw(IO::Handle);
our $VERSION = "1.43";
our @EXPORT_OK = qw(sockatmark);
sub import {
my $pkg = shift;
if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
} else {
my $callpkg = caller;
Exporter::export 'Socket', $callpkg, @_;
}
}
sub new {
my($class,%arg) = @_;
my $sock = $class->SUPER::new();
$sock->autoflush(1);
${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
return scalar(%arg) ? $sock->configure(\%arg)
: $sock;
}
my @domain2pkg;
sub register_domain {
my($p,$d) = @_;
$domain2pkg[$d] = $p;
}
sub configure {
my($sock,$arg) = @_;
my $domain = delete $arg->{Domain};
croak 'IO::Socket: Cannot configure a generic socket'
unless defined $domain;
croak "IO::Socket: Unsupported socket domain"
unless defined $domain2pkg[$domain];
croak "IO::Socket: Cannot configure socket in domain '$domain'"
unless ref($sock) eq "IO::Socket";
bless($sock, $domain2pkg[$domain]);
$sock->configure($arg);
}
sub socket {
@_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
my($sock,$domain,$type,$protocol) = @_;
socket($sock,$domain,$type,$protocol) or
return undef;
${*$sock}{'io_socket_domain'} = $domain;
${*$sock}{'io_socket_type'} = $type;
# "A value of 0 for protocol will let the system select an
# appropriate protocol"
# so we need to look up what the system selected,
# not cache PF_UNSPEC.
${*$sock}{'io_socket_proto'} = $protocol if $protocol;
$sock;
}
sub socketpair {
@_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
my($class,$domain,$type,$protocol) = @_;
my $sock1 = $class->new();
my $sock2 = $class->new();
socketpair($sock1,$sock2,$domain,$type,$protocol) or
return ();
${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
($sock1,$sock2);
}
sub connect {
@_ == 2 or croak 'usage: $sock->connect(NAME)';
my $sock = shift;
my $addr = shift;
my $timeout = ${*$sock}{'io_socket_timeout'};
my $err;
my $blocking;
$blocking = $sock->blocking(0) if $timeout;
if (!connect($sock, $addr)) {
if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
require IO::Select;
my $sel = new IO::Select $sock;
undef $!;
my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
if(@$e[0]) {
# Windows return from select after the timeout in case of
# WSAECONNREFUSED(10061) if exception set is not used.
# This behavior is different from Linux.
# Using the exception
# set we now emulate the behavior in Linux
# - Karthik Rajagopalan
$err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
$@ = "connect: $err";
}
elsif(!@$w[0]) {
$err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
$@ = "connect: timeout";
}
elsif (!connect($sock,$addr) &&
not ($!{EISCONN} || ($^O eq 'MSWin32' &&
($! == (($] < 5.019004) ? 10022 : Errno::EINVAL))))
) {
# Some systems refuse to re-connect() to
# an already open socket and set errno to EISCONN.
# Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
# EINVAL (22) (5.19.4 onwards).
$err = $!;
$@ = "connect: $!";
}
}
elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
$err = $!;
$@ = "connect: $!";
}
}
$sock->blocking(1) if $blocking;
$! = $err if $err;
$err ? undef : $sock;
}
# Enable/disable blocking IO on sockets.
# Without args return the current status of blocking,
# with args change the mode as appropriate, returning the
# old setting, or in case of error during the mode change
# undef.
sub blocking {
my $sock = shift;
return $sock->SUPER::blocking(@_)
if $^O ne 'MSWin32' && $^O ne 'VMS';
# Windows handles blocking differently
#
# http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
# http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
#
# 0x8004667e is FIONBIO
#
# which is used to set blocking behaviour.
# NOTE:
# This is a little confusing, the perl keyword for this is
# 'blocking' but the OS level behaviour is 'non-blocking', probably
# because sockets are blocking by default.
# Therefore internally we have to reverse the semantics.
my $orig= !${*$sock}{io_sock_nonblocking};
return $orig unless @_;
my $block = shift;
if ( !$block != !$orig ) {
${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
or return undef;
}
return $orig;
}
sub close {
@_ == 1 or croak 'usage: $sock->close()';
my $sock = shift;
${*$sock}{'io_socket_peername'} = undef;
$sock->SUPER::close();
}
sub bind {
@_ == 2 or croak 'usage: $sock->bind(NAME)';
my $sock = shift;
my $addr = shift;
return bind($sock, $addr) ? $sock
: undef;
}
sub listen {
@_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
my($sock,$queue) = @_;
$queue = 5
unless $queue && $queue > 0;
return listen($sock, $queue) ? $sock
: undef;
}
sub accept {
@_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
my $sock = shift;
my $pkg = shift || $sock;
my $timeout = ${*$sock}{'io_socket_timeout'};
my $new = $pkg->new(Timeout => $timeout);
my $peer = undef;
if(defined $timeout) {
require IO::Select;
my $sel = new IO::Select $sock;
unless ($sel->can_read($timeout)) {
$@ = 'accept: timeout';
$! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
return;
}
}
$peer = accept($new,$sock)
or return;
${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
return wantarray ? ($new, $peer)
: $new;
}
sub sockname {
@_ == 1 or croak 'usage: $sock->sockname()';
getsockname($_[0]);
}
sub peername {
@_ == 1 or croak 'usage: $sock->peername()';
my($sock) = @_;
${*$sock}{'io_socket_peername'} ||= getpeername($sock);
}
sub connected {
@_ == 1 or croak 'usage: $sock->connected()';
my($sock) = @_;
getpeername($sock);
}
sub send {
@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
my $sock = $_[0];
my $flags = $_[2] || 0;
my $peer;
if ($_[3]) {
# the caller explicitly requested a TO, so use it
# this is non-portable for "connected" UDP sockets
$peer = $_[3];
}
elsif (!defined getpeername($sock)) {
# we're not connected, so we require a peer from somewhere
$peer = $sock->peername;
croak 'send: Cannot determine peer address'
unless(defined $peer);
}
my $r = $peer
? send($sock, $_[1], $flags, $peer)
: send($sock, $_[1], $flags);
# remember who we send to, if it was successful
${*$sock}{'io_socket_peername'} = $peer
if(@_ == 4 && defined $r);
$r;
}
sub recv {
@_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
my $sock = $_[0];
my $len = $_[2];
my $flags = $_[3] || 0;
# remember who we recv'd from
${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}
sub shutdown {
@_ == 2 or croak 'usage: $sock->shutdown(HOW)';
my($sock, $how) = @_;
${*$sock}{'io_socket_peername'} = undef;
shutdown($sock, $how);
}
sub setsockopt {
@_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
setsockopt($_[0],$_[1],$_[2],$_[3]);
}
my $intsize = length(pack("i",0));
sub getsockopt {
@_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
my $r = getsockopt($_[0],$_[1],$_[2]);
# Just a guess
$r = unpack("i", $r)
if(defined $r && length($r) == $intsize);
$r;
}
sub sockopt {
my $sock = shift;
@_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
: $sock->setsockopt(SOL_SOCKET,@_);
}
sub atmark {
@_ == 1 or croak 'usage: $sock->atmark()';
my($sock) = @_;
sockatmark($sock);
}
sub timeout {
@_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
my($sock,$val) = @_;
my $r = ${*$sock}{'io_socket_timeout'};
${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
if(@_ == 2);
$r;
}
sub sockdomain {
@_ == 1 or croak 'usage: $sock->sockdomain()';
my $sock = shift;
if (!defined(${*$sock}{'io_socket_domain'})) {
my $addr = $sock->sockname();
${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
if (defined($addr));
}
${*$sock}{'io_socket_domain'};
}
sub socktype {
@_ == 1 or croak 'usage: $sock->socktype()';
my $sock = shift;
${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
${*$sock}{'io_socket_type'}
}
sub protocol {
@_ == 1 or croak 'usage: $sock->protocol()';
my($sock) = @_;
${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
${*$sock}{'io_socket_proto'};
}
1;
__END__
=head1 NAME
IO::Socket - Object interface to socket communications
=head1 SYNOPSIS
use strict;
use warnings;
use IO::Socket qw(AF_INET AF_UNIX);
# create a new AF_INET socket
my $sock = IO::Socket->new(Domain => AF_INET);
# which is the same as
$sock = IO::Socket::INET->new();
# create a new AF_UNIX socket
$sock = IO::Socket->new(Domain => AF_UNIX);
# which is the same as
$sock = IO::Socket::UNIX->new();
=head1 DESCRIPTION
C provides an object-oriented, L-based interface to
creating and using sockets via L, which provides a near one-to-one
interface to the C socket library.
C is a base class that really only defines methods for those
operations which are common to all types of sockets. Operations which are
specific to a particular socket domain have methods defined in subclasses of
C. See L, L, and
L for examples of such a subclass.
C will export all functions (and constants) defined by L.
=head1 CONSTRUCTOR ARGUMENTS
Given that C doesn't have attributes in the traditional sense, the
following arguments, rather than attributes, can be passed into the
constructor.
Constructor arguments should be passed in C<< Key => 'Value' >> pairs.
The only required argument is L.
=head2 Blocking
my $sock = IO::Socket->new(..., Blocking => 1);
$sock = IO::Socket->new(..., Blocking => 0);
If defined but false, the socket will be set to non-blocking mode. If not
specified it defaults to C<1> (blocking mode).
=head2 Domain
my $sock = IO::Socket->new(Domain => IO::Socket::AF_INET);
$sock = IO::Socket->new(Domain => IO::Socket::AF_UNIX);
The socket domain will define which subclass of C to use. The two
options available along with this distribution are C and C.
C is for the internet address family of sockets and is handled via
L. C sockets are bound to an internet address and
port.
C is for the unix domain socket and is handled via
L. C sockets are bound to the file system as their
address name space.
This argument is B. All other arguments are optional.
=head2 Listen
my $sock = IO::Socket->new(..., Listen => 5);
Listen should be an integer value or left unset.
If provided, this argument will place the socket into listening mode. New
connections can then be accepted using the L method. The
value given is used as the C queue size.
If the C argument is given, but false, the queue size will be set to
5.
=head2 Timeout
my $sock = IO::Socket->new(..., Timeout => 5);
The timeout value, in seconds, for this socket connection. How exactly this
value is utilized is defined in the socket domain subclasses that make use of
the value.
=head2 Type
my $sock = IO::Socket->new(..., Type => IO::Socket::SOCK_STREAM);
The socket type that will be used. These are usually C,
C, or C. If this argument is left undefined an attempt
will be made to infer the type from the service name.
For example, you'll usually use C with a C connection and
C with a C connection.
=head1 CONSTRUCTORS
C extends the L constructor.
=head2 new
my $sock = IO::Socket->new();
# get a new IO::Socket::INET instance
$sock = IO::Socket->new(Domain => IO::Socket::AF_INET);
# get a new IO::Socket::UNIX instance
$sock = IO::Socket->new(Domain => IO::Socket::AF_UNIX);
# Domain is the only required argument
$sock = IO::Socket->new(
Domain => IO::Socket::AF_INET, # AF_INET, AF_UNIX
Type => IO::Socket::SOCK_STREAM, # SOCK_STREAM, SOCK_DGRAM, ...
Proto => 'tcp', # 'tcp', 'udp', IPPROTO_TCP, IPPROTO_UDP
# and so on...
);
Creates an C, which is a reference to a newly created symbol (see
the L package). C optionally takes arguments, these arguments
are defined in L.
Any of the L may be passed to the
constructor, but if any arguments are provided, then one of them must be
the L argument. The L argument can,
by default, be either C or C. Other domains can be used if a
proper subclass for the domain family is registered. All other arguments will
be passed to the C method of the package for that domain.
=head1 METHODS
C inherits all methods from L and implements the
following new ones.
=head2 accept
my $client_sock = $sock->accept();
my $inet_sock = $sock->accept('IO::Socket::INET');
The accept method will perform the system call C on the socket and
return a new object. The new object will be created in the same class as the
listen socket, unless a specific package name is specified. This object can be
used to communicate with the client that was trying to connect.
This differs slightly from the C function in L.
In a scalar context the new socket is returned, or C upon
failure. In a list context a two-element array is returned containing
the new socket and the peer address; the list will be empty upon failure.
=head2 atmark
my $integer = $sock->atmark();
# read in some data on a given socket
my $data;
$sock->read($data, 1024) until $sock->atmark;
# or, export the function to use:
use IO::Socket 'sockatmark';
$sock->read($data, 1024) until sockatmark($sock);
True if the socket is currently positioned at the urgent data mark, false
otherwise. If your system doesn't yet implement C this will throw
an exception.
If your system does not support C, the C