require 5.000;
use vars qw(@ISA $VERSION);@ISA = qw(IO::Handle);
$VERSION = "1.16";
sub import {
my $pkg = shift;
my $callpkg = caller;
Exporter::export 'Socket', $callpkg, @_;
}
sub new {
my($class,%arg) = @_;
my $fh = $class->SUPER::new();
${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
return scalar(%arg) ? $fh->configure(\%arg)
: $fh;
}
my @domain2pkg = ();
sub register_domain {
my($p,$d) = @_;
$domain2pkg[$d] = $p;
}
sub configure {
my($fh,$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($fh) eq "IO::Socket";
bless($fh, $domain2pkg[$domain]);
$fh->configure;
}
sub socket {
@_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
my($fh,$domain,$type,$protocol) = @_;
socket($fh,$domain,$type,$protocol) or
return undef;
${*$fh}{'io_socket_domain'} = $domain;
${*$fh}{'io_socket_type'} = $type;
${*$fh}{'io_socket_proto'} = $protocol;
$fh;
}
sub socketpair {
@_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
my($class,$domain,$type,$protocol) = @_;
my $fh1 = $class->new();
my $fh2 = $class->new();
socketpair($fh1,$fh1,$domain,$type,$protocol) or
return ();
${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
($fh1,$fh2);
}
sub connect {
@_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
my $fh = shift;
my $addr = @_ == 1 ? shift : sockaddr_in(@_);
my $timeout = ${*$fh}{'io_socket_timeout'};
local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
: $SIG{ALRM} || 'DEFAULT';
eval {
croak 'connect: Bad address'
if(@_ == 2 && !defined $_[1]);
if($timeout) {
defined $Config{d_alarm} && defined alarm($timeout) or
$timeout = 0;
}
my $ok = connect($fh, $addr);
alarm(0)
if($timeout);
croak "connect: timeout"
unless defined $fh;
undef $fh unless $ok;
};
$fh;
}
sub bind {
@_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
my $fh = shift;
my $addr = @_ == 1 ? shift : sockaddr_in(@_);
return bind($fh, $addr) ? $fh
: undef;
}
sub listen {
@_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
my($fh,$queue) = @_;
$queue = 5
unless $queue && $queue > 0;
return listen($fh, $queue) ? $fh
: undef;
}
sub accept {
@_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
my $fh = shift;
my $pkg = shift || $fh;
my $timeout = ${*$fh}{'io_socket_timeout'};
my $new = $pkg->new(Timeout => $timeout);
my $peer = undef;
eval {
if($timeout) {
my $fdset = "";
vec($fdset, $fh->fileno,1) = 1;
croak "accept: timeout"
unless select($fdset,undef,undef,$timeout);
}
$peer = accept($new,$fh);
};
return wantarray ? defined $peer ? ($new, $peer)
: ()
: defined $peer ? $new
: undef;
}
sub sockname {
@_ == 1 or croak 'usage: $fh->sockname()';
getsockname($_[0]);
}
sub peername {
@_ == 1 or croak 'usage: $fh->peername()';
my($fh) = @_;
getpeername($fh)
|| ${*$fh}{'io_socket_peername'}
|| undef;
}
sub send {
@_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
my $fh = $_[0];
my $flags = $_[2] || 0;
my $peer = $_[3] || $fh->peername;
croak 'send: Cannot determine peer address'
unless($peer);
my $r = defined(getpeername($fh))
? send($fh, $_[1], $flags)
: send($fh, $_[1], $flags, $peer);
${*$fh}{'io_socket_peername'} = $peer
if(@_ == 4 && defined $r);
$r;
}
sub recv {
@_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
my $sock = $_[0];
my $len = $_[2];
my $flags = $_[3] || 0;
${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}
sub setsockopt {
@_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
setsockopt($_[0],$_[1],$_[2],$_[3]);
}
my $intsize = length(pack("i",0));
sub getsockopt {
@_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
my $r = getsockopt($_[0],$_[1],$_[2]);
$r = unpack("i", $r)
if(defined $r && length($r) == $intsize);
$r;
}
sub sockopt {
my $fh = shift;
@_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
: $fh->setsockopt(SOL_SOCKET,@_);
}
sub timeout {
@_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
my($fh,$val) = @_;
my $r = ${*$fh}{'io_socket_timeout'} || undef;
${*$fh}{'io_socket_timeout'} = 0 + $val
if(@_ == 2);
$r;
}
sub sockdomain {
@_ == 1 or croak 'usage: $fh->sockdomain()';
my $fh = shift;
${*$fh}{'io_socket_domain'};
}
sub socktype {
@_ == 1 or croak 'usage: $fh->socktype()';
my $fh = shift;
${*$fh}{'io_socket_type'}
}
sub protocol {
@_ == 1 or croak 'usage: $fh->protocol()';
my($fh) = @_;
${*$fh}{'io_socket_protocol'};
}
@ISA = qw(IO::Socket);
IO::Socket::INET->register_domain( AF_INET );
my %socket_type = ( tcp => SOCK_STREAM,
udp => SOCK_DGRAM,
);
sub _sock_info {
my($addr,$port,$proto) = @_;
my @proto = ();
my @serv = ();
$port = $1
if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
if(defined $proto) {
@proto = $proto =~ m,\D, ? getprotobyname($proto)
: getprotobynumber($proto);
$proto = $proto[2] || undef;
}
if(defined $port) {
$port =~ s,\((\d+)\)$,,;
my $defport = $1 || undef;
my $pnum = ($port =~ m,^(\d+)$,)[0];
@serv= getservbyname($port, $proto[0] || "")
if($port =~ m,\D,);
$port = $pnum || $serv[2] || $defport || undef;
$proto = (getprotobyname($serv[3]))[2] || undef
if @serv && !$proto;
}
return ($addr || undef,
$port || undef,
$proto || undef
);
}
sub _error {
my $fh = shift;
$@ = join("",ref($fh),": ",@_);
carp $@ if $^W;
close($fh)
if(defined fileno($fh));
return undef;
}
sub configure {
my($fh,$arg) = @_;
my($lport,$rport,$laddr,$raddr,$proto,$type);
($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
$arg->{LocalPort},
$arg->{Proto});
$laddr = defined $laddr ? inet_aton($laddr)
: INADDR_ANY;
return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
unless(defined $laddr);
unless(exists $arg->{Listen}) {
($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
$arg->{PeerPort},
$proto);
}
if(defined $raddr) {
$raddr = inet_aton($raddr);
return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
unless(defined $raddr);
}
return _error($fh,'Cannot determine protocol')
unless($proto);
my $pname = (getprotobynumber($proto))[0];
$type = $arg->{Type} || $socket_type{$pname};
$fh->socket(AF_INET, $type, $proto) or
return _error($fh,"$!");
if ($arg->{Reuse}) {
$fh->sockopt(SO_REUSEADDR,1) or
return _error($fh);
}
$fh->bind($lport || 0, $laddr) or
return _error($fh,"$!");
if(exists $arg->{Listen}) {
$fh->listen($arg->{Listen} || 5) or
return _error($fh,"$!");
}
else {
return _error($fh,'Cannot determine remote port')
unless($rport || $type == SOCK_DGRAM);
if($type == SOCK_STREAM || defined $raddr) {
return _error($fh,'Bad peer address')
unless(defined $raddr);
$fh->connect($rport,$raddr) or
return _error($fh,"$!");
}
}
$fh;
}
sub sockaddr {
@_ == 1 or croak 'usage: $fh->sockaddr()';
my($fh) = @_;
(sockaddr_in($fh->sockname))[1];
}
sub sockport {
@_ == 1 or croak 'usage: $fh->sockport()';
my($fh) = @_;
(sockaddr_in($fh->sockname))[0];
}
sub sockhost {
@_ == 1 or croak 'usage: $fh->sockhost()';
my($fh) = @_;
inet_ntoa($fh->sockaddr);
}
sub peeraddr {
@_ == 1 or croak 'usage: $fh->peeraddr()';
my($fh) = @_;
(sockaddr_in($fh->peername))[1];
}
sub peerport {
@_ == 1 or croak 'usage: $fh->peerport()';
my($fh) = @_;
(sockaddr_in($fh->peername))[0];
}
sub peerhost {
@_ == 1 or croak 'usage: $fh->peerhost()';
my($fh) = @_;
inet_ntoa($fh->peeraddr);
}
use vars qw(@ISA $VERSION);@ISA = qw(IO::Socket);
IO::Socket::UNIX->register_domain( AF_UNIX );
sub configure {
my($fh,$arg) = @_;
my($bport,$cport);
my $type = $arg->{Type} || SOCK_STREAM;
$fh->socket(AF_UNIX, $type, 0) or
return undef;
if(exists $arg->{Local}) {
my $addr = sockaddr_un($arg->{Local});
$fh->bind($addr) or
return undef;
}
if(exists $arg->{Listen}) {
$fh->listen($arg->{Listen} || 5) or
return undef;
}
elsif(exists $arg->{Peer}) {
my $addr = sockaddr_un($arg->{Peer});
$fh->connect($addr) or
return undef;
}
$fh;
}
sub hostpath {
@_ == 1 or croak 'usage: $fh->hostpath()';
my $n = $_[0]->sockname || return undef;
(sockaddr_un($n))[0];
}
sub peerpath {
@_ == 1 or croak 'usage: $fh->peerpath()';
my $n = $_[0]->peername || return undef;
(sockaddr_un($n))[0];
}
1;