diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-09-28 14:58:16 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-09-29 11:12:37 +0100 |
commit | 725607636edc598ad6823e49789420d734f8aa28 (patch) | |
tree | 2e6a93cdd6c65e8412bf874507a63c8ac8f14a71 /ext | |
parent | 8b2306352e674fdd7eb8b61ff2ce78864a87ed9c (diff) | |
download | perl-725607636edc598ad6823e49789420d734f8aa28.tar.gz |
Move IO from ext/ to dist/
Diffstat (limited to 'ext')
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"; - |