From: Gurusamy Sarathy Date: Sat, 28 Nov 1998 16:08:07 +0000 (+0000) Subject: add IO-1.20; mess with t/lib/io_*.t in an attempt to X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cf7fe8a27ac6ee8776974a7c83e80425f2ec0ff8;p=p5sagit%2Fp5-mst-13.2.git add IO-1.20; mess with t/lib/io_*.t in an attempt to keep platform hacks that aren't in the 1.20 dist; add new files to MANIFEST; hack Makefile.PL; result hasn't been tested anywhere p4raw-id: //depot/perl@2354 --- diff --git a/MANIFEST b/MANIFEST index e6ab011..116a183 100644 --- a/MANIFEST +++ b/MANIFEST @@ -224,16 +224,21 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module 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 @@ -1020,13 +1025,18 @@ t/lib/h2ph.h Test header file for h2ph 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 diff --git a/ext/IO/ChangeLog b/ext/IO/ChangeLog new file mode 100644 index 0000000..28bc431 --- /dev/null +++ b/ext/IO/ChangeLog @@ -0,0 +1,316 @@ +Change 173 on 1998/07/14 by (Graham Barr) + + IO::Socket + - Added method connected + + IO.xs + - Added check that file * is not null + + t/io_udp.t + - Added check for connected + - Made change to catch recv not returning the address, and added a fix to + ensure test does not hang + + t/io_sock.t + - Added check for connected. + +Change 137 on 1998/05/21 by (Graham Barr) + + IO::Socket::INET + - Added checks to all peer* and host* methods for undef + +Change 134 on 1998/05/09 by (Graham Barr) + + t/io_sock.t + - fix race condition on Solaris & SunOS + + IO::Handle + - Applied patch from Gisle Aas for + documentation update + - Applied patch from Kuma + changed input_line_number to be on a per-handle basis. + + IO::File + - Applied patch from Gisle Aas for + documentation update + + IO::Seekable + - Applied patch from Gisle Aas for + documentation update + added sysseek + + IO, IO::Socket::INET + - documentation update + + IO.xs + - Applied patch from Gisle Aas for + blocking + +Change 133 on 1998/05/09 by (Graham Barr) + + t/io_sock.t + - Added checks for blocking() + +Sun Apr 12 1998 (Graham Barr) + + IO.xs + - enclosed newCONSTSUB in #ifdef as _64 now defines it. + +Thu Mar 19 1998 (Graham Barr) + + All + - Changed copyright/distribution policy back to be the same as perl + +Sun Feb 15 1998 (Graham Barr) + + IO::Socket + - Fix to ->accept, accept() returns false on error not undef. + +*** Release 1.19 + +Thu Feb 5 1998 (Graham Barr) + + All + - change copyright notice + + IO::Socket::INET + - changed configure to accept PeerHost and LocalHost as well as the + PeerAddr and LocalAddr arguments. + +Mon Feb 2 1998 (Graham Barr) + + IO::Handle + - Added printflush so that flush.pl can be depreciated + + IO::Socket + - Remove C statement as it was not needed + +Tue Jan 27 1998 (Graham Barr) + + IO::Socket::INET + - removed carp if $^W + +*** Patch 1.1804 + +Sat Jan 17 1998 (Graham Barr) + + t/io_sock.t + - Replaced C 0> with C 'localhost'> + + IO/Socket/INET.pm + - Modified the MultiHomed code. Now each address for a given host has + a timeout of C. + - added _get_addr method for doing hostname lookups. Now Net::DNS can be + use by sub-classing IO::Socket::INET, Thanks Gisle Aas + + t/io_multihomed.t + - new test added. Thanks Gisle Aas. + +*** Patch 1.1803 + +Mon Nov 17 1997 (Graham Barr) + + poll.c + - Added #ifdef I_* tests + + IO::Socket + - Changed initialization of @domain2pkg to fix problem of Domain option + not working + - Added patch for multi-homed hosts, Thanks to Gisle Aas + + IO::Socket::INET + - Change default proto to getprotobyname instead of 'tcp' constant string + - Added patch for multi-homed hosts, Thanks to Gisle Aas + + t/io_sock.t + - Change to test fix for Domain problem fixed in IO::Socket and be + more comprehensive, Thanks to Gisle Aas + + t/io_unix.t + - New test, Thanks to Gisle Aas + +*** Patch 1.1802 + +Wed Nov 12 1997 (Graham Barr) + + t/io_poll.t + - test 4 made an assumption that was not portable, fixed. + +*** Patch 1.1801 + +Wed Oct 22 1997 (Graham Barr) + + IO.xs + - change #ifdef's to allow compilation with 5.002 + + IO::Socket + - Fix to ensure that socket is not returned as non-blocking + unless the user asks for it + + t/io_udp.t + - Fix to stop endless loop + +*** Release 1.18 + +Mon Oct 13 1997 (Graham Barr) + + IO.xs, IO::Handle + - 1.17 broke compatability with 5.003, small tweaks to restore + compatability + + t/io_const.t + - Added new test to ensure backwards compatability with constants + is not broken + +Wed Oct 8 1997 (Graham Barr) + + IO.xs + - Added #define's to cope with argument changes to start_subparse + from 5.003_22, _23 and _24 + + IO::Select + - Renamed has_error to be has_exception which is more correct, + has_error is a wrapper around has_exception with a warning if + $^W is set. + + Makefile.PL + - Remove 'linkext' option to WriteMakefile so that static linking + should work properly, cannot remember why I added it. + +Sun Oct 5 1997 (Graham Barr) + + IO::Pipe + - GLOB assignment does not copy the fileno while under -T + added checks for undefined fileno, and added fdopen + - reader and write can now be called as static methods + + Makefile.PL + - Attempt to locate and define I_POLL if found + +*** Release 1.17 + +Fri Sep 26 1997 (Graham Barr) + + IO.xs + - Fix bug in _poll for ANSI C compilers + + IO::Socket + - Split IO::Socket::INET and IO::Socket::UNIX into separate files + + IO::File + - Patch to open() for when file is in current directory. + +*** Release 1.16 + +Mon 15 Sep 1997 Graham Barr + + o New modules + - IO::Dir + - IO::Poll + + o IO::Socket + - Changed new to call autoflush on the new socket + - IO::Socket::INET->new now accepts a single argument + - IO::Socket::INET default to protocol 'tcp' + + o IO::File + - Added doc for new_tmpfile + + o IO::Handle + - Removed use of AutoLoader for constants, constants are + now defined as constant XS subs + - Added fsync, but will not be avaliable for use + unless HAS_FSYNC is defined, perls configure does not define + this yet. + - Moved bootstrap of IO.xs to IO.pm. IO::Handle no longer + contains an AUTOLOAD sub in it's ISA hier + + o IO::Seekable + - Remove clearerr, as it is defined in IO.xs + + o IO.xs + - Patched IO.xs with patch from Chip for setvbuf warning + - Added XS sub "constant" for backwards compatability + + o Misc + - Fixed IO::Socket::configure, it was not passing $arg to domain + specific package + - Changed all $fh variables in IO::Handle to $io and all $fh + variables in IO::Socket to $sock as Chip suggested + - Fixed usage messages to be consistant + +*** Release 1.15 + +Sun 19 Jan 1997 Graham Barr + + o Updated PODs for IO::Handle and IO::File + o Modified IO.xs so that DESTROY gets called on IO::File + objects that were created with IO::File->new_tmpfile + o Modified the domain2pkg code in IO::Socket so that it + does not use blessd refs + o Created a new package IO::Pipe::End so that pipe specific + stuff can be moved out of IO::Handle. + o Added Ilya's OS/2 changes to Pipe.pm and io_pipe.t + + o These changes happened somtime before the release of 1.15 + - added shutdown to IO::Socket + - modified connect to not use alarm + - modified accept and connect to use IO::Select + +*** Release 1.14 + +Tue 24 Dec 1996 Graham Barr + + o Updated to patches in perl core dist. + o Added C to all modules + o Modified t/io_sock.t, hopefully the race condition has gone + o Added close statements to reader/writer in IO::Pipe + o IO::Handle::syswrite was calling sysread, fixed :-) + +*** Release 1.12 + +Thu 19 Sep 1996 Graham Barr + + o Modified IO.xs so that it will compile with pre perlio version + of perl (ie pre perl5.003_02) + o Modified IO::Socket::send so not to pass 4 arguments to send + if the socket is connected + +*** Release 1.10 + +Mon 11 Sep 1996 Graham Barr + + o Fixed a bug in IO::Socket which caused DESTROY to be called + on a partly initialised connection + o Changed IO.xs to use Perlio + o Modified usage message to report correct package + o Added IO::File::new changes from Chip, to allow PERM to be passed + o Added sysread and syswrite methods to IO::Handle + o Updated documentation + o Fixed a bug in IO::Select that caused a hang if the last handle + was removed. + o Added count method to IO::Select + o Renamed and modified tests so that they can be copied into the + perl distribution + o Added fcntl and ioctl methods to IO::Handle + +Thu 25 Jul 1996 Graham Barr + + o It is now not necessary to call the domain sub-classes of + IO::Socket. when connect is called it notes the domain. + Domain specific methods, which are normally non-critical, are + called via this note-ing. + o Added methods to IO::Socket to retrieve the domain, type and + protocol of a given socket + +Tue 23 Jul 1996 Graham Barr + + o IO::Socket::connect changed how we do timeouts, as it did not work + + o IO::Handle::new_from_fd removed method call to _ref_fd, which was + a leftover from FileHandle + +Fri 28 Jun 1996 Graham Barr + + o Modified IO::Socket::UNIX::configure to default to using a socket + type of SOCK_STREAM if no type is specified. diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm index 4d4c81c..b6ce216 100644 --- a/ext/IO/IO.pm +++ b/ext/IO/IO.pm @@ -2,6 +2,28 @@ 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 @@ -20,17 +42,10 @@ Currently this includes: 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; - diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index a434cca..a434d08 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -1,20 +1,19 @@ +/* + * Copyright (c) 1997-8 Graham Barr . All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + */ + #include "EXTERN.h" #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" - +#include "poll.h" #ifdef I_UNISTD # include #endif -#ifdef I_FCNTL -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#define _NO_OLDNAMES -#endif +#if defined(I_FCNTL) || defined(HAS_FCNTL) # include -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#undef _NO_OLDNAMES -#endif - #endif #ifdef PerlIO @@ -28,63 +27,168 @@ typedef FILE * InputStream; 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 * @@ -101,7 +205,7 @@ fgetpos(handle) ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } else { - ST(0) = &PL_sv_undef; + ST(0) = &sv_undef; errno = EINVAL; } @@ -110,12 +214,11 @@ fsetpos(handle, pos) 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; @@ -143,24 +246,63 @@ new_tmpfile(packname = "IO::File") 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) @@ -290,3 +432,91 @@ setvbuf(handle, buf, type, size) 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 +} diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL index 6a2d50d..05c7227 100644 --- a/ext/IO/Makefile.PL +++ b/ext/IO/Makefile.PL @@ -1,8 +1,24 @@ use ExtUtils::MakeMaker; +use Config qw(%Config); + +#--- Attempt to find + +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. ); diff --git a/ext/IO/README b/ext/IO/README index e855afa..375e2ac 100644 --- a/ext/IO/README +++ b/ext/IO/README @@ -1,4 +1,4 @@ This directory contains files from the IO distribution maintained by -Graham Barr . If you find that you have to modify +Graham Barr . 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. diff --git a/ext/IO/lib/IO/Dir.pm b/ext/IO/lib/IO/Dir.pm new file mode 100644 index 0000000..cb612d5 --- /dev/null +++ b/ext/IO/lib/IO/Dir.pm @@ -0,0 +1,238 @@ +# IO::Dir.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Dir; + +use 5.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 package provides two interfaces to perl's directory reading +routines. + +The first interface is an object approach. C provides an object +constructor and methods, which are just wrappers around perl's built in +directory reading routines. + +=over 4 + +=item new ( [ DIRNAME ] ) + +C is the constuctor for C objects. It accepts one optional +argument which, if given, C will pass to C + +=back + +The following methods are wrappers for the directory related functions built +into perl (the trailing `dir' has been removed from the names). See L +for details of these functions. + +=over 4 + +=item open ( DIRNAME ) + +=item read () + +=item seek ( POS ) + +=item tell () + +=item rewind () + +=item close () + +=back + +C also provides 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, from the C package, +C, C and C. + +=over 4 + +=item tie %hash, IO::Dir, DIRNAME [, OPTIONS ] + +=back + +The keys of the HASH will be the names of the entries in the directory. +Reading a value from the hash will be the result of calling +C. Deleting an element from the hash will call C +providing that C is passed in the C. + +Assigning to an entry in the HASH will cause the time stamps of the file +to be modified. If the file does not exist then it will be created. Assigning +a single integer to a HASH element will cause both the access and +modification times to be changed to that value. Alternatively a reference to +an array of two values can be passed. The first array element will be used to +set the access time and the second element will be used to set the modification +time. + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Graham Barr EFE + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index de7fabc..fa7e804 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -49,7 +49,7 @@ these classes with methods that are specific to file handles. =over 4 -=item new ([ ARGS ] ) +=item new ( FILENAME [,MODE [,PERMS]] ) Creates a C. If it receives any parameters, they are passed to the method C; if the open fails, the object is destroyed. Otherwise, @@ -72,20 +72,21 @@ Otherwise, it is returned to the caller. =item open( FILENAME [,MODE [,PERMS]] ) C accepts one, two or three parameters. With one parameter, -it is just a front end for the built-in C function. With two +it is just a front end for the built-in C function. With two or three parameters, the first parameter is a filename that may include whitespace or other special characters, and the second parameter is the open mode, optionally followed by a file permission value. If C receives a Perl mode string ("E", "+E", etc.) -or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic -Perl C operator. +or a ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C operator (but protects any special characters). If C is given a numeric mode, it passes that mode and the optional permissions value to the Perl C operator. -For convenience, C 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 exports the O_XXX constants from the +Fcntl module, if this module is available. =back @@ -98,13 +99,13 @@ L =head1 HISTORY -Derived from FileHandle.pm by Graham Barr EFE. +Derived from FileHandle.pm by Graham Barr EFE. =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; @@ -115,7 +116,7 @@ require DynaLoader; @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); -$VERSION = "1.06021"; +$VERSION = "1.08"; @EXPORT = @IO::Seekable::EXPORT; @@ -127,7 +128,6 @@ eval { push(@EXPORT, @O); }; - ################################################ ## Constructor ## diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index 7927641..1063f1a 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -9,21 +9,21 @@ IO::Handle - supply object methods for I/O handles 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; @@ -36,9 +36,7 @@ in the IO hierarchy. If you are reading this documentation, looking for a replacement for the C package, then I suggest you read the documentation -for C - -A C object is a reference to a symbol (see the C package) +for C too. =head1 CONSTRUCTOR @@ -63,87 +61,123 @@ See L for complete descriptions of each of the following supported C 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 for complete descriptions of each of the following -supported C methods: +supported C methods. All of them return the previous +value of the attribute and takes an optional single argument that when +given will set the value. If no argument is given the previous value +is unchanged (except for $io->autoflush will actually turn ON +autoflush by default). - 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 is like an ordinary C 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 +This works like <$io> described in L 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 is like C found in C, that is it is the opposite of read. The wrapper for the perl C function is called C. -=item $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. -=item $fh->clearerr +=item $io->clearerr Clear the given handle's error indicator. +=item $io->sync + +C synchronizes a file's in-memory state with that on the +physical medium. C does not operate at the perlio api level, but +operates on the file descriptor, this means that any data held at the +perlio api level will not be synchronized. To synchronize data that is +buffered at the perlio api level you must use the flush method. C +is not implemented on all platforms. See L. + +=item $io->flush + +C causes perl to flush any buffered data at the perlio api level. +Any unread data in the buffer will be discarded, and any unwritten data +will be written to the underlying file descriptor. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C object. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C will turn on non-blocking IO if +C is false, and turn it off if C is true. + +C will return the value of the previous setting, or the +current setting if C is not given. + +If an error occurs C will return undef and C<$!> will be set. + =back + If the C functions setbuf() and/or setvbuf() are available, then C and C set the buffering policy for an IO::Handle. The calling sequences for the Perl functions @@ -152,7 +186,7 @@ C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter specifies a scalar variable to use as a buffer. WARNING: A variable used as a buffer by C or C must not be modified in any way until the IO::Handle is closed or C or C 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 @@ -160,7 +194,7 @@ scripts: =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 @@ -171,7 +205,8 @@ vulnerability should be kept in mind. =head1 NOTE -A C object is a GLOB reference. Some modules that +A C object is a reference to a symbol/GLOB reference (see +the C package). Some modules that inherit from C may want to keep object related variables in the hash table part of the GLOB. In an attempt to prevent modules trampling on each other I propose the that any such module should prefix @@ -193,22 +228,22 @@ class from C and inherit those methods. =head1 HISTORY -Derived from FileHandle.pm by Graham Barr EFE +Derived from FileHandle.pm by Graham Barr EFE =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 @@ -230,6 +265,9 @@ $XS_VERSION = "1.15"; getline getlines + printflush + flush + SEEK_SET SEEK_CUR SEEK_END @@ -238,30 +276,6 @@ $XS_VERSION = "1.15"; _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. ## @@ -269,18 +283,18 @@ sub AUTOLOAD { 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; } # @@ -307,8 +321,8 @@ sub _open_mode_string { } 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) { @@ -321,15 +335,15 @@ sub fdopen { $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); } ################################################ @@ -340,39 +354,39 @@ sub close { # 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>; } @@ -380,41 +394,41 @@ sub getline { *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]); } @@ -423,34 +437,44 @@ sub stat { ## 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; } @@ -490,50 +514,82 @@ sub format_top_name { } 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; diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm index ae6d9a5..59f6293 100644 --- a/ext/IO/lib/IO/Pipe.pm +++ b/ext/IO/lib/IO/Pipe.pm @@ -1,7 +1,7 @@ # IO::Pipe.pm # -# Copyright (c) 1996 Graham Barr . All rights -# reserved. This program is free software; you can redistribute it and/or +# Copyright (c) 1996-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package IO::Pipe; @@ -14,7 +14,7 @@ use vars qw($VERSION); use Carp; use Symbol; -$VERSION = "1.0901"; +$VERSION = "1.12"; sub new { my $type = shift; @@ -65,7 +65,7 @@ sub _doit { } bless $io, "IO::Handle"; $io->fdopen($fh, $mode); - $fh->close; + $fh->close; if ($do_spawn) { $pid = eval { system 1, @_ }; # 1 == P_NOWAIT @@ -88,8 +88,12 @@ sub _doit { } 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(@_); @@ -97,6 +101,8 @@ sub reader { 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; @@ -105,8 +111,12 @@ sub reader { } 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(@_); @@ -114,6 +124,8 @@ sub writer { 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; @@ -143,7 +155,7 @@ __END__ =head1 NAME -IO::pipe - supply object methods for pipes +IO::Pipe - supply object methods for pipes =head1 SYNOPSIS @@ -228,12 +240,12 @@ L =head1 AUTHOR -Graham Barr +Graham Barr =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 . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. =cut diff --git a/ext/IO/lib/IO/Poll.pm b/ext/IO/lib/IO/Poll.pm new file mode 100644 index 0000000..3a31eb9 --- /dev/null +++ b/ext/IO/lib/IO/Poll.pm @@ -0,0 +1,204 @@ +# IO::Poll.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Poll; + +use strict; +use IO::Handle; +use Exporter (); +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 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. + +=item remove ( IO ) + +Remove IO from the list of file descriptors for the next poll. + +=item handles( [ EVENT_MASK ] ) + +Returns a list of handles. If EVENT_MASK is not given then a list of all +handles known will be returned. If EVENT_MASK is given then a list +of handles will be returned which had one of the events specified by +EVENT_MASK happen during the last call ti C + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Graham Barr + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm index 91c381a..de982ed 100644 --- a/ext/IO/lib/IO/Seekable.pm +++ b/ext/IO/lib/IO/Seekable.pm @@ -19,16 +19,17 @@ be inherited by other C based objects. It provides methods which allow seeking of the file descriptors. If the C functions fgetpos() and fsetpos() are available, then -C returns an opaque value that represents the -current position of the IO::File, and C uses +C<$io-Egetpos> returns an opaque value that represents the +current position of the IO::File, and C<$io-Esetpos(POS)> uses that value to return to a previously visited position. See L for complete descriptions of each of the following supported C 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 @@ -39,7 +40,7 @@ L =head1 HISTORY -Derived from FileHandle.pm by Graham Barr Ebodg@tiuk.ti.comE +Derived from FileHandle.pm by Graham Barr Egbarr@pobox.comE =cut @@ -53,15 +54,20 @@ require Exporter; @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]); } diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index dea684a..ccb49b8 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -1,163 +1,16 @@ # 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 . 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 package implements an object approach to the system C static method. - -=item bits() - -Return the bit string suitable as argument to the core select() call. - -=item bits() - -Return the bit string suitable as argument to the core select() call. - -=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) - -C +function call. It allows the user to see what IO handles, see L, +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 object. It is these values that +will be returned when an event occurs. C keeps these values in a +cache which is indexed by the C of the handle, so if more than one +handle with the same C is specified then only the last one is cached. + +Each handle can be an C object, an integer or an array +reference where the first element is a C or an integer. + +=item remove ( HANDLES ) + +Remove all the given handles from the object. This method also works +by the C of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C + +=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 is +the maximum amount of time to wait before returning an empty list. If +C is not given and any handles are registered then the call +will block. + +=item can_write ( [ TIMEOUT ] ) + +Same as C except check for handles that can be written to. + +=item has_exception ( [ TIMEOUT ] ) + +Same as C 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 methods is called or the object is passed to +the C is a static method, that is you call it with the package +name like C. C, C and C are either C +or C objects. C 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 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 EFE + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 406f74d..894190f 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -1,119 +1,13 @@ # IO::Socket.pm # -# Copyright (c) 1996 Graham Barr . All rights -# reserved. This program is free software; you can redistribute it and/or +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package IO::Socket; -=head1 NAME - -IO::Socket - Object interface to socket communications - -=head1 SYNOPSIS - - use IO::Socket; - -=head1 DESCRIPTION - -C provides an object interface to creating and using sockets. It -is built upon the L interface and inherits all the methods defined -by L. - -C 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 - -C will export all functions (and constants) defined by L. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C, which is a reference to a -newly created symbol (see the C package). C -optionally takes arguments, these arguments are in key-value pairs. -C only looks for one key C 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. - -Cs 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 for complete descriptions of each of the following -supported C 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 -in attempt to make the interface more flexible. These are - -=over 4 - -=item accept([PKG]) - -perform the system call C on the socket and return a new object. The -new object will be created in the same class as the listen socket, unless -C 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; @@ -121,9 +15,14 @@ use strict; 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; @@ -133,16 +32,17 @@ sub import { 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) = @_; @@ -150,7 +50,7 @@ sub register_domain { } sub configure { - my($fh,$arg) = @_; + my($sock,$arg) = @_; my $domain = delete $arg->{Domain}; croak 'IO::Socket: Cannot configure a generic socket' @@ -160,107 +60,119 @@ sub configure { 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) @@ -270,40 +182,46 @@ sub accept { } 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; @@ -312,16 +230,21 @@ sub recv { ${*$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) @@ -330,399 +253,166 @@ sub getsockopt { } 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 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 [:] - PeerPort Remote port or service [()] | - LocalAddr Local host bind address hostname[:port] - LocalPort Local host bind port [()] | - 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 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 can be a hostname or the IP-address on the -"xx.xx.xx.xx" form. The C 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 specification can also be embedded in the C -by preceding it with a ":". - -If C is not given and you specify a symbolic C port, -then the constructor will try to derive C from the service -name. As a last resort C "tcp" is assumed. The C -parameter will be deduced from C if not specified. +=head1 NAME -If the constructor is only passed a single argument, it is assumed to -be a C 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 provides an object interface to creating and using sockets. It +is built upon the L interface and inherits all the methods defined +by L. - $sock = IO::Socket::INET->new('127.0.0.1:25'); +C 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 +C will export all functions (and constants) defined by L. -=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, which is a reference to a +newly created symbol (see the C package). C +optionally takes arguments, these arguments are in key-value pairs. +C only looks for one key C 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 for complete descriptions of each of the following +supported C 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 +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 on the socket and return a new object. The +new object will be created in the same class as the listen socket, unless +C 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 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, L +L, L, L, L =head1 AUTHOR -Graham Barr EFE +Graham Barr EFE =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 . 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 diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm new file mode 100644 index 0000000..ccd0e8f --- /dev/null +++ b/ext/IO/lib/IO/Socket/INET.pm @@ -0,0 +1,379 @@ +# IO::Socket::INET.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::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 provides an object interface to creating and using sockets +in the AF_INET domain. It is built upon the L interface and +inherits all the methods defined by L. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C object, which is a reference to a +newly created symbol (see the C package). C +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L, +C provides. + + + PeerAddr Remote host address [:] + PeerHost Synonym for PeerAddr + PeerPort Remote port or service [()] | + LocalAddr Local host bind address hostname[:port] + LocalHost Synonym for LocalAddr + LocalPort Local host bind port [()] | + 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 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 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 can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C 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 specification can also be embedded in the C +by preceding it with a ":". + +If C is not given and you specify a symbolic C port, +then the constructor will try to derive C from the service +name. As a last resort C "tcp" is assumed. The C +parameter will be deduced from C if not specified. + +If the constructor is only passed a single argument, it is assumed to +be a C 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, L + +=head1 AUTHOR + +Graham Barr EFE + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/ext/IO/lib/IO/Socket/UNIX.pm b/ext/IO/lib/IO/Socket/UNIX.pm new file mode 100644 index 0000000..7dc7d0c --- /dev/null +++ b/ext/IO/lib/IO/Socket/UNIX.pm @@ -0,0 +1,142 @@ +# IO::Socket::UNIX.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::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 provides an object interface to creating and using sockets +in the AF_UNIX domain. It is built upon the L interface and +inherits all the methods defined by L. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C object, which is a reference to a +newly created symbol (see the C package). C +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L, +C 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 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, L + +=head1 AUTHOR + +Graham Barr EFE + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/ext/IO/poll.c b/ext/IO/poll.c new file mode 100644 index 0000000..50a5151 --- /dev/null +++ b/ext/IO/poll.c @@ -0,0 +1,132 @@ +/* + * poll.c + * + * Copyright (c) 1997-8 Graham Barr . All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + * + * 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 +#endif +#ifdef I_TIME +# include +#endif +#include +#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ +# include +#endif +#include +#include + +#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 */ diff --git a/ext/IO/poll.h b/ext/IO/poll.h new file mode 100644 index 0000000..d17edff --- /dev/null +++ b/ext/IO/poll.h @@ -0,0 +1,58 @@ +/* + * poll.h + * + * Copyright (c) 1997-8 Graham Barr . All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + * + */ + +#ifndef POLL_H +# define POLL_H + +#if defined(I_POLL) || defined(POLLWRBAND) +# include +# 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 */ + diff --git a/t/lib/io_const.t b/t/lib/io_const.t new file mode 100755 index 0000000..3d747f1 --- /dev/null +++ b/t/lib/io_const.t @@ -0,0 +1,33 @@ + +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"; +} diff --git a/t/lib/io_dir.t b/t/lib/io_dir.t new file mode 100755 index 0000000..889e35c --- /dev/null +++ b/t/lib/io_dir.t @@ -0,0 +1,66 @@ +#!./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"; diff --git a/t/lib/io_multihomed.t b/t/lib/io_multihomed.t new file mode 100644 index 0000000..20ecf6e --- /dev/null +++ b/t/lib/io_multihomed.t @@ -0,0 +1,110 @@ +#!./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; +} diff --git a/t/lib/io_poll.t b/t/lib/io_poll.t new file mode 100755 index 0000000..d907d54 --- /dev/null +++ b/t/lib/io_poll.t @@ -0,0 +1,66 @@ +#!./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"; diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t index 8fc52e4..60f5b5a 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -22,12 +22,13 @@ BEGIN { } $| = 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"; @@ -69,7 +70,7 @@ if($pid = fork()) { 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); @@ -84,8 +85,99 @@ if($pid = fork()) { 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"; diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index 014e12d..88cb4b6 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -21,8 +21,16 @@ BEGIN { } } +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); @@ -35,14 +43,33 @@ 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"; diff --git a/t/lib/io_unix.t b/t/lib/io_unix.t new file mode 100644 index 0000000..3d9ed50 --- /dev/null +++ b/t/lib/io_unix.t @@ -0,0 +1,72 @@ + +#!./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; +}