FM / IO

/usr/lib/x86_64-linux-gnu/perl-base/IO

Name	Size	Mode	Actions
Socket/	-	0755	rm
File.pm	1636	0644	edit dl rm
Handle.pm	7700	0644	edit dl rm
Pipe.pm	3414	0644	edit dl rm
Seekable.pm	642	0644	edit dl rm
Select.pm	4714	0644	edit dl rm
Socket.pm	9938	0644	edit dl rm

Edit: /usr/lib/x86_64-linux-gnu/perl-base/IO/Socket.pm (9938B)

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

use 5.008_001;

use IO::Handle;
use Socket 1.3;
use Carp;
use strict;
use Exporter;
use Errno;

# legacy

require IO::Socket::INET;
require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');

our @ISA = qw(IO::Handle);

our $VERSION = "1.46";

our @EXPORT_OK = qw(sockatmark);

our $errstr;

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;

# "A value of 0 for protocol will let the system select an
    # appropriate protocol"
    # so we need to look up what the system selected,
    # not cache PF_UNSPEC.
    ${*$sock}{'io_socket_proto'} = $protocol if $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 = IO::Select->new( $sock );

undef $!;
	    my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
	    if(@$e[0]) {
		# Windows return from select after the timeout in case of
		# WSAECONNREFUSED(10061) if exception set is not used.
		# This behavior is different from Linux.
		# Using the exception
		# set we now emulate the behavior in Linux
		#    - Karthik Rajagopalan
		$err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
		$errstr = $@ = "connect: $err";
	    }
	    elsif(!@$w[0]) {
		$err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
		$errstr = $@ = "connect: timeout";
	    }
	    elsif (!connect($sock,$addr) &&
                not ($!{EISCONN} || ($^O eq 'MSWin32' &&
                ($! == (($] < 5.019004) ? 10022 : Errno::EINVAL))))
            ) {
		# Some systems refuse to re-connect() to
		# an already open socket and set errno to EISCONN.
		# Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
		# EINVAL (22) (5.19.4 onwards).
		$err = $!;
		$errstr = $@ = "connect: $!";
	    }
	}
        elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK}))  {
	    $err = $!;
	    $errstr = $@ = "connect: $!";
	}
    }

$sock->blocking(1) if $blocking;

$! = $err if $err;

$err ? undef : $sock;
}

# Enable/disable blocking IO on sockets.
# Without args return the current status of blocking,
# with args change the mode as appropriate, returning the
# old setting, or in case of error during the mode change
# undef.

sub blocking {
    my $sock = shift;

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

# Windows handles blocking differently
    #
    # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
    # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
    #
    # 0x8004667e is FIONBIO
    #
    # which is used to set blocking behaviour.

# NOTE:
    # This is a little confusing, the perl keyword for this is
    # 'blocking' but the OS level behaviour is 'non-blocking', probably
    # because sockets are blocking by default.
    # Therefore internally we have to reverse the semantics.

my $orig= !${*$sock}{io_sock_nonblocking};

return $orig unless @_;

my $block = shift;

if ( !$block != !$orig ) {
        ${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
        ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
            or return undef;
    }

return $orig;
}

sub close {
    @_ == 1 or croak 'usage: $sock->close()';
    my $sock = shift;
    ${*$sock}{'io_socket_peername'} = undef;
    $sock->SUPER::close();
}

sub bind {
    @_ == 2 or croak 'usage: $sock->bind(NAME)';
    my $sock = shift;
    my $addr = shift;

return bind($sock, $addr) ? $sock
			      : undef;
}

sub listen {
    @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
    my($sock,$queue) = @_;
    $queue = 5
	unless $queue && $queue > 0;

return listen($sock, $queue) ? $sock
				 : undef;
}

sub accept {
    @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
    my $sock = shift;
    my $pkg = shift || $sock;
    my $timeout = ${*$sock}{'io_socket_timeout'};
    my $new = $pkg->new(Timeout => $timeout);
    my $peer = undef;

if(defined $timeout) {
	require IO::Select;

my $sel = IO::Select->new( $sock );

unless ($sel->can_read($timeout)) {
	    $errstr = $@ = 'accept: timeout';
	    $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
	    return;
	}
    }

$peer = accept($new,$sock)
	or return;

${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );

return wantarray ? ($new, $peer)
    	      	     : $new;
}

sub sockname {
    @_ == 1 or croak 'usage: $sock->sockname()';
    getsockname($_[0]);
}

sub peername {
    @_ == 1 or croak 'usage: $sock->peername()';
    my($sock) = @_;
    ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
}

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

sub send {
    @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
    my $sock  = $_[0];
    my $flags = $_[2] || 0;
    my $peer;

if ($_[3]) {
        # the caller explicitly requested a TO, so use it
        # this is non-portable for "connected" UDP sockets
        $peer = $_[3];
    }
    elsif (!defined getpeername($sock)) {
        # we're not connected, so we require a peer from somewhere
        $peer = $sock->peername;

croak 'send: Cannot determine peer address'
	    unless(defined $peer);
    }

my $r = $peer
      ? send($sock, $_[1], $flags, $peer)
      : send($sock, $_[1], $flags);

# remember who we send to, if it was successful
    ${*$sock}{'io_socket_peername'} = $peer
	if(@_ == 4 && defined $r);

$r;
}

sub recv {
    @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
    my $sock  = $_[0];
    my $len   = $_[2];
    my $flags = $_[3] || 0;

# remember who we recv'd from
    ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}

sub shutdown {
    @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
    my($sock, $how) = @_;
    ${*$sock}{'io_socket_peername'} = undef;
    shutdown($sock, $how);
}

sub setsockopt {
    @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
    setsockopt($_[0],$_[1],$_[2],$_[3]);
}

my $intsize = length(pack("i",0));

sub getsockopt {
    @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
    my $r = getsockopt($_[0],$_[1],$_[2]);
    # Just a guess
    $r = unpack("i", $r)
	if(defined $r && length($r) == $intsize);
    $r;
}

sub sockopt {
    my $sock = shift;
    @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
	    : $sock->setsockopt(SOL_SOCKET,@_);
}

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

sub timeout {
    @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
    my($sock,$val) = @_;
    my $r = ${*$sock}{'io_socket_timeout'};

${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
	if(@_ == 2);

$r;
}

sub sockdomain {
    @_ == 1 or croak 'usage: $sock->sockdomain()';
    my $sock = shift;
    if (!defined(${*$sock}{'io_socket_domain'})) {
	my $addr = $sock->sockname();
	${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
	    if (defined($addr));
    }
    ${*$sock}{'io_socket_domain'};
}

sub socktype {
    @_ == 1 or croak 'usage: $sock->socktype()';
    my $sock = shift;
    ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
	if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
    ${*$sock}{'io_socket_type'}
}

sub protocol {
    @_ == 1 or croak 'usage: $sock->protocol()';
    my($sock) = @_;
    ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
	if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
    ${*$sock}{'io_socket_proto'};
}

__END__

cmd: