382 lines
9.2 KiB
Perl
382 lines
9.2 KiB
Perl
# IO::Socket.pm
|
|
#
|
|
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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.38";
|
|
|
|
@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} || ($^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 = $_[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__
|
|
|