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

# 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.30_01";

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

	    if (!$sel->can_write($timeout)) {
		$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;
}


sub blocking {
    my $sock = shift;

    return $sock->SUPER::blocking(@_)
        if $^O ne 'MSWin32';

    # 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
    # By default all sockets are blocking

    return !${*$sock}{io_sock_nonblocking}
        unless @_;

    my $block = shift;

    ${*$sock}{io_sock_nonblocking} = $block ? "0" : "1";

    return ioctl($sock, 0x8004667e, \${*$sock}{io_sock_nonblocking});
}


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;

    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($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;
    ${*$sock}{'io_socket_domain'};
}

sub socktype {
    @_ == 1 or croak 'usage: $sock->socktype()';
    my $sock = shift;
    ${*$sock}{'io_socket_type'}
}

sub protocol {
    @_ == 1 or croak 'usage: $sock->protocol()';
    my($sock) = @_;
    ${*$sock}{'io_socket_proto'};
}

1;

__END__

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

C<IO::Socket> will export all functions (and constants) defined by L<Socket>.

=head1 CONSTRUCTOR

=over 4

=item new ( [ARGS] )

Creates an C<IO::Socket>, 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 will be in. All other arguments will be passed to the
configuration method of the package for that domain, See below.

 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE

As of VERSION 1.18 all IO::Socket objects have autoflush turned on
by default. This was not the case with earlier releases.

 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE

=back

=head1 METHODS

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

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

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 a list context a two-element array is returned containing
the new socket and the peer address; the list will be empty upon
failure.

The timeout in the [PKG] can be specified as zero to effect a "poll",
but you shouldn't do that because a new IO::Select object will be
created behind the scenes just to do the single poll.  This is
horrendously inefficient.  Use rather true select() with a zero
timeout on the handle, or non-blocking IO.

=item socketpair(DOMAIN, TYPE, PROTOCOL)

Call C<socketpair> and return a list of two sockets created, or an
empty list on failure.

=back

Additional methods that are provided are:

=over 4

=item atmark

True if the socket is currently positioned at the urgent data mark,
false otherwise.

    use IO::Socket;

    my $sock = IO::Socket::INET->new('some_server');
    $sock->read($data, 1024) until $sock->atmark;

Note: this is a reasonably new addition to the family of socket
functions, so all systems may not support this yet.  If it is
unsupported by the system, an attempt to use this method will
abort the program.

The atmark() functionality is also exportable as sockatmark() function:

	use IO::Socket 'sockatmark';

This allows for a more traditional use of sockatmark() as a procedural
socket function.  If your system does not support sockatmark(), the
C<use> declaration will fail at compile time.

=item connected

If the socket is in a connected state the peer address is returned.
If the socket is not in a connected state then undef 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.

=item sockdomain

Returns the numerical number for the socket domain type. For example, for
an AF_INET socket the value of &AF_INET will be 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 socktype

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

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

=back

=head1 SEE ALSO

L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>

=head1 AUTHOR

Graham Barr.  atmark() by Lincoln Stein.  Currently maintained by the
Perl Porters.  Please report all bugs to <perl5-porters@perl.org>.

=head1 COPYRIGHT

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.

The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
This module is distributed under the same terms as Perl itself.
Feel free to use, modify and redistribute it as long as you retain
the correct attribution.

=cut
Commit	Line	Data
774d564b	1	# IO::Socket.pm
8add82fc	2	#
cf7fe8a2	3	# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
cf7fe8a2	4	# This program is free software; you can redistribute it and/or
774d564b	5	# modify it under the same terms as Perl itself.
8add82fc	6
	7	package IO::Socket;
	8
e3407aba	9	require 5.006;
8add82fc	10
8add82fc	11	use IO::Handle;
	12	use Socket 1.3;
	13	use Carp;
	14	use strict;
63a347c7	15	our(@ISA, $VERSION, @EXPORT_OK);
8add82fc	16	use Exporter;
c9fcc6c4	17	use Errno;
8add82fc	18
cf7fe8a2	19	# legacy
	20
	21	require IO::Socket::INET;
27da23d5	22	require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
cf7fe8a2	23
8add82fc	24	@ISA = qw(IO::Handle);
8add82fc	25
2f78ce11	26	$VERSION = "1.30_01";
63a347c7	27
63a347c7	28	@EXPORT_OK = qw(sockatmark);
8add82fc	29
	30	sub import {
	31	my $pkg = shift;
e822bc79	32	if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
63a347c7	33	Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
	34	} else {
	35	my $callpkg = caller;
	36	Exporter::export 'Socket', $callpkg, @_;
	37	}
8add82fc	38	}
	39
	40	sub new {
	41	my($class,%arg) = @_;
cf7fe8a2	42	my $sock = $class->SUPER::new();
	43
	44	$sock->autoflush(1);
8add82fc	45
cf7fe8a2	46	${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
8add82fc	47
cf7fe8a2	48	return scalar(%arg) ? $sock->configure(\%arg)
cf7fe8a2	49	: $sock;
8add82fc	50	}
8add82fc	51
cf7fe8a2	52	my @domain2pkg;
27d4819a	53
	54	sub register_domain {
	55	my($p,$d) = @_;
774d564b	56	$domain2pkg[$d] = $p;
27d4819a	57	}
27d4819a	58
8add82fc	59	sub configure {
cf7fe8a2	60	my($sock,$arg) = @_;
27d4819a	61	my $domain = delete $arg->{Domain};
	62
	63	croak 'IO::Socket: Cannot configure a generic socket'
	64	unless defined $domain;
	65
774d564b	66	croak "IO::Socket: Unsupported socket domain"
774d564b	67	unless defined $domain2pkg[$domain];
27d4819a	68
7a4c00b4	69	croak "IO::Socket: Cannot configure socket in domain '$domain'"
cf7fe8a2	70	unless ref($sock) eq "IO::Socket";
27d4819a	71
cf7fe8a2	72	bless($sock, $domain2pkg[$domain]);
cf7fe8a2	73	$sock->configure($arg);
8add82fc	74	}
	75
	76	sub socket {
cf7fe8a2	77	@_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
cf7fe8a2	78	my($sock,$domain,$type,$protocol) = @_;
8add82fc	79
cf7fe8a2	80	socket($sock,$domain,$type,$protocol) or
8add82fc	81	return undef;
8add82fc	82
cf7fe8a2	83	${*$sock}{'io_socket_domain'} = $domain;
	84	${*$sock}{'io_socket_type'} = $type;
	85	${*$sock}{'io_socket_proto'} = $protocol;
774d564b	86
cf7fe8a2	87	$sock;
8add82fc	88	}
	89
	90	sub socketpair {
c4be5b27	91	@_ == 4 \|\| croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
8add82fc	92	my($class,$domain,$type,$protocol) = @_;
cf7fe8a2	93	my $sock1 = $class->new();
cf7fe8a2	94	my $sock2 = $class->new();
8add82fc	95
cf7fe8a2	96	socketpair($sock1,$sock2,$domain,$type,$protocol) or
8add82fc	97	return ();
8add82fc	98
cf7fe8a2	99	${$sock1}{'io_socket_type'} = ${$sock2}{'io_socket_type'} = $type;
cf7fe8a2	100	${$sock1}{'io_socket_proto'} = ${$sock2}{'io_socket_proto'} = $protocol;
8add82fc	101
cf7fe8a2	102	($sock1,$sock2);
8add82fc	103	}
	104
	105	sub connect {
cf7fe8a2	106	@_ == 2 or croak 'usage: $sock->connect(NAME)';
	107	my $sock = shift;
	108	my $addr = shift;
	109	my $timeout = ${*$sock}{'io_socket_timeout'};
c9fcc6c4	110	my $err;
00fdd80d	111	my $blocking;
cf7fe8a2	112
ae1c8c83	113	$blocking = $sock->blocking(0) if $timeout;
c9fcc6c4	114	if (!connect($sock, $addr)) {
2f78ce11	115	if (defined $timeout && ($!{EINPROGRESS} \|\| $!{EWOULDBLOCK})) {
c9fcc6c4	116	require IO::Select;
8add82fc	117
c9fcc6c4	118	my $sel = new IO::Select $sock;
8add82fc	119
c9fcc6c4	120	if (!$sel->can_write($timeout)) {
	121	$err = $! \|\| (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
	122	$@ = "connect: timeout";
cf7fe8a2	123	}
2f78ce11	124	elsif (!connect($sock,$addr) &&
	125	not ($!{EISCONN} \|\| ($! == 10022 && $^O eq 'MSWin32'))
	126	) {
af663859	127	# Some systems refuse to re-connect() to
af663859	128	# an already open socket and set errno to EISCONN.
2f78ce11	129	# Windows sets errno to WSAEINVAL (10022)
f9c1db8d	130	$err = $!;
f9c1db8d	131	$@ = "connect: $!";
cf7fe8a2	132	}
cf7fe8a2	133	}
2f78ce11	134	elsif ($blocking \|\| !($!{EINPROGRESS} \|\| $!{EWOULDBLOCK})) {
c9fcc6c4	135	$err = $!;
	136	$@ = "connect: $!";
	137	}
	138	}
760ac839	139
c9fcc6c4	140	$sock->blocking(1) if $blocking;
00fdd80d	141
c9fcc6c4	142	$! = $err if $err;
00fdd80d	143
c9fcc6c4	144	$err ? undef : $sock;
8add82fc	145	}
8add82fc	146
2f78ce11	147
	148	sub blocking {
	149	my $sock = shift;
	150
	151	return $sock->SUPER::blocking(@_)
	152	if $^O ne 'MSWin32';
	153
	154	# Windows handles blocking differently
	155	#
	156	# http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/
	157	# thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
	158	# http://msdn.microsoft.com/library/default.asp?url=/library/en-us/
	159	# winsock/winsock/ioctlsocket_2.asp
	160	#
	161	# 0x8004667e is FIONBIO
	162	# By default all sockets are blocking
	163
	164	return !${*$sock}{io_sock_nonblocking}
	165	unless @_;
	166
	167	my $block = shift;
	168
	169	${*$sock}{io_sock_nonblocking} = $block ? "0" : "1";
	170
	171	return ioctl($sock, 0x8004667e, \${*$sock}{io_sock_nonblocking});
	172	}
	173
	174
2d169392	175	sub close {
	176	@_ == 1 or croak 'usage: $sock->close()';
	177	my $sock = shift;
	178	${*$sock}{'io_socket_peername'} = undef;
	179	$sock->SUPER::close();
	180	}
	181
8add82fc	182	sub bind {
cf7fe8a2	183	@_ == 2 or croak 'usage: $sock->bind(NAME)';
	184	my $sock = shift;
	185	my $addr = shift;
8add82fc	186
cf7fe8a2	187	return bind($sock, $addr) ? $sock
cf7fe8a2	188	: undef;
8add82fc	189	}
	190
	191	sub listen {
cf7fe8a2	192	@_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
cf7fe8a2	193	my($sock,$queue) = @_;
8add82fc	194	$queue = 5
	195	unless $queue && $queue > 0;
	196
cf7fe8a2	197	return listen($sock, $queue) ? $sock
cf7fe8a2	198	: undef;
8add82fc	199	}
	200
	201	sub accept {
cf7fe8a2	202	@_ == 1 \|\| @_ == 2 or croak 'usage $sock->accept([PKG])';
	203	my $sock = shift;
	204	my $pkg = shift \|\| $sock;
	205	my $timeout = ${*$sock}{'io_socket_timeout'};
8add82fc	206	my $new = $pkg->new(Timeout => $timeout);
	207	my $peer = undef;
	208
7e92b095	209	if(defined $timeout) {
c9fcc6c4	210	require IO::Select;
cf7fe8a2	211
c9fcc6c4	212	my $sel = new IO::Select $sock;
	213
	214	unless ($sel->can_read($timeout)) {
	215	$@ = 'accept: timeout';
	216	$! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
	217	return;
	218	}
	219	}
	220
	221	$peer = accept($new,$sock)
	222	or return;
cf7fe8a2	223
c9fcc6c4	224	return wantarray ? ($new, $peer)
c9fcc6c4	225	: $new;
8add82fc	226	}
	227
	228	sub sockname {
cf7fe8a2	229	@_ == 1 or croak 'usage: $sock->sockname()';
8add82fc	230	getsockname($_[0]);
	231	}
	232
	233	sub peername {
cf7fe8a2	234	@_ == 1 or croak 'usage: $sock->peername()';
cf7fe8a2	235	my($sock) = @_;
2d169392	236	${*$sock}{'io_socket_peername'} \|\|= getpeername($sock);
8add82fc	237	}
8add82fc	238
cf7fe8a2	239	sub connected {
	240	@_ == 1 or croak 'usage: $sock->connected()';
	241	my($sock) = @_;
	242	getpeername($sock);
	243	}
	244
8add82fc	245	sub send {
cf7fe8a2	246	@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
cf7fe8a2	247	my $sock = $_[0];
8add82fc	248	my $flags = $_[2] \|\| 0;
cf7fe8a2	249	my $peer = $_[3] \|\| $sock->peername;
8add82fc	250
	251	croak 'send: Cannot determine peer address'
	252	unless($peer);
	253
cf7fe8a2	254	my $r = defined(getpeername($sock))
	255	? send($sock, $_[1], $flags)
	256	: send($sock, $_[1], $flags, $peer);
8add82fc	257
a6d05634	258	# remember who we send to, if it was successful
cf7fe8a2	259	${*$sock}{'io_socket_peername'} = $peer
8add82fc	260	if(@_ == 4 && defined $r);
	261
	262	$r;
	263	}
	264
	265	sub recv {
cf7fe8a2	266	@_ == 3 \|\| @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
8add82fc	267	my $sock = $_[0];
	268	my $len = $_[2];
	269	my $flags = $_[3] \|\| 0;
	270
	271	# remember who we recv'd from
	272	${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
	273	}
	274
cf7fe8a2	275	sub shutdown {
	276	@_ == 2 or croak 'usage: $sock->shutdown(HOW)';
	277	my($sock, $how) = @_;
2d169392	278	${*$sock}{'io_socket_peername'} = undef;
cf7fe8a2	279	shutdown($sock, $how);
cf7fe8a2	280	}
8add82fc	281
8add82fc	282	sub setsockopt {
f0bc0462	283	@_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
8add82fc	284	setsockopt($_[0],$_[1],$_[2],$_[3]);
	285	}
	286
	287	my $intsize = length(pack("i",0));
	288
	289	sub getsockopt {
cf7fe8a2	290	@_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
8add82fc	291	my $r = getsockopt($_[0],$_[1],$_[2]);
	292	# Just a guess
	293	$r = unpack("i", $r)
	294	if(defined $r && length($r) == $intsize);
	295	$r;
	296	}
	297
	298	sub sockopt {
cf7fe8a2	299	my $sock = shift;
	300	@_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
	301	: $sock->setsockopt(SOL_SOCKET,@_);
8add82fc	302	}
8add82fc	303
63a347c7	304	sub atmark {
	305	@_ == 1 or croak 'usage: $sock->atmark()';
	306	my($sock) = @_;
	307	sockatmark($sock);
	308	}
	309
8add82fc	310	sub timeout {
cf7fe8a2	311	@_ == 1 \|\| @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
cf7fe8a2	312	my($sock,$val) = @_;
96e47f5b	313	my $r = ${*$sock}{'io_socket_timeout'};
8add82fc	314
96e47f5b	315	${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
8add82fc	316	if(@_ == 2);
	317
	318	$r;
	319	}
	320
27d4819a	321	sub sockdomain {
cf7fe8a2	322	@_ == 1 or croak 'usage: $sock->sockdomain()';
	323	my $sock = shift;
	324	${*$sock}{'io_socket_domain'};
27d4819a	325	}
27d4819a	326
8add82fc	327	sub socktype {
cf7fe8a2	328	@_ == 1 or croak 'usage: $sock->socktype()';
	329	my $sock = shift;
	330	${*$sock}{'io_socket_type'}
8add82fc	331	}
8add82fc	332
27d4819a	333	sub protocol {
cf7fe8a2	334	@_ == 1 or croak 'usage: $sock->protocol()';
cf7fe8a2	335	my($sock) = @_;
8fd73a68	336	${*$sock}{'io_socket_proto'};
27d4819a	337	}
27d4819a	338
cf7fe8a2	339	1;
8add82fc	340
cf7fe8a2	341	__END__
27d4819a	342
cf7fe8a2	343	=head1 NAME
e713eafe	344
cf7fe8a2	345	IO::Socket - Object interface to socket communications
8add82fc	346
cf7fe8a2	347	=head1 SYNOPSIS
7a4c00b4	348
cf7fe8a2	349	use IO::Socket;
7a4c00b4	350
cf7fe8a2	351	=head1 DESCRIPTION
7a4c00b4	352
cf7fe8a2	353	C<IO::Socket> provides an object interface to creating and using sockets. It
	354	is built upon the L<IO::Handle> interface and inherits all the methods defined
	355	by L<IO::Handle>.
8add82fc	356
cf7fe8a2	357	C<IO::Socket> only defines methods for those operations which are common to all
	358	types of socket. Operations which are specified to a socket in a particular
	359	domain have methods defined in sub classes of C<IO::Socket>
e713eafe	360
cf7fe8a2	361	C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
e713eafe	362
cf7fe8a2	363	=head1 CONSTRUCTOR
8add82fc	364
27d4819a	365	=over 4
27d4819a	366
cf7fe8a2	367	=item new ( [ARGS] )
27d4819a	368
cf7fe8a2	369	Creates an C<IO::Socket>, which is a reference to a
	370	newly created symbol (see the C<Symbol> package). C<new>
	371	optionally takes arguments, these arguments are in key-value pairs.
	372	C<new> only looks for one key C<Domain> which tells new which domain
	373	the socket will be in. All other arguments will be passed to the
	374	configuration method of the package for that domain, See below.
8add82fc	375
cf7fe8a2	376	NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
3cb6de81	377
cf7fe8a2	378	As of VERSION 1.18 all IO::Socket objects have autoflush turned on
cf7fe8a2	379	by default. This was not the case with earlier releases.
27d4819a	380
cf7fe8a2	381	NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
27d4819a	382
27d4819a	383	=back
8add82fc	384
cf7fe8a2	385	=head1 METHODS
8add82fc	386
cf7fe8a2	387	See L<perlfunc> for complete descriptions of each of the following
	388	supported C<IO::Socket> methods, which are just front ends for the
	389	corresponding built-in functions:
8add82fc	390
cf7fe8a2	391	socket
	392	socketpair
	393	bind
	394	listen
	395	accept
	396	send
	397	recv
	398	peername (getpeername)
	399	sockname (getsockname)
	400	shutdown
8add82fc	401
cf7fe8a2	402	Some methods take slightly different arguments to those defined in L<perlfunc>
cf7fe8a2	403	in attempt to make the interface more flexible. These are
8add82fc	404
cf7fe8a2	405	=over 4
8add82fc	406
cf7fe8a2	407	=item accept([PKG])
8add82fc	408
7e92b095	409	perform the system call C<accept> on the socket and return a new
	410	object. The new object will be created in the same class as the listen
	411	socket, unless C<PKG> is specified. This object can be used to
	412	communicate with the client that was trying to connect.
	413
	414	In a scalar context the new socket is returned, or undef upon
	415	failure. In a list context a two-element array is returned containing
	416	the new socket and the peer address; the list will be empty upon
	417	failure.
	418
	419	The timeout in the [PKG] can be specified as zero to effect a "poll",
	420	but you shouldn't do that because a new IO::Select object will be
10eaad5c	421	created behind the scenes just to do the single poll. This is
7e92b095	422	horrendously inefficient. Use rather true select() with a zero
7e92b095	423	timeout on the handle, or non-blocking IO.
8add82fc	424
c4be5b27	425	=item socketpair(DOMAIN, TYPE, PROTOCOL)
	426
	427	Call C<socketpair> and return a list of two sockets created, or an
	428	empty list on failure.
	429
	430	=back
	431
	432	Additional methods that are provided are:
	433
	434	=over 4
8add82fc	435
63a347c7	436	=item atmark
8add82fc	437
63a347c7	438	True if the socket is currently positioned at the urgent data mark,
63a347c7	439	false otherwise.
8add82fc	440
63a347c7	441	use IO::Socket;
27d4819a	442
63a347c7	443	my $sock = IO::Socket::INET->new('some_server');
322cad79	444	$sock->read($data, 1024) until $sock->atmark;
8add82fc	445
63a347c7	446	Note: this is a reasonably new addition to the family of socket
	447	functions, so all systems may not support this yet. If it is
	448	unsupported by the system, an attempt to use this method will
	449	abort the program.
8add82fc	450
63a347c7	451	The atmark() functionality is also exportable as sockatmark() function:
8add82fc	452
63a347c7	453	use IO::Socket 'sockatmark';
8add82fc	454
63a347c7	455	This allows for a more traditional use of sockatmark() as a procedural
737dd4b4	456	socket function. If your system does not support sockatmark(), the
737dd4b4	457	C<use> declaration will fail at compile time.
63a347c7	458
	459	=item connected
	460
a6d05634	461	If the socket is in a connected state the peer address is returned.
63a347c7	462	If the socket is not in a connected state then undef will be returned.
27d4819a	463
cf7fe8a2	464	=item protocol
8add82fc	465
cf7fe8a2	466	Returns the numerical number for the protocol being used on the socket, if
	467	known. If the protocol is unknown, as with an AF_UNIX socket, zero
	468	is returned.
8add82fc	469
63a347c7	470	=item sockdomain
8add82fc	471
63a347c7	472	Returns the numerical number for the socket domain type. For example, for
d1be9408	473	an AF_INET socket the value of &AF_INET will be returned.
63a347c7	474
	475	=item sockopt(OPT [, VAL])
	476
	477	Unified method to both set and get options in the SOL_SOCKET level. If called
	478	with one argument then getsockopt is called, otherwise setsockopt is called.
	479
	480	=item socktype
	481
	482	Returns the numerical number for the socket type. For example, for
	483	a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
	484
	485	=item timeout([VAL])
	486
	487	Set or get the timeout value associated with this socket. If called without
	488	any arguments then the current setting is returned. If called with an argument
	489	the current setting is changed and the previous value returned.
27d4819a	490
27d4819a	491	=back
8add82fc	492
7a4c00b4	493	=head1 SEE ALSO
8add82fc	494
cf7fe8a2	495	L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
8add82fc	496
7a4c00b4	497	=head1 AUTHOR
8add82fc	498
63a347c7	499	Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
63a347c7	500	Perl Porters. Please report all bugs to <perl5-porters@perl.org>.
760ac839	501
8add82fc	502	=head1 COPYRIGHT
8add82fc	503
cf7fe8a2	504	Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
	505	This program is free software; you can redistribute it and/or
	506	modify it under the same terms as Perl itself.
8add82fc	507
63a347c7	508	The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
	509	This module is distributed under the same terms as Perl itself.
	510	Feel free to use, modify and redistribute it as long as you retain
	511	the correct attribution.
	512
8add82fc	513	=cut