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
pod/perlport.pod Portability guide
pod/perlre.pod Regular expression info
pod/perlref.pod References info
+pod/perlreftut.pod Mark's references tutorial
pod/perlrun.pod Execution info
pod/perlsec.pod Security info
pod/perlstyle.pod Style info
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
struct subst {
I32 sbu_iters;
I32 sbu_maxiters;
- I32 sbu_safebase;
+ I32 sbu_rflags;
I32 sbu_oldsave;
bool sbu_once;
bool sbu_rxtainted;
};
#define sb_iters cx_u.cx_subst.sbu_iters
#define sb_maxiters cx_u.cx_subst.sbu_maxiters
-#define sb_safebase cx_u.cx_subst.sbu_safebase
+#define sb_rflags cx_u.cx_subst.sbu_rflags
#define sb_oldsave cx_u.cx_subst.sbu_oldsave
#define sb_once cx_u.cx_subst.sbu_once
#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted
#define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
cx->sb_iters = iters, \
cx->sb_maxiters = maxiters, \
- cx->sb_safebase = safebase, \
+ cx->sb_rflags = r_flags, \
cx->sb_oldsave = oldsave, \
cx->sb_once = once, \
cx->sb_rxtainted = rxtainted, \
#define refkids Perl_refkids
#define regdump Perl_regdump
#define regexec_flags Perl_regexec_flags
+#define reginitcolors Perl_reginitcolors
#define regnext Perl_regnext
#define regprop Perl_regprop
#define repeatcpy Perl_repeatcpy
#define reghopmaybe CPerlObj::Perl_reghopmaybe
#define reginclass CPerlObj::Perl_reginclass
#define reginclassutf8 CPerlObj::Perl_reginclassutf8
+#define reginitcolors CPerlObj::Perl_reginitcolors
#define reginsert CPerlObj::Perl_reginsert
#define regmatch CPerlObj::Perl_regmatch
#define regnext CPerlObj::Perl_regnext
#define restore_expect CPerlObj::Perl_restore_expect
#define restore_lex_expect CPerlObj::Perl_restore_lex_expect
#define restore_magic CPerlObj::Perl_restore_magic
+#define restore_pos CPerlObj::Perl_restore_pos
#define restore_rsfp CPerlObj::Perl_restore_rsfp
#define rninstr CPerlObj::Perl_rninstr
#define rsignal CPerlObj::Perl_rsignal
regcppop
regcp_set_to
cache_re
+ restore_pos
reghop
reghopmaybe
dump
#define PL_op (PL_curinterp->Top)
#define PL_opsave (PL_curinterp->Topsave)
#define PL_reg_call_cc (PL_curinterp->Treg_call_cc)
+#define PL_reg_curpm (PL_curinterp->Treg_curpm)
#define PL_reg_eval_set (PL_curinterp->Treg_eval_set)
#define PL_reg_flags (PL_curinterp->Treg_flags)
+#define PL_reg_ganch (PL_curinterp->Treg_ganch)
+#define PL_reg_magic (PL_curinterp->Treg_magic)
+#define PL_reg_oldcurpm (PL_curinterp->Treg_oldcurpm)
+#define PL_reg_oldpos (PL_curinterp->Treg_oldpos)
#define PL_reg_re (PL_curinterp->Treg_re)
#define PL_reg_start_tmp (PL_curinterp->Treg_start_tmp)
#define PL_reg_start_tmpl (PL_curinterp->Treg_start_tmpl)
+#define PL_reg_starttry (PL_curinterp->Treg_starttry)
+#define PL_reg_sv (PL_curinterp->Treg_sv)
#define PL_regbol (PL_curinterp->Tregbol)
#define PL_regcc (PL_curinterp->Tregcc)
#define PL_regcode (PL_curinterp->Tregcode)
#define PL_Top PL_op
#define PL_Topsave PL_opsave
#define PL_Treg_call_cc PL_reg_call_cc
+#define PL_Treg_curpm PL_reg_curpm
#define PL_Treg_eval_set PL_reg_eval_set
#define PL_Treg_flags PL_reg_flags
+#define PL_Treg_ganch PL_reg_ganch
+#define PL_Treg_magic PL_reg_magic
+#define PL_Treg_oldcurpm PL_reg_oldcurpm
+#define PL_Treg_oldpos PL_reg_oldpos
#define PL_Treg_re PL_reg_re
#define PL_Treg_start_tmp PL_reg_start_tmp
#define PL_Treg_start_tmpl PL_reg_start_tmpl
+#define PL_Treg_starttry PL_reg_starttry
+#define PL_Treg_sv PL_reg_sv
#define PL_Tregbol PL_regbol
#define PL_Tregcc PL_regcc
#define PL_Tregcode PL_regcode
#define PL_op (thr->Top)
#define PL_opsave (thr->Topsave)
#define PL_reg_call_cc (thr->Treg_call_cc)
+#define PL_reg_curpm (thr->Treg_curpm)
#define PL_reg_eval_set (thr->Treg_eval_set)
#define PL_reg_flags (thr->Treg_flags)
+#define PL_reg_ganch (thr->Treg_ganch)
+#define PL_reg_magic (thr->Treg_magic)
+#define PL_reg_oldcurpm (thr->Treg_oldcurpm)
+#define PL_reg_oldpos (thr->Treg_oldpos)
#define PL_reg_re (thr->Treg_re)
#define PL_reg_start_tmp (thr->Treg_start_tmp)
#define PL_reg_start_tmpl (thr->Treg_start_tmpl)
+#define PL_reg_starttry (thr->Treg_starttry)
+#define PL_reg_sv (thr->Treg_sv)
#define PL_regbol (thr->Tregbol)
#define PL_regcc (thr->Tregcc)
#define PL_regcode (thr->Tregcode)
--- /dev/null
+Change 173 on 1998/07/14 by <gbarr@pobox.com> (Graham Barr)
+
+ IO::Socket
+ - Added method connected
+
+ IO.xs
+ - Added check that file * is not null
+
+ t/io_udp.t
+ - Added check for connected
+ - Made change to catch recv not returning the address, and added a fix to
+ ensure test does not hang
+
+ t/io_sock.t
+ - Added check for connected.
+
+Change 137 on 1998/05/21 by <gbarr@pobox.com> (Graham Barr)
+
+ IO::Socket::INET
+ - Added checks to all peer* and host* methods for undef
+
+Change 134 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr)
+
+ t/io_sock.t
+ - fix race condition on Solaris & SunOS
+
+ IO::Handle
+ - Applied patch from Gisle Aas <gisle@aas.no> for
+ documentation update
+ - Applied patch from Kuma <tgy@chocobo.org>
+ changed input_line_number to be on a per-handle basis.
+
+ IO::File
+ - Applied patch from Gisle Aas <gisle@aas.no> for
+ documentation update
+
+ IO::Seekable
+ - Applied patch from Gisle Aas <gisle@aas.no> for
+ documentation update
+ added sysseek
+
+ IO, IO::Socket::INET
+ - documentation update
+
+ IO.xs
+ - Applied patch from Gisle Aas <gisle@aas.no> for
+ blocking
+
+Change 133 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr)
+
+ t/io_sock.t
+ - Added checks for blocking()
+
+Sun Apr 12 1998 <gbarr@pobox.com> (Graham Barr)
+
+ IO.xs
+ - enclosed newCONSTSUB in #ifdef as _64 now defines it.
+
+Thu Mar 19 1998 <gbarr@pobox.com> (Graham Barr)
+
+ All
+ - Changed copyright/distribution policy back to be the same as perl
+
+Sun Feb 15 1998 <gbarr@pobox.com> (Graham Barr)
+
+ IO::Socket
+ - Fix to ->accept, accept() returns false on error not undef.
+
+*** Release 1.19
+
+Thu Feb 5 1998 <gbarr@pobox.com> (Graham Barr)
+
+ All
+ - change copyright notice
+
+ IO::Socket::INET
+ - changed configure to accept PeerHost and LocalHost as well as the
+ PeerAddr and LocalAddr arguments.
+
+Mon Feb 2 1998 <gbarr@pobox.com> (Graham Barr)
+
+ IO::Handle
+ - Added printflush so that flush.pl can be depreciated
+
+ IO::Socket
+ - Remove C<use Config> statement as it was not needed
+
+Tue Jan 27 1998 <gbarr@pobox.com> (Graham Barr)
+
+ IO::Socket::INET
+ - removed carp if $^W
+
+*** Patch 1.1804
+
+Sat Jan 17 1998 <gbarr@pobox.com> (Graham Barr)
+
+ t/io_sock.t
+ - Replaced C<Listen => 0> with C<LocalAddr => 'localhost'>
+
+ IO/Socket/INET.pm
+ - Modified the MultiHomed code. Now each address for a given host has
+ a timeout of C<Timeout>.
+ - added _get_addr method for doing hostname lookups. Now Net::DNS can be
+ use by sub-classing IO::Socket::INET, Thanks Gisle Aas
+
+ t/io_multihomed.t
+ - new test added. Thanks Gisle Aas.
+
+*** Patch 1.1803
+
+Mon Nov 17 1997 <gbarr@pobox.com> (Graham Barr)
+
+ poll.c
+ - Added #ifdef I_* tests
+
+ IO::Socket
+ - Changed initialization of @domain2pkg to fix problem of Domain option
+ not working
+ - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no>
+
+ IO::Socket::INET
+ - Change default proto to getprotobyname instead of 'tcp' constant string
+ - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no>
+
+ t/io_sock.t
+ - Change to test fix for Domain problem fixed in IO::Socket and be
+ more comprehensive, Thanks to Gisle Aas <gisle@aas.no>
+
+ t/io_unix.t
+ - New test, Thanks to Gisle Aas <gisle@aas.no>
+
+*** Patch 1.1802
+
+Wed Nov 12 1997 <gbarr@pobox.com> (Graham Barr)
+
+ t/io_poll.t
+ - test 4 made an assumption that was not portable, fixed.
+
+*** Patch 1.1801
+
+Wed Oct 22 1997 <gbarr@pobox.com> (Graham Barr)
+
+ IO.xs
+ - change #ifdef's to allow compilation with 5.002
+
+ IO::Socket
+ - Fix to ensure that socket is not returned as non-blocking
+ unless the user asks for it
+
+ t/io_udp.t
+ - Fix to stop endless loop
+
+*** Release 1.18
+
+Mon Oct 13 1997 <gbarr@pobox.com> (Graham Barr)
+
+ IO.xs, IO::Handle
+ - 1.17 broke compatability with 5.003, small tweaks to restore
+ compatability
+
+ t/io_const.t
+ - Added new test to ensure backwards compatability with constants
+ is not broken
+
+Wed Oct 8 1997 <gbarr@pobox.com> (Graham Barr)
+
+ IO.xs
+ - Added #define's to cope with argument changes to start_subparse
+ from 5.003_22, _23 and _24
+
+ IO::Select
+ - Renamed has_error to be has_exception which is more correct,
+ has_error is a wrapper around has_exception with a warning if
+ $^W is set.
+
+ Makefile.PL
+ - Remove 'linkext' option to WriteMakefile so that static linking
+ should work properly, cannot remember why I added it.
+
+Sun Oct 5 1997 <gbarr@pobox.com> (Graham Barr)
+
+ IO::Pipe
+ - GLOB assignment does not copy the fileno while under -T
+ added checks for undefined fileno, and added fdopen
+ - reader and write can now be called as static methods
+
+ Makefile.PL
+ - Attempt to locate <poll.h> and define I_POLL if found
+
+*** Release 1.17
+
+Fri Sep 26 1997 <gbarr@pobox.com> (Graham Barr)
+
+ IO.xs
+ - Fix bug in _poll for ANSI C compilers
+
+ IO::Socket
+ - Split IO::Socket::INET and IO::Socket::UNIX into separate files
+
+ IO::File
+ - Patch to open() for when file is in current directory.
+
+*** Release 1.16
+
+Mon 15 Sep 1997 <gbarr@pobox.com> Graham Barr
+
+ o New modules
+ - IO::Dir
+ - IO::Poll
+
+ o IO::Socket
+ - Changed new to call autoflush on the new socket
+ - IO::Socket::INET->new now accepts a single argument
+ - IO::Socket::INET default to protocol 'tcp'
+
+ o IO::File
+ - Added doc for new_tmpfile
+
+ o IO::Handle
+ - Removed use of AutoLoader for constants, constants are
+ now defined as constant XS subs
+ - Added fsync, but will not be avaliable for use
+ unless HAS_FSYNC is defined, perls configure does not define
+ this yet.
+ - Moved bootstrap of IO.xs to IO.pm. IO::Handle no longer
+ contains an AUTOLOAD sub in it's ISA hier
+
+ o IO::Seekable
+ - Remove clearerr, as it is defined in IO.xs
+
+ o IO.xs
+ - Patched IO.xs with patch from Chip for setvbuf warning
+ - Added XS sub "constant" for backwards compatability
+
+ o Misc
+ - Fixed IO::Socket::configure, it was not passing $arg to domain
+ specific package
+ - Changed all $fh variables in IO::Handle to $io and all $fh
+ variables in IO::Socket to $sock as Chip suggested
+ - Fixed usage messages to be consistant
+
+*** Release 1.15
+
+Sun 19 Jan 1997 <bodg@tiuk.ti.com> Graham Barr
+
+ o Updated PODs for IO::Handle and IO::File
+ o Modified IO.xs so that DESTROY gets called on IO::File
+ objects that were created with IO::File->new_tmpfile
+ o Modified the domain2pkg code in IO::Socket so that it
+ does not use blessd refs
+ o Created a new package IO::Pipe::End so that pipe specific
+ stuff can be moved out of IO::Handle.
+ o Added Ilya's OS/2 changes to Pipe.pm and io_pipe.t
+
+ o These changes happened somtime before the release of 1.15
+ - added shutdown to IO::Socket
+ - modified connect to not use alarm
+ - modified accept and connect to use IO::Select
+
+*** Release 1.14
+
+Tue 24 Dec 1996 <bodg@tiuk.ti.com> Graham Barr
+
+ o Updated to patches in perl core dist.
+ o Added C<use strict> to all modules
+ o Modified t/io_sock.t, hopefully the race condition has gone
+ o Added close statements to reader/writer in IO::Pipe
+ o IO::Handle::syswrite was calling sysread, fixed :-)
+
+*** Release 1.12
+
+Thu 19 Sep 1996 <bodg@tiuk.ti.com> Graham Barr
+
+ o Modified IO.xs so that it will compile with pre perlio version
+ of perl (ie pre perl5.003_02)
+ o Modified IO::Socket::send so not to pass 4 arguments to send
+ if the socket is connected
+
+*** Release 1.10
+
+Mon 11 Sep 1996 <bodg@tiuk.ti.com> Graham Barr
+
+ o Fixed a bug in IO::Socket which caused DESTROY to be called
+ on a partly initialised connection
+ o Changed IO.xs to use Perlio
+ o Modified usage message to report correct package
+ o Added IO::File::new changes from Chip, to allow PERM to be passed
+ o Added sysread and syswrite methods to IO::Handle
+ o Updated documentation
+ o Fixed a bug in IO::Select that caused a hang if the last handle
+ was removed.
+ o Added count method to IO::Select
+ o Renamed and modified tests so that they can be copied into the
+ perl distribution
+ o Added fcntl and ioctl methods to IO::Handle
+
+Thu 25 Jul 1996 <bodg@tiuk.ti.com> Graham Barr
+
+ o It is now not necessary to call the domain sub-classes of
+ IO::Socket. when connect is called it notes the domain.
+ Domain specific methods, which are normally non-critical, are
+ called via this note-ing.
+ o Added methods to IO::Socket to retrieve the domain, type and
+ protocol of a given socket
+
+Tue 23 Jul 1996 <bodg@tiuk.ti.com> Graham Barr
+
+ o IO::Socket::connect changed how we do timeouts, as it did not work
+
+ o IO::Handle::new_from_fd removed method call to _ref_fd, which was
+ a leftover from FileHandle
+
+Fri 28 Jun 1996 <bodg@tiuk.ti.com> Graham Barr
+
+ o Modified IO::Socket::UNIX::configure to default to using a socket
+ type of SOCK_STREAM if no type is specified.
package IO;
+require DynaLoader;
+require Exporter;
+use Carp;
+
+use vars qw(@ISA $VERSION @EXPORT);
+
+@ISA = qw(DynaLoader);
+$VERSION = "1.20";
+bootstrap IO $VERSION;
+
+sub import {
+ shift;
+ my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir);
+
+ eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l)
+ or croak $@;
+}
+
+1;
+
+__END__
+
=head1 NAME
IO - load various IO modules
IO::File
IO::Pipe
IO::Socket
+ IO::Dir
For more information on any of these modules, please see its respective
documentation.
=cut
-use IO::Handle;
-use IO::Seekable;
-use IO::File;
-use IO::Pipe;
-use IO::Socket;
-
-1;
-
+/*
+ * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ */
+
#include "EXTERN.h"
#define PERLIO_NOT_STDIO 1
#include "perl.h"
#include "XSUB.h"
-
+#include "poll.h"
#ifdef I_UNISTD
# include <unistd.h>
#endif
-#ifdef I_FCNTL
-#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
-#define _NO_OLDNAMES
-#endif
+#if defined(I_FCNTL) || defined(HAS_FCNTL)
# include <fcntl.h>
-#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
-#undef _NO_OLDNAMES
-#endif
-
#endif
#ifdef PerlIO
typedef FILE * OutputStream;
#endif
+#include "patchlevel.h"
+
+#if (PATCHLEVEL < 3) || ((PATCHLEVEL == 3) && (SUBVERSION < 22))
+ /* before 5.003_22 */
+# define MY_start_subparse(fmt,flags) start_subparse()
+#else
+# if (PATCHLEVEL == 3) && (SUBVERSION == 22)
+ /* 5.003_22 */
+# define MY_start_subparse(fmt,flags) start_subparse(flags)
+# else
+ /* 5.003_23 onwards */
+# define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
+# endif
+#endif
+
+#ifndef gv_stashpvn
+#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
static int
not_here(char *s)
{
return -1;
}
-static bool
-constant(char *name, IV *pval)
-{
- switch (*name) {
- case '_':
- if (strEQ(name, "_IOFBF"))
-#ifdef _IOFBF
- { *pval = _IOFBF; return TRUE; }
-#else
- return FALSE;
-#endif
- if (strEQ(name, "_IOLBF"))
-#ifdef _IOLBF
- { *pval = _IOLBF; return TRUE; }
-#else
- return FALSE;
-#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(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 *
InputStream handle
SV * pos
CODE:
- char *p;
- if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t))
+ char *p;
+ STRLEN len;
+ if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t))
#ifdef PerlIO
RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
#else
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;
SvREFCNT_dec(gv);
}
+MODULE = IO PACKAGE = IO::Poll
+
+void
+_poll(timeout,...)
+ int timeout;
+PPCODE:
+{
+#ifdef HAS_POLL
+ int nfd = (items - 1) / 2;
+ SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
+ struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
+ int i,j,ret;
+ for(i=1, j=0 ; j < nfd ; j++) {
+ fds[j].fd = SvIV(ST(i));
+ i++;
+ fds[j].events = SvIV(ST(i));
+ i++;
+ fds[j].revents = 0;
+ }
+ if((ret = poll(fds,nfd,timeout)) >= 0) {
+ for(i=1, j=0 ; j < nfd ; j++) {
+ sv_setiv(ST(i), fds[j].fd); i++;
+ sv_setiv(ST(i), fds[j].revents); i++;
+ }
+ }
+ SvREFCNT_dec(tmpsv);
+ XSRETURN_IV(ret);
+#else
+ not_here("IO::Poll::poll");
+#endif
+}
+
+MODULE = IO PACKAGE = IO::Handle PREFIX = io_
+
+void
+io_blocking(handle,blk=-1)
+ InputStream handle
+ int blk
+PROTOTYPE: $;$
+CODE:
+{
+ int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0);
+ if(ret >= 0)
+ XSRETURN_IV(ret);
+ else
+ XSRETURN_UNDEF;
+}
+
MODULE = IO PACKAGE = IO::Handle PREFIX = f
-SV *
-constant(name)
- char * name
- CODE:
- IV i;
- if (constant(name, &i))
- ST(0) = sv_2mortal(newSViv(i));
- else
- ST(0) = &PL_sv_undef;
int
ungetc(handle, c)
RETVAL
+SysRet
+fsync(handle)
+ OutputStream handle
+ CODE:
+#ifdef HAS_FSYNC
+ if(handle)
+ RETVAL = fsync(PerlIO_fileno(handle));
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+#else
+ RETVAL = (SysRet) not_here("IO::Handle::sync");
+#endif
+ OUTPUT:
+ RETVAL
+
+
+BOOT:
+{
+ HV *stash;
+ /*
+ * constant subs for IO::Poll
+ */
+ stash = gv_stashpvn("IO::Poll", 8, TRUE);
+#ifdef POLLIN
+ newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
+#endif
+#ifdef POLLPRI
+ newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
+#endif
+#ifdef POLLOUT
+ newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
+#endif
+#ifdef POLLRDNORM
+ newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
+#endif
+#ifdef POLLWRNORM
+ newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
+#endif
+#ifdef POLLRDBAND
+ newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
+#endif
+#ifdef POLLWRBAND
+ newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
+#endif
+#ifdef POLLNORM
+ newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
+#endif
+#ifdef POLLERR
+ newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
+#endif
+#ifdef POLLHUP
+ newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
+#endif
+#ifdef POLLNVAL
+ newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
+#endif
+ /*
+ * constant subs for IO::Handle
+ */
+ stash = gv_stashpvn("IO::Handle", 10, TRUE);
+#ifdef _IOFBF
+ newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
+#endif
+#ifdef _IOLBF
+ newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
+#endif
+#ifdef _IONBF
+ newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
+#endif
+#ifdef SEEK_SET
+ newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
+#endif
+#ifdef SEEK_CUR
+ newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
+#endif
+#ifdef SEEK_END
+ newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
+#endif
+ /*
+ * constant subs for IO
+ */
+ stash = gv_stashpvn("IO", 2, TRUE);
+#ifdef EINPROGRESS
+ newCONSTSUB(stash,"EINPROGRESS", newSViv(EINPROGRESS));
+#endif
+}
use ExtUtils::MakeMaker;
+use Config qw(%Config);
+
+#--- Attempt to find <poll.h>
+
+my $define = "";
+
+my @inc = split(/\s+/, join(" ",$Config{'usrinc'},$Config{'incpth'},$Config{'locincpth'}));
+foreach $path (@inc) {
+ if(-f $path . "/poll.h") {
+ $define .= "-DI_POLL ";
+ last;
+ }
+}
+
+#--- Write the Makefile
+
WriteMakefile(
- NAME => 'IO',
- MAN3PODS => {}, # Pods will be built by installman.
- XSPROTOARG => '-noprototypes', # XXX remove later?
- VERSION_FROM => 'lib/IO/Handle.pm',
- XS_VERSION => 1.15
+ VERSION_FROM => "IO.pm",
+ NAME => "IO",
+ OBJECT => '$(O_FILES)',
+ DEFINE => $define,
+ MAN3PODS => {}, # Pods will be built by installman.
);
This directory contains files from the IO distribution maintained by
-Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify
+Graham Barr <gbarr@pobox.com>. If you find that you have to modify
any files in this directory then please forward him a patch for only
the files in this directory.
--- /dev/null
+# IO::Dir.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Dir;
+
+use 5.003_26;
+
+use strict;
+use Carp;
+use Symbol;
+use Exporter;
+use IO::File;
+use vars qw(@ISA $VERSION @EXPORT_OK);
+use Tie::Hash;
+use File::stat;
+
+@ISA = qw(Tie::Hash Exporter);
+$VERSION = "1.03";
+@EXPORT_OK = qw(DIR_UNLINK);
+
+sub DIR_UNLINK () { 1 }
+
+sub new {
+ @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]';
+ my $class = shift;
+ my $dh = gensym;
+ if (@_) {
+ IO::Dir::open($dh, $_[0])
+ or return undef;
+ }
+ bless $dh, $class;
+}
+
+sub DESTROY {
+ my ($dh) = @_;
+ closedir($dh);
+}
+
+sub open {
+ @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
+ my ($dh, $dirname) = @_;
+ return undef
+ unless opendir($dh, $dirname);
+ ${*$dh}{io_dir_path} = $dirname;
+ 1;
+}
+
+sub close {
+ @_ == 1 or croak 'usage: $dh->close()';
+ my ($dh) = @_;
+ closedir($dh);
+}
+
+sub read {
+ @_ == 1 or croak 'usage: $dh->read()';
+ my ($dh) = @_;
+ readdir($dh);
+}
+
+sub seek {
+ @_ == 2 or croak 'usage: $dh->seek(POS)';
+ my ($dh,$pos) = @_;
+ seekdir($dh,$pos);
+}
+
+sub tell {
+ @_ == 1 or croak 'usage: $dh->tell()';
+ my ($dh) = @_;
+ telldir($dh);
+}
+
+sub rewind {
+ @_ == 1 or croak 'usage: $dh->rewind()';
+ my ($dh) = @_;
+ rewinddir($dh);
+}
+
+sub TIEHASH {
+ my($class,$dir,$options) = @_;
+
+ my $dh = $class->new($dir)
+ or return undef;
+
+ $options ||= 0;
+
+ ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK;
+ $dh;
+}
+
+sub FIRSTKEY {
+ my($dh) = @_;
+ $dh->rewind;
+ scalar $dh->read;
+}
+
+sub NEXTKEY {
+ my($dh) = @_;
+ scalar $dh->read;
+}
+
+sub EXISTS {
+ my($dh,$key) = @_;
+ -e ${*$dh}{io_dir_path} . "/" . $key;
+}
+
+sub FETCH {
+ my($dh,$key) = @_;
+ &lstat(${*$dh}{io_dir_path} . "/" . $key);
+}
+
+sub STORE {
+ my($dh,$key,$data) = @_;
+ my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
+ my $file = ${*$dh}{io_dir_path} . "/" . $key;
+ unless(-e $file) {
+ my $io = IO::File->new($file,O_CREAT | O_RDWR);
+ $io->close if $io;
+ }
+ utime($atime,$mtime, $file);
+}
+
+sub DELETE {
+ my($dh,$key) = @_;
+ # Only unlink if unlink-ing is enabled
+ my $file = ${*$dh}{io_dir_path} . "/" . $key;
+
+ return 0
+ unless ${*$dh}{io_dir_unlink};
+
+ -d $file
+ ? rmdir($file)
+ : unlink($file);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Dir - supply object methods for directory handles
+
+=head1 SYNOPSIS
+
+ use IO::Dir;
+ $d = new IO::Dir ".";
+ if (defined $d) {
+ while (defined($_ = $d->read)) { something($_); }
+ $d->rewind;
+ while (defined($_ = $d->read)) { something_else($_); }
+ undef $d;
+ }
+
+ tie %dir, IO::Dir, ".";
+ foreach (keys %dir) {
+ print $_, " " , $dir{$_}->size,"\n";
+ }
+
+=head1 DESCRIPTION
+
+The C<IO::Dir> package provides two interfaces to perl's directory reading
+routines.
+
+The first interface is an object approach. C<IO::Dir> provides an object
+constructor and methods, which are just wrappers around perl's built in
+directory reading routines.
+
+=over 4
+
+=item new ( [ DIRNAME ] )
+
+C<new> is the constuctor for C<IO::Dir> objects. It accepts one optional
+argument which, if given, C<new> will pass to C<open>
+
+=back
+
+The following methods are wrappers for the directory related functions built
+into perl (the trailing `dir' has been removed from the names). See L<perlfunc>
+for details of these functions.
+
+=over 4
+
+=item open ( DIRNAME )
+
+=item read ()
+
+=item seek ( POS )
+
+=item tell ()
+
+=item rewind ()
+
+=item close ()
+
+=back
+
+C<IO::Dir> also provides a interface to reading directories via a tied
+HASH. The tied HASH extends the interface beyond just the directory
+reading routines by the use of C<lstat>, from the C<File::stat> package,
+C<unlink>, C<rmdir> and C<utime>.
+
+=over 4
+
+=item tie %hash, IO::Dir, DIRNAME [, OPTIONS ]
+
+=back
+
+The keys of the HASH will be the names of the entries in the directory.
+Reading a value from the hash will be the result of calling
+C<File::stat::lstat>. Deleting an element from the hash will call C<unlink>
+providing that C<DIR_UNLINK> is passed in the C<OPTIONS>.
+
+Assigning to an entry in the HASH will cause the time stamps of the file
+to be modified. If the file does not exist then it will be created. Assigning
+a single integer to a HASH element will cause both the access and
+modification times to be changed to that value. Alternatively a reference to
+an array of two values can be passed. The first array element will be used to
+set the access time and the second element will be used to set the modification
+time.
+
+=head1 SEE ALSO
+
+L<File::stat>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
=over 4
-=item new ([ ARGS ] )
+=item new ( FILENAME [,MODE [,PERMS]] )
Creates a C<IO::File>. If it receives any parameters, they are passed to
the method C<open>; if the open fails, the object is destroyed. Otherwise,
=item open( FILENAME [,MODE [,PERMS]] )
C<open> accepts one, two or three parameters. With one parameter,
-it is just a front end for the built-in C<open> function. With two
+it is just a front end for the built-in C<open> function. With two or three
parameters, the first parameter is a filename that may include
whitespace or other special characters, and the second parameter is
the open mode, optionally followed by a file permission value.
If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.)
-or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
-Perl C<open> operator.
+or a ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic
+Perl C<open> operator (but protects any special characters).
If C<IO::File::open> is given a numeric mode, it passes that mode
and the optional permissions value to the Perl C<sysopen> operator.
-For convenience, C<IO::File::import> tries to import the O_XXX
-constants from the Fcntl module. If dynamic loading is not available,
-this may fail, but the rest of IO::File will still work.
+The permissions default to 0666.
+
+For convenience, C<IO::File> exports the O_XXX constants from the
+Fcntl module, if this module is available.
=back
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>.
+Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
=cut
require 5.000;
use strict;
-use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
+use vars qw($VERSION @EXPORT @EXPORT_OK @ISA);
use Carp;
use Symbol;
use SelectSaver;
@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
-$VERSION = "1.06021";
+$VERSION = "1.08";
@EXPORT = @IO::Seekable::EXPORT;
push(@EXPORT, @O);
};
-
################################################
## Constructor
##
use IO::Handle;
- $fh = new IO::Handle;
- if ($fh->fdopen(fileno(STDIN),"r")) {
- print $fh->getline;
- $fh->close;
+ $io = new IO::Handle;
+ if ($io->fdopen(fileno(STDIN),"r")) {
+ print $io->getline;
+ $io->close;
}
- $fh = new IO::Handle;
- if ($fh->fdopen(fileno(STDOUT),"w")) {
- $fh->print("Some text\n");
+ $io = new IO::Handle;
+ if ($io->fdopen(fileno(STDOUT),"w")) {
+ $io->print("Some text\n");
}
use IO::Handle '_IOLBF';
- $fh->setvbuf($buffer_var, _IOLBF, 1024);
+ $io->setvbuf($buffer_var, _IOLBF, 1024);
- undef $fh; # automatically closes the file if it's open
+ undef $io; # automatically closes the file if it's open
autoflush STDOUT 1;
If you are reading this documentation, looking for a replacement for
the C<FileHandle> package, then I suggest you read the documentation
-for C<IO::File>
-
-A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package)
+for C<IO::File> too.
=head1 CONSTRUCTOR
supported C<IO::Handle> methods, which are just front ends for the
corresponding built-in functions:
- close
- fileno
- getc
- eof
- read
- truncate
- stat
- print
- printf
- sysread
- syswrite
+ $io->close
+ $io->eof
+ $io->fileno
+ $io->format_write( [FORMAT_NAME] )
+ $io->getc
+ $io->read ( BUF, LEN, [OFFSET] )
+ $io->print ( ARGS )
+ $io->printf ( FMT, [ARGS] )
+ $io->stat
+ $io->sysread ( BUF, LEN, [OFFSET] )
+ $io->syswrite ( BUF, LEN, [OFFSET] )
+ $io->truncate ( LEN )
See L<perlvar> for complete descriptions of each of the following
-supported C<IO::Handle> methods:
+supported C<IO::Handle> methods. All of them return the previous
+value of the attribute and takes an optional single argument that when
+given will set the value. If no argument is given the previous value
+is unchanged (except for $io->autoflush will actually turn ON
+autoflush by default).
- autoflush
- output_field_separator
- output_record_separator
- input_record_separator
- input_line_number
- format_page_number
- format_lines_per_page
- format_lines_left
- format_name
- format_top_name
- format_line_break_characters
- format_formfeed
- format_write
+ $io->autoflush ( [BOOL] ) $|
+ $io->format_page_number( [NUM] ) $%
+ $io->format_lines_per_page( [NUM] ) $=
+ $io->format_lines_left( [NUM] ) $-
+ $io->format_name( [STR] ) $~
+ $io->format_top_name( [STR] ) $^
+ $io->input_line_number( [NUM]) $.
+
+The following methods are not supported on a per-filehandle basis.
+
+ IO::Handle->format_line_break_characters( [STR] ) $:
+ IO::Handle->format_formfeed( [STR]) $^L
+ IO::Handle->output_field_separator( [STR] ) $,
+ IO::Handle->output_record_separator( [STR] ) $\
+
+ IO::Handle->input_record_separator( [STR] ) $/
Furthermore, for doing normal I/O you might need these:
=over
-=item $fh->fdopen ( FD, MODE )
+=item $io->fdopen ( FD, MODE )
C<fdopen> is like an ordinary C<open> except that its first parameter
is not a filename but rather a file handle name, a IO::Handle object,
or a file descriptor number.
-=item $fh->opened
+=item $io->opened
Returns true if the object is currently a valid file descriptor.
-=item $fh->getline
+=item $io->getline
-This works like <$
fh> described in L<perlop/"I/O Operators">
+This works like <$
io> described in L<perlop/"I/O Operators">
except that it's more readable and can be safely called in an
array context but still returns just one line.
-=item $fh->getlines
+=item $io->getlines
-This works like <$fh> when called in an array context to
+This works like <$io> when called in an array context to
read all the remaining lines in a file, except that it's more readable.
It will also croak() if accidentally called in a scalar context.
-=item $fh->ungetc ( ORD )
+=item $io->ungetc ( ORD )
Pushes a character with the given ordinal value back onto the given
-handle's input stream.
+handle's input stream. Only one character of pushback per handle is
+guaranteed.
-=item $fh->write ( BUF, LEN [, OFFSET }\] )
+=item $io->write ( BUF, LEN [, OFFSET ] )
This C<write> is like C<write> found in C, that is it is the
opposite of read. The wrapper for the perl C<write> function is
called C<format_write>.
-=item $fh->flush
-
-Flush the given handle's buffer.
-
-=item $fh->error
+=item $io->error
Returns a true value if the given handle has experienced any errors
since it was opened or since the last call to C<clearerr>.
-=item $fh->clearerr
+=item $io->clearerr
Clear the given handle's error indicator.
+=item $io->sync
+
+C<sync> synchronizes a file's in-memory state with that on the
+physical medium. C<sync> does not operate at the perlio api level, but
+operates on the file descriptor, this means that any data held at the
+perlio api level will not be synchronized. To synchronize data that is
+buffered at the perlio api level you must use the flush method. C<sync>
+is not implemented on all platforms. See L<fsync(3c)>.
+
+=item $io->flush
+
+C<flush> causes perl to flush any buffered data at the perlio api level.
+Any unread data in the buffer will be discarded, and any unwritten data
+will be written to the underlying file descriptor.
+
+=item $io->printflush ( ARGS )
+
+Turns on autoflush, print ARGS and then restores the autoflush status of the
+C<IO::Handle> object.
+
+=item $io->blocking ( [ BOOL ] )
+
+If called with an argument C<blocking> will turn on non-blocking IO if
+C<BOOL> is false, and turn it off if C<BOOL> is true.
+
+C<blocking> will return the value of the previous setting, or the
+current setting if C<BOOL> is not given.
+
+If an error occurs C<blocking> will return undef and C<$!> will be set.
+
=back
+
If the C functions setbuf() and/or setvbuf() are available, then
C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
policy for an IO::Handle. The calling sequences for the Perl functions
specifies a scalar variable to use as a buffer. WARNING: A variable
used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any
way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called
-again, or memory corruption may result! Note that you need to import
+again, or memory corruption may result! Note that you need to import
the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly.
Lastly, there is a special method for working under B<-T> and setuid/gid
=over
-=item $fh->untaint
+=item $io->untaint
Marks the object as taint-clean, and as such data read from it will also
be considered taint-clean. Note that this is a very trusting action to
=head1 NOTE
-A C<IO::Handle> object is a GLOB reference. Some modules that
+A C<IO::Handle> object is a reference to a symbol/GLOB reference (see
+the C<Symbol> package). Some modules that
inherit from C<IO::Handle> may want to keep object related variables
in the hash table part of the GLOB. In an attempt to prevent modules
trampling on each other I propose the that any such module should prefix
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
+Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
=cut
require 5.000;
use strict;
-use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA);
+use vars qw($VERSION @EXPORT_OK @ISA);
use Carp;
use Symbol;
use SelectSaver;
+use IO (); # Load the XS module
require Exporter;
@ISA = qw(Exporter);
-$VERSION = "1.1505";
-$XS_VERSION = "1.15";
+$VERSION = "1.21";
@EXPORT_OK = qw(
autoflush
getline
getlines
+ printflush
+ flush
+
SEEK_SET
SEEK_CUR
SEEK_END
_IONBF
);
-
-################################################
-## Interaction with the XS.
-##
-
-require DynaLoader;
-@IO::ISA = qw(DynaLoader);
-bootstrap IO $XS_VERSION;
-
-sub AUTOLOAD {
- if ($AUTOLOAD =~ /::(_?[a-z])/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD
- }
- my $constname = $AUTOLOAD;
- $constname =~ s/.*:://;
- my $val = constant($constname);
- defined $val or croak "$constname is not a valid IO::Handle macro";
- no strict 'refs';
- *$AUTOLOAD = sub { $val };
- goto &$AUTOLOAD;
-}
-
-
################################################
## Constructors, destructors.
##
sub new {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
@_ == 1 or croak "usage: new $class";
- my $fh = gensym;
- bless $fh, $class;
+ my $io = gensym;
+ bless $io, $class;
}
sub new_from_fd {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
@_ == 3 or croak "usage: new_from_fd $class FD, MODE";
- my $fh = gensym;
+ my $io = gensym;
shift;
- IO::Handle::fdopen($fh, @_)
+ IO::Handle::fdopen($io, @_)
or return undef;
- bless $fh, $class;
+ bless $io, $class;
}
#
}
sub fdopen {
- @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
- my ($fh, $fd, $mode) = @_;
+ @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
+ my ($io, $fd, $mode) = @_;
local(*GLOB);
if (ref($fd) && "".$fd =~ /GLOB\(/o) {
$fd = "=$fd";
}
- open($fh, _open_mode_string($mode) . '&' . $fd)
- ? $fh : undef;
+ open($io, _open_mode_string($mode) . '&' . $fd)
+ ? $io : undef;
}
sub close {
- @_ == 1 or croak 'usage: $fh->close()';
- my($fh) = @_;
+ @_ == 1 or croak 'usage: $io->close()';
+ my($io) = @_;
- close($fh);
+ close($io);
}
################################################
# select
sub opened {
- @_ == 1 or croak 'usage: $fh->opened()';
+ @_ == 1 or croak 'usage: $io->opened()';
defined fileno($_[0]);
}
sub fileno {
- @_ == 1 or croak 'usage: $fh->fileno()';
+ @_ == 1 or croak 'usage: $io->fileno()';
fileno($_[0]);
}
sub getc {
- @_ == 1 or croak 'usage: $fh->getc()';
+ @_ == 1 or croak 'usage: $io->getc()';
getc($_[0]);
}
sub eof {
- @_ == 1 or croak 'usage: $fh->eof()';
+ @_ == 1 or croak 'usage: $io->eof()';
eof($_[0]);
}
sub print {
- @_ or croak 'usage: $fh->print([ARGS])';
+ @_ or croak 'usage: $io->print(ARGS)';
my $this = shift;
print $this @_;
}
sub printf {
- @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
+ @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
my $this = shift;
printf $this @_;
}
sub getline {
- @_ == 1 or croak 'usage: $fh->getline';
+ @_ == 1 or croak 'usage: $io->getline()';
my $this = shift;
return scalar <$this>;
}
*gets = \&getline; # deprecated
sub getlines {
- @_ == 1 or croak 'usage: $fh->getline()';
+ @_ == 1 or croak 'usage: $io->getlines()';
wantarray or
- croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
+ croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
my $this = shift;
return <$this>;
}
sub truncate {
- @_ == 2 or croak 'usage: $fh->truncate(LEN)';
+ @_ == 2 or croak 'usage: $io->truncate(LEN)';
truncate($_[0], $_[1]);
}
sub read {
- @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
read($_[0], $_[1], $_[2], $_[3] || 0);
}
sub sysread {
- @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
sysread($_[0], $_[1], $_[2], $_[3] || 0);
}
sub write {
- @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->write(BUF, LEN [, OFFSET])';
local($\) = "";
print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
}
sub syswrite {
- @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])';
+ @_ == 3 || @_ == 4 or croak 'usage: $io->syswrite(BUF, LEN [, OFFSET])';
syswrite($_[0], $_[1], $_[2], $_[3] || 0);
}
sub stat {
- @_ == 1 or croak 'usage: $fh->stat()';
+ @_ == 1 or croak 'usage: $io->stat()';
stat($_[0]);
}
##
sub autoflush {
- my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $old = new SelectSaver qualify($_[0], caller);
my $prev = $|;
$| = @_ > 1 ? $_[1] : 1;
$prev;
}
sub output_field_separator {
+ carp "output_field_separator is not supported on a per-handle basis"
+ if ref($_[0]);
my $prev = $,;
$, = $_[1] if @_ > 1;
$prev;
}
sub output_record_separator {
+ carp "output_record_separator is not supported on a per-handle basis"
+ if ref($_[0]);
my $prev = $\;
$\ = $_[1] if @_ > 1;
$prev;
}
sub input_record_separator {
+ carp "input_record_separator is not supported on a per-handle basis"
+ if ref($_[0]);
my $prev = $/;
$/ = $_[1] if @_ > 1;
$prev;
}
sub input_line_number {
- # localizing $. doesn't work as advertised. grrrrrr.
+ my $now = select;
+ my $keep = $.;
+ my $tell = tell qualify($_[0], caller) if ref($_[0]);
my $prev = $.;
$. = $_[1] if @_ > 1;
+ $tell = tell $now;
+ $. = $keep;
$prev;
}
}
sub format_line_break_characters {
+ carp "format_line_break_characters is not supported on a per-handle basis"
+ if ref($_[0]);
my $prev = $:;
$: = $_[1] if @_ > 1;
$prev;
}
sub format_formfeed {
+ carp "format_formfeed is not supported on a per-handle basis"
+ if ref($_[0]);
my $prev = $^L;
$^L = $_[1] if @_ > 1;
$prev;
}
sub formline {
- my $fh = shift;
+ my $io = shift;
my $picture = shift;
local($^A) = $^A;
local($\) = "";
formline($picture, @_);
- print $fh $^A;
+ print $io $^A;
}
sub format_write {
- @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
+ @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
if (@_ == 2) {
- my ($fh, $fmt) = @_;
- my $oldfmt = $fh->format_name($fmt);
- CORE::write($fh);
- $fh->format_name($oldfmt);
+ my ($io, $fmt) = @_;
+ my $oldfmt = $io->format_name($fmt);
+ CORE::write($io);
+ $io->format_name($oldfmt);
} else {
CORE::write($_[0]);
}
}
sub fcntl {
- @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );';
- my ($fh, $op, $val) = @_;
- my $r = fcntl($fh, $op, $val);
+ @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
+ my ($io, $op, $val) = @_;
+ my $r = fcntl($io, $op, $val);
defined $r && $r eq "0 but true" ? 0 : $r;
}
sub ioctl {
- @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );';
- my ($fh, $op, $val) = @_;
- my $r = ioctl($fh, $op, $val);
+ @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
+ my ($io, $op, $val) = @_;
+ my $r = ioctl($io, $op, $val);
defined $r && $r eq "0 but true" ? 0 : $r;
}
+# this sub is for compatability with older releases of IO that used
+# a sub called constant to detemine if a constant existed -- GMB
+#
+# The SEEK_* and _IO?BF constants were the only constants at that time
+# any new code should just chech defined(&CONSTANT_NAME)
+
+sub constant {
+ no strict 'refs';
+ my $name = shift;
+ (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
+ ? &{$name}() : undef;
+}
+
+
+# so that flush.pl can be depriciated
+
+sub printflush {
+ my $io = shift;
+ my $old = new SelectSaver qualify($io, caller) if ref($io);
+ local $| = 1;
+ if(ref($io)) {
+ print $io @_;
+ }
+ else {
+ print @_;
+ }
+}
+
1;
# IO::Pipe.pm
#
-# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
-# reserved. This program is free software; you can redistribute it and/or
+# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Pipe;
use Carp;
use Symbol;
-$VERSION = "1.0901";
+$VERSION = "1.12";
sub new {
my $type = shift;
}
bless $io, "IO::Handle";
$io->fdopen($fh, $mode);
- $fh->close;
+ $fh->close;
if ($do_spawn) {
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
}
sub reader {
- @_ >= 1 or croak 'usage: $pipe->reader()';
+ @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
my $me = shift;
+
+ return undef
+ unless(ref($me) || ref($me = $me->new));
+
my $fh = ${*$me}[0];
my $pid = $me->_doit(0, $fh, @_)
if(@_);
close ${*$me}[1];
bless $me, ref($fh);
*{*$me} = *{*$fh}; # Alias self to handle
+ $me->fdopen($fh->fileno,"r")
+ unless defined($me->fileno);
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
}
sub writer {
- @_ >= 1 or croak 'usage: $pipe->writer()';
+ @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
my $me = shift;
+
+ return undef
+ unless(ref($me) || ref($me = $me->new));
+
my $fh = ${*$me}[1];
my $pid = $me->_doit(1, $fh, @_)
if(@_);
close ${*$me}[0];
bless $me, ref($fh);
*{*$me} = *{*$fh}; # Alias self to handle
+ $me->fdopen($fh->fileno,"w")
+ unless defined($me->fileno);
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
=head1 NAME
-IO::pipe - supply object methods for pipes
+IO::Pipe - supply object methods for pipes
=head1 SYNOPSIS
=head1 AUTHOR
-Graham Barr <bodg@tiuk.ti.com>
+Graham Barr <gbarr@pobox.com>
=head1 COPYRIGHT
-Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
-software; you can redistribute it and/or modify it under the same terms
-as Perl itself.
+Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
=cut
--- /dev/null
+# IO::Poll.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Poll;
+
+use strict;
+use IO::Handle;
+use Exporter ();
+use vars qw(@ISA @EXPORT_OK @EXPORT $VERSION);
+
+@ISA = qw(Exporter);
+$VERSION = "0.01";
+
+@EXPORT = qw(poll);
+
+@EXPORT_OK = qw(
+ POLLIN
+ POLLPRI
+ POLLOUT
+ POLLRDNORM
+ POLLWRNORM
+ POLLRDBAND
+ POLLWRBAND
+ POLLNORM
+ POLLERR
+ POLLHUP
+ POLLNVAL
+);
+
+sub new {
+ my $class = shift;
+
+ my $self = bless [{},{}], $class;
+
+ $self;
+}
+
+sub mask {
+ my $self = shift;
+ my $io = shift;
+ my $fd = fileno($io);
+ if(@_) {
+ my $mask = shift;
+ $self->[0]{$fd} ||= {};
+ if($mask) {
+ $self->[0]{$fd}{$io} = $mask;
+ }
+ else {
+ delete $self->[0]{$fd}{$io};
+ }
+ }
+ elsif(exists $self->[0]{$fd}{$io}) {
+ return $self->[0]{$fd}{$io};
+ }
+ return;
+}
+
+
+sub poll {
+ my($self,$timeout) = @_;
+
+ $self->[1] = {};
+
+ my($fd,$ref);
+ my @poll = ();
+
+ while(($fd,$ref) = each %{$self->[0]}) {
+ my $events = 0;
+ map { $events |= $_ } values %{$ref};
+ push(@poll,$fd, $events);
+ }
+
+ my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0;
+
+ return $ret
+ unless $ret > 0;
+
+ while(@poll) {
+ my($fd,$got) = splice(@poll,0,2);
+ $self->[1]{$fd} = $got
+ if $got;
+ }
+
+ return $ret;
+}
+
+sub events {
+ my $self = shift;
+ my $io = shift;
+ my $fd = fileno($io);
+
+ exists $self->[1]{$fd} && exists $self->[0]{$fd}{$io}
+ ? $self->[1]{$fd} & $self->[0]{$fd}{$io}
+ : 0;
+}
+
+sub remove {
+ my $self = shift;
+ my $io = shift;
+ $self->mask($io,0);
+}
+
+sub handles {
+ my $self = shift;
+
+ return map { keys %$_ } values %{$self->[0]}
+ unless(@_);
+
+ my $events = shift || 0;
+ my($fd,$ev,$io,$mask);
+ my @handles = ();
+
+ while(($fd,$ev) = each %{$self->[1]}) {
+ if($ev & $events) {
+ while(($io,$mask) = each %{$self->[0][$fd]}) {
+ push(@handles, $io)
+ if $events & $mask;
+ }
+ }
+ }
+ return @handles;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Poll - Object interface to system poll call
+
+=head1 SYNOPSIS
+
+ use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP);
+
+ $poll = new IO::Poll;
+
+ $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP);
+ $poll->mask($output_handle => POLLWRNORM);
+
+ $poll->poll($timeout);
+
+ $ev = $poll->events($input);
+
+=head1 DESCRIPTION
+
+C<IO::Poll> is a simple interface to the system level poll routine.
+
+=head1 METHODS
+
+=over 4
+
+=item mask ( IO [, EVENT_MASK ] )
+
+If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the
+list of file descriptors and the next call to poll will check for
+any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be
+removed from the list of file descriptors.
+
+If EVENT_MASK is not given then the return value will be the current
+event mask value for IO.
+
+=item poll ( [ TIMEOUT ] )
+
+Call the system level poll routine. If TIMEOUT is not specified then the
+call will block. Returns the number of handles which had events
+happen, or -1 on error.
+
+=item events ( IO )
+
+Returns the event mask which represents the events that happend on IO
+during the last call to C<poll>.
+
+=item remove ( IO )
+
+Remove IO from the list of file descriptors for the next poll.
+
+=item handles( [ EVENT_MASK ] )
+
+Returns a list of handles. If EVENT_MASK is not given then a list of all
+handles known will be returned. If EVENT_MASK is given then a list
+of handles will be returned which had one of the events specified by
+EVENT_MASK happen during the last call ti C<poll>
+
+=back
+
+=head1 SEE ALSO
+
+L<poll(2)>, L<IO::Handle>, L<IO::Select>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
which allow seeking of the file descriptors.
If the C functions fgetpos() and fsetpos() are available, then
-C<IO::File::getpos> returns an opaque value that represents the
-current position of the IO::File, and C<IO::File::setpos> uses
+C<$io-E<lt>getpos> returns an opaque value that represents the
+current position of the IO::File, and C<$io-E<gt>setpos(POS)> uses
that value to return to a previously visited position.
See L<perlfunc> for complete descriptions of each of the following
supported C<IO::Seekable> methods, which are just front ends for the
corresponding built-in functions:
- seek
- tell
+ $io->seek( POS, WHENCE )
+ $io->sysseek( POS, WHENCE )
+ $io->tell
=head1 SEE ALSO
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt>
+Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt>
=cut
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
-$VERSION = "1.06";
+$VERSION = "1.08";
sub seek {
- @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+ @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
seek($_[0], $_[1], $_[2]);
}
+sub sysseek {
+ @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)';
+ sysseek($_[0], $_[1], $_[2]);
+}
+
sub tell {
- @_ == 1 or croak 'usage: $fh->tell()';
+ @_ == 1 or croak 'usage: $io->tell()';
tell($_[0]);
}
# IO::Select.pm
#
-# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
-# software; you can redistribute it and/or modify it under the same terms
-# as Perl itself.
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
package IO::Select;
-=head1 NAME
-
-IO::Select - OO interface to the select system call
-
-=head1 SYNOPSIS
-
- use IO::Select;
-
- $s = IO::Select->new();
-
- $s->add(\*STDIN);
- $s->add($some_handle);
-
- @ready = $s->can_read($timeout);
-
- @ready = IO::Select->new(@handles)->read(0);
-
-=head1 DESCRIPTION
-
-The C<IO::Select> package implements an object approach to the system C<select>
-function call. It allows the user to see what IO handles, see L<IO::Handle>,
-are ready for reading, writing or have an error condition pending.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HANDLES ] )
-
-The constructor creates a new object and optionally initialises it with a set
-of handles.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item add ( HANDLES )
-
-Add the list of handles to the C<IO::Select> object. It is these values that
-will be returned when an event occurs. C<IO::Select> keeps these values in a
-cache which is indexed by the C<fileno> of the handle, so if more than one
-handle with the same C<fileno> is specified then only the last one is cached.
-
-Each handle can be an C<IO::Handle> object, an integer or an array
-reference where the first element is a C<IO::Handle> or an integer.
-
-=item remove ( HANDLES )
-
-Remove all the given handles from the object. This method also works
-by the C<fileno> of the handles. So the exact handles that were added
-need not be passed, just handles that have an equivalent C<fileno>
-
-=item exists ( HANDLE )
-
-Returns a true value (actually the handle itself) if it is present.
-Returns undef otherwise.
-
-=item handles
-
-Return an array of all registered handles.
-
-=item can_read ( [ TIMEOUT ] )
-
-Return an array of handles that are ready for reading. C<TIMEOUT> is
-the maximum amount of time to wait before returning an empty list. If
-C<TIMEOUT> is not given and any handles are registered then the call
-will block.
-
-=item can_write ( [ TIMEOUT ] )
-
-Same as C<can_read> except check for handles that can be written to.
-
-=item has_error ( [ TIMEOUT ] )
-
-Same as C<can_read> except check for handles that have an error
-condition, for example EOF.
-
-=item count ()
-
-Returns the number of handles that the object will check for when
-one of the C<can_> methods is called or the object is passed to
-the C<select> static method.
-
-=item bits()
-
-Return the bit string suitable as argument to the core select() call.
-
-=item bits()
-
-Return the bit string suitable as argument to the core select() call.
-
-=item select ( READ, WRITE, ERROR [, TIMEOUT ] )
-
-C<select> is a static method, that is you call it with the package
-name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef>
-or C<IO::Select> objects. C<TIMEOUT> is optional and has the same
-effect as for the core select call.
-
-The result will be an array of 3 elements, each a reference to an array
-which will hold the handles that are ready for reading, writing and have
-error conditions respectively. Upon error an empty array is returned.
-
-=back
-
-=head1 EXAMPLE
-
-Here is a short example which shows how C<IO::Select> could be used
-to write a server which communicates with several sockets while also
-listening for more connections on a listen socket
-
- use IO::Select;
- use IO::Socket;
-
- $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
- $sel = new IO::Select( $lsn );
-
- while(@ready = $sel->can_read) {
- foreach $fh (@ready) {
- if($fh == $lsn) {
- # Create a new socket
- $new = $lsn->accept;
- $sel->add($new);
- }
- else {
- # Process socket
-
- # Maybe we have finished with the socket
- $sel->remove($fh);
- $fh->close;
- }
- }
- }
-
-=head1 AUTHOR
-
-Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
-software; you can redistribute it and/or modify it under the same terms
-as Perl itself.
-
-=cut
-
use strict;
use vars qw($VERSION @ISA);
require Exporter;
-$VERSION = "1.10";
+$VERSION = "1.13";
@ISA = qw(Exporter); # This is only so we can do version checking
: ();
}
-sub has_error
+sub has_exception
{
my $vec = shift;
my $timeout = shift;
: ();
}
+sub has_error
+{
+ require Carp;
+ Carp::carp("Call to depreciated method 'has_error', use 'has_exception'")
+ if $^W;
+ goto &has_exception;
+}
+
sub count
{
my $vec = shift;
}
1;
+__END__
+
+=head1 NAME
+
+IO::Select - OO interface to the select system call
+
+=head1 SYNOPSIS
+
+ use IO::Select;
+
+ $s = IO::Select->new();
+
+ $s->add(\*STDIN);
+ $s->add($some_handle);
+
+ @ready = $s->can_read($timeout);
+
+ @ready = IO::Select->new(@handles)->read(0);
+
+=head1 DESCRIPTION
+
+The C<IO::Select> package implements an object approach to the system C<select>
+function call. It allows the user to see what IO handles, see L<IO::Handle>,
+are ready for reading, writing or have an error condition pending.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HANDLES ] )
+
+The constructor creates a new object and optionally initialises it with a set
+of handles.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item add ( HANDLES )
+
+Add the list of handles to the C<IO::Select> object. It is these values that
+will be returned when an event occurs. C<IO::Select> keeps these values in a
+cache which is indexed by the C<fileno> of the handle, so if more than one
+handle with the same C<fileno> is specified then only the last one is cached.
+
+Each handle can be an C<IO::Handle> object, an integer or an array
+reference where the first element is a C<IO::Handle> or an integer.
+
+=item remove ( HANDLES )
+
+Remove all the given handles from the object. This method also works
+by the C<fileno> of the handles. So the exact handles that were added
+need not be passed, just handles that have an equivalent C<fileno>
+
+=item exists ( HANDLE )
+
+Returns a true value (actually the handle itself) if it is present.
+Returns undef otherwise.
+
+=item handles
+
+Return an array of all registered handles.
+
+=item can_read ( [ TIMEOUT ] )
+
+Return an array of handles that are ready for reading. C<TIMEOUT> is
+the maximum amount of time to wait before returning an empty list. If
+C<TIMEOUT> is not given and any handles are registered then the call
+will block.
+
+=item can_write ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that can be written to.
+
+=item has_exception ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that have an exception
+condition, for example pending out-of-band data.
+
+=item count ()
+
+Returns the number of handles that the object will check for when
+one of the C<can_> methods is called or the object is passed to
+the C<select> static method.
+
+=item bits()
+
+Return the bit string suitable as argument to the core select() call.
+
+=item select ( READ, WRITE, ERROR [, TIMEOUT ] )
+
+C<select> is a static method, that is you call it with the package
+name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef>
+or C<IO::Select> objects. C<TIMEOUT> is optional and has the same
+effect as for the core select call.
+
+The result will be an array of 3 elements, each a reference to an array
+which will hold the handles that are ready for reading, writing and have
+error conditions respectively. Upon error an empty array is returned.
+
+=back
+
+=head1 EXAMPLE
+
+Here is a short example which shows how C<IO::Select> could be used
+to write a server which communicates with several sockets while also
+listening for more connections on a listen socket
+
+ use IO::Select;
+ use IO::Socket;
+
+ $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
+ $sel = new IO::Select( $lsn );
+
+ while(@ready = $sel->can_read) {
+ foreach $fh (@ready) {
+ if($fh == $lsn) {
+ # Create a new socket
+ $new = $lsn->accept;
+ $sel->add($new);
+ }
+ else {
+ # Process socket
+
+ # Maybe we have finished with the socket
+ $sel->remove($fh);
+ $fh->close;
+ }
+ }
+ }
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
# IO::Socket.pm
#
-# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
-# reserved. This program is free software; you can redistribute it and/or
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket;
-=head1 NAME
-
-IO::Socket - Object interface to socket communications
-
-=head1 SYNOPSIS
-
- use IO::Socket;
-
-=head1 DESCRIPTION
-
-C<IO::Socket> provides an object interface to creating and using sockets. It
-is built upon the L<IO::Handle> interface and inherits all the methods defined
-by L<IO::Handle>.
-
-C<IO::Socket> only defines methods for those operations which are common to all
-types of socket. Operations which are specified to a socket in a particular
-domain have methods defined in sub classes of C<IO::Socket>
-
-C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ARGS] )
-
-Creates an C<IO::Socket>, which is a reference to a
-newly created symbol (see the C<Symbol> package). C<new>
-optionally takes arguments, these arguments are in key-value pairs.
-C<new> only looks for one key C<Domain> which tells new which domain
-the socket will be in. All other arguments will be passed to the
-configuration method of the package for that domain, See below.
-
-C<IO::Socket>s will be in autoflush mode after creation. Note that
-versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04)
-did not do this. So if you need backward compatibility, you should
-set autoflush explicitly.
-
-=back
-
-=head1 METHODS
-
-See L<perlfunc> for complete descriptions of each of the following
-supported C<IO::Socket> methods, which are just front ends for the
-corresponding built-in functions:
-
- socket
- socketpair
- bind
- listen
- accept
- send
- recv
- peername (getpeername)
- sockname (getsockname)
-
-Some methods take slightly different arguments to those defined in L<perlfunc>
-in attempt to make the interface more flexible. These are
-
-=over 4
-
-=item accept([PKG])
-
-perform the system call C<accept> on the socket and return a new object. The
-new object will be created in the same class as the listen socket, unless
-C<PKG> is specified. This object can be used to communicate with the client
-that was trying to connect. In a scalar context the new socket is returned,
-or undef upon failure. In an array context a two-element array is returned
-containing the new socket and the peer address, the list will
-be empty upon failure.
-
-Additional methods that are provided are
-
-=item timeout([VAL])
-
-Set or get the timeout value associated with this socket. If called without
-any arguments then the current setting is returned. If called with an argument
-the current setting is changed and the previous value returned.
-
-=item sockopt(OPT [, VAL])
-
-Unified method to both set and get options in the SOL_SOCKET level. If called
-with one argument then getsockopt is called, otherwise setsockopt is called.
-
-=item sockdomain
-
-Returns the numerical number for the socket domain type. For example, for
-a AF_INET socket the value of &AF_INET will be returned.
-
-=item socktype
-
-Returns the numerical number for the socket type. For example, for
-a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
-
-=item protocol
-
-Returns the numerical number for the protocol being used on the socket, if
-known. If the protocol is unknown, as with an AF_UNIX socket, zero
-is returned.
-
-=back
-
-=cut
-
-
require 5.000;
-use Config;
use IO::Handle;
use Socket 1.3;
use Carp;
use vars qw(@ISA $VERSION);
use Exporter;
+# legacy
+
+require IO::Socket::INET;
+require IO::Socket::UNIX;
+
@ISA = qw(IO::Handle);
-$VERSION = "1.1603";
+$VERSION = "1.25";
sub import {
my $pkg = shift;
sub new {
my($class,%arg) = @_;
- my $fh = $class->SUPER::new();
- $fh->autoflush;
+ my $sock = $class->SUPER::new();
+
+ $sock->autoflush(1);
- ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
+ ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
- return scalar(%arg) ? $fh->configure(\%arg)
- : $fh;
+ return scalar(%arg) ? $sock->configure(\%arg)
+ : $sock;
}
-my @domain2pkg = ();
+my @domain2pkg;
sub register_domain {
my($p,$d) = @_;
}
sub configure {
- my($fh,$arg) = @_;
+ my($sock,$arg) = @_;
my $domain = delete $arg->{Domain};
croak 'IO::Socket: Cannot configure a generic socket'
unless defined $domain2pkg[$domain];
croak "IO::Socket: Cannot configure socket in domain '$domain'"
- unless ref($fh) eq "IO::Socket";
+ unless ref($sock) eq "IO::Socket";
- bless($fh, $domain2pkg[$domain]);
- $fh->configure($arg);
+ bless($sock, $domain2pkg[$domain]);
+ $sock->configure($arg);
}
sub socket {
- @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
- my($fh,$domain,$type,$protocol) = @_;
+ @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
+ my($sock,$domain,$type,$protocol) = @_;
- socket($fh,$domain,$type,$protocol) or
+ socket($sock,$domain,$type,$protocol) or
return undef;
- ${*$fh}{'io_socket_domain'} = $domain;
- ${*$fh}{'io_socket_type'} = $type;
- ${*$fh}{'io_socket_proto'} = $protocol;
+ ${*$sock}{'io_socket_domain'} = $domain;
+ ${*$sock}{'io_socket_type'} = $type;
+ ${*$sock}{'io_socket_proto'} = $protocol;
- $fh;
+ $sock;
}
sub socketpair {
@_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
my($class,$domain,$type,$protocol) = @_;
- my $fh1 = $class->new();
- my $fh2 = $class->new();
+ my $sock1 = $class->new();
+ my $sock2 = $class->new();
- socketpair($fh1,$fh2,$domain,$type,$protocol) or
+ socketpair($sock1,$sock2,$domain,$type,$protocol) or
return ();
- ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
- ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
+ ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
+ ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
- ($fh1,$fh2);
+ ($sock1,$sock2);
}
sub connect {
- @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
- my $fh = shift;
- my $addr = @_ == 1 ? shift : sockaddr_in(@_);
- my $timeout = ${*$fh}{'io_socket_timeout'};
- local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
- : $SIG{ALRM} || 'DEFAULT';
-
- eval {
+ @_ == 2 or croak 'usage: $sock->connect(NAME)';
+ my $sock = shift;
+ my $addr = shift;
+ my $timeout = ${*$sock}{'io_socket_timeout'};
+
+ eval {
+ my $blocking = 0;
+
croak 'connect: Bad address'
if(@_ == 2 && !defined $_[1]);
- if($timeout) {
- defined $Config{d_alarm} && defined alarm($timeout) or
- $timeout = 0;
- }
+ $blocking = $sock->blocking(0)
+ if($timeout);
- my $ok = connect($fh, $addr);
+ unless(connect($sock, $addr)) {
+ if($timeout && ($! == &IO::EINPROGRESS)) {
+ require IO::Select;
- alarm(0)
- if($timeout);
+ my $sel = new IO::Select $sock;
- croak "connect: timeout"
- unless defined $fh;
+ $sock->blocking(1)
+ if($blocking);
- undef $fh unless $ok;
+ unless($sel->can_write($timeout) && defined($sock->peername)) {
+ undef $sock;
+ croak "connect: timeout";
+ }
+ }
+ else {
+ undef $sock;
+ croak "connect: $!";
+ }
+ }
+ $sock->blocking(1)
+ if($sock && $blocking);
};
- $fh;
+ $sock;
}
sub bind {
- @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
- my $fh = shift;
- my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+ @_ == 2 or croak 'usage: $sock->bind(NAME)';
+ my $sock = shift;
+ my $addr = shift;
- return bind($fh, $addr) ? $fh
- : undef;
+ return bind($sock, $addr) ? $sock
+ : undef;
}
sub listen {
- @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
- my($fh,$queue) = @_;
+ @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
+ my($sock,$queue) = @_;
$queue = 5
unless $queue && $queue > 0;
- return listen($fh, $queue) ? $fh
- : undef;
+ return listen($sock, $queue) ? $sock
+ : undef;
}
sub accept {
- @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
- my $fh = shift;
- my $pkg = shift || $fh;
- my $timeout = ${*$fh}{'io_socket_timeout'};
+ @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
+ my $sock = shift;
+ my $pkg = shift || $sock;
+ my $timeout = ${*$sock}{'io_socket_timeout'};
my $new = $pkg->new(Timeout => $timeout);
my $peer = undef;
eval {
if($timeout) {
- my $fdset = "";
- vec($fdset, $fh->fileno,1) = 1;
+ require IO::Select;
+
+ my $sel = new IO::Select $sock;
+
croak "accept: timeout"
- unless select($fdset,undef,undef,$timeout);
+ unless $sel->can_read($timeout);
}
- $peer = accept($new,$fh);
+ $peer = accept($new,$sock) || undef;
};
return wantarray ? defined $peer ? ($new, $peer)
}
sub sockname {
- @_ == 1 or croak 'usage: $fh->sockname()';
+ @_ == 1 or croak 'usage: $sock->sockname()';
getsockname($_[0]);
}
sub peername {
- @_ == 1 or croak 'usage: $fh->peername()';
- my($fh) = @_;
- getpeername($fh)
- || ${*$fh}{'io_socket_peername'}
+ @_ == 1 or croak 'usage: $sock->peername()';
+ my($sock) = @_;
+ getpeername($sock)
+ || ${*$sock}{'io_socket_peername'}
|| undef;
}
+sub connected {
+ @_ == 1 or croak 'usage: $sock->connected()';
+ my($sock) = @_;
+ getpeername($sock);
+}
+
sub send {
- @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
- my $fh = $_[0];
+ @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
+ my $sock = $_[0];
my $flags = $_[2] || 0;
- my $peer = $_[3] || $fh->peername;
+ my $peer = $_[3] || $sock->peername;
croak 'send: Cannot determine peer address'
unless($peer);
- my $r = defined(getpeername($fh))
- ? send($fh, $_[1], $flags)
- : send($fh, $_[1], $flags, $peer);
+ my $r = defined(getpeername($sock))
+ ? send($sock, $_[1], $flags)
+ : send($sock, $_[1], $flags, $peer);
# remember who we send to, if it was sucessful
- ${*$fh}{'io_socket_peername'} = $peer
+ ${*$sock}{'io_socket_peername'} = $peer
if(@_ == 4 && defined $r);
$r;
}
sub recv {
- @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
+ @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
my $sock = $_[0];
my $len = $_[2];
my $flags = $_[3] || 0;
${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}
+sub shutdown {
+ @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
+ my($sock, $how) = @_;
+ shutdown($sock, $how);
+}
sub setsockopt {
- @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
+ @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
setsockopt($_[0],$_[1],$_[2],$_[3]);
}
my $intsize = length(pack("i",0));
sub getsockopt {
- @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
+ @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
my $r = getsockopt($_[0],$_[1],$_[2]);
# Just a guess
$r = unpack("i", $r)
}
sub sockopt {
- my $fh = shift;
- @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
- : $fh->setsockopt(SOL_SOCKET,@_);
+ my $sock = shift;
+ @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
+ : $sock->setsockopt(SOL_SOCKET,@_);
}
sub timeout {
- @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
- my($fh,$val) = @_;
- my $r = ${*$fh}{'io_socket_timeout'} || undef;
+ @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
+ my($sock,$val) = @_;
+ my $r = ${*$sock}{'io_socket_timeout'} || undef;
- ${*$fh}{'io_socket_timeout'} = 0 + $val
+ ${*$sock}{'io_socket_timeout'} = 0 + $val
if(@_ == 2);
$r;
}
sub sockdomain {
- @_ == 1 or croak 'usage: $fh->sockdomain()';
- my $fh = shift;
- ${*$fh}{'io_socket_domain'};
+ @_ == 1 or croak 'usage: $sock->sockdomain()';
+ my $sock = shift;
+ ${*$sock}{'io_socket_domain'};
}
sub socktype {
- @_ == 1 or croak 'usage: $fh->socktype()';
- my $fh = shift;
- ${*$fh}{'io_socket_type'}
+ @_ == 1 or croak 'usage: $sock->socktype()';
+ my $sock = shift;
+ ${*$sock}{'io_socket_type'}
}
sub protocol {
- @_ == 1 or croak 'usage: $fh->protocol()';
- my($fh) = @_;
- ${*$fh}{'io_socket_protocol'};
+ @_ == 1 or croak 'usage: $sock->protocol()';
+ my($sock) = @_;
+ ${*$sock}{'io_socket_protocol'};
}
-=head1 SUB-CLASSES
-
-=cut
-
-##
-## AF_INET
-##
-
-package IO::Socket::INET;
-
-use strict;
-use vars qw(@ISA);
-use Socket;
-use Carp;
-use Exporter;
-
-@ISA = qw(IO::Socket);
-
-IO::Socket::INET->register_domain( AF_INET );
-
-my %socket_type = ( tcp => SOCK_STREAM,
- udp => SOCK_DGRAM,
- icmp => SOCK_RAW,
- );
-
-=head2 IO::Socket::INET
-
-C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
-and some related methods. The constructor can take the following options
-
- PeerAddr Remote host address <hostname>[:<port>]
- PeerPort Remote port or service <service>[(<no>)] | <no>
- LocalAddr Local host bind address hostname[:port]
- LocalPort Local host bind port <service>[(<no>)] | <no>
- Proto Protocol name (or number) "tcp" | "udp" | ...
- Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
- Listen Queue size for listen
- Reuse Set SO_REUSEADDR before binding
- Timeout Timeout value for various operations
+1;
+__END__
-If C<Listen> is defined then a listen socket is created, else if the
-socket type, which is derived from the protocol, is SOCK_STREAM then
-connect() is called.
-
-The C<PeerAddr> can be a hostname or the IP-address on the
-"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic
-service name. The service name might be followed by a number in
-parenthesis which is used if the service is not known by the system.
-The C<PeerPort> specification can also be embedded in the C<PeerAddr>
-by preceding it with a ":".
-
-If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
-then the constructor will try to derive C<Proto> from the service
-name. As a last resort C<Proto> "tcp" is assumed. The C<Type>
-parameter will be deduced from C<Proto> if not specified.
+=head1 NAME
-If the constructor is only passed a single argument, it is assumed to
-be a C<PeerAddr> specification.
+IO::Socket - Object interface to socket communications
-Examples:
+=head1 SYNOPSIS
- $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
- PeerPort => 'http(80)',
- Proto => 'tcp');
+ use IO::Socket;
- $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
+=head1 DESCRIPTION
- $sock = IO::Socket::INET->new(Listen => 5,
- LocalAddr => 'localhost',
- LocalPort => 9000,
- Proto => 'tcp');
+C<IO::Socket> provides an object interface to creating and using sockets. It
+is built upon the L<IO::Handle> interface and inherits all the methods defined
+by L<IO::Handle>.
- $sock = IO::Socket::INET->new('127.0.0.1:25');
+C<IO::Socket> only defines methods for those operations which are common to all
+types of socket. Operations which are specified to a socket in a particular
+domain have methods defined in sub classes of C<IO::Socket>
+C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
-=head2 METHODS
+=head1 CONSTRUCTOR
=over 4
-=item sockaddr ()
-
-Return the address part of the sockaddr structure for the socket
-
-=item sockport ()
-
-Return the port number that the socket is using on the local host
-
-=item sockhost ()
-
-Return the address part of the sockaddr structure for the socket in a
-text form xx.xx.xx.xx
-
-=item peeraddr ()
-
-Return the address part of the sockaddr structure for the socket on
-the peer host
-
-=item peerport ()
+=item new ( [ARGS] )
-Return the port number for the socket on the peer host.
+Creates an C<IO::Socket>, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+C<new> only looks for one key C<Domain> which tells new which domain
+the socket will be in. All other arguments will be passed to the
+configuration method of the package for that domain, See below.
-=item peerhost ()
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+As of VERSION 1.18 all IO::Socket objects have autoflush turned on
+by default. This was not the case with earlier releases.
-Return the address part of the sockaddr structure for the socket on the
-peer host in a text form xx.xx.xx.xx
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
=back
-=cut
-
-sub new
-{
- my $class = shift;
- unshift(@_, "PeerAddr") if @_ == 1;
- return $class->SUPER::new(@_);
-}
-
-sub _sock_info {
- my($addr,$port,$proto) = @_;
- my @proto = ();
- my @serv = ();
-
- $port = $1
- if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
-
- if(defined $proto) {
- @proto = $proto =~ m,\D, ? getprotobyname($proto)
- : getprotobynumber($proto);
-
- $proto = $proto[2] || undef;
- }
-
- if(defined $port) {
- $port =~ s,\((\d+)\)$,,;
-
- my $defport = $1 || undef;
- my $pnum = ($port =~ m,^(\d+)$,)[0];
-
- @serv= getservbyname($port, $proto[0] || "")
- if($port =~ m,\D,);
-
- $port = $pnum || $serv[2] || $defport || undef;
-
- $proto = (getprotobyname($serv[3]))[2] || undef
- if @serv && !$proto;
- }
-
- return ($addr || undef,
- $port || undef,
- $proto || undef
- );
-}
-
-sub _error {
- my $fh = shift;
- $@ = join("",ref($fh),": ",@_);
- carp $@ if $^W;
- close($fh)
- if(defined fileno($fh));
- return undef;
-}
-
-sub configure {
- my($fh,$arg) = @_;
- my($lport,$rport,$laddr,$raddr,$proto,$type);
-
-
- ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
- $arg->{LocalPort},
- $arg->{Proto});
-
- $laddr = defined $laddr ? inet_aton($laddr)
- : INADDR_ANY;
-
- return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
- unless(defined $laddr);
-
- unless(exists $arg->{Listen}) {
- ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
- $arg->{PeerPort},
- $proto);
- }
-
- if(defined $raddr) {
- $raddr = inet_aton($raddr);
- return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
- unless(defined $raddr);
- }
-
- $proto ||= (getprotobyname "tcp")[2];
- return _error($fh,'Cannot determine protocol')
- unless($proto);
-
- my $pname = (getprotobynumber($proto))[0];
- $type = $arg->{Type} || $socket_type{$pname};
-
- $fh->socket(AF_INET, $type, $proto) or
- return _error($fh,"$!");
-
- if ($arg->{Reuse}) {
- $fh->sockopt(SO_REUSEADDR,1) or
- return _error($fh);
- }
-
- $fh->bind($lport || 0, $laddr) or
- return _error($fh,"$!");
-
- if(exists $arg->{Listen}) {
- $fh->listen($arg->{Listen} || 5) or
- return _error($fh,"$!");
- }
- else {
- return _error($fh,'Cannot determine remote port')
- unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
-
- if($type == SOCK_STREAM || defined $raddr) {
- return _error($fh,'Bad peer address')
- unless(defined $raddr);
-
- $fh->connect($rport,$raddr) or
- return _error($fh,"$!");
- }
- }
-
- $fh;
-}
-
-sub sockaddr {
- @_ == 1 or croak 'usage: $fh->sockaddr()';
- my($fh) = @_;
- (sockaddr_in($fh->sockname))[1];
-}
+=head1 METHODS
-sub sockport {
- @_ == 1 or croak 'usage: $fh->sockport()';
- my($fh) = @_;
- (sockaddr_in($fh->sockname))[0];
-}
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Socket> methods, which are just front ends for the
+corresponding built-in functions:
-sub sockhost {
- @_ == 1 or croak 'usage: $fh->sockhost()';
- my($fh) = @_;
- inet_ntoa($fh->sockaddr);
-}
+ socket
+ socketpair
+ bind
+ listen
+ accept
+ send
+ recv
+ peername (getpeername)
+ sockname (getsockname)
+ shutdown
-sub peeraddr {
- @_ == 1 or croak 'usage: $fh->peeraddr()';
- my($fh) = @_;
- (sockaddr_in($fh->peername))[1];
-}
+Some methods take slightly different arguments to those defined in L<perlfunc>
+in attempt to make the interface more flexible. These are
-sub peerport {
- @_ == 1 or croak 'usage: $fh->peerport()';
- my($fh) = @_;
- (sockaddr_in($fh->peername))[0];
-}
+=over 4
-sub peerhost {
- @_ == 1 or croak 'usage: $fh->peerhost()';
- my($fh) = @_;
- inet_ntoa($fh->peeraddr);
-}
+=item accept([PKG])
-##
-## AF_UNIX
-##
+perform the system call C<accept> on the socket and return a new object. The
+new object will be created in the same class as the listen socket, unless
+C<PKG> is specified. This object can be used to communicate with the client
+that was trying to connect. In a scalar context the new socket is returned,
+or undef upon failure. In an array context a two-element array is returned
+containing the new socket and the peer address, the list will
+be empty upon failure.
-package IO::Socket::UNIX;
+Additional methods that are provided are
-use strict;
-use vars qw(@ISA $VERSION);
-use Socket;
-use Carp;
-use Exporter;
+=item timeout([VAL])
-@ISA = qw(IO::Socket);
+Set or get the timeout value associated with this socket. If called without
+any arguments then the current setting is returned. If called with an argument
+the current setting is changed and the previous value returned.
-IO::Socket::UNIX->register_domain( AF_UNIX );
+=item sockopt(OPT [, VAL])
-=head2 IO::Socket::UNIX
+Unified method to both set and get options in the SOL_SOCKET level. If called
+with one argument then getsockopt is called, otherwise setsockopt is called.
-C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
-and some related methods. The constructor can take the following options
+=item sockdomain
- Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
- Local Path to local fifo
- Peer Path to peer fifo
- Listen Create a listen socket
+Returns the numerical number for the socket domain type. For example, for
+a AF_INET socket the value of &AF_INET will be returned.
-=head2 METHODS
+=item socktype
-=over 4
+Returns the numerical number for the socket type. For example, for
+a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
-=item hostpath()
+=item protocol
-Returns the pathname to the fifo at the local end
+Returns the numerical number for the protocol being used on the socket, if
+known. If the protocol is unknown, as with an AF_UNIX socket, zero
+is returned.
-=item peerpath()
+=item connected
-Returns the pathanme to the fifo at the peer end
+If the socket is in a connected state the the peer address is returned.
+If the socket is not in a connected state then undef will be returned.
=back
-=cut
-
-sub configure {
- my($fh,$arg) = @_;
- my($bport,$cport);
-
- my $type = $arg->{Type} || SOCK_STREAM;
-
- $fh->socket(AF_UNIX, $type, 0) or
- return undef;
-
- if(exists $arg->{Local}) {
- my $addr = sockaddr_un($arg->{Local});
- $fh->bind($addr) or
- return undef;
- }
- if(exists $arg->{Listen}) {
- $fh->listen($arg->{Listen} || 5) or
- return undef;
- }
- elsif(exists $arg->{Peer}) {
- my $addr = sockaddr_un($arg->{Peer});
- $fh->connect($addr) or
- return undef;
- }
-
- $fh;
-}
-
-sub hostpath {
- @_ == 1 or croak 'usage: $fh->hostpath()';
- my $n = $_[0]->sockname || return undef;
- (sockaddr_un($n))[0];
-}
-
-sub peerpath {
- @_ == 1 or croak 'usage: $fh->peerpath()';
- my $n = $_[0]->peername || return undef;
- (sockaddr_un($n))[0];
-}
-
=head1 SEE ALSO
-L<Socket>, L<IO::Handle>
+L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
=head1 AUTHOR
-Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
=head1 COPYRIGHT
-Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
-software; you can redistribute it and/or modify it under the same terms
-as Perl itself.
+Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
=cut
-
-1; # Keep require happy
--- /dev/null
+# IO::Socket::INET.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Socket::INET;
+
+use strict;
+use vars qw(@ISA $VERSION);
+use IO::Socket;
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+$VERSION = "1.24";
+
+IO::Socket::INET->register_domain( AF_INET );
+
+my %socket_type = ( tcp => SOCK_STREAM,
+ udp => SOCK_DGRAM,
+ icmp => SOCK_RAW
+ );
+
+sub new {
+ my $class = shift;
+ unshift(@_, "PeerAddr") if @_ == 1;
+ return $class->SUPER::new(@_);
+}
+
+sub _sock_info {
+ my($addr,$port,$proto) = @_;
+ my @proto = ();
+ my @serv = ();
+
+ $port = $1
+ if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
+
+ if(defined $proto) {
+ @proto = $proto =~ m,\D, ? getprotobyname($proto)
+ : getprotobynumber($proto);
+
+ $proto = $proto[2] || undef;
+ }
+
+ if(defined $port) {
+ $port =~ s,\((\d+)\)$,,;
+
+ my $defport = $1 || undef;
+ my $pnum = ($port =~ m,^(\d+)$,)[0];
+
+ @serv= getservbyname($port, $proto[0] || "")
+ if($port =~ m,\D,);
+
+ $port = $pnum || $serv[2] || $defport || undef;
+
+ $proto = (getprotobyname($serv[3]))[2] || undef
+ if @serv && !$proto;
+ }
+
+ return ($addr || undef,
+ $port || undef,
+ $proto || undef
+ );
+}
+
+sub _error {
+ my $sock = shift;
+ local($!);
+ $@ = join("",ref($sock),": ",@_);
+ close($sock)
+ if(defined fileno($sock));
+ return undef;
+}
+
+sub _get_addr {
+ my($sock,$addr_str, $multi) = @_;
+ my @addr;
+ if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
+ (undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
+ } else {
+ my $h = inet_aton($addr_str);
+ push(@addr, $h) if defined $h;
+ }
+ @addr;
+}
+
+sub configure {
+ my($sock,$arg) = @_;
+ my($lport,$rport,$laddr,$raddr,$proto,$type);
+
+
+ $arg->{LocalAddr} = $arg->{LocalHost}
+ if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
+
+ ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
+ $arg->{LocalPort},
+ $arg->{Proto});
+
+ $laddr = defined $laddr ? inet_aton($laddr)
+ : INADDR_ANY;
+
+ return _error($sock,"Bad hostname '",$arg->{LocalAddr},"'")
+ unless(defined $laddr);
+
+ $arg->{PeerAddr} = $arg->{PeerHost}
+ if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
+
+ unless(exists $arg->{Listen}) {
+ ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
+ $arg->{PeerPort},
+ $proto);
+ }
+
+ $proto ||= (getprotobyname('tcp'))[2];
+
+ my $pname = (getprotobynumber($proto))[0];
+ $type = $arg->{Type} || $socket_type{$pname};
+
+ my @raddr = ();
+
+ if(defined $raddr) {
+ @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
+ return _error($sock,"Bad hostname '",$arg->{PeerAddr},"'")
+ unless @raddr;
+ }
+
+ while(1) {
+
+ $sock->socket(AF_INET, $type, $proto) or
+ return _error($sock,"$!");
+
+ if ($arg->{Reuse}) {
+ $sock->sockopt(SO_REUSEADDR,1) or
+ return _error($sock,"$!");
+ }
+
+ if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
+ $sock->bind($lport || 0, $laddr) or
+ return _error($sock,"$!");
+ }
+
+ if(exists $arg->{Listen}) {
+ $sock->listen($arg->{Listen} || 5) or
+ return _error($sock,"$!");
+ last;
+ }
+
+ $raddr = shift @raddr;
+
+ return _error($sock,'Cannot determine remote port')
+ unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
+
+ last
+ unless($type == SOCK_STREAM || defined $raddr);
+
+ return _error($sock,"Bad hostname '",$arg->{PeerAddr},"'")
+ unless defined $raddr;
+
+# my $timeout = ${*$sock}{'io_socket_timeout'};
+# my $before = time() if $timeout;
+
+ if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
+# ${*$sock}{'io_socket_timeout'} = $timeout;
+ return $sock;
+ }
+
+ return _error($sock,"$!")
+ unless @raddr;
+
+# if ($timeout) {
+# my $new_timeout = $timeout - (time() - $before);
+# return _error($sock, "Timeout") if $new_timeout <= 0;
+# ${*$sock}{'io_socket_timeout'} = $new_timeout;
+# }
+
+ }
+
+ $sock;
+}
+
+sub connect {
+ @_ == 2 || @_ == 3 or
+ croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
+ my $sock = shift;
+ return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
+}
+
+sub bind {
+ @_ == 2 || @_ == 3 or
+ croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
+ my $sock = shift;
+ return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
+}
+
+sub sockaddr {
+ @_ == 1 or croak 'usage: $sock->sockaddr()';
+ my($sock) = @_;
+ my $name = $sock->sockname;
+ $name ? (sockaddr_in($name))[1] : undef;
+}
+
+sub sockport {
+ @_ == 1 or croak 'usage: $sock->sockport()';
+ my($sock) = @_;
+ my $name = $sock->sockname;
+ $name ? (sockaddr_in($name))[0] : undef;
+}
+
+sub sockhost {
+ @_ == 1 or croak 'usage: $sock->sockhost()';
+ my($sock) = @_;
+ my $addr = $sock->sockaddr;
+ $addr ? inet_ntoa($addr) : undef;
+}
+
+sub peeraddr {
+ @_ == 1 or croak 'usage: $sock->peeraddr()';
+ my($sock) = @_;
+ my $name = $sock->peername;
+ $name ? (sockaddr_in($name))[1] : undef;
+}
+
+sub peerport {
+ @_ == 1 or croak 'usage: $sock->peerport()';
+ my($sock) = @_;
+ my $name = $sock->peername;
+ $name ? (sockaddr_in($name))[0] : undef;
+}
+
+sub peerhost {
+ @_ == 1 or croak 'usage: $sock->peerhost()';
+ my($sock) = @_;
+ my $addr = $sock->peeraddr;
+ $addr ? inet_ntoa($addr) : undef;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::Socket::INET - Object interface for AF_INET domain sockets
+
+=head1 SYNOPSIS
+
+ use IO::Socket::INET;
+
+=head1 DESCRIPTION
+
+C<IO::Socket::INET> provides an object interface to creating and using sockets
+in the AF_INET domain. It is built upon the L<IO::Socket> interface and
+inherits all the methods defined by L<IO::Socket>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Socket::INET> object, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+
+In addition to the key-value pairs accepted by L<IO::Socket>,
+C<IO::Socket::INET> provides.
+
+
+ PeerAddr Remote host address <hostname>[:<port>]
+ PeerHost Synonym for PeerAddr
+ PeerPort Remote port or service <service>[(<no>)] | <no>
+ LocalAddr Local host bind address hostname[:port]
+ LocalHost Synonym for LocalAddr
+ LocalPort Local host bind port <service>[(<no>)] | <no>
+ Proto Protocol name (or number) "tcp" | "udp" | ...
+ Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
+ Listen Queue size for listen
+ Reuse Set SO_REUSEADDR before binding
+ Timeout Timeout value for various operations
+ MultiHomed Try all adresses for multi-homed hosts
+
+
+If C<Listen> is defined then a listen socket is created, else if the
+socket type, which is derived from the protocol, is SOCK_STREAM then
+connect() is called.
+
+Although it is not illegal, the use of C<MultiHomed> on a socket
+which is in non-blocking mode is of little use. This is because the
+first connect will never fail with a timeout as the connaect call
+will not block.
+
+The C<PeerAddr> can be a hostname or the IP-address on the
+"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic
+service name. The service name might be followed by a number in
+parenthesis which is used if the service is not known by the system.
+The C<PeerPort> specification can also be embedded in the C<PeerAddr>
+by preceding it with a ":".
+
+If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
+then the constructor will try to derive C<Proto> from the service
+name. As a last resort C<Proto> "tcp" is assumed. The C<Type>
+parameter will be deduced from C<Proto> if not specified.
+
+If the constructor is only passed a single argument, it is assumed to
+be a C<PeerAddr> specification.
+
+Examples:
+
+ $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
+ PeerPort => 'http(80)',
+ Proto => 'tcp');
+
+ $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
+
+ $sock = IO::Socket::INET->new(Listen => 5,
+ LocalAddr => 'localhost',
+ LocalPort => 9000,
+ Proto => 'tcp');
+
+ $sock = IO::Socket::INET->new('127.0.0.1:25');
+
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+As of VERSION 1.18 all IO::Socket objects have autoflush turned on
+by default. This was not the case with earlier releases.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+=head2 METHODS
+
+=over 4
+
+=item sockaddr ()
+
+Return the address part of the sockaddr structure for the socket
+
+=item sockport ()
+
+Return the port number that the socket is using on the local host
+
+=item sockhost ()
+
+Return the address part of the sockaddr structure for the socket in a
+text form xx.xx.xx.xx
+
+=item peeraddr ()
+
+Return the address part of the sockaddr structure for the socket on
+the peer host
+
+=item peerport ()
+
+Return the port number for the socket on the peer host.
+
+=item peerhost ()
+
+Return the address part of the sockaddr structure for the socket on the
+peer host in a text form xx.xx.xx.xx
+
+=back
+
+=head1 SEE ALSO
+
+L<Socket>, L<IO::Socket>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+# IO::Socket::UNIX.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Socket::UNIX;
+
+use strict;
+use vars qw(@ISA $VERSION);
+use IO::Socket;
+use Socket;
+use Carp;
+
+@ISA = qw(IO::Socket);
+$VERSION = "1.20";
+
+IO::Socket::UNIX->register_domain( AF_UNIX );
+
+sub new {
+ my $class = shift;
+ unshift(@_, "Peer") if @_ == 1;
+ return $class->SUPER::new(@_);
+}
+
+sub configure {
+ my($sock,$arg) = @_;
+ my($bport,$cport);
+
+ my $type = $arg->{Type} || SOCK_STREAM;
+
+ $sock->socket(AF_UNIX, $type, 0) or
+ return undef;
+
+ if(exists $arg->{Local}) {
+ my $addr = sockaddr_un($arg->{Local});
+ $sock->bind($addr) or
+ return undef;
+ }
+ if(exists $arg->{Listen}) {
+ $sock->listen($arg->{Listen} || 5) or
+ return undef;
+ }
+ elsif(exists $arg->{Peer}) {
+ my $addr = sockaddr_un($arg->{Peer});
+ $sock->connect($addr) or
+ return undef;
+ }
+
+ $sock;
+}
+
+sub hostpath {
+ @_ == 1 or croak 'usage: $sock->hostpath()';
+ my $n = $_[0]->sockname || return undef;
+ (sockaddr_un($n))[0];
+}
+
+sub peerpath {
+ @_ == 1 or croak 'usage: $sock->peerpath()';
+ my $n = $_[0]->peername || return undef;
+ (sockaddr_un($n))[0];
+}
+
+1; # Keep require happy
+
+__END__
+
+=head1 NAME
+
+IO::Socket::UNIX - Object interface for AF_UNIX domain sockets
+
+=head1 SYNOPSIS
+
+ use IO::Socket::UNIX;
+
+=head1 DESCRIPTION
+
+C<IO::Socket::UNIX> provides an object interface to creating and using sockets
+in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and
+inherits all the methods defined by L<IO::Socket>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Socket::UNIX> object, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+
+In addition to the key-value pairs accepted by L<IO::Socket>,
+C<IO::Socket::UNIX> provides.
+
+ Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
+ Local Path to local fifo
+ Peer Path to peer fifo
+ Listen Create a listen socket
+
+If the constructor is only passed a single argument, it is assumed to
+be a C<Peer> specification.
+
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+As of VERSION 1.18 all IO::Socket objects have autoflush turned on
+by default. This was not the case with earlier releases.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item hostpath()
+
+Returns the pathname to the fifo at the local end
+
+=item peerpath()
+
+Returns the pathanme to the fifo at the peer end
+
+=back
+
+=head1 SEE ALSO
+
+L<Socket>, L<IO::Socket>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+/*
+ * poll.c
+ *
+ * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ *
+ * For systems that do not have the poll() system call (for example Linux)
+ * try to emulate it as closely as possible using select()
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "poll.h"
+#ifdef I_SYS_TIME
+# include <sys/time.h>
+#endif
+#ifdef I_TIME
+# include <time.h>
+#endif
+#include <sys/types.h>
+#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
+# include <sys/socket.h>
+#endif
+#include <sys/stat.h>
+#include <errno.h>
+
+#ifdef EMULATE_POLL_WITH_SELECT
+
+# define POLL_CAN_READ (POLLIN | POLLRDNORM )
+# define POLL_CAN_WRITE (POLLOUT | POLLWRNORM | POLLWRBAND )
+# define POLL_HAS_EXCP (POLLRDBAND | POLLPRI )
+
+# define POLL_EVENTS_MASK (POLL_CAN_READ | POLL_CAN_WRITE | POLL_HAS_EXCP)
+
+int
+poll(fds, nfds, timeout)
+struct pollfd *fds;
+unsigned long nfds;
+int timeout;
+{
+ int i,err;
+ fd_set rfd,wfd,efd,ifd;
+ struct timeval timebuf;
+ struct timeval *tbuf = (struct timeval *)0;
+ int n = 0;
+ int count;
+
+ FD_ZERO(&ifd);
+
+again:
+
+ FD_ZERO(&rfd);
+ FD_ZERO(&wfd);
+ FD_ZERO(&efd);
+
+ for(i = 0 ; i < nfds ; i++) {
+ int events = fds[i].events;
+ int fd = fds[i].fd;
+
+ fds[i].revents = 0;
+
+ if(fd < 0 || FD_ISSET(fd, &ifd))
+ continue;
+
+ if(fd > n)
+ n = fd;
+
+ if(events & POLL_CAN_READ)
+ FD_SET(fd, &rfd);
+
+ if(events & POLL_CAN_WRITE)
+ FD_SET(fd, &wfd);
+
+ if(events & POLL_HAS_EXCP)
+ FD_SET(fd, &efd);
+ }
+
+ if(timeout >= 0) {
+ timebuf.tv_sec = timeout / 1000;
+ timebuf.tv_usec = (timeout % 1000) * 1000;
+ tbuf = &timebuf;
+ }
+
+ err = select(n+1,&rfd,&wfd,&efd,tbuf);
+
+ if(err < 0) {
+#ifdef HAS_FSTAT
+ if(errno == EBADF) {
+ for(i = 0 ; i < nfds ; i++) {
+ struct stat buf;
+ if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) {
+ FD_SET(fds[i].fd, &ifd);
+ goto again;
+ }
+ }
+ }
+#endif /* HAS_FSTAT */
+ return err;
+ }
+
+ count = 0;
+
+ for(i = 0 ; i < nfds ; i++) {
+ int revents = (fds[i].events & POLL_EVENTS_MASK);
+ int fd = fds[i].fd;
+
+ if(fd < 0)
+ continue;
+
+ if(FD_ISSET(fd, &ifd))
+ revents = POLLNVAL;
+ else {
+ if(!FD_ISSET(fd, &rfd))
+ revents &= ~POLL_CAN_READ;
+
+ if(!FD_ISSET(fd, &wfd))
+ revents &= ~POLL_CAN_WRITE;
+
+ if(!FD_ISSET(fd, &efd))
+ revents &= ~POLL_HAS_EXCP;
+ }
+
+ if((fds[i].revents = revents) != 0)
+ count++;
+ }
+
+ return count;
+}
+
+#endif /* EMULATE_POLL_WITH_SELECT */
--- /dev/null
+/*
+ * poll.h
+ *
+ * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ *
+ */
+
+#ifndef POLL_H
+# define POLL_H
+
+#if defined(I_POLL) || defined(POLLWRBAND)
+# include <poll.h>
+# ifndef HAS_POLL
+# define HAS_POLL
+# endif
+#else
+#ifdef HAS_SELECT
+
+
+/* We shall emulate poll using select */
+
+#define EMULATE_POLL_WITH_SELECT
+
+typedef struct pollfd {
+ int fd;
+ short events;
+ short revents;
+} pollfd_t;
+
+#define POLLIN 0x0001
+#define POLLPRI 0x0002
+#define POLLOUT 0x0004
+#define POLLRDNORM 0x0040
+#define POLLWRNORM POLLOUT
+#define POLLRDBAND 0x0080
+#define POLLWRBAND 0x0100
+#define POLLNORM POLLRDNORM
+
+/* Return ONLY events (NON testable) */
+
+#define POLLERR 0x0008
+#define POLLHUP 0x0010
+#define POLLNVAL 0x0020
+
+int poll _((struct pollfd *, unsigned long, int));
+
+#ifndef HAS_POLL
+# define HAS_POLL
+#endif
+
+#endif /* HAS_SELECT */
+
+#endif /* I_POLL */
+
+#endif /* POLL_H */
+
push_scope
ref
refkids
+reginitcolors
regdump
regexec_flags
regnext
case '|':
case '\001':
case '\002':
+ case '\003':
case '\004':
case '\005':
case '\006':
=head1 DESCRIPTION
+You should I<not> use this module in programs intended to be portable
+among Perl versions, programs that must perform regular expression
+matching operations efficiently, or libraries intended for use with
+such programs. In a sense, this module is deprecated. The reasons
+for this have to do with implementation details of the Perl
+interpreter which are too thorny to go into here. Perhaps someday
+they will be fixed to make "C<use English>" more practical.
+
This module provides aliases for the built-in variables whose
names no one seems to like to read. Variables with side-effects
which get triggered just by accessing them (like $0) will still
my $search = 1;
my($fullname, $thislib, $thispth);
+ # add "$Config{installarchlib}/CORE" to default search path
+ push @libpath, "$Config{installarchlib}/CORE";
+
foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){
$thislib = $_;
# if searching is disabled, do compiler-specific translations
unless ($search) {
- s/^-L/-libpath:/ if $VC;
s/^-l(.+)$/$1.lib/ unless $GC;
+ s/^-L/-libpath:/ if $VC;
push(@extralibs, $_);
$found++;
next;
If C<$potential_libs> is empty, the return value will be empty.
Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
will be appended to the list of C<$potential_libs>. The libraries
-will be searched for in the directories specified in C<$potential_libs>
-as well as in C<$Config{libpth}>. For each library that is found, a
-space-separated list of fully qualified library pathnames is generated.
+will be searched for in the directories specified in C<$potential_libs>,
+C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
+For each library that is found, a space-separated list of fully qualified
+library pathnames is generated.
=item *
@ISA = qw(Exporter);
@EXPORT = qw(Complete);
-# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91
+# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91
=head1 NAME
}
sub Complete {
- my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
+ my($prompt, @cmp_list, $cmp, $test, $l, @match);
+ my ($return, $r) = ("", 0);
$return = "";
$r = 0;
# (TAB) attempt completion
$_ eq "\t" && do {
@match = grep(/^$return/, @cmp_lst);
- $l = length($test = shift(@match));
unless ($#match < 0) {
+ $l = length($test = shift(@match));
foreach $cmp (@match) {
until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
$l--;
}
}
print("\a");
+ print($test = substr($test, $r, $l - $r));
+ $r = length($return .= $test);
}
- print($test = substr($test, $r, $l - $r));
- $r = length($return .= $test);
last CASE;
};
package Test;
use Test::Harness 1.1601 ();
use Carp;
-use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish
- qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish
-$VERSION = '1.04';
+use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
+ qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish
+$VERSION = '1.121';
require Exporter;
@ISA=('Exporter');
-@EXPORT= qw(&plan &ok &skip $ntest);
+@EXPORT=qw(&plan &ok &skip);
+@EXPORT_OK=qw($ntest $TESTOUT);
$TestLevel = 0; # how many extra stack frames to skip
$|=1;
#$^W=1; ?
$ntest=1;
+$TESTOUT = *STDOUT{IO};
# Use of this variable is strongly discouraged. It is set mainly to
# help test coverage analyzers know which test is running.
}
my @todo = sort { $a <=> $b } keys %todo;
if (@todo) {
- print "1..$max todo ".join(' ', @todo).";\n";
+ print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
} else {
- print "1..$max\n";
+ print $TESTOUT "1..$max\n";
}
++$planned;
}
(ref $v or '') eq 'CODE' ? $v->() : $v;
}
-# STDERR is NOT used for diagnostic output which should have been
-# fixed before release. Is this appropriate?
-
sub ok ($;$$) {
croak "ok: plan before you test!" if !$planned;
my ($pkg,$file,$line) = caller($TestLevel);
$ok = $result;
} else {
$expected = to_value(shift);
- # until regex can be manipulated like objects...
my ($regex,$ignore);
- if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
+ if ((ref($expected)||'') eq 're') {
+ $ok = $result =~ /$expected/;
+ } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
$ok = $result =~ /$regex/;
} else {
$ok = $result eq $expected;
}
}
- if ($todo{$ntest}) {
- if ($ok) {
- print "ok $ntest # Wow! ($context)\n";
- } else {
- $diag = to_value(shift) if @_;
- if (!$diag) {
- print "not ok $ntest # (failure expected in $context)\n";
- } else {
- print "not ok $ntest # (failure expected: $diag)\n";
- }
- }
+ my $todo = $todo{$ntest};
+ if ($todo and $ok) {
+ $context .= ' TODO?!' if $todo;
+ print $TESTOUT "ok $ntest # ($context)\n";
} else {
- print "not " if !$ok;
- print "ok $ntest\n";
+ print $TESTOUT "not " if !$ok;
+ print $TESTOUT "ok $ntest\n";
if (!$ok) {
my $detail = { 'repetition' => $repetition, 'package' => $pkg,
- 'result' => $result };
+ 'result' => $result, 'todo' => $todo };
$$detail{expected} = $expected if defined $expected;
$diag = $$detail{diagnostic} = to_value(shift) if @_;
+ $context .= ' *TODO*' if $todo;
if (!defined $expected) {
if (!$diag) {
- print STDERR "# Failed test $ntest in $context\n";
+ print $TESTOUT "# Failed test $ntest in $context\n";
} else {
- print STDERR "# Failed test $ntest in $context: $diag\n";
+ print $TESTOUT "# Failed test $ntest in $context: $diag\n";
}
} else {
my $prefix = "Test $ntest";
- print STDERR "# $prefix got: '$result' ($context)\n";
+ print $TESTOUT "# $prefix got: '$result' ($context)\n";
$prefix = ' ' x (length($prefix) - 5);
+ if ((ref($expected)||'') eq 're') {
+ $expected = 'qr/'.$expected.'/'
+ } else {
+ $expected = "'$expected'";
+ }
if (!$diag) {
- print STDERR "# $prefix Expected: '$expected'\n";
+ print $TESTOUT "# $prefix Expected: $expected\n";
} else {
- print STDERR "# $prefix Expected: '$expected' ($diag)\n";
+ print $TESTOUT "# $prefix Expected: $expected ($diag)\n";
}
}
push @FAILDETAIL, $detail;
}
sub skip ($$;$$) {
- if (to_value(shift)) {
- print "ok $ntest # skip\n";
+ my $whyskip = to_value(shift);
+ if ($whyskip) {
+ $whyskip = 'skip' if $whyskip =~ m/^\d+$/;
+ print $TESTOUT "ok $ntest # $whyskip\n";
++ $ntest;
1;
} else {
use strict;
use Test;
- BEGIN { plan tests => 13, todo => [3,4] }
+
+ # use a BEGIN block so we print our plan before MyModule is loaded
+ BEGIN { plan tests => 14, todo => [3,4] }
+
+ # load your module...
+ use MyModule;
ok(0); # failure
ok(1); # success
ok(0,1); # failure: '0' ne '1'
ok('broke','fixed'); # failure: 'broke' ne 'fixed'
ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
+ ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
ok(sub { 1+1 }, 2); # success: '2' eq '2'
ok(sub { 1+1 }, 3); # failure: '2' ne '3'
=head1 DESCRIPTION
-Test::Harness expects to see particular output when it executes tests.
-This module aims to make writing proper test scripts just a little bit
-easier (and less error prone :-).
+L<Test::Harness> expects to see particular output when it executes
+tests. This module aims to make writing proper test scripts just a
+little bit easier (and less error prone :-).
=head1 TEST TYPES
=item * NORMAL TESTS
-These tests are expected to succeed. If they don't, something's
+These tests are expected to succeed. If they don't something's
screwed up!
=item * SKIPPED TESTS
-Skip tests need a platform specific feature that might or might not be
-available. The first argument should evaluate to true if the required
-feature is NOT available. After the first argument, skip tests work
+Skip is for tests that might or might not be possible to run depending
+on the availability of platform specific features. The first argument
+should evaluate to true (think "yes, please skip") if the required
+feature is not available. After the first argument, skip works
exactly the same way as do normal tests.
=item * TODO TESTS
-TODO tests are designed for maintaining an executable TODO list.
-These tests are expected NOT to succeed (otherwise the feature they
-test would be on the new feature list, not the TODO list).
+TODO tests are designed for maintaining an B<executable TODO list>.
+These tests are expected NOT to succeed. If a TODO test does succeed,
+the feature in question should not be on the TODO list, now should it?
-Packages should NOT be released with successful TODO tests. As soon
+Packages should NOT be released with succeeding TODO tests. As soon
as a TODO test starts working, it should be promoted to a normal test
-and the newly minted feature should be documented in the release
-notes.
+and the newly working feature should be documented in the release
+notes or change log.
=back
+=head1 RETURN VALUE
+
+Both C<ok> and C<skip> return true if their test succeeds and false
+otherwise in a scalar context.
+
=head1 ONFAIL
BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
-The test failures can trigger extra diagnostics at the end of the test
-run. C<onfail> is passed an array ref of hash refs that describe each
-test failure. Each hash will contain at least the following fields:
-package, repetition, and result. (The file, line, and test number are
-not included because their correspondance to a particular test is
-fairly weak.) If the test had an expected value or a diagnostic
-string, these will also be included.
-
-This optional feature might be used simply to print out the version of
-your package and/or how to report problems. It might also be used to
-generate extremely sophisticated diagnostics for a particular test
-failure. It's not a panacea, however. Core dumps or other
-unrecoverable errors will prevent the C<onfail> hook from running.
-(It is run inside an END block.) Besides, C<onfail> is probably
-over-kill in the majority of cases. (Your test code should be simpler
+While test failures should be enough, extra diagnostics can be
+triggered at the end of a test run. C<onfail> is passed an array ref
+of hash refs that describe each test failure. Each hash will contain
+at least the following fields: C<package>, C<repetition>, and
+C<result>. (The file, line, and test number are not included because
+their correspondance to a particular test is tenuous.) If the test
+had an expected value or a diagnostic string, these will also be
+included.
+
+The B<optional> C<onfail> hook might be used simply to print out the
+version of your package and/or how to report problems. It might also
+be used to generate extremely sophisticated diagnostics for a
+particularly bizarre test failure. However it's not a panacea. Core
+dumps or other unrecoverable errors prevent the C<onfail> hook from
+running. (It is run inside an C<END> block.) Besides, C<onfail> is
+probably over-kill in most cases. (Your test code should be simpler
than the code it is testing, yes?)
=head1 SEE ALSO
-L<Test::Harness> and various test coverage analysis tools.
+L<Test::Harness> and, perhaps, test coverage analysis tools.
=head1 AUTHOR
Get a single character
+=item CLOSE this
+
+Close the handle
+
=item DESTROY this
Free the storage associated with the tied handle referenced by I<this>.
register REGEXP *rx;
char *t;
- if (PL_curpm && (rx = PL_curpm->op_pmregexp))
- return rx->lastparen;
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ if (mg->mg_obj) /* @+ */
+ return rx->nparens;
+ else /* @- */
+ return rx->lastparen;
+ }
+
return (U32)-1;
}
(t = rx->endp[paren]))
{
if (mg->mg_obj) /* @+ */
- i = t - rx->subbase;
+ i = t - rx->subbeg;
else /* @- */
- i = s - rx->subbase;
+ i = s - rx->subbeg;
sv_setiv(sv,i);
}
}
/* printf("some %s\n", printW(PL_curcop->cop_warnings)), */
sv_setsv(sv, PL_curcop->cop_warnings);
break;
+ case '\003': /* ^C */
+ sv_setiv(sv, (IV)PL_minus_c);
+ break;
+
case '\004': /* ^D */
sv_setiv(sv, (IV)(PL_debug & 32767));
break;
}
}
break;
+
+ case '\003': /* ^C */
+ PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
+
case '\004': /* ^D */
PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
DEBUG_x(dump_all());
#define PL_profiledata pPerl->PL_profiledata
#undef PL_reg_call_cc
#define PL_reg_call_cc pPerl->PL_reg_call_cc
+#undef PL_reg_curpm
+#define PL_reg_curpm pPerl->PL_reg_curpm
#undef PL_reg_eval_set
#define PL_reg_eval_set pPerl->PL_reg_eval_set
#undef PL_reg_flags
#define PL_reg_flags pPerl->PL_reg_flags
+#undef PL_reg_ganch
+#define PL_reg_ganch pPerl->PL_reg_ganch
+#undef PL_reg_magic
+#define PL_reg_magic pPerl->PL_reg_magic
+#undef PL_reg_oldcurpm
+#define PL_reg_oldcurpm pPerl->PL_reg_oldcurpm
+#undef PL_reg_oldpos
+#define PL_reg_oldpos pPerl->PL_reg_oldpos
#undef PL_reg_re
#define PL_reg_re pPerl->PL_reg_re
#undef PL_reg_start_tmp
#define PL_reg_start_tmp pPerl->PL_reg_start_tmp
#undef PL_reg_start_tmpl
#define PL_reg_start_tmpl pPerl->PL_reg_start_tmpl
+#undef PL_reg_starttry
+#define PL_reg_starttry pPerl->PL_reg_starttry
+#undef PL_reg_sv
+#define PL_reg_sv pPerl->PL_reg_sv
#undef PL_regbol
#define PL_regbol pPerl->PL_regbol
#undef PL_regcc
#define reginclass pPerl->Perl_reginclass
#undef reginclassutf8
#define reginclassutf8 pPerl->Perl_reginclassutf8
+#undef reginitcolors
+#define reginitcolors pPerl->Perl_reginitcolors
#undef reginsert
#define reginsert pPerl->Perl_reginsert
#undef regmatch
#define restore_lex_expect pPerl->Perl_restore_lex_expect
#undef restore_magic
#define restore_magic pPerl->Perl_restore_magic
+#undef restore_pos
+#define restore_pos pPerl->Perl_restore_pos
#undef restore_rsfp
#define restore_rsfp pPerl->Perl_restore_rsfp
#undef rninstr
$^E was reset on the second read, and contained ".\r\n" at the end.
after 5.005_53:
+ Would segfault system()ing non-existing program;
+ AOUT build was hosed;
warning-test for getpriority() might lock the system hard on
pre-fixpak22 configuration (calling getpriority() on
non-existing process triggers a system-wide bug).
PERL_VERSION = $perl_version
+OPTIMIZE = $optimize
AOUT_OPTIMIZE = \$(OPTIMIZE)
AOUT_CCCMD = \$(CC) $aout_ccflags \$(AOUT_OPTIMIZE)
AOUT_AR = $aout_ar
/* Try adding script extensions to the file name, and
search on PATH. */
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
- int l = strlen(scr);
-
- if (l >= sizeof scrbuf) {
- Safefree(scr);
- longbuf:
- croak("Size of scriptname too big: %d", l);
- }
- strcpy(scrbuf, scr);
- Safefree(scr);
- scr = scrbuf;
if (scr) {
- FILE *file = fopen(scr, "r");
+ FILE *file;
char *s = 0, *s1;
+ int l;
+ l = strlen(scr);
+
+ if (l >= sizeof scrbuf) {
+ Safefree(scr);
+ longbuf:
+ croak("Size of scriptname too big: %d", l);
+ }
+ strcpy(scrbuf, scr);
+ Safefree(scr);
+ scr = scrbuf;
+
+ file = fopen(scr, "r");
PL_Argv[0] = scr;
if (!file)
goto panic_file;
Safefree(PL_origfilename);
Safefree(PL_archpat_auto);
Safefree(PL_reg_start_tmp);
+ if (PL_reg_curpm)
+ Safefree(PL_reg_curpm);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
nuke_stacks();
perlform.pod \
perllocale.pod \
perlref.pod \
+ perlreftut.pod \
perldsc.pod \
perllol.pod \
perltoot.pod \
perlform.man \
perllocale.man \
perlref.man \
+ perlreftut.man \
perldsc.man \
perllol.man \
perltoot.man \
perlform.html \
perllocale.html \
perlref.html \
+ perlreftut.html \
perldsc.html \
perllol.html \
perltoot.html \
perlform.tex \
perllocale.tex \
perlref.tex \
+ perlreftut.tex \
perldsc.tex \
perllol.tex \
perltoot.tex \
perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5
perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata
perlsyn perlop perlre perlrun perlfunc perlvar perlsub
- perlmod perlmodlib perlmodinstall perlform perllocale perlref perldsc
+ perlmod perlmodlib perlmodinstall perlform perllocale
+ perlref perlreftut perldsc
perllol perltoot perlobj perltie perlbot perlipc perldebug
perldiag perlsec perltrap perlport perlstyle perlpod perlbook
perlembed perlapio perlxs perlxstut perlguts perlcall
perllocale Perl locale support
perlref Perl references
+ perlreftut Perl references short introduction
perldsc Perl data structures intro
perllol Perl data structures: lists of lists
perltoot Perl OO tutorial
($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00);
-Array assignment in a scalar context returns the number of elements
+List assignment in a scalar context returns the number of elements
produced by the expression on the right side of the assignment:
$x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2
=item qw/STRING/
-Generalized quotes. See L<perlop>.
+Generalized quotes. See L<perlop/"Regexp Quote-Like Operators">.
=item quotemeta EXPR
implementation for the variable. VARIABLE is the name of the variable
to be enchanted. CLASSNAME is the name of a class implementing objects
of correct type. Any additional arguments are passed to the "C<new()>"
-method of the class (meaning C<TIESCALAR>, C<TIEARRAY>, or C<TIEHASH>).
-Typically these are arguments such as might be passed to the C<dbm_open()>
-function of C. The object returned by the "C<new()>" method is also
-returned by the C<tie()> function, which would be useful if you want to
-access other methods in CLASSNAME.
+method of the class (meaning C<TIESCALAR>, C<TIEHANDLE>, C<TIEARRAY>,
+or C<TIEHASH>). Typically these are arguments such as might be passed
+to the C<dbm_open()> function of C. The object returned by the "C<new()>"
+method is also returned by the C<tie()> function, which would be useful
+if you want to access other methods in CLASSNAME.
Note that functions such as C<keys()> and C<values()> may return huge lists
when used on large objects, like DBM files. You may prefer to use the
A class implementing a hash should have the following methods:
TIEHASH classname, LIST
- DESTROY this
FETCH this, key
STORE this, key, value
DELETE this, key
+ CLEAR this
EXISTS this, key
FIRSTKEY this
NEXTKEY this, lastkey
+ DESTROY this
A class implementing an ordinary array should have the following methods:
TIEARRAY classname, LIST
- DESTROY this
FETCH this, key
STORE this, key, value
- [others TBD]
+ FETCHSIZE this
+ STORESIZE this, count
+ CLEAR this
+ PUSH this, LIST
+ POP this
+ SHIFT this
+ UNSHIFT this, LIST
+ SPLICE this, offset, length, LIST
+ EXTEND this, count
+ DESTROY this
+
+A class implementing a file handle should have the following methods:
+
+ TIEHANDLE classname, LIST
+ READ this, scalar, length, offset
+ READLINE this
+ GETC this
+ WRITE this, scalar, length, offset
+ PRINT this, LIST
+ PRINTF this, format, LIST
+ CLOSE this
+ DESTROY this
A class implementing a scalar should have the following methods:
TIESCALAR classname, LIST
- DESTROY this
FETCH this,
STORE this, value
+ DESTROY this
+
+Not all methods indicated above need be implemented. See L<perltie>,
+L<Tie::Hash>, L<Tie::Array>, L<Tie::Scalar> and L<Tie::Handle>.
Unlike C<dbmopen()>, the C<tie()> function will not use or require a module
for you--you need to do that explicitly yourself. See L<DB_File>
=item qr/STRING/imosx
-A string which is (possibly) interpolated and then compiled as a
-regular expression. The result may be used as a pattern in a match
+Quote-as-a-regular-expression operator. I<STRING> is interpolated the
+same way as I<PATTERN> in C<m/PATTERN/>. Returns a Perl value which
+may be used instead of the corresponding C</STRING/imosx> expression.
+
+For example,
+
+ $rex = qr/my.STRING/is;
+ s/$rex/foo/;
+
+is equivalent to
+
+ s/my.STRING/foo/is;
+
+The result may be used as a subpattern in a match:
$re = qr/$pattern/;
$string =~ /foo${re}bar/; # can be interpolated in other patterns
$string =~ $re; # or used standalone
+ $string =~ /$re/; # or this way
+
+Since Perl may compile the pattern at the moment of execution of qr()
+operator, using qr() may have speed advantages in I<some> situations,
+notably if the result of qr() is used standalone:
+
+ sub match {
+ my $patterns = shift;
+ my @compiled = map qr/$_/i, @$patterns;
+ grep {
+ my $success = 0;
+ foreach my $pat @compiled {
+ $success = 1, last if /$pat/;
+ }
+ $success;
+ } @_;
+ }
+
+Precompilation of the pattern into an internal representation at the
+moment of qr() avoids a need to recompile the pattern every time a
+match C</$pat/> is attempted. (Note that Perl has many other
+internal optimizations, but none would be triggered in the above
+example if we did not use qr() operator.)
Options are:
s Treat string as single line.
x Use extended regular expressions.
-The benefit from this is that the pattern is precompiled into an internal
-representation, and does not need to be recompiled every time a match
-is attempted. This makes it very efficient to do something like:
-
- foreach $pattern (@pattern_list) {
- my $re = qr/$pattern/;
- foreach $line (@lines) {
- if($line =~ /$re/) {
- do_something($line);
- }
- }
- }
-
See L<perlre> for additional information on valid syntax for STRING, and
for a detailed look at the semantics of regular expressions.
(the quotes are optional)
L</"sec"> ditto
same as above but only 'text' is used for output.
- (Text can not contain the characters '|' or '>')
+ (Text can not contain the characters '/' and '|',
+ and should contain matched '<' or '>')
L<text|name>
L<text|name/ident>
L<text|name/"sec">
E<escape> A named character (very similar to HTML escapes)
E<lt> A literal <
E<gt> A literal >
+ E<sol> A literal /
+ E<verbar> A literal |
(these are optional except in other interior
sequences and when preceded by a capital letter)
E<n> Character number n (probably in ASCII)
perlref - Perl references and nested data structures
+=head1 NOTE
+
+This is complete documentation about all aspects of references.
+For a shorter, tutorial introduction to just the essential features,
+see L<perlreftut>.
+
=head1 DESCRIPTION
Before release 5 of Perl it was difficult to represent complex data
--- /dev/null
+
+=head1 NAME
+
+perlreftut - Mark's very short tutorial about references
+
+=head1 DESCRIPTION
+
+One of the most important new features in Perl 5 was the capability to
+manage complicated data structures like multidimensional arrays and
+nested hashes. To enable these, Perl 5 introduced a feature called
+`references', and using references is the key to managing complicated,
+structured data in Perl. Unfortunately, there's a lot of funny syntax
+to learn, and the main manual page can be hard to follow. The manual
+is quite complete, and sometimes people find that a problem, because it
+can be hard to tell what is important and what isn't.
+
+Fortunately, you only need to know 10% of what's in the main page to get
+90% of the benefit. This page will show you that 10%.
+
+=head1 Who Needs Complicated Data Structures?
+
+One problem that came up all the time in Perl 4 was how to represent a
+hash whose values were lists. Perl 4 had hashes, of course, but the
+values had to be scalars; they couldn't be lists.
+
+Why would you want a hash of lists? Let's take a simple example: You
+have a file of city and state names, like this:
+
+ Chicago, Illinois
+ New York, New York
+ Albany, New York
+ Springfield, Illinois
+ Trenton, New Jersey
+ Evanston, Illinois
+
+and you want to produce an output like this, with each state mentioned
+once, and then an alphabetical list of the cities in that state:
+
+ Illinois: Chicago, Evanston, Springfield.
+ New Jersey: Trenton.
+ New York: Albany, New York.
+
+The natural way to do this is to have a hash whose keys are state
+names. Associated with each state name key is a list of the cities in
+that state. Each time you read a line of input, split it into a state
+and a city, look up the list of cities already known to be in that
+state, and append the new city to the list. When you're done reading
+the input, iterate over the hash as usual, sorting each list of cities
+before you print it out.
+
+If hash values can't be lists, you lose. In Perl 4, hash values can't
+be lists; they can only be strings. You lose. You'd probably have to
+combine all the cities into a single string somehow, and then when
+time came to write the output, you'd have to break the string into a
+list, sort the list, and turn it back into a string. This is messy
+and error-prone. And it's frustrating, because Perl already has
+perfectly good lists that would solve the problem if only you could
+use them.
+
+=head1 The Solution
+
+Unfortunately, by the time Perl 5 rolled around, we were already stuck
+with this design: Hash values must be scalars. The solution to this is
+references.
+
+A reference is a scalar value that I<refers to> an entire array or an
+entire hash (or to just about anything else.) Names are one kind of
+reference that you're already familiar with. Think of the President:
+a messy, inconvenient bag of blood and bones. But to talk about him,
+or to represent him in a computer program, all you need is the easy,
+convenient scalar string "Bill Clinton".
+
+References in Perl are like names for arrays and hashes. They're
+Perl's private, internal names, so you can be sure they're
+unambiguous. Unlike "Bill Clinton", a reference only refers to one
+thing, and you always know what it refers to. If you have a reference
+to an array, you can recover the entire array from it. If you have a
+reference to a hash, you can recover the entire hash. But the
+reference is still an easy, compact scalar value.
+
+You can't have a hash whose values are arrays; hash values can only be
+scalars. We're stuck with that. But a single reference can refer to
+an entire array, and references are scalars, so you can have a hash of
+references to arrays, and it'll act a lot like a hash of arrays, and
+it'll be just as useful as a hash of arrays.
+
+We'll come back to this city-state problem later, after we've seen
+some syntax for managing references.
+
+
+=head1 Syntax
+
+There are just two ways to make a reference, and just two ways to use
+it once you have it.
+
+=head2 Making References
+
+B<Make Rule 1>
+
+If you put a C<\> in front of a variable, you get a
+reference to that variable.
+
+ $aref = \@array; # $aref now holds a reference to @array
+ $href = \%hash; # $href now holds a reference to %hash
+
+Once the reference is stored in a variable like $aref or $href, you
+can copy it or store it just the same as any other scalar value:
+
+ $xy = $aref; # $xy now holds a reference to @array
+ $p[3] = $href; # $p[3] now holds a reference to %hash
+ $z = $p[3]; # $z now holds a reference to %hash
+
+
+These examples show how to make references to variables with names.
+Sometimes you want to make an array or a hash that doesn't have a
+name. This is analogous to the way you like to be able to use the
+string C<"\n"> or the number 80 without having to store it in a named
+variable first.
+
+B<Make Rule 2>
+
+C<[ ITEMS ]> makes a new, anonymous array, and returns a reference to
+that array. C<{ ITEMS }> makes a new, anonymous hash. and returns a
+reference to that hash.
+
+ $aref = [ 1, "foo", undef, 13 ];
+ # $aref now holds a reference to an array
+
+ $href = { APR => 4, AUG => 8 };
+ # $href now holds a reference to a hash
+
+
+The references you get from rule 2 are the same kind of
+references that you get from rule 1:
+
+ # This:
+ $aref = [ 1, 2, 3 ];
+
+ # Does the same as this:
+ @array = (1, 2, 3);
+ $aref = \@array;
+
+
+The first line is an abbreviation for the following two lines, except
+that it doesn't create the superfluous array variable C<@array>.
+
+
+=head2 Using References
+
+What can you do with a reference once you have it? It's a scalar
+value, and we've seen that you can store it as a scalar and get it back
+again just like any scalar. There are just two more ways to use it:
+
+B<Use Rule 1>
+
+If C<$aref> contains a reference to an array, then you
+can put C<{$aref}> anywhere you would normally put the name of an
+array. For example, C<@{$aref}> instead of C<@array>.
+
+Here are some examples of that:
+
+Arrays:
+
+
+ @a @{$aref} An array
+ reverse @a reverse @{$aref} Reverse the array
+ $a[3] ${$aref}[3] An element of the array
+ $a[3] = 17; ${$aref}[3] = 17 Assigning an element
+
+
+On each line are two expressions that do the same thing. The
+left-hand versions operate on the array C<@a>, and the right-hand
+versions operate on the array that is referred to by C<$aref>, but
+once they find the array they're operating on, they do the same things
+to the arrays.
+
+Using a hash reference is I<exactly> the same:
+
+ %h %{$href} A hash
+ keys %h keys %{$href} Get the keys from the hash
+ $h{'red'} ${$href}{'red'} An element of the hash
+ $h{'red'} = 17 ${$href}{'red'} = 17 Assigning an element
+
+
+B<Use Rule 2>
+
+C<${$aref}[3]> is too hard to read, so you can write C<$aref-E<gt>[3]>
+instead.
+
+C<${$href}{red}> is too hard to read, so you can write
+C<$href-E<gt>{red}> instead.
+
+Most often, when you have an array or a hash, you want to get or set a
+single element from it. C<${$aref}[3]> and C<${$href}{'red'}> have
+too much punctuation, and Perl lets you abbreviate.
+
+If C<$aref> holds a reference to an array, then C<$aref-E<gt>[3]> is
+the fourth element of the array. Don't confuse this with C<$aref[3]>,
+which is the fourth element of a totally different array, one
+deceptively named C<@aref>. C<$aref> and C<@aref> are unrelated the
+same way that C<$item> and C<@item> are.
+
+Similarly, C<$href-E<gt>{'red'}> is part of the hash referred to by
+the scalar variable C<$href>, perhaps even one with no name.
+C<$href{'red'}> is part of the deceptively named C<%href> hash. It's
+easy to forget to leave out the C<-E<gt>>, and if you do, you'll get
+bizarre results when your program gets array and hash elements out of
+totally unexpected hashes and arrays that weren't the ones you wanted
+to use.
+
+
+=head1 An Example
+
+Let's see a quick example of how all this is useful.
+
+First, remember that C<[1, 2, 3]> makes an anonymous array containing
+C<(1, 2, 3)>, and gives you a reference to that array.
+
+Now think about
+
+ @a = ( [1, 2, 3],
+ [4, 5, 6],
+ [7, 8, 9]
+ );
+
+@a is an array with three elements, and each one is a reference to
+another array.
+
+C<$a[1]> is one of these references. It refers to an array, the array
+containing C<(4, 5, 6)>, and because it is a reference to an array,
+B<USE RULE 2> says that we can write C<$a[1]-E<gt>[2]> to get the
+third element from that array. C<$a[1]-E<gt>[2]> is the 6.
+Similarly, C<$a[0]-E<gt>[1]> is the 2. What we have here is like a
+two-dimensional array; you can write C<$a[ROW]-E<gt>[COLUMN]> to get
+or set the element in any row and any column of the array.
+
+The notation still looks a little cumbersome, so there's one more
+abbreviation:
+
+=head1 Arrow Rule
+
+In between two B<subscripts>, the arrow is optional.
+
+Instead of C<$a[1]-E<gt>[2]>, we can write C<$a[1][2]>; it means the
+same thing. Instead of C<$a[0]-E<gt>[1]>, we can write C<$a[0][1]>;
+it means the same thing.
+
+Now it really looks like two-dimensional arrays!
+
+You can see why the arrows are important. Without them, we would have
+had to write C<${$a[1]}[2]> instead of C<$a[1][2]>. For
+three-dimensional arrays, they let us write C<$x[2][3][5]> instead of
+the unreadable C<${${$x[2]}[3]}[5]>.
+
+
+=head1 Solution
+
+Here's the answer to the problem I posed the the beginning of the
+article, of reformatting a file of city and state names.
+
+ 1 while (<>) {
+ 2 chomp;
+ 3 my ($city, $state) = split /, /;
+ 4 push @{$table{$state}}, $city;
+ 5 }
+ 6
+ 7 foreach $state (sort keys %table) {
+ 8 print "$state: ";
+ 9 my @cities = @{$table{$state}};
+ 10 print join ', ', sort @cities;
+ 11 print ".\n";
+ 12 }
+
+
+The program has two pieces: Lines 1--5 read the input and build a
+data structure, and lines 7--12 analyze the data and print out the
+report.
+
+In the first part, line 4 is the important one. We're going to have a
+hash, C<%table>, whose keys are state names, and whose values are
+(references to) arrays of city names. After acquiring a city and
+state name, the program looks up C<$table{$state}>, which holds (a
+reference to) the list of cities seen in that state so far. Line 4 is
+totally analogous to
+
+ push @array, $city;
+
+except that the name C<array> has been replaced by the reference
+C<{$table{$state}}>. The C<push> adds a city name to the end of the
+referred-to array.
+
+In the second part, line 9 is the important one. Again,
+C<$table{$state}> is (a reference to) the list of cities in the state, so
+we can recover the original list, and copy it into the array C<@cities>,
+by using C<@{$table{$state}}>. Line 9 is totally analogous to
+
+ @cities = @array;
+
+except that the name C<array> has been replaced by the reference
+C<{$table{$state}}>. The C<@> tells Perl to get the entire array.
+
+The rest of the program is just familiar uses of C<chomp>, C<split>, C<sort>,
+C<print>, and doesn't involve references at all.
+
+There's one fine point I skipped. Suppose the program has just read
+the first line in its input that happens to mention the state of Ohio.
+Control is at line 4, C<$state> is C<'Ohio'>, and C<$city> is
+C<'Cleveland'>. Since this is the first city in Ohio,
+C<$table{$state}> is undefined---in fact there isn't an C<'Ohio'> key
+in C<%table> at all. What does line 4 do here?
+
+ 4 push @{$table{$state}}, $city;
+
+
+This is Perl, so it does the exact right thing. It sees that you want
+to push C<Cleveland> onto an array that doesn't exist, so it helpfully
+makes a new, empty, anonymous array for you, installs it in the table,
+and then pushes C<Cleveland> onto it. This is called `autovivification'.
+
+
+=head1 The Rest
+
+I promised to give you 90% of the benefit with 10% of the details, and
+that means I left out 90% of the details. Now that you have an
+overview of the important parts, it should be easier to read the
+L<perlref> manual page, which discusses 100% of the details.
+
+Some of the highlights of L<perlref>:
+
+=over 4
+
+=item *
+
+You can make references to anything, including scalars, functions, and
+other references.
+
+=item *
+
+In B<USE RULE 1>, you can often omit the curly braces. For example,
+C<@$aref> is the same as C<@{$aref}>, and C<$$aref[1]> is the same as
+C<${$aref}[1]>. If you're jsut starting out, you might want to adopt
+the habit of always including the curly braces.
+
+=item *
+
+To see if a variable contains a reference, use the `ref' function.
+It returns true if its argument is a reference. Actually it's a
+little better than that: It returns HASH for hash references and
+ARRAYfor array references.
+
+=item *
+
+If you try to use a reference like a string, you get strings like
+
+ ARRAY(0x80f5dec) or HASH(0x826afc0)
+
+If you ever see a string that looks like this, you'll know you
+printed out a reference by mistake.
+
+A side effect of this representation is that you can use C<eq> to see
+if two references refer to the same thing. (But you should usually use
+C<==> instead because it's much faster.)
+
+=item *
+
+You can use a string as if it were a reference. If you use the string
+C<"foo"> as an array reference, it's taken to be a reference to the
+array C<@foo>. This is called a I<soft reference> or I<symbolic reference>.
+
+=back
+
+You might prefer to go on to L<perllol> instead of L<perlref>; it
+discusses lists of lists and multidimensional arrays in detail. After
+that, you should move on to L<perldsc>; it's a Data Structure Cookbook
+that shows recipes for using and printing out arrays of hashes, hashes
+of arrays, and other kinds of data.
+
+=head1 Summary
+
+Everyone needs compound data structures, and in Perl the way you get
+them is with references. There are four important rules for managing
+references: Two for making references and two for using them. Once
+you know these rules you can do most of the important things you need
+to do with references.
+
+=head1 Credits
+
+Author: Mark-Jason Dominus, Plover Systems (C<mjd-perl-ref@plover.com>)
+
+This article originally appeared in I<The Perl Journal> volume 3, #2.
+Reprinted with permission.
+
+The original title was I<Understand References Today>.
+
+
+=cut
+
long names in the current package. Some even have medium names,
generally borrowed from B<awk>.
+Due to an unfortunate accident of Perl's implementation, "C<use English>"
+imposes a considerable performance penalty on all regular expression
+matches in a program, regardless of whether they occur in the scope of
+"C<use English>". For that reason, saying "C<use English>" in
+libraries is strongly discouraged. See the Devel::SawAmpersand module
+documentation from CPAN
+(http://www.perl.com/CPAN/modules/by-module/Devel/Devel-SawAmpersand-0.10.readme)
+for more information.
+
To go a step further, those variables that depend on the currently
selected filehandle may instead (and preferably) be set by calling an
object method on the FileHandle object. (Summary lines below for this
any matches hidden within a BLOCK or eval() enclosed by the current
BLOCK). (Mnemonic: like & in some editors.) This variable is read-only.
+The use of this variable anywhere in a program imposes a considerable
+performance penalty on all regular expression matches. See the
+Devel::SawAmpersand module from CPAN for more information.
+
=item $PREMATCH
=item $`
enclosed by the current BLOCK). (Mnemonic: C<`> often precedes a quoted
string.) This variable is read-only.
+The use of this variable anywhere in a program imposes a considerable
+performance penalty on all regular expression matches. See the
+Devel::SawAmpersand module from CPAN for more information.
+
=item $POSTMATCH
=item $'
This variable is read-only.
+The use of this variable anywhere in a program imposes a considerable
+performance penalty on all regular expression matches. See the
+Devel::SawAmpersand module from CPAN for more information.
+
=item $LAST_PAREN_MATCH
=item $+
$+[0] is the offset of the end of the last successfull match.
C<$+[>I<n>C<]> is the offset of the end of the substring matched by
-I<n>-th subpattern.
+I<n>-th subpattern, or undef if the subpattern did not match.
Thus after a match against $_, $& coincides with C<substr $_, $-[0],
-$+[0]>. Similarly, C<$>I<n> coincides with C<substr $_, $-[>I<n>C<],
-$+[>I<0>C<]> if C<$-[>I<n>C<]> is defined, and $+ conincides with
-C<substr $_, $-[-1], $+[-1]>. One can use C<$#+> to find the last
-matched subgroup in the last successful match. Compare with L<"@-">.
+$+[0] - $-[0]>. Similarly, C<$>I<n> coincides with C<substr $_, $-[>I<n>C<],
+$+[>I<n>C<] - $-[>I<n>C<]> if C<$-[>I<n>C<]> is defined, and $+ coincides with
+C<substr $_, $-[$#-], $+[$#-]>. One can use C<$#+> to find the number
+of subgroups in the last successful match. Note the difference with
+C<$#->, which is the last I<matched> subgroup. Compare with L<"@-">.
=item $MULTILINE_MATCHING
$-[0] is the offset of the start of the last successfull match.
C<$-[>I<n>C<]> is the offset of the start of the substring matched by
-I<n>-th subpattern.
+I<n>-th subpattern, or undef if the subpattern did not match.
Thus after a match against $_, $& coincides with C<substr $_, $-[0],
-$+[0]>. Similarly, C<$>I<n> coincides with C<substr $_, $-[>I<n>C<],
-$+[>I<0>C<]> if C<$-[>I<n>C<]> is defined, and $+ conincides with
-C<substr $_, $-[-1], $+[-1]>. One can use C<$#-> to find the last
-matched subgroup in the last successful match. Compare with L<"@+">.
+$+[0] - $-[0]>. Similarly, C<$>I<n> coincides with C<substr $_, $-[>I<n>C<],
+$+[>I<n>C<] - $-[>I<n>C<]> if C<$-[>I<n>C<]> is defined, and $+ coincides with
+C<substr $_, $-[$#-], $+[$#-]>. One can use C<$#-> to find the last
+matched subgroup in the last successful match. Note the difference with
+C<$#+>, which is the number of subgroups in the regular expression. Compare
+with L<"@+">.
=item format_name HANDLE EXPR
$mandir/perlform.1 \
$mandir/perllocale.1 \
$mandir/perlref.1 \
+ $mandir/perlreftut.1 \
$mandir/perldsc.1 \
$mandir/perllol.1 \
$mandir/perltoot.1 \
else {
maxiters += (strend - s) * rx->nparens;
while (s < strend && --limit &&
- CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
+ CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
{
TAINT_IF(RX_MATCH_TAINTED(rx));
if (rx->subbase
/* Are we done */
if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
- s == m, Nullsv, NULL,
- cx->sb_safebase ? 0 : REXEC_COPY_STR))
+ s == m, cx->sb_targ, NULL,
+ ((cx->sb_rflags & REXEC_COPY_STR)
+ ? 0 : REXEC_COPY_STR)))
{
SV *targ = cx->sb_targ;
sv_catpvn(dstr, s, cx->sb_strend - s);
register char *s;
char *strend;
I32 global;
- I32 safebase;
+ I32 r_flags;
char *truebase;
register REGEXP *rx = pm->op_pmregexp;
bool rxtainted;
I32 minmatch = 0;
I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
- SV *screamer;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
}
if (rx->minlen > len) goto failure;
- screamer = ( (SvSCREAM(TARG) && rx->check_substr
- && SvTYPE(rx->check_substr) == SVt_PVBM
- && SvVALID(rx->check_substr))
- ? TARG : Nullsv);
truebase = t = s;
if (global = pm->op_pmflags & PMf_GLOBAL) {
rx->startp[0] = 0;
}
}
}
- safebase = ((gimme != G_ARRAY && !global && rx->nparens)
+ r_flags = ((gimme != G_ARRAY && !global && rx->nparens)
|| SvTEMP(TARG) || PL_sawampersand)
? REXEC_COPY_STR : 0;
+ if (SvSCREAM(TARG) && rx->check_substr
+ && SvTYPE(rx->check_substr) == SVt_PVBM
+ && SvVALID(rx->check_substr))
+ r_flags |= REXEC_SCREAM;
+
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
}
if (rx->check_substr) {
if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
- if ( screamer ) {
+ if (r_flags & REXEC_SCREAM) {
I32 p = -1;
char *b;
rx->float_substr = Nullsv;
}
}
- if (CALLREGEXEC(rx, s, strend, truebase, minmatch,
- screamer, NULL, safebase))
+ if (CALLREGEXEC(rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
{
PL_curpm = pm;
if (pm->op_pmflags & PMf_ONCE)
bool once;
bool rxtainted;
char *orig;
- I32 safebase;
+ I32 r_flags;
register REGEXP *rx = pm->op_pmregexp;
STRLEN len;
int force_on_match = 0;
I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
- SV *screamer;
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
pm = PL_curpm;
rx = pm->op_pmregexp;
}
- screamer = ( (SvSCREAM(TARG) && rx->check_substr
- && SvTYPE(rx->check_substr) == SVt_PVBM
- && SvVALID(rx->check_substr))
- ? TARG : Nullsv);
- safebase = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
+ r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
? REXEC_COPY_STR : 0;
+ if (SvSCREAM(TARG) && rx->check_substr
+ && SvTYPE(rx->check_substr) == SVt_PVBM
+ && SvVALID(rx->check_substr))
+ r_flags |= REXEC_SCREAM;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(PL_multiline);
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
orig = m = s;
if (rx->check_substr) {
if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */
- if (screamer) {
+ if (r_flags & REXEC_SCREAM) {
I32 p = -1;
char *b;
c = dstr ? SvPV(dstr, clen) : Nullch;
/* can do inplace substitution? */
- if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR))
+ if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
- if (!CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+ if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
SPAGAIN;
PUSHs(&PL_sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
}
- if (CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+ if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
sv_catpvn(dstr, c, clen);
if (once)
break;
- } while (CALLREGEXEC(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
+ } while (CALLREGEXEC(rx, s, strend, orig, s == m, Nullsv, NULL, r_flags));
sv_catpvn(dstr, s, strend - s);
(void)SvOOK_off(TARG);
char * regcppop _((void));
char * regcp_set_to _((I32 ss));
void cache_re _((regexp *prog));
+void restore_pos _((void *arg));
U8 * reghop _((U8 *pos, I32 off));
U8 * reghopmaybe _((U8 *pos, I32 off));
void dump _((char *pat,...));
VIRTUAL void do_pmop_dump _((I32 level, PerlIO *file, PMOP *pm));
VIRTUAL void do_sv_dump _((I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim));
VIRTUAL void magic_dump _((MAGIC *mg));
+VIRTUAL void reginitcolors _((void));
# define Perl_pregfree my_regfree
# define Perl_regnext my_regnext
# define Perl_save_re_context my_save_re_context
+# define Perl_reginitcolors my_reginitcolors
#endif
/*SUPPRESS 112*/
return PL_regcomp_rx->data->count - n;
}
+void
+reginitcolors(void)
+{
+ dTHR;
+ int i = 0;
+ char *s = PerlEnv_getenv("PERL_RE_COLORS");
+
+ if (s) {
+ PL_colors[0] = s = savepv(s);
+ while (++i < 6) {
+ s = strchr(s, '\t');
+ if (s) {
+ *s = '\0';
+ PL_colors[i] = ++s;
+ }
+ else
+ PL_colors[i] = "";
+ }
+ } else {
+ while (i < 6)
+ PL_colors[i++] = "";
+ }
+ PL_colorset = 1;
+}
+
/*
- pregcomp - compile a regular expression into internal code
*
PL_regprecomp = savepvn(exp, xend - exp);
DEBUG_r(
- if (!PL_colorset) {
- int i = 0;
- char *s = PerlEnv_getenv("PERL_RE_COLORS");
-
- if (s) {
- PL_colors[0] = s = savepv(s);
- while (++i < 6) {
- s = strchr(s, '\t');
- if (s) {
- *s = '\0';
- PL_colors[i] = ++s;
- }
- else
- PL_colors[i] = "";
- }
- } else {
- while (i < 6)
- PL_colors[i++] = "";
- }
- PL_colorset = 1;
- }
- );
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling%s RE `%s%*s%s'\n",
- PL_colors[4],PL_colors[5],PL_colors[0],
- xend - exp, PL_regprecomp, PL_colors[1]));
+ if (!PL_colorset)
+ reginitcolors();
+ PerlIO_printf(Perl_debug_log, "%sCompiling%s RE `%s%*s%s'\n",
+ PL_colors[4],PL_colors[5],PL_colors[0],
+ xend - exp, PL_regprecomp, PL_colors[1]));
PL_regflags = pm->op_pmflags;
PL_regsawback = 0;
# define Perl_regprop my_regprop
/* *These* symbols are masked to allow static link. */
# define Perl_pregexec my_pregexec
+# define Perl_reginitcolors my_reginitcolors
#endif
/*SUPPRESS 112*/
static char * regcppop _((void));
static char * regcp_set_to _((I32 ss));
static void cache_re _((regexp *prog));
+static void restore_pos _((void *arg));
#endif
#define REGINCLASS(p,c) (*(p) ? reginclass(p,c) : ANYOF_TEST(p,c))
PL_regdata = prog->data;
PL_reg_re = prog;
}
-
+
+STATIC void
+restore_pos(void *arg)
+{
+ if (PL_reg_eval_set) {
+ PL_reg_magic->mg_len = PL_reg_oldpos;
+ PL_reg_eval_set = 0;
+ PL_curpm = PL_reg_oldcurpm;
+ }
+}
+
+
/*
- regexec_flags - match a regexp against a string
*/
I32
regexec_flags(register regexp *prog, char *stringarg, register char *strend,
- char *strbeg, I32 minend, SV *screamer, void *data, U32 flags)
+ char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
/* strend: pointer to null at end of string */
/* strbeg: real beginning of string */
/* minend: end of match must be >=minend after stringarg. */
/* Mark beginning of line for ^ and lookbehind. */
PL_regbol = startpos;
PL_bostr = strbeg;
+ PL_reg_sv = sv;
/* Mark end of line for $ (and such) */
PL_regeol = strend;
start_shift = prog->check_offset_min; /* okay to underestimate on CC */
/* Should be nonnegative! */
end_shift = minlen - start_shift - CHR_SVLEN(prog->check_substr);
- if (screamer) {
+ if (flags & REXEC_SCREAM) {
if (PL_screamfirst[BmRARE(prog->check_substr)] >= 0)
- s = screaminstr(screamer, prog->check_substr,
+ s = screaminstr(sv, prog->check_substr,
start_shift + (stringarg - strbeg),
end_shift, &scream_pos, 0);
else
}
DEBUG_r(
+ if (!PL_colorset)
+ reginitcolors();
PerlIO_printf(Perl_debug_log,
"%sMatching%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
PL_colors[4],PL_colors[5],PL_colors[0],
(strend - startpos > 60 ? "..." : ""))
);
+ if (prog->reganch & ROPT_GPOS_SEEN) {
+ MAGIC *mg;
+ int pos = 0;
+
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)
+ && (mg = mg_find(sv, 'g')) && mg->mg_len >= 0)
+ pos = mg->mg_len;
+ PL_reg_ganch = startpos + pos;
+ }
+
/* Simplest case: anchored match need be tried only once. */
/* [unless only anchor is BOL and multiline is set] */
- if (prog->reganch & ROPT_ANCH) {
+ if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
if (regtry(prog, startpos))
goto got_it;
- else if (!(prog->reganch & ROPT_ANCH_GPOS) &&
- (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
- || (prog->reganch & ROPT_ANCH_MBOL)))
+ else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
+ || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
{
if (minlen)
dontbother = minlen - 1;
}
}
goto phooey;
+ } else if (prog->reganch & ROPT_ANCH_GPOS) {
+ if (regtry(prog, PL_reg_ganch))
+ goto got_it;
+ goto phooey;
}
/* Messy cases: unanchored match. */
dontbother = end_shift;
strend = HOPc(strend, -dontbother);
while ( (s <= last) &&
- (screamer
- ? (s = screaminstr(screamer, must, HOPc(s, back_min) - strbeg,
+ ((flags & REXEC_SCREAM)
+ ? (s = screaminstr(sv, must, HOPc(s, back_min) - strbeg,
end_shift, &scream_pos, 0))
: (s = fbm_instr((unsigned char*)HOP(s, back_min),
(unsigned char*)strend, must, 0))) ) {
char *last;
I32 oldpos = scream_pos;
- if (screamer) {
- last = screaminstr(screamer, prog->float_substr, s - strbeg,
+ if (flags & REXEC_SCREAM) {
+ last = screaminstr(sv, prog->float_substr, s - strbeg,
end_shift, &scream_pos, 1); /* last one */
if (!last) {
last = scream_olds; /* Only one occurence. */
}
}
}
- /* Preserve the current value of $^R */
- if (oreplsv != GvSV(PL_replgv)) {
- sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
- restored, the value remains
- the same. */
+ if (PL_reg_eval_set) {
+ /* Preserve the current value of $^R */
+ if (oreplsv != GvSV(PL_replgv))
+ sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
+ restored, the value remains
+ the same. */
+ restore_pos(0);
}
+
return 1;
phooey:
+ if (PL_reg_eval_set)
+ restore_pos(0);
return 0;
}
CHECKPOINT lastcp;
if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
+ MAGIC *mg;
+
PL_reg_eval_set = RS_init;
DEBUG_r(DEBUG_s(
PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %i\n",
/* Apparently this is not needed, judging by wantarray. */
/* SAVEINT(cxstack[cxstack_ix].blk_gimme);
cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
+
+ if (PL_reg_sv) {
+ /* Make $_ available to executed code. */
+ if (PL_reg_sv != GvSV(PL_defgv)) {
+ SAVESPTR(GvSV(PL_defgv));
+ GvSV(PL_defgv) = PL_reg_sv;
+ }
+
+ if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
+ && (mg = mg_find(PL_reg_sv, 'g')))) {
+ /* prepare for quick setting of pos */
+ sv_magic(PL_reg_sv, (SV*)0, 'g', Nullch, 0);
+ mg = mg_find(PL_reg_sv, 'g');
+ mg->mg_len = -1;
+ }
+ PL_reg_magic = mg;
+ PL_reg_oldpos = mg->mg_len;
+ SAVEDESTRUCTOR(restore_pos, 0);
+ }
+ if (!PL_reg_curpm)
+ New(22,PL_reg_curpm, 1, PMOP);
+ PL_reg_curpm->op_pmregexp = prog;
+ PL_reg_oldcurpm = PL_curpm;
+ PL_curpm = PL_reg_curpm;
+ prog->subbeg = PL_bostr;
+ prog->subend = PL_regeol; /* strend may have been modified */
}
+ prog->startp[0] = startpos;
PL_reginput = startpos;
PL_regstartp = prog->startp;
PL_regendp = prog->endp;
PL_reglastparen = &prog->lastparen;
prog->lastparen = 0;
PL_regsize = 0;
+ DEBUG_r(PL_reg_starttry = startpos);
if (PL_reg_start_tmpl <= prog->nparens) {
PL_reg_start_tmpl = prog->nparens*3/2 + 3;
if(PL_reg_start_tmp)
New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
}
+ /* XXXX What this code is doing here?!!! There should be no need
+ to do this again and again, PL_reglastparen should take care of
+ this! */
sp = prog->startp;
ep = prog->endp;
if (prog->nparens) {
- for (i = prog->nparens; i >= 0; i--) {
- *sp++ = NULL;
- *ep++ = NULL;
+ for (i = prog->nparens; i >= 1; i--) {
+ *++sp = NULL;
+ *++ep = NULL;
}
}
REGCP_SET;
if (regmatch(prog->program + 1)) {
- prog->startp[0] = startpos;
prog->endp[0] = PL_reginput;
return 1;
}
int l = (PL_regeol - locinput > taill ? taill : PL_regeol - locinput);
int pref_len = (locinput - PL_bostr > (5 + taill) - l
? (5 + taill) - l : locinput - PL_bostr);
- int pref0_len = pref_len - (locinput - PL_reginput);
+ int pref0_len = pref_len - (locinput - PL_reg_starttry);
if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
l = ( PL_regeol - locinput > (5 + taill) - pref_len
break;
sayNO;
case GPOS:
- if (locinput == PL_regbol)
+ if (locinput == PL_reg_ganch)
break;
sayNO;
case EOL:
PL_op = (OP_4tree*)PL_regdata->data[n];
DEBUG_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%x\n", PL_op) );
PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 1]);
+ PL_reg_magic->mg_len = locinput - PL_bostr;
+ PL_regendp[0] = locinput;
CALLRUNOPS(); /* Scalar context. */
SPAGAIN;
#define ROPT_LOOKBEHIND_SEEN 0x00100
#define ROPT_EVAL_SEEN 0x00200
#define ROPT_TAINTED_SEEN 0x00400
+#define ROPT_ANCH_SBOL 0x00800
/* 0xf800 of reganch is used by PMf_COMPILETIME */
#define REXEC_COPY_STR 1 /* Need to copy the string. */
#define REXEC_CHECKED 2 /* check_substr already checked. */
+#define REXEC_SCREAM 4 /* use scream table. */
#define ReREFCNT_inc(re) ((re && re->refcnt++), re)
#define ReREFCNT_dec(re) pregfree(re)
--- /dev/null
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+use IO::Handle;
+
+print "1..6\n";
+my $i = 1;
+foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) {
+ my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0;
+ my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef;
+ my $v2 = IO::Handle::constant($_);
+ my $d2 = defined($v2);
+
+ print "not "
+ if($d1 != $d2 || ($d1 && ($v1 != $v2)));
+ print "ok ",$i++,"\n";
+}
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+ require Config; import Config;
+ if ($] < 5.00326 || not $Config{'d_readdir'}) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+use IO::Dir qw(DIR_UNLINK);
+
+print "1..10\n";
+
+$dot = new IO::Dir ".";
+print defined($dot) ? "ok" : "not ok", " 1\n";
+
+@a = sort <*>;
+do { $first = $dot->read } while defined($first) && $first =~ /^\./;
+print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
+
+@b = sort($first, (grep {/^[^.]/} $dot->read));
+print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n";
+
+$dot->rewind;
+@c = sort grep {/^[^.]/} $dot->read;
+print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n";
+
+$dot->close;
+$dot->rewind;
+print defined($dot->read) ? "not ok" : "ok", " 5\n";
+
+open(FH,'>X') || die "Can't create x";
+print FH "X";
+close(FH);
+
+tie %dir, IO::Dir, ".";
+my @files = keys %dir;
+
+# I hope we do not have an empty dir :-)
+print @files ? "ok" : "not ok", " 6\n";
+
+my $stat = $dir{'X'};
+print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1
+ ? "ok" : "not ok", " 7\n";
+
+delete $dir{'X'};
+
+print -f 'X' ? "ok" : "not ok", " 8\n";
+
+tie %dirx, IO::Dir, ".", DIR_UNLINK;
+
+my $statx = $dirx{'X'};
+print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1
+ ? "ok" : "not ok", " 9\n";
+
+delete $dirx{'X'};
+
+print -f 'X' ? "not ok" : "ok", " 10\n";
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+$| = 1;
+
+print "1..8\n";
+
+
+package Multi;
+require IO::Socket::INET;
+@ISA=qw(IO::Socket::INET);
+
+use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in);
+
+sub _get_addr
+{
+ my($sock,$addr_str, $multi) = @_;
+ #print "_get_addr($sock, $addr_str, $multi)\n";
+
+ print "not " unless $multi;
+ print "ok 2\n";
+
+ (
+ # private IP-addresses which I hope does not work anywhere :-)
+ inet_aton("10.250.230.10"),
+ inet_aton("10.250.230.12"),
+ inet_aton("127.0.0.1") # loopback
+ )
+}
+
+sub connect
+{
+ my $self = shift;
+ if (@_ == 1) {
+ my($port, $addr) = unpack_sockaddr_in($_[0]);
+ $addr = inet_ntoa($addr);
+ #print "connect($self, $port, $addr)\n";
+ print "ok 3\n" if $addr eq "10.250.230.10";
+ print "ok 4\n" if $addr eq "10.250.230.12";
+ }
+ $self->SUPER::connect(@_);
+}
+
+
+
+package main;
+
+use IO::Socket;
+
+$listen = IO::Socket::INET->new(Listen => 2,
+ Proto => 'tcp',
+ Timeout => 5,
+ ) or die "$!";
+
+print "ok 1\n";
+
+$port = $listen->sockport;
+
+if($pid = fork()) {
+
+ $sock = $listen->accept() or die "$!";
+ print "ok 5\n";
+
+ print $sock->getline();
+ print $sock "ok 7\n";
+
+ waitpid($pid,0);
+
+ $sock->close;
+
+ print "ok 8\n";
+
+} elsif(defined $pid) {
+
+ $sock = Multi->new(PeerPort => $port,
+ Proto => 'tcp',
+ PeerAddr => 'localhost',
+ MultiHomed => 1,
+ Timeout => 1,
+ ) or die "$!";
+
+ print $sock "ok 6\n";
+ sleep(1); # race condition
+ print $sock->getline();
+
+ $sock->close;
+
+ exit;
+} else {
+ die;
+}
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print "1..8\n";
+
+use IO::Handle;
+use IO::Poll qw(/POLL/);
+
+my $poll = new IO::Poll;
+
+my $stdout = \*STDOUT;
+my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w");
+
+$poll->mask($stdout => POLLOUT);
+
+print "not "
+ unless $poll->mask($stdout) == POLLOUT;
+print "ok 1\n";
+
+$poll->mask($dupout => POLLPRI);
+
+print "not "
+ unless $poll->mask($dupout) == POLLPRI;
+print "ok 2\n";
+
+$poll->poll(0.1);
+
+print "not "
+ unless $poll->events($stdout) == POLLOUT;
+print "ok 3\n";
+
+print "not "
+ if $poll->events($dupout);
+print "ok 4\n";
+
+my @h = $poll->handles;
+print "not "
+ unless @h == 2;
+print "ok 5\n";
+
+$poll->remove($stdout);
+
+@h = $poll->handles;
+
+print "not "
+ unless @h == 1;
+print "ok 6\n";
+
+print "not "
+ if $poll->mask($stdout);
+print "ok 7\n";
+
+$poll->poll(0.1);
+
+print "not "
+ if $poll->events($stdout);
+print "ok 8\n";
}
$| = 1;
-print "1..5\n";
+print "1..14\n";
use IO::Socket;
$listen = IO::Socket::INET->new(Listen => 2,
Proto => 'tcp',
+ Timeout => 2,
) or die "$!";
print "ok 1\n";
Proto => 'tcp',
PeerAddr => 'localhost'
)
- or die "$! (maybe your system does not have the 'localhost' address defined)";
+ or die "$! (maybe your system does not have the 'localhost' address defined)";
$sock->autoflush(1);
die;
}
+# Test various other ways to create INET sockets that should
+# also work.
+$listen = IO::Socket::INET->new(Listen => '', Timeout => 2) or die "$!";
+$port = $listen->sockport;
+if($pid = fork()) {
+ SERVER_LOOP:
+ while (1) {
+ last SERVER_LOOP unless $sock = $listen->accept;
+ while (<$sock>) {
+ last SERVER_LOOP if /^quit/;
+ last if /^done/;
+ print;
+ }
+ $sock = undef;
+ }
+ $listen->close;
+} elsif (defined $pid) {
+ # child, try various ways to connect
+ $sock = IO::Socket::INET->new("localhost:$port");
+ if ($sock) {
+ print "not " unless $sock->connected;
+ print "ok 6\n";
+ $sock->print("ok 7\n");
+ sleep(1);
+ print "ok 8\n";
+ $sock->print("ok 9\n");
+ $sock->print("done\n");
+ $sock->close;
+ }
+ else {
+ print "# $@\n";
+ print "not ok 6\n";
+ print "not ok 7\n";
+ print "not ok 8\n";
+ print "not ok 9\n";
+ }
+
+ # some machines seem to suffer from a race condition here
+# sleep(1);
+
+ $sock = IO::Socket::INET->new("127.0.0.1:$port");
+ if ($sock) {
+ $sock->print("ok 10\n");
+ $sock->print("done\n");
+ $sock->close;
+ }
+ else {
+ print "# $@\n";
+ print "not ok 10\n";
+ }
+ # some machines seem to suffer from a race condition here
+# sleep(1);
+ $sock = IO::Socket->new(Domain => AF_INET,
+ PeerAddr => "localhost:$port");
+ if ($sock) {
+ $sock->print("ok 11\n");
+ $sock->print("quit\n");
+ }
+ $sock = undef;
+ sleep(1);
+ exit;
+} else {
+ die;
+}
+
+# Then test UDP sockets
+$server = IO::Socket->new(Domain => AF_INET,
+ Proto => 'udp',
+ LocalAddr => 'localhost');
+$port = $server->sockport;
+
+if ($pid = fork()) {
+ my $buf;
+ $server->recv($buf, 100);
+ print $buf;
+} elsif (defined($pid)) {
+ #child
+ $sock = IO::Socket::INET->new(Proto => 'udp',
+ PeerAddr => "localhost:$port");
+ $sock->send("ok 12\n");
+ sleep(1);
+ $sock->send("ok 12\n"); # send another one to be sure
+ exit;
+} else {
+ die;
+}
+print "not " unless $server->blocking;
+print "ok 13\n";
+$server->blocking(0);
+print "not " if $server->blocking;
+print "ok 14\n";
}
}
+sub compare_addr {
+ my $a = shift;
+ my $b = shift;
+ my @a = unpack_sockaddr_in($a);
+ my @b = unpack_sockaddr_in($b);
+ "$a[0]$a[1]" eq "$b[0]$b[1]";
+}
+
$| = 1;
-print "1..3\n";
+print "1..7\n";
use Socket;
use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
or die "$! (maybe your system does not have the 'localhost' address defined)";
+
+print "ok 1\n";
+
$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
or die "$! (maybe your system does not have the 'localhost' address defined)";
-print "ok 1\n";
+print "ok 2\n";
+
+$udpa->send("ok 4\n",0,$udpb->sockname);
-$udpa->send("ok 2\n",0,$udpb->sockname);
-$udpb->recv($buf="",5);
+print "not " unless compare_addr($udpa->peername,$udpb->sockname);
+print "ok 3\n";
+
+my $where = $udpb->recv($buf="",5);
print $buf;
-$udpb->send("ok 3\n");
+
+my @xtra = ();
+
+unless(compare_addr($where,$udpa->sockname)) {
+ print "not ";
+ @xtra = (0,$udpa->sockname);
+}
+print "ok 5\n";
+
+$udpb->send("ok 6\n",@xtra);
$udpa->recv($buf="",5);
print $buf;
+
+print "not " if $udpa->connected;
+print "ok 7\n";
--- /dev/null
+
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+$PATH = "/tmp/sock-$$";
+
+# Test if we can create the file within the tmp directory
+if (-e $PATH or not open(TEST, ">$PATH")) {
+ print "1..0\n";
+ exit 0;
+}
+close(TEST);
+unlink($PATH) or die "Can't unlink $PATH: $!";
+
+# Start testing
+$| = 1;
+print "1..5\n";
+
+use IO::Socket;
+
+$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!";
+print "ok 1\n";
+
+if($pid = fork()) {
+
+ $sock = $listen->accept();
+ print "ok 2\n";
+
+ print $sock->getline();
+
+ print $sock "ok 4\n";
+
+ $sock->close;
+
+ waitpid($pid,0);
+ unlink($PATH) || warn "Can't unlink $PATH: $!";
+
+ print "ok 5\n";
+
+} elsif(defined $pid) {
+
+ $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!";
+
+ print $sock "ok 3\n";
+
+ print $sock->getline();
+
+ $sock->close;
+
+ exit;
+} else {
+ die;
+}
%h = (1..6);
$aref = \@a;
$href = \%h;
-open OP, qq{$^X -le 'print "aaa Ok ok" while \$i++ < 100'|};
+open OP, qq{$^X -le "print 'aaa Ok ok' for 1..100"|};
$chopit = 'aaaaaa';
@chopar = (113 .. 119);
$posstr = '123456';
# the format supported by op/regexp.t. If you want to add a test
# that does fit that format, add it to op/re_tests, not here.
-print "1..162\n";
+print "1..177\n";
BEGIN {
chdir 't' if -d 't';
print "ok $test\n";
$test++;
+/.(a)(ba*)?/;
+print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1;
+print "ok $test\n";
+$test++;
+
+$str = 'abcde';
+pos $str = 2;
+
+print "not " if $str =~ /^\G/;
+print "ok $test\n";
+$test++;
+
+print "not " if $str =~ /^.\G/;
+print "ok $test\n";
+$test++;
+
+print "not " unless $str =~ /^..\G/;
+print "ok $test\n";
+$test++;
+
+print "not " if $str =~ /^...\G/;
+print "ok $test\n";
+$test++;
+
+print "not " unless $str =~ /.\G./ and $& eq 'bc';
+print "ok $test\n";
+$test++;
+
+print "not " unless $str =~ /\G../ and $& eq 'cd';
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+print "#'$str','$foo','$bar'\nnot "
+ unless $str =~ /b(?{$foo = $_; $bar = pos})c/
+ and $foo eq 'abcde' and $bar eq 2;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+pos $str = undef;
+print "#'$str','$foo','$bar'\nnot "
+ unless $str =~ /b(?{$foo = $_; $bar = pos})c/g
+ and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3;
+print "ok $test\n";
+$test++;
+
+$_ = $str;
+
+undef $foo; undef $bar;
+print "#'$str','$foo','$bar'\nnot "
+ unless /b(?{$foo = $_; $bar = pos})c/
+ and $foo eq 'abcde' and $bar eq 2;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+print "#'$str','$foo','$bar'\nnot "
+ unless /b(?{$foo = $_; $bar = pos})c/g
+ and $foo eq 'abcde' and $bar eq 2 and pos eq 3;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+pos = undef;
+1 while /b(?{$foo = $_; $bar = pos})c/g;
+print "#'$str','$foo','$bar'\nnot "
+ unless $foo eq 'abcde' and $bar eq 2 and not defined pos;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+$_ = 'abcde|abcde';
+print "#'$str','$foo','$bar','$_'\nnot "
+ unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde'
+ and $bar eq 8 and $_ eq 'axde|axde';
+print "ok $test\n";
+$test++;
+
+@res = ();
+# List context:
+$_ = 'abcde|abcde';
+@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
+@res = map {defined $_ ? "'$_'" : 'undef'} @res;
+$res = "@res";
+print "#'@res' '$_'\nnot "
+ unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'";
+print "ok $test\n";
+$test++;
+
+@res = ();
+@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
+@res = map {defined $_ ? "'$_'" : 'undef'} @res;
+$res = "@res";
+print "#'@res' '$_'\nnot "
+ unless "@res" eq
+ "'' 'ab' 'cde|abcde' " .
+ "'' 'abc' 'de|abcde' " .
+ "'abcd' 'e|' 'abcde' " .
+ "'abcde|' 'ab' 'cde' " .
+ "'abcde|' 'abc' 'de'" ;
+print "ok $test\n";
+$test++;
+
# see if matching against temporaries (created via pp_helem()) is safe
{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g;
print "$1\n";
use warning 'void' ;
use Config ;
BEGIN {
- if ( ! $Config{d_getprior}) {
+ if ( ! $Config{d_getprior} or $^O eq 'os2') { # Locks before fixpak22
print <<EOM ;
SKIPPED
# getpriority not present
PERLVAR(Tregcc, CURCUR *) /* from regexec.c */
PERLVAR(Treg_call_cc, struct re_cc_state *) /* from regexec.c */
PERLVAR(Treg_re, regexp *) /* from regexec.c */
+PERLVAR(Treg_ganch, char *) /* position of \G */
+PERLVAR(Treg_sv, SV *) /* what we match against */
+PERLVAR(Treg_magic, MAGIC *) /* pos-magic of what we match */
+PERLVAR(Treg_oldpos, I32) /* old pos of what we match */
+PERLVARI(Treg_oldcurpm, PMOP*, NULL) /* curpm before match */
+PERLVARI(Treg_curpm, PMOP*, NULL) /* curpm during match */
PERLVARI(Tregcompp, regcomp_t, FUNC_NAME_TO_PTR(pregcomp))
/* Pointer to RE compiler */
/* Pointer to RE executer */
PERLVARI(Treginterp_cnt,int, 0) /* Whether `re'
was interpolated. */
+PERLVARI(Treg_starttry, char *, 0) /* -Dr: where regtry was called. */
#ifdef DEBUGGING
PERLVARI(Twatchaddr, char **, 0)
PERLVAR(Twatchok, char *)
#else
for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
#endif
- if (*t == '\n')
+ if (*t == '\n' || t == PL_bufend)
break;
}
if (PL_in_eval && !PL_rsfp) {
pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod
pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod
-pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlrun.pod
-pod6 = [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod
+pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlreftut.pod
+pod6 = [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod
pod7 = [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltoot.pod
pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod
perlform.pod \
perllocale.pod \
perlref.pod \
+ perlreftut.pod \
perldsc.pod \
perllol.pod \
perltoot.pod \
https://perl5.git.perl.org / perl5.git / commitdiff