diff options
Diffstat (limited to 'beagle/debian-rfs/usr/lib/perl/5.10.1/IO/Socket.pm')
| -rw-r--r-- | beagle/debian-rfs/usr/lib/perl/5.10.1/IO/Socket.pm | 357 |
1 files changed, 0 insertions, 357 deletions
diff --git a/beagle/debian-rfs/usr/lib/perl/5.10.1/IO/Socket.pm b/beagle/debian-rfs/usr/lib/perl/5.10.1/IO/Socket.pm deleted file mode 100644 index 7c196f9..0000000 --- a/beagle/debian-rfs/usr/lib/perl/5.10.1/IO/Socket.pm +++ /dev/null @@ -1,357 +0,0 @@ -# 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.31"; - -@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; - - undef $!; - 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; -} - -# 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'; - - # 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 = 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(defined $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__ - |