[p5sagit/p5-mst-13.2.git] / ext / IO / lib / IO / Socket.pm

#

package IO::Socket;

=head1 NAME

IO::Socket - Object interface to socket communications

=head1 SYNOPSIS

    use IO::Socket;

=head1 DESCRIPTION

C<IO::Socket> provides an object interface to creating and using sockets. It
is built upon the L<IO::Handle> interface and inherits all the methods defined
by L<IO::Handle>.

C<IO::Socket> only defines methods for those operations which are common to all
types of socket. Operations which are specified to a socket in a particular 
domain have methods defined in sub classes of C<IO::Socket>

=head1 CONSTRUCTOR

=over 4

=item new ( [ARGS] )

Creates a C<IO::Pipe>, which is a reference to a
newly created symbol (see the C<Symbol> package). C<new>
optionally takes arguments, these arguments are in key-value pairs.
C<new> only looks for one key C<Domain> which tells new which domain
the socket it will be. All other arguments will be passed to the
configuration method of the package for that domain, See below.

=back

=head1 METHODS

See L<perlfunc> for complete descriptions of each of the following
supported C<IO::Seekable> methods, which are just front ends for the
corresponding built-in functions:

    socket
    socketpair
    bind
    listen
    accept
    send
    recv
    peername (getpeername)
    sockname (getsockname)

Some methods take slightly different arguments to those defined in L<perlfunc>
in attempt to make the interface more flexible. These are

=over 4

=item accept([PKG])

perform the system call C<accept> on the socket and return a new object. The
new object will be created in the same class as the listen socket, unless
C<PKG> is specified. This object can be used to communicate with the client
that was trying to connect. In a scalar context the new socket is returned,
or undef upon failure. In an array context a two-element array is returned
containing the new socket and the peer address, the list will
be empty upon failure.

Additional methods that are provided are

=item timeout([VAL])

Set or get the timeout value associated with this socket. If called without
any arguments then the current setting is returned. If called with an argument
the current setting is changed and the previous value returned.

=item sockopt(OPT [, VAL])

Unified method to both set and get options in the SOL_SOCKET level. If called
with one argument then getsockopt is called, otherwise setsockopt is called.

=item sockdomain

Returns the numerical number for the socket domain type. For example, fir
a AF_INET socket the value of &AF_INET will be returned.

=item socktype

Returns the numerical number for the socket type. For example, fir
a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.

=item protocol

Returns the numerical number for the protocol being used on the socket, if
known. If the protocol is unknown, as with an AF_UNIX socket, zero
is returned.

=back

=cut


require 5.000;

use Config;
use IO::Handle;
use Socket 1.3;
use Carp;
use strict;
use vars qw(@ISA @EXPORT_OK $VERSION);
use Exporter;

@ISA = qw(IO::Handle);

# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...

$VERSION = do{my @r=(q$Revision: 1.13 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};

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] = bless \$d, $p;
}

sub _domain2pkg {
    my $domain = shift;

    croak "Unsupported socket domain"
	unless defined $domain2pkg[$domain];

    $domain2pkg[$domain]
}

sub configure {
    my($fh,$arg) = @_;
    my $domain = delete $arg->{Domain};

    croak 'IO::Socket: Cannot configure a generic socket'
	unless defined $domain;

    my $sub = ref(_domain2pkg($domain)) . "::configure";

    goto &{$sub}
	if(defined &{$sub});

    croak "IO::Socket: Cannot configure socket in domain '$domain' $sub";
}

sub socket {
    @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
    my($fh,$domain,$type,$protocol) = @_;

    if(!defined ${*$fh}{'io_socket_domain'}
	|| !ref(${*$fh}{'io_socket_domain'})
	|| ${${*$fh}{'io_socket_domain'}} != $domain) {
	my $pkg = 
	${*$fh}{'io_socket_domain'} = _domain2pkg($domain);
    }

    socket($fh,$domain,$type,$protocol) or
    	return undef;

    ${*$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);

    # remember who we send to, if it was sucessful
    ${*$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;

    # remember who we recv'd from
    ${*$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]);
    # Just a guess
    $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'};
}

sub _addmethod {
    my $self = shift;
    my $name;

    foreach $name (@_) {
	my $n = $name;

	no strict qw(refs);

	*{$n} = sub { 
		    my $pkg = ref(${*{$_[0]}}{'io_socket_domain'});
		    my $sub = "${pkg}::${n}";
		    goto &{$sub} if defined &{$sub};
		    croak qq{Can't locate object method "$n" via package "$pkg"};
		}
		unless defined &{$n};
    }

}


=head1 SUB-CLASSES

=cut

##
## AF_INET
##

package IO::Socket::INET;

use strict;
use vars qw(@ISA $VERSION);
use Socket;
use Carp;
use Exporter;

@ISA = qw(IO::Socket);

IO::Socket::INET->_addmethod( qw(sockaddr sockport sockhost peeraddr peerport peerhost));
IO::Socket::INET->register_domain( AF_INET );

my %socket_type = ( tcp => SOCK_STREAM,
		    udp => SOCK_DGRAM,
		  );

=head2 IO::Socket::INET

C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
and some related methods. The constructor can take the following options

    PeerAddr	Remote host address
    PeerPort	Remote port or service
    LocalPort	Local host bind	port
    LocalAddr	Local host bind	address
    Proto	Protocol name (eg tcp udp etc)
    Type	Socket type (SOCK_STREAM etc)
    Listen	Queue size for listen
    Timeout	Timeout	value for various operations


If Listen is defined then a listen socket is created, else if the socket
type,   which is derived from the protocol, is SOCK_STREAM then a connect
is called.

Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
from the other.

=head2 METHODS

=over 4

=item sockaddr ()

Return the address part of the sockaddr structure for the socket

=item sockport ()

Return the port number that the socket is using on the local host

=item sockhost ()

Return the address part of the sockaddr structure for the socket in a
text form xx.xx.xx.xx

=item peeraddr ()

Return the address part of the sockaddr structure for the socket on
the peer host

=item peerport ()

Return the port number for the socket on the peer host.

=item peerhost ()

Return the address part of the sockaddr structure for the socket on the
peer host in a text form xx.xx.xx.xx

=back

=cut


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;
    carp join("",ref($fh),": ",@_) if @_;
    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};

    my $domain = AF_INET;
    ${*$fh}{'io_socket_domain'} = bless \$domain;

    $fh->socket(AF_INET, $type, $proto) 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);
}

##
## AF_UNIX
##

package IO::Socket::UNIX;

use strict;
use vars qw(@ISA $VERSION);
use Socket;
use Carp;
use Exporter;

@ISA = qw(IO::Socket);

IO::Socket::UNIX->_addmethod(qw(hostpath peerpath));
IO::Socket::UNIX->register_domain( AF_UNIX );

=head2 IO::Socket::UNIX

C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
and some related methods. The constructor can take the following options

    Type    	Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
    Local   	Path to local fifo
    Peer    	Path to peer fifo
    Listen  	Create a listen socket

=head2 METHODS

=over 4

=item hostpath()

Returns the pathname to the fifo at the local end.

=item peerpath()

Returns the pathanme to the fifo at the peer end.

=back

=cut

sub configure {
    my($fh,$arg) = @_;
    my($bport,$cport);

    my $type = $arg->{Type} || SOCK_STREAM;

    my $domain = AF_UNIX;
    ${*$fh}{'io_socket_domain'} = bless \$domain;

    $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;
warn length($n);
    (sockaddr_un($n))[0];
}

sub peerpath {
    @_ == 1 or croak 'usage: $fh->peerpath()';
    my $n = $_[0]->peername || return undef;
warn length($n);
my @n = sockaddr_un($n);
warn join(",",@n);
    (sockaddr_un($n))[0];
}

=head1 AUTHOR

Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>

=head1 REVISION

$Revision: 1.13 $

The VERSION is derived from the revision turning each number after the
first dot into a 2 digit number so

	Revision 1.8   => VERSION 1.08
	Revision 1.2.3 => VERSION 1.0203

=head1 COPYRIGHT

Copyright (c) 1995 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.

=cut

1; # Keep require happy
Commit	Line	Data
8add82fc	1	#
	2
	3	package IO::Socket;
	4
	5	=head1 NAME
	6
27d4819a	7	IO::Socket - Object interface to socket communications
8add82fc	8
	9	=head1 SYNOPSIS
	10
	11	use IO::Socket;
	12
	13	=head1 DESCRIPTION
	14
	15	C<IO::Socket> provides an object interface to creating and using sockets. It
	16	is built upon the L<IO::Handle> interface and inherits all the methods defined
	17	by L<IO::Handle>.
	18
	19	C<IO::Socket> only defines methods for those operations which are common to all
	20	types of socket. Operations which are specified to a socket in a particular
	21	domain have methods defined in sub classes of C<IO::Socket>
	22
27d4819a	23	=head1 CONSTRUCTOR
	24
	25	=over 4
	26
	27	=item new ( [ARGS] )
	28
	29	Creates a C<IO::Pipe>, which is a reference to a
	30	newly created symbol (see the C<Symbol> package). C<new>
	31	optionally takes arguments, these arguments are in key-value pairs.
	32	C<new> only looks for one key C<Domain> which tells new which domain
	33	the socket it will be. All other arguments will be passed to the
	34	configuration method of the package for that domain, See below.
	35
	36	=back
	37
	38	=head1 METHODS
	39
8add82fc	40	See L<perlfunc> for complete descriptions of each of the following
	41	supported C<IO::Seekable> methods, which are just front ends for the
	42	corresponding built-in functions:
	43
	44	socket
	45	socketpair
	46	bind
	47	listen
	48	accept
	49	send
	50	recv
	51	peername (getpeername)
	52	sockname (getsockname)
	53
	54	Some methods take slightly different arguments to those defined in L<perlfunc>
	55	in attempt to make the interface more flexible. These are
	56
27d4819a	57	=over 4
27d4819a	58
8add82fc	59	=item accept([PKG])
	60
	61	perform the system call C<accept> on the socket and return a new object. The
	62	new object will be created in the same class as the listen socket, unless
	63	C<PKG> is specified. This object can be used to communicate with the client
	64	that was trying to connect. In a scalar context the new socket is returned,
	65	or undef upon failure. In an array context a two-element array is returned
	66	containing the new socket and the peer address, the list will
	67	be empty upon failure.
	68
	69	Additional methods that are provided are
	70
	71	=item timeout([VAL])
	72
	73	Set or get the timeout value associated with this socket. If called without
	74	any arguments then the current setting is returned. If called with an argument
	75	the current setting is changed and the previous value returned.
	76
	77	=item sockopt(OPT [, VAL])
	78
	79	Unified method to both set and get options in the SOL_SOCKET level. If called
27d4819a	80	with one argument then getsockopt is called, otherwise setsockopt is called.
	81
	82	=item sockdomain
	83
	84	Returns the numerical number for the socket domain type. For example, fir
	85	a AF_INET socket the value of &AF_INET will be returned.
	86
	87	=item socktype
	88
	89	Returns the numerical number for the socket type. For example, fir
	90	a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
	91
	92	=item protocol
	93
	94	Returns the numerical number for the protocol being used on the socket, if
	95	known. If the protocol is unknown, as with an AF_UNIX socket, zero
	96	is returned.
	97
	98	=back
8add82fc	99
	100	=cut
	101
	102
	103	require 5.000;
	104
	105	use Config;
	106	use IO::Handle;
	107	use Socket 1.3;
	108	use Carp;
	109	use strict;
	110	use vars qw(@ISA @EXPORT_OK $VERSION);
	111	use Exporter;
	112
	113	@ISA = qw(IO::Handle);
	114
	115	# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...
760ac839	116
27d4819a	117	$VERSION = do{my @r=(q$Revision: 1.13 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
8add82fc	118
	119	sub import {
	120	my $pkg = shift;
	121	my $callpkg = caller;
	122	Exporter::export 'Socket', $callpkg, @_;
	123	}
	124
	125	sub new {
	126	my($class,%arg) = @_;
	127	my $fh = $class->SUPER::new();
	128
	129	${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
	130
	131	return scalar(%arg) ? $fh->configure(\%arg)
	132	: $fh;
	133	}
	134
27d4819a	135	my @domain2pkg = ();
	136
	137	sub register_domain {
	138	my($p,$d) = @_;
	139	$domain2pkg[$d] = bless \$d, $p;
	140	}
	141
	142	sub _domain2pkg {
	143	my $domain = shift;
	144
	145	croak "Unsupported socket domain"
	146	unless defined $domain2pkg[$domain];
	147
	148	$domain2pkg[$domain]
	149	}
	150
8add82fc	151	sub configure {
27d4819a	152	my($fh,$arg) = @_;
	153	my $domain = delete $arg->{Domain};
	154
	155	croak 'IO::Socket: Cannot configure a generic socket'
	156	unless defined $domain;
	157
	158	my $sub = ref(_domain2pkg($domain)) . "::configure";
	159
	160	goto &{$sub}
	161	if(defined &{$sub});
	162
	163	croak "IO::Socket: Cannot configure socket in domain '$domain' $sub";
8add82fc	164	}
	165
	166	sub socket {
	167	@_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
	168	my($fh,$domain,$type,$protocol) = @_;
	169
27d4819a	170	if(!defined ${*$fh}{'io_socket_domain'}
	171	\|\| !ref(${*$fh}{'io_socket_domain'})
	172	\|\| ${${*$fh}{'io_socket_domain'}} != $domain) {
	173	my $pkg =
	174	${*$fh}{'io_socket_domain'} = _domain2pkg($domain);
	175	}
	176
8add82fc	177	socket($fh,$domain,$type,$protocol) or
	178	return undef;
	179
27d4819a	180	${*$fh}{'io_socket_type'} = $type;
27d4819a	181	${*$fh}{'io_socket_proto'} = $protocol;
8add82fc	182	$fh;
	183	}
	184
	185	sub socketpair {
	186	@_ == 4 \|\| croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
	187	my($class,$domain,$type,$protocol) = @_;
	188	my $fh1 = $class->new();
	189	my $fh2 = $class->new();
	190
	191	socketpair($fh1,$fh1,$domain,$type,$protocol) or
	192	return ();
	193
27d4819a	194	${$fh1}{'io_socket_type'} = ${$fh2}{'io_socket_type'} = $type;
27d4819a	195	${$fh1}{'io_socket_proto'} = ${$fh2}{'io_socket_proto'} = $protocol;
8add82fc	196
	197	($fh1,$fh2);
	198	}
	199
	200	sub connect {
	201	@_ == 2 \|\| @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
	202	my $fh = shift;
	203	my $addr = @_ == 1 ? shift : sockaddr_in(@_);
	204	my $timeout = ${*$fh}{'io_socket_timeout'};
	205	local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
	206	: $SIG{ALRM} \|\| 'DEFAULT';
	207
760ac839	208	eval {
8add82fc	209	croak 'connect: Bad address'
	210	if(@_ == 2 && !defined $_[1]);
	211
	212	if($timeout) {
	213	defined $Config{d_alarm} && defined alarm($timeout) or
	214	$timeout = 0;
	215	}
	216
760ac839	217	my $ok = connect($fh, $addr);
8add82fc	218
	219	alarm(0)
	220	if($timeout);
	221
760ac839	222	croak "connect: timeout"
760ac839	223	unless defined $fh;
8add82fc	224
760ac839	225	undef $fh unless $ok;
8add82fc	226	};
760ac839	227
8add82fc	228	$fh;
	229	}
	230
	231	sub bind {
	232	@_ == 2 \|\| @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
	233	my $fh = shift;
	234	my $addr = @_ == 1 ? shift : sockaddr_in(@_);
	235
	236	return bind($fh, $addr) ? $fh
	237	: undef;
	238	}
	239
	240	sub listen {
	241	@_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
	242	my($fh,$queue) = @_;
	243	$queue = 5
	244	unless $queue && $queue > 0;
	245
	246	return listen($fh, $queue) ? $fh
	247	: undef;
	248	}
	249
	250	sub accept {
	251	@_ == 1 \|\| @_ == 2 or croak 'usage $fh->accept([PKG])';
	252	my $fh = shift;
	253	my $pkg = shift \|\| $fh;
	254	my $timeout = ${*$fh}{'io_socket_timeout'};
	255	my $new = $pkg->new(Timeout => $timeout);
	256	my $peer = undef;
	257
	258	eval {
	259	if($timeout) {
	260	my $fdset = "";
	261	vec($fdset, $fh->fileno,1) = 1;
	262	croak "accept: timeout"
	263	unless select($fdset,undef,undef,$timeout);
	264	}
	265	$peer = accept($new,$fh);
	266	};
	267
	268	return wantarray ? defined $peer ? ($new, $peer)
	269	: ()
	270	: defined $peer ? $new
	271	: undef;
	272	}
	273
	274	sub sockname {
	275	@_ == 1 or croak 'usage: $fh->sockname()';
	276	getsockname($_[0]);
	277	}
	278
	279	sub peername {
	280	@_ == 1 or croak 'usage: $fh->peername()';
	281	my($fh) = @_;
	282	getpeername($fh)
	283	\|\| ${*$fh}{'io_socket_peername'}
	284	\|\| undef;
	285	}
	286
	287	sub send {
	288	@_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
	289	my $fh = $_[0];
	290	my $flags = $_[2] \|\| 0;
	291	my $peer = $_[3] \|\| $fh->peername;
292
293	croak 'send: Cannot determine peer address'
294	unless($peer);
295
27d4819a	296	my $r = defined(getpeername($fh))
	297	? send($fh, $_[1], $flags)
	298	: send($fh, $_[1], $flags, $peer);
8add82fc	299
	300	# remember who we send to, if it was sucessful
	301	${*$fh}{'io_socket_peername'} = $peer
	302	if(@_ == 4 && defined $r);
	303
	304	$r;
	305	}
	306
	307	sub recv {
	308	@_ == 3 \|\| @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
	309	my $sock = $_[0];
	310	my $len = $_[2];
	311	my $flags = $_[3] \|\| 0;
	312
	313	# remember who we recv'd from
	314	${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
	315	}
	316
	317
	318	sub setsockopt {
	319	@_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
	320	setsockopt($_[0],$_[1],$_[2],$_[3]);
	321	}
	322
	323	my $intsize = length(pack("i",0));
	324
	325	sub getsockopt {
	326	@_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
	327	my $r = getsockopt($_[0],$_[1],$_[2]);
	328	# Just a guess
	329	$r = unpack("i", $r)
	330	if(defined $r && length($r) == $intsize);
	331	$r;
	332	}
	333
	334	sub sockopt {
	335	my $fh = shift;
	336	@_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
	337	: $fh->setsockopt(SOL_SOCKET,@_);
	338	}
	339
	340	sub timeout {
	341	@_ == 1 \|\| @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
	342	my($fh,$val) = @_;
	343	my $r = ${*$fh}{'io_socket_timeout'} \|\| undef;
	344
	345	${*$fh}{'io_socket_timeout'} = 0 + $val
	346	if(@_ == 2);
	347
	348	$r;
	349	}
	350
27d4819a	351	sub sockdomain {
	352	@_ == 1 or croak 'usage: $fh->sockdomain()';
	353	my $fh = shift;
	354	${${*$fh}{'io_socket_domain'}}
	355	}
	356
8add82fc	357	sub socktype {
27d4819a	358	@_ == 1 or croak 'usage: $fh->socktype()';
	359	my $fh = shift;
	360	${*$fh}{'io_socket_type'}
8add82fc	361	}
8add82fc	362
27d4819a	363	sub protocol {
	364	@_ == 1 or croak 'usage: $fh->protocol()';
	365	my($fh) = @_;
	366	${*$fh}{'io_socket_protocol'};
	367	}
	368
	369	sub _addmethod {
	370	my $self = shift;
	371	my $name;
	372
	373	foreach $name (@_) {
	374	my $n = $name;
	375
	376	no strict qw(refs);
	377
	378	*{$n} = sub {
	379	my $pkg = ref(${*{$_[0]}}{'io_socket_domain'});
	380	my $sub = "${pkg}::${n}";
	381	goto &{$sub} if defined &{$sub};
	382	croak qq{Can't locate object method "$n" via package "$pkg"};
	383	}
	384	unless defined &{$n};
	385	}
	386
	387	}
	388
	389
8add82fc	390	=head1 SUB-CLASSES
	391
	392	=cut
	393
	394	##
	395	## AF_INET
	396	##
	397
	398	package IO::Socket::INET;
	399
	400	use strict;
	401	use vars qw(@ISA $VERSION);
	402	use Socket;
	403	use Carp;
	404	use Exporter;
	405
	406	@ISA = qw(IO::Socket);
	407
27d4819a	408	IO::Socket::INET->_addmethod( qw(sockaddr sockport sockhost peeraddr peerport peerhost));
	409	IO::Socket::INET->register_domain( AF_INET );
	410
8add82fc	411	my %socket_type = ( tcp => SOCK_STREAM,
	412	udp => SOCK_DGRAM,
	413	);
	414
	415	=head2 IO::Socket::INET
	416
	417	C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
	418	and some related methods. The constructor can take the following options
	419
	420	PeerAddr Remote host address
	421	PeerPort Remote port or service
	422	LocalPort Local host bind port
	423	LocalAddr Local host bind address
	424	Proto Protocol name (eg tcp udp etc)
	425	Type Socket type (SOCK_STREAM etc)
	426	Listen Queue size for listen
	427	Timeout Timeout value for various operations
	428
27d4819a	429
8add82fc	430	If Listen is defined then a listen socket is created, else if the socket
8add82fc	431	type, which is derived from the protocol, is SOCK_STREAM then a connect
27d4819a	432	is called.
8add82fc	433
	434	Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
	435	from the other.
	436
	437	=head2 METHODS
	438
27d4819a	439	=over 4
	440
	441	=item sockaddr ()
8add82fc	442
	443	Return the address part of the sockaddr structure for the socket
	444
27d4819a	445	=item sockport ()
8add82fc	446
	447	Return the port number that the socket is using on the local host
	448
27d4819a	449	=item sockhost ()
8add82fc	450
	451	Return the address part of the sockaddr structure for the socket in a
	452	text form xx.xx.xx.xx
	453
27d4819a	454	=item peeraddr ()
	455
	456	Return the address part of the sockaddr structure for the socket on
	457	the peer host
	458
	459	=item peerport ()
	460
	461	Return the port number for the socket on the peer host.
8add82fc	462
27d4819a	463	=item peerhost ()
	464
	465	Return the address part of the sockaddr structure for the socket on the
	466	peer host in a text form xx.xx.xx.xx
	467
	468	=back
8add82fc	469
	470	=cut
	471
	472
	473	sub _sock_info {
	474	my($addr,$port,$proto) = @_;
	475	my @proto = ();
	476	my @serv = ();
	477
	478	$port = $1
	479	if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
	480
	481	if(defined $proto) {
	482	@proto = $proto =~ m,\D, ? getprotobyname($proto)
	483	: getprotobynumber($proto);
	484
	485	$proto = $proto[2] \|\| undef;
	486	}
	487
	488	if(defined $port) {
	489	$port =~ s,\((\d+)\)$,,;
	490
	491	my $defport = $1 \|\| undef;
	492	my $pnum = ($port =~ m,^(\d+)$,)[0];
	493
	494	@serv= getservbyname($port, $proto[0] \|\| "")
	495	if($port =~ m,\D,);
	496
	497	$port = $pnum \|\| $serv[2] \|\| $defport \|\| undef;
	498
	499	$proto = (getprotobyname($serv[3]))[2] \|\| undef
	500	if @serv && !$proto;
	501	}
	502
	503	return ($addr \|\| undef,
	504	$port \|\| undef,
	505	$proto \|\| undef
	506	);
	507	}
	508
27d4819a	509	sub _error {
	510	my $fh = shift;
	511	carp join("",ref($fh),": ",@_) if @_;
	512	close($fh)
	513	if(defined fileno($fh));
	514	return undef;
	515	}
	516
8add82fc	517	sub configure {
	518	my($fh,$arg) = @_;
	519	my($lport,$rport,$laddr,$raddr,$proto,$type);
	520
	521
	522	($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
	523	$arg->{LocalPort},
	524	$arg->{Proto});
	525
	526	$laddr = defined $laddr ? inet_aton($laddr)
	527	: INADDR_ANY;
	528
27d4819a	529	return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
	530	unless(defined $laddr);
	531
8add82fc	532	unless(exists $arg->{Listen}) {
	533	($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
	534	$arg->{PeerPort},
	535	$proto);
	536	}
	537
27d4819a	538	if(defined $raddr) {
	539	$raddr = inet_aton($raddr);
	540	return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
	541	unless(defined $raddr);
	542	}
	543
	544	return _error($fh,'Cannot determine protocol')
8add82fc	545	unless($proto);
	546
	547	my $pname = (getprotobynumber($proto))[0];
	548	$type = $arg->{Type} \|\| $socket_type{$pname};
	549
27d4819a	550	my $domain = AF_INET;
	551	${*$fh}{'io_socket_domain'} = bless \$domain;
	552
8add82fc	553	$fh->socket(AF_INET, $type, $proto) or
27d4819a	554	return _error($fh);
8add82fc	555
8add82fc	556	$fh->bind($lport \|\| 0, $laddr) or
27d4819a	557	return _error($fh);
8add82fc	558
	559	if(exists $arg->{Listen}) {
	560	$fh->listen($arg->{Listen} \|\| 5) or
27d4819a	561	return _error($fh);
8add82fc	562	}
8add82fc	563	else {
27d4819a	564	return _error($fh,'Cannot determine remote port')
8add82fc	565	unless($rport \|\| $type == SOCK_DGRAM);
	566
	567	if($type == SOCK_STREAM \|\| defined $raddr) {
27d4819a	568	return _error($fh,'Bad peer address')
27d4819a	569	unless(defined $raddr);
8add82fc	570
27d4819a	571	$fh->connect($rport,$raddr) or
27d4819a	572	return _error($fh);
8add82fc	573	}
	574	}
	575
	576	$fh;
	577	}
	578
	579	sub sockaddr {
	580	@_ == 1 or croak 'usage: $fh->sockaddr()';
	581	my($fh) = @_;
	582	(sockaddr_in($fh->sockname))[1];
	583	}
	584
	585	sub sockport {
	586	@_ == 1 or croak 'usage: $fh->sockport()';
	587	my($fh) = @_;
	588	(sockaddr_in($fh->sockname))[0];
	589	}
	590
	591	sub sockhost {
	592	@_ == 1 or croak 'usage: $fh->sockhost()';
	593	my($fh) = @_;
	594	inet_ntoa($fh->sockaddr);
	595	}
	596
	597	sub peeraddr {
	598	@_ == 1 or croak 'usage: $fh->peeraddr()';
	599	my($fh) = @_;
	600	(sockaddr_in($fh->peername))[1];
	601	}
	602
	603	sub peerport {
	604	@_ == 1 or croak 'usage: $fh->peerport()';
	605	my($fh) = @_;
	606	(sockaddr_in($fh->peername))[0];
	607	}
	608
	609	sub peerhost {
	610	@_ == 1 or croak 'usage: $fh->peerhost()';
	611	my($fh) = @_;
	612	inet_ntoa($fh->peeraddr);
	613	}
	614
	615	##
	616	## AF_UNIX
	617	##
	618
	619	package IO::Socket::UNIX;
	620
	621	use strict;
	622	use vars qw(@ISA $VERSION);
	623	use Socket;
	624	use Carp;
	625	use Exporter;
	626
	627	@ISA = qw(IO::Socket);
	628
27d4819a	629	IO::Socket::UNIX->_addmethod(qw(hostpath peerpath));
	630	IO::Socket::UNIX->register_domain( AF_UNIX );
	631
8add82fc	632	=head2 IO::Socket::UNIX
	633
	634	C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
	635	and some related methods. The constructor can take the following options
	636
	637	Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
	638	Local Path to local fifo
	639	Peer Path to peer fifo
	640	Listen Create a listen socket
	641
	642	=head2 METHODS
	643
27d4819a	644	=over 4
27d4819a	645
8add82fc	646	=item hostpath()
8add82fc	647
27d4819a	648	Returns the pathname to the fifo at the local end.
8add82fc	649
	650	=item peerpath()
	651
27d4819a	652	Returns the pathanme to the fifo at the peer end.
	653
	654	=back
8add82fc	655
	656	=cut
	657
	658	sub configure {
	659	my($fh,$arg) = @_;
	660	my($bport,$cport);
	661
	662	my $type = $arg->{Type} \|\| SOCK_STREAM;
	663
27d4819a	664	my $domain = AF_UNIX;
	665	${*$fh}{'io_socket_domain'} = bless \$domain;
	666
8add82fc	667	$fh->socket(AF_UNIX, $type, 0) or
	668	return undef;
	669
	670	if(exists $arg->{Local}) {
	671	my $addr = sockaddr_un($arg->{Local});
	672	$fh->bind($addr) or
	673	return undef;
	674	}
	675	if(exists $arg->{Listen}) {
	676	$fh->listen($arg->{Listen} \|\| 5) or
	677	return undef;
	678	}
	679	elsif(exists $arg->{Peer}) {
	680	my $addr = sockaddr_un($arg->{Peer});
	681	$fh->connect($addr) or
	682	return undef;
	683	}
	684
	685	$fh;
	686	}
	687
	688	sub hostpath {
	689	@_ == 1 or croak 'usage: $fh->hostpath()';
27d4819a	690	my $n = $_[0]->sockname \|\| return undef;
	691	warn length($n);
	692	(sockaddr_un($n))[0];
8add82fc	693	}
	694
	695	sub peerpath {
	696	@_ == 1 or croak 'usage: $fh->peerpath()';
27d4819a	697	my $n = $_[0]->peername \|\| return undef;
	698	warn length($n);
	699	my @n = sockaddr_un($n);
	700	warn join(",",@n);
	701	(sockaddr_un($n))[0];
8add82fc	702	}
	703
	704	=head1 AUTHOR
	705
27d4819a	706	Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
8add82fc	707
	708	=head1 REVISION
	709
27d4819a	710	$Revision: 1.13 $
8add82fc	711
	712	The VERSION is derived from the revision turning each number after the
	713	first dot into a 2 digit number so
	714
760ac839	715	Revision 1.8 => VERSION 1.08
	716	Revision 1.2.3 => VERSION 1.0203
	717
8add82fc	718	=head1 COPYRIGHT
	719
	720	Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
	721	software; you can redistribute it and/or modify it under the same terms
	722	as Perl itself.
	723
	724	=cut
	725
	726	1; # Keep require happy