summaryrefslogtreecommitdiff
path: root/ext
diff options
context:
space:
mode:
authorNicholas Clark <nick@ccl4.org>2009-09-28 14:58:16 +0100
committerNicholas Clark <nick@ccl4.org>2009-09-29 11:12:37 +0100
commit725607636edc598ad6823e49789420d734f8aa28 (patch)
tree2e6a93cdd6c65e8412bf874507a63c8ac8f14a71 /ext
parent8b2306352e674fdd7eb8b61ff2ce78864a87ed9c (diff)
downloadperl-725607636edc598ad6823e49789420d734f8aa28.tar.gz
Move IO from ext/ to dist/
Diffstat (limited to 'ext')
-rw-r--r--ext/IO/.gitignore1
-rw-r--r--ext/IO/ChangeLog364
-rw-r--r--ext/IO/IO.pm68
-rw-r--r--ext/IO/IO.xs541
-rw-r--r--ext/IO/Makefile.PL45
-rw-r--r--ext/IO/README27
-rw-r--r--ext/IO/hints/sco.pl2
-rw-r--r--ext/IO/lib/IO/Dir.pm248
-rw-r--r--ext/IO/lib/IO/File.pm204
-rw-r--r--ext/IO/lib/IO/Handle.pm635
-rw-r--r--ext/IO/lib/IO/Pipe.pm257
-rw-r--r--ext/IO/lib/IO/Poll.pm209
-rw-r--r--ext/IO/lib/IO/Seekable.pm128
-rw-r--r--ext/IO/lib/IO/Select.pm381
-rw-r--r--ext/IO/lib/IO/Socket.pm530
-rw-r--r--ext/IO/lib/IO/Socket/INET.pm464
-rw-r--r--ext/IO/lib/IO/Socket/UNIX.pm143
-rw-r--r--ext/IO/poll.c146
-rw-r--r--ext/IO/poll.h60
-rw-r--r--ext/IO/t/IO.t127
-rw-r--r--ext/IO/t/io_const.t25
-rw-r--r--ext/IO/t/io_dir.t73
-rw-r--r--ext/IO/t/io_dup.t57
-rw-r--r--ext/IO/t/io_file.t48
-rw-r--r--ext/IO/t/io_linenum.t73
-rw-r--r--ext/IO/t/io_multihomed.t118
-rw-r--r--ext/IO/t/io_pipe.t136
-rw-r--r--ext/IO/t/io_poll.t83
-rw-r--r--ext/IO/t/io_sel.t131
-rw-r--r--ext/IO/t/io_sock.t396
-rw-r--r--ext/IO/t/io_taint.t62
-rw-r--r--ext/IO/t/io_tell.t55
-rw-r--r--ext/IO/t/io_udp.t79
-rw-r--r--ext/IO/t/io_unix.t113
-rw-r--r--ext/IO/t/io_utf8.t31
-rw-r--r--ext/IO/t/io_xs.t40
36 files changed, 0 insertions, 6100 deletions
diff --git a/ext/IO/.gitignore b/ext/IO/.gitignore
deleted file mode 100644
index 577c726243..0000000000
--- a/ext/IO/.gitignore
+++ /dev/null
@@ -1 +0,0 @@
-!/poll.c
diff --git a/ext/IO/ChangeLog b/ext/IO/ChangeLog
deleted file mode 100644
index 6913c646e1..0000000000
--- a/ext/IO/ChangeLog
+++ /dev/null
@@ -1,364 +0,0 @@
-IO 1.25 -- Wed May 13 18:37:33 CDT 2009
- * Fix test warnings in io_dir
- * skip tests known to cause a segfault 5.10.0
-
-IO 1.24 -- Mon May 11 14:15:51 CDT 2009
-
- * Make Makefile.PL usable by core and CPAN
- * Reorganize files to be under lib/ directory structure now matches core perl
- * Update with following changes made to core perl distribution
- * Silence Win32 compiler warning in IO.xs
- * Make non-blocking mode work on Windows in IO::Socket::INET
- * fix some missing parts of IO::Handle pod
- * Implement IO::Handle::say the same way as the builtin say().
- * Undo io_linenum.t part of #34148. It was io_multihomed.t that I meant (my mistake), and that is now covered by #34155.
- * watchdog() some IO tests
- * Some more missing isGV_with_GP()s
- * IO::Dir destructor
- * IO::Socket::INET unnecessarily resolves "udp"
- * IO::Handle->say should ignore $\ (bug #49266)
- * consting IO.xs
- * Net::SMTP can't send large messages with bleadperl
- * Fix for IO::Socket send method
- * Fixes for the test suite on OS/2
- * Silence VC++ compiler warnings
- * IO::Socket's IO.xs fails to compile
- * IO::Socket::connect returns wrong errno on timeout
- * Coverity correctly reports that gv might (just) be NULL. So don't derefernece it if it is.
- * Simplify tests for fork() capabilities
- * Fix syntax error in io_pipe test
- * Making IO::Socket pass test on Win32
- * ext/IO/t/io_unix.t
-
-IO 1.23 -- Sat Mar 25 19:28:28 CST 2006
-
- * Adjust the regression tests to use t/test.pl when $ENV{PERL_CORE} is defined
- * Reduce number of calls to getpeername
- * Call qualify on format name passed to format_write. Bug reported by Johan Vromans
- * Reduce calls to getprotobyname/number. Patch from Gisle Aas
- * Remove references to file TEST used in core so appropriate tests are skipped
- during an install from CPAN
- * Add method say to IO::Handle
- * Performance improvement for IO::File::open
- * Don't warn about a directory being closed in the DESTROY
-
-IO 1.22 -- Mon Sep 5 10:29:35 CDT 2005
-
- * Update with changes made in perl core distribution
-
-Change 173 on 1998/07/14 by <gbarr@pobox.com> (Graham Barr)
-
- IO::Socket
- - Added method connected
-
- IO.xs
- - Added check that file * is not null
-
- t/io_udp.t
- - Added check for connected
- - Made change to catch recv not returning the address, and added a fix to
- ensure test does not hang
-
- t/io_sock.t
- - Added check for connected.
-
-Change 137 on 1998/05/21 by <gbarr@pobox.com> (Graham Barr)
-
- IO::Socket::INET
- - Added checks to all peer* and host* methods for undef
-
-Change 134 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr)
-
- t/io_sock.t
- - fix race condition on Solaris & SunOS
-
- IO::Handle
- - Applied patch from Gisle Aas <gisle@aas.no> for
- documentation update
- - Applied patch from Kuma <tgy@chocobo.org>
- changed input_line_number to be on a per-handle basis.
-
- IO::File
- - Applied patch from Gisle Aas <gisle@aas.no> for
- documentation update
-
- IO::Seekable
- - Applied patch from Gisle Aas <gisle@aas.no> for
- documentation update
- added sysseek
-
- IO, IO::Socket::INET
- - documentation update
-
- IO.xs
- - Applied patch from Gisle Aas <gisle@aas.no> for
- blocking
-
-Change 133 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr)
-
- t/io_sock.t
- - Added checks for blocking()
-
-Sun Apr 12 1998 <gbarr@pobox.com> (Graham Barr)
-
- IO.xs
- - enclosed newCONSTSUB in #ifdef as _64 now defines it.
-
-Thu Mar 19 1998 <gbarr@pobox.com> (Graham Barr)
-
- All
- - Changed copyright/distribution policy back to be the same as perl
-
-Sun Feb 15 1998 <gbarr@pobox.com> (Graham Barr)
-
- IO::Socket
- - Fix to ->accept, accept() returns false on error not undef.
-
-*** Release 1.19
-
-Thu Feb 5 1998 <gbarr@pobox.com> (Graham Barr)
-
- All
- - change copyright notice
-
- IO::Socket::INET
- - changed configure to accept PeerHost and LocalHost as well as the
- PeerAddr and LocalAddr arguments.
-
-Mon Feb 2 1998 <gbarr@pobox.com> (Graham Barr)
-
- IO::Handle
- - Added printflush so that flush.pl can be depreciated
-
- IO::Socket
- - Remove C<use Config> statement as it was not needed
-
-Tue Jan 27 1998 <gbarr@pobox.com> (Graham Barr)
-
- IO::Socket::INET
- - removed carp if $^W
-
-*** Patch 1.1804
-
-Sat Jan 17 1998 <gbarr@pobox.com> (Graham Barr)
-
- t/io_sock.t
- - Replaced C<Listen => 0> with C<LocalAddr => 'localhost'>
-
- IO/Socket/INET.pm
- - Modified the MultiHomed code. Now each address for a given host has
- a timeout of C<Timeout>.
- - added _get_addr method for doing hostname lookups. Now Net::DNS can be
- use by sub-classing IO::Socket::INET, Thanks Gisle Aas
-
- t/io_multihomed.t
- - new test added. Thanks Gisle Aas.
-
-*** Patch 1.1803
-
-Mon Nov 17 1997 <gbarr@pobox.com> (Graham Barr)
-
- poll.c
- - Added #ifdef I_* tests
-
- IO::Socket
- - Changed initialization of @domain2pkg to fix problem of Domain option
- not working
- - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no>
-
- IO::Socket::INET
- - Change default proto to getprotobyname instead of 'tcp' constant string
- - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no>
-
- t/io_sock.t
- - Change to test fix for Domain problem fixed in IO::Socket and be
- more comprehensive, Thanks to Gisle Aas <gisle@aas.no>
-
- t/io_unix.t
- - New test, Thanks to Gisle Aas <gisle@aas.no>
-
-*** Patch 1.1802
-
-Wed Nov 12 1997 <gbarr@pobox.com> (Graham Barr)
-
- t/io_poll.t
- - test 4 made an assumption that was not portable, fixed.
-
-*** Patch 1.1801
-
-Wed Oct 22 1997 <gbarr@pobox.com> (Graham Barr)
-
- IO.xs
- - change #ifdef's to allow compilation with 5.002
-
- IO::Socket
- - Fix to ensure that socket is not returned as non-blocking
- unless the user asks for it
-
- t/io_udp.t
- - Fix to stop endless loop
-
-*** Release 1.18
-
-Mon Oct 13 1997 <gbarr@pobox.com> (Graham Barr)
-
- IO.xs, IO::Handle
- - 1.17 broke compatability with 5.003, small tweaks to restore
- compatability
-
- t/io_const.t
- - Added new test to ensure backwards compatability with constants
- is not broken
-
-Wed Oct 8 1997 <gbarr@pobox.com> (Graham Barr)
-
- IO.xs
- - Added #define's to cope with argument changes to start_subparse
- from 5.003_22, _23 and _24
-
- IO::Select
- - Renamed has_error to be has_exception which is more correct,
- has_error is a wrapper around has_exception with a warning if
- $^W is set.
-
- Makefile.PL
- - Remove 'linkext' option to WriteMakefile so that static linking
- should work properly, cannot remember why I added it.
-
-Sun Oct 5 1997 <gbarr@pobox.com> (Graham Barr)
-
- IO::Pipe
- - GLOB assignment does not copy the fileno while under -T
- added checks for undefined fileno, and added fdopen
- - reader and write can now be called as static methods
-
- Makefile.PL
- - Attempt to locate <poll.h> and define I_POLL if found
-
-*** Release 1.17
-
-Fri Sep 26 1997 <gbarr@pobox.com> (Graham Barr)
-
- IO.xs
- - Fix bug in _poll for ANSI C compilers
-
- IO::Socket
- - Split IO::Socket::INET and IO::Socket::UNIX into separate files
-
- IO::File
- - Patch to open() for when file is in current directory.
-
-*** Release 1.16
-
-Mon 15 Sep 1997 <gbarr@pobox.com> Graham Barr
-
- o New modules
- - IO::Dir
- - IO::Poll
-
- o IO::Socket
- - Changed new to call autoflush on the new socket
- - IO::Socket::INET->new now accepts a single argument
- - IO::Socket::INET default to protocol 'tcp'
-
- o IO::File
- - Added doc for new_tmpfile
-
- o IO::Handle
- - Removed use of AutoLoader for constants, constants are
- now defined as constant XS subs
- - Added fsync, but will not be avaliable for use
- unless HAS_FSYNC is defined, perls configure does not define
- this yet.
- - Moved bootstrap of IO.xs to IO.pm. IO::Handle no longer
- contains an AUTOLOAD sub in it's ISA hier
-
- o IO::Seekable
- - Remove clearerr, as it is defined in IO.xs
-
- o IO.xs
- - Patched IO.xs with patch from Chip for setvbuf warning
- - Added XS sub "constant" for backwards compatability
-
- o Misc
- - Fixed IO::Socket::configure, it was not passing $arg to domain
- specific package
- - Changed all $fh variables in IO::Handle to $io and all $fh
- variables in IO::Socket to $sock as Chip suggested
- - Fixed usage messages to be consistant
-
-*** Release 1.15
-
-Sun 19 Jan 1997 <bodg@tiuk.ti.com> Graham Barr
-
- o Updated PODs for IO::Handle and IO::File
- o Modified IO.xs so that DESTROY gets called on IO::File
- objects that were created with IO::File->new_tmpfile
- o Modified the domain2pkg code in IO::Socket so that it
- does not use blessd refs
- o Created a new package IO::Pipe::End so that pipe specific
- stuff can be moved out of IO::Handle.
- o Added Ilya's OS/2 changes to Pipe.pm and io_pipe.t
-
- o These changes happened somtime before the release of 1.15
- - added shutdown to IO::Socket
- - modified connect to not use alarm
- - modified accept and connect to use IO::Select
-
-*** Release 1.14
-
-Tue 24 Dec 1996 <bodg@tiuk.ti.com> Graham Barr
-
- o Updated to patches in perl core dist.
- o Added C<use strict> to all modules
- o Modified t/io_sock.t, hopefully the race condition has gone
- o Added close statements to reader/writer in IO::Pipe
- o IO::Handle::syswrite was calling sysread, fixed :-)
-
-*** Release 1.12
-
-Thu 19 Sep 1996 <bodg@tiuk.ti.com> Graham Barr
-
- o Modified IO.xs so that it will compile with pre perlio version
- of perl (ie pre perl5.003_02)
- o Modified IO::Socket::send so not to pass 4 arguments to send
- if the socket is connected
-
-*** Release 1.10
-
-Mon 11 Sep 1996 <bodg@tiuk.ti.com> Graham Barr
-
- o Fixed a bug in IO::Socket which caused DESTROY to be called
- on a partly initialised connection
- o Changed IO.xs to use Perlio
- o Modified usage message to report correct package
- o Added IO::File::new changes from Chip, to allow PERM to be passed
- o Added sysread and syswrite methods to IO::Handle
- o Updated documentation
- o Fixed a bug in IO::Select that caused a hang if the last handle
- was removed.
- o Added count method to IO::Select
- o Renamed and modified tests so that they can be copied into the
- perl distribution
- o Added fcntl and ioctl methods to IO::Handle
-
-Thu 25 Jul 1996 <bodg@tiuk.ti.com> Graham Barr
-
- o It is now not necessary to call the domain sub-classes of
- IO::Socket. when connect is called it notes the domain.
- Domain specific methods, which are normally non-critical, are
- called via this note-ing.
- o Added methods to IO::Socket to retrieve the domain, type and
- protocol of a given socket
-
-Tue 23 Jul 1996 <bodg@tiuk.ti.com> Graham Barr
-
- o IO::Socket::connect changed how we do timeouts, as it did not work
-
- o IO::Handle::new_from_fd removed method call to _ref_fd, which was
- a leftover from FileHandle
-
-Fri 28 Jun 1996 <bodg@tiuk.ti.com> Graham Barr
-
- o Modified IO::Socket::UNIX::configure to default to using a socket
- type of SOCK_STREAM if no type is specified.
diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm
deleted file mode 100644
index a72e2243d7..0000000000
--- a/ext/IO/IO.pm
+++ /dev/null
@@ -1,68 +0,0 @@
-#
-
-package IO;
-
-use XSLoader ();
-use Carp;
-use strict;
-use warnings;
-
-our $VERSION = "1.25";
-XSLoader::load 'IO', $VERSION;
-
-sub import {
- shift;
-
- warnings::warnif('deprecated', qq{Parameterless "use IO" deprecated})
- if @_ == 0 ;
-
- my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir);
-
- eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l)
- or croak $@;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO - load various IO modules
-
-=head1 SYNOPSIS
-
- use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File
- use IO; # DEPRECATED
-
-=head1 DESCRIPTION
-
-C<IO> provides a simple mechanism to load several of the IO modules
-in one go. The IO modules belonging to the core are:
-
- IO::Handle
- IO::Seekable
- IO::File
- IO::Pipe
- IO::Socket
- IO::Dir
- IO::Select
- IO::Poll
-
-Some other IO modules don't belong to the perl core but can be loaded
-as well if they have been installed from CPAN. You can discover which
-ones exist by searching for "^IO::" on http://search.cpan.org.
-
-For more information on any of these modules, please see its respective
-documentation.
-
-=head1 DEPRECATED
-
- use IO; # loads all the modules listed below
-
-The loaded modules are IO::Handle, IO::Seekable, IO::File, IO::Pipe,
-IO::Socket, IO::Dir. You should instead explicitly import the IO
-modules you want.
-
-=cut
-
diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs
deleted file mode 100644
index d3dff557a2..0000000000
--- a/ext/IO/IO.xs
+++ /dev/null
@@ -1,541 +0,0 @@
-/*
- * 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.
- */
-
-#define PERL_EXT_IO
-
-#define PERL_NO_GET_CONTEXT
-#include "EXTERN.h"
-#define PERLIO_NOT_STDIO 1
-#include "perl.h"
-#include "XSUB.h"
-#include "poll.h"
-#ifdef I_UNISTD
-# include <unistd.h>
-#endif
-#if defined(I_FCNTL) || defined(HAS_FCNTL)
-# include <fcntl.h>
-#endif
-
-#ifndef SIOCATMARK
-# ifdef I_SYS_SOCKIO
-# include <sys/sockio.h>
-# endif
-#endif
-
-#ifdef PerlIO
-#if defined(MACOS_TRADITIONAL) && defined(USE_SFIO)
-#define PERLIO_IS_STDIO 1
-#undef setbuf
-#undef setvbuf
-#define setvbuf _stdsetvbuf
-#define setbuf(f,b) ( __sf_setbuf(f,b) )
-#endif
-typedef int SysRet;
-typedef PerlIO * InputStream;
-typedef PerlIO * OutputStream;
-#else
-#define PERLIO_IS_STDIO 1
-typedef int SysRet;
-typedef FILE * InputStream;
-typedef FILE * OutputStream;
-#endif
-
-#define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
-
-#ifndef gv_stashpvn
-#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
-#endif
-
-#ifndef __attribute__noreturn__
-# define __attribute__noreturn__
-#endif
-
-#ifndef NORETURN_FUNCTION_END
-# define NORETURN_FUNCTION_END /* NOT REACHED */ return 0
-#endif
-
-static int not_here(const char *s) __attribute__noreturn__;
-static int
-not_here(const char *s)
-{
- croak("%s not implemented on this architecture", s);
- NORETURN_FUNCTION_END;
-}
-
-
-#ifndef PerlIO
-#define PerlIO_fileno(f) fileno(f)
-#endif
-
-static int
-io_blocking(pTHX_ InputStream f, int block)
-{
-#if defined(HAS_FCNTL)
- int RETVAL;
- if(!f) {
- errno = EBADF;
- return -1;
- }
- RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
- if (RETVAL >= 0) {
- int mode = RETVAL;
- int newmode = mode;
-#ifdef O_NONBLOCK
- /* POSIX style */
-
-# ifndef O_NDELAY
-# define O_NDELAY O_NONBLOCK
-# endif
- /* Note: UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY
- * after a successful F_SETFL of an O_NONBLOCK. */
- RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1;
-
- if (block == 0) {
- newmode &= ~O_NDELAY;
- newmode |= O_NONBLOCK;
- } else if (block > 0) {
- newmode &= ~(O_NDELAY|O_NONBLOCK);
- }
-#else
- /* Not POSIX - better have O_NDELAY or we can't cope.
- * for BSD-ish machines this is an acceptable alternative
- * for SysV we can't tell "would block" from EOF but that is
- * the way SysV is...
- */
- RETVAL = RETVAL & O_NDELAY ? 0 : 1;
-
- if (block == 0) {
- newmode |= O_NDELAY;
- } else if (block > 0) {
- newmode &= ~O_NDELAY;
- }
-#endif
- if (newmode != mode) {
- const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
- if (ret < 0)
- RETVAL = ret;
- }
- }
- return RETVAL;
-#else
-# ifdef WIN32
- char flags = (char)block;
- return ioctl(PerlIO_fileno(f), FIONBIO, &flags);
-# else
- return -1;
-# endif
-#endif
-}
-
-MODULE = IO PACKAGE = IO::Seekable PREFIX = f
-
-void
-fgetpos(handle)
- InputStream handle
- CODE:
- if (handle) {
-#ifdef PerlIO
-#if PERL_VERSION < 8
- Fpos_t pos;
- ST(0) = sv_newmortal();
- if (PerlIO_getpos(handle, &pos) != 0) {
- ST(0) = &PL_sv_undef;
- }
- else {
- sv_setpvn(ST(0), (char *)&pos, sizeof(Fpos_t));
- }
-#else
- ST(0) = sv_newmortal();
- if (PerlIO_getpos(handle, ST(0)) != 0) {
- ST(0) = &PL_sv_undef;
- }
-#endif
-#else
- Fpos_t pos;
- if (fgetpos(handle, &pos)) {
- ST(0) = &PL_sv_undef;
- } else {
- ST(0) = sv_2mortal(newSVpvn((char*)&pos, sizeof(Fpos_t)));
- }
-#endif
- }
- else {
- errno = EINVAL;
- ST(0) = &PL_sv_undef;
- }
-
-SysRet
-fsetpos(handle, pos)
- InputStream handle
- SV * pos
- CODE:
- if (handle) {
-#ifdef PerlIO
-#if PERL_VERSION < 8
- char *p;
- STRLEN len;
- if (SvOK(pos) && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
- RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
- }
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
-#else
- RETVAL = PerlIO_setpos(handle, pos);
-#endif
-#else
- char *p;
- STRLEN len;
- if ((p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
- RETVAL = fsetpos(handle, (Fpos_t*)p);
- }
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
-#endif
- }
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- OUTPUT:
- RETVAL
-
-MODULE = IO PACKAGE = IO::File PREFIX = f
-
-void
-new_tmpfile(packname = "IO::File")
- const char * packname
- PREINIT:
- OutputStream fp;
- GV *gv;
- CODE:
-#ifdef PerlIO
- fp = PerlIO_tmpfile();
-#else
- fp = tmpfile();
-#endif
- gv = (GV*)SvREFCNT_inc(newGVgen(packname));
- if (gv)
- hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
- if (gv && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
- ST(0) = sv_2mortal(newRV((SV*)gv));
- sv_bless(ST(0), gv_stashpv(packname, TRUE));
- SvREFCNT_dec(gv); /* undo increment in newRV() */
- }
- else {
- ST(0) = &PL_sv_undef;
- SvREFCNT_dec(gv);
- }
-
-MODULE = IO PACKAGE = IO::Poll
-
-void
-_poll(timeout,...)
- int timeout;
-PPCODE:
-{
-#ifdef HAS_POLL
- const int nfd = (items - 1) / 2;
- SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
- struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
- int i,j,ret;
- for(i=1, j=0 ; j < nfd ; j++) {
- fds[j].fd = SvIV(ST(i));
- i++;
- fds[j].events = (short)SvIV(ST(i));
- i++;
- fds[j].revents = 0;
- }
- if((ret = poll(fds,nfd,timeout)) >= 0) {
- for(i=1, j=0 ; j < nfd ; j++) {
- sv_setiv(ST(i), fds[j].fd); i++;
- sv_setiv(ST(i), fds[j].revents); i++;
- }
- }
- SvREFCNT_dec(tmpsv);
- XSRETURN_IV(ret);
-#else
- not_here("IO::Poll::poll");
-#endif
-}
-
-MODULE = IO PACKAGE = IO::Handle PREFIX = io_
-
-void
-io_blocking(handle,blk=-1)
- InputStream handle
- int blk
-PROTOTYPE: $;$
-CODE:
-{
- const int ret = io_blocking(aTHX_ handle, items == 1 ? -1 : blk ? 1 : 0);
- if(ret >= 0)
- XSRETURN_IV(ret);
- else
- XSRETURN_UNDEF;
-}
-
-MODULE = IO PACKAGE = IO::Handle PREFIX = f
-
-int
-ungetc(handle, c)
- InputStream handle
- int c
- CODE:
- if (handle)
-#ifdef PerlIO
- RETVAL = PerlIO_ungetc(handle, c);
-#else
- RETVAL = ungetc(c, handle);
-#endif
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- OUTPUT:
- RETVAL
-
-int
-ferror(handle)
- InputStream handle
- CODE:
- if (handle)
-#ifdef PerlIO
- RETVAL = PerlIO_error(handle);
-#else
- RETVAL = ferror(handle);
-#endif
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- OUTPUT:
- RETVAL
-
-int
-clearerr(handle)
- InputStream handle
- CODE:
- if (handle) {
-#ifdef PerlIO
- PerlIO_clearerr(handle);
-#else
- clearerr(handle);
-#endif
- RETVAL = 0;
- }
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- OUTPUT:
- RETVAL
-
-int
-untaint(handle)
- SV * handle
- CODE:
-#ifdef IOf_UNTAINT
- IO * io;
- io = sv_2io(handle);
- if (io) {
- IoFLAGS(io) |= IOf_UNTAINT;
- RETVAL = 0;
- }
- else {
-#endif
- RETVAL = -1;
- errno = EINVAL;
-#ifdef IOf_UNTAINT
- }
-#endif
- OUTPUT:
- RETVAL
-
-SysRet
-fflush(handle)
- OutputStream handle
- CODE:
- if (handle)
-#ifdef PerlIO
- RETVAL = PerlIO_flush(handle);
-#else
- RETVAL = Fflush(handle);
-#endif
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- OUTPUT:
- RETVAL
-
-void
-setbuf(handle, ...)
- OutputStream handle
- CODE:
- if (handle)
-#ifdef PERLIO_IS_STDIO
- {
- char *buf = items == 2 && SvPOK(ST(1)) ?
- sv_grow(ST(1), BUFSIZ) : 0;
- setbuf(handle, buf);
- }
-#else
- not_here("IO::Handle::setbuf");
-#endif
-
-SysRet
-setvbuf(...)
- CODE:
- if (items != 4)
- Perl_croak(aTHX_ "Usage: IO::Handle::setvbuf(handle, buf, type, size)");
-#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF)
- {
- OutputStream handle = 0;
- char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
- int type;
- int size;
-
- if (items == 4) {
- handle = IoOFP(sv_2io(ST(0)));
- buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
- type = (int)SvIV(ST(2));
- size = (int)SvIV(ST(3));
- }
- if (!handle) /* Try input stream. */
- handle = IoIFP(sv_2io(ST(0)));
- if (items == 4 && handle)
- RETVAL = setvbuf(handle, buf, type, size);
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- }
-#else
- RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
-#endif
- OUTPUT:
- RETVAL
-
-
-SysRet
-fsync(handle)
- OutputStream handle
- CODE:
-#ifdef HAS_FSYNC
- if(handle)
- RETVAL = fsync(PerlIO_fileno(handle));
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
-#else
- RETVAL = (SysRet) not_here("IO::Handle::sync");
-#endif
- OUTPUT:
- RETVAL
-
-
-MODULE = IO PACKAGE = IO::Socket
-
-SysRet
-sockatmark (sock)
- InputStream sock
- PROTOTYPE: $
- PREINIT:
- int fd;
- CODE:
- {
- fd = PerlIO_fileno(sock);
-#ifdef HAS_SOCKATMARK
- RETVAL = sockatmark(fd);
-#else
- {
- int flag = 0;
-# ifdef SIOCATMARK
-# if defined(NETWARE) || defined(WIN32)
- if (ioctl(fd, SIOCATMARK, (void*)&flag) != 0)
-# else
- if (ioctl(fd, SIOCATMARK, &flag) != 0)
-# endif
- XSRETURN_UNDEF;
-# else
- not_here("IO::Socket::atmark");
-# endif
- RETVAL = flag;
- }
-#endif
- }
- OUTPUT:
- RETVAL
-
-BOOT:
-{
- HV *stash;
- /*
- * constant subs for IO::Poll
- */
- stash = gv_stashpvn("IO::Poll", 8, TRUE);
-#ifdef POLLIN
- newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
-#endif
-#ifdef POLLPRI
- newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
-#endif
-#ifdef POLLOUT
- newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
-#endif
-#ifdef POLLRDNORM
- newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
-#endif
-#ifdef POLLWRNORM
- newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
-#endif
-#ifdef POLLRDBAND
- newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
-#endif
-#ifdef POLLWRBAND
- newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
-#endif
-#ifdef POLLNORM
- newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
-#endif
-#ifdef POLLERR
- newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
-#endif
-#ifdef POLLHUP
- newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
-#endif
-#ifdef POLLNVAL
- newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
-#endif
- /*
- * constant subs for IO::Handle
- */
- stash = gv_stashpvn("IO::Handle", 10, TRUE);
-#ifdef _IOFBF
- newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
-#endif
-#ifdef _IOLBF
- newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
-#endif
-#ifdef _IONBF
- newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
-#endif
-#ifdef SEEK_SET
- newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
-#endif
-#ifdef SEEK_CUR
- newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
-#endif
-#ifdef SEEK_END
- newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
-#endif
-}
-
diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL
deleted file mode 100644
index 2159f43e49..0000000000
--- a/ext/IO/Makefile.PL
+++ /dev/null
@@ -1,45 +0,0 @@
-# This -*- perl -*- script makes the Makefile
-
-BEGIN { require 5.006_001 }
-use ExtUtils::MakeMaker;
-use Config qw(%Config);
-my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV;
-
-#--- Attempt to find <poll.h>
-
-my $define = "";
-
-unless ($PERL_CORE or exists $Config{'i_poll'}) {
- my @inc = split(/\s+/, join(" ", $Config{'usrinc'}, $Config{'incpth'}, $Config{'locincpth'}));
- foreach $path (@inc) {
- if (-f $path . "/poll.h") {
- $define .= "-DI_POLL ";
- last;
- }
- }
-}
-
-if ($] < 5.008 and !$PERL_CORE) {
- open(FH,">typemap");
- print FH "const char * T_PV\n";
- close(FH);
-}
-
-#--- Write the Makefile
-
-WriteMakefile(
- VERSION_FROM => "IO.pm",
- NAME => "IO",
- OBJECT => '$(O_FILES)',
- ABSTRACT => 'Perl core IO modules',
- AUTHOR => 'Graham Barr <gbarr@cpan.org>',
- ( $PERL_CORE
- ? ()
- : (
- INSTALLDIRS => 'perl',
- clean => {FILES => 'typemap'},
- )
- ),
- ($define ? (DEFINE => $define) : ()),
- ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? ('LICENSE' => 'perl') : ()),
-);
diff --git a/ext/IO/README b/ext/IO/README
deleted file mode 100644
index e4d9dfad55..0000000000
--- a/ext/IO/README
+++ /dev/null
@@ -1,27 +0,0 @@
-This is the perl5 IO distribution.
-
-This distribution is included in the perl5 core distribution. You should
-only need to install this distribution if it is newer than your perl
-installation.
-
-To install this distribution you will need access rights to the perl
-install ation on your system, as it overwrites your currently installed
-version of IO.
-
-This distribution relies upon the Socket module (version 1.3), which is
-avaliable from CPAN. Although you should not need to get this if your
-version of perl is fairly recent, as Socket is also distributed in the
-core perl distribution.
-
-If you do not have the required modules, you will see a warning when
-the Makefile is built.
-
-To build, test and install this distribution type:
-
- perl Makefile.PL
- make test
- make install
-
-Share and Enjoy!
-Graham Barr <gbarr@pobox.com>
-
diff --git a/ext/IO/hints/sco.pl b/ext/IO/hints/sco.pl
deleted file mode 100644
index ddcf1551d1..0000000000
--- a/ext/IO/hints/sco.pl
+++ /dev/null
@@ -1,2 +0,0 @@
-# SCO OSR5 needs to link with libc.so again to have C<fsync> defined
-$self->{LIBS} = ['-lc'];
diff --git a/ext/IO/lib/IO/Dir.pm b/ext/IO/lib/IO/Dir.pm
deleted file mode 100644
index cce392c2ce..0000000000
--- a/ext/IO/lib/IO/Dir.pm
+++ /dev/null
@@ -1,248 +0,0 @@
-# IO::Dir.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::Dir;
-
-use 5.006;
-
-use strict;
-use Carp;
-use Symbol;
-use Exporter;
-use IO::File;
-our(@ISA, $VERSION, @EXPORT_OK);
-use Tie::Hash;
-use File::stat;
-use File::Spec;
-
-@ISA = qw(Tie::Hash Exporter);
-$VERSION = "1.07";
-$VERSION = eval $VERSION;
-@EXPORT_OK = qw(DIR_UNLINK);
-
-sub DIR_UNLINK () { 1 }
-
-sub new {
- @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]';
- my $class = shift;
- my $dh = gensym;
- if (@_) {
- IO::Dir::open($dh, $_[0])
- or return undef;
- }
- bless $dh, $class;
-}
-
-sub DESTROY {
- my ($dh) = @_;
- local($., $@, $!, $^E, $?);
- no warnings 'io';
- closedir($dh);
-}
-
-sub open {
- @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
- my ($dh, $dirname) = @_;
- return undef
- unless opendir($dh, $dirname);
- # a dir name should always have a ":" in it; assume dirname is
- # in current directory
- $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) );
- ${*$dh}{io_dir_path} = $dirname;
- 1;
-}
-
-sub close {
- @_ == 1 or croak 'usage: $dh->close()';
- my ($dh) = @_;
- closedir($dh);
-}
-
-sub read {
- @_ == 1 or croak 'usage: $dh->read()';
- my ($dh) = @_;
- readdir($dh);
-}
-
-sub seek {
- @_ == 2 or croak 'usage: $dh->seek(POS)';
- my ($dh,$pos) = @_;
- seekdir($dh,$pos);
-}
-
-sub tell {
- @_ == 1 or croak 'usage: $dh->tell()';
- my ($dh) = @_;
- telldir($dh);
-}
-
-sub rewind {
- @_ == 1 or croak 'usage: $dh->rewind()';
- my ($dh) = @_;
- rewinddir($dh);
-}
-
-sub TIEHASH {
- my($class,$dir,$options) = @_;
-
- my $dh = $class->new($dir)
- or return undef;
-
- $options ||= 0;
-
- ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK;
- $dh;
-}
-
-sub FIRSTKEY {
- my($dh) = @_;
- $dh->rewind;
- scalar $dh->read;
-}
-
-sub NEXTKEY {
- my($dh) = @_;
- scalar $dh->read;
-}
-
-sub EXISTS {
- my($dh,$key) = @_;
- -e File::Spec->catfile(${*$dh}{io_dir_path}, $key);
-}
-
-sub FETCH {
- my($dh,$key) = @_;
- &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key));
-}
-
-sub STORE {
- my($dh,$key,$data) = @_;
- my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
- my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
- unless(-e $file) {
- my $io = IO::File->new($file,O_CREAT | O_RDWR);
- $io->close if $io;
- }
- utime($atime,$mtime, $file);
-}
-
-sub DELETE {
- my($dh,$key) = @_;
-
- # Only unlink if unlink-ing is enabled
- return 0
- unless ${*$dh}{io_dir_unlink};
-
- my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
-
- -d $file
- ? rmdir($file)
- : unlink($file);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Dir - supply object methods for directory handles
-
-=head1 SYNOPSIS
-
- use IO::Dir;
- $d = IO::Dir->new(".");
- if (defined $d) {
- while (defined($_ = $d->read)) { something($_); }
- $d->rewind;
- while (defined($_ = $d->read)) { something_else($_); }
- undef $d;
- }
-
- tie %dir, 'IO::Dir', ".";
- foreach (keys %dir) {
- print $_, " " , $dir{$_}->size,"\n";
- }
-
-=head1 DESCRIPTION
-
-The C<IO::Dir> package provides two interfaces to perl's directory reading
-routines.
-
-The first interface is an object approach. C<IO::Dir> provides an object
-constructor and methods, which are just wrappers around perl's built in
-directory reading routines.
-
-=over 4
-
-=item new ( [ DIRNAME ] )
-
-C<new> is the constructor for C<IO::Dir> objects. It accepts one optional
-argument which, if given, C<new> will pass to C<open>
-
-=back
-
-The following methods are wrappers for the directory related functions built
-into perl (the trailing `dir' has been removed from the names). See L<perlfunc>
-for details of these functions.
-
-=over 4
-
-=item open ( DIRNAME )
-
-=item read ()
-
-=item seek ( POS )
-
-=item tell ()
-
-=item rewind ()
-
-=item close ()
-
-=back
-
-C<IO::Dir> also provides an interface to reading directories via a tied
-hash. The tied hash extends the interface beyond just the directory
-reading routines by the use of C<lstat>, from the C<File::stat> package,
-C<unlink>, C<rmdir> and C<utime>.
-
-=over 4
-
-=item tie %hash, 'IO::Dir', DIRNAME [, OPTIONS ]
-
-=back
-
-The keys of the hash will be the names of the entries in the directory.
-Reading a value from the hash will be the result of calling
-C<File::stat::lstat>. Deleting an element from the hash will
-delete the corresponding file or subdirectory,
-provided that C<DIR_UNLINK> is included in the C<OPTIONS>.
-
-Assigning to an entry in the hash will cause the time stamps of the file
-to be modified. If the file does not exist then it will be created. Assigning
-a single integer to a hash element will cause both the access and
-modification times to be changed to that value. Alternatively a reference to
-an array of two values can be passed. The first array element will be used to
-set the access time and the second element will be used to set the modification
-time.
-
-=head1 SEE ALSO
-
-L<File::stat>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1997-2003 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.
-
-=cut
diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm
deleted file mode 100644
index d33d090d0b..0000000000
--- a/ext/IO/lib/IO/File.pm
+++ /dev/null
@@ -1,204 +0,0 @@
-#
-
-package IO::File;
-
-=head1 NAME
-
-IO::File - supply object methods for filehandles
-
-=head1 SYNOPSIS
-
- use IO::File;
-
- $fh = new IO::File;
- if ($fh->open("< file")) {
- print <$fh>;
- $fh->close;
- }
-
- $fh = new IO::File "> file";
- if (defined $fh) {
- print $fh "bar\n";
- $fh->close;
- }
-
- $fh = new IO::File "file", "r";
- if (defined $fh) {
- print <$fh>;
- undef $fh; # automatically closes the file
- }
-
- $fh = new IO::File "file", O_WRONLY|O_APPEND;
- if (defined $fh) {
- print $fh "corge\n";
-
- $pos = $fh->getpos;
- $fh->setpos($pos);
-
- undef $fh; # automatically closes the file
- }
-
- autoflush STDOUT 1;
-
-=head1 DESCRIPTION
-
-C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends
-these classes with methods that are specific to file handles.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( FILENAME [,MODE [,PERMS]] )
-
-Creates an C<IO::File>. If it receives any parameters, they are passed to
-the method C<open>; if the open fails, the object is destroyed. Otherwise,
-it is returned to the caller.
-
-=item new_tmpfile
-
-Creates an C<IO::File> opened for read/write on a newly created temporary
-file. On systems where this is possible, the temporary file is anonymous
-(i.e. it is unlinked after creation, but held open). If the temporary
-file cannot be created or opened, the C<IO::File> object is destroyed.
-Otherwise, it is returned to the caller.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item open( FILENAME [,MODE [,PERMS]] )
-
-=item open( FILENAME, IOLAYERS )
-
-C<open> accepts one, two or three parameters. With one parameter,
-it is just a front end for the built-in C<open> function. With two or three
-parameters, the first parameter is a filename that may include
-whitespace or other special characters, and the second parameter is
-the open mode, optionally followed by a file permission value.
-
-If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.)
-or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic
-Perl C<open> operator (but protects any special characters).
-
-If C<IO::File::open> is given a numeric mode, it passes that mode
-and the optional permissions value to the Perl C<sysopen> operator.
-The permissions default to 0666.
-
-If C<IO::File::open> is given a mode that includes the C<:> character,
-it passes all the three arguments to the three-argument C<open> operator.
-
-For convenience, C<IO::File> exports the O_XXX constants from the
-Fcntl module, if this module is available.
-
-=item binmode( [LAYER] )
-
-C<binmode> sets C<binmode> on the underlying C<IO> object, as documented
-in C<perldoc -f binmode>.
-
-C<binmode> accepts one optional parameter, which is the layer to be
-passed on to the C<binmode> call.
-
-=back
-
-=head1 NOTE
-
-Some operating systems may perform C<IO::File::new()> or C<IO::File::open()>
-on a directory without errors. This behavior is not portable and not
-suggested for use. Using C<opendir()> and C<readdir()> or C<IO::Dir> are
-suggested instead.
-
-=head1 SEE ALSO
-
-L<perlfunc>,
-L<perlop/"I/O Operators">,
-L<IO::Handle>,
-L<IO::Seekable>,
-L<IO::Dir>
-
-=head1 HISTORY
-
-Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
-
-=cut
-
-use 5.006_001;
-use strict;
-our($VERSION, @EXPORT, @EXPORT_OK, @ISA);
-use Carp;
-use Symbol;
-use SelectSaver;
-use IO::Seekable;
-use File::Spec;
-
-require Exporter;
-
-@ISA = qw(IO::Handle IO::Seekable Exporter);
-
-$VERSION = "1.14";
-
-@EXPORT = @IO::Seekable::EXPORT;
-
-eval {
- # Make all Fcntl O_XXX constants available for importing
- require Fcntl;
- my @O = grep /^O_/, @Fcntl::EXPORT;
- Fcntl->import(@O); # first we import what we want to export
- push(@EXPORT, @O);
-};
-
-################################################
-## Constructor
-##
-
-sub new {
- my $type = shift;
- my $class = ref($type) || $type || "IO::File";
- @_ >= 0 && @_ <= 3
- or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]";
- my $fh = $class->SUPER::new();
- if (@_) {
- $fh->open(@_)
- or return undef;
- }
- $fh;
-}
-
-################################################
-## Open
-##
-
-sub open {
- @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
- my ($fh, $file) = @_;
- if (@_ > 2) {
- my ($mode, $perms) = @_[2, 3];
- if ($mode =~ /^\d+$/) {
- defined $perms or $perms = 0666;
- return sysopen($fh, $file, $mode, $perms);
- } elsif ($mode =~ /:/) {
- return open($fh, $mode, $file) if @_ == 3;
- croak 'usage: $fh->open(FILENAME, IOLAYERS)';
- } else {
- return open($fh, IO::Handle::_open_mode_string($mode), $file);
- }
- }
- open($fh, $file);
-}
-
-################################################
-## Binmode
-##
-
-sub binmode {
- ( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])';
-
- my($fh, $layer) = @_;
-
- return binmode $$fh unless $layer;
- return binmode $$fh, $layer;
-}
-
-1;
diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm
deleted file mode 100644
index 2f1f1b423b..0000000000
--- a/ext/IO/lib/IO/Handle.pm
+++ /dev/null
@@ -1,635 +0,0 @@
-package IO::Handle;
-
-=head1 NAME
-
-IO::Handle - supply object methods for I/O handles
-
-=head1 SYNOPSIS
-
- use IO::Handle;
-
- $io = new IO::Handle;
- if ($io->fdopen(fileno(STDIN),"r")) {
- print $io->getline;
- $io->close;
- }
-
- $io = new IO::Handle;
- if ($io->fdopen(fileno(STDOUT),"w")) {
- $io->print("Some text\n");
- }
-
- # setvbuf is not available by default on Perls 5.8.0 and later.
- use IO::Handle '_IOLBF';
- $io->setvbuf($buffer_var, _IOLBF, 1024);
-
- undef $io; # automatically closes the file if it's open
-
- autoflush STDOUT 1;
-
-=head1 DESCRIPTION
-
-C<IO::Handle> is the base class for all other IO handle classes. It is
-not intended that objects of C<IO::Handle> would be created directly,
-but instead C<IO::Handle> is inherited from by several other classes
-in the IO hierarchy.
-
-If you are reading this documentation, looking for a replacement for
-the C<FileHandle> package, then I suggest you read the documentation
-for C<IO::File> too.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ()
-
-Creates a new C<IO::Handle> object.
-
-=item new_from_fd ( FD, MODE )
-
-Creates an C<IO::Handle> like C<new> does.
-It requires two parameters, which are passed to the method C<fdopen>;
-if the fdopen fails, the object is destroyed. Otherwise, it is returned
-to the caller.
-
-=back
-
-=head1 METHODS
-
-See L<perlfunc> for complete descriptions of each of the following
-supported C<IO::Handle> methods, which are just front ends for the
-corresponding built-in functions:
-
- $io->close
- $io->eof
- $io->fcntl( FUNCTION, SCALAR )
- $io->fileno
- $io->format_write( [FORMAT_NAME] )
- $io->getc
- $io->ioctl( FUNCTION, SCALAR )
- $io->read ( BUF, LEN, [OFFSET] )
- $io->print ( ARGS )
- $io->printf ( FMT, [ARGS] )
- $io->say ( ARGS )
- $io->stat
- $io->sysread ( BUF, LEN, [OFFSET] )
- $io->syswrite ( BUF, [LEN, [OFFSET]] )
- $io->truncate ( LEN )
-
-See L<perlvar> for complete descriptions of each of the following
-supported C<IO::Handle> methods. All of them return the previous
-value of the attribute and takes an optional single argument that when
-given will set the value. If no argument is given the previous value
-is unchanged (except for $io->autoflush will actually turn ON
-autoflush by default).
-
- $io->autoflush ( [BOOL] ) $|
- $io->format_page_number( [NUM] ) $%
- $io->format_lines_per_page( [NUM] ) $=
- $io->format_lines_left( [NUM] ) $-
- $io->format_name( [STR] ) $~
- $io->format_top_name( [STR] ) $^
- $io->input_line_number( [NUM]) $.
-
-The following methods are not supported on a per-filehandle basis.
-
- IO::Handle->format_line_break_characters( [STR] ) $:
- IO::Handle->format_formfeed( [STR]) $^L
- IO::Handle->output_field_separator( [STR] ) $,
- IO::Handle->output_record_separator( [STR] ) $\
-
- IO::Handle->input_record_separator( [STR] ) $/
-
-Furthermore, for doing normal I/O you might need these:
-
-=over 4
-
-=item $io->fdopen ( FD, MODE )
-
-C<fdopen> is like an ordinary C<open> except that its first parameter
-is not a filename but rather a file handle name, an IO::Handle object,
-or a file descriptor number. (For the documentation of the C<open>
-method, see L<IO::File>.)
-
-=item $io->opened
-
-Returns true if the object is currently a valid file descriptor, false
-otherwise.
-
-=item $io->getline
-
-This works like <$io> described in L<perlop/"I/O Operators">
-except that it's more readable and can be safely called in a
-list context but still returns just one line. If used as the conditional
-+within a C<while> or C-style C<for> loop, however, you will need to
-+emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>.
-
-=item $io->getlines
-
-This works like <$io> when called in a list context to read all
-the remaining lines in a file, except that it's more readable.
-It will also croak() if accidentally called in a scalar context.
-
-=item $io->ungetc ( ORD )
-
-Pushes a character with the given ordinal value back onto the given
-handle's input stream. Only one character of pushback per handle is
-guaranteed.
-
-=item $io->write ( BUF, LEN [, OFFSET ] )
-
-This C<write> is like C<write> found in C, that is it is the
-opposite of read. The wrapper for the perl C<write> function is
-called C<format_write>.
-
-=item $io->error
-
-Returns a true value if the given handle has experienced any errors
-since it was opened or since the last call to C<clearerr>, or if the
-handle is invalid. It only returns false for a valid handle with no
-outstanding errors.
-
-=item $io->clearerr
-
-Clear the given handle's error indicator. Returns -1 if the handle is
-invalid, 0 otherwise.
-
-=item $io->sync
-
-C<sync> synchronizes a file's in-memory state with that on the
-physical medium. C<sync> does not operate at the perlio api level, but
-operates on the file descriptor (similar to sysread, sysseek and
-systell). This means that any data held at the perlio api level will not
-be synchronized. To synchronize data that is buffered at the perlio api
-level you must use the flush method. C<sync> is not implemented on all
-platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
-for an invalid handle. See L<fsync(3c)>.
-
-=item $io->flush
-
-C<flush> causes perl to flush any buffered data at the perlio api level.
-Any unread data in the buffer will be discarded, and any unwritten data
-will be written to the underlying file descriptor. Returns "0 but true"
-on success, C<undef> on error.
-
-=item $io->printflush ( ARGS )
-
-Turns on autoflush, print ARGS and then restores the autoflush status of the
-C<IO::Handle> object. Returns the return value from print.
-
-=item $io->blocking ( [ BOOL ] )
-
-If called with an argument C<blocking> will turn on non-blocking IO if
-C<BOOL> is false, and turn it off if C<BOOL> is true.
-
-C<blocking> will return the value of the previous setting, or the
-current setting if C<BOOL> is not given.
-
-If an error occurs C<blocking> will return undef and C<$!> will be set.
-
-=back
-
-
-If the C functions setbuf() and/or setvbuf() are available, then
-C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
-policy for an IO::Handle. The calling sequences for the Perl functions
-are the same as their C counterparts--including the constants C<_IOFBF>,
-C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
-specifies a scalar variable to use as a buffer. You should only
-change the buffer before any I/O, or immediately after calling flush.
-
-WARNING: The IO::Handle::setvbuf() is not available by default on
-Perls 5.8.0 and later because setvbuf() is rather specific to using
-the stdio library, while Perl prefers the new perlio subsystem instead.
-
-WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
-be modified> in any way until the IO::Handle is closed or C<setbuf> or
-C<setvbuf> is called again, or memory corruption may result! Remember that
-the order of global destruction is undefined, so even if your buffer
-variable remains in scope until program termination, it may be undefined
-before the file IO::Handle is closed. Note that you need to import the
-constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
-returns nothing. setvbuf returns "0 but true", on success, C<undef> on
-failure.
-
-Lastly, there is a special method for working under B<-T> and setuid/gid
-scripts:
-
-=over 4
-
-=item $io->untaint
-
-Marks the object as taint-clean, and as such data read from it will also
-be considered taint-clean. Note that this is a very trusting action to
-take, and appropriate consideration for the data source and potential
-vulnerability should be kept in mind. Returns 0 on success, -1 if setting
-the taint-clean flag failed. (eg invalid handle)
-
-=back
-
-=head1 NOTE
-
-An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
-the C<Symbol> package). Some modules that
-inherit from C<IO::Handle> may want to keep object related variables
-in the hash table part of the GLOB. In an attempt to prevent modules
-trampling on each other I propose the that any such module should prefix
-its variables with its own name separated by _'s. For example the IO::Socket
-module keeps a C<timeout> variable in 'io_socket_timeout'.
-
-=head1 SEE ALSO
-
-L<perlfunc>,
-L<perlop/"I/O Operators">,
-L<IO::File>
-
-=head1 BUGS
-
-Due to backwards compatibility, all filehandles resemble objects
-of class C<IO::Handle>, or actually classes derived from that class.
-They actually aren't. Which means you can't derive your own
-class from C<IO::Handle> and inherit those methods.
-
-=head1 HISTORY
-
-Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
-
-=cut
-
-use 5.006_001;
-use strict;
-our($VERSION, @EXPORT_OK, @ISA);
-use Carp;
-use Symbol;
-use SelectSaver;
-use IO (); # Load the XS module
-
-require Exporter;
-@ISA = qw(Exporter);
-
-$VERSION = "1.28";
-$VERSION = eval $VERSION;
-
-@EXPORT_OK = qw(
- autoflush
- output_field_separator
- output_record_separator
- input_record_separator
- input_line_number
- format_page_number
- format_lines_per_page
- format_lines_left
- format_name
- format_top_name
- format_line_break_characters
- format_formfeed
- format_write
-
- print
- printf
- say
- getline
- getlines
-
- printflush
- flush
-
- SEEK_SET
- SEEK_CUR
- SEEK_END
- _IOFBF
- _IOLBF
- _IONBF
-);
-
-################################################
-## Constructors, destructors.
-##
-
-sub new {
- my $class = ref($_[0]) || $_[0] || "IO::Handle";
- @_ == 1 or croak "usage: new $class";
- my $io = gensym;
- bless $io, $class;
-}
-
-sub new_from_fd {
- my $class = ref($_[0]) || $_[0] || "IO::Handle";
- @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
- my $io = gensym;
- shift;
- IO::Handle::fdopen($io, @_)
- or return undef;
- bless $io, $class;
-}
-
-#
-# There is no need for DESTROY to do anything, because when the
-# last reference to an IO object is gone, Perl automatically
-# closes its associated files (if any). However, to avoid any
-# attempts to autoload DESTROY, we here define it to do nothing.
-#
-sub DESTROY {}
-
-
-################################################
-## Open and close.
-##
-
-sub _open_mode_string {
- my ($mode) = @_;
- $mode =~ /^\+?(<|>>?)$/
- or $mode =~ s/^r(\+?)$/$1</
- or $mode =~ s/^w(\+?)$/$1>/
- or $mode =~ s/^a(\+?)$/$1>>/
- or croak "IO::Handle: bad open mode: $mode";
- $mode;
-}
-
-sub fdopen {
- @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
- my ($io, $fd, $mode) = @_;
- local(*GLOB);
-
- if (ref($fd) && "".$fd =~ /GLOB\(/o) {
- # It's a glob reference; Alias it as we cannot get name of anon GLOBs
- my $n = qualify(*GLOB);
- *GLOB = *{*$fd};
- $fd = $n;
- } elsif ($fd =~ m#^\d+$#) {
- # It's an FD number; prefix with "=".
- $fd = "=$fd";
- }
-
- open($io, _open_mode_string($mode) . '&' . $fd)
- ? $io : undef;
-}
-
-sub close {
- @_ == 1 or croak 'usage: $io->close()';
- my($io) = @_;
-
- close($io);
-}
-
-################################################
-## Normal I/O functions.
-##
-
-# flock
-# select
-
-sub opened {
- @_ == 1 or croak 'usage: $io->opened()';
- defined fileno($_[0]);
-}
-
-sub fileno {
- @_ == 1 or croak 'usage: $io->fileno()';
- fileno($_[0]);
-}
-
-sub getc {
- @_ == 1 or croak 'usage: $io->getc()';
- getc($_[0]);
-}
-
-sub eof {
- @_ == 1 or croak 'usage: $io->eof()';
- eof($_[0]);
-}
-
-sub print {
- @_ or croak 'usage: $io->print(ARGS)';
- my $this = shift;
- print $this @_;
-}
-
-sub printf {
- @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
- my $this = shift;
- printf $this @_;
-}
-
-sub say {
- @_ or croak 'usage: $io->say(ARGS)';
- my $this = shift;
- local $\ = "\n";
- print $this @_;
-}
-
-sub getline {
- @_ == 1 or croak 'usage: $io->getline()';
- my $this = shift;
- return scalar <$this>;
-}
-
-*gets = \&getline; # deprecated
-
-sub getlines {
- @_ == 1 or croak 'usage: $io->getlines()';
- wantarray or
- croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
- my $this = shift;
- return <$this>;
-}
-
-sub truncate {
- @_ == 2 or croak 'usage: $io->truncate(LEN)';
- truncate($_[0], $_[1]);
-}
-
-sub read {
- @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
- read($_[0], $_[1], $_[2], $_[3] || 0);
-}
-
-sub sysread {
- @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
- sysread($_[0], $_[1], $_[2], $_[3] || 0);
-}
-
-sub write {
- @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
- local($\) = "";
- $_[2] = length($_[1]) unless defined $_[2];
- print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
-}
-
-sub syswrite {
- @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
- if (defined($_[2])) {
- syswrite($_[0], $_[1], $_[2], $_[3] || 0);
- } else {
- syswrite($_[0], $_[1]);
- }
-}
-
-sub stat {
- @_ == 1 or croak 'usage: $io->stat()';
- stat($_[0]);
-}
-
-################################################
-## State modification functions.
-##
-
-sub autoflush {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $|;
- $| = @_ > 1 ? $_[1] : 1;
- $prev;
-}
-
-sub output_field_separator {
- carp "output_field_separator is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $,;
- $, = $_[1] if @_ > 1;
- $prev;
-}
-
-sub output_record_separator {
- carp "output_record_separator is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $\;
- $\ = $_[1] if @_ > 1;
- $prev;
-}
-
-sub input_record_separator {
- carp "input_record_separator is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $/;
- $/ = $_[1] if @_ > 1;
- $prev;
-}
-
-sub input_line_number {
- local $.;
- () = tell qualify($_[0], caller) if ref($_[0]);
- my $prev = $.;
- $. = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_page_number {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $%;
- $% = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_lines_per_page {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $=;
- $= = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_lines_left {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $-;
- $- = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_name {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $~;
- $~ = qualify($_[1], caller) if @_ > 1;
- $prev;
-}
-
-sub format_top_name {
- my $old;
- $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
- my $prev = $^;
- $^ = qualify($_[1], caller) if @_ > 1;
- $prev;
-}
-
-sub format_line_break_characters {
- carp "format_line_break_characters is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $:;
- $: = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_formfeed {
- carp "format_formfeed is not supported on a per-handle basis"
- if ref($_[0]);
- my $prev = $^L;
- $^L = $_[1] if @_ > 1;
- $prev;
-}
-
-sub formline {
- my $io = shift;
- my $picture = shift;
- local($^A) = $^A;
- local($\) = "";
- formline($picture, @_);
- print $io $^A;
-}
-
-sub format_write {
- @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
- if (@_ == 2) {
- my ($io, $fmt) = @_;
- my $oldfmt = $io->format_name(qualify($fmt,caller));
- CORE::write($io);
- $io->format_name($oldfmt);
- } else {
- CORE::write($_[0]);
- }
-}
-
-sub fcntl {
- @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
- my ($io, $op) = @_;
- return fcntl($io, $op, $_[2]);
-}
-
-sub ioctl {
- @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
- my ($io, $op) = @_;
- return ioctl($io, $op, $_[2]);
-}
-
-# this sub is for compatability with older releases of IO that used
-# a sub called constant to detemine if a constant existed -- GMB
-#
-# The SEEK_* and _IO?BF constants were the only constants at that time
-# any new code should just chech defined(&CONSTANT_NAME)
-
-sub constant {
- no strict 'refs';
- my $name = shift;
- (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
- ? &{$name}() : undef;
-}
-
-
-# so that flush.pl can be deprecated
-
-sub printflush {
- my $io = shift;
- my $old;
- $old = new SelectSaver qualify($io, caller) if ref($io);
- local $| = 1;
- if(ref($io)) {
- print $io @_;
- }
- else {
- print @_;
- }
-}
-
-1;
diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm
deleted file mode 100644
index 827cc48bfc..0000000000
--- a/ext/IO/lib/IO/Pipe.pm
+++ /dev/null
@@ -1,257 +0,0 @@
-# IO::Pipe.pm
-#
-# Copyright (c) 1996-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::Pipe;
-
-use 5.006_001;
-
-use IO::Handle;
-use strict;
-our($VERSION);
-use Carp;
-use Symbol;
-
-$VERSION = "1.13";
-
-sub new {
- my $type = shift;
- my $class = ref($type) || $type || "IO::Pipe";
- @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
-
- my $me = bless gensym(), $class;
-
- my($readfh,$writefh) = @_ ? @_ : $me->handles;
-
- pipe($readfh, $writefh)
- or return undef;
-
- @{*$me} = ($readfh, $writefh);
-
- $me;
-}
-
-sub handles {
- @_ == 1 or croak 'usage: $pipe->handles()';
- (IO::Pipe::End->new(), IO::Pipe::End->new());
-}
-
-my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
-
-sub _doit {
- my $me = shift;
- my $rw = shift;
-
- my $pid = $do_spawn ? 0 : fork();
-
- if($pid) { # Parent
- return $pid;
- }
- elsif(defined $pid) { # Child or spawn
- my $fh;
- my $io = $rw ? \*STDIN : \*STDOUT;
- my ($mode, $save) = $rw ? "r" : "w";
- if ($do_spawn) {
- require Fcntl;
- $save = IO::Handle->new_from_fd($io, $mode);
- my $handle = shift;
- # Close in child:
- unless ($^O eq 'MSWin32') {
- fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
- }
- $fh = $rw ? ${*$me}[0] : ${*$me}[1];
- } else {
- shift;
- $fh = $rw ? $me->reader() : $me->writer(); # close the other end
- }
- bless $io, "IO::Handle";
- $io->fdopen($fh, $mode);
- $fh->close;
-
- if ($do_spawn) {
- $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
- my $err = $!;
-
- $io->fdopen($save, $mode);
- $save->close or croak "Cannot close $!";
- croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
- return $pid;
- } else {
- exec @_ or
- croak "IO::Pipe: Cannot exec: $!";
- }
- }
- else {
- croak "IO::Pipe: Cannot fork: $!";
- }
-
- # NOT Reached
-}
-
-sub reader {
- @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
- my $me = shift;
-
- return undef
- unless(ref($me) || ref($me = $me->new));
-
- my $fh = ${*$me}[0];
- my $pid;
- $pid = $me->_doit(0, $fh, @_)
- if(@_);
-
- close ${*$me}[1];
- bless $me, ref($fh);
- *$me = *$fh; # Alias self to handle
- $me->fdopen($fh->fileno,"r")
- unless defined($me->fileno);
- bless $fh; # Really wan't un-bless here
- ${*$me}{'io_pipe_pid'} = $pid
- if defined $pid;
-
- $me;
-}
-
-sub writer {
- @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
- my $me = shift;
-
- return undef
- unless(ref($me) || ref($me = $me->new));
-
- my $fh = ${*$me}[1];
- my $pid;
- $pid = $me->_doit(1, $fh, @_)
- if(@_);
-
- close ${*$me}[0];
- bless $me, ref($fh);
- *$me = *$fh; # Alias self to handle
- $me->fdopen($fh->fileno,"w")
- unless defined($me->fileno);
- bless $fh; # Really wan't un-bless here
- ${*$me}{'io_pipe_pid'} = $pid
- if defined $pid;
-
- $me;
-}
-
-package IO::Pipe::End;
-
-our(@ISA);
-
-@ISA = qw(IO::Handle);
-
-sub close {
- my $fh = shift;
- my $r = $fh->SUPER::close(@_);
-
- waitpid(${*$fh}{'io_pipe_pid'},0)
- if(defined ${*$fh}{'io_pipe_pid'});
-
- $r;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Pipe - supply object methods for pipes
-
-=head1 SYNOPSIS
-
- use IO::Pipe;
-
- $pipe = new IO::Pipe;
-
- if($pid = fork()) { # Parent
- $pipe->reader();
-
- while(<$pipe>) {
- ...
- }
-
- }
- elsif(defined $pid) { # Child
- $pipe->writer();
-
- print $pipe ...
- }
-
- or
-
- $pipe = new IO::Pipe;
-
- $pipe->reader(qw(ls -l));
-
- while(<$pipe>) {
- ...
- }
-
-=head1 DESCRIPTION
-
-C<IO::Pipe> provides an interface to creating pipes between
-processes.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [READER, WRITER] )
-
-Creates an C<IO::Pipe>, which is a reference to a newly created symbol
-(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
-arguments, which should be objects blessed into C<IO::Handle>, or a
-subclass thereof. These two objects will be used for the system call
-to C<pipe>. If no arguments are given then method C<handles> is called
-on the new C<IO::Pipe> object.
-
-These two handles are held in the array part of the GLOB until either
-C<reader> or C<writer> is called.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item reader ([ARGS])
-
-The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
-handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
-is called and C<ARGS> are passed to exec.
-
-=item writer ([ARGS])
-
-The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
-handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
-is called and C<ARGS> are passed to exec.
-
-=item handles ()
-
-This method is called during construction by C<IO::Pipe::new>
-on the newly created C<IO::Pipe> object. It returns an array of two objects
-blessed into C<IO::Pipe::End>, or a subclass thereof.
-
-=back
-
-=head1 SEE ALSO
-
-L<IO::Handle>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-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.
-
-=cut
diff --git a/ext/IO/lib/IO/Poll.pm b/ext/IO/lib/IO/Poll.pm
deleted file mode 100644
index e7fb013506..0000000000
--- a/ext/IO/lib/IO/Poll.pm
+++ /dev/null
@@ -1,209 +0,0 @@
-
-# IO::Poll.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::Poll;
-
-use strict;
-use IO::Handle;
-use Exporter ();
-our(@ISA, @EXPORT_OK, @EXPORT, $VERSION);
-
-@ISA = qw(Exporter);
-$VERSION = "0.07";
-
-@EXPORT = qw( POLLIN
- POLLOUT
- POLLERR
- POLLHUP
- POLLNVAL
- );
-
-@EXPORT_OK = qw(
- POLLPRI
- POLLRDNORM
- POLLWRNORM
- POLLRDBAND
- POLLWRBAND
- POLLNORM
- );
-
-# [0] maps fd's to requested masks
-# [1] maps fd's to returned masks
-# [2] maps fd's to handles
-sub new {
- my $class = shift;
-
- my $self = bless [{},{},{}], $class;
-
- $self;
-}
-
-sub mask {
- my $self = shift;
- my $io = shift;
- my $fd = fileno($io);
- return unless defined $fd;
- if (@_) {
- my $mask = shift;
- if($mask) {
- $self->[0]{$fd}{$io} = $mask; # the error events are always returned
- $self->[1]{$fd} = 0; # output mask
- $self->[2]{$io} = $io; # remember handle
- } else {
- delete $self->[0]{$fd}{$io};
- unless(%{$self->[0]{$fd}}) {
- # We no longer have any handles for this FD
- delete $self->[1]{$fd};
- delete $self->[0]{$fd};
- }
- delete $self->[2]{$io};
- }
- }
-
- return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io};
- return $self->[0]{$fd}{$io};
-}
-
-
-sub poll {
- my($self,$timeout) = @_;
-
- $self->[1] = {};
-
- my($fd,$mask,$iom);
- my @poll = ();
-
- while(($fd,$iom) = each %{$self->[0]}) {
- $mask = 0;
- $mask |= $_ for values(%$iom);
- push(@poll,$fd => $mask);
- }
-
- my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0;
-
- return $ret
- unless $ret > 0;
-
- while(@poll) {
- my($fd,$got) = splice(@poll,0,2);
- $self->[1]{$fd} = $got if $got;
- }
-
- return $ret;
-}
-
-sub events {
- my $self = shift;
- my $io = shift;
- my $fd = fileno($io);
- exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io}
- ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL)
- : 0;
-}
-
-sub remove {
- my $self = shift;
- my $io = shift;
- $self->mask($io,0);
-}
-
-sub handles {
- my $self = shift;
- return values %{$self->[2]} unless @_;
-
- my $events = shift || 0;
- my($fd,$ev,$io,$mask);
- my @handles = ();
-
- while(($fd,$ev) = each %{$self->[1]}) {
- while (($io,$mask) = each %{$self->[0]{$fd}}) {
- $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these
- push @handles,$self->[2]{$io} if ($ev & $mask) & $events;
- }
- }
- return @handles;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Poll - Object interface to system poll call
-
-=head1 SYNOPSIS
-
- use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP);
-
- $poll = new IO::Poll;
-
- $poll->mask($input_handle => POLLIN);
- $poll->mask($output_handle => POLLOUT);
-
- $poll->poll($timeout);
-
- $ev = $poll->events($input);
-
-=head1 DESCRIPTION
-
-C<IO::Poll> is a simple interface to the system level poll routine.
-
-=head1 METHODS
-
-=over 4
-
-=item mask ( IO [, EVENT_MASK ] )
-
-If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the
-list of file descriptors and the next call to poll will check for
-any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be
-removed from the list of file descriptors.
-
-If EVENT_MASK is not given then the return value will be the current
-event mask value for IO.
-
-=item poll ( [ TIMEOUT ] )
-
-Call the system level poll routine. If TIMEOUT is not specified then the
-call will block. Returns the number of handles which had events
-happen, or -1 on error.
-
-=item events ( IO )
-
-Returns the event mask which represents the events that happened on IO
-during the last call to C<poll>.
-
-=item remove ( IO )
-
-Remove IO from the list of file descriptors for the next poll.
-
-=item handles( [ EVENT_MASK ] )
-
-Returns a list of handles. If EVENT_MASK is not given then a list of all
-handles known will be returned. If EVENT_MASK is given then a list
-of handles will be returned which had one of the events specified by
-EVENT_MASK happen during the last call ti C<poll>
-
-=back
-
-=head1 SEE ALSO
-
-L<poll(2)>, L<IO::Handle>, L<IO::Select>
-
-=head1 AUTHOR
-
-Graham Barr. 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.
-
-=cut
diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm
deleted file mode 100644
index db1effda28..0000000000
--- a/ext/IO/lib/IO/Seekable.pm
+++ /dev/null
@@ -1,128 +0,0 @@
-#
-
-package IO::Seekable;
-
-=head1 NAME
-
-IO::Seekable - supply seek based methods for I/O objects
-
-=head1 SYNOPSIS
-
- use IO::Seekable;
- package IO::Something;
- @ISA = qw(IO::Seekable);
-
-=head1 DESCRIPTION
-
-C<IO::Seekable> does not have a constructor of its own as it is intended to
-be inherited by other C<IO::Handle> based objects. It provides methods
-which allow seeking of the file descriptors.
-
-=over 4
-
-=item $io->getpos
-
-Returns an opaque value that represents the current position of the
-IO::File, or C<undef> if this is not possible (eg an unseekable stream such
-as a terminal, pipe or socket). If the fgetpos() function is available in
-your C library it is used to implements getpos, else perl emulates getpos
-using C's ftell() function.
-
-=item $io->setpos
-
-Uses the value of a previous getpos call to return to a previously visited
-position. Returns "0 but true" on success, C<undef> on failure.
-
-=back
-
-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:
-
-=over 4
-
-=item $io->seek ( POS, WHENCE )
-
-Seek the IO::File to position POS, relative to WHENCE:
-
-=over 8
-
-=item WHENCE=0 (SEEK_SET)
-
-POS is absolute position. (Seek relative to the start of the file)
-
-=item WHENCE=1 (SEEK_CUR)
-
-POS is an offset from the current position. (Seek relative to current)
-
-=item WHENCE=2 (SEEK_END)
-
-POS is an offset from the end of the file. (Seek relative to end)
-
-=back
-
-The SEEK_* constants can be imported from the C<Fcntl> module if you
-don't wish to use the numbers C<0> C<1> or C<2> in your code.
-
-Returns C<1> upon success, C<0> otherwise.
-
-=item $io->sysseek( POS, WHENCE )
-
-Similar to $io->seek, but sets the IO::File's position using the system
-call lseek(2) directly, so will confuse most perl IO operators except
-sysread and syswrite (see L<perlfunc> for full details)
-
-Returns the new position, or C<undef> on failure. A position
-of zero is returned as the string C<"0 but true">
-
-=item $io->tell
-
-Returns the IO::File's current position, or -1 on error.
-
-=back
-
-=head1 SEE ALSO
-
-L<perlfunc>,
-L<perlop/"I/O Operators">,
-L<IO::Handle>
-L<IO::File>
-
-=head1 HISTORY
-
-Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt>
-
-=cut
-
-use 5.006_001;
-use Carp;
-use strict;
-our($VERSION, @EXPORT, @ISA);
-use IO::Handle ();
-# XXX we can't get these from IO::Handle or we'll get prototype
-# mismatch warnings on C<use POSIX; use IO::File;> :-(
-use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END);
-require Exporter;
-
-@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
-@ISA = qw(Exporter);
-
-$VERSION = "1.10";
-$VERSION = eval $VERSION;
-
-sub seek {
- @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
- seek($_[0], $_[1], $_[2]);
-}
-
-sub sysseek {
- @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)';
- sysseek($_[0], $_[1], $_[2]);
-}
-
-sub tell {
- @_ == 1 or croak 'usage: $io->tell()';
- tell($_[0]);
-}
-
-1;
diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm
deleted file mode 100644
index fc05fe70e9..0000000000
--- a/ext/IO/lib/IO/Select.pm
+++ /dev/null
@@ -1,381 +0,0 @@
-# IO::Select.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::Select;
-
-use strict;
-use warnings::register;
-use vars qw($VERSION @ISA);
-require Exporter;
-
-$VERSION = "1.17";
-
-@ISA = qw(Exporter); # This is only so we can do version checking
-
-sub VEC_BITS () {0}
-sub FD_COUNT () {1}
-sub FIRST_FD () {2}
-
-sub new
-{
- my $self = shift;
- my $type = ref($self) || $self;
-
- my $vec = bless [undef,0], $type;
-
- $vec->add(@_)
- if @_;
-
- $vec;
-}
-
-sub add
-{
- shift->_update('add', @_);
-}
-
-
-sub remove
-{
- shift->_update('remove', @_);
-}
-
-
-sub exists
-{
- my $vec = shift;
- my $fno = $vec->_fileno(shift);
- return undef unless defined $fno;
- $vec->[$fno + FIRST_FD];
-}
-
-
-sub _fileno
-{
- my($self, $f) = @_;
- return unless defined $f;
- $f = $f->[0] if ref($f) eq 'ARRAY';
- ($f =~ /^\d+$/) ? $f : fileno($f);
-}
-
-sub _update
-{
- my $vec = shift;
- my $add = shift eq 'add';
-
- my $bits = $vec->[VEC_BITS];
- $bits = '' unless defined $bits;
-
- my $count = 0;
- my $f;
- foreach $f (@_)
- {
- my $fn = $vec->_fileno($f);
- next unless defined $fn;
- my $i = $fn + FIRST_FD;
- if ($add) {
- if (defined $vec->[$i]) {
- $vec->[$i] = $f; # if array rest might be different, so we update
- next;
- }
- $vec->[FD_COUNT]++;
- vec($bits, $fn, 1) = 1;
- $vec->[$i] = $f;
- } else { # remove
- next unless defined $vec->[$i];
- $vec->[FD_COUNT]--;
- vec($bits, $fn, 1) = 0;
- $vec->[$i] = undef;
- }
- $count++;
- }
- $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
- $count;
-}
-
-sub can_read
-{
- my $vec = shift;
- my $timeout = shift;
- my $r = $vec->[VEC_BITS];
-
- defined($r) && (select($r,undef,undef,$timeout) > 0)
- ? handles($vec, $r)
- : ();
-}
-
-sub can_write
-{
- my $vec = shift;
- my $timeout = shift;
- my $w = $vec->[VEC_BITS];
-
- defined($w) && (select(undef,$w,undef,$timeout) > 0)
- ? handles($vec, $w)
- : ();
-}
-
-sub has_exception
-{
- my $vec = shift;
- my $timeout = shift;
- my $e = $vec->[VEC_BITS];
-
- defined($e) && (select(undef,undef,$e,$timeout) > 0)
- ? handles($vec, $e)
- : ();
-}
-
-sub has_error
-{
- warnings::warn("Call to deprecated method 'has_error', use 'has_exception'")
- if warnings::enabled();
- goto &has_exception;
-}
-
-sub count
-{
- my $vec = shift;
- $vec->[FD_COUNT];
-}
-
-sub bits
-{
- my $vec = shift;
- $vec->[VEC_BITS];
-}
-
-sub as_string # for debugging
-{
- my $vec = shift;
- my $str = ref($vec) . ": ";
- my $bits = $vec->bits;
- my $count = $vec->count;
- $str .= defined($bits) ? unpack("b*", $bits) : "undef";
- $str .= " $count";
- my @handles = @$vec;
- splice(@handles, 0, FIRST_FD);
- for (@handles) {
- $str .= " " . (defined($_) ? "$_" : "-");
- }
- $str;
-}
-
-sub _max
-{
- my($a,$b,$c) = @_;
- $a > $b
- ? $a > $c
- ? $a
- : $c
- : $b > $c
- ? $b
- : $c;
-}
-
-sub select
-{
- shift
- if defined $_[0] && !ref($_[0]);
-
- my($r,$w,$e,$t) = @_;
- my @result = ();
-
- my $rb = defined $r ? $r->[VEC_BITS] : undef;
- my $wb = defined $w ? $w->[VEC_BITS] : undef;
- my $eb = defined $e ? $e->[VEC_BITS] : undef;
-
- if(select($rb,$wb,$eb,$t) > 0)
- {
- my @r = ();
- my @w = ();
- my @e = ();
- my $i = _max(defined $r ? scalar(@$r)-1 : 0,
- defined $w ? scalar(@$w)-1 : 0,
- defined $e ? scalar(@$e)-1 : 0);
-
- for( ; $i >= FIRST_FD ; $i--)
- {
- my $j = $i - FIRST_FD;
- push(@r, $r->[$i])
- if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
- push(@w, $w->[$i])
- if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
- push(@e, $e->[$i])
- if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
- }
-
- @result = (\@r, \@w, \@e);
- }
- @result;
-}
-
-
-sub handles
-{
- my $vec = shift;
- my $bits = shift;
- my @h = ();
- my $i;
- my $max = scalar(@$vec) - 1;
-
- for ($i = FIRST_FD; $i <= $max; $i++)
- {
- next unless defined $vec->[$i];
- push(@h, $vec->[$i])
- if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
- }
-
- @h;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-IO::Select - OO interface to the select system call
-
-=head1 SYNOPSIS
-
- use IO::Select;
-
- $s = IO::Select->new();
-
- $s->add(\*STDIN);
- $s->add($some_handle);
-
- @ready = $s->can_read($timeout);
-
- @ready = IO::Select->new(@handles)->can_read(0);
-
-=head1 DESCRIPTION
-
-The C<IO::Select> package implements an object approach to the system C<select>
-function call. It allows the user to see what IO handles, see L<IO::Handle>,
-are ready for reading, writing or have an exception pending.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HANDLES ] )
-
-The constructor creates a new object and optionally initialises it with a set
-of handles.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item add ( HANDLES )
-
-Add the list of handles to the C<IO::Select> object. It is these values that
-will be returned when an event occurs. C<IO::Select> keeps these values in a
-cache which is indexed by the C<fileno> of the handle, so if more than one
-handle with the same C<fileno> is specified then only the last one is cached.
-
-Each handle can be an C<IO::Handle> object, an integer or an array
-reference where the first element is an C<IO::Handle> or an integer.
-
-=item remove ( HANDLES )
-
-Remove all the given handles from the object. This method also works
-by the C<fileno> of the handles. So the exact handles that were added
-need not be passed, just handles that have an equivalent C<fileno>
-
-=item exists ( HANDLE )
-
-Returns a true value (actually the handle itself) if it is present.
-Returns undef otherwise.
-
-=item handles
-
-Return an array of all registered handles.
-
-=item can_read ( [ TIMEOUT ] )
-
-Return an array of handles that are ready for reading. C<TIMEOUT> is
-the maximum amount of time to wait before returning an empty list, in
-seconds, possibly fractional. If C<TIMEOUT> is not given and any
-handles are registered then the call will block.
-
-=item can_write ( [ TIMEOUT ] )
-
-Same as C<can_read> except check for handles that can be written to.
-
-=item has_exception ( [ TIMEOUT ] )
-
-Same as C<can_read> except check for handles that have an exception
-condition, for example pending out-of-band data.
-
-=item count ()
-
-Returns the number of handles that the object will check for when
-one of the C<can_> methods is called or the object is passed to
-the C<select> static method.
-
-=item bits()
-
-Return the bit string suitable as argument to the core select() call.
-
-=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] )
-
-C<select> is a static method, that is you call it with the package name
-like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or
-C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as
-for the core select call.
-
-The result will be an array of 3 elements, each a reference to an array
-which will hold the handles that are ready for reading, writing and have
-exceptions respectively. Upon error an empty list is returned.
-
-=back
-
-=head1 EXAMPLE
-
-Here is a short example which shows how C<IO::Select> could be used
-to write a server which communicates with several sockets while also
-listening for more connections on a listen socket
-
- use IO::Select;
- use IO::Socket;
-
- $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
- $sel = new IO::Select( $lsn );
-
- while(@ready = $sel->can_read) {
- foreach $fh (@ready) {
- if($fh == $lsn) {
- # Create a new socket
- $new = $lsn->accept;
- $sel->add($new);
- }
- else {
- # Process socket
-
- # Maybe we have finished with the socket
- $sel->remove($fh);
- $fh->close;
- }
- }
- }
-
-=head1 AUTHOR
-
-Graham Barr. 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.
-
-=cut
-
diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm
deleted file mode 100644
index 9938c7807a..0000000000
--- a/ext/IO/lib/IO/Socket.pm
+++ /dev/null
@@ -1,530 +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__
-
-=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 (in seconds) 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
diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm
deleted file mode 100644
index 2f0e5d1d7a..0000000000
--- a/ext/IO/lib/IO/Socket/INET.pm
+++ /dev/null
@@ -1,464 +0,0 @@
-# IO::Socket::INET.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::INET;
-
-use strict;
-our(@ISA, $VERSION);
-use IO::Socket;
-use Socket;
-use Carp;
-use Exporter;
-use Errno;
-
-@ISA = qw(IO::Socket);
-$VERSION = "1.31";
-
-my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
-
-IO::Socket::INET->register_domain( AF_INET );
-
-my %socket_type = ( tcp => SOCK_STREAM,
- udp => SOCK_DGRAM,
- icmp => SOCK_RAW
- );
-my %proto_number;
-$proto_number{tcp} = Socket::IPPROTO_TCP() if defined &Socket::IPPROTO_TCP;
-$proto_number{udp} = Socket::IPPROTO_UDP() if defined &Socket::IPPROTO_UDP;
-$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
-my %proto_name = reverse %proto_number;
-
-sub new {
- my $class = shift;
- unshift(@_, "PeerAddr") if @_ == 1;
- return $class->SUPER::new(@_);
-}
-
-sub _cache_proto {
- my @proto = @_;
- for (map lc($_), $proto[0], split(' ', $proto[1])) {
- $proto_number{$_} = $proto[2];
- }
- $proto_name{$proto[2]} = $proto[0];
-}
-
-sub _get_proto_number {
- my $name = lc(shift);
- return undef unless defined $name;
- return $proto_number{$name} if exists $proto_number{$name};
-
- my @proto = getprotobyname($name);
- return undef unless @proto;
- _cache_proto(@proto);
-
- return $proto[2];
-}
-
-sub _get_proto_name {
- my $num = shift;
- return undef unless defined $num;
- return $proto_name{$num} if exists $proto_name{$num};
-
- my @proto = getprotobynumber($num);
- return undef unless @proto;
- _cache_proto(@proto);
-
- return $proto[0];
-}
-
-sub _sock_info {
- my($addr,$port,$proto) = @_;
- my $origport = $port;
- my @serv = ();
-
- $port = $1
- if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
-
- if(defined $proto && $proto =~ /\D/) {
- my $num = _get_proto_number($proto);
- unless (defined $num) {
- $@ = "Bad protocol '$proto'";
- return;
- }
- $proto = $num;
- }
-
- if(defined $port) {
- my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
- my $pnum = ($port =~ m,^(\d+)$,)[0];
-
- @serv = getservbyname($port, _get_proto_name($proto) || "")
- if ($port =~ m,\D,);
-
- $port = $serv[2] || $defport || $pnum;
- unless (defined $port) {
- $@ = "Bad service '$origport'";
- return;
- }
-
- $proto = _get_proto_number($serv[3]) if @serv && !$proto;
- }
-
- return ($addr || undef,
- $port || undef,
- $proto || undef
- );
-}
-
-sub _error {
- my $sock = shift;
- my $err = shift;
- {
- local($!);
- my $title = ref($sock).": ";
- $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
- $sock->close()
- if(defined fileno($sock));
- }
- $! = $err;
- return undef;
-}
-
-sub _get_addr {
- my($sock,$addr_str, $multi) = @_;
- my @addr;
- if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
- (undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
- } else {
- my $h = inet_aton($addr_str);
- push(@addr, $h) if defined $h;
- }
- @addr;
-}
-
-sub configure {
- my($sock,$arg) = @_;
- my($lport,$rport,$laddr,$raddr,$proto,$type);
-
-
- $arg->{LocalAddr} = $arg->{LocalHost}
- if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
-
- ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
- $arg->{LocalPort},
- $arg->{Proto})
- or return _error($sock, $!, $@);
-
- $laddr = defined $laddr ? inet_aton($laddr)
- : INADDR_ANY;
-
- return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
- unless(defined $laddr);
-
- $arg->{PeerAddr} = $arg->{PeerHost}
- if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
-
- unless(exists $arg->{Listen}) {
- ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
- $arg->{PeerPort},
- $proto)
- or return _error($sock, $!, $@);
- }
-
- $proto ||= _get_proto_number('tcp');
-
- $type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)};
-
- my @raddr = ();
-
- if(defined $raddr) {
- @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
- return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
- unless @raddr;
- }
-
- while(1) {
-
- $sock->socket(AF_INET, $type, $proto) or
- return _error($sock, $!, "$!");
-
- if (defined $arg->{Blocking}) {
- defined $sock->blocking($arg->{Blocking})
- or return _error($sock, $!, "$!");
- }
-
- if ($arg->{Reuse} || $arg->{ReuseAddr}) {
- $sock->sockopt(SO_REUSEADDR,1) or
- return _error($sock, $!, "$!");
- }
-
- if ($arg->{ReusePort}) {
- $sock->sockopt(SO_REUSEPORT,1) or
- return _error($sock, $!, "$!");
- }
-
- if ($arg->{Broadcast}) {
- $sock->sockopt(SO_BROADCAST,1) or
- return _error($sock, $!, "$!");
- }
-
- if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
- $sock->bind($lport || 0, $laddr) or
- return _error($sock, $!, "$!");
- }
-
- if(exists $arg->{Listen}) {
- $sock->listen($arg->{Listen} || 5) or
- return _error($sock, $!, "$!");
- last;
- }
-
- # don't try to connect unless we're given a PeerAddr
- last unless exists($arg->{PeerAddr});
-
- $raddr = shift @raddr;
-
- return _error($sock, $EINVAL, 'Cannot determine remote port')
- unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
-
- last
- unless($type == SOCK_STREAM || defined $raddr);
-
- return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
- unless defined $raddr;
-
-# my $timeout = ${*$sock}{'io_socket_timeout'};
-# my $before = time() if $timeout;
-
- undef $@;
- if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
-# ${*$sock}{'io_socket_timeout'} = $timeout;
- return $sock;
- }
-
- return _error($sock, $!, $@ || "Timeout")
- unless @raddr;
-
-# if ($timeout) {
-# my $new_timeout = $timeout - (time() - $before);
-# return _error($sock,
-# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
-# "Timeout") if $new_timeout <= 0;
-# ${*$sock}{'io_socket_timeout'} = $new_timeout;
-# }
-
- }
-
- $sock;
-}
-
-sub connect {
- @_ == 2 || @_ == 3 or
- croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
- my $sock = shift;
- return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
-}
-
-sub bind {
- @_ == 2 || @_ == 3 or
- croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
- my $sock = shift;
- return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
-}
-
-sub sockaddr {
- @_ == 1 or croak 'usage: $sock->sockaddr()';
- my($sock) = @_;
- my $name = $sock->sockname;
- $name ? (sockaddr_in($name))[1] : undef;
-}
-
-sub sockport {
- @_ == 1 or croak 'usage: $sock->sockport()';
- my($sock) = @_;
- my $name = $sock->sockname;
- $name ? (sockaddr_in($name))[0] : undef;
-}
-
-sub sockhost {
- @_ == 1 or croak 'usage: $sock->sockhost()';
- my($sock) = @_;
- my $addr = $sock->sockaddr;
- $addr ? inet_ntoa($addr) : undef;
-}
-
-sub peeraddr {
- @_ == 1 or croak 'usage: $sock->peeraddr()';
- my($sock) = @_;
- my $name = $sock->peername;
- $name ? (sockaddr_in($name))[1] : undef;
-}
-
-sub peerport {
- @_ == 1 or croak 'usage: $sock->peerport()';
- my($sock) = @_;
- my $name = $sock->peername;
- $name ? (sockaddr_in($name))[0] : undef;
-}
-
-sub peerhost {
- @_ == 1 or croak 'usage: $sock->peerhost()';
- my($sock) = @_;
- my $addr = $sock->peeraddr;
- $addr ? inet_ntoa($addr) : undef;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-IO::Socket::INET - Object interface for AF_INET domain sockets
-
-=head1 SYNOPSIS
-
- use IO::Socket::INET;
-
-=head1 DESCRIPTION
-
-C<IO::Socket::INET> provides an object interface to creating and using sockets
-in the AF_INET domain. It is built upon the L<IO::Socket> interface and
-inherits all the methods defined by L<IO::Socket>.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ARGS] )
-
-Creates an C<IO::Socket::INET> object, 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.
-
-In addition to the key-value pairs accepted by L<IO::Socket>,
-C<IO::Socket::INET> provides.
-
-
- PeerAddr Remote host address <hostname>[:<port>]
- PeerHost Synonym for PeerAddr
- PeerPort Remote port or service <service>[(<no>)] | <no>
- LocalAddr Local host bind address hostname[:port]
- LocalHost Synonym for LocalAddr
- LocalPort Local host bind port <service>[(<no>)] | <no>
- Proto Protocol name (or number) "tcp" | "udp" | ...
- Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
- Listen Queue size for listen
- ReuseAddr Set SO_REUSEADDR before binding
- Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr)
- ReusePort Set SO_REUSEPORT before binding
- Broadcast Set SO_BROADCAST before binding
- Timeout Timeout value for various operations
- MultiHomed Try all addresses for multi-homed hosts
- Blocking Determine if connection will be blocking mode
-
-If C<Listen> is defined then a listen socket is created, else if the
-socket type, which is derived from the protocol, is SOCK_STREAM then
-connect() is called.
-
-Although it is not illegal, the use of C<MultiHomed> on a socket
-which is in non-blocking mode is of little use. This is because the
-first connect will never fail with a timeout as the connect call
-will not block.
-
-The C<PeerAddr> can be a hostname or the IP-address on the
-"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic
-service name. The service name might be followed by a number in
-parenthesis which is used if the service is not known by the system.
-The C<PeerPort> specification can also be embedded in the C<PeerAddr>
-by preceding it with a ":".
-
-If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
-then the constructor will try to derive C<Proto> from the service
-name. As a last resort C<Proto> "tcp" is assumed. The C<Type>
-parameter will be deduced from C<Proto> if not specified.
-
-If the constructor is only passed a single argument, it is assumed to
-be a C<PeerAddr> specification.
-
-If C<Blocking> is set to 0, the connection will be in nonblocking mode.
-If not specified it defaults to 1 (blocking mode).
-
-Examples:
-
- $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
- PeerPort => 'http(80)',
- Proto => 'tcp');
-
- $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
-
- $sock = IO::Socket::INET->new(Listen => 5,
- LocalAddr => 'localhost',
- LocalPort => 9000,
- Proto => 'tcp');
-
- $sock = IO::Socket::INET->new('127.0.0.1:25');
-
- $sock = IO::Socket::INET->new(PeerPort => 9999,
- PeerAddr => inet_ntoa(INADDR_BROADCAST),
- Proto => udp,
- LocalAddr => 'localhost',
- Broadcast => 1 )
- or die "Can't bind : $@\n";
-
- 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
-
-=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
-
-=head1 SEE ALSO
-
-L<Socket>, L<IO::Socket>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-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.
-
-=cut
diff --git a/ext/IO/lib/IO/Socket/UNIX.pm b/ext/IO/lib/IO/Socket/UNIX.pm
deleted file mode 100644
index baa092ba1f..0000000000
--- a/ext/IO/lib/IO/Socket/UNIX.pm
+++ /dev/null
@@ -1,143 +0,0 @@
-# IO::Socket::UNIX.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::UNIX;
-
-use strict;
-our(@ISA, $VERSION);
-use IO::Socket;
-use Carp;
-
-@ISA = qw(IO::Socket);
-$VERSION = "1.23";
-$VERSION = eval $VERSION;
-
-IO::Socket::UNIX->register_domain( AF_UNIX );
-
-sub new {
- my $class = shift;
- unshift(@_, "Peer") if @_ == 1;
- return $class->SUPER::new(@_);
-}
-
-sub configure {
- my($sock,$arg) = @_;
- my($bport,$cport);
-
- my $type = $arg->{Type} || SOCK_STREAM;
-
- $sock->socket(AF_UNIX, $type, 0) or
- return undef;
-
- if(exists $arg->{Local}) {
- my $addr = sockaddr_un($arg->{Local});
- $sock->bind($addr) or
- return undef;
- }
- if(exists $arg->{Listen} && $type != SOCK_DGRAM) {
- $sock->listen($arg->{Listen} || 5) or
- return undef;
- }
- elsif(exists $arg->{Peer}) {
- my $addr = sockaddr_un($arg->{Peer});
- $sock->connect($addr) or
- return undef;
- }
-
- $sock;
-}
-
-sub hostpath {
- @_ == 1 or croak 'usage: $sock->hostpath()';
- my $n = $_[0]->sockname || return undef;
- (sockaddr_un($n))[0];
-}
-
-sub peerpath {
- @_ == 1 or croak 'usage: $sock->peerpath()';
- my $n = $_[0]->peername || return undef;
- (sockaddr_un($n))[0];
-}
-
-1; # Keep require happy
-
-__END__
-
-=head1 NAME
-
-IO::Socket::UNIX - Object interface for AF_UNIX domain sockets
-
-=head1 SYNOPSIS
-
- use IO::Socket::UNIX;
-
-=head1 DESCRIPTION
-
-C<IO::Socket::UNIX> provides an object interface to creating and using sockets
-in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and
-inherits all the methods defined by L<IO::Socket>.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ARGS] )
-
-Creates an C<IO::Socket::UNIX> object, 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.
-
-In addition to the key-value pairs accepted by L<IO::Socket>,
-C<IO::Socket::UNIX> provides.
-
- 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
-
-If the constructor is only passed a single argument, it is assumed to
-be a C<Peer> specification.
-
-
- 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
-
-=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
-
-=head1 SEE ALSO
-
-L<Socket>, L<IO::Socket>
-
-=head1 AUTHOR
-
-Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perl5-porters@perl.org>.
-
-=head1 COPYRIGHT
-
-Copyright (c) 1996-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.
-
-=cut
diff --git a/ext/IO/poll.c b/ext/IO/poll.c
deleted file mode 100644
index 9d39d57f2f..0000000000
--- a/ext/IO/poll.c
+++ /dev/null
@@ -1,146 +0,0 @@
-/*
- * poll.c
- *
- * 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.
- *
- * For systems that do not have the poll() system call (for example Linux
- * kernels < v2.1.23) try to emulate it as closely as possible using select()
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-#include "poll.h"
-#ifdef I_SYS_TIME
-# include <sys/time.h>
-#endif
-#ifdef I_TIME
-# include <time.h>
-#endif
-#include <sys/types.h>
-#if defined(HAS_SOCKET) && !defined(VMS) && !defined(ultrix) /* VMS handles sockets via vmsish.h, ULTRIX dies of socket struct redefinitions */
-# include <sys/socket.h>
-#endif
-#include <sys/stat.h>
-#include <errno.h>
-
-#ifdef HAS_SELECT
-#ifdef I_SYS_SELECT
-#include <sys/select.h>
-#endif
-#endif
-
-#ifdef EMULATE_POLL_WITH_SELECT
-
-# define POLL_CAN_READ (POLLIN | POLLRDNORM )
-# define POLL_CAN_WRITE (POLLOUT | POLLWRNORM | POLLWRBAND )
-# define POLL_HAS_EXCP (POLLRDBAND | POLLPRI )
-
-# define POLL_EVENTS_MASK (POLL_CAN_READ | POLL_CAN_WRITE | POLL_HAS_EXCP)
-
-int
-poll(struct pollfd *fds, unsigned long nfds, int timeout)
-{
- int i,err;
- fd_set rfd,wfd,efd,ifd;
- struct timeval timebuf;
- struct timeval *tbuf = (struct timeval *)0;
- int n = 0;
- int count;
-
- FD_ZERO(&ifd);
-
-again:
-
- FD_ZERO(&rfd);
- FD_ZERO(&wfd);
- FD_ZERO(&efd);
-
- for(i = 0 ; i < (int)nfds ; i++) {
- int events = fds[i].events;
- int fd = fds[i].fd;
-
- fds[i].revents = 0;
-
- if(fd < 0 || FD_ISSET(fd, &ifd))
- continue;
-
- if(fd > n)
- n = fd;
-
- if(events & POLL_CAN_READ)
- FD_SET(fd, &rfd);
-
- if(events & POLL_CAN_WRITE)
- FD_SET(fd, &wfd);
-
- if(events & POLL_HAS_EXCP)
- FD_SET(fd, &efd);
- }
-
- if(timeout >= 0) {
- timebuf.tv_sec = timeout / 1000;
- timebuf.tv_usec = (timeout % 1000) * 1000;
- tbuf = &timebuf;
- }
-
- err = select(n+1,&rfd,&wfd,&efd,tbuf);
-
- if(err < 0) {
-#ifdef HAS_FSTAT
- if(errno == EBADF) {
- for(i = 0 ; i < nfds ; i++) {
- struct stat buf;
- if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) {
- FD_SET(fds[i].fd, &ifd);
- goto again;
- }
- }
- }
-#endif /* HAS_FSTAT */
- return err;
- }
-
- count = 0;
-
- for(i = 0 ; i < (int)nfds ; i++) {
- int revents = (fds[i].events & POLL_EVENTS_MASK);
- int fd = fds[i].fd;
-
- if(fd < 0)
- continue;
-
- if(FD_ISSET(fd, &ifd))
- revents = POLLNVAL;
- else {
- if(!FD_ISSET(fd, &rfd))
- revents &= ~POLL_CAN_READ;
-
- if(!FD_ISSET(fd, &wfd))
- revents &= ~POLL_CAN_WRITE;
-
- if(!FD_ISSET(fd, &efd))
- revents &= ~POLL_HAS_EXCP;
- }
-
- if((fds[i].revents = revents) != 0)
- count++;
- }
-
- return count;
-}
-
-#endif /* EMULATE_POLL_WITH_SELECT */
-
-/* gcc for SunOS 4 produces code from an empty (code/symbolwise)
- * source code file that makes the SunOS 4.x /usr/bin/ld fail with
- * ld: poll.o: premature EOF
- * To avoid this, have at least something in here. */
-#if defined(__sun) && !defined(__SVR4) && defined(__GNUC__)
-static int dummy;
-#endif
-
diff --git a/ext/IO/poll.h b/ext/IO/poll.h
deleted file mode 100644
index 634bcddd15..0000000000
--- a/ext/IO/poll.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/*
- * poll.h
- *
- * 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.
- *
- */
-
-#ifndef POLL_H
-# define POLL_H
-
-#if (defined(HAS_POLL) && defined(I_POLL)) || defined(POLLWRBAND)
-# include <poll.h>
-#else
-#ifdef HAS_SELECT
-
-
-/* We shall emulate poll using select */
-
-#define EMULATE_POLL_WITH_SELECT
-
-#ifdef poll
-# undef poll
-#endif
-#define poll Perl_my_poll
-
-typedef struct pollfd {
- int fd;
- short events;
- short revents;
-} pollfd_t;
-
-#define POLLIN 0x0001
-#define POLLPRI 0x0002
-#define POLLOUT 0x0004
-#define POLLRDNORM 0x0040
-#define POLLWRNORM POLLOUT
-#define POLLRDBAND 0x0080
-#define POLLWRBAND 0x0100
-#define POLLNORM POLLRDNORM
-
-/* Return ONLY events (NON testable) */
-
-#define POLLERR 0x0008
-#define POLLHUP 0x0010
-#define POLLNVAL 0x0020
-
-int poll (struct pollfd *, unsigned long, int);
-
-#ifndef HAS_POLL
-# define HAS_POLL
-#endif
-
-#endif /* HAS_SELECT */
-
-#endif /* I_POLL */
-
-#endif /* POLL_H */
-
diff --git a/ext/IO/t/IO.t b/ext/IO/t/IO.t
deleted file mode 100644
index effd414a4c..0000000000
--- a/ext/IO/t/IO.t
+++ /dev/null
@@ -1,127 +0,0 @@
-#!/usr/bin/perl -w
-
-BEGIN {
- if ($ENV{PERL_CORE}) {
- require Config;
- if ($Config::Config{'extensions'} !~ /\bSocket\b/) {
- print "1..0 # Skip: Socket not built - IO.pm uses Socket";
- exit 0;
- }
- }
-}
-
-use strict;
-use File::Path;
-use File::Spec;
-require($ENV{PERL_CORE} ? "../../t/test.pl" : "./t/test.pl");
-plan(tests => 18);
-
-{
- require XSLoader;
-
- my @load;
- local $^W;
- local *XSLoader::load = sub {
- push @load, \@_;
- };
-
- # use_ok() calls import, which we do not want to do
- require_ok( 'IO' );
- ok( @load, 'IO should call XSLoader::load()' );
- is( $load[0][0], 'IO', '... loading the IO library' );
- is( $load[0][1], $IO::VERSION, '... with the current .pm version' );
-}
-
-my @default = map { "IO/$_.pm" } qw( Handle Seekable File Pipe Socket Dir );
-delete @INC{ @default };
-
-my $warn = '' ;
-local $SIG{__WARN__} = sub { $warn = "@_" } ;
-
-{
- no warnings ;
- IO->import();
- is( $warn, '', "... import default, should not warn");
- $warn = '' ;
-}
-
-{
- local $^W = 0;
- IO->import();
- is( $warn, '', "... import default, should not warn");
- $warn = '' ;
-}
-
-{
- local $^W = 1;
- IO->import();
- like( $warn, qr/^Parameterless "use IO" deprecated at/,
- "... import default, should warn");
- $warn = '' ;
-}
-
-{
- use warnings 'deprecated' ;
- IO->import();
- like( $warn, qr/^Parameterless "use IO" deprecated at/,
- "... import default, should warn");
- $warn = '' ;
-}
-
-{
- use warnings ;
- IO->import();
- like( $warn, qr/^Parameterless "use IO" deprecated at/,
- "... import default, should warn");
- $warn = '' ;
-}
-
-foreach my $default (@default)
-{
- ok( exists $INC{ $default }, "... import should default load $default" );
-}
-
-eval { IO->import( 'nothere' ) };
-like( $@, qr/Can.t locate IO.nothere\.pm/, '... croaking on any error' );
-
-my $fakedir = File::Spec->catdir( 'lib', 'IO' );
-my $fakemod = File::Spec->catfile( $fakedir, 'fakemod.pm' );
-
-my $flag;
-if ( -d $fakedir or mkpath( $fakedir ))
-{
- if (open( OUT, ">$fakemod"))
- {
- (my $package = <<' END_HERE') =~ tr/\t//d;
- package IO::fakemod;
-
- sub import { die "Do not import!\n" }
-
- sub exists { 1 }
-
- 1;
- END_HERE
-
- print OUT $package;
- }
-
- if (close OUT)
- {
- $flag = 1;
- push @INC, 'lib';
- }
-}
-
-SKIP:
-{
- skip("Could not write to disk", 2 ) unless $flag;
- eval { IO->import( 'fakemod' ) };
- ok( IO::fakemod::exists(), 'import() should import IO:: modules by name' );
- is( $@, '', '... and should not call import() on imported modules' );
-}
-
-END
-{
- 1 while unlink $fakemod;
- rmdir $fakedir;
-}
diff --git a/ext/IO/t/io_const.t b/ext/IO/t/io_const.t
deleted file mode 100644
index f6f83c1956..0000000000
--- a/ext/IO/t/io_const.t
+++ /dev/null
@@ -1,25 +0,0 @@
-use Config;
-
-BEGIN {
- if($ENV{PERL_CORE}) {
- if ($Config{'extensions'} !~ /\bIO\b/) {
- print "1..0 # Skip: IO extension not compiled\n";
- exit 0;
- }
- }
-}
-
-use IO::Handle;
-
-print "1..6\n";
-my $i = 1;
-foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) {
- my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0;
- my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef;
- my $v2 = IO::Handle::constant($_);
- my $d2 = defined($v2);
-
- print "not "
- if($d1 != $d2 || ($d1 && ($v1 != $v2)));
- print "ok ",$i++,"\n";
-}
diff --git a/ext/IO/t/io_dir.t b/ext/IO/t/io_dir.t
deleted file mode 100644
index 5472daa9b9..0000000000
--- a/ext/IO/t/io_dir.t
+++ /dev/null
@@ -1,73 +0,0 @@
-#!./perl
-
-BEGIN {
- if ($ENV{PERL_CORE}) {
- require Config; import Config;
- if ($] < 5.00326 || not $Config{'d_readdir'}) {
- print "1..0 # Skip: readdir() not available\n";
- exit 0;
- }
- }
-
- require($ENV{PERL_CORE} ? "../../t/test.pl" : "./t/test.pl");
- plan(16);
-
- use_ok('IO::Dir');
- IO::Dir->import(DIR_UNLINK);
-}
-
-use strict;
-
-my $DIR = $^O eq 'MacOS' ? ":" : ".";
-
-my $CLASS = "IO::Dir";
-my $dot = $CLASS->new($DIR);
-ok(defined($dot));
-
-my @a = sort <*>;
-my $first;
-do { $first = $dot->read } while defined($first) && $first =~ /^\./;
-ok(+(grep { $_ eq $first } @a));
-
-my @b = sort($first, (grep {/^[^.]/} $dot->read));
-ok(+(join("\0", @a) eq join("\0", @b)));
-
-ok($dot->rewind,'rewind');
-my @c = sort grep {/^[^.]/} $dot->read;
-ok(+(join("\0", @b) eq join("\0", @c)));
-
-ok($dot->close,'close');
-{ local $^W; # avoid warnings on invalid dirhandle
-ok(!$dot->rewind, "rewind on closed");
-ok(!defined($dot->read));
-}
-
-open(FH,'>X') || die "Can't create x";
-print FH "X";
-close(FH) or die "Can't close: $!";
-
-my %dir;
-tie %dir, $CLASS, $DIR;
-my @files = keys %dir;
-
-# I hope we do not have an empty dir :-)
-ok(scalar @files);
-
-my $stat = $dir{'X'};
-isa_ok($stat,'File::stat');
-ok(defined($stat) && $stat->size == 1);
-
-delete $dir{'X'};
-
-ok(-f 'X');
-
-my %dirx;
-tie %dirx, $CLASS, $DIR, DIR_UNLINK;
-
-my $statx = $dirx{'X'};
-isa_ok($statx,'File::stat');
-ok(defined($statx) && $statx->size == 1);
-
-delete $dirx{'X'};
-
-ok(!(-f 'X'));
diff --git a/ext/IO/t/io_dup.t b/ext/IO/t/io_dup.t
deleted file mode 100644
index 6afc96a272..0000000000
--- a/ext/IO/t/io_dup.t
+++ /dev/null
@@ -1,57 +0,0 @@
-#!./perl
-
-use Config;
-
-BEGIN {
- if($ENV{PERL_CORE}) {
- if ($Config{'extensions'} !~ /\bIO\b/) {
- print "1..0 # Skip: IO extension not compiled\n";
- exit 0;
- }
- }
-}
-
-use IO::Handle;
-use IO::File;
-
-select(STDERR); $| = 1;
-select(STDOUT); $| = 1;
-
-print "1..6\n";
-
-print "ok 1\n";
-
-$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w");
-$duperr = IO::Handle->new->fdopen( \*STDERR ,"w");
-
-$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle";
-$stderr = \*STDERR; bless $stderr, "IO::Handle";
-
-$stdout->open( "Io.dup","w") || die "Can't open stdout";
-$stderr->fdopen($stdout,"w");
-
-print $stdout "ok 2\n";
-print $stderr "ok 3\n";
-
-# Since some systems don't have echo, we use Perl.
-$echo = qq{$^X -le "print q(ok %d)"};
-
-$cmd = sprintf $echo, 4;
-print `$cmd`;
-
-$cmd = sprintf "$echo 1>&2", 5;
-$cmd = sprintf $echo, 5 if $^O eq 'MacOS';
-print `$cmd`;
-
-$stderr->close;
-$stdout->close;
-
-$stdout->fdopen($dupout,"w");
-$stderr->fdopen($duperr,"w");
-
-if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { print `type Io.dup` }
-elsif ($^O eq 'MacOS') { system 'Catenate Io.dup' }
-else { system 'cat Io.dup' }
-unlink 'Io.dup';
-
-print STDOUT "ok 6\n";
diff --git a/ext/IO/t/io_file.t b/ext/IO/t/io_file.t
deleted file mode 100644
index 1cf60f5441..0000000000
--- a/ext/IO/t/io_file.t
+++ /dev/null
@@ -1,48 +0,0 @@
-#!./perl -w
-
-use strict;
-require($ENV{PERL_CORE} ? "../../t/test.pl" : "./t/test.pl");
-plan(tests => ($^O =~ /MSWin32/ ? 9 : 6));
-
-my $Class = 'IO::File';
-my $All_Chars = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r";
-my $File = 'bin.'.$$;
-my $Expect = quotemeta $All_Chars;
-
-use_ok( $Class );
-can_ok( $Class, "binmode" );
-
-### file the file with binary data;
-### use standard open to make sure we can compare binmodes
-### on both.
-{ my $tmp;
- open $tmp, ">$File" or die "Could not open '$File': $!";
- binmode $tmp;
- print $tmp $All_Chars;
- close $tmp;
-}
-
-### now read in the file, once without binmode, once with.
-### without binmode should fail at least on win32...
-if( $^O =~ /MSWin32/ ) {
- my $fh = $Class->new;
-
- isa_ok( $fh, $Class );
- ok( $fh->open($File), " Opened '$File'" );
-
- my $cont = do { local $/; <$fh> };
- unlike( $cont, qr/$Expect/, " Content match fails without binmode" );
-}
-
-### now with binmode, it must pass
-{ my $fh = $Class->new;
-
- isa_ok( $fh, $Class );
- ok( $fh->open($File), " Opened '$File' $!" );
- ok( $fh->binmode, " binmode enabled" );
-
- my $cont = do { local $/; <$fh> };
- like( $cont, qr/$Expect/, " Content match passes with binmode" );
-}
-
-unlink $File;
diff --git a/ext/IO/t/io_linenum.t b/ext/IO/t/io_linenum.t
deleted file mode 100644
index 259f73631a..0000000000
--- a/ext/IO/t/io_linenum.t
+++ /dev/null
@@ -1,73 +0,0 @@
-#!./perl
-
-# test added 29th April 1999 by Paul Johnson (pjcj@transeda.com)
-# updated 28th May 1999 by Paul Johnson
-
-my $File;
-
-BEGIN {
- $File = __FILE__;
- require strict; import strict;
-}
-
-use Test;
-
-BEGIN { plan tests => 12 }
-
-use IO::File;
-
-sub lineno
-{
- my ($f) = @_;
- my $l;
- $l .= "$. ";
- $l .= $f->input_line_number;
- $l .= " $."; # check $. before and after input_line_number
- $l;
-}
-
-my $t;
-
-open (F, $File) or die $!;
-my $io = IO::File->new($File) or die $!;
-
-<F> for (1 .. 10);
-ok(lineno($io), "10 0 10");
-
-$io->getline for (1 .. 5);
-ok(lineno($io), "5 5 5");
-
-<F>;
-ok(lineno($io), "11 5 11");
-
-$io->getline;
-ok(lineno($io), "6 6 6");
-
-$t = tell F; # tell F; provokes a warning
-ok(lineno($io), "11 6 11");
-
-<F>;
-ok(lineno($io), "12 6 12");
-
-select F;
-ok(lineno($io), "12 6 12");
-
-<F> for (1 .. 10);
-ok(lineno($io), "22 6 22");
-
-$io->getline for (1 .. 5);
-ok(lineno($io), "11 11 11");
-
-$t = tell F;
-# We used to have problems here before local $. worked.
-# input_line_number() used to use select and tell. When we did the
-# same, that mechanism broke. It should work now.
-ok(lineno($io), "22 11 22");
-
-{
- local $.;
- $io->getline for (1 .. 5);
- ok(lineno($io), "16 16 16");
-}
-
-ok(lineno($io), "22 16 22");
diff --git a/ext/IO/t/io_multihomed.t b/ext/IO/t/io_multihomed.t
deleted file mode 100644
index f1bd5b9df9..0000000000
--- a/ext/IO/t/io_multihomed.t
+++ /dev/null
@@ -1,118 +0,0 @@
-#!./perl
-
-BEGIN {
- require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
-
- use Config;
- my $can_fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
- $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
- );
- my $reason;
- if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) {
- $reason = 'Socket extension unavailable';
- }
- elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
- $reason = 'IO extension unavailable';
- }
- elsif (!$can_fork) {
- $reason = 'no fork';
- }
- skip_all($reason) if $reason;
-}
-
-$| = 1;
-
-print "1..8\n";
-watchdog(15);
-
-package Multi;
-require IO::Socket::INET;
-@ISA=qw(IO::Socket::INET);
-
-use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in);
-
-sub _get_addr
-{
- my($sock,$addr_str, $multi) = @_;
- #print "_get_addr($sock, $addr_str, $multi)\n";
-
- print "not " unless $multi;
- print "ok 2\n";
-
- (
- # private IP-addresses which I hope does not work anywhere :-)
- inet_aton("10.250.230.10"),
- inet_aton("10.250.230.12"),
- inet_aton("127.0.0.1") # loopback
- )
-}
-
-sub connect
-{
- my $self = shift;
- if (@_ == 1) {
- my($port, $addr) = unpack_sockaddr_in($_[0]);
- $addr = inet_ntoa($addr);
- #print "connect($self, $port, $addr)\n";
- if($addr eq "10.250.230.10") {
- print "ok 3\n";
- return 0;
- }
- if($addr eq "10.250.230.12") {
- print "ok 4\n";
- return 0;
- }
- }
- $self->SUPER::connect(@_);
-}
-
-
-
-package main;
-
-use IO::Socket;
-
-$listen = IO::Socket::INET->new(Listen => 2,
- Proto => 'tcp',
- Timeout => 5,
- ) or die "$!";
-
-print "ok 1\n";
-
-$port = $listen->sockport;
-
-if($pid = fork()) {
-
- $sock = $listen->accept() or die "$!";
- print "ok 5\n";
-
- print $sock->getline();
- print $sock "ok 7\n";
-
- waitpid($pid,0);
-
- $sock->close;
-
- print "ok 8\n";
-
-} elsif(defined $pid) {
-
- $sock = Multi->new(PeerPort => $port,
- Proto => 'tcp',
- PeerAddr => 'localhost',
- MultiHomed => 1,
- Timeout => 1,
- ) or die "$!";
-
- print $sock "ok 6\n";
- sleep(1); # race condition
- print $sock->getline();
-
- $sock->close;
-
- exit;
-} else {
- die;
-}
diff --git a/ext/IO/t/io_pipe.t b/ext/IO/t/io_pipe.t
deleted file mode 100644
index b7897bb2df..0000000000
--- a/ext/IO/t/io_pipe.t
+++ /dev/null
@@ -1,136 +0,0 @@
-#!./perl
-
-my $perl;
-
-BEGIN {
- $perl = $^X;
-}
-
-use Config;
-
-BEGIN {
- my $can_fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
- $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
- );
- my $reason;
- if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
- $reason = 'IO extension unavailable';
- }
- elsif (!$can_fork) {
- $reason = 'no fork';
- }
- elsif ($^O eq 'MSWin32' && !$ENV{TEST_IO_PIPE}) {
- $reason = 'Win32 testing environment not set';
- }
- if ($reason) {
- print "1..0 # Skip: $reason\n";
- exit 0;
- }
-}
-
-use IO::Pipe;
-
-my $is_win32=$^O eq 'MSWin32' ? "MSWin32 has broken pipes" : "";
-
-$| = 1;
-print "1..10\n";
-
-if ($is_win32) {
- print "ok $_ # skipped: $is_win32\n" for 1..4;
-} else {
- $pipe = new IO::Pipe->reader($perl, '-e', 'print qq(not ok 1\n)');
- while (<$pipe>) {
- s/^not //;
- print;
- }
- $pipe->close or print "# \$!=$!\nnot ";
- print "ok 2\n";
- $cmd = 'BEGIN{$SIG{ALRM} = sub {print qq(not ok 4\n); exit}; alarm 10} s/not //';
- $pipe = new IO::Pipe->writer($perl, '-pe', $cmd);
- print $pipe "not ok 3\n" ;
- $pipe->close or print "# \$!=$!\nnot ";
- print "ok 4\n";
-}
-
-# Check if can fork with dynamic extensions (bug in CRT):
-if ($^O eq 'os2' and
- system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
- print "ok $_ # skipped: broken fork\n" for 5..10;
- exit 0;
-}
-
-$pipe = new IO::Pipe;
-
-$pid = fork();
-
-if($pid)
- {
- $pipe->writer;
- print $pipe "Xk 5\n";
- print $pipe "oY 6\n";
- $pipe->close;
- wait;
- }
-elsif(defined $pid)
- {
- $pipe->reader;
- $stdin = bless \*STDIN, "IO::Handle";
- $stdin->fdopen($pipe,"r");
- exec $^X, '-pne', 'tr/YX/ko/';
- }
-else
- {
- die "# error = $!";
- }
-
-if ($is_win32) {
- print "ok $_ # skipped: $is_win32\n" for 7..8;
-} else {
- $pipe = new IO::Pipe;
- $pid = fork();
-
- if($pid)
- {
- $pipe->reader;
- while(<$pipe>) {
- s/^not //;
- print;
- }
- $pipe->close;
- wait;
- }
- elsif(defined $pid)
- {
- $pipe->writer;
-
- $stdout = bless \*STDOUT, "IO::Handle";
- $stdout->fdopen($pipe,"w");
- print STDOUT "not ok 7\n";
- exec 'echo', 'not ok 8';
- }
- else
- {
- die;
- }
-}
-if ($is_win32) {
- print "ok $_ # skipped: $is_win32\n" for 9;
-} else {
- $pipe = new IO::Pipe;
- $pipe->writer;
-
- $SIG{'PIPE'} = 'broken_pipe';
-
- sub broken_pipe {
- print "ok 9\n";
- }
-
- print $pipe "not ok 9\n";
- $pipe->close;
-
- sleep 1;
-}
-print "ok 10\n";
-
diff --git a/ext/IO/t/io_poll.t b/ext/IO/t/io_poll.t
deleted file mode 100644
index 364d346ace..0000000000
--- a/ext/IO/t/io_poll.t
+++ /dev/null
@@ -1,83 +0,0 @@
-#!./perl
-
-if ($^O eq 'mpeix') {
- print "1..0 # Skip: broken on MPE/iX\n";
- exit 0;
-}
-
-select(STDERR); $| = 1;
-select(STDOUT); $| = 1;
-
-print "1..10\n";
-
-use IO::Handle;
-use IO::Poll qw(/POLL/);
-
-my $poll = new IO::Poll;
-
-my $stdout = \*STDOUT;
-my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w");
-
-$poll->mask($stdout => POLLOUT);
-
-print "not "
- unless $poll->mask($stdout) == POLLOUT;
-print "ok 1\n";
-
-$poll->mask($dupout => POLLPRI);
-
-print "not "
- unless $poll->mask($dupout) == POLLPRI;
-print "ok 2\n";
-
-$poll->poll(0.1);
-
-if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O eq 'beos') {
-print "ok 3 # skipped, doesn't work on non-socket fds\n";
-print "ok 4 # skipped, doesn't work on non-socket fds\n";
-}
-else {
-print "not "
- unless $poll->events($stdout) == POLLOUT;
-print "ok 3\n";
-
-print "not "
- if $poll->events($dupout);
-print "ok 4\n";
-}
-
-my @h = $poll->handles;
-print "not "
- unless @h == 2;
-print "ok 5\n";
-
-$poll->remove($stdout);
-
-@h = $poll->handles;
-
-print "not "
- unless @h == 1;
-print "ok 6\n";
-
-print "not "
- if $poll->mask($stdout);
-print "ok 7\n";
-
-$poll->poll(0.1);
-
-print "not "
- if $poll->events($stdout);
-print "ok 8\n";
-
-$poll->remove($dupout);
-print "not "
- if $poll->handles;
-print "ok 9\n";
-
-my $stdin = \*STDIN;
-$poll->mask($stdin => POLLIN);
-$poll->remove($stdin);
-close STDIN;
-print "not "
- if $poll->poll(0.1);
-print "ok 10\n";
diff --git a/ext/IO/t/io_sel.t b/ext/IO/t/io_sel.t
deleted file mode 100644
index 260ca439e7..0000000000
--- a/ext/IO/t/io_sel.t
+++ /dev/null
@@ -1,131 +0,0 @@
-#!./perl -w
-
-select(STDERR); $| = 1;
-select(STDOUT); $| = 1;
-
-print "1..23\n";
-
-use IO::Select 1.09;
-
-my $sel = new IO::Select(\*STDIN);
-$sel->add(4, 5) == 2 or print "not ";
-print "ok 1\n";
-
-$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
-print "ok 2\n";
-
-@handles = $sel->handles;
-print "not " unless $sel->count == 4 && @handles == 4;
-print "ok 3\n";
-#print $sel->as_string, "\n";
-
-$sel->remove(\*STDIN) == 1 or print "not ";
-print "ok 4\n",
-;
-$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present
- or print "not ";
-print "ok 5\n";
-
-print "not " unless $sel->count == 2;
-print "ok 6\n";
-#print $sel->as_string, "\n";
-
-$sel->remove(1, 4);
-print "not " unless $sel->count == 0 && !defined($sel->bits);
-print "ok 7\n";
-
-$sel = new IO::Select;
-print "not " unless $sel->count == 0 && !defined($sel->bits);
-print "ok 8\n";
-
-$sel->remove([\*STDOUT, 5]);
-print "not " unless $sel->count == 0 && !defined($sel->bits);
-print "ok 9\n";
-
-if ( grep $^O eq $_, qw(MSWin32 NetWare dos VMS riscos beos) ) {
- for (10 .. 15) {
- print "ok $_ # skip: 4-arg select is only valid on sockets\n"
- }
- $sel->add(\*STDOUT); # update
- goto POST_SOCKET;
-}
-
-@a = $sel->can_read(); # should return imediately
-print "not " unless @a == 0;
-print "ok 10\n";
-
-# we assume that we can write to STDOUT :-)
-$sel->add([\*STDOUT, "ok 12\n"]);
-
-@a = $sel->can_write;
-print "not " unless @a == 1;
-print "ok 11\n";
-
-my($fd, $msg) = @{shift @a};
-print $fd $msg;
-
-$sel->add(\*STDOUT); # update
-
-@a = IO::Select::select(undef, $sel, undef, 1);
-print "not " unless @a == 3;
-print "ok 13\n";
-
-($r, $w, $e) = @a;
-
-print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
-print "ok 14\n";
-
-$fd = $w->[0];
-print $fd "ok 15\n";
-
-POST_SOCKET:
-# Test new exists() method
-$sel->exists(\*STDIN) and print "not ";
-print "ok 16\n";
-
-($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
-print "ok 17\n";
-
-$fd = $sel->exists(\*STDOUT);
-if ($fd) {
- print $fd "ok 18\n";
-} else {
- print "not ok 18\n";
-}
-
-$fd = $sel->exists([1, 'foo']);
-if ($fd) {
- print $fd "ok 19\n";
-} else {
- print "not ok 19\n";
-}
-
-# Try self clearing
-$sel->add(5,6,7,8,9,10);
-print "not " unless $sel->count == 7;
-print "ok 20\n";
-
-$sel->remove($sel->handles);
-print "not " unless $sel->count == 0 && !defined($sel->bits);
-print "ok 21\n";
-
-# check warnings
-$SIG{__WARN__} = sub {
- ++ $w
- if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ ;
- } ;
-$w = 0 ;
-{
-no warnings 'IO::Select' ;
-IO::Select::has_error();
-}
-print "not " unless $w == 0 ;
-$w = 0 ;
-print "ok 22\n" ;
-{
-use warnings 'IO::Select' ;
-IO::Select::has_error();
-}
-print "not " unless $w == 1 ;
-$w = 0 ;
-print "ok 23\n" ;
diff --git a/ext/IO/t/io_sock.t b/ext/IO/t/io_sock.t
deleted file mode 100644
index 38aefeeb53..0000000000
--- a/ext/IO/t/io_sock.t
+++ /dev/null
@@ -1,396 +0,0 @@
-#!./perl -w
-
-use Config;
-
-BEGIN {
- my $can_fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
- $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
- );
- my $reason;
- if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) {
- $reason = 'Socket extension unavailable';
- }
- elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
- $reason = 'IO extension unavailable';
- }
- elsif (!$can_fork) {
- $reason = 'no fork';
- }
- if ($reason) {
- print "1..0 # Skip: $reason\n";
- exit 0;
- }
-}
-
-my $has_perlio = $] >= 5.008 && find PerlIO::Layer 'perlio';
-
-$| = 1;
-print "1..26\n";
-
-eval {
- $SIG{ALRM} = sub { die; };
- alarm 120;
-};
-
-use IO::Socket;
-
-$listen = IO::Socket::INET->new(Listen => 2,
- Proto => 'tcp',
- # some systems seem to need as much as 10,
- # so be generous with the timeout
- Timeout => 15,
- ) or die "$!";
-
-print "ok 1\n";
-
-# Check if can fork with dynamic extensions (bug in CRT):
-if ($^O eq 'os2' and
- system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
- print "ok $_ # skipped: broken fork\n" for 2..5;
- exit 0;
-}
-
-$port = $listen->sockport;
-
-if($pid = fork()) {
-
- $sock = $listen->accept() or die "accept failed: $!";
- print "ok 2\n";
-
- $sock->autoflush(1);
- print $sock->getline();
-
- print $sock "ok 4\n";
-
- $sock->close;
-
- waitpid($pid,0);
-
- print "ok 5\n";
-
-} elsif(defined $pid) {
-
- $sock = IO::Socket::INET->new(PeerPort => $port,
- Proto => 'tcp',
- PeerAddr => 'localhost'
- )
- || IO::Socket::INET->new(PeerPort => $port,
- Proto => 'tcp',
- PeerAddr => '127.0.0.1'
- )
- or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
-
- $sock->autoflush(1);
-
- print $sock "ok 3\n";
-
- print $sock->getline();
-
- $sock->close;
-
- exit;
-} else {
- die;
-}
-
-# Test various other ways to create INET sockets that should
-# also work.
-$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
-$port = $listen->sockport;
-
-if($pid = fork()) {
- SERVER_LOOP:
- while (1) {
- last SERVER_LOOP unless $sock = $listen->accept;
- while (<$sock>) {
- last SERVER_LOOP if /^quit/;
- last if /^done/;
- print;
- }
- $sock = undef;
- }
- $listen->close;
-} elsif (defined $pid) {
- # child, try various ways to connect
- $sock = IO::Socket::INET->new("localhost:$port")
- || IO::Socket::INET->new("127.0.0.1:$port");
- if ($sock) {
- print "not " unless $sock->connected;
- print "ok 6\n";
- $sock->print("ok 7\n");
- sleep(1);
- print "ok 8\n";
- $sock->print("ok 9\n");
- $sock->print("done\n");
- $sock->close;
- }
- else {
- print "# $@\n";
- print "not ok 6\n";
- print "not ok 7\n";
- print "not ok 8\n";
- print "not ok 9\n";
- }
-
- # some machines seem to suffer from a race condition here
- sleep(2);
-
- $sock = IO::Socket::INET->new("127.0.0.1:$port");
- if ($sock) {
- $sock->print("ok 10\n");
- $sock->print("done\n");
- $sock->close;
- }
- else {
- print "# $@\n";
- print "not ok 10\n";
- }
-
- # some machines seem to suffer from a race condition here
- sleep(1);
-
- $sock = IO::Socket->new(Domain => AF_INET,
- PeerAddr => "localhost:$port")
- || IO::Socket->new(Domain => AF_INET,
- PeerAddr => "127.0.0.1:$port");
- if ($sock) {
- $sock->print("ok 11\n");
- $sock->print("quit\n");
- } else {
- print "not ok 11\n";
- }
- $sock = undef;
- sleep(1);
- exit;
-} else {
- die;
-}
-
-# Then test UDP sockets
-$server = IO::Socket->new(Domain => AF_INET,
- Proto => 'udp',
- LocalAddr => 'localhost')
- || IO::Socket->new(Domain => AF_INET,
- Proto => 'udp',
- LocalAddr => '127.0.0.1');
-$port = $server->sockport;
-
-if ($pid = fork()) {
- my $buf;
- $server->recv($buf, 100);
- print $buf;
-} elsif (defined($pid)) {
- #child
- $sock = IO::Socket::INET->new(Proto => 'udp',
- PeerAddr => "localhost:$port")
- || IO::Socket::INET->new(Proto => 'udp',
- PeerAddr => "127.0.0.1:$port");
- $sock->send("ok 12\n");
- sleep(1);
- $sock->send("ok 12\n"); # send another one to be sure
- exit;
-} else {
- die;
-}
-
-print "not " unless $server->blocking;
-print "ok 13\n";
-
-if ( $^O eq 'qnx' ) {
- # QNX4 library bug: Can set non-blocking on socket, but
- # cannot return that status.
- print "ok 14 # skipped on QNX4\n";
-} else {
- $server->blocking(0);
- print "not " if $server->blocking;
- print "ok 14\n";
-}
-
-### TEST 15
-### Set up some data to be transfered between the server and
-### the client. We'll use own source code ...
-#
-local @data;
-if( !open( SRC, "< $0")) {
- print "not ok 15 - $!\n";
-} else {
- @data = <SRC>;
- close(SRC);
- print "ok 15\n";
-}
-
-### TEST 16
-### Start the server
-#
-my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
- print "not ";
-print "ok 16\n";
-die if( !defined( $listen));
-my $serverport = $listen->sockport;
-my $server_pid = fork();
-if( $server_pid) {
-
- ### TEST 17 Client/Server establishment
- #
- print "ok 17\n";
-
- ### TEST 18
- ### Get data from the server using a single stream
- #
- $sock = IO::Socket::INET->new("localhost:$serverport")
- || IO::Socket::INET->new("127.0.0.1:$serverport");
-
- if ($sock) {
- $sock->print("send\n");
-
- my @array = ();
- while( <$sock>) {
- push( @array, $_);
- }
-
- $sock->print("done\n");
- $sock->close;
-
- print "not " if( @array != @data);
- } else {
- print "not ";
- }
- print "ok 18\n";
-
- ### TEST 21
- ### Get data from the server using a stream, which is
- ### interrupted by eof calls.
- ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
- ### did an getc followed by an ungetc in order to check for the streams
- ### end. getc(3) got replaced by the SOCKS funktion, which ended up in
- ### a recv(2) call on the socket, while ungetc(3) put back a character
- ### to an IO buffer, which never again was read.
- #
- ### TESTS 19,20,21,22
- ### Try to ping-pong some Unicode.
- #
- $sock = IO::Socket::INET->new("localhost:$serverport")
- || IO::Socket::INET->new("127.0.0.1:$serverport");
-
- if ($has_perlio) {
- print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n";
- } else {
- print "ok 19 - Skip: no perlio\n";
- }
-
- if ($sock) {
-
- if ($has_perlio) {
- $sock->print("ping \x{100}\n");
- chomp(my $pong = scalar <$sock>);
- print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
- "ok 20\n" : "not ok 20\n";
-
- $sock->print("ord \x{100}\n");
- chomp(my $ord = scalar <$sock>);
- print $ord == 0x100 ?
- "ok 21\n" : "not ok 21\n";
-
- $sock->print("chr 0x100\n");
- chomp(my $chr = scalar <$sock>);
- print $chr eq "\x{100}" ?
- "ok 22\n" : "not ok 22\n";
- } else {
- print "ok $_ - Skip: no perlio\n" for 20..22;
- }
-
- $sock->print("send\n");
-
- my @array = ();
- while( !eof( $sock ) ){
- while( <$sock>) {
- push( @array, $_);
- last;
- }
- }
-
- $sock->print("done\n");
- $sock->close;
-
- print "not " if( @array != @data);
- } else {
- print "not ";
- }
- print "ok 23\n";
-
- ### TEST 24
- ### Stop the server
- #
- $sock = IO::Socket::INET->new("localhost:$serverport")
- || IO::Socket::INET->new("127.0.0.1:$serverport");
-
- if ($sock) {
- $sock->print("done\n");
- $sock->close;
-
- print "not " if( 1 != kill 0, $server_pid);
- } else {
- print "not ";
- }
- print "ok 24\n";
-
-} elsif (defined($server_pid)) {
-
- ### Child
- #
- SERVER_LOOP: while (1) {
- last SERVER_LOOP unless $sock = $listen->accept;
- # Do not print ok/not ok for this binmode() since there's
- # a race condition with our client, just die if we fail.
- if ($has_perlio) { binmode($sock, ":utf8") or die }
- while (<$sock>) {
- last SERVER_LOOP if /^quit/;
- last if /^done/;
- if (/^ping (.+)/) {
- print $sock "pong $1\n";
- next;
- }
- if (/^ord (.+)/) {
- print $sock ord($1), "\n";
- next;
- }
- if (/^chr (.+)/) {
- print $sock chr(hex($1)), "\n";
- next;
- }
- if (/^send/) {
- print $sock @data;
- last;
- }
- print;
- }
- $sock = undef;
- }
- $listen->close;
- exit 0;
-
-} else {
-
- ### Fork failed
- #
- print "not ok 17\n";
- die;
-}
-
-# test Blocking option in constructor
-
-$sock = IO::Socket::INET->new(Blocking => 0)
- or print "not ";
-print "ok 25\n";
-
-if ( $^O eq 'qnx' ) {
- print "ok 26 # skipped on QNX4\n";
- # QNX4 library bug: Can set non-blocking on socket, but
- # cannot return that status.
-} else {
- my $status = $sock->blocking;
- print "not " unless defined $status && !$status;
- print "ok 26\n";
-}
diff --git a/ext/IO/t/io_taint.t b/ext/IO/t/io_taint.t
deleted file mode 100644
index 3cbe30345f..0000000000
--- a/ext/IO/t/io_taint.t
+++ /dev/null
@@ -1,62 +0,0 @@
-#!./perl -T
-
-use Config;
-
-BEGIN {
- if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
- print "1..0\n";
- exit 0;
- }
-}
-
-use strict;
-if ($ENV{PERL_CORE}) {
- require("../../t/test.pl");
-}
-else {
- require("./t/test.pl");
-}
-plan(tests => 5);
-
-END { unlink "./__taint__$$" }
-
-use IO::File;
-my $x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n");
-print $x "$$\n";
-$x->close;
-
-$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
-chop(my $unsafe = <$x>);
-eval { kill 0 * $unsafe };
-SKIP: {
- skip($^O) if $^O eq 'MSWin32' or $^O eq 'NetWare';
- like($@, '^Insecure');
-}
-$x->close;
-
-# We could have just done a seek on $x, but technically we haven't tested
-# seek yet...
-$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
-$x->untaint;
-ok(!$?); # Calling the method worked
-chop($unsafe = <$x>);
-eval { kill 0 * $unsafe };
-unlike($@,'^Insecure');
-$x->close;
-
-TODO: {
- todo_skip("Known bug in 5.10.0",2) if $] >= 5.010 and $] < 5.010_001;
-
- # this will segfault if it fails
-
- sub PVBM () { 'foo' }
- { my $dummy = index 'foo', PVBM }
-
- eval { IO::Handle::untaint(PVBM) };
- pass();
-
- eval { IO::Handle::untaint(\PVBM) };
- pass();
-}
-
-exit 0;
diff --git a/ext/IO/t/io_tell.t b/ext/IO/t/io_tell.t
deleted file mode 100644
index 3f8ad30b9f..0000000000
--- a/ext/IO/t/io_tell.t
+++ /dev/null
@@ -1,55 +0,0 @@
-#!./perl
-
-BEGIN {
- $tell_file = "Makefile.PL";
-}
-
-use Config;
-
-BEGIN {
- if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
- print "1..0\n";
- exit 0;
- }
-}
-
-print "1..13\n";
-
-use IO::File;
-
-$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
-binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos');
-if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
-
-$firstline = <$tst>;
-$secondpos = tell;
-
-$x = 0;
-while (<$tst>) {
- if (eof) {$x++;}
-}
-if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
-
-$lastpos = tell;
-
-unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
-
-if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
-
-if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
-
-if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
-
-if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
-
-if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
-
-if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; }
-
-if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
-
-if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
-
-if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
-
-unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
diff --git a/ext/IO/t/io_udp.t b/ext/IO/t/io_udp.t
deleted file mode 100644
index 6b139dd83f..0000000000
--- a/ext/IO/t/io_udp.t
+++ /dev/null
@@ -1,79 +0,0 @@
-#!./perl
-
-BEGIN {
- require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
-
- use Config;
- my $reason;
- if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) {
- $reason = 'Socket was not built';
- }
- elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
- $reason = 'IO was not built';
- }
- elsif ($^O eq 'apollo') {
- $reason = "unknown *FIXME*";
- }
- undef $reason if $^O eq 'VMS' and $Config{d_socket};
- skip_all($reason) if $reason;
-}
-
-sub compare_addr {
- no utf8;
- my $a = shift;
- my $b = shift;
- if (length($a) != length $b) {
- my $min = (length($a) < length $b) ? length($a) : length $b;
- if ($min and substr($a, 0, $min) eq substr($b, 0, $min)) {
- printf "# Apparently: %d bytes junk at the end of %s\n# %s\n",
- abs(length($a) - length ($b)),
- $_[length($a) < length ($b) ? 1 : 0],
- "consider decreasing bufsize of recfrom.";
- substr($a, $min) = "";
- substr($b, $min) = "";
- }
- return 0;
- }
- my @a = unpack_sockaddr_in($a);
- my @b = unpack_sockaddr_in($b);
- "$a[0]$a[1]" eq "$b[0]$b[1]";
-}
-
-plan(7);
-watchdog(15);
-
-use Socket;
-use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
-
-$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
- || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
- or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
-ok(1);
-
-$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
- || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
- or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
-ok(1);
-
-$udpa->send('BORK', 0, $udpb->sockname);
-
-ok(compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'));
-
-my $where = $udpb->recv($buf="", 4);
-is($buf, 'BORK');
-
-my @xtra = ();
-
-if (! ok(compare_addr($where,$udpa->sockname, 'recv name', 'sockname'))) {
- @xtra = (0, $udpa->sockname);
-}
-
-$udpb->send('FOObar', @xtra);
-$udpa->recv($buf="", 6);
-is($buf, 'FOObar');
-
-ok(! $udpa->connected);
-
-exit(0);
-
-# EOF
diff --git a/ext/IO/t/io_unix.t b/ext/IO/t/io_unix.t
deleted file mode 100644
index 61ba3635f8..0000000000
--- a/ext/IO/t/io_unix.t
+++ /dev/null
@@ -1,113 +0,0 @@
-#!./perl
-
-use Config;
-
-BEGIN {
- my $reason;
- if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) {
- $reason = 'Socket extension unavailable';
- }
- elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) {
- $reason = 'IO extension unavailable';
- }
- elsif ($^O eq 'os2') {
- require IO::Socket;
-
- eval {IO::Socket::pack_sockaddr_un('/foo/bar') || 1}
- or $@ !~ /not implemented/ or
- $reason = 'compiled without TCP/IP stack v4';
- }
- elsif ($^O =~ m/^(?:qnx|nto|vos|MSWin32)$/ ) {
- $reason = "UNIX domain sockets not implemented on $^O";
- }
- elsif (! $Config{'d_fork'}) {
- $reason = 'no fork';
- }
- if ($reason) {
- print "1..0 # Skip: $reason\n";
- exit 0;
- }
-}
-
-$PATH = "sock-$$";
-
-if ($^O eq 'os2') { # Can't create sockets with relative path...
- require Cwd;
- my $d = Cwd::cwd();
- $d =~ s/^[a-z]://i;
- $PATH = "$d/$PATH";
-}
-
-# Test if we can create the file within the tmp directory
-if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') {
- print "1..0 # Skip: cannot open '$PATH' for write\n";
- exit 0;
-}
-close(TEST);
-unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!";
-
-# Start testing
-$| = 1;
-print "1..5\n";
-
-use IO::Socket;
-
-$listen = IO::Socket::UNIX->new(Local => $PATH, Listen => 0);
-
-# Sometimes UNIX filesystems are mounted for security reasons
-# with "nodev" option which spells out "no" for creating UNIX
-# local sockets. Therefore we will retry with a File::Temp
-# generated filename from a temp directory.
-unless (defined $listen) {
- eval { require File::Temp };
- unless ($@) {
- import File::Temp 'mktemp';
- for my $TMPDIR ($ENV{TMPDIR}, "/tmp") {
- if (defined $TMPDIR && -d $TMPDIR && -w $TMPDIR) {
- $PATH = mktemp("$TMPDIR/sXXXXXXXX");
- last if $listen = IO::Socket::UNIX->new(Local => $PATH,
- Listen => 0);
- }
- }
- }
- defined $listen or die "$PATH: $!";
-}
-print "ok 1\n";
-
-if($pid = fork()) {
-
- $sock = $listen->accept();
-
- if (defined $sock) {
- print "ok 2\n";
-
- print $sock->getline();
-
- print $sock "ok 4\n";
-
- $sock->close;
-
- waitpid($pid,0);
- unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!";
-
- print "ok 5\n";
- } else {
- print "# accept() failed: $!\n";
- for (2..5) {
- print "not ok $_ # accept failed\n";
- }
- }
-} elsif(defined $pid) {
-
- $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!";
-
- print $sock "ok 3\n";
-
- print $sock->getline();
-
- $sock->close;
-
- exit;
-} else {
- die;
-}
diff --git a/ext/IO/t/io_utf8.t b/ext/IO/t/io_utf8.t
deleted file mode 100644
index 53c209d4b8..0000000000
--- a/ext/IO/t/io_utf8.t
+++ /dev/null
@@ -1,31 +0,0 @@
-#!./perl
-
-BEGIN {
- unless ($] >= 5.008 and find PerlIO::Layer 'perlio') {
- print "1..0 # Skip: not perlio\n";
- exit 0;
- }
-}
-
-require($ENV{PERL_CORE} ? "../../t/test.pl" : "./t/test.pl");
-
-plan(tests => 5);
-
-my $io;
-
-use_ok('IO::File');
-
-$io = IO::File->new;
-
-ok($io->open("io_utf8", ">:utf8"), "open >:utf8");
-ok((print $io chr(256)), "print chr(256)");
-undef $io;
-
-$io = IO::File->new;
-ok($io->open("io_utf8", "<:utf8"), "open <:utf8");
-is(ord(<$io>), 256, "readline chr(256)");
-undef $io;
-
-END {
- 1 while unlink "io_utf8";
-}
diff --git a/ext/IO/t/io_xs.t b/ext/IO/t/io_xs.t
deleted file mode 100644
index 585eed84b2..0000000000
--- a/ext/IO/t/io_xs.t
+++ /dev/null
@@ -1,40 +0,0 @@
-#!./perl
-
-use Config;
-
-BEGIN {
- if($ENV{PERL_CORE}) {
- if ($Config{'extensions'} !~ /\bIO\b/) {
- print "1..0 # Skip: IO extension not built\n";
- exit 0;
- }
- }
- if( $^O eq 'VMS' && $Config{'vms_cc_type'} ne 'decc' ) {
- print "1..0 # Skip: not compatible with the VAXCRTL\n";
- exit 0;
- }
-}
-
-use IO::File;
-use IO::Seekable;
-
-print "1..4\n";
-
-$x = new_tmpfile IO::File or print "not ";
-print "ok 1\n";
-print $x "ok 2\n";
-$x->seek(0,SEEK_SET);
-print <$x>;
-
-$x->seek(0,SEEK_SET);
-print $x "not ok 3\n";
-$p = $x->getpos;
-print $x "ok 3\n";
-$x->flush;
-$x->setpos($p);
-print scalar <$x>;
-
-$! = 0;
-$x->setpos(undef);
-print $! ? "ok 4 # $!\n" : "not ok 4\n";
-