From 725607636edc598ad6823e49789420d734f8aa28 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Mon, 28 Sep 2009 14:58:16 +0100 Subject: Move IO from ext/ to dist/ --- dist/IO/.gitignore | 1 + dist/IO/ChangeLog | 364 ++++++++++++++++++++++++ dist/IO/IO.pm | 68 +++++ dist/IO/IO.xs | 541 +++++++++++++++++++++++++++++++++++ dist/IO/Makefile.PL | 45 +++ dist/IO/README | 27 ++ dist/IO/hints/sco.pl | 2 + dist/IO/lib/IO/Dir.pm | 248 +++++++++++++++++ dist/IO/lib/IO/File.pm | 204 ++++++++++++++ dist/IO/lib/IO/Handle.pm | 635 ++++++++++++++++++++++++++++++++++++++++++ dist/IO/lib/IO/Pipe.pm | 257 +++++++++++++++++ dist/IO/lib/IO/Poll.pm | 209 ++++++++++++++ dist/IO/lib/IO/Seekable.pm | 128 +++++++++ dist/IO/lib/IO/Select.pm | 381 +++++++++++++++++++++++++ dist/IO/lib/IO/Socket.pm | 530 +++++++++++++++++++++++++++++++++++ dist/IO/lib/IO/Socket/INET.pm | 464 ++++++++++++++++++++++++++++++ dist/IO/lib/IO/Socket/UNIX.pm | 143 ++++++++++ dist/IO/poll.c | 146 ++++++++++ dist/IO/poll.h | 60 ++++ dist/IO/t/IO.t | 127 +++++++++ dist/IO/t/io_const.t | 25 ++ dist/IO/t/io_dir.t | 73 +++++ dist/IO/t/io_dup.t | 57 ++++ dist/IO/t/io_file.t | 48 ++++ dist/IO/t/io_linenum.t | 73 +++++ dist/IO/t/io_multihomed.t | 118 ++++++++ dist/IO/t/io_pipe.t | 136 +++++++++ dist/IO/t/io_poll.t | 83 ++++++ dist/IO/t/io_sel.t | 131 +++++++++ dist/IO/t/io_sock.t | 396 ++++++++++++++++++++++++++ dist/IO/t/io_taint.t | 62 +++++ dist/IO/t/io_tell.t | 55 ++++ dist/IO/t/io_udp.t | 79 ++++++ dist/IO/t/io_unix.t | 113 ++++++++ dist/IO/t/io_utf8.t | 31 +++ dist/IO/t/io_xs.t | 40 +++ 36 files changed, 6100 insertions(+) create mode 100644 dist/IO/.gitignore create mode 100644 dist/IO/ChangeLog create mode 100644 dist/IO/IO.pm create mode 100644 dist/IO/IO.xs create mode 100644 dist/IO/Makefile.PL create mode 100644 dist/IO/README create mode 100644 dist/IO/hints/sco.pl create mode 100644 dist/IO/lib/IO/Dir.pm create mode 100644 dist/IO/lib/IO/File.pm create mode 100644 dist/IO/lib/IO/Handle.pm create mode 100644 dist/IO/lib/IO/Pipe.pm create mode 100644 dist/IO/lib/IO/Poll.pm create mode 100644 dist/IO/lib/IO/Seekable.pm create mode 100644 dist/IO/lib/IO/Select.pm create mode 100644 dist/IO/lib/IO/Socket.pm create mode 100644 dist/IO/lib/IO/Socket/INET.pm create mode 100644 dist/IO/lib/IO/Socket/UNIX.pm create mode 100644 dist/IO/poll.c create mode 100644 dist/IO/poll.h create mode 100644 dist/IO/t/IO.t create mode 100644 dist/IO/t/io_const.t create mode 100644 dist/IO/t/io_dir.t create mode 100644 dist/IO/t/io_dup.t create mode 100644 dist/IO/t/io_file.t create mode 100644 dist/IO/t/io_linenum.t create mode 100644 dist/IO/t/io_multihomed.t create mode 100644 dist/IO/t/io_pipe.t create mode 100644 dist/IO/t/io_poll.t create mode 100644 dist/IO/t/io_sel.t create mode 100644 dist/IO/t/io_sock.t create mode 100644 dist/IO/t/io_taint.t create mode 100644 dist/IO/t/io_tell.t create mode 100644 dist/IO/t/io_udp.t create mode 100644 dist/IO/t/io_unix.t create mode 100644 dist/IO/t/io_utf8.t create mode 100644 dist/IO/t/io_xs.t (limited to 'dist/IO') diff --git a/dist/IO/.gitignore b/dist/IO/.gitignore new file mode 100644 index 0000000000..577c726243 --- /dev/null +++ b/dist/IO/.gitignore @@ -0,0 +1 @@ +!/poll.c diff --git a/dist/IO/ChangeLog b/dist/IO/ChangeLog new file mode 100644 index 0000000000..6913c646e1 --- /dev/null +++ b/dist/IO/ChangeLog @@ -0,0 +1,364 @@ +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 (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 (Graham Barr) + + IO::Socket::INET + - Added checks to all peer* and host* methods for undef + +Change 134 on 1998/05/09 by (Graham Barr) + + t/io_sock.t + - fix race condition on Solaris & SunOS + + IO::Handle + - Applied patch from Gisle Aas for + documentation update + - Applied patch from Kuma + changed input_line_number to be on a per-handle basis. + + IO::File + - Applied patch from Gisle Aas for + documentation update + + IO::Seekable + - Applied patch from Gisle Aas for + documentation update + added sysseek + + IO, IO::Socket::INET + - documentation update + + IO.xs + - Applied patch from Gisle Aas for + blocking + +Change 133 on 1998/05/09 by (Graham Barr) + + t/io_sock.t + - Added checks for blocking() + +Sun Apr 12 1998 (Graham Barr) + + IO.xs + - enclosed newCONSTSUB in #ifdef as _64 now defines it. + +Thu Mar 19 1998 (Graham Barr) + + All + - Changed copyright/distribution policy back to be the same as perl + +Sun Feb 15 1998 (Graham Barr) + + IO::Socket + - Fix to ->accept, accept() returns false on error not undef. + +*** Release 1.19 + +Thu Feb 5 1998 (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 (Graham Barr) + + IO::Handle + - Added printflush so that flush.pl can be depreciated + + IO::Socket + - Remove C statement as it was not needed + +Tue Jan 27 1998 (Graham Barr) + + IO::Socket::INET + - removed carp if $^W + +*** Patch 1.1804 + +Sat Jan 17 1998 (Graham Barr) + + t/io_sock.t + - Replaced C 0> with C 'localhost'> + + IO/Socket/INET.pm + - Modified the MultiHomed code. Now each address for a given host has + a timeout of C. + - 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 (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 + + IO::Socket::INET + - Change default proto to getprotobyname instead of 'tcp' constant string + - Added patch for multi-homed hosts, Thanks to Gisle Aas + + t/io_sock.t + - Change to test fix for Domain problem fixed in IO::Socket and be + more comprehensive, Thanks to Gisle Aas + + t/io_unix.t + - New test, Thanks to Gisle Aas + +*** Patch 1.1802 + +Wed Nov 12 1997 (Graham Barr) + + t/io_poll.t + - test 4 made an assumption that was not portable, fixed. + +*** Patch 1.1801 + +Wed Oct 22 1997 (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 (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 (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 (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 and define I_POLL if found + +*** Release 1.17 + +Fri Sep 26 1997 (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 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 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 Graham Barr + + o Updated to patches in perl core dist. + o Added C 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 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 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 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 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 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/dist/IO/IO.pm b/dist/IO/IO.pm new file mode 100644 index 0000000000..a72e2243d7 --- /dev/null +++ b/dist/IO/IO.pm @@ -0,0 +1,68 @@ +# + +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 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/dist/IO/IO.xs b/dist/IO/IO.xs new file mode 100644 index 0000000000..d3dff557a2 --- /dev/null +++ b/dist/IO/IO.xs @@ -0,0 +1,541 @@ +/* + * Copyright (c) 1997-8 Graham Barr . 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 +#endif +#if defined(I_FCNTL) || defined(HAS_FCNTL) +# include +#endif + +#ifndef SIOCATMARK +# ifdef I_SYS_SOCKIO +# include +# 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/dist/IO/Makefile.PL b/dist/IO/Makefile.PL new file mode 100644 index 0000000000..2159f43e49 --- /dev/null +++ b/dist/IO/Makefile.PL @@ -0,0 +1,45 @@ +# 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 + +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 ', + ( $PERL_CORE + ? () + : ( + INSTALLDIRS => 'perl', + clean => {FILES => 'typemap'}, + ) + ), + ($define ? (DEFINE => $define) : ()), + ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? ('LICENSE' => 'perl') : ()), +); diff --git a/dist/IO/README b/dist/IO/README new file mode 100644 index 0000000000..e4d9dfad55 --- /dev/null +++ b/dist/IO/README @@ -0,0 +1,27 @@ +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 + diff --git a/dist/IO/hints/sco.pl b/dist/IO/hints/sco.pl new file mode 100644 index 0000000000..ddcf1551d1 --- /dev/null +++ b/dist/IO/hints/sco.pl @@ -0,0 +1,2 @@ +# SCO OSR5 needs to link with libc.so again to have C defined +$self->{LIBS} = ['-lc']; diff --git a/dist/IO/lib/IO/Dir.pm b/dist/IO/lib/IO/Dir.pm new file mode 100644 index 0000000000..cce392c2ce --- /dev/null +++ b/dist/IO/lib/IO/Dir.pm @@ -0,0 +1,248 @@ +# IO::Dir.pm +# +# Copyright (c) 1997-8 Graham Barr . 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 package provides two interfaces to perl's directory reading +routines. + +The first interface is an object approach. C provides an object +constructor and methods, which are just wrappers around perl's built in +directory reading routines. + +=over 4 + +=item new ( [ DIRNAME ] ) + +C is the constructor for C objects. It accepts one optional +argument which, if given, C will pass to C + +=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 +for details of these functions. + +=over 4 + +=item open ( DIRNAME ) + +=item read () + +=item seek ( POS ) + +=item tell () + +=item rewind () + +=item close () + +=back + +C 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, from the C package, +C, C and C. + +=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. Deleting an element from the hash will +delete the corresponding file or subdirectory, +provided that C is included in the C. + +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 + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to . + +=head1 COPYRIGHT + +Copyright (c) 1997-2003 Graham Barr . 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/dist/IO/lib/IO/File.pm b/dist/IO/lib/IO/File.pm new file mode 100644 index 0000000000..d33d090d0b --- /dev/null +++ b/dist/IO/lib/IO/File.pm @@ -0,0 +1,204 @@ +# + +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 inherits from C and C. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( FILENAME [,MODE [,PERMS]] ) + +Creates an C. If it receives any parameters, they are passed to +the method C; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C 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 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 accepts one, two or three parameters. With one parameter, +it is just a front end for the built-in C 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 receives a Perl mode string ("E", "+E", etc.) +or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C operator (but protects any special characters). + +If C is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C operator. +The permissions default to 0666. + +If C is given a mode that includes the C<:> character, +it passes all the three arguments to the three-argument C operator. + +For convenience, C exports the O_XXX constants from the +Fcntl module, if this module is available. + +=item binmode( [LAYER] ) + +C sets C on the underlying C object, as documented +in C. + +C accepts one optional parameter, which is the layer to be +passed on to the C call. + +=back + +=head1 NOTE + +Some operating systems may perform C or C +on a directory without errors. This behavior is not portable and not +suggested for use. Using C and C or C are +suggested instead. + +=head1 SEE ALSO + +L, +L, +L, +L, +L + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr EFE. + +=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/dist/IO/lib/IO/Handle.pm b/dist/IO/lib/IO/Handle.pm new file mode 100644 index 0000000000..2f1f1b423b --- /dev/null +++ b/dist/IO/lib/IO/Handle.pm @@ -0,0 +1,635 @@ +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 is the base class for all other IO handle classes. It is +not intended that objects of C would be created directly, +but instead C is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C package, then I suggest you read the documentation +for C too. + +=head1 CONSTRUCTOR + +=over 4 + +=item new () + +Creates a new C object. + +=item new_from_fd ( FD, MODE ) + +Creates an C like C does. +It requires two parameters, which are passed to the method C; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L for complete descriptions of each of the following +supported C 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 for complete descriptions of each of the following +supported C 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 is like an ordinary C 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 +method, see L.) + +=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 +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 or C-style C 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 is like C found in C, that is it is the +opposite of read. The wrapper for the perl C function is +called C. + +=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, 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 synchronizes a file's in-memory state with that on the +physical medium. C 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 is not implemented on all +platforms. Returns "0 but true" on success, C on error, C +for an invalid handle. See L. + +=item $io->flush + +C 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 on error. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C object. Returns the return value from print. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C will turn on non-blocking IO if +C is false, and turn it off if C is true. + +C will return the value of the previous setting, or the +current setting if C is not given. + +If an error occurs C will return undef and C<$!> will be set. + +=back + + +If the C functions setbuf() and/or setvbuf() are available, then +C and C 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 or C B in any way until the IO::Handle is closed or C or +C 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 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 object is a reference to a symbol/GLOB reference (see +the C package). Some modules that +inherit from C 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 variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L, +L, +L + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr EFE + +=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/^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/dist/IO/lib/IO/Pipe.pm b/dist/IO/lib/IO/Pipe.pm new file mode 100644 index 0000000000..827cc48bfc --- /dev/null +++ b/dist/IO/lib/IO/Pipe.pm @@ -0,0 +1,257 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996-8 Graham Barr . 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 provides an interface to creating pipes between +processes. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates an C, which is a reference to a newly created symbol +(see the C package). C optionally takes two +arguments, which should be objects blessed into C, or a +subclass thereof. These two objects will be used for the system call +to C. If no arguments are given then method C is called +on the new C object. + +These two handles are held in the array part of the GLOB until either +C or C is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the reading end of the pipe. If C are given then C +is called and C are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the writing end of the pipe. If C are given then C +is called and C are passed to exec. + +=item handles () + +This method is called during construction by C +on the newly created C object. It returns an array of two objects +blessed into C, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to . + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr . 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/dist/IO/lib/IO/Poll.pm b/dist/IO/lib/IO/Poll.pm new file mode 100644 index 0000000000..e7fb013506 --- /dev/null +++ b/dist/IO/lib/IO/Poll.pm @@ -0,0 +1,209 @@ + +# IO::Poll.pm +# +# Copyright (c) 1997-8 Graham Barr . 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 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. + +=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 + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to . + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr . 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/dist/IO/lib/IO/Seekable.pm b/dist/IO/lib/IO/Seekable.pm new file mode 100644 index 0000000000..db1effda28 --- /dev/null +++ b/dist/IO/lib/IO/Seekable.pm @@ -0,0 +1,128 @@ +# + +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 does not have a constructor of its own as it is intended to +be inherited by other C 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 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 on failure. + +=back + +See L for complete descriptions of each of the following +supported C 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 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 for full details) + +Returns the new position, or C 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, +L, +L +L + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr Egbarr@pobox.comE + +=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 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/dist/IO/lib/IO/Select.pm b/dist/IO/lib/IO/Select.pm new file mode 100644 index 0000000000..fc05fe70e9 --- /dev/null +++ b/dist/IO/lib/IO/Select.pm @@ -0,0 +1,381 @@ +# IO::Select.pm +# +# Copyright (c) 1997-8 Graham Barr . 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 package implements an object approach to the system C static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] ) + +C