This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate from mainperl.
authorJarkko Hietaniemi <jhi@iki.fi>
Sun, 29 Nov 1998 10:08:15 +0000 (10:08 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sun, 29 Nov 1998 10:08:15 +0000 (10:08 +0000)
p4raw-id: //depot/cfgperl@2381

71 files changed:
MANIFEST
cop.h
embed.h
embed.pl
embedvar.h
ext/B/B/C.pm
ext/IO/ChangeLog [new file with mode: 0644]
ext/IO/IO.pm
ext/IO/IO.xs
ext/IO/Makefile.PL
ext/IO/README
ext/IO/lib/IO/Dir.pm [new file with mode: 0644]
ext/IO/lib/IO/File.pm
ext/IO/lib/IO/Handle.pm
ext/IO/lib/IO/Pipe.pm
ext/IO/lib/IO/Poll.pm [new file with mode: 0644]
ext/IO/lib/IO/Seekable.pm
ext/IO/lib/IO/Select.pm
ext/IO/lib/IO/Socket.pm
ext/IO/lib/IO/Socket/INET.pm [new file with mode: 0644]
ext/IO/lib/IO/Socket/UNIX.pm [new file with mode: 0644]
ext/IO/poll.c [new file with mode: 0644]
ext/IO/poll.h [new file with mode: 0644]
global.sym
gv.c
lib/English.pm
lib/ExtUtils/Liblist.pm
lib/Term/Complete.pm
lib/Test.pm
lib/Tie/Handle.pm
mg.c
myconfig
objXSUB.h
os2/Changes
os2/Makefile.SHs
os2/os2.c
perl.c
pod/Makefile
pod/buildtoc
pod/perl.pod
pod/perldata.pod
pod/perlfunc.pod
pod/perlop.pod
pod/perlpod.pod
pod/perlref.pod
pod/perlreftut.pod [new file with mode: 0644]
pod/perlvar.pod
pod/roffitall
pp.c
pp_ctl.c
pp_hot.c
proto.h
regcomp.c
regexec.c
regexp.h
scope.c
t/lib/io_const.t [new file with mode: 0755]
t/lib/io_dir.t [new file with mode: 0755]
t/lib/io_multihomed.t [new file with mode: 0644]
t/lib/io_poll.t [new file with mode: 0755]
t/lib/io_sock.t
t/lib/io_udp.t
t/lib/io_unix.t [new file with mode: 0644]
t/op/lex_assign.t
t/op/pat.t
t/pragma/warn/op
thrdvar.h
toke.c
vms/descrip_mms.template
win32/makefile.mk
win32/pod.mak

index e6ab011..6ac2168 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -224,16 +224,21 @@ ext/GDBM_File/GDBM_File.pm        GDBM extension Perl module
 ext/GDBM_File/GDBM_File.xs     GDBM extension external subroutines
 ext/GDBM_File/Makefile.PL      GDBM extension makefile writer
 ext/GDBM_File/typemap          GDBM extension interface types
+ext/IO/ChangeLog               IO perl module change log
 ext/IO/IO.pm                   Top-level interface to IO::* classes
 ext/IO/IO.xs                   IO extension external subroutines
 ext/IO/Makefile.PL             IO extension makefile writer
 ext/IO/README                  IO extension maintenance notice
-ext/IO/lib/IO/File.pm          IO::File extension Perl module
-ext/IO/lib/IO/Handle.pm                IO::Handle extension Perl module
-ext/IO/lib/IO/Pipe.pm          IO::Pipe extension Perl module
-ext/IO/lib/IO/Seekable.pm      IO::Seekable extension Perl module
-ext/IO/lib/IO/Select.pm                IO::Select extension Perl module
-ext/IO/lib/IO/Socket.pm                IO::Socket extension Perl module
+ext/IO/lib/IO/Dir.pm           IO directory reading package
+ext/IO/lib/IO/File.pm          IO file handle package
+ext/IO/lib/IO/Handle.pm                IO base handle package
+ext/IO/lib/IO/Pipe.pm          IO pipe package
+ext/IO/lib/IO/Poll.pm          IO system poll() interface
+ext/IO/lib/IO/Seekable.pm      IO methods for seekable handles
+ext/IO/lib/IO/Select.pm                IO system select() interface
+ext/IO/lib/IO/Socket.pm                IO socket handle package
+ext/IO/lib/IO/Socket/INET.pm   IO INET specific socket methods
+ext/IO/lib/IO/Socket/UNIX.pm   IO UNIX specific socket methods
 ext/IPC/SysV/ChangeLog         IPC::SysV extension Perl module
 ext/IPC/SysV/hints/next_3.pl   Hint for IPC::SysV for named architecture
 ext/IPC/SysV/MANIFEST          IPC::SysV extension Perl module
@@ -904,6 +909,7 @@ pod/perlpod.pod             Pod info
 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
@@ -1020,13 +1026,18 @@ t/lib/h2ph.h            Test header file for h2ph
 t/lib/h2ph.pht         Generated output from h2ph.h by h2ph, for comparison
 t/lib/h2ph.t           See if h2ph works like it should
 t/lib/hostname.t       See if Sys::Hostname works
+t/lib/io_const.t       See if constants from IO work
+t/lib/io_dir.t         See if directory-related methods from IO work
 t/lib/io_dup.t         See if dup()-related methods from IO work
+t/lib/io_multihomed.t  See if INET sockets work with multi-homed hosts
 t/lib/io_pipe.t                See if pipe()-related methods from IO work
+t/lib/io_poll.t                See if poll()-related methods from IO work
 t/lib/io_sel.t         See if select()-related methods from IO work
 t/lib/io_sock.t                See if INET socket-related methods from IO work
 t/lib/io_taint.t       See if the untaint method from IO works
 t/lib/io_tell.t                See if seek()/tell()-related methods from IO work
 t/lib/io_udp.t         See if UDP socket-related methods from IO work
+t/lib/io_unix.t                See if UNIX socket-related methods from IO work
 t/lib/io_xs.t          See if XSUB methods from IO work
 t/lib/ipc_sysv.t       See if IPC::SysV works
 t/lib/ndbm.t           See if NDBM_File works
diff --git a/cop.h b/cop.h
index 043ea8d..6bdb594 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -213,7 +213,7 @@ struct block {
 struct subst {
     I32                sbu_iters;
     I32                sbu_maxiters;
-    I32                sbu_safebase;
+    I32                sbu_rflags;
     I32                sbu_oldsave;
     bool       sbu_once;
     bool       sbu_rxtainted;
@@ -228,7 +228,7 @@ struct subst {
 };
 #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
@@ -244,7 +244,7 @@ struct subst {
 #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,                            \
diff --git a/embed.h b/embed.h
index d6aca6d..95d8889 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
index f309c3b..4017a05 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -360,6 +360,7 @@ my @staticfuncs = qw(
     regcppop
     regcp_set_to
     cache_re
+    restore_pos
     reghop
     reghopmaybe
     dump
index 7225618..4d28711 100644 (file)
 #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)
index da9f7dd..e695cc2 100644 (file)
@@ -1052,17 +1052,22 @@ sub save_object {
     foreach $sv (@_) {
        svref_2object($sv)->save;
     }
-}                    
+}       
+
+sub Dummy_BootStrap { }            
 
 sub B::GV::savecv {
     my $gv = shift;
     my $cv = $gv->CV;
     my $name = $gv->NAME;
-    if ($$cv && !objsym($cv)) {
+    if ($$cv) {
        if ($name eq "bootstrap" && $cv->XSUB) {
            my $file = $cv->FILEGV->SV->PV;
            $bootstrap->add($file);
-           return;
+           my $name = $gv->STASH->NAME.'::'.$name;
+           no strict 'refs';
+            *{$name} = \&Dummy_BootStrap;   
+           $cv = $gv->CV;
        }
        if ($debug_cv) {
            warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
@@ -1085,6 +1090,8 @@ sub B::GV::savecv {
 
 }
 
+
+
 sub save_unused_subs {
     my %search_pack;
     map { $search_pack{$_} = 1 } @_;
@@ -1132,9 +1139,12 @@ sub save_unused_subs {
 }
 
 sub save_main {
+    warn "Walking tree\n";
     my $curpad_nam = (comppadlist->ARRAY)[0]->save;
     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
     my $init_av    = init_av->save;
+    my $inc_hv     = svref_2object(\%INC)->save;
+    my $inc_av     = svref_2object(\@INC)->save;
     walkoptree(main_root, "save");
     warn "done main optree, walking symtable for extras\n" if $debug_cv;
     save_unused_subs(@unused_sub_packages);
@@ -1143,6 +1153,8 @@ sub save_main {
               sprintf("PL_main_start = s\\_%x;", ${main_start()}),
               "PL_curpad = AvARRAY($curpad_sym);",
               "PL_initav = $init_av;",
+              "GvHV(PL_incgv) = $inc_hv;",
+              "GvAV(PL_incgv) = $inc_av;",
                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
     warn "Writing output\n";
diff --git a/ext/IO/ChangeLog b/ext/IO/ChangeLog
new file mode 100644 (file)
index 0000000..28bc431
--- /dev/null
@@ -0,0 +1,316 @@
+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.
index 4d4c81c..b6ce216 100644 (file)
@@ -2,6 +2,28 @@
 
 package IO;
 
+require DynaLoader;
+require Exporter;
+use Carp;
+
+use vars qw(@ISA $VERSION @EXPORT);
+
+@ISA = qw(DynaLoader);
+$VERSION = "1.20";
+bootstrap IO $VERSION;
+
+sub import {
+    shift;
+    my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir);
+
+    eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l)
+       or croak $@;
+}
+
+1;
+
+__END__
+
 =head1 NAME
 
 IO - load various IO modules
@@ -20,17 +42,10 @@ Currently this includes:
       IO::File
       IO::Pipe
       IO::Socket
+      IO::Dir
 
 For more information on any of these modules, please see its respective
 documentation.
 
 =cut
 
-use IO::Handle;
-use IO::Seekable;
-use IO::File;
-use IO::Pipe;
-use IO::Socket;
-
-1;
-
index a434cca..1d0e356 100644 (file)
@@ -1,20 +1,19 @@
+/*
+ * 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
@@ -28,6 +27,25 @@ typedef FILE * InputStream;
 typedef FILE * OutputStream;
 #endif
 
+#include "patchlevel.h"
+
+#if (PATCHLEVEL < 3) || ((PATCHLEVEL == 3) && (SUBVERSION < 22))
+     /* before 5.003_22 */
+#    define MY_start_subparse(fmt,flags) start_subparse()
+#else
+#  if (PATCHLEVEL == 3) && (SUBVERSION == 22)
+     /* 5.003_22 */
+#    define MY_start_subparse(fmt,flags) start_subparse(flags)
+#  else
+     /* 5.003_23  onwards */
+#    define MY_start_subparse(fmt,flags) start_subparse(fmt,flags)
+#  endif
+#endif
+
+#ifndef gv_stashpvn
+#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
 static int
 not_here(char *s)
 {
@@ -35,56 +53,94 @@ 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 *
@@ -110,8 +166,9 @@ fsetpos(handle, pos)
        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
@@ -143,24 +200,63 @@ new_tmpfile(packname = "IO::File")
        if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
            ST(0) = sv_2mortal(newRV((SV*)gv));
            sv_bless(ST(0), gv_stashpv(packname, TRUE));
-           SvREFCNT_dec(gv);   /* undo increment in newRV() */
+           SvREFCNT_dec(gv);   /* undo increment in newRV() */
        }
        else {
            ST(0) = &PL_sv_undef;
            SvREFCNT_dec(gv);
        }
 
+MODULE = IO    PACKAGE = IO::Poll
+
+void   
+_poll(timeout,...)
+       int timeout;
+PPCODE:
+{
+#ifdef HAS_POLL
+    int nfd = (items - 1) / 2;
+    SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
+    struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv);
+    int i,j,ret;
+    for(i=1, j=0  ; j < nfd ; j++) {
+       fds[j].fd = SvIV(ST(i));
+       i++;
+       fds[j].events = SvIV(ST(i));
+       i++;
+       fds[j].revents = 0;
+    }
+    if((ret = poll(fds,nfd,timeout)) >= 0) {
+       for(i=1, j=0 ; j < nfd ; j++) {
+           sv_setiv(ST(i), fds[j].fd); i++;
+           sv_setiv(ST(i), fds[j].revents); i++;
+       }
+    }
+    SvREFCNT_dec(tmpsv);
+    XSRETURN_IV(ret);
+#else
+       not_here("IO::Poll::poll");
+#endif
+}
+
+MODULE = IO    PACKAGE = IO::Handle    PREFIX = io_
+
+void
+io_blocking(handle,blk=-1)
+       InputStream     handle
+       int             blk
+PROTOTYPE: $;$
+CODE:
+{
+    int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0);
+    if(ret >= 0)
+       XSRETURN_IV(ret);
+    else
+       XSRETURN_UNDEF;
+}
+
 MODULE = IO    PACKAGE = IO::Handle    PREFIX = f
 
-SV *
-constant(name)
-       char *          name
-    CODE:
-       IV i;
-       if (constant(name, &i))
-           ST(0) = sv_2mortal(newSViv(i));
-       else
-           ST(0) = &PL_sv_undef;
 
 int
 ungetc(handle, c)
@@ -290,3 +386,91 @@ setvbuf(handle, buf, type, size)
        RETVAL
 
 
+SysRet
+fsync(handle)
+       OutputStream handle
+    CODE:
+#ifdef HAS_FSYNC
+       if(handle)
+           RETVAL = fsync(PerlIO_fileno(handle));
+       else {
+           RETVAL = -1;
+           errno = EINVAL;
+       }
+#else
+       RETVAL = (SysRet) not_here("IO::Handle::sync");
+#endif
+    OUTPUT:
+       RETVAL
+
+
+BOOT:
+{
+    HV *stash;
+    /*
+     * constant subs for IO::Poll
+     */
+    stash = gv_stashpvn("IO::Poll", 8, TRUE);
+#ifdef POLLIN
+       newCONSTSUB(stash,"POLLIN",newSViv(POLLIN));
+#endif
+#ifdef POLLPRI
+        newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI));
+#endif
+#ifdef POLLOUT
+        newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT));
+#endif
+#ifdef POLLRDNORM
+        newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM));
+#endif
+#ifdef POLLWRNORM
+        newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM));
+#endif
+#ifdef POLLRDBAND
+        newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND));
+#endif
+#ifdef POLLWRBAND
+        newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND));
+#endif
+#ifdef POLLNORM
+        newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM));
+#endif
+#ifdef POLLERR
+        newCONSTSUB(stash,"POLLERR", newSViv(POLLERR));
+#endif
+#ifdef POLLHUP
+        newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP));
+#endif
+#ifdef POLLNVAL
+        newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL));
+#endif
+    /*
+     * constant subs for IO::Handle
+     */
+    stash = gv_stashpvn("IO::Handle", 10, TRUE);
+#ifdef _IOFBF
+        newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF));
+#endif
+#ifdef _IOLBF
+        newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF));
+#endif
+#ifdef _IONBF
+        newCONSTSUB(stash,"_IONBF", newSViv(_IONBF));
+#endif
+#ifdef SEEK_SET
+        newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET));
+#endif
+#ifdef SEEK_CUR
+        newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR));
+#endif
+#ifdef SEEK_END
+        newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END));
+#endif
+    /*
+     * constant subs for IO
+     */
+    stash = gv_stashpvn("IO", 2, TRUE);
+#ifdef EINPROGRESS
+        newCONSTSUB(stash,"EINPROGRESS", newSViv(EINPROGRESS));
+#endif
+}
index 6a2d50d..05c7227 100644 (file)
@@ -1,8 +1,24 @@
 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.
 );
index e855afa..375e2ac 100644 (file)
@@ -1,4 +1,4 @@
 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.
diff --git a/ext/IO/lib/IO/Dir.pm b/ext/IO/lib/IO/Dir.pm
new file mode 100644 (file)
index 0000000..cb612d5
--- /dev/null
@@ -0,0 +1,238 @@
+# 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
index de7fabc..fa7e804 100644 (file)
@@ -49,7 +49,7 @@ these classes with methods that are specific to file handles.
 
 =over 4
 
-=item new ([ ARGS ] )
+=item new ( FILENAME [,MODE [,PERMS]] )
 
 Creates a C<IO::File>.  If it receives any parameters, they are passed to
 the method C<open>; if the open fails, the object is destroyed.  Otherwise,
@@ -72,20 +72,21 @@ Otherwise, it is returned to the caller.
 =item open( FILENAME [,MODE [,PERMS]] )
 
 C<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
 
@@ -98,13 +99,13 @@ L<IO::Seekable>
 
 =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;
@@ -115,7 +116,7 @@ require DynaLoader;
 
 @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
 
-$VERSION = "1.06021";
+$VERSION = "1.08";
 
 @EXPORT = @IO::Seekable::EXPORT;
 
@@ -127,7 +128,6 @@ eval {
     push(@EXPORT, @O);
 };
 
-
 ################################################
 ## Constructor
 ##
index 7927641..1063f1a 100644 (file)
@@ -9,21 +9,21 @@ IO::Handle - supply object methods for I/O handles
 
     use IO::Handle;
 
-    $fh = new IO::Handle;
-    if ($fh->fdopen(fileno(STDIN),"r")) {
-        print $fh->getline;
-        $fh->close;
+    $io = new IO::Handle;
+    if ($io->fdopen(fileno(STDIN),"r")) {
+        print $io->getline;
+        $io->close;
     }
 
-    $fh = new IO::Handle;
-    if ($fh->fdopen(fileno(STDOUT),"w")) {
-        $fh->print("Some text\n");
+    $io = new IO::Handle;
+    if ($io->fdopen(fileno(STDOUT),"w")) {
+        $io->print("Some text\n");
     }
 
     use IO::Handle '_IOLBF';
-    $fh->setvbuf($buffer_var, _IOLBF, 1024);
+    $io->setvbuf($buffer_var, _IOLBF, 1024);
 
-    undef $fh;       # automatically closes the file if it's open
+    undef $io;       # automatically closes the file if it's open
 
     autoflush STDOUT 1;
 
@@ -36,9 +36,7 @@ in the IO hierarchy.
 
 If you are reading this documentation, looking for a replacement for
 the C<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
 
@@ -63,87 +61,123 @@ See L<perlfunc> for complete descriptions of each of the following
 supported C<IO::Handle> methods, which are just front ends for the
 corresponding built-in functions:
 
-    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
@@ -152,7 +186,7 @@ C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
 specifies a scalar variable to use as a buffer.  WARNING: A variable
 used as a buffer by C<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
@@ -160,7 +194,7 @@ scripts:
 
 =over
 
-=item $fh->untaint
+=item $io->untaint
 
 Marks the object as taint-clean, and as such data read from it will also
 be considered taint-clean. Note that this is a very trusting action to
@@ -171,7 +205,8 @@ vulnerability should be kept in mind.
 
 =head1 NOTE
 
-A C<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
@@ -193,22 +228,22 @@ class from C<IO::Handle> and inherit those methods.
 
 =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
@@ -230,6 +265,9 @@ $XS_VERSION = "1.15";
     getline
     getlines
 
+    printflush
+    flush
+
     SEEK_SET
     SEEK_CUR
     SEEK_END
@@ -238,30 +276,6 @@ $XS_VERSION = "1.15";
     _IONBF
 );
 
-
-################################################
-## Interaction with the XS.
-##
-
-require DynaLoader;
-@IO::ISA = qw(DynaLoader);
-bootstrap IO $XS_VERSION;
-
-sub AUTOLOAD {
-    if ($AUTOLOAD =~ /::(_?[a-z])/) {
-       $AutoLoader::AUTOLOAD = $AUTOLOAD;
-       goto &AutoLoader::AUTOLOAD
-    }
-    my $constname = $AUTOLOAD;
-    $constname =~ s/.*:://;
-    my $val = constant($constname);
-    defined $val or croak "$constname is not a valid IO::Handle macro";
-    no strict 'refs';
-    *$AUTOLOAD = sub { $val };
-    goto &$AUTOLOAD;
-}
-
-
 ################################################
 ## Constructors, destructors.
 ##
@@ -269,18 +283,18 @@ sub AUTOLOAD {
 sub new {
     my $class = ref($_[0]) || $_[0] || "IO::Handle";
     @_ == 1 or croak "usage: new $class";
-    my $fh = gensym;
-    bless $fh, $class;
+    my $io = gensym;
+    bless $io, $class;
 }
 
 sub new_from_fd {
     my $class = ref($_[0]) || $_[0] || "IO::Handle";
     @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
-    my $fh = gensym;
+    my $io = gensym;
     shift;
-    IO::Handle::fdopen($fh, @_)
+    IO::Handle::fdopen($io, @_)
        or return undef;
-    bless $fh, $class;
+    bless $io, $class;
 }
 
 #
@@ -307,8 +321,8 @@ sub _open_mode_string {
 }
 
 sub fdopen {
-    @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
-    my ($fh, $fd, $mode) = @_;
+    @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
+    my ($io, $fd, $mode) = @_;
     local(*GLOB);
 
     if (ref($fd) && "".$fd =~ /GLOB\(/o) {
@@ -321,15 +335,15 @@ sub fdopen {
        $fd = "=$fd";
     }
 
-    open($fh, _open_mode_string($mode) . '&' . $fd)
-       ? $fh : undef;
+    open($io, _open_mode_string($mode) . '&' . $fd)
+       ? $io : undef;
 }
 
 sub close {
-    @_ == 1 or croak 'usage: $fh->close()';
-    my($fh) = @_;
+    @_ == 1 or croak 'usage: $io->close()';
+    my($io) = @_;
 
-    close($fh);
+    close($io);
 }
 
 ################################################
@@ -340,39 +354,39 @@ sub close {
 # select
 
 sub opened {
-    @_ == 1 or croak 'usage: $fh->opened()';
+    @_ == 1 or croak 'usage: $io->opened()';
     defined fileno($_[0]);
 }
 
 sub fileno {
-    @_ == 1 or croak 'usage: $fh->fileno()';
+    @_ == 1 or croak 'usage: $io->fileno()';
     fileno($_[0]);
 }
 
 sub getc {
-    @_ == 1 or croak 'usage: $fh->getc()';
+    @_ == 1 or croak 'usage: $io->getc()';
     getc($_[0]);
 }
 
 sub eof {
-    @_ == 1 or croak 'usage: $fh->eof()';
+    @_ == 1 or croak 'usage: $io->eof()';
     eof($_[0]);
 }
 
 sub print {
-    @_ or croak 'usage: $fh->print([ARGS])';
+    @_ or croak 'usage: $io->print(ARGS)';
     my $this = shift;
     print $this @_;
 }
 
 sub printf {
-    @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
+    @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
     my $this = shift;
     printf $this @_;
 }
 
 sub getline {
-    @_ == 1 or croak 'usage: $fh->getline';
+    @_ == 1 or croak 'usage: $io->getline()';
     my $this = shift;
     return scalar <$this>;
 } 
@@ -380,41 +394,41 @@ sub getline {
 *gets = \&getline;  # deprecated
 
 sub getlines {
-    @_ == 1 or croak 'usage: $fh->getline()';
+    @_ == 1 or croak 'usage: $io->getlines()';
     wantarray or
-       croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
+       croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
     my $this = shift;
     return <$this>;
 }
 
 sub truncate {
-    @_ == 2 or croak 'usage: $fh->truncate(LEN)';
+    @_ == 2 or croak 'usage: $io->truncate(LEN)';
     truncate($_[0], $_[1]);
 }
 
 sub read {
-    @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
+    @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
     read($_[0], $_[1], $_[2], $_[3] || 0);
 }
 
 sub sysread {
-    @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])';
+    @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
     sysread($_[0], $_[1], $_[2], $_[3] || 0);
 }
 
 sub write {
-    @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
+    @_ == 3 || @_ == 4 or croak 'usage: $io->write(BUF, LEN [, OFFSET])';
     local($\) = "";
     print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
 }
 
 sub syswrite {
-    @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])';
+    @_ == 3 || @_ == 4 or croak 'usage: $io->syswrite(BUF, LEN [, OFFSET])';
     syswrite($_[0], $_[1], $_[2], $_[3] || 0);
 }
 
 sub stat {
-    @_ == 1 or croak 'usage: $fh->stat()';
+    @_ == 1 or croak 'usage: $io->stat()';
     stat($_[0]);
 }
 
@@ -423,34 +437,44 @@ sub stat {
 ##
 
 sub autoflush {
-    my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+    my $old = new SelectSaver qualify($_[0], caller);
     my $prev = $|;
     $| = @_ > 1 ? $_[1] : 1;
     $prev;
 }
 
 sub output_field_separator {
+    carp "output_field_separator is not supported on a per-handle basis"
+       if ref($_[0]);
     my $prev = $,;
     $, = $_[1] if @_ > 1;
     $prev;
 }
 
 sub output_record_separator {
+    carp "output_record_separator is not supported on a per-handle basis"
+       if ref($_[0]);
     my $prev = $\;
     $\ = $_[1] if @_ > 1;
     $prev;
 }
 
 sub input_record_separator {
+    carp "input_record_separator is not supported on a per-handle basis"
+       if ref($_[0]);
     my $prev = $/;
     $/ = $_[1] if @_ > 1;
     $prev;
 }
 
 sub input_line_number {
-    # localizing $. doesn't work as advertised.  grrrrrr.
+    my $now  = select;
+    my $keep = $.;
+    my $tell = tell qualify($_[0], caller) if ref($_[0]);
     my $prev = $.;
     $. = $_[1] if @_ > 1;
+    $tell = tell $now;
+    $. = $keep;
     $prev;
 }
 
@@ -490,50 +514,82 @@ sub format_top_name {
 }
 
 sub format_line_break_characters {
+    carp "format_line_break_characters is not supported on a per-handle basis"
+       if ref($_[0]);
     my $prev = $:;
     $: = $_[1] if @_ > 1;
     $prev;
 }
 
 sub format_formfeed {
+    carp "format_formfeed is not supported on a per-handle basis"
+       if ref($_[0]);
     my $prev = $^L;
     $^L = $_[1] if @_ > 1;
     $prev;
 }
 
 sub formline {
-    my $fh = shift;
+    my $io = shift;
     my $picture = shift;
     local($^A) = $^A;
     local($\) = "";
     formline($picture, @_);
-    print $fh $^A;
+    print $io $^A;
 }
 
 sub format_write {
-    @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
+    @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
     if (@_ == 2) {
-       my ($fh, $fmt) = @_;
-       my $oldfmt = $fh->format_name($fmt);
-       CORE::write($fh);
-       $fh->format_name($oldfmt);
+       my ($io, $fmt) = @_;
+       my $oldfmt = $io->format_name($fmt);
+       CORE::write($io);
+       $io->format_name($oldfmt);
     } else {
        CORE::write($_[0]);
     }
 }
 
 sub fcntl {
-    @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );';
-    my ($fh, $op, $val) = @_;
-    my $r = fcntl($fh, $op, $val);
+    @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
+    my ($io, $op, $val) = @_;
+    my $r = fcntl($io, $op, $val);
     defined $r && $r eq "0 but true" ? 0 : $r;
 }
 
 sub ioctl {
-    @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );';
-    my ($fh, $op, $val) = @_;
-    my $r = ioctl($fh, $op, $val);
+    @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
+    my ($io, $op, $val) = @_;
+    my $r = ioctl($io, $op, $val);
     defined $r && $r eq "0 but true" ? 0 : $r;
 }
 
+# this sub is for compatability with older releases of IO that used
+# a sub called constant to detemine if a constant existed -- GMB
+#
+# The SEEK_* and _IO?BF constants were the only constants at that time
+# any new code should just chech defined(&CONSTANT_NAME)
+
+sub constant {
+    no strict 'refs';
+    my $name = shift;
+    (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
+       ? &{$name}() : undef;
+}
+
+
+# so that flush.pl can be depriciated
+
+sub printflush {
+    my $io = shift;
+    my $old = new SelectSaver qualify($io, caller) if ref($io);
+    local $| = 1;
+    if(ref($io)) {
+        print $io @_;
+    }
+    else {
+       print @_;
+    }
+}
+
 1;
index ae6d9a5..59f6293 100644 (file)
@@ -1,7 +1,7 @@
 # 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;
@@ -14,7 +14,7 @@ use vars qw($VERSION);
 use Carp;
 use Symbol;
 
-$VERSION = "1.0901";
+$VERSION = "1.12";
 
 sub new {
     my $type = shift;
@@ -65,7 +65,7 @@ sub _doit {
         }
         bless $io, "IO::Handle";
         $io->fdopen($fh, $mode);
-        $fh->close;
+       $fh->close;
 
         if ($do_spawn) {
           $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
@@ -88,8 +88,12 @@ sub _doit {
 }
 
 sub reader {
-    @_ >= 1 or croak 'usage: $pipe->reader()';
+    @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
     my $me = shift;
+
+    return undef
+       unless(ref($me) || ref($me = $me->new));
+
     my $fh  = ${*$me}[0];
     my $pid = $me->_doit(0, $fh, @_)
         if(@_);
@@ -97,6 +101,8 @@ sub reader {
     close ${*$me}[1];
     bless $me, ref($fh);
     *{*$me} = *{*$fh};          # Alias self to handle
+    $me->fdopen($fh->fileno,"r")
+       unless defined($me->fileno);
     bless $fh;                  # Really wan't un-bless here
     ${*$me}{'io_pipe_pid'} = $pid
         if defined $pid;
@@ -105,8 +111,12 @@ sub reader {
 }
 
 sub writer {
-    @_ >= 1 or croak 'usage: $pipe->writer()';
+    @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
     my $me = shift;
+
+    return undef
+       unless(ref($me) || ref($me = $me->new));
+
     my $fh  = ${*$me}[1];
     my $pid = $me->_doit(1, $fh, @_)
         if(@_);
@@ -114,6 +124,8 @@ sub writer {
     close ${*$me}[0];
     bless $me, ref($fh);
     *{*$me} = *{*$fh};          # Alias self to handle
+    $me->fdopen($fh->fileno,"w")
+       unless defined($me->fileno);
     bless $fh;                  # Really wan't un-bless here
     ${*$me}{'io_pipe_pid'} = $pid
         if defined $pid;
@@ -143,7 +155,7 @@ __END__
 
 =head1 NAME
 
-IO::pipe - supply object methods for pipes
+IO::Pipe - supply object methods for pipes
 
 =head1 SYNOPSIS
 
@@ -228,12 +240,12 @@ L<IO::Handle>
 
 =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
diff --git a/ext/IO/lib/IO/Poll.pm b/ext/IO/lib/IO/Poll.pm
new file mode 100644 (file)
index 0000000..3a31eb9
--- /dev/null
@@ -0,0 +1,204 @@
+# 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
index 91c381a..de982ed 100644 (file)
@@ -19,16 +19,17 @@ be inherited by other C<IO::Handle> based objects. It provides methods
 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
 
@@ -39,7 +40,7 @@ L<IO::File>
 
 =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
 
@@ -53,15 +54,20 @@ require Exporter;
 @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
 @ISA = qw(Exporter);
 
-$VERSION = "1.06";
+$VERSION = "1.08";
 
 sub seek {
-    @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+    @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
     seek($_[0], $_[1], $_[2]);
 }
 
+sub sysseek {
+    @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)';
+    sysseek($_[0], $_[1], $_[2]);
+}
+
 sub tell {
-    @_ == 1 or croak 'usage: $fh->tell()';
+    @_ == 1 or croak 'usage: $io->tell()';
     tell($_[0]);
 }
 
index dea684a..ccb49b8 100644 (file)
 # 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
 
@@ -261,7 +114,7 @@ sub can_write
     : ();
 }
 
-sub has_error
+sub has_exception
 {
  my $vec = shift;
  my $timeout = shift;
@@ -272,6 +125,14 @@ sub has_error
     : ();
 }
 
+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;
@@ -369,3 +230,148 @@ sub handles
 }
 
 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
+
index 406f74d..894190f 100644 (file)
 # 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;
@@ -121,9 +15,14 @@ use strict;
 use vars qw(@ISA $VERSION);
 use Exporter;
 
+# legacy
+
+require IO::Socket::INET;
+require IO::Socket::UNIX;
+
 @ISA = qw(IO::Handle);
 
-$VERSION = "1.1603";
+$VERSION = "1.25";
 
 sub import {
     my $pkg = shift;
@@ -133,16 +32,17 @@ sub import {
 
 sub new {
     my($class,%arg) = @_;
-    my $fh = $class->SUPER::new();
-    $fh->autoflush;
+    my $sock = $class->SUPER::new();
+
+    $sock->autoflush(1);
 
-    ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
+    ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
 
-    return scalar(%arg) ? $fh->configure(\%arg)
-                       : $fh;
+    return scalar(%arg) ? $sock->configure(\%arg)
+                       : $sock;
 }
 
-my @domain2pkg = ();
+my @domain2pkg;
 
 sub register_domain {
     my($p,$d) = @_;
@@ -150,7 +50,7 @@ sub register_domain {
 }
 
 sub configure {
-    my($fh,$arg) = @_;
+    my($sock,$arg) = @_;
     my $domain = delete $arg->{Domain};
 
     croak 'IO::Socket: Cannot configure a generic socket'
@@ -160,107 +60,119 @@ sub configure {
        unless defined $domain2pkg[$domain];
 
     croak "IO::Socket: Cannot configure socket in domain '$domain'"
-       unless ref($fh) eq "IO::Socket";
+       unless ref($sock) eq "IO::Socket";
 
-    bless($fh, $domain2pkg[$domain]);
-    $fh->configure($arg);
+    bless($sock, $domain2pkg[$domain]);
+    $sock->configure($arg);
 }
 
 sub socket {
-    @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
-    my($fh,$domain,$type,$protocol) = @_;
+    @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
+    my($sock,$domain,$type,$protocol) = @_;
 
-    socket($fh,$domain,$type,$protocol) or
+    socket($sock,$domain,$type,$protocol) or
        return undef;
 
-    ${*$fh}{'io_socket_domain'} = $domain;
-    ${*$fh}{'io_socket_type'}   = $type;
-    ${*$fh}{'io_socket_proto'}  = $protocol;
+    ${*$sock}{'io_socket_domain'} = $domain;
+    ${*$sock}{'io_socket_type'}   = $type;
+    ${*$sock}{'io_socket_proto'}  = $protocol;
 
-    $fh;
+    $sock;
 }
 
 sub socketpair {
     @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
     my($class,$domain,$type,$protocol) = @_;
-    my $fh1 = $class->new();
-    my $fh2 = $class->new();
+    my $sock1 = $class->new();
+    my $sock2 = $class->new();
 
-    socketpair($fh1,$fh2,$domain,$type,$protocol) or
+    socketpair($sock1,$sock2,$domain,$type,$protocol) or
        return ();
 
-    ${*$fh1}{'io_socket_type'}  = ${*$fh2}{'io_socket_type'}  = $type;
-    ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
+    ${*$sock1}{'io_socket_type'}  = ${*$sock2}{'io_socket_type'}  = $type;
+    ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
 
-    ($fh1,$fh2);
+    ($sock1,$sock2);
 }
 
 sub connect {
-    @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
-    my $fh = shift;
-    my $addr = @_ == 1 ? shift : sockaddr_in(@_);
-    my $timeout = ${*$fh}{'io_socket_timeout'};
-    local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
-                                : $SIG{ALRM} || 'DEFAULT';
-
-     eval {
+    @_ == 2 or croak 'usage: $sock->connect(NAME)';
+    my $sock = shift;
+    my $addr = shift;
+    my $timeout = ${*$sock}{'io_socket_timeout'};
+
+    eval {
+       my $blocking = 0;
+
        croak 'connect: Bad address'
            if(@_ == 2 && !defined $_[1]);
 
-       if($timeout) {
-           defined $Config{d_alarm} && defined alarm($timeout) or
-               $timeout = 0;
-       }
+       $blocking = $sock->blocking(0)
+           if($timeout);
 
-       my $ok = connect($fh, $addr);
+       unless(connect($sock, $addr)) {
+           if($timeout && ($! == &IO::EINPROGRESS)) {
+               require IO::Select;
 
-       alarm(0)
-           if($timeout);
+               my $sel = new IO::Select $sock;
 
-       croak "connect: timeout"
-           unless defined $fh;
+               $sock->blocking(1)
+                   if($blocking);
 
-       undef $fh unless $ok;
+               unless($sel->can_write($timeout) && defined($sock->peername)) {
+                   undef $sock;
+                   croak "connect: timeout";
+               }
+           }
+           else {
+               undef $sock;
+               croak "connect: $!";
+           }
+       }
+       $sock->blocking(1)
+           if($sock && $blocking);
     };
 
-    $fh;
+    $sock;
 }
 
 sub bind {
-    @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
-    my $fh = shift;
-    my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+    @_ == 2 or croak 'usage: $sock->bind(NAME)';
+    my $sock = shift;
+    my $addr = shift;
 
-    return bind($fh, $addr) ? $fh
-                           : undef;
+    return bind($sock, $addr) ? $sock
+                             : undef;
 }
 
 sub listen {
-    @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
-    my($fh,$queue) = @_;
+    @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
+    my($sock,$queue) = @_;
     $queue = 5
        unless $queue && $queue > 0;
 
-    return listen($fh, $queue) ? $fh
-                              : undef;
+    return listen($sock, $queue) ? $sock
+                                : undef;
 }
 
 sub accept {
-    @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
-    my $fh = shift;
-    my $pkg = shift || $fh;
-    my $timeout = ${*$fh}{'io_socket_timeout'};
+    @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
+    my $sock = shift;
+    my $pkg = shift || $sock;
+    my $timeout = ${*$sock}{'io_socket_timeout'};
     my $new = $pkg->new(Timeout => $timeout);
     my $peer = undef;
 
     eval {
        if($timeout) {
-           my $fdset = "";
-           vec($fdset, $fh->fileno,1) = 1;
+           require IO::Select;
+
+           my $sel = new IO::Select $sock;
+
            croak "accept: timeout"
-               unless select($fdset,undef,undef,$timeout);
+               unless $sel->can_read($timeout);
        }
-       $peer = accept($new,$fh);
+       $peer = accept($new,$sock) || undef;
     };
 
     return wantarray ? defined $peer ? ($new, $peer)
@@ -270,40 +182,46 @@ sub accept {
 }
 
 sub sockname {
-    @_ == 1 or croak 'usage: $fh->sockname()';
+    @_ == 1 or croak 'usage: $sock->sockname()';
     getsockname($_[0]);
 }
 
 sub peername {
-    @_ == 1 or croak 'usage: $fh->peername()';
-    my($fh) = @_;
-    getpeername($fh)
-      || ${*$fh}{'io_socket_peername'}
+    @_ == 1 or croak 'usage: $sock->peername()';
+    my($sock) = @_;
+    getpeername($sock)
+      || ${*$sock}{'io_socket_peername'}
       || undef;
 }
 
+sub connected {
+    @_ == 1 or croak 'usage: $sock->connected()';
+    my($sock) = @_;
+    getpeername($sock);
+}
+
 sub send {
-    @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
-    my $fh    = $_[0];
+    @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
+    my $sock  = $_[0];
     my $flags = $_[2] || 0;
-    my $peer  = $_[3] || $fh->peername;
+    my $peer  = $_[3] || $sock->peername;
 
     croak 'send: Cannot determine peer address'
         unless($peer);
 
-    my $r = defined(getpeername($fh))
-       ? send($fh, $_[1], $flags)
-       : send($fh, $_[1], $flags, $peer);
+    my $r = defined(getpeername($sock))
+       ? send($sock, $_[1], $flags)
+       : send($sock, $_[1], $flags, $peer);
 
     # remember who we send to, if it was sucessful
-    ${*$fh}{'io_socket_peername'} = $peer
+    ${*$sock}{'io_socket_peername'} = $peer
        if(@_ == 4 && defined $r);
 
     $r;
 }
 
 sub recv {
-    @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
+    @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
     my $sock  = $_[0];
     my $len   = $_[2];
     my $flags = $_[3] || 0;
@@ -312,16 +230,21 @@ sub recv {
     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
 }
 
+sub shutdown {
+    @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
+    my($sock, $how) = @_;
+    shutdown($sock, $how);
+}
 
 sub setsockopt {
-    @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
+    @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
     setsockopt($_[0],$_[1],$_[2],$_[3]);
 }
 
 my $intsize = length(pack("i",0));
 
 sub getsockopt {
-    @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
+    @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
     my $r = getsockopt($_[0],$_[1],$_[2]);
     # Just a guess
     $r = unpack("i", $r)
@@ -330,399 +253,166 @@ sub getsockopt {
 }
 
 sub sockopt {
-    my $fh = shift;
-    @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
-           : $fh->setsockopt(SOL_SOCKET,@_);
+    my $sock = shift;
+    @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
+           : $sock->setsockopt(SOL_SOCKET,@_);
 }
 
 sub timeout {
-    @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
-    my($fh,$val) = @_;
-    my $r = ${*$fh}{'io_socket_timeout'} || undef;
+    @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
+    my($sock,$val) = @_;
+    my $r = ${*$sock}{'io_socket_timeout'} || undef;
 
-    ${*$fh}{'io_socket_timeout'} = 0 + $val
+    ${*$sock}{'io_socket_timeout'} = 0 + $val
        if(@_ == 2);
 
     $r;
 }
 
 sub sockdomain {
-    @_ == 1 or croak 'usage: $fh->sockdomain()';
-    my $fh = shift;
-    ${*$fh}{'io_socket_domain'};
+    @_ == 1 or croak 'usage: $sock->sockdomain()';
+    my $sock = shift;
+    ${*$sock}{'io_socket_domain'};
 }
 
 sub socktype {
-    @_ == 1 or croak 'usage: $fh->socktype()';
-    my $fh = shift;
-    ${*$fh}{'io_socket_type'}
+    @_ == 1 or croak 'usage: $sock->socktype()';
+    my $sock = shift;
+    ${*$sock}{'io_socket_type'}
 }
 
 sub protocol {
-    @_ == 1 or croak 'usage: $fh->protocol()';
-    my($fh) = @_;
-    ${*$fh}{'io_socket_protocol'};
+    @_ == 1 or croak 'usage: $sock->protocol()';
+    my($sock) = @_;
+    ${*$sock}{'io_socket_protocol'};
 }
 
-=head1 SUB-CLASSES
-
-=cut
-
-##
-## AF_INET
-##
-
-package IO::Socket::INET;
-
-use strict;
-use vars qw(@ISA);
-use Socket;
-use Carp;
-use Exporter;
-
-@ISA = qw(IO::Socket);
-
-IO::Socket::INET->register_domain( AF_INET );
-
-my %socket_type = ( tcp => SOCK_STREAM,
-                   udp => SOCK_DGRAM,
-                   icmp => SOCK_RAW,
-                 );
-
-=head2 IO::Socket::INET
-
-C<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
diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm
new file mode 100644 (file)
index 0000000..ccd0e8f
--- /dev/null
@@ -0,0 +1,379 @@
+# 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
diff --git a/ext/IO/lib/IO/Socket/UNIX.pm b/ext/IO/lib/IO/Socket/UNIX.pm
new file mode 100644 (file)
index 0000000..7dc7d0c
--- /dev/null
@@ -0,0 +1,142 @@
+# 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
diff --git a/ext/IO/poll.c b/ext/IO/poll.c
new file mode 100644 (file)
index 0000000..5d806b6
--- /dev/null
@@ -0,0 +1,129 @@
+/*
+ * 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(struct pollfd *fds, unsigned long nfds, int timeout)
+{
+    int i,err;
+    fd_set rfd,wfd,efd,ifd;
+    struct timeval timebuf;
+    struct timeval *tbuf = (struct timeval *)0;
+    int n = 0;
+    int count;
+
+    FD_ZERO(&ifd);
+
+again:
+
+    FD_ZERO(&rfd);
+    FD_ZERO(&wfd);
+    FD_ZERO(&efd);
+
+    for(i = 0 ; i < nfds ; i++) {
+       int events = fds[i].events;
+       int fd = fds[i].fd;
+
+       fds[i].revents = 0;
+
+       if(fd < 0 || FD_ISSET(fd, &ifd))
+           continue;
+
+       if(fd > n)
+           n = fd;
+
+       if(events & POLL_CAN_READ)
+           FD_SET(fd, &rfd);
+
+       if(events & POLL_CAN_WRITE)
+           FD_SET(fd, &wfd);
+
+       if(events & POLL_HAS_EXCP)
+           FD_SET(fd, &efd);
+    }
+
+    if(timeout >= 0) {
+       timebuf.tv_sec = timeout / 1000;
+       timebuf.tv_usec = (timeout % 1000) * 1000;
+       tbuf = &timebuf;
+    }
+
+    err = select(n+1,&rfd,&wfd,&efd,tbuf);
+
+    if(err < 0) {
+#ifdef HAS_FSTAT
+       if(errno == EBADF) {
+           for(i = 0 ; i < nfds ; i++) {
+               struct stat buf;
+               if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) {
+                   FD_SET(fds[i].fd, &ifd);
+                   goto again;
+               }
+           }
+       }
+#endif /* HAS_FSTAT */
+       return err;
+    }
+
+    count = 0;
+
+    for(i = 0 ; i < nfds ; i++) {
+       int revents = (fds[i].events & POLL_EVENTS_MASK);
+       int fd = fds[i].fd;
+
+       if(fd < 0)
+           continue;
+
+       if(FD_ISSET(fd, &ifd))
+           revents = POLLNVAL;
+       else {
+           if(!FD_ISSET(fd, &rfd))
+               revents &= ~POLL_CAN_READ;
+
+           if(!FD_ISSET(fd, &wfd))
+               revents &= ~POLL_CAN_WRITE;
+
+           if(!FD_ISSET(fd, &efd))
+               revents &= ~POLL_HAS_EXCP;
+       }
+
+       if((fds[i].revents = revents) != 0)
+           count++;
+    }
+
+    return count; 
+}
+
+#endif /* EMULATE_POLL_WITH_SELECT */
diff --git a/ext/IO/poll.h b/ext/IO/poll.h
new file mode 100644 (file)
index 0000000..d17edff
--- /dev/null
@@ -0,0 +1,58 @@
+/*
+ * 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 */
+
index b2a8f1a..7c1ecc5 100644 (file)
@@ -419,6 +419,7 @@ push_return
 push_scope
 ref
 refkids
+reginitcolors
 regdump
 regexec_flags
 regnext
diff --git a/gv.c b/gv.c
index 4cef56d..85ac8f9 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -761,6 +761,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
     case '|':
     case '\001':
     case '\002':
+    case '\003':
     case '\004':
     case '\005':
     case '\006':
@@ -874,7 +875,8 @@ newIO(void)
     SvREFCNT(io) = 1;
     SvOBJECT_on(io);
     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
-    if (!iogv)
+    /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
+    if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
     return io;
index bbb6bd7..7aa0d84 100644 (file)
@@ -15,6 +15,14 @@ English - use nice English (or awk) names for ugly punctuation variables
 
 =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 
index b072c12..1710c5e 100644 (file)
@@ -225,6 +225,9 @@ sub _win32_ext {
     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 = $_;
@@ -240,8 +243,8 @@ sub _win32_ext {
 
        # 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;
@@ -625,9 +628,10 @@ Unix-OS/2 version in several respects:
 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 *
 
index f26be77..9f1256a 100644 (file)
@@ -5,7 +5,7 @@ require Exporter;
 @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
 
@@ -72,7 +72,8 @@ CONFIG: {
 }
 
 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;
@@ -93,17 +94,17 @@ sub Complete {
                 # (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;
                 };
 
index 6f57415..22f947a 100644 (file)
@@ -2,17 +2,19 @@ use strict;
 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.
@@ -35,9 +37,9 @@ sub plan {
     }
     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;
 }
@@ -47,9 +49,6 @@ sub to_value {
     (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);
@@ -63,49 +62,49 @@ sub ok ($;$$) {
        $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;
@@ -116,8 +115,10 @@ sub ok ($;$$) {
 }
 
 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 {
@@ -141,7 +142,12 @@ __END__
 
   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
@@ -152,6 +158,7 @@ __END__
   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'
@@ -165,9 +172,9 @@ __END__
 
 =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
 
@@ -175,53 +182,60 @@ easier (and less error prone :-).
 
 =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
 
index c755053..3cf94ec 100644 (file)
@@ -65,6 +65,10 @@ Read a single line
 
 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>.
diff --git a/mg.c b/mg.c
index 7859c47..ba90227 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -326,8 +326,13 @@ magic_regdata_cnt(SV *sv, MAGIC *mg)
     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;
 }
 
@@ -350,9 +355,9 @@ magic_regdatum_get(SV *sv, MAGIC *mg)
            (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);
            }
     }
@@ -477,6 +482,10 @@ magic_get(SV *sv, MAGIC *mg)
            /* 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;
@@ -1655,6 +1664,11 @@ magic_set(SV *sv, MAGIC *mg)
            }
        }
        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());
index 86f0368..51991e6 100755 (executable)
--- a/myconfig
+++ b/myconfig
@@ -21,6 +21,7 @@ Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION)
   Platform:
     osname=$osname, osvers=$osvers, archname=$archname
     uname='$myuname'
+    config_args='$config_args'
     hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
     usethreads=$usethreads useperlio=$useperlio d_sfio=$d_sfio
     use64bits=$use64bits usemultiplicity=$usemultiplicity
index a9820dd..75be465 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #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
index dbd721f..f725137 100644 (file)
@@ -214,6 +214,8 @@ after 5.005_02:
        $^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).
index 8fd7bfb..c9bf39a 100644 (file)
@@ -18,6 +18,7 @@ $spitshell >>Makefile <<!GROK!THIS!
 
 PERL_VERSION = $perl_version
 
+OPTIMIZE       = $optimize
 AOUT_OPTIMIZE  = \$(OPTIMIZE)
 AOUT_CCCMD     = \$(CC) $aout_ccflags \$(AOUT_OPTIMIZE)
 AOUT_AR                = $aout_ar
index 15a6392..ce1f209 100644 (file)
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -580,21 +580,24 @@ char *inicmd;
                /* 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;
diff --git a/perl.c b/perl.c
index 7659b7c..9ddf917 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -547,6 +547,8 @@ perl_destruct(register PerlInterpreter *sv_interp)
     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();
index 9187c84..1452a84 100644 (file)
@@ -30,6 +30,7 @@ POD = \
        perlform.pod    \
        perllocale.pod  \
        perlref.pod     \
+       perlreftut.pod  \
        perldsc.pod     \
        perllol.pod     \
        perltoot.pod    \
@@ -80,6 +81,7 @@ MAN = \
        perlform.man    \
        perllocale.man  \
        perlref.man     \
+       perlreftut.man  \
        perldsc.man     \
        perllol.man     \
        perltoot.man    \
@@ -130,6 +132,7 @@ HTML = \
        perlform.html   \
        perllocale.html \
        perlref.html    \
+       perlreftut.html \
        perldsc.html    \
        perllol.html    \
        perltoot.html   \
@@ -180,6 +183,7 @@ TEX = \
        perlform.tex    \
        perllocale.tex  \
        perlref.tex     \
+       perlreftut.tex  \
        perldsc.tex     \
        perllol.tex     \
        perltoot.tex    \
index 80ca2ec..8df5726 100644 (file)
@@ -8,7 +8,8 @@ sub output ($);
           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
index 0f0f859..0d2251e 100644 (file)
@@ -40,6 +40,7 @@ of sections:
     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
index 58c1123..8f700f6 100644 (file)
@@ -471,7 +471,7 @@ is legal to assign to:
 
     ($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
index 265aad4..370353b 100644 (file)
@@ -2804,7 +2804,7 @@ but is more efficient.  Returns the new number of elements in the array.
 
 =item qw/STRING/
 
-Generalized quotes.  See L<perlop>.
+Generalized quotes.  See L<perlop/"Regexp Quote-Like Operators">.
 
 =item quotemeta EXPR
 
@@ -4145,11 +4145,11 @@ This function binds a variable to a package class that will provide the
 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
@@ -4166,28 +4166,52 @@ C<each()> function to iterate over such.  Example:
 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>
index 8e50ec3..857b951 100644 (file)
@@ -910,12 +910,47 @@ A double-quoted, interpolated string.
 
 =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:
 
@@ -925,19 +960,6 @@ 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.
 
index d20d62d..7fa8290 100644 (file)
@@ -171,7 +171,8 @@ here and in commands:
                                        (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">
@@ -184,6 +185,8 @@ here and in commands:
     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)
index aa4ddfb..b59b4a8 100644 (file)
@@ -2,6 +2,12 @@
 
 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
diff --git a/pod/perlreftut.pod b/pod/perlreftut.pod
new file mode 100644 (file)
index 0000000..2fac79d
--- /dev/null
@@ -0,0 +1,397 @@
+
+=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
+
index 38fd168..8c6305c 100644 (file)
@@ -17,6 +17,15 @@ at the top of your program.  This will alias all the short names to the
 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
@@ -127,6 +136,10 @@ The string matched by the last successful pattern match (not counting
 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 $`
@@ -136,6 +149,10 @@ pattern match (not counting any matches hidden within a BLOCK or eval
 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 $'
@@ -151,6 +168,10 @@ string.)  Example:
 
 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 $+
@@ -168,13 +189,14 @@ This variable is read-only.
 
 $+[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
 
@@ -389,13 +411,15 @@ channel.  (Mnemonic: lines_on_page - lines_printed.)
 
 $-[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
 
index 918fe02..421b37a 100644 (file)
@@ -44,6 +44,7 @@ toroff=`
     $mandir/perlform.1 \
     $mandir/perllocale.1       \
     $mandir/perlref.1  \
+    $mandir/perlreftut.1       \
     $mandir/perldsc.1  \
     $mandir/perllol.1  \
     $mandir/perltoot.1 \
diff --git a/pp.c b/pp.c
index 0bd4842..21a5dd3 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4672,7 +4672,7 @@ PP(pp_split)
     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
index e488749..fbfcab5 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -164,8 +164,9 @@ PP(pp_substcont)
 
        /* 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);
@@ -668,12 +669,8 @@ PP(pp_grepstart)
     ENTER;                                     /* enter outer scope */
 
     SAVETMPS;
-#ifdef USE_THREADS
-    /* SAVE_DEFSV does *not* suffice here */
-    save_sptr(&THREADSV(0));
-#else
-    SAVESPTR(GvSV(PL_defgv));
-#endif /* USE_THREADS */
+    /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
+    SAVESPTR(DEFSV);
     ENTER;                                     /* enter inner scope */
     SAVESPTR(PL_curpm);
 
index 713b1d1..f9ff09d 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -832,7 +832,7 @@ PP(pp_match)
     register char *s;
     char *strend;
     I32 global;
-    I32 safebase;
+    I32 r_flags;
     char *truebase;
     register REGEXP *rx = pm->op_pmregexp;
     bool rxtainted;
@@ -841,7 +841,6 @@ PP(pp_match)
     I32 minmatch = 0;
     I32 oldsave = PL_savestack_ix;
     I32 update_minmatch = 1;
-    SV *screamer;
 
     if (PL_op->op_flags & OPf_STACKED)
        TARG = POPs;
@@ -871,10 +870,6 @@ PP(pp_match)
     }
     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;
@@ -887,9 +882,14 @@ PP(pp_match)
            }
        }
     }
-    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;
@@ -905,7 +905,7 @@ play_it_again:
     }
     if (rx->check_substr) {
        if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
-           if ( screamer ) {
+           if (r_flags & REXEC_SCREAM) {
                I32 p = -1;
                char *b;
                
@@ -950,8 +950,7 @@ play_it_again:
            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)
@@ -1602,13 +1601,12 @@ PP(pp_subst)
     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;
@@ -1646,12 +1644,12 @@ PP(pp_subst)
        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;
@@ -1659,7 +1657,7 @@ PP(pp_subst)
     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;
                
@@ -1706,9 +1704,9 @@ PP(pp_subst)
     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);
@@ -1808,7 +1806,7 @@ PP(pp_subst)
        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);
@@ -1842,7 +1840,7 @@ PP(pp_subst)
                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);
diff --git a/proto.h b/proto.h
index b0c7f9b..b22451a 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -873,6 +873,7 @@ CHECKPOINT regcppush _((I32 parenfloor));
 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,...));
@@ -960,3 +961,4 @@ VIRTUAL void do_op_dump _((I32 level, PerlIO *file, OP *o));
 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));
index 4fcef36..0915af6 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -39,6 +39,7 @@
 #  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*/
@@ -759,6 +760,31 @@ add_data(I32 n, char *s)
     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
  *
@@ -798,32 +824,10 @@ pregcomp(char *exp, char *xend, PMOP *pm)
        PL_reg_flags = 0;
 
     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(if (!PL_colorset) reginitcolors());
     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]));
+                     PL_colors[4],PL_colors[5],PL_colors[0],
+                     xend - exp, PL_regprecomp, PL_colors[1]));
     PL_regflags = pm->op_pmflags;
     PL_regsawback = 0;
 
index 841b900..4879706 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -37,6 +37,7 @@
 #  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*/
@@ -108,6 +109,7 @@ static CHECKPOINT regcppush _((I32 parenfloor));
 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))
@@ -259,13 +261,25 @@ cache_re(regexp *prog)
     PL_regdata = prog->data;    
     PL_reg_re = prog;    
 }
-  
+
+STATIC void
+restore_pos(void *arg)
+{
+    dTHR;
+    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. */
@@ -327,6 +341,7 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
     /* 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;
@@ -349,9 +364,9 @@ regexec_flags(register regexp *prog, char *stringarg, register char *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
@@ -388,8 +403,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
            s = startpos;
     }
 
-    DEBUG_r(
-       PerlIO_printf(Perl_debug_log, 
+    DEBUG_r(if (!PL_colorset) reginitcolors());
+    DEBUG_r(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],
                      prog->precomp,
@@ -401,14 +416,23 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
                      (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;
@@ -424,6 +448,10 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
            }
        }
        goto phooey;
+    } else if (prog->reganch & ROPT_ANCH_GPOS) {
+       if (regtry(prog, PL_reg_ganch))
+           goto got_it;
+       goto phooey;
     }
 
     /* Messy cases:  unanchored match. */
@@ -479,8 +507,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
        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))) ) {
@@ -912,8 +940,8 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
            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. */
@@ -983,15 +1011,20 @@ got_it:
            }
        }
     }
-    /* 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;
 }
 
@@ -1008,6 +1041,8 @@ regtry(regexp *prog, char *startpos)
     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",
@@ -1020,13 +1055,42 @@ regtry(regexp *prog, char *startpos)
        /* 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 != DEFSV) {
+               /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
+               SAVESPTR(DEFSV);
+               DEFSV = 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)
@@ -1035,17 +1099,19 @@ regtry(regexp *prog, char *startpos)
             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;
     }
@@ -1108,7 +1174,7 @@ regmatch(regnode *prog)
            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 
@@ -1159,7 +1225,7 @@ regmatch(regnode *prog)
                break;
            sayNO;
        case GPOS:
-           if (locinput == PL_regbol)
+           if (locinput == PL_reg_ganch)
                break;
            sayNO;
        case EOL:
@@ -1591,6 +1657,8 @@ regmatch(regnode *prog)
            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;
index 5082610..67410a5 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -86,6 +86,7 @@ typedef struct regexp {
 #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 */
 
@@ -101,6 +102,7 @@ typedef struct regexp {
 
 #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)
diff --git a/scope.c b/scope.c
index b6c0c0a..fadc5df 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -930,8 +930,8 @@ cx_dump(PERL_CONTEXT *cx)
                (long)cx->sb_iters);
        PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
                (long)cx->sb_maxiters);
-       PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
-               (long)cx->sb_safebase);
+       PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
+               (long)cx->sb_rflags);
        PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
                (long)cx->sb_once);
        PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
diff --git a/t/lib/io_const.t b/t/lib/io_const.t
new file mode 100755 (executable)
index 0000000..3d747f1
--- /dev/null
@@ -0,0 +1,33 @@
+
+BEGIN {
+    unless(grep /blib/, @INC) {
+       chdir 't' if -d 't';
+       @INC = '../lib' if -d '../lib';
+    }
+}
+
+use Config;
+
+BEGIN {
+    if(-d "lib" && -f "TEST") {
+        if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+           print "1..0\n";
+           exit 0;
+        }
+    }
+}
+
+use IO::Handle;
+
+print "1..6\n";
+my $i = 1;
+foreach (qw(SEEK_SET SEEK_CUR SEEK_END     _IOFBF    _IOLBF    _IONBF)) {
+    my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0;
+    my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef;
+    my $v2 = IO::Handle::constant($_);
+    my $d2 = defined($v2);
+
+    print "not "
+       if($d1 != $d2 || ($d1 && ($v1 != $v2)));
+    print "ok ",$i++,"\n";
+}
diff --git a/t/lib/io_dir.t b/t/lib/io_dir.t
new file mode 100755 (executable)
index 0000000..889e35c
--- /dev/null
@@ -0,0 +1,66 @@
+#!./perl
+
+BEGIN {
+    unless(grep /blib/, @INC) {
+        chdir 't' if -d 't';
+        @INC = '../lib' if -d '../lib';
+    }
+    require Config; import Config;
+    if ($] < 5.00326 || not $Config{'d_readdir'}) {
+       print "1..0\n";
+       exit 0;
+    }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+use IO::Dir qw(DIR_UNLINK);
+
+print "1..10\n";
+
+$dot = new IO::Dir ".";
+print defined($dot) ? "ok" : "not ok", " 1\n";
+
+@a = sort <*>;
+do { $first = $dot->read } while defined($first) && $first =~ /^\./;
+print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
+
+@b = sort($first, (grep {/^[^.]/} $dot->read));
+print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n";
+
+$dot->rewind;
+@c = sort grep {/^[^.]/} $dot->read;
+print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n";
+
+$dot->close;
+$dot->rewind;
+print defined($dot->read) ? "not ok" : "ok", " 5\n";
+
+open(FH,'>X') || die "Can't create x";
+print FH "X";
+close(FH);
+
+tie %dir, IO::Dir, ".";
+my @files = keys %dir;
+
+# I hope we do not have an empty dir :-)
+print @files ? "ok" : "not ok", " 6\n";
+
+my $stat = $dir{'X'};
+print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1
+       ? "ok" : "not ok", " 7\n";
+
+delete $dir{'X'};
+
+print -f 'X' ? "ok" : "not ok", " 8\n";
+
+tie %dirx, IO::Dir, ".", DIR_UNLINK;
+
+my $statx = $dirx{'X'};
+print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1
+       ? "ok" : "not ok", " 9\n";
+
+delete $dirx{'X'};
+
+print -f 'X' ? "not ok" : "ok", " 10\n";
diff --git a/t/lib/io_multihomed.t b/t/lib/io_multihomed.t
new file mode 100644 (file)
index 0000000..3d7188b
--- /dev/null
@@ -0,0 +1,111 @@
+#!./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{'d_fork'} ||
+           (($Config{'extensions'} !~ /\bSocket\b/ ||
+             $Config{'extensions'} !~ /\bIO\b/) &&
+            !(($^O eq 'VMS') && $Config{d_socket}))) {
+           print "1..0\n";
+           exit 0;
+        }
+    }
+}
+
+$| = 1;
+
+print "1..8\n";
+
+
+package Multi;
+require IO::Socket::INET;
+@ISA=qw(IO::Socket::INET);
+
+use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in);
+
+sub _get_addr
+{
+    my($sock,$addr_str, $multi) = @_;
+    #print "_get_addr($sock, $addr_str, $multi)\n";
+
+    print "not " unless $multi;
+    print "ok 2\n";
+
+    (
+     # private IP-addresses which I hope does not work anywhere :-)
+     inet_aton("10.250.230.10"),
+     inet_aton("10.250.230.12"),
+     inet_aton("127.0.0.1")        # loopback
+    )
+}
+
+sub connect
+{
+    my $self = shift;
+    if (@_ == 1) {
+       my($port, $addr) = unpack_sockaddr_in($_[0]);
+       $addr = inet_ntoa($addr);
+       #print "connect($self, $port, $addr)\n";
+       print "ok 3\n" if $addr eq "10.250.230.10";
+       print "ok 4\n" if $addr eq "10.250.230.12";
+    }
+    $self->SUPER::connect(@_);
+}
+
+
+
+package main;
+
+use IO::Socket;
+
+$listen = IO::Socket::INET->new(Listen => 2,
+                               Proto => 'tcp',
+                               Timeout => 5,
+                              ) or die "$!";
+
+print "ok 1\n";
+
+$port = $listen->sockport;
+
+if($pid = fork()) {
+
+    $sock = $listen->accept() or die "$!";
+    print "ok 5\n";
+
+    print $sock->getline();
+    print $sock "ok 7\n";
+
+    waitpid($pid,0);
+
+    $sock->close;
+
+    print "ok 8\n";
+
+} elsif(defined $pid) {
+
+    $sock = Multi->new(PeerPort => $port,
+                      Proto => 'tcp',
+                      PeerAddr => 'localhost',
+                      MultiHomed => 1,
+                      Timeout => 1,
+                     ) or die "$!";
+
+    print $sock "ok 6\n";
+    sleep(1); # race condition
+    print $sock->getline();
+
+    $sock->close;
+
+    exit;
+} else {
+    die;
+}
diff --git a/t/lib/io_poll.t b/t/lib/io_poll.t
new file mode 100755 (executable)
index 0000000..d907d54
--- /dev/null
@@ -0,0 +1,66 @@
+#!./perl
+
+BEGIN {
+    unless(grep /blib/, @INC) {
+        chdir 't' if -d 't';
+        @INC = '../lib' if -d '../lib';
+    }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print "1..8\n";
+
+use IO::Handle;
+use IO::Poll qw(/POLL/);
+
+my $poll = new IO::Poll;
+
+my $stdout = \*STDOUT;
+my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w");
+
+$poll->mask($stdout => POLLOUT);
+
+print "not "
+       unless $poll->mask($stdout) == POLLOUT;
+print "ok 1\n";
+
+$poll->mask($dupout => POLLPRI);
+
+print "not "
+       unless $poll->mask($dupout) == POLLPRI;
+print "ok 2\n";
+
+$poll->poll(0.1);
+
+print "not "
+       unless $poll->events($stdout) == POLLOUT;
+print "ok 3\n";
+
+print "not "
+       if $poll->events($dupout);
+print "ok 4\n";
+
+my @h = $poll->handles;
+print "not "
+       unless @h == 2;
+print "ok 5\n";
+
+$poll->remove($stdout);
+
+@h = $poll->handles;
+
+print "not "
+       unless @h == 1;
+print "ok 6\n";
+
+print "not "
+       if $poll->mask($stdout);
+print "ok 7\n";
+
+$poll->poll(0.1);
+
+print "not "
+       if $poll->events($stdout);
+print "ok 8\n";
index 8fc52e4..60f5b5a 100755 (executable)
@@ -22,12 +22,13 @@ BEGIN {
 }
 
 $| = 1;
-print "1..5\n";
+print "1..14\n";
 
 use IO::Socket;
 
 $listen = IO::Socket::INET->new(Listen => 2,
                                Proto => 'tcp',
+                               Timeout => 2,
                               ) or die "$!";
 
 print "ok 1\n";
@@ -69,7 +70,7 @@ if($pid = fork()) {
                                  Proto => 'tcp',
                                  PeerAddr => 'localhost'
                                 )
-           or die "$! (maybe your system does not have the 'localhost' address defined)";
+       or die "$! (maybe your system does not have the 'localhost' address defined)";
 
     $sock->autoflush(1);
 
@@ -84,8 +85,99 @@ if($pid = fork()) {
  die;
 }
 
+# Test various other ways to create INET sockets that should
+# also work.
+$listen = IO::Socket::INET->new(Listen => '', Timeout => 2) or die "$!";
+$port = $listen->sockport;
 
+if($pid = fork()) {
+  SERVER_LOOP:
+    while (1) {
+       last SERVER_LOOP unless $sock = $listen->accept;
+       while (<$sock>) {
+           last SERVER_LOOP if /^quit/;
+           last if /^done/;
+           print;
+       }
+       $sock = undef;
+    }
+    $listen->close;
+} elsif (defined $pid) {
+    # child, try various ways to connect
+    $sock = IO::Socket::INET->new("localhost:$port");
+    if ($sock) {
+       print "not " unless $sock->connected;
+       print "ok 6\n";
+       $sock->print("ok 7\n");
+       sleep(1);
+       print "ok 8\n";
+       $sock->print("ok 9\n");
+       $sock->print("done\n");
+       $sock->close;
+    }
+    else {
+       print "# $@\n";
+       print "not ok 6\n";
+       print "not ok 7\n";
+       print "not ok 8\n";
+       print "not ok 9\n";
+    }
+
+    # some machines seem to suffer from a race condition here
+#    sleep(1);
+
+    $sock = IO::Socket::INET->new("127.0.0.1:$port");
+    if ($sock) {
+       $sock->print("ok 10\n");
+       $sock->print("done\n");
+       $sock->close;
+    }
+    else {
+       print "# $@\n";
+       print "not ok 10\n";
+    }
 
+    # some machines seem to suffer from a race condition here
+#    sleep(1);
 
+    $sock = IO::Socket->new(Domain => AF_INET,
+                            PeerAddr => "localhost:$port");
+    if ($sock) {
+       $sock->print("ok 11\n");
+       $sock->print("quit\n");
+    }
+    $sock = undef;
+    sleep(1);
+    exit;
+} else {
+    die;
+}
+
+# Then test UDP sockets
+$server = IO::Socket->new(Domain => AF_INET,
+                          Proto  => 'udp',
+                          LocalAddr => 'localhost');
+$port = $server->sockport;
+
+if ($pid = fork()) {
+    my $buf;
+    $server->recv($buf, 100);
+    print $buf;
+} elsif (defined($pid)) {
+    #child
+    $sock = IO::Socket::INET->new(Proto => 'udp',
+                                  PeerAddr => "localhost:$port");
+    $sock->send("ok 12\n");
+    sleep(1);
+    $sock->send("ok 12\n");  # send another one to be sure
+    exit;
+} else {
+    die;
+}
 
+print "not " unless $server->blocking;
+print "ok 13\n";
 
+$server->blocking(0);
+print "not " if $server->blocking;
+print "ok 14\n";
index 014e12d..88cb4b6 100755 (executable)
@@ -21,8 +21,16 @@ BEGIN {
     }
 }
 
+sub compare_addr {
+    my $a = shift;
+    my $b = shift;
+    my @a = unpack_sockaddr_in($a);
+    my @b = unpack_sockaddr_in($b);
+    "$a[0]$a[1]" eq "$b[0]$b[1]";
+}
+
 $| = 1;
-print "1..3\n";
+print "1..7\n";
 
 use Socket;
 use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
@@ -35,14 +43,33 @@ use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
 
 $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
     or die "$! (maybe your system does not have the 'localhost' address defined)";
+
+print "ok 1\n";
+
 $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
     or die "$! (maybe your system does not have the 'localhost' address defined)";
 
-print "ok 1\n";
+print "ok 2\n";
+
+$udpa->send("ok 4\n",0,$udpb->sockname);
 
-$udpa->send("ok 2\n",0,$udpb->sockname);
-$udpb->recv($buf="",5);
+print "not " unless compare_addr($udpa->peername,$udpb->sockname);
+print "ok 3\n";
+
+my $where = $udpb->recv($buf="",5);
 print $buf;
-$udpb->send("ok 3\n");
+
+my @xtra = ();
+
+unless(compare_addr($where,$udpa->sockname)) {
+    print "not ";
+    @xtra = (0,$udpa->sockname);
+}
+print "ok 5\n";
+
+$udpb->send("ok 6\n",@xtra);
 $udpa->recv($buf="",5);
 print $buf;
+
+print "not " if $udpa->connected;
+print "ok 7\n";
diff --git a/t/lib/io_unix.t b/t/lib/io_unix.t
new file mode 100644 (file)
index 0000000..3d9ed50
--- /dev/null
@@ -0,0 +1,72 @@
+
+#!./perl
+
+BEGIN {
+    unless(grep /blib/, @INC) {
+        chdir 't' if -d 't';
+        @INC = '../lib' if -d '../lib';
+    }
+}
+
+use Config;
+
+BEGIN {
+    if(-d "lib" && -f "TEST") {
+        if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+              $Config{'extensions'} !~ /\bIO\b/)    &&
+              !(($^O eq 'VMS') && $Config{d_socket})) {
+            print "1..0\n";
+            exit 0;
+        }
+    }
+}
+
+$PATH = "/tmp/sock-$$";
+
+# Test if we can create the file within the tmp directory
+if (-e $PATH or not open(TEST, ">$PATH")) {
+    print "1..0\n";
+    exit 0;
+}
+close(TEST);
+unlink($PATH) or die "Can't unlink $PATH: $!";
+
+# Start testing
+$| = 1;
+print "1..5\n";
+
+use IO::Socket;
+
+$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!";
+print "ok 1\n";
+
+if($pid = fork()) {
+
+    $sock = $listen->accept();
+    print "ok 2\n";
+
+    print $sock->getline();
+
+    print $sock "ok 4\n";
+
+    $sock->close;
+
+    waitpid($pid,0);
+    unlink($PATH) || warn "Can't unlink $PATH: $!";
+
+    print "ok 5\n";
+
+} elsif(defined $pid) {
+
+    $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!";
+
+    print $sock "ok 3\n";
+
+    print $sock->getline();
+
+    $sock->close;
+
+    exit;
+} else {
+ die;
+}
index 2b6c38d..8ca22b0 100755 (executable)
@@ -11,7 +11,7 @@ $xref = \ "";
 %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';
index cea2267..7bcc196 100755 (executable)
@@ -4,7 +4,7 @@
 # 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';
@@ -692,6 +692,110 @@ print "not "
 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";
index d0886ed..195928c 100644 (file)
@@ -296,7 +296,7 @@ Useless use of times in void context at - line 13.
 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
index 93c4546..cb39d08 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -156,6 +156,12 @@ PERLVARI(Tregindent,       int,        0)  /* from regexec.c */
 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 */
@@ -163,6 +169,7 @@ PERLVARI(Tregexecp, regexec_t, FUNC_NAME_TO_PTR(regexec_flags))
                                        /* 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 *)
diff --git a/toke.c b/toke.c
index fb54cee..e91fa8c 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -6148,7 +6148,7 @@ scan_formline(register char *s)
 #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) {
index a9b41d2..087c015 100644 (file)
@@ -363,8 +363,8 @@ pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.po
 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
 
index 360bd97..e74dc68 100644 (file)
@@ -956,7 +956,7 @@ $(DUMPER_DLL): $(PERLEXE) $(DUMPER).xs
        ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\Data\$(*B) && $(MAKE)
 
-$(PEEK_DLL): $(PERLEXE) $(Peek).xs
+$(PEEK_DLL): $(PERLEXE) $(PEEK).xs
        cd $(EXTDIR)\Devel\$(*B) && \
        ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl
        cd $(EXTDIR)\Devel\$(*B) && $(MAKE)
index f17e959..e16cf8e 100644 (file)
@@ -30,6 +30,7 @@ POD = \
        perlform.pod    \
        perllocale.pod  \
        perlref.pod     \
+       perlreftut.pod  \
        perldsc.pod     \
        perllol.pod     \
        perltoot.pod    \