ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
ext/GDBM_File/typemap GDBM extension interface types
+ext/IO/ChangeLog IO perl module change log
ext/IO/IO.pm Top-level interface to IO::* classes
ext/IO/IO.xs IO extension external subroutines
ext/IO/Makefile.PL IO extension makefile writer
ext/IO/README IO extension maintenance notice
-ext/IO/lib/IO/File.pm IO::File extension Perl module
-ext/IO/lib/IO/Handle.pm IO::Handle extension Perl module
-ext/IO/lib/IO/Pipe.pm IO::Pipe extension Perl module
-ext/IO/lib/IO/Seekable.pm IO::Seekable extension Perl module
-ext/IO/lib/IO/Select.pm IO::Select extension Perl module
-ext/IO/lib/IO/Socket.pm IO::Socket extension Perl module
+ext/IO/lib/IO/Dir.pm IO directory reading package
+ext/IO/lib/IO/File.pm IO file handle package
+ext/IO/lib/IO/Handle.pm IO base handle package
+ext/IO/lib/IO/Pipe.pm IO pipe package
+ext/IO/lib/IO/Poll.pm IO system poll() interface
+ext/IO/lib/IO/Seekable.pm IO methods for seekable handles
+ext/IO/lib/IO/Select.pm IO system select() interface
+ext/IO/lib/IO/Socket.pm IO socket handle package
+ext/IO/lib/IO/Socket/INET.pm IO INET specific socket methods
+ext/IO/lib/IO/Socket/UNIX.pm IO UNIX specific socket methods
ext/IPC/SysV/ChangeLog IPC::SysV extension Perl module
ext/IPC/SysV/hints/next_3.pl Hint for IPC::SysV for named architecture
ext/IPC/SysV/MANIFEST IPC::SysV extension Perl module
t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison
t/lib/h2ph.t See if h2ph works like it should
t/lib/hostname.t See if Sys::Hostname works
+t/lib/io_const.t See if constants from IO work
+t/lib/io_dir.t See if directory-related methods from IO work
t/lib/io_dup.t See if dup()-related methods from IO work
+t/lib/io_multihomed.t See if INET sockets work with multi-homed hosts
t/lib/io_pipe.t See if pipe()-related methods from IO work
+t/lib/io_poll.t See if poll()-related methods from IO work
t/lib/io_sel.t See if select()-related methods from IO work
t/lib/io_sock.t See if INET socket-related methods from IO work
t/lib/io_taint.t See if the untaint method from IO works
t/lib/io_tell.t See if seek()/tell()-related methods from IO work
t/lib/io_udp.t See if UDP socket-related methods from IO work
+t/lib/io_unix.t See if UNIX socket-related methods from IO work
t/lib/io_xs.t See if XSUB methods from IO work
t/lib/ipc_sysv.t See if IPC::SysV works
t/lib/ndbm.t See if NDBM_File works
--- /dev/null
+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.
package IO;
+require DynaLoader;
+require Exporter;
+use Carp;
+
+use vars qw(@ISA $VERSION @EXPORT);
+
+@ISA = qw(DynaLoader);
+$VERSION = "1.20";
+bootstrap IO $VERSION;
+
+sub import {
+ shift;
+ 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
IO::File
IO::Pipe
IO::Socket
+ IO::Dir
For more information on any of these modules, please see its respective
documentation.
=cut
-use IO::Handle;
-use IO::Seekable;
-use IO::File;
-use IO::Pipe;
-use IO::Socket;
-
-1;
-
+/*
+ * 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.
+ */
+
#include "EXTERN.h"
#define PERLIO_NOT_STDIO 1
#include "perl.h"
#include "XSUB.h"
-
+#include "poll.h"
#ifdef I_UNISTD
# include <unistd.h>
#endif
-#ifdef I_FCNTL
-#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
-#define _NO_OLDNAMES
-#endif
+#if defined(I_FCNTL) || defined(HAS_FCNTL)
# include <fcntl.h>
-#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
-#undef _NO_OLDNAMES
-#endif
-
#endif
#ifdef PerlIO
typedef FILE * OutputStream;
#endif
+#include "patchlevel.h"
+
+#if (PATCHLEVEL < 3) || ((PATCHLEVEL == 3) && (SUBVERSION < 22))
+ /* before 5.003_22 */
+# define MY_start_subparse(fmt,flags) start_subparse()
+#else
+# if (PATCHLEVEL == 3) && (SUBVERSION == 22)
+ /* 5.003_22 */
+# define MY_start_subparse(fmt,flags) start_subparse(flags)
+# else
+ /* 5.003_23 onwards */
+# define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
+# endif
+#endif
+
+#ifndef gv_stashpvn
+#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
static int
-not_here(char *s)
+not_here(s)
+char *s;
{
croak("%s not implemented on this architecture", s);
return -1;
}
-static bool
-constant(char *name, IV *pval)
+#ifndef newCONSTSUB
+/*
+ * Define an XSUB that returns a constant scalar. The resulting structure is
+ * identical to that created by the parser when it parses code like :
+ *
+ * sub xyz () { 123 }
+ *
+ * This allows the constants from the XSUB to be inlined.
+ *
+ * !!! THIS SHOULD BE ADDED INTO THE CORE CODE !!!!
+ *
+ */
+
+static void
+newCONSTSUB(stash,name,sv)
+ HV *stash;
+ char *name;
+ SV *sv;
{
- switch (*name) {
- case '_':
- if (strEQ(name, "_IOFBF"))
-#ifdef _IOFBF
- { *pval = _IOFBF; return TRUE; }
-#else
- return FALSE;
+#ifdef dTHR
+ dTHR;
#endif
- if (strEQ(name, "_IOLBF"))
-#ifdef _IOLBF
- { *pval = _IOLBF; return TRUE; }
-#else
- return FALSE;
+ U32 oldhints = hints;
+ HV *old_cop_stash = curcop->cop_stash;
+ HV *old_curstash = curstash;
+ line_t oldline = curcop->cop_line;
+ curcop->cop_line = copline;
+
+ hints &= ~HINT_BLOCK_SCOPE;
+ if(stash)
+ curstash = curcop->cop_stash = stash;
+
+ newSUB(
+ MY_start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ hints = oldhints;
+ curcop->cop_stash = old_cop_stash;
+ curstash = old_curstash;
+ curcop->cop_line = oldline;
+}
#endif
- if (strEQ(name, "_IONBF"))
-#ifdef _IONBF
- { *pval = _IONBF; return TRUE; }
-#else
- return FALSE;
+
+#ifndef PerlIO
+#define PerlIO_fileno(f) fileno(f)
#endif
- break;
- case 'S':
- if (strEQ(name, "SEEK_SET"))
-#ifdef SEEK_SET
- { *pval = SEEK_SET; return TRUE; }
+
+static int
+io_blocking(f,block)
+InputStream f;
+int block;
+{
+ int RETVAL;
+ if(!f) {
+ errno = EBADF;
+ return -1;
+ }
+#if defined(HAS_FCNTL)
+ RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
+ if (RETVAL >= 0) {
+ int mode = RETVAL;
+#ifdef O_NONBLOCK
+ /* POSIX style */
+#if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK
+ /* Ooops has O_NDELAY too - make sure we don't
+ * get SysV behaviour by mistake
+ */
+ RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
+
+ if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) {
+ int ret;
+ mode = (mode & ~O_NDELAY) | O_NONBLOCK;
+ ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
+ if(ret < 0)
+ RETVAL = ret;
+ }
+ else if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) {
+ int ret;
+ mode &= ~(O_NONBLOCK | O_NDELAY);
+ ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
+ if(ret < 0)
+ RETVAL = ret;
+ }
#else
- return FALSE;
-#endif
- if (strEQ(name, "SEEK_CUR"))
-#ifdef SEEK_CUR
- { *pval = SEEK_CUR; return TRUE; }
+ /* Standard POSIX */
+ RETVAL = RETVAL & O_NONBLOCK ? 0 : 1;
+
+ if ((block == 0) && !(mode & O_NONBLOCK)) {
+ int ret;
+ mode |= O_NONBLOCK;
+ ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
+ if(ret < 0)
+ RETVAL = ret;
+ }
+ else if ((block > 0) && (mode & O_NONBLOCK)) {
+ int ret;
+ mode &= ~O_NONBLOCK;
+ ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
+ if(ret < 0)
+ RETVAL = ret;
+ }
+#endif
#else
- return FALSE;
+ /* 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) && !(mode & O_NDELAY)) {
+ int ret;
+ mode |= O_NDELAY;
+ ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
+ if(ret < 0)
+ RETVAL = ret;
+ }
+ else if ((block > 0) && (mode & O_NDELAY)) {
+ int ret;
+ mode &= ~O_NDELAY;
+ ret = fcntl(PerlIO_fileno(f),F_SETFL,mode);
+ if(ret < 0)
+ RETVAL = ret;
+ }
#endif
- if (strEQ(name, "SEEK_END"))
-#ifdef SEEK_END
- { *pval = SEEK_END; return TRUE; }
+ }
+ return RETVAL;
#else
- return FALSE;
+ return -1;
#endif
- break;
- }
-
- return FALSE;
}
-
MODULE = IO PACKAGE = IO::Seekable PREFIX = f
SV *
ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
}
else {
- ST(0) = &PL_sv_undef;
+ ST(0) = &sv_undef;
errno = EINVAL;
}
InputStream handle
SV * pos
CODE:
- char *p;
- if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t))
+ if (handle)
#ifdef PerlIO
- RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
+ RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos));
#else
- RETVAL = fsetpos(handle, (Fpos_t*)p);
+ RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos));
#endif
else {
RETVAL = -1;
if (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() */
+ SvREFCNT_dec(gv); /* undo increment in newRV() */
}
else {
- ST(0) = &PL_sv_undef;
+ ST(0) = &sv_undef;
SvREFCNT_dec(gv);
}
+MODULE = IO PACKAGE = IO::Poll
+
+void
+_poll(timeout,...)
+ int timeout;
+PPCODE:
+{
+#ifdef HAS_POLL
+ 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 = 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:
+{
+ int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0);
+ if(ret >= 0)
+ XSRETURN_IV(ret);
+ else
+ XSRETURN_UNDEF;
+}
+
MODULE = IO PACKAGE = IO::Handle PREFIX = f
-SV *
-constant(name)
- char * name
- CODE:
- IV i;
- if (constant(name, &i))
- ST(0) = sv_2mortal(newSViv(i));
- else
- ST(0) = &PL_sv_undef;
int
ungetc(handle, c)
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
+
+
+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
+ /*
+ * constant subs for IO
+ */
+ stash = gv_stashpvn("IO", 2, TRUE);
+#ifdef EINPROGRESS
+ newCONSTSUB(stash,"EINPROGRESS", newSViv(EINPROGRESS));
+#endif
+}
use ExtUtils::MakeMaker;
+use Config qw(%Config);
+
+#--- Attempt to find <poll.h>
+
+my $define = "";
+
+my @inc = split(/\s+/, join(" ",$Config{'usrinc'},$Config{'incpth'},$Config{'locincpth'}));
+foreach $path (@inc) {
+ if(-f $path . "/poll.h") {
+ $define .= "-DI_POLL ";
+ last;
+ }
+}
+
+#--- Write the Makefile
+
WriteMakefile(
- NAME => 'IO',
- MAN3PODS => {}, # Pods will be built by installman.
- XSPROTOARG => '-noprototypes', # XXX remove later?
- VERSION_FROM => 'lib/IO/Handle.pm',
- XS_VERSION => 1.15
+ VERSION_FROM => "IO.pm",
+ NAME => "IO",
+ OBJECT => '$(O_FILES)',
+ DEFINE => $define,
+ MAN3PODS => {}, # Pods will be built by installman.
);
This directory contains files from the IO distribution maintained by
-Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify
+Graham Barr <gbarr@pobox.com>. If you find that you have to modify
any files in this directory then please forward him a patch for only
the files in this directory.
--- /dev/null
+# 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.003_26;
+
+use strict;
+use Carp;
+use Symbol;
+use Exporter;
+use IO::File;
+use vars qw(@ISA $VERSION @EXPORT_OK);
+use Tie::Hash;
+use File::stat;
+
+@ISA = qw(Tie::Hash Exporter);
+$VERSION = "1.03";
+@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) = @_;
+ closedir($dh);
+}
+
+sub open {
+ @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
+ my ($dh, $dirname) = @_;
+ return undef
+ unless opendir($dh, $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 ${*$dh}{io_dir_path} . "/" . $key;
+}
+
+sub FETCH {
+ my($dh,$key) = @_;
+ &lstat(${*$dh}{io_dir_path} . "/" . $key);
+}
+
+sub STORE {
+ my($dh,$key,$data) = @_;
+ my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
+ my $file = ${*$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
+ my $file = ${*$dh}{io_dir_path} . "/" . $key;
+
+ return 0
+ unless ${*$dh}{io_dir_unlink};
+
+ -d $file
+ ? rmdir($file)
+ : unlink($file);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Dir - supply object methods for directory handles
+
+=head1 SYNOPSIS
+
+ use IO::Dir;
+ $d = new IO::Dir ".";
+ 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 constuctor 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 a 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 call C<unlink>
+providing that C<DIR_UNLINK> is passed 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 E<lt>F<gbarr@pobox.com>E<gt>
+
+=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
=over 4
-=item new ([ ARGS ] )
+=item new ( FILENAME [,MODE [,PERMS]] )
Creates a 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,
=item open( FILENAME [,MODE [,PERMS]] )
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
+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 a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
-Perl C<open> operator.
+or a 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.
-For convenience, C<IO::File::import> tries to import the O_XXX
-constants from the Fcntl module. If dynamic loading is not available,
-this may fail, but the rest of IO::File will still work.
+The permissions default to 0666.
+
+For convenience, C<IO::File> exports the O_XXX constants from the
+Fcntl module, if this module is available.
=back
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>.
+Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
=cut
require 5.000;
use strict;
-use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
+use vars qw($VERSION @EXPORT @EXPORT_OK @ISA);
use Carp;
use Symbol;
use SelectSaver;
@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
-$VERSION = "1.06021";
+$VERSION = "1.08";
@EXPORT = @IO::Seekable::EXPORT;
push(@EXPORT, @O);
};
-
################################################
## Constructor
##
use IO::Handle;
- $fh = new IO::Handle;
- if ($fh->fdopen(fileno(STDIN),"r")) {
- print $fh->getline;
- $fh->close;
+ $io = new IO::Handle;
+ if ($io->fdopen(fileno(STDIN),"r")) {
+ print $io->getline;
+ $io->close;
}
- $fh = new IO::Handle;
- if ($fh->fdopen(fileno(STDOUT),"w")) {
- $fh->print("Some text\n");
+ $io = new IO::Handle;
+ if ($io->fdopen(fileno(STDOUT),"w")) {
+ $io->print("Some text\n");
}
use IO::Handle '_IOLBF';
- $fh->setvbuf($buffer_var, _IOLBF, 1024);
+ $io->setvbuf($buffer_var, _IOLBF, 1024);
- undef $fh; # automatically closes the file if it's open
+ undef $io; # automatically closes the file if it's open
autoflush STDOUT 1;
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>
-
-A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package)
+for C<IO::File> too.
=head1 CONSTRUCTOR
supported C<IO::Handle> methods, which are just front ends for the
corresponding built-in functions:
- close
- fileno
- getc
- eof
- read
- truncate
- stat
- print
- printf
- sysread
- syswrite
+ $io->close
+ $io->eof
+ $io->fileno
+ $io->format_write( [FORMAT_NAME] )
+ $io->getc
+ $io->read ( BUF, LEN, [OFFSET] )
+ $io->print ( ARGS )
+ $io->printf ( FMT, [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:
+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).
- 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
+ $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
-=item $fh->fdopen ( FD, MODE )
+=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, a IO::Handle object,
or a file descriptor number.
-=item $fh->opened
+=item $io->opened
Returns true if the object is currently a valid file descriptor.
-=item $fh->getline
+=item $io->getline
-This works like <$fh> described in L<perlop/"I/O Operators">
+This works like <$io> described in L<perlop/"I/O Operators">
except that it's more readable and can be safely called in an
array context but still returns just one line.
-=item $fh->getlines
+=item $io->getlines
-This works like <$fh> when called in an array context to
+This works like <$io> when called in an array 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 $fh->ungetc ( ORD )
+=item $io->ungetc ( ORD )
Pushes a character with the given ordinal value back onto the given
-handle's input stream.
+handle's input stream. Only one character of pushback per handle is
+guaranteed.
-=item $fh->write ( BUF, LEN [, OFFSET }\] )
+=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 $fh->flush
-
-Flush the given handle's buffer.
-
-=item $fh->error
+=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>.
-=item $fh->clearerr
+=item $io->clearerr
Clear the given handle's error indicator.
+=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, 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. 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.
+
+=item $io->printflush ( ARGS )
+
+Turns on autoflush, print ARGS and then restores the autoflush status of the
+C<IO::Handle> object.
+
+=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
specifies a scalar variable to use as a buffer. WARNING: A variable
used as a buffer by C<setbuf> or C<setvbuf> 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! Note that you need to import
+again, or memory corruption may result! Note that you need to import
the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly.
Lastly, there is a special method for working under B<-T> and setuid/gid
=over
-=item $fh->untaint
+=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
=head1 NOTE
-A C<IO::Handle> object is a GLOB reference. Some modules that
+A 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
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
+Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
=cut
require 5.000;
use strict;
-use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA);
+use vars qw($VERSION @EXPORT_OK @ISA);
use Carp;
use Symbol;
use SelectSaver;
+use IO (); # Load the XS module
require Exporter;
@ISA = qw(Exporter);
-$VERSION = "1.1505";
-$XS_VERSION = "1.15";
+$VERSION = "1.21";
@EXPORT_OK = qw(
autoflush
getline
getlines
+ printflush
+ flush
+
SEEK_SET
SEEK_CUR
SEEK_END
_IONBF
);
-
-################################################
-## Interaction with the XS.
-##
-
-require DynaLoader;
-@IO::ISA = qw(DynaLoader);
-bootstrap IO $XS_VERSION;
-
-sub AUTOLOAD {
- if ($AUTOLOAD =~ /::(_?[a-z])/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD
- }
- my $constname = $AUTOLOAD;
- $constname =~ s/.*:://;
- my $val = constant($constname);
- defined $val or croak "$constname is not a valid IO::Handle macro";
- no strict 'refs';
- *$AUTOLOAD = sub { $val };
- goto &$AUTOLOAD;
-}
-
-
################################################
## Constructors, destructors.
##
sub new {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
@_ == 1 or croak "usage: new $class";
- my $fh = gensym;
- bless $fh, $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 $fh = gensym;
+ my $io = gensym;
shift;
- IO::Handle::fdopen($fh, @_)
+ IO::Handle::fdopen($io, @_)
or return undef;
- bless $fh, $class;
+ bless $io, $class;
}
#
}
sub fdopen {
- @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
- my ($fh, $fd, $mode) = @_;
+ @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
+ my ($io, $fd, $mode) = @_;
local(*GLOB);
if (ref($fd) && "".$fd =~ /GLOB\(/o) {
$fd = "=$fd";
}
- open($fh, _open_mode_string($mode) . '&' . $fd)
- ? $fh : undef;
+ open($io, _open_mode_string($mode) . '&' . $fd)
+ ? $io : undef;
}
sub close {
- @_ == 1 or croak 'usage: $fh->close()';
- my($fh) = @_;
+ @_ == 1 or croak 'usage: $io->close()';
+ my($io) = @_;
- close($fh);
+ close($io);
}
################################################
# select
sub opened {
- @_ == 1 or croak 'usage: $fh->opened()';
+ @_ == 1 or croak 'usage: $io->opened()';
defined fileno($_[0]);
}
sub fileno {
- @_ == 1 or croak 'usage: $fh->fileno()';
+ @_ == 1 or croak 'usage: $io->fileno()';
fileno($_[0]);
}
sub getc {
- @_ == 1 or croak 'usage: $fh->getc()';
+ @_ == 1 or croak 'usage: $io->getc()';
getc($_[0]);
}
sub eof {
- @_ == 1 or croak 'usage: $fh->eof()';
+ @_ == 1 or croak 'usage: $io->eof()';
eof($_[0]);
}
sub print {
- @_ or croak 'usage: $fh->print([ARGS])';
+ @_ or croak 'usage: $io->print(ARGS)';
my $this = shift;
print $this @_;
}
sub printf {
- @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
+ @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
my $this = shift;
printf $this @_;
}
sub getline {
- @_ == 1 or croak 'usage: $fh->getline';
+ @_ == 1 or croak 'usage: $io->getline()';
my $this = shift;
return scalar <$this>;
}
*gets = \&getline; # deprecated
sub getlines {
- @_ == 1 or croak 'usage: $fh->getline()';
+ @_ == 1 or croak 'usage: $io->getlines()';
wantarray or
- croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
+ croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
my $this = shift;
return <$this>;
}
sub truncate {
- @_ == 2 or croak 'usage: $fh->truncate(LEN)';
+ @_ == 2 or croak 'usage: $io->truncate(LEN)';
truncate($_[0], $_[1]);
}
sub read {
- @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
read($_[0], $_[1], $_[2], $_[3] || 0);
}
sub sysread {
- @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
sysread($_[0], $_[1], $_[2], $_[3] || 0);
}
sub write {
- @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->write(BUF, LEN [, OFFSET])';
local($\) = "";
print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
}
sub syswrite {
- @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->syswrite(BUF, LEN [, OFFSET])';
syswrite($_[0], $_[1], $_[2], $_[3] || 0);
}
sub stat {
- @_ == 1 or croak 'usage: $fh->stat()';
+ @_ == 1 or croak 'usage: $io->stat()';
stat($_[0]);
}
##
sub autoflush {
- my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ 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 {
- # localizing $. doesn't work as advertised. grrrrrr.
+ my $now = select;
+ my $keep = $.;
+ my $tell = tell qualify($_[0], caller) if ref($_[0]);
my $prev = $.;
$. = $_[1] if @_ > 1;
+ $tell = tell $now;
+ $. = $keep;
$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 $fh = shift;
+ my $io = shift;
my $picture = shift;
local($^A) = $^A;
local($\) = "";
formline($picture, @_);
- print $fh $^A;
+ print $io $^A;
}
sub format_write {
- @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
+ @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
if (@_ == 2) {
- my ($fh, $fmt) = @_;
- my $oldfmt = $fh->format_name($fmt);
- CORE::write($fh);
- $fh->format_name($oldfmt);
+ my ($io, $fmt) = @_;
+ my $oldfmt = $io->format_name($fmt);
+ CORE::write($io);
+ $io->format_name($oldfmt);
} else {
CORE::write($_[0]);
}
}
sub fcntl {
- @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );';
- my ($fh, $op, $val) = @_;
- my $r = fcntl($fh, $op, $val);
+ @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
+ my ($io, $op, $val) = @_;
+ my $r = fcntl($io, $op, $val);
defined $r && $r eq "0 but true" ? 0 : $r;
}
sub ioctl {
- @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );';
- my ($fh, $op, $val) = @_;
- my $r = ioctl($fh, $op, $val);
+ @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
+ my ($io, $op, $val) = @_;
+ my $r = ioctl($io, $op, $val);
defined $r && $r eq "0 but true" ? 0 : $r;
}
+# 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 depriciated
+
+sub printflush {
+ my $io = shift;
+ my $old = new SelectSaver qualify($io, caller) if ref($io);
+ local $| = 1;
+ if(ref($io)) {
+ print $io @_;
+ }
+ else {
+ print @_;
+ }
+}
+
1;
# IO::Pipe.pm
#
-# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
-# reserved. This program is free software; you can redistribute it and/or
+# 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 Carp;
use Symbol;
-$VERSION = "1.0901";
+$VERSION = "1.12";
sub new {
my $type = shift;
}
bless $io, "IO::Handle";
$io->fdopen($fh, $mode);
- $fh->close;
+ $fh->close;
if ($do_spawn) {
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
}
sub reader {
- @_ >= 1 or croak 'usage: $pipe->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 = $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;
}
sub writer {
- @_ >= 1 or croak 'usage: $pipe->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 = $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;
=head1 NAME
-IO::pipe - supply object methods for pipes
+IO::Pipe - supply object methods for pipes
=head1 SYNOPSIS
=head1 AUTHOR
-Graham Barr <bodg@tiuk.ti.com>
+Graham Barr <gbarr@pobox.com>
=head1 COPYRIGHT
-Copyright (c) 1996 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.
+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
--- /dev/null
+# 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 ();
+use vars qw(@ISA @EXPORT_OK @EXPORT $VERSION);
+
+@ISA = qw(Exporter);
+$VERSION = "0.01";
+
+@EXPORT = qw(poll);
+
+@EXPORT_OK = qw(
+ POLLIN
+ POLLPRI
+ POLLOUT
+ POLLRDNORM
+ POLLWRNORM
+ POLLRDBAND
+ POLLWRBAND
+ POLLNORM
+ POLLERR
+ POLLHUP
+ POLLNVAL
+);
+
+sub new {
+ my $class = shift;
+
+ my $self = bless [{},{}], $class;
+
+ $self;
+}
+
+sub mask {
+ my $self = shift;
+ my $io = shift;
+ my $fd = fileno($io);
+ if(@_) {
+ my $mask = shift;
+ $self->[0]{$fd} ||= {};
+ if($mask) {
+ $self->[0]{$fd}{$io} = $mask;
+ }
+ else {
+ delete $self->[0]{$fd}{$io};
+ }
+ }
+ elsif(exists $self->[0]{$fd}{$io}) {
+ return $self->[0]{$fd}{$io};
+ }
+ return;
+}
+
+
+sub poll {
+ my($self,$timeout) = @_;
+
+ $self->[1] = {};
+
+ my($fd,$ref);
+ my @poll = ();
+
+ while(($fd,$ref) = each %{$self->[0]}) {
+ my $events = 0;
+ map { $events |= $_ } values %{$ref};
+ push(@poll,$fd, $events);
+ }
+
+ 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} && exists $self->[0]{$fd}{$io}
+ ? $self->[1]{$fd} & $self->[0]{$fd}{$io}
+ : 0;
+}
+
+sub remove {
+ my $self = shift;
+ my $io = shift;
+ $self->mask($io,0);
+}
+
+sub handles {
+ my $self = shift;
+
+ return map { keys %$_ } values %{$self->[0]}
+ unless(@_);
+
+ my $events = shift || 0;
+ my($fd,$ev,$io,$mask);
+ my @handles = ();
+
+ while(($fd,$ev) = each %{$self->[1]}) {
+ if($ev & $events) {
+ while(($io,$mask) = each %{$self->[0][$fd]}) {
+ push(@handles, $io)
+ if $events & $mask;
+ }
+ }
+ }
+ 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 => POLLRDNORM | POLLIN | POLLHUP);
+ $poll->mask($output_handle => POLLWRNORM);
+
+ $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 happend 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 <gbarr@pobox.com>
+
+=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
which allow seeking of the file descriptors.
If the C functions fgetpos() and fsetpos() are available, then
-C<IO::File::getpos> returns an opaque value that represents the
-current position of the IO::File, and C<IO::File::setpos> uses
+C<$io-E<lt>getpos> returns an opaque value that represents the
+current position of the IO::File, and C<$io-E<gt>setpos(POS)> uses
that value to return to a previously visited position.
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:
- seek
- tell
+ $io->seek( POS, WHENCE )
+ $io->sysseek( POS, WHENCE )
+ $io->tell
=head1 SEE ALSO
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt>
+Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt>
=cut
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
-$VERSION = "1.06";
+$VERSION = "1.08";
sub seek {
- @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+ @_ == 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: $fh->tell()';
+ @_ == 1 or croak 'usage: $io->tell()';
tell($_[0]);
}
# IO::Select.pm
#
-# Copyright (c) 1995 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.
+# 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;
-=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)->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 error condition 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 a 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. 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_error ( [ TIMEOUT ] )
-
-Same as C<can_read> except check for handles that have an error
-condition, for example EOF.
-
-=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 bits()
-
-Return the bit string suitable as argument to the core select() call.
-
-=item select ( READ, WRITE, ERROR [, 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<ERROR> 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
-error conditions respectively. Upon error an empty array 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 E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995 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
-
use strict;
use vars qw($VERSION @ISA);
require Exporter;
-$VERSION = "1.10";
+$VERSION = "1.13";
@ISA = qw(Exporter); # This is only so we can do version checking
: ();
}
-sub has_error
+sub has_exception
{
my $vec = shift;
my $timeout = shift;
: ();
}
+sub has_error
+{
+ require Carp;
+ Carp::carp("Call to depreciated method 'has_error', use 'has_exception'")
+ if $^W;
+ goto &has_exception;
+}
+
sub count
{
my $vec = shift;
}
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)->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 error condition 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 a 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. 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, ERROR [, 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<ERROR> 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
+error conditions respectively. Upon error an empty array 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 E<lt>F<gbarr@pobox.com>E<gt>
+
+=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
+
# IO::Socket.pm
#
-# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
-# reserved. This program is free software; you can redistribute it and/or
+# 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;
-=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.
-
-C<IO::Socket>s will be in autoflush mode after creation. Note that
-versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04)
-did not do this. So if you need backward compatibility, you should
-set autoflush explicitly.
-
-=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)
-
-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 an array context a two-element array is returned
-containing the new socket and the peer address, the list will
-be empty upon failure.
-
-Additional methods that are provided are
-
-=item timeout([VAL])
-
-Set or get the timeout value 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.
-
-=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 sockdomain
-
-Returns the numerical number for the socket domain type. For example, for
-a AF_INET socket the value of &AF_INET will be returned.
-
-=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 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.
-
-=back
-
-=cut
-
-
require 5.000;
-use Config;
use IO::Handle;
use Socket 1.3;
use Carp;
use vars qw(@ISA $VERSION);
use Exporter;
+# legacy
+
+require IO::Socket::INET;
+require IO::Socket::UNIX;
+
@ISA = qw(IO::Handle);
-$VERSION = "1.1603";
+$VERSION = "1.25";
sub import {
my $pkg = shift;
sub new {
my($class,%arg) = @_;
- my $fh = $class->SUPER::new();
- $fh->autoflush;
+ my $sock = $class->SUPER::new();
+
+ $sock->autoflush(1);
- ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
+ ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
- return scalar(%arg) ? $fh->configure(\%arg)
- : $fh;
+ return scalar(%arg) ? $sock->configure(\%arg)
+ : $sock;
}
-my @domain2pkg = ();
+my @domain2pkg;
sub register_domain {
my($p,$d) = @_;
}
sub configure {
- my($fh,$arg) = @_;
+ my($sock,$arg) = @_;
my $domain = delete $arg->{Domain};
croak 'IO::Socket: Cannot configure a generic socket'
unless defined $domain2pkg[$domain];
croak "IO::Socket: Cannot configure socket in domain '$domain'"
- unless ref($fh) eq "IO::Socket";
+ unless ref($sock) eq "IO::Socket";
- bless($fh, $domain2pkg[$domain]);
- $fh->configure($arg);
+ bless($sock, $domain2pkg[$domain]);
+ $sock->configure($arg);
}
sub socket {
- @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
- my($fh,$domain,$type,$protocol) = @_;
+ @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
+ my($sock,$domain,$type,$protocol) = @_;
- socket($fh,$domain,$type,$protocol) or
+ socket($sock,$domain,$type,$protocol) or
return undef;
- ${*$fh}{'io_socket_domain'} = $domain;
- ${*$fh}{'io_socket_type'} = $type;
- ${*$fh}{'io_socket_proto'} = $protocol;
+ ${*$sock}{'io_socket_domain'} = $domain;
+ ${*$sock}{'io_socket_type'} = $type;
+ ${*$sock}{'io_socket_proto'} = $protocol;
- $fh;
+ $sock;
}
sub socketpair {
@_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
my($class,$domain,$type,$protocol) = @_;
- my $fh1 = $class->new();
- my $fh2 = $class->new();
+ my $sock1 = $class->new();
+ my $sock2 = $class->new();
- socketpair($fh1,$fh2,$domain,$type,$protocol) or
+ socketpair($sock1,$sock2,$domain,$type,$protocol) or
return ();
- ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
- ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
+ ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
+ ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
- ($fh1,$fh2);
+ ($sock1,$sock2);
}
sub connect {
- @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
- my $fh = shift;
- my $addr = @_ == 1 ? shift : sockaddr_in(@_);
- my $timeout = ${*$fh}{'io_socket_timeout'};
- local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
- : $SIG{ALRM} || 'DEFAULT';
-
- eval {
+ @_ == 2 or croak 'usage: $sock->connect(NAME)';
+ my $sock = shift;
+ my $addr = shift;
+ my $timeout = ${*$sock}{'io_socket_timeout'};
+
+ eval {
+ my $blocking = 0;
+
croak 'connect: Bad address'
if(@_ == 2 && !defined $_[1]);
- if($timeout) {
- defined $Config{d_alarm} && defined alarm($timeout) or
- $timeout = 0;
- }
+ $blocking = $sock->blocking(0)
+ if($timeout);
- my $ok = connect($fh, $addr);
+ unless(connect($sock, $addr)) {
+ if($timeout && ($! == &IO::EINPROGRESS)) {
+ require IO::Select;
- alarm(0)
- if($timeout);
+ my $sel = new IO::Select $sock;
- croak "connect: timeout"
- unless defined $fh;
+ $sock->blocking(1)
+ if($blocking);
- undef $fh unless $ok;
+ unless($sel->can_write($timeout) && defined($sock->peername)) {
+ undef $sock;
+ croak "connect: timeout";
+ }
+ }
+ else {
+ undef $sock;
+ croak "connect: $!";
+ }
+ }
+ $sock->blocking(1)
+ if($sock && $blocking);
};
- $fh;
+ $sock;
}
sub bind {
- @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
- my $fh = shift;
- my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+ @_ == 2 or croak 'usage: $sock->bind(NAME)';
+ my $sock = shift;
+ my $addr = shift;
- return bind($fh, $addr) ? $fh
- : undef;
+ return bind($sock, $addr) ? $sock
+ : undef;
}
sub listen {
- @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
- my($fh,$queue) = @_;
+ @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
+ my($sock,$queue) = @_;
$queue = 5
unless $queue && $queue > 0;
- return listen($fh, $queue) ? $fh
- : undef;
+ return listen($sock, $queue) ? $sock
+ : undef;
}
sub accept {
- @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
- my $fh = shift;
- my $pkg = shift || $fh;
- my $timeout = ${*$fh}{'io_socket_timeout'};
+ @_ == 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;
eval {
if($timeout) {
- my $fdset = "";
- vec($fdset, $fh->fileno,1) = 1;
+ require IO::Select;
+
+ my $sel = new IO::Select $sock;
+
croak "accept: timeout"
- unless select($fdset,undef,undef,$timeout);
+ unless $sel->can_read($timeout);
}
- $peer = accept($new,$fh);
+ $peer = accept($new,$sock) || undef;
};
return wantarray ? defined $peer ? ($new, $peer)
}
sub sockname {
- @_ == 1 or croak 'usage: $fh->sockname()';
+ @_ == 1 or croak 'usage: $sock->sockname()';
getsockname($_[0]);
}
sub peername {
- @_ == 1 or croak 'usage: $fh->peername()';
- my($fh) = @_;
- getpeername($fh)
- || ${*$fh}{'io_socket_peername'}
+ @_ == 1 or croak 'usage: $sock->peername()';
+ my($sock) = @_;
+ getpeername($sock)
+ || ${*$sock}{'io_socket_peername'}
|| undef;
}
+sub connected {
+ @_ == 1 or croak 'usage: $sock->connected()';
+ my($sock) = @_;
+ getpeername($sock);
+}
+
sub send {
- @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
- my $fh = $_[0];
+ @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
+ my $sock = $_[0];
my $flags = $_[2] || 0;
- my $peer = $_[3] || $fh->peername;
+ my $peer = $_[3] || $sock->peername;
croak 'send: Cannot determine peer address'
unless($peer);
- my $r = defined(getpeername($fh))
- ? send($fh, $_[1], $flags)
- : send($fh, $_[1], $flags, $peer);
+ my $r = defined(getpeername($sock))
+ ? send($sock, $_[1], $flags)
+ : send($sock, $_[1], $flags, $peer);
# remember who we send to, if it was sucessful
- ${*$fh}{'io_socket_peername'} = $peer
+ ${*$sock}{'io_socket_peername'} = $peer
if(@_ == 4 && defined $r);
$r;
}
sub recv {
- @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
+ @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
my $sock = $_[0];
my $len = $_[2];
my $flags = $_[3] || 0;
${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}
+sub shutdown {
+ @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
+ my($sock, $how) = @_;
+ shutdown($sock, $how);
+}
sub setsockopt {
- @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
+ @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
setsockopt($_[0],$_[1],$_[2],$_[3]);
}
my $intsize = length(pack("i",0));
sub getsockopt {
- @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
+ @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
my $r = getsockopt($_[0],$_[1],$_[2]);
# Just a guess
$r = unpack("i", $r)
}
sub sockopt {
- my $fh = shift;
- @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
- : $fh->setsockopt(SOL_SOCKET,@_);
+ my $sock = shift;
+ @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
+ : $sock->setsockopt(SOL_SOCKET,@_);
}
sub timeout {
- @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
- my($fh,$val) = @_;
- my $r = ${*$fh}{'io_socket_timeout'} || undef;
+ @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
+ my($sock,$val) = @_;
+ my $r = ${*$sock}{'io_socket_timeout'} || undef;
- ${*$fh}{'io_socket_timeout'} = 0 + $val
+ ${*$sock}{'io_socket_timeout'} = 0 + $val
if(@_ == 2);
$r;
}
sub sockdomain {
- @_ == 1 or croak 'usage: $fh->sockdomain()';
- my $fh = shift;
- ${*$fh}{'io_socket_domain'};
+ @_ == 1 or croak 'usage: $sock->sockdomain()';
+ my $sock = shift;
+ ${*$sock}{'io_socket_domain'};
}
sub socktype {
- @_ == 1 or croak 'usage: $fh->socktype()';
- my $fh = shift;
- ${*$fh}{'io_socket_type'}
+ @_ == 1 or croak 'usage: $sock->socktype()';
+ my $sock = shift;
+ ${*$sock}{'io_socket_type'}
}
sub protocol {
- @_ == 1 or croak 'usage: $fh->protocol()';
- my($fh) = @_;
- ${*$fh}{'io_socket_protocol'};
+ @_ == 1 or croak 'usage: $sock->protocol()';
+ my($sock) = @_;
+ ${*$sock}{'io_socket_protocol'};
}
-=head1 SUB-CLASSES
-
-=cut
-
-##
-## AF_INET
-##
-
-package IO::Socket::INET;
-
-use strict;
-use vars qw(@ISA);
-use Socket;
-use Carp;
-use Exporter;
-
-@ISA = qw(IO::Socket);
-
-IO::Socket::INET->register_domain( AF_INET );
-
-my %socket_type = ( tcp => SOCK_STREAM,
- udp => SOCK_DGRAM,
- icmp => SOCK_RAW,
- );
-
-=head2 IO::Socket::INET
-
-C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
-and some related methods. The constructor can take the following options
-
- PeerAddr Remote host address <hostname>[:<port>]
- PeerPort Remote port or service <service>[(<no>)] | <no>
- LocalAddr Local host bind address hostname[:port]
- 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
- Reuse Set SO_REUSEADDR before binding
- Timeout Timeout value for various operations
+1;
+__END__
-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.
-
-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.
+=head1 NAME
-If the constructor is only passed a single argument, it is assumed to
-be a C<PeerAddr> specification.
+IO::Socket - Object interface to socket communications
-Examples:
+=head1 SYNOPSIS
- $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
- PeerPort => 'http(80)',
- Proto => 'tcp');
+ use IO::Socket;
- $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
+=head1 DESCRIPTION
- $sock = IO::Socket::INET->new(Listen => 5,
- LocalAddr => 'localhost',
- LocalPort => 9000,
- Proto => 'tcp');
+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>.
- $sock = IO::Socket::INET->new('127.0.0.1:25');
+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>.
-=head2 METHODS
+=head1 CONSTRUCTOR
=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 ()
+=item new ( [ARGS] )
-Return the port number for the socket on the peer host.
+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.
-=item peerhost ()
+ 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.
-Return the address part of the sockaddr structure for the socket on the
-peer host in a text form xx.xx.xx.xx
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
=back
-=cut
-
-sub new
-{
- my $class = shift;
- unshift(@_, "PeerAddr") if @_ == 1;
- return $class->SUPER::new(@_);
-}
-
-sub _sock_info {
- my($addr,$port,$proto) = @_;
- my @proto = ();
- my @serv = ();
-
- $port = $1
- if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
-
- if(defined $proto) {
- @proto = $proto =~ m,\D, ? getprotobyname($proto)
- : getprotobynumber($proto);
-
- $proto = $proto[2] || undef;
- }
-
- if(defined $port) {
- $port =~ s,\((\d+)\)$,,;
-
- my $defport = $1 || undef;
- my $pnum = ($port =~ m,^(\d+)$,)[0];
-
- @serv= getservbyname($port, $proto[0] || "")
- if($port =~ m,\D,);
-
- $port = $pnum || $serv[2] || $defport || undef;
-
- $proto = (getprotobyname($serv[3]))[2] || undef
- if @serv && !$proto;
- }
-
- return ($addr || undef,
- $port || undef,
- $proto || undef
- );
-}
-
-sub _error {
- my $fh = shift;
- $@ = join("",ref($fh),": ",@_);
- carp $@ if $^W;
- close($fh)
- if(defined fileno($fh));
- return undef;
-}
-
-sub configure {
- my($fh,$arg) = @_;
- my($lport,$rport,$laddr,$raddr,$proto,$type);
-
-
- ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
- $arg->{LocalPort},
- $arg->{Proto});
-
- $laddr = defined $laddr ? inet_aton($laddr)
- : INADDR_ANY;
-
- return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
- unless(defined $laddr);
-
- unless(exists $arg->{Listen}) {
- ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
- $arg->{PeerPort},
- $proto);
- }
-
- if(defined $raddr) {
- $raddr = inet_aton($raddr);
- return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
- unless(defined $raddr);
- }
-
- $proto ||= (getprotobyname "tcp")[2];
- return _error($fh,'Cannot determine protocol')
- unless($proto);
-
- my $pname = (getprotobynumber($proto))[0];
- $type = $arg->{Type} || $socket_type{$pname};
-
- $fh->socket(AF_INET, $type, $proto) or
- return _error($fh,"$!");
-
- if ($arg->{Reuse}) {
- $fh->sockopt(SO_REUSEADDR,1) or
- return _error($fh);
- }
-
- $fh->bind($lport || 0, $laddr) or
- return _error($fh,"$!");
-
- if(exists $arg->{Listen}) {
- $fh->listen($arg->{Listen} || 5) or
- return _error($fh,"$!");
- }
- else {
- return _error($fh,'Cannot determine remote port')
- unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
-
- if($type == SOCK_STREAM || defined $raddr) {
- return _error($fh,'Bad peer address')
- unless(defined $raddr);
-
- $fh->connect($rport,$raddr) or
- return _error($fh,"$!");
- }
- }
-
- $fh;
-}
-
-sub sockaddr {
- @_ == 1 or croak 'usage: $fh->sockaddr()';
- my($fh) = @_;
- (sockaddr_in($fh->sockname))[1];
-}
+=head1 METHODS
-sub sockport {
- @_ == 1 or croak 'usage: $fh->sockport()';
- my($fh) = @_;
- (sockaddr_in($fh->sockname))[0];
-}
+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:
-sub sockhost {
- @_ == 1 or croak 'usage: $fh->sockhost()';
- my($fh) = @_;
- inet_ntoa($fh->sockaddr);
-}
+ socket
+ socketpair
+ bind
+ listen
+ accept
+ send
+ recv
+ peername (getpeername)
+ sockname (getsockname)
+ shutdown
-sub peeraddr {
- @_ == 1 or croak 'usage: $fh->peeraddr()';
- my($fh) = @_;
- (sockaddr_in($fh->peername))[1];
-}
+Some methods take slightly different arguments to those defined in L<perlfunc>
+in attempt to make the interface more flexible. These are
-sub peerport {
- @_ == 1 or croak 'usage: $fh->peerport()';
- my($fh) = @_;
- (sockaddr_in($fh->peername))[0];
-}
+=over 4
-sub peerhost {
- @_ == 1 or croak 'usage: $fh->peerhost()';
- my($fh) = @_;
- inet_ntoa($fh->peeraddr);
-}
+=item accept([PKG])
-##
-## AF_UNIX
-##
+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 an array context a two-element array is returned
+containing the new socket and the peer address, the list will
+be empty upon failure.
-package IO::Socket::UNIX;
+Additional methods that are provided are
-use strict;
-use vars qw(@ISA $VERSION);
-use Socket;
-use Carp;
-use Exporter;
+=item timeout([VAL])
-@ISA = qw(IO::Socket);
+Set or get the timeout value 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.
-IO::Socket::UNIX->register_domain( AF_UNIX );
+=item sockopt(OPT [, VAL])
-=head2 IO::Socket::UNIX
+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.
-C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
-and some related methods. The constructor can take the following options
+=item sockdomain
- 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
+Returns the numerical number for the socket domain type. For example, for
+a AF_INET socket the value of &AF_INET will be returned.
-=head2 METHODS
+=item socktype
-=over 4
+Returns the numerical number for the socket type. For example, for
+a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
-=item hostpath()
+=item protocol
-Returns the pathname to the fifo at the local end
+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 peerpath()
+=item connected
-Returns the pathanme to the fifo at the peer end
+If the socket is in a connected state the the peer address is returned.
+If the socket is not in a connected state then undef will be returned.
=back
-=cut
-
-sub configure {
- my($fh,$arg) = @_;
- my($bport,$cport);
-
- my $type = $arg->{Type} || SOCK_STREAM;
-
- $fh->socket(AF_UNIX, $type, 0) or
- return undef;
-
- if(exists $arg->{Local}) {
- my $addr = sockaddr_un($arg->{Local});
- $fh->bind($addr) or
- return undef;
- }
- if(exists $arg->{Listen}) {
- $fh->listen($arg->{Listen} || 5) or
- return undef;
- }
- elsif(exists $arg->{Peer}) {
- my $addr = sockaddr_un($arg->{Peer});
- $fh->connect($addr) or
- return undef;
- }
-
- $fh;
-}
-
-sub hostpath {
- @_ == 1 or croak 'usage: $fh->hostpath()';
- my $n = $_[0]->sockname || return undef;
- (sockaddr_un($n))[0];
-}
-
-sub peerpath {
- @_ == 1 or croak 'usage: $fh->peerpath()';
- my $n = $_[0]->peername || return undef;
- (sockaddr_un($n))[0];
-}
-
=head1 SEE ALSO
-L<Socket>, L<IO::Handle>
+L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
=head1 AUTHOR
-Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
=head1 COPYRIGHT
-Copyright (c) 1996 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.
+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
-
-1; # Keep require happy
--- /dev/null
+# 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;
+use vars qw(@ISA $VERSION);
+use IO::Socket;
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+$VERSION = "1.24";
+
+IO::Socket::INET->register_domain( AF_INET );
+
+my %socket_type = ( tcp => SOCK_STREAM,
+ udp => SOCK_DGRAM,
+ icmp => SOCK_RAW
+ );
+
+sub new {
+ my $class = shift;
+ unshift(@_, "PeerAddr") if @_ == 1;
+ return $class->SUPER::new(@_);
+}
+
+sub _sock_info {
+ my($addr,$port,$proto) = @_;
+ my @proto = ();
+ my @serv = ();
+
+ $port = $1
+ if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
+
+ if(defined $proto) {
+ @proto = $proto =~ m,\D, ? getprotobyname($proto)
+ : getprotobynumber($proto);
+
+ $proto = $proto[2] || undef;
+ }
+
+ if(defined $port) {
+ $port =~ s,\((\d+)\)$,,;
+
+ my $defport = $1 || undef;
+ my $pnum = ($port =~ m,^(\d+)$,)[0];
+
+ @serv= getservbyname($port, $proto[0] || "")
+ if($port =~ m,\D,);
+
+ $port = $pnum || $serv[2] || $defport || undef;
+
+ $proto = (getprotobyname($serv[3]))[2] || undef
+ if @serv && !$proto;
+ }
+
+ return ($addr || undef,
+ $port || undef,
+ $proto || undef
+ );
+}
+
+sub _error {
+ my $sock = shift;
+ local($!);
+ $@ = join("",ref($sock),": ",@_);
+ close($sock)
+ if(defined fileno($sock));
+ 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});
+
+ $laddr = defined $laddr ? inet_aton($laddr)
+ : INADDR_ANY;
+
+ return _error($sock,"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);
+ }
+
+ $proto ||= (getprotobyname('tcp'))[2];
+
+ my $pname = (getprotobynumber($proto))[0];
+ $type = $arg->{Type} || $socket_type{$pname};
+
+ my @raddr = ();
+
+ if(defined $raddr) {
+ @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
+ return _error($sock,"Bad hostname '",$arg->{PeerAddr},"'")
+ unless @raddr;
+ }
+
+ while(1) {
+
+ $sock->socket(AF_INET, $type, $proto) or
+ return _error($sock,"$!");
+
+ if ($arg->{Reuse}) {
+ $sock->sockopt(SO_REUSEADDR,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;
+ }
+
+ $raddr = shift @raddr;
+
+ return _error($sock,'Cannot determine remote port')
+ unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
+
+ last
+ unless($type == SOCK_STREAM || defined $raddr);
+
+ return _error($sock,"Bad hostname '",$arg->{PeerAddr},"'")
+ unless defined $raddr;
+
+# my $timeout = ${*$sock}{'io_socket_timeout'};
+# my $before = time() if $timeout;
+
+ if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
+# ${*$sock}{'io_socket_timeout'} = $timeout;
+ return $sock;
+ }
+
+ return _error($sock,"$!")
+ unless @raddr;
+
+# if ($timeout) {
+# my $new_timeout = $timeout - (time() - $before);
+# return _error($sock, "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
+ Reuse Set SO_REUSEADDR before binding
+ Timeout Timeout value for various operations
+ MultiHomed Try all adresses for multi-homed hosts
+
+
+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 connaect 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.
+
+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');
+
+
+ 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
+
+=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 E<lt>F<gbarr@pobox.com>E<gt>
+
+=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
--- /dev/null
+# 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;
+use vars qw(@ISA $VERSION);
+use IO::Socket;
+use Socket;
+use Carp;
+
+@ISA = qw(IO::Socket);
+$VERSION = "1.20";
+
+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}) {
+ $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 E<lt>F<gbarr@pobox.com>E<gt>
+
+=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
--- /dev/null
+/*
+ * 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)
+ * try to emulate it as closely as possible using select()
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.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) /* VMS handles sockets via vmsish.h */
+# include <sys/socket.h>
+#endif
+#include <sys/stat.h>
+#include <errno.h>
+
+#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(fds, nfds, timeout)
+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 < 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 < 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 */
--- /dev/null
+/*
+ * 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(I_POLL) || defined(POLLWRBAND)
+# include <poll.h>
+# ifndef HAS_POLL
+# define HAS_POLL
+# endif
+#else
+#ifdef HAS_SELECT
+
+
+/* We shall emulate poll using select */
+
+#define EMULATE_POLL_WITH_SELECT
+
+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 */
+
--- /dev/null
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\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";
+}
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+ require Config; import Config;
+ if ($] < 5.00326 || not $Config{'d_readdir'}) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+use IO::Dir qw(DIR_UNLINK);
+
+print "1..10\n";
+
+$dot = new IO::Dir ".";
+print defined($dot) ? "ok" : "not ok", " 1\n";
+
+@a = sort <*>;
+do { $first = $dot->read } while defined($first) && $first =~ /^\./;
+print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
+
+@b = sort($first, (grep {/^[^.]/} $dot->read));
+print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n";
+
+$dot->rewind;
+@c = sort grep {/^[^.]/} $dot->read;
+print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n";
+
+$dot->close;
+$dot->rewind;
+print defined($dot->read) ? "not ok" : "ok", " 5\n";
+
+open(FH,'>X') || die "Can't create x";
+print FH "X";
+close(FH);
+
+tie %dir, IO::Dir, ".";
+my @files = keys %dir;
+
+# I hope we do not have an empty dir :-)
+print @files ? "ok" : "not ok", " 6\n";
+
+my $stat = $dir{'X'};
+print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1
+ ? "ok" : "not ok", " 7\n";
+
+delete $dir{'X'};
+
+print -f 'X' ? "ok" : "not ok", " 8\n";
+
+tie %dirx, IO::Dir, ".", DIR_UNLINK;
+
+my $statx = $dirx{'X'};
+print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1
+ ? "ok" : "not ok", " 9\n";
+
+delete $dirx{'X'};
+
+print -f 'X' ? "not ok" : "ok", " 10\n";
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+$| = 1;
+
+print "1..8\n";
+
+
+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";
+ print "ok 3\n" if $addr eq "10.250.230.10";
+ print "ok 4\n" if $addr eq "10.250.230.12";
+ }
+ $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;
+}
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print "1..8\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);
+
+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";
}
$| = 1;
-print "1..5\n";
+print "1..14\n";
use IO::Socket;
$listen = IO::Socket::INET->new(Listen => 2,
Proto => 'tcp',
+ Timeout => 2,
) or die "$!";
print "ok 1\n";
Proto => 'tcp',
PeerAddr => 'localhost'
)
- or die "$! (maybe your system does not have the 'localhost' address defined)";
+ or die "$! (maybe your system does not have the 'localhost' address defined)";
$sock->autoflush(1);
die;
}
+# Test various other ways to create INET sockets that should
+# also work.
+$listen = IO::Socket::INET->new(Listen => '', Timeout => 2) 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");
+ 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(1);
+
+ $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");
+ if ($sock) {
+ $sock->print("ok 11\n");
+ $sock->print("quit\n");
+ }
+ $sock = undef;
+ sleep(1);
+ exit;
+} else {
+ die;
+}
+
+# Then test UDP sockets
+$server = IO::Socket->new(Domain => AF_INET,
+ Proto => 'udp',
+ LocalAddr => 'localhost');
+$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");
+ $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";
+$server->blocking(0);
+print "not " if $server->blocking;
+print "ok 14\n";
}
}
+sub compare_addr {
+ my $a = shift;
+ my $b = shift;
+ my @a = unpack_sockaddr_in($a);
+ my @b = unpack_sockaddr_in($b);
+ "$a[0]$a[1]" eq "$b[0]$b[1]";
+}
+
$| = 1;
-print "1..3\n";
+print "1..7\n";
use Socket;
use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
or die "$! (maybe your system does not have the 'localhost' address defined)";
+
+print "ok 1\n";
+
$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
or die "$! (maybe your system does not have the 'localhost' address defined)";
-print "ok 1\n";
+print "ok 2\n";
+
+$udpa->send("ok 4\n",0,$udpb->sockname);
-$udpa->send("ok 2\n",0,$udpb->sockname);
-$udpb->recv($buf="",5);
+print "not " unless compare_addr($udpa->peername,$udpb->sockname);
+print "ok 3\n";
+
+my $where = $udpb->recv($buf="",5);
print $buf;
-$udpb->send("ok 3\n");
+
+my @xtra = ();
+
+unless(compare_addr($where,$udpa->sockname)) {
+ print "not ";
+ @xtra = (0,$udpa->sockname);
+}
+print "ok 5\n";
+
+$udpb->send("ok 6\n",@xtra);
$udpa->recv($buf="",5);
print $buf;
+
+print "not " if $udpa->connected;
+print "ok 7\n";
--- /dev/null
+
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+$PATH = "/tmp/sock-$$";
+
+# Test if we can create the file within the tmp directory
+if (-e $PATH or not open(TEST, ">$PATH")) {
+ print "1..0\n";
+ exit 0;
+}
+close(TEST);
+unlink($PATH) 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) || die "$!";
+print "ok 1\n";
+
+if($pid = fork()) {
+
+ $sock = $listen->accept();
+ print "ok 2\n";
+
+ print $sock->getline();
+
+ print $sock "ok 4\n";
+
+ $sock->close;
+
+ waitpid($pid,0);
+ unlink($PATH) || warn "Can't unlink $PATH: $!";
+
+ print "ok 5\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;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff