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

#

package IO::Socket;

=head1 NAME

IO::Socket - supply object methods for sockets

=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>

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

=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

=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.9 $=~/(\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;
}

sub configure {
    croak 'IO::Socket: Cannot configure a generic socket';
}

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_type'} = $type;
    $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,$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 = 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 socktype {
    @_ == 1 or croak '$fh->socktype()';
    ${*{$_[0]}}{'io_socket_type'} || undef;
}

=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);

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

=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(), peerport(), peerhost()

Same as for the sock* functions, but returns the data about the peer
host instead of the local host.

=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 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;

    unless(exists $arg->{Listen}) {
	($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
					    $arg->{PeerPort},
					    $proto);
    }

    croak 'IO::Socket: Cannot determine protocol'
	unless($proto);

    my $pname = (getprotobynumber($proto))[0];
    $type = $arg->{Type} || $socket_type{$pname};

    $fh->socket(AF_INET, $type, $proto) or
	return undef;

    $fh->bind($lport || 0, $laddr) or
	return undef;

    if(exists $arg->{Listen}) {
	$fh->listen($arg->{Listen} || 5) or
	    return undef;
    }
    else {
	croak "IO::Socket: Cannot determine remote port"
		unless($rport || $type == SOCK_DGRAM);

	if($type == SOCK_STREAM || defined $raddr) {
	    croak "IO::Socket: Bad peer address"
		unless defined $raddr;

	    $fh->connect($rport,inet_aton($raddr)) or
		return undef;
	}
    }

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

=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

=item hostpath()

Returns the pathname to the fifo at the local end

=item peerpath()

Returns the pathanme to the fifo at the peer end

=cut

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()';
    (sockaddr_un($_[0]->hostname))[0];
}

sub peerpath {
    @_ == 1 or croak 'usage: $fh->peerpath()';
    (sockaddr_un($_[0]->peername))[0];
}

=head1 AUTHOR

Graham Barr <Graham.Barr@tiuk.ti.com>

=head1 REVISION

$Revision: 1.9 $

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
	7	IO::Socket - supply object methods for sockets
	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
	23	See L<perlfunc> for complete descriptions of each of the following
	24	supported C<IO::Seekable> methods, which are just front ends for the
	25	corresponding built-in functions:
	26
	27	socket
	28	socketpair
	29	bind
	30	listen
	31	accept
	32	send
	33	recv
	34	peername (getpeername)
	35	sockname (getsockname)
	36
	37	Some methods take slightly different arguments to those defined in L<perlfunc>
	38	in attempt to make the interface more flexible. These are
	39
	40	=item accept([PKG])
	41
	42	perform the system call C<accept> on the socket and return a new object. The
	43	new object will be created in the same class as the listen socket, unless
	44	C<PKG> is specified. This object can be used to communicate with the client
	45	that was trying to connect. In a scalar context the new socket is returned,
	46	or undef upon failure. In an array context a two-element array is returned
	47	containing the new socket and the peer address, the list will
	48	be empty upon failure.
	49
	50	Additional methods that are provided are
	51
	52	=item timeout([VAL])
	53
	54	Set or get the timeout value associated with this socket. If called without
	55	any arguments then the current setting is returned. If called with an argument
	56	the current setting is changed and the previous value returned.
	57
	58	=item sockopt(OPT [, VAL])
	59
	60	Unified method to both set and get options in the SOL_SOCKET level. If called
	61	with one argument then getsockopt is called, otherwise setsockopt is called
	62
	63	=cut
	64
65
66	require 5.000;
67
68	use Config;
69	use IO::Handle;
70	use Socket 1.3;
71	use Carp;
72	use strict;
73	use vars qw(@ISA @EXPORT_OK $VERSION);
74	use Exporter;
75
76	@ISA = qw(IO::Handle);
77
78	# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...
760ac839	79
760ac839	80	$VERSION = do{my @r=(q$Revision: 1.9 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
8add82fc	81
	82	sub import {
	83	my $pkg = shift;
	84	my $callpkg = caller;
	85	Exporter::export 'Socket', $callpkg, @_;
	86	}
	87
	88	sub new {
	89	my($class,%arg) = @_;
	90	my $fh = $class->SUPER::new();
	91
	92	${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
	93
	94	return scalar(%arg) ? $fh->configure(\%arg)
	95	: $fh;
	96	}
	97
	98	sub configure {
	99	croak 'IO::Socket: Cannot configure a generic socket';
	100	}
	101
	102	sub socket {
	103	@_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
	104	my($fh,$domain,$type,$protocol) = @_;
	105
	106	socket($fh,$domain,$type,$protocol) or
	107	return undef;
	108
	109	${*$fh}{'io_socket_type'} = $type;
	110	$fh;
	111	}
	112
	113	sub socketpair {
	114	@_ == 4 \|\| croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
	115	my($class,$domain,$type,$protocol) = @_;
	116	my $fh1 = $class->new();
	117	my $fh2 = $class->new();
	118
	119	socketpair($fh1,$fh1,$domain,$type,$protocol) or
	120	return ();
	121
	122	${$fh1}{'io_socket_type'} = ${$fh2}{'io_socket_type'} = $type;
	123
	124	($fh1,$fh2);
	125	}
	126
	127	sub connect {
	128	@_ == 2 \|\| @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
	129	my $fh = shift;
	130	my $addr = @_ == 1 ? shift : sockaddr_in(@_);
	131	my $timeout = ${*$fh}{'io_socket_timeout'};
	132	local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
	133	: $SIG{ALRM} \|\| 'DEFAULT';
	134
760ac839	135	eval {
8add82fc	136	croak 'connect: Bad address'
	137	if(@_ == 2 && !defined $_[1]);
	138
	139	if($timeout) {
	140	defined $Config{d_alarm} && defined alarm($timeout) or
	141	$timeout = 0;
	142	}
	143
760ac839	144	my $ok = connect($fh, $addr);
8add82fc	145
	146	alarm(0)
	147	if($timeout);
	148
760ac839	149	croak "connect: timeout"
760ac839	150	unless defined $fh;
8add82fc	151
760ac839	152	undef $fh unless $ok;
8add82fc	153	};
760ac839	154
8add82fc	155	$fh;
	156	}
	157
	158	sub bind {
	159	@_ == 2 \|\| @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
	160	my $fh = shift;
	161	my $addr = @_ == 1 ? shift : sockaddr_in(@_);
	162
	163	return bind($fh, $addr) ? $fh
	164	: undef;
	165	}
	166
	167	sub listen {
	168	@_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
	169	my($fh,$queue) = @_;
	170	$queue = 5
	171	unless $queue && $queue > 0;
	172
	173	return listen($fh, $queue) ? $fh
	174	: undef;
	175	}
	176
	177	sub accept {
	178	@_ == 1 \|\| @_ == 2 or croak 'usage $fh->accept([PKG])';
	179	my $fh = shift;
	180	my $pkg = shift \|\| $fh;
	181	my $timeout = ${*$fh}{'io_socket_timeout'};
	182	my $new = $pkg->new(Timeout => $timeout);
	183	my $peer = undef;
	184
	185	eval {
	186	if($timeout) {
	187	my $fdset = "";
	188	vec($fdset, $fh->fileno,1) = 1;
	189	croak "accept: timeout"
	190	unless select($fdset,undef,undef,$timeout);
	191	}
	192	$peer = accept($new,$fh);
	193	};
	194
	195	return wantarray ? defined $peer ? ($new, $peer)
	196	: ()
	197	: defined $peer ? $new
	198	: undef;
	199	}
	200
	201	sub sockname {
	202	@_ == 1 or croak 'usage: $fh->sockname()';
	203	getsockname($_[0]);
	204	}
	205
	206	sub peername {
	207	@_ == 1 or croak 'usage: $fh->peername()';
	208	my($fh) = @_;
	209	getpeername($fh)
	210	\|\| ${*$fh}{'io_socket_peername'}
	211	\|\| undef;
	212	}
	213
	214	sub send {
	215	@_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
	216	my $fh = $_[0];
	217	my $flags = $_[2] \|\| 0;
	218	my $peer = $_[3] \|\| $fh->peername;
219
220	croak 'send: Cannot determine peer address'
221	unless($peer);
222
223	my $r = send($fh, $_[1], $flags, $peer);
224
225	# remember who we send to, if it was sucessful
226	${*$fh}{'io_socket_peername'} = $peer
227	if(@_ == 4 && defined $r);
228
229	$r;
230	}
231
232	sub recv {
233	@_ == 3 \|\| @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
234	my $sock = $_[0];
235	my $len = $_[2];
236	my $flags = $_[3] \|\| 0;
237
238	# remember who we recv'd from
239	${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
240	}
241
242
243	sub setsockopt {
244	@_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
245	setsockopt($_[0],$_[1],$_[2],$_[3]);
246	}
247
248	my $intsize = length(pack("i",0));
249
250	sub getsockopt {
251	@_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
252	my $r = getsockopt($_[0],$_[1],$_[2]);
253	# Just a guess
254	$r = unpack("i", $r)
255	if(defined $r && length($r) == $intsize);
256	$r;
257	}
258
259	sub sockopt {
260	my $fh = shift;
261	@_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
262	: $fh->setsockopt(SOL_SOCKET,@_);
263	}
264
265	sub timeout {
266	@_ == 1 \|\| @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
267	my($fh,$val) = @_;
268	my $r = ${*$fh}{'io_socket_timeout'} \|\| undef;
269
270	${*$fh}{'io_socket_timeout'} = 0 + $val
271	if(@_ == 2);
272
273	$r;
274	}
275
276	sub socktype {
277	@_ == 1 or croak '$fh->socktype()';
278	${*{$_[0]}}{'io_socket_type'} \|\| undef;
279	}
280
281	=head1 SUB-CLASSES
282
283	=cut
284
285	##
286	## AF_INET
287	##
288
289	package IO::Socket::INET;
290
291	use strict;
292	use vars qw(@ISA $VERSION);
293	use Socket;
294	use Carp;
295	use Exporter;
296
297	@ISA = qw(IO::Socket);
298
299	my %socket_type = ( tcp => SOCK_STREAM,
300	udp => SOCK_DGRAM,
301	);
302
303	=head2 IO::Socket::INET
304
305	C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
306	and some related methods. The constructor can take the following options
307
308	PeerAddr Remote host address
309	PeerPort Remote port or service
310	LocalPort Local host bind port
311	LocalAddr Local host bind address
312	Proto Protocol name (eg tcp udp etc)
313	Type Socket type (SOCK_STREAM etc)
314	Listen Queue size for listen
315	Timeout Timeout value for various operations
316
317	If Listen is defined then a listen socket is created, else if the socket
318	type, which is derived from the protocol, is SOCK_STREAM then a connect
319	is called
320
321	Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
322	from the other.
323
324	=head2 METHODS
325
326	=item sockaddr()
327
328	Return the address part of the sockaddr structure for the socket
329
330	=item sockport()
331
332	Return the port number that the socket is using on the local host
333
334	=item sockhost()
335
336	Return the address part of the sockaddr structure for the socket in a
337	text form xx.xx.xx.xx
338
339	=item peeraddr(), peerport(), peerhost()
340
341	Same as for the sock* functions, but returns the data about the peer
342	host instead of the local host.
343
344	=cut
345
346
347	sub _sock_info {
348	my($addr,$port,$proto) = @_;
349	my @proto = ();
350	my @serv = ();
351
352	$port = $1
353	if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
354
355	if(defined $proto) {
356	@proto = $proto =~ m,\D, ? getprotobyname($proto)
357	: getprotobynumber($proto);
358
359	$proto = $proto[2] \|\| undef;
360	}
361
362	if(defined $port) {
363	$port =~ s,\((\d+)\)$,,;
364
365	my $defport = $1 \|\| undef;
366	my $pnum = ($port =~ m,^(\d+)$,)[0];
367
368	@serv= getservbyname($port, $proto[0] \|\| "")
369	if($port =~ m,\D,);
370
371	$port = $pnum \|\| $serv[2] \|\| $defport \|\| undef;
372
373	$proto = (getprotobyname($serv[3]))[2] \|\| undef
374	if @serv && !$proto;
375	}
376
377	return ($addr \|\| undef,
378	$port \|\| undef,
379	$proto \|\| undef
380	);
381	}
382
383	sub configure {
384	my($fh,$arg) = @_;
385	my($lport,$rport,$laddr,$raddr,$proto,$type);
386
387
388	($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
389	$arg->{LocalPort},
390	$arg->{Proto});
391
392	$laddr = defined $laddr ? inet_aton($laddr)
393	: INADDR_ANY;
394
395	unless(exists $arg->{Listen}) {
396	($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
397	$arg->{PeerPort},
398	$proto);
399	}
400
401	croak 'IO::Socket: Cannot determine protocol'
402	unless($proto);
403
404	my $pname = (getprotobynumber($proto))[0];
405	$type = $arg->{Type} \|\| $socket_type{$pname};
406
407	$fh->socket(AF_INET, $type, $proto) or
408	return undef;
409
410	$fh->bind($lport \|\| 0, $laddr) or
411	return undef;
412
413	if(exists $arg->{Listen}) {
414	$fh->listen($arg->{Listen} \|\| 5) or
415	return undef;
416	}
417	else {
418	croak "IO::Socket: Cannot determine remote port"
419	unless($rport \|\| $type == SOCK_DGRAM);
420
421	if($type == SOCK_STREAM \|\| defined $raddr) {
422	croak "IO::Socket: Bad peer address"
423	unless defined $raddr;
424
425	$fh->connect($rport,inet_aton($raddr)) or
426	return undef;
427	}
428	}
429
430	$fh;
431	}
432
433	sub sockaddr {
434	@_ == 1 or croak 'usage: $fh->sockaddr()';
435	my($fh) = @_;
436	(sockaddr_in($fh->sockname))[1];
437	}
438
439	sub sockport {
440	@_ == 1 or croak 'usage: $fh->sockport()';
441	my($fh) = @_;
442	(sockaddr_in($fh->sockname))[0];
443	}
444
445	sub sockhost {
446	@_ == 1 or croak 'usage: $fh->sockhost()';
447	my($fh) = @_;
448	inet_ntoa($fh->sockaddr);
449	}
450
451	sub peeraddr {
452	@_ == 1 or croak 'usage: $fh->peeraddr()';
453	my($fh) = @_;
454	(sockaddr_in($fh->peername))[1];
455	}
456
457	sub peerport {
458	@_ == 1 or croak 'usage: $fh->peerport()';
459	my($fh) = @_;
460	(sockaddr_in($fh->peername))[0];
461	}
462
463	sub peerhost {
464	@_ == 1 or croak 'usage: $fh->peerhost()';
465	my($fh) = @_;
466	inet_ntoa($fh->peeraddr);
467	}
468
469	##
470	## AF_UNIX
471	##
472
473	package IO::Socket::UNIX;
474
475	use strict;
476	use vars qw(@ISA $VERSION);
477	use Socket;
478	use Carp;
479	use Exporter;
480
481	@ISA = qw(IO::Socket);
482
483	=head2 IO::Socket::UNIX
484
485	C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
486	and some related methods. The constructor can take the following options
487
488	Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
489	Local Path to local fifo
490	Peer Path to peer fifo
491	Listen Create a listen socket
492
493	=head2 METHODS
494
495	=item hostpath()
496
497	Returns the pathname to the fifo at the local end
498
499	=item peerpath()
500
501	Returns the pathanme to the fifo at the peer end
502
503	=cut
504
505	sub configure {
506	my($fh,$arg) = @_;
507	my($bport,$cport);
508
509	my $type = $arg->{Type} \|\| SOCK_STREAM;
510
511	$fh->socket(AF_UNIX, $type, 0) or
512	return undef;
513
514	if(exists $arg->{Local}) {
515	my $addr = sockaddr_un($arg->{Local});
516	$fh->bind($addr) or
517	return undef;
518	}
519	if(exists $arg->{Listen}) {
520	$fh->listen($arg->{Listen} \|\| 5) or
521	return undef;
522	}
523	elsif(exists $arg->{Peer}) {
524	my $addr = sockaddr_un($arg->{Peer});
525	$fh->connect($addr) or
526	return undef;
527	}
528
529	$fh;
530	}
531
532	sub hostpath {
533	@_ == 1 or croak 'usage: $fh->hostpath()';
534	(sockaddr_un($_[0]->hostname))[0];
535	}
536
537	sub peerpath {
538	@_ == 1 or croak 'usage: $fh->peerpath()';
539	(sockaddr_un($_[0]->peername))[0];
540	}
541
542	=head1 AUTHOR
543
544	Graham Barr <Graham.Barr@tiuk.ti.com>
545
546	=head1 REVISION
547
760ac839	548	$Revision: 1.9 $
8add82fc	549
	550	The VERSION is derived from the revision turning each number after the
	551	first dot into a 2 digit number so
	552
760ac839	553	Revision 1.8 => VERSION 1.08
	554	Revision 1.2.3 => VERSION 1.0203
	555
8add82fc	556	=head1 COPYRIGHT
	557
	558	Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
	559	software; you can redistribute it and/or modify it under the same terms
	560	as Perl itself.
	561
	562	=cut
	563
	564	1; # Keep require happy