# IO::Socket.pm
#
# Copyright (c) 1997-8 Graham Barr <[email protected]>. 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;

require 5.006;

use IO::Handle;
use Socket 1.3;
use Carp;
use strict;
our(@ISA, $VERSION, @EXPORT_OK);
use Exporter;
use Errno;

# legacy

require IO::Socket::INET;
require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');

@ISA = qw(IO::Handle);

$VERSION = "1.36";

@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;
${*$sock}{'io_socket_proto'} = $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} || ($! == 10022 && $^O eq 'MSWin32'))
) {
# Some systems refuse to re-connect() to
# an already open socket and set errno to EISCONN.
# Windows sets errno to WSAEINVAL (10022)
$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 = $_[3] || $sock->peername;

croak 'send: Cannot determine peer address'
unless(defined $peer);

my $r = defined(getpeername($sock))
? send($sock, $_[1], $flags)
: send($sock, $_[1], $flags, $peer);

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