This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_15 to perl5.003_16]
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Tue, 24 Dec 1996 23:25:00 +0000 (11:25 +1200)
committerChip Salzenberg <chip@atlantic.net>
Tue, 24 Dec 1996 23:25:00 +0000 (11:25 +1200)
 CORE PORTABILITY

Subject: _13: patches for unicos/unicosmk
Date: Fri, 20 Dec 1996 14:38:50 -0600
From: Dean Roehrich <roehrich@cray.com>
Files: Configure MANIFEST hints/unicos.sh hints/unicosmk.sh

    private-msgid: <199612202038.OAA22805@poplar.cray.com>

 LIBRARY AND EXTENSIONS

Subject: Refresh IO to 1.14
From: Graham Barr <gbarr@ti.com>
Files: MANIFEST ext/IO/IO.xs ext/IO/README ext/IO/lib/IO/File.pm ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Pipe.pm ext/IO/lib/IO/Seekable.pm ext/IO/lib/IO/Select.pm ext/IO/lib/IO/Socket.pm t/lib/io_dup.t t/lib/io_pipe.t t/lib/io_sel.t t/lib/io_sock.t t/lib/io_tell.t t/lib/io_udp.t t/lib/io_xs.t

 OTHER CORE CHANGES

Subject: Fix 'foreach(@ARGV) { while (<>) { push @p,$_ } }'
From: Chip Salzenberg <chip@atlantic.net>
Files: cop.h pp_hot.c scope.c

Subject: Eliminate warnings from C< undef $x; $x OP= "foo" >
From: Chip Salzenberg <chip@atlantic.net>
Files: doop.c pp.c pp.h pp_hot.c

Subject: Try again to improve method caching
Date: Mon, 23 Dec 1996 20:13:56 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: gv.c sv.c
Msg-ID: <199612240113.UAA09487@monk.mps.ohio-state.edu>

    (applied based on p5p patch as commit 81c78688fe5c3927ad37ba29de14c86e38120317)

Subject: Be more careful about 'o' magic memory management
From: Chip Salzenberg <chip@atlantic.net>
Files: mg.c sv.c

Subject: Fix bad pointer refs when localized object loses magic
From: Chip Salzenberg <chip@atlantic.net>
Files: scope.c

34 files changed:
Changes
Configure
MANIFEST
cop.h
doop.c
ext/IO/IO.xs
ext/IO/README [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/Seekable.pm
ext/IO/lib/IO/Select.pm
ext/IO/lib/IO/Socket.pm
gv.c
hints/unicos.sh
hints/unicosmk.sh [new file with mode: 0644]
hv.c
lib/strict.pm
mg.c
patchlevel.h
pod/perlnews.pod
pp.c
pp.h
pp_hot.c
proto.h
scope.c
sv.c
t/lib/io_dup.t
t/lib/io_pipe.t
t/lib/io_sel.t
t/lib/io_sock.t
t/lib/io_tell.t
t/lib/io_udp.t
t/lib/io_xs.t

diff --git a/Changes b/Changes
index 450c444..856a5b5 100644 (file)
--- a/Changes
+++ b/Changes
@@ -9,6 +9,95 @@ releases.)
 
 
 ----------------
+Version 5.003_16
+----------------
+
+This patch is all bug fixes, library updates, and documentation
+updates.  We'll get to 5.004 RSN, I promise.  :-)
+
+ CORE LANGUAGE CHANGES
+
+  Title:  "Fix closures that are not in subroutines"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  op.c
+
+ CORE PORTABILITY
+
+  Title:  "_13: patches for unicos/unicosmk"
+   From:  Dean Roehrich <roehrich@cray.com>
+ Msg-ID:  <199612202038.OAA22805@poplar.cray.com>
+   Date:  Fri, 20 Dec 1996 14:38:50 -0600
+  Files:  Configure MANIFEST hints/unicos.sh hints/unicosmk.sh
+
+ OTHER CORE CHANGES
+
+  Title:  "Fix 'foreach(@ARGV) { while (<>) { push @p,$_ } }'"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  cop.h pp_hot.c scope.c
+
+  Title:  "Eliminate warnings from C< undef $x; $x OP= "foo" >"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  doop.c pp.c pp.h pp_hot.c
+
+  Title:  "Try again to improve method caching"
+   From:  Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID:  <199612240113.UAA09487@monk.mps.ohio-state.edu>
+   Date:  Mon, 23 Dec 1996 20:13:56 -0500 (EST)
+  Files:  gv.c sv.c
+
+  Title:  "Be more careful about 'o' magic memory management"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  mg.c sv.c
+
+  Title:  "Fix bad pointer refs when localized object loses magic"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  scope.c
+
+ LIBRARY AND EXTENSIONS
+
+  Title:  "Refresh CPAN to 1.09"
+   From:  Andreas Koenig
+  Files:  lib/CPAN.pm
+
+  Title:  "Refresh Net::Ping to 2.02"
+   From:  Russell Mosemann <mose@ccsn.edu>
+  Files:  lib/Net/Ping.pm
+
+  Title:  "Refresh IO to 1.14"
+   From:  Graham Barr
+  Files:  MANIFEST ext/IO/IO.xs ext/IO/README ext/IO/lib/IO/File.pm
+          ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Pipe.pm
+          ext/IO/lib/IO/Seekable.pm ext/IO/lib/IO/Select.pm
+          ext/IO/lib/IO/Socket.pm t/lib/io_dup.t t/lib/io_pipe.t
+          t/lib/io_sel.t t/lib/io_sock.t t/lib/io_tell.t
+          t/lib/io_udp.t t/lib/io_xs.t
+
+ BUILD PROCESS AND UTILITIES
+
+  Title:  "Don't recurse into subdirs twice on 'make realclean'"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  Makefile.SH
+
+  Title:  "Use root EXTERN.h when compiling x2p/malloc.c."
+   From:  Paul Marquess
+  Files:  x2p/Makefile.SH
+
+  Title:  "Fix compilation errors when malloc.c used for x2p"
+   From:  Robin Barker <rmb@cise.npl.co.uk>
+  Files:  malloc.c
+
+ DOCUMENTATION
+
+  Title:  "Edit INSTALL to describe new binary compat setup"
+   From:  Chip Salzenberg <chip@atlantic.net>
+  Files:  INSTALL
+
+  Title:  "Update to perllocale.pod"
+   From:  Jarkko Hietaniemi <jhi@cc.hut.fi>
+  Files:  pod/perllocale.pod
+
+
+----------------
 Version 5.003_15
 ----------------
 
index c5fe4a4..3ae746c 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -1644,6 +1644,7 @@ EOM
        $test -f /dnix && osname=dnix
        $test -f /lynx.os && osname=lynxos
        $test -f /unicos && osname=unicos && osvers=`$uname -r`
+       $test -f /unicosmk.ar && osname=unicosmk && osvers=`$uname -r`
        $test -f /bin/mips && /bin/mips && osname=mips
        $test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | \
                $sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4
index d256010..025bb2c 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -108,6 +108,7 @@ ext/GDBM_File/typemap               GDBM extension interface types
 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
@@ -257,6 +258,7 @@ hints/titanos.sh    Hints for named architecture
 hints/ultrix_4.sh      Hints for named architecture
 hints/umips.sh         Hints for named architecture
 hints/unicos.sh                Hints for named architecture
+hints/unicosmk.sh      Hints for named architecture
 hints/unisysdynix.sh   Hints for named architecture
 hints/utekv.sh         Hints for named architecture
 hints/uts.sh           Hints for named architecture
@@ -601,6 +603,7 @@ t/lib/getopt.t              See if Getopt::Std and Getopt::Long works
 t/lib/hostname.t       See if Sys::Hostname works
 t/lib/io_dup.t         See if dup()-related methods from IO work
 t/lib/io_pipe.t                See if pipe()-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
diff --git a/cop.h b/cop.h
index c062dc6..543c039 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -105,13 +105,16 @@ struct block_loop {
        cx->blk_loop.next_op = cLOOP->op_nextop;                        \
        cx->blk_loop.last_op = cLOOP->op_lastop;                        \
        cx->blk_loop.iterlval = Nullsv;                                 \
-       cx->blk_loop.itervar = ivar;                                    \
-       if (ivar)                                                       \
-           cx->blk_loop.itersave = *cx->blk_loop.itervar;
+       if (cx->blk_loop.itervar = (ivar))                              \
+           cx->blk_loop.itersave = SvREFCNT_inc(*cx->blk_loop.itervar);
 
 #define POPLOOP(cx)                                                    \
        newsp           = stack_base + cx->blk_loop.resetsp;            \
-       SvREFCNT_dec(cx->blk_loop.iterlval)
+       SvREFCNT_dec(cx->blk_loop.iterlval);                            \
+       if (cx->blk_loop.itervar) {                                     \
+           SvREFCNT_dec(*cx->blk_loop.itervar);                        \
+           *cx->blk_loop.itervar = cx->blk_loop.itersave;              \
+       }
 
 /* context common to subroutines, evals and loops */
 struct block {
diff --git a/doop.c b/doop.c
index 836027e..33726bf 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -528,16 +528,20 @@ SV *right;
     register char *dc;
     STRLEN leftlen;
     STRLEN rightlen;
-    register char *lc = SvPV(left, leftlen);
-    register char *rc = SvPV(right, rightlen);
+    register char *lc;
+    register char *rc;
     register I32 len;
     I32 lensave;
-    char *lsave = lc;
-    char *rsave = rc;
+    char *lsave;
+    char *rsave;
 
+    if (sv == left && !SvOK(sv) && !SvGMAGICAL(sv) && SvTYPE(sv) <= SVt_PVMG)
+       sv_setpvn(sv, "", 0);   /* avoid warning on &= etc. */
+    lsave = lc = SvPV(left, leftlen);
+    rsave = rc = SvPV(right, rightlen);
     len = leftlen < rightlen ? leftlen : rightlen;
     lensave = len;
-    if (SvOK(sv)) {
+    if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
        dc = SvPV_force(sv, na);
        if (SvCUR(sv) < len) {
            dc = SvGROW(sv, len + 1);
index 3cc3518..a6eb075 100644 (file)
@@ -203,6 +203,7 @@ int
 untaint(handle)
        SV *    handle
     CODE:
+#ifdef IOf_UNTAINT
        IO * io;
        io = sv_2io(handle);
        if (io) {
@@ -210,9 +211,12 @@ untaint(handle)
            RETVAL = 0;
        }
         else {
+#endif
            RETVAL = -1;
            errno = EINVAL;
+#ifdef IOf_UNTAINT
        }
+#endif
     OUTPUT:
        RETVAL
 
diff --git a/ext/IO/README b/ext/IO/README
new file mode 100644 (file)
index 0000000..e855afa
--- /dev/null
@@ -0,0 +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
+any files in this directory then please forward him a patch for only
+the files in this directory.
index 81d48b1..e44d77f 100644 (file)
@@ -1,3 +1,5 @@
+#
+
 package IO::File;
 
 =head1 NAME
@@ -91,14 +93,11 @@ L<IO::Seekable>
 
 Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>.
 
-=head1 REVISION
-
-$Revision: 1.5 $
-
 =cut
 
 require 5.000;
-use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
+use strict;
+use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
 use Carp;
 use Symbol;
 use SelectSaver;
@@ -110,7 +109,7 @@ require DynaLoader;
 
 @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
 
-$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.06";
 
 @EXPORT = @IO::Seekable::EXPORT;
 
index 7b8c709..59741c1 100644 (file)
@@ -180,12 +180,11 @@ class from C<IO::Handle> and inherit those methods.
 
 Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
 
-Version 1.1201 specialized from 1.12 for inclusion in Perl distribution
-
 =cut
 
 require 5.000;
-use vars qw($RCS $VERSION @EXPORT_OK $AUTOLOAD);
+use strict;
+use vars qw($VERSION @EXPORT_OK $AUTOLOAD @ISA);
 use Carp;
 use Symbol;
 use SelectSaver;
@@ -193,8 +192,7 @@ use SelectSaver;
 require Exporter;
 @ISA = qw(Exporter);
 
-$VERSION = "1.1201";
-$RCS = sprintf("%s", q$Revision: 1.15 $ =~ /([\d\.]+)/);
+$VERSION = "1.14";
 
 @EXPORT_OK = qw(
     autoflush
@@ -244,6 +242,7 @@ sub 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;
 }
@@ -270,16 +269,23 @@ sub new_from_fd {
     bless $fh, $class;
 }
 
-#
-# That an IO::Handle is being destroyed does not necessarily mean
-# that the associated filehandle should be closed.  This is because
-# *FOO{FILEHANDLE} may by a synonym for *BAR{FILEHANDLE}.
-#
-# If this IO::Handle really does have the final reference to the
-# given FILEHANDLE, then Perl will close it for us automatically.
-#
-
 sub DESTROY {
+    my ($fh) = @_;
+
+    # During global object destruction, this function may be called
+    # on FILEHANDLEs as well as on the GLOBs that contains them.
+    # Thus the following trickery.  If only the CORE file operators
+    # could deal with FILEHANDLEs, it wouldn't be necessary...
+
+    if ($fh =~ /=FILEHANDLE\(/) {
+       local *TMP = $fh;
+       close(TMP)
+           if defined fileno(TMP);
+    }
+    else {
+       close($fh)
+           if defined fileno($fh);
+    }
 }
 
 ################################################
index 9ec8b64..34cb0da 100644 (file)
@@ -4,7 +4,7 @@ package IO::Pipe;
 
 =head1 NAME
 
-IO::Pipe - supply object methods for pipes
+IO::pipe - supply object methods for pipes
 
 =head1 SYNOPSIS
 
@@ -89,11 +89,7 @@ L<IO::Handle>
 
 =head1 AUTHOR
 
-Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
-
-=head1 REVISION
-
-$Revision: 1.7 $
+Graham Barr <bodg@tiuk.ti.com>
 
 =head1 COPYRIGHT
 
@@ -104,12 +100,13 @@ as Perl itself.
 =cut
 
 require 5.000;
+use     strict;
 use    vars qw($VERSION);
 use    Carp;
 use    Symbol;
 require IO::Handle;
 
-$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.08";
 
 sub new {
     my $type = shift;
@@ -165,9 +162,10 @@ sub reader {
     my $pid = $me->_doit(0,@_)
        if(@_);
 
+    close(${*$me}[1]);
     bless $me, ref($fh);
-    *{*$me} = *{*$fh};         # Alias self to handle
-    bless $fh;                 # Really wan't un-bless here
+    *{*$me} = *{*$fh};                 # Alias self to handle
+    bless $fh, 'IO::Pipe::DeadEnd';    # Really wan't un-bless here
     ${*$me}{'io_pipe_pid'} = $pid
        if defined $pid;
 
@@ -181,9 +179,10 @@ sub writer {
     my $pid = $me->_doit(1,@_)
        if(@_);
 
+    close(${*$me}[0]);
     bless $me, ref($fh);
-    *{*$me} = *{*$fh};         # Alias self to handle
-    bless $fh;                 # Really wan't un-bless here
+    *{*$me} = *{*$fh};                 # Alias self to handle
+    bless $fh, 'IO::Pipe::DeadEnd';    # Really wan't un-bless here
     ${*$me}{'io_pipe_pid'} = $pid
        if defined $pid;
 
index 8e0f87a..e8a9530 100644 (file)
@@ -42,14 +42,11 @@ L<IO::File>
 
 Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt>
 
-=head1 REVISION
-
-$Revision: 1.5 $
-
 =cut
 
 require 5.000;
 use Carp;
+use strict;
 use vars qw($VERSION @EXPORT @ISA);
 use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
 require Exporter;
@@ -57,7 +54,7 @@ require Exporter;
 @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
 @ISA = qw(Exporter);
 
-$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.06";
 
 sub clearerr {
     @_ == 1 or croak 'usage: $fh->clearerr()';
index 845d6b2..dea684a 100644 (file)
@@ -1,4 +1,8 @@
 # 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.
 
 package IO::Select;
 
@@ -47,17 +51,30 @@ 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 then the call will block.
+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 ] )
 
@@ -65,8 +82,8 @@ 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.
+Same as C<can_read> except check for handles that have an error
+condition, for example EOF.
 
 =item count ()
 
@@ -74,12 +91,20 @@ 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
-before.
+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
@@ -120,10 +145,6 @@ listening for more connections on a listen socket
 
 Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
 
-=head1 REVISION
-
-$Revision: 1.9 $
-
 =head1 COPYRIGHT
 
 Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
@@ -136,13 +157,13 @@ use     strict;
 use     vars qw($VERSION @ISA);
 require Exporter;
 
-$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.10";
 
 @ISA = qw(Exporter); # This is only so we can do version checking
 
-sub VEC_BITS {0}
-sub FD_COUNT {1}
-sub FIRST_FD {2}
+sub VEC_BITS () {0}
+sub FD_COUNT () {1}
+sub FIRST_FD () {2}
 
 sub new
 {
@@ -159,39 +180,63 @@ sub new
 
 sub add
 {
+ shift->_update('add', @_);
+}
+
+
+sub remove
+{
+ shift->_update('remove', @_);
+}
+
+
+sub exists
+{
  my $vec = shift;
- my $f;
+ $vec->[$vec->_fileno(shift) + FIRST_FD];
+}
 
- $vec->[VEC_BITS] = '' unless defined $vec->[VEC_BITS];
 
- foreach $f (@_)
-  {
-   my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
-   next
-    unless defined $fn;
-   vec($vec->[VEC_BITS],$fn,1) = 1;
-   $vec->[FD_COUNT] += 1
-       unless defined $vec->[$fn+FIRST_FD];
-   $vec->[$fn+FIRST_FD] = $f;
-  }
- $vec->[VEC_BITS] = undef unless $vec->count;
+sub _fileno
+{
+ my($self, $f) = @_;
+ $f = $f->[0] if ref($f) eq 'ARRAY';
+ ($f =~ /^\d+$/) ? $f : fileno($f);
 }
 
-sub remove
+sub _update
 {
  my $vec = shift;
- my $f;
+ my $add = shift eq 'add';
 
+ my $bits = $vec->[VEC_BITS];
+ $bits = '' unless defined $bits;
+
+ my $count = 0;
+ my $f;
  foreach $f (@_)
   {
-   my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
-   next
-    unless defined $fn;
-   vec($vec->[VEC_BITS],$fn,1) = 0;
-   $vec->[$fn+FIRST_FD] = undef;
-   $vec->[FD_COUNT] -= 1;
+   my $fn = $vec->_fileno($f);
+   next unless defined $fn;
+   my $i = $fn + FIRST_FD;
+   if ($add) {
+     if (defined $vec->[$i]) {
+        $vec->[$i] = $f;  # if array rest might be different, so we update
+        next;
+     }
+     $vec->[FD_COUNT]++;
+     vec($bits, $fn, 1) = 1;
+     $vec->[$i] = $f;
+   } else {      # remove
+     next unless defined $vec->[$i];
+     $vec->[FD_COUNT]--;
+     vec($bits, $fn, 1) = 0;
+     $vec->[$i] = undef;
+   }
+   $count++;
   }
- $vec->[VEC_BITS] = undef unless $vec->count;
+ $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
+ $count;
 }
 
 sub can_read
@@ -201,7 +246,7 @@ sub can_read
  my $r = $vec->[VEC_BITS];
 
  defined($r) && (select($r,undef,undef,$timeout) > 0)
-    ? _handles($vec, $r)
+    ? handles($vec, $r)
     : ();
 }
 
@@ -212,7 +257,7 @@ sub can_write
  my $w = $vec->[VEC_BITS];
 
  defined($w) && (select(undef,$w,undef,$timeout) > 0)
-    ? _handles($vec, $w)
+    ? handles($vec, $w)
     : ();
 }
 
@@ -223,7 +268,7 @@ sub has_error
  my $e = $vec->[VEC_BITS];
 
  defined($e) && (select(undef,undef,$e,$timeout) > 0)
-    ? _handles($vec, $e)
+    ? handles($vec, $e)
     : ();
 }
 
@@ -233,6 +278,28 @@ sub count
  $vec->[FD_COUNT];
 }
 
+sub bits
+{
+ my $vec = shift;
+ $vec->[VEC_BITS];
+}
+
+sub as_string  # for debugging
+{
+ my $vec = shift;
+ my $str = ref($vec) . ": ";
+ my $bits = $vec->bits;
+ my $count = $vec->count;
+ $str .= defined($bits) ? unpack("b*", $bits) : "undef";
+ $str .= " $count";
+ my @handles = @$vec;
+ splice(@handles, 0, FIRST_FD);
+ for (@handles) {
+     $str .= " " . (defined($_) ? "$_" : "-");
+ }
+ $str;
+}
+
 sub _max
 {
  my($a,$b,$c) = @_;
@@ -254,8 +321,8 @@ sub select
  my @result = ();
 
  my $rb = defined $r ? $r->[VEC_BITS] : undef;
- my $wb = defined $w ? $e->[VEC_BITS] : undef;
- my $eb = defined $e ? $w->[VEC_BITS] : undef;
+ my $wb = defined $w ? $w->[VEC_BITS] : undef;
+ my $eb = defined $e ? $e->[VEC_BITS] : undef;
 
  if(select($rb,$wb,$eb,$t) > 0)
   {
@@ -282,18 +349,20 @@ sub select
  @result;
 }
 
-sub _handles
+
+sub handles
 {
  my $vec = shift;
  my $bits = shift;
  my @h = ();
  my $i;
+ my $max = scalar(@$vec) - 1;
 
- for($i = scalar(@$vec) - 1 ; $i >= FIRST_FD ; $i--)
+ for ($i = FIRST_FD; $i <= $max; $i++)
   {
    next unless defined $vec->[$i];
    push(@h, $vec->[$i])
-      if vec($bits,$i - FIRST_FD,1);
+      if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
   }
  
  @h;
index 94ae88a..6a69c6b 100644 (file)
@@ -20,13 +20,15 @@ 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 a C<IO::Pipe>, which is a reference to a
+Creates a 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
@@ -81,12 +83,12 @@ with one argument then getsockopt is called, otherwise setsockopt is called.
 
 =item sockdomain
 
-Returns the numerical number for the socket domain type. For example, fir
+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, fir
+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
@@ -107,14 +109,12 @@ use IO::Handle;
 use Socket 1.3;
 use Carp;
 use strict;
-use vars qw(@ISA @EXPORT_OK $VERSION);
+use vars qw(@ISA $VERSION);
 use Exporter;
 
 @ISA = qw(IO::Handle);
 
-# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...
-
-$VERSION = do{my @r=(q$Revision: 1.13 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+$VERSION = "1.15";
 
 sub import {
     my $pkg = shift;
@@ -155,12 +155,13 @@ sub configure {
     croak 'IO::Socket: Cannot configure a generic socket'
        unless defined $domain;
 
-    my $sub = ref(_domain2pkg($domain)) . "::configure";
+    my $class = ref(_domain2pkg($domain));
 
-    goto &{$sub}
-       if(defined &{$sub});
+    croak "IO::Socket: Cannot configure socket in domain '$domain'"
+       unless ref($fh) eq "IO::Socket";
 
-    croak "IO::Socket: Cannot configure socket in domain '$domain' $sub";
+    bless($fh, $class);
+    $fh->configure;
 }
 
 sub socket {
@@ -366,27 +367,6 @@ sub protocol {
     ${*$fh}{'io_socket_protocol'};
 }
 
-sub _addmethod {
-    my $self = shift;
-    my $name;
-
-    foreach $name (@_) {
-       my $n = $name;
-
-       no strict qw(refs);
-
-       *{$n} = sub { 
-                   my $pkg = ref(${*{$_[0]}}{'io_socket_domain'});
-                   my $sub = "${pkg}::${n}";
-                   goto &{$sub} if defined &{$sub};
-                   croak qq{Can't locate object method "$n" via package "$pkg"};
-               }
-               unless defined &{$n};
-    }
-
-}
-
-
 =head1 SUB-CLASSES
 
 =cut
@@ -398,14 +378,13 @@ sub _addmethod {
 package IO::Socket::INET;
 
 use strict;
-use vars qw(@ISA $VERSION);
+use vars qw(@ISA);
 use Socket;
 use Carp;
 use Exporter;
 
 @ISA = qw(IO::Socket);
 
-IO::Socket::INET->_addmethod( qw(sockaddr sockport sockhost peeraddr peerport peerhost));
 IO::Socket::INET->register_domain( AF_INET );
 
 my %socket_type = ( tcp => SOCK_STREAM,
@@ -417,22 +396,45 @@ my %socket_type = ( tcp => SOCK_STREAM,
 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
-    PeerPort   Remote port or service
-    LocalPort  Local host bind port
-    LocalAddr  Local host bind address
-    Proto      Protocol name (eg tcp udp etc)
-    Type       Socket type (SOCK_STREAM etc)
+    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                   "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
 
 
-If Listen is defined then a listen socket is created, else if the socket
-type,   which is derived from the protocol, is SOCK_STREAM then a connect
-is called.
+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 ":".
+
+Only one of C<Type> or C<Proto> needs to be specified, one will be
+assumed from the other.  If you specify a symbolic C<PeerPort> port,
+then the constructor will try to derive C<Type> and C<Proto> from
+the service name.
 
-Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
-from the other.
+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');
 
 =head2 METHODS
 
@@ -469,7 +471,6 @@ peer host in a text form xx.xx.xx.xx
 
 =cut
 
-
 sub _sock_info {
   my($addr,$port,$proto) = @_;
   my @proto = ();
@@ -508,7 +509,8 @@ sub _sock_info {
 
 sub _error {
     my $fh = shift;
-    carp join("",ref($fh),": ",@_) if @_;
+    $@ = join("",ref($fh),": ",@_);
+    carp $@ if $^W;
     close($fh)
        if(defined fileno($fh));
     return undef;
@@ -551,14 +553,19 @@ sub configure {
     ${*$fh}{'io_socket_domain'} = bless \$domain;
 
     $fh->socket(AF_INET, $type, $proto) or
-       return _error($fh);
+       return _error($fh,"$!");
+
+    if ($arg->{Reuse}) {
+       $fh->sockopt(SO_REUSEADDR,1) or
+               return _error($fh);
+    }
 
     $fh->bind($lport || 0, $laddr) or
-       return _error($fh);
+       return _error($fh,"$!");
 
     if(exists $arg->{Listen}) {
        $fh->listen($arg->{Listen} || 5) or
-           return _error($fh);
+           return _error($fh,"$!");
     }
     else {
        return _error($fh,'Cannot determine remote port')
@@ -569,7 +576,7 @@ sub configure {
                unless(defined $raddr);
 
            $fh->connect($rport,$raddr) or
-               return _error($fh);
+               return _error($fh,"$!");
        }
     }
 
@@ -626,7 +633,6 @@ use Exporter;
 
 @ISA = qw(IO::Socket);
 
-IO::Socket::UNIX->_addmethod(qw(hostpath peerpath));
 IO::Socket::UNIX->register_domain( AF_UNIX );
 
 =head2 IO::Socket::UNIX
@@ -645,11 +651,11 @@ and some related methods. The constructor can take the following options
 
 =item hostpath()
 
-Returns the pathname to the fifo at the local end.
+Returns the pathname to the fifo at the local end
 
 =item peerpath()
 
-Returns the pathanme to the fifo at the peer end.
+Returns the pathanme to the fifo at the peer end
 
 =back
 
@@ -688,32 +694,22 @@ sub configure {
 sub hostpath {
     @_ == 1 or croak 'usage: $fh->hostpath()';
     my $n = $_[0]->sockname || return undef;
-warn length($n);
     (sockaddr_un($n))[0];
 }
 
 sub peerpath {
     @_ == 1 or croak 'usage: $fh->peerpath()';
     my $n = $_[0]->peername || return undef;
-warn length($n);
-my @n = sockaddr_un($n);
-warn join(",",@n);
     (sockaddr_un($n))[0];
 }
 
-=head1 AUTHOR
-
-Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+=head1 SEE ALSO
 
-=head1 REVISION
+L<Socket>, L<IO::Handle>
 
-$Revision: 1.13 $
-
-The VERSION is derived from the revision turning each number after the
-first dot into a 2 digit number so
+=head1 AUTHOR
 
-       Revision 1.8   => VERSION 1.08
-       Revision 1.2.3 => VERSION 1.0203
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
 
 =head1 COPYRIGHT
 
diff --git a/gv.c b/gv.c
index fed7eca..6dd8ad0 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -143,19 +143,20 @@ I32 level;
     if (SvTYPE(topgv) != SVt_PVGV)
        gv_init(topgv, stash, name, len, TRUE);
 
-    if (cv=GvCV(topgv)) {
-       if (GvCVGEN(topgv) >= sub_generation)
-           return topgv;       /* valid cached inheritance */
-       if (!GvCVGEN(topgv)) {  /* not an inheritance cache */
-           return topgv;
-       }
-       else {
-           /* stale cached entry, just junk it */
-           GvCV(topgv) = cv = 0;
-           GvCVGEN(topgv) = 0;
+    if (cv = GvCV(topgv)) {
+       if (CvXSUB(cv) || CvROOT(cv) || CvGV(cv)) { /* Not deleted, possibly autoloaded. */
+           if (GvCVGEN(topgv) >= sub_generation)
+               return topgv;   /* valid cached inheritance */
+           if (!GvCVGEN(topgv)) {      /* not an inheritance cache */
+               return topgv;
+           }
        }
+       /* stale cached entry, just junk it */
+       SvREFCNT_dec(cv);
+       GvCV(topgv) = cv = 0;
+       GvCVGEN(topgv) = 0;
     }
-    /* if cv is still set, we have to free it if we find something to cache */
+    /* Now cv = 0, and there is no cv in topgv. */
 
     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
     if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
@@ -172,13 +173,9 @@ I32 level;
            }
            gv = gv_fetchmeth(basestash, name, len, level + 1);
            if (gv) {
-               if (cv) {                               /* junk old undef */
-                   assert(SvREFCNT(topgv) > 1);
-                   SvREFCNT_dec(topgv);
-                   SvREFCNT_dec(cv);
-               }
                GvCV(topgv) = GvCV(gv);                 /* cache the CV */
                GvCVGEN(topgv) = sub_generation;        /* valid for now */
+               SvREFCNT_inc(GvCV(gv));
                return gv;
            }
        }
@@ -187,13 +184,9 @@ I32 level;
     if (!level) {
        if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
            if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
-               if (cv) {                               /* junk old undef */
-                   assert(SvREFCNT(topgv) > 1);
-                   SvREFCNT_dec(topgv);
-                   SvREFCNT_dec(cv);
-               }
                GvCV(topgv) = GvCV(gv);                 /* cache the CV */
                GvCVGEN(topgv) = sub_generation;        /* valid for now */
+               SvREFCNT_inc(GvCV(gv));
                return gv;
            }
        }
index 272cb9b..b864019 100644 (file)
@@ -1,9 +1,7 @@
 case `uname -r` in
 6.1*) shellflags="-m+65536" ;;
 esac
-ccflags="$ccflags -DHZ=__hertz"
 optimize="-O1"
-libswanted=m
 d_setregid='undef'
 d_setreuid='undef'
 
diff --git a/hints/unicosmk.sh b/hints/unicosmk.sh
new file mode 100644 (file)
index 0000000..90784b5
--- /dev/null
@@ -0,0 +1,3 @@
+optimize="-O1"
+d_setregid='undef'
+d_setreuid='undef'
diff --git a/hv.c b/hv.c
index 806e573..3208b56 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -752,7 +752,7 @@ I32 shared;
 {
     if (!hent)
        return;
-    if (SvTYPE(HeVAL(hent)) == SVt_PVGV)
+    if (SvTYPE(HeVAL(hent)) == SVt_PVGV && GvCV(HeVAL(hent)))
        sub_generation++;               /* May be deletion of method? */
     SvREFCNT_dec(HeVAL(hent));
     if (HeKLEN(hent) == HEf_SVKEY) {
index e261e92..8492e93 100644 (file)
@@ -74,10 +74,11 @@ See L<perlmod/Pragmatic Modules>.
 
 sub bits {
     my $bits = 0;
+    my $sememe;
     foreach $sememe (@_) {
-       $bits |= 0x00000002 if $sememe eq 'refs';
-       $bits |= 0x00000200 if $sememe eq 'subs';
-       $bits |= 0x00000400 if $sememe eq 'vars';
+       $bits |= 0x00000002, next if $sememe eq 'refs';
+       $bits |= 0x00000200, next if $sememe eq 'subs';
+       $bits |= 0x00000400, next if $sememe eq 'vars';
     }
     $bits;
 }
diff --git a/mg.c b/mg.c
index 0225ca4..cffad0e 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1200,6 +1200,7 @@ MAGIC* mg;
     return 0;
 }
 
+#ifdef USE_LOCALE_COLLATE
 int
 magic_setcollxfrm(sv,mg)
 SV* sv;
@@ -1209,9 +1210,14 @@ MAGIC* mg;
      * RenĂ© Descartes said "I think not."
      * and vanished with a faint plop.
      */
-    sv_unmagic(sv, 'o');
+    if (mg->mg_ptr) {
+       Safefree(mg->mg_ptr);
+       mg->mg_ptr = NULL;
+       mg->mg_len = -1;
+    }
     return 0;
 }
+#endif /* USE_LOCALE_COLLATE */
 
 int
 magic_set(sv,mg)
index 07c9884..644f47c 100644 (file)
@@ -1,5 +1,5 @@
 #define PATCHLEVEL 3
-#define SUBVERSION 15
+#define SUBVERSION 16
 
 /*
        local_patches -- list of locally applied less-than-subversion patches.
index a624b21..0af4e4e 100644 (file)
@@ -359,6 +359,8 @@ Brand new modules:
     User/grent.pm        Object-oriented wrapper around CORE::getgr*
     User/pwent.pm        Object-oriented wrapper around CORE::getpw*
 
+    lib/Tie/RefHash.pm   Base class for tied hashes with references as keys
+
     UNIVERSAL.pm         Base class for *ALL* classes
 
 =head2 IO
@@ -643,5 +645,4 @@ Constructed by Tom Christiansen, grabbing material with permission
 from innumerable contributors, with kibitzing by more than a few Perl
 porters.
 
-Last update:
-Wed Dec 18 16:18:27 EST 1996
+Last update: Tue Dec 24 16:45:14 EST 1996
diff --git a/pp.c b/pp.c
index b07a54b..e071ee3 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -619,7 +619,7 @@ PP(pp_pow)
 {
     dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); 
     {
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_ul;
       SETn( pow( left, right) );
       RETURN;
     }
@@ -629,7 +629,7 @@ PP(pp_multiply)
 {
     dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 
     {
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_ul;
       SETn( left * right );
       RETURN;
     }
@@ -639,25 +639,24 @@ PP(pp_divide)
 {
     dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 
     {
-      dPOPnv;
-      if (value == 0.0)
+      dPOPPOPnnrl_ul;
+      double value;
+      if (right == 0.0)
        DIE("Illegal division by zero");
 #ifdef SLOPPYDIVIDE
       /* insure that 20./5. == 4. */
       {
-       double x;
-       I32    k;
-       x =  POPn;
-       if ((double)I_32(x)     == x &&
-           (double)I_32(value) == value &&
-           (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) {
+       IV k;
+       if ((double)I_V(left)  == left &&
+           (double)I_V(right) == right &&
+           (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
            value = k;
        } else {
-           value = x/value;
+           value = left / right;
        }
       }
 #else
-      value = POPn / value;
+      value = left / right;
 #endif
       PUSHn( value );
       RETURN;
@@ -682,7 +681,7 @@ PP(pp_modulo)
          SETi( left % right );
       }
       else {
-       register double left = TOPn;
+       register double left = USE_LEFT(TOPs) ? SvNV(TOPs) : 0.0;
        if (left < 0.0)
          SETu( (right - (U_V(-left) - 1) % right) - 1 );
        else
@@ -729,14 +728,19 @@ PP(pp_repeat)
            if (SvROK(tmpstr))
                sv_unref(tmpstr);
        }
-       SvSetSV(TARG, tmpstr);
-       SvPV_force(TARG, len);
-       if (count >= 1) {
-           SvGROW(TARG, (count * len) + 1);
-           if (count > 1)
-               repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
-           SvCUR(TARG) *= count;
-           *SvEND(TARG) = '\0';
+       if (USE_LEFT(tmpstr) || SvTYPE(tmpstr) > SVt_PVMG) {
+           SvSetSV(TARG, tmpstr);
+           SvPV_force(TARG, len);
+           if (count != 1) {
+               if (count < 1)
+                   SvCUR_set(TARG, 0);
+               else {
+                   SvGROW(TARG, (count * len) + 1);
+                   repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
+                   SvCUR(TARG) *= count;
+               }
+               *SvEND(TARG) = '\0';
+           }
            (void)SvPOK_only(TARG);
        }
        else
@@ -751,7 +755,7 @@ PP(pp_subtract)
 {
     dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); 
     {
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_ul;
       SETn( left - right );
       RETURN;
     }
diff --git a/pp.h b/pp.h
index 56cd26c..ea1fd39 100644 (file)
--- a/pp.h
+++ b/pp.h
 #define dTOPuv         UV value = TOPu
 #define dPOPuv         UV value = POPu
 
-#define dPOPPOPssrl    SV *right = POPs; SV *left = POPs
-#define dPOPPOPnnrl    double right = POPn; double left = POPn
-#define dPOPPOPiirl    IV right = POPi; IV left = POPi
-
-#define dPOPTOPssrl    SV *right = POPs; SV *left = TOPs
-#define dPOPTOPnnrl    double right = POPn; double left = TOPn
-#define dPOPTOPiirl    IV right = POPi; IV left = TOPi
+#define dPOPXssrl(X)   SV *right = POPs; SV *left = CAT2(X,s)
+#define dPOPXnnrl(X)   double right = POPn; double left = CAT2(X,n)
+#define dPOPXiirl(X)   IV right = POPi; IV left = CAT2(X,i)
+
+#define USE_LEFT(sv) \
+       (SvOK(sv) || SvGMAGICAL(sv) || !(op->op_flags & OPf_STACKED))
+#define dPOPXnnrl_ul(X)        \
+    double right = POPn;                               \
+    SV *leftsv = CAT2(X,s);                            \
+    double left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0
+#define dPOPXiirl_ul(X) \
+    IV right = POPi;                                   \
+    SV *leftsv = CAT2(X,s);                            \
+    IV left = USE_LEFT(leftsv) ? SvIV(leftsv) : 0
+
+#define dPOPPOPssrl    dPOPXssrl(POP)
+#define dPOPPOPnnrl    dPOPXnnrl(POP)
+#define dPOPPOPnnrl_ul dPOPXnnrl_ul(POP)
+#define dPOPPOPiirl    dPOPXiirl(POP)
+#define dPOPPOPiirl_ul dPOPXiirl_ul(POP)
+
+#define dPOPTOPssrl    dPOPXssrl(TOP)
+#define dPOPTOPnnrl    dPOPXnnrl(TOP)
+#define dPOPTOPnnrl_ul dPOPXnnrl_ul(TOP)
+#define dPOPTOPiirl    dPOPXiirl(TOP)
+#define dPOPTOPiirl_ul dPOPXiirl_ul(TOP)
 
 #define RETPUSHYES     RETURNX(PUSHs(&sv_yes))
 #define RETPUSHNO      RETURNX(PUSHs(&sv_no))
index ba49535..41ad9f4 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -199,9 +199,9 @@ PP(pp_concat)
     }
     else if (SvGMAGICAL(TARG))
        mg_get(TARG);
-    else if (!SvOK(TARG)) {
-       s = SvPV_force(TARG, len);
+    else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
        sv_setpv(TARG, "");     /* Suppress warning. */
+       s = SvPV_force(TARG, len);
     }
     s = SvPV(right,len);
     sv_catpvn(TARG,s,len);
@@ -269,7 +269,7 @@ PP(pp_add)
 {
     dSP; dATARGET; tryAMAGICbin(add,opASSIGN); 
     {
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_ul;
       SETn( left + right );
       RETURN;
     }
@@ -1311,6 +1311,8 @@ PP(pp_iter)
     if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av)))
        RETPUSHNO;
 
+    SvREFCNT_dec(*cx->blk_loop.itervar);
+
     if (sv = AvARRAY(av)[++cx->blk_loop.iterix])
        SvTEMP_off(sv);
     else
@@ -1334,7 +1336,8 @@ PP(pp_iter)
        LvTARGLEN(lv) = 1;
        sv = (SV*)lv;
     }
-    *cx->blk_loop.itervar = sv;
+
+    *cx->blk_loop.itervar = SvREFCNT_inc(sv);
     RETPUSHYES;
 }
 
diff --git a/proto.h b/proto.h
index fe06b48..c762d38 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -64,8 +64,7 @@ void  debprofdump _((void));
 #endif
 I32    debstack _((void));
 void   deprecate _((char* s));
-OP*    die _((const char* pat,...))
-               __attribute__((format(printf,1,2),noreturn));
+OP*    die _((const char* pat,...)) __attribute__((format(printf,1,2)));
 OP*    die_where _((char* message));
 void   dounwind _((I32 cxix));
 bool   do_aexec _((SV* really, SV** mark, SV** sp));
diff --git a/scope.c b/scope.c
index afdcf44..2fdea90 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -107,19 +107,14 @@ free_tmps()
     }
 }
 
-SV *
-save_scalar(gv)
-GV *gv;
+static SV *
+save_scalar_at(sptr)
+SV **sptr;
 {
     register SV *sv;
-    SV *osv = GvSV(gv);
-
-    SSCHECK(3);
-    SSPUSHPTR(gv);
-    SSPUSHPTR(osv);
-    SSPUSHINT(SAVEt_SV);
+    SV *osv = *sptr;
 
-    sv = GvSV(gv) = NEWSV(0,0);
+    sv = *sptr = NEWSV(0,0);
     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
        sv_upgrade(sv, SvTYPE(osv));
        if (SvGMAGICAL(osv)) {
@@ -143,6 +138,28 @@ GV *gv;
     return sv;
 }
 
+SV *
+save_scalar(gv)
+GV *gv;
+{
+    SSCHECK(3);
+    SSPUSHPTR(gv);
+    SSPUSHPTR(GvSV(gv));
+    SSPUSHINT(SAVEt_SV);
+    return save_scalar_at(&GvSV(gv));
+}
+
+SV*
+save_svref(sptr)
+SV **sptr;
+{
+    SSCHECK(3);
+    SSPUSHPTR(sptr);
+    SSPUSHPTR(*sptr);
+    SSPUSHINT(SAVEt_SVREF);
+    return save_scalar_at(sptr);
+}
+
 void
 save_gp(gv, empty)
 GV *gv;
@@ -168,42 +185,6 @@ I32 empty;
     }
 }
 
-SV*
-save_svref(sptr)
-SV **sptr;
-{
-    register SV *sv;
-    SV *osv = *sptr;
-
-    SSCHECK(3);
-    SSPUSHPTR(*sptr);
-    SSPUSHPTR(sptr);
-    SSPUSHINT(SAVEt_SVREF);
-
-    sv = *sptr = NEWSV(0,0);
-    if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
-       sv_upgrade(sv, SvTYPE(osv));
-       if (SvGMAGICAL(osv)) {
-           MAGIC* mg;
-           bool oldtainted = tainted;
-           mg_get(osv);
-           if (tainting && tainted && (mg = mg_find(osv, 't'))) {
-               SAVESPTR(mg->mg_obj);
-               mg->mg_obj = osv;
-           }
-           SvFLAGS(osv) |= (SvFLAGS(osv) &
-               (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
-           tainted = oldtainted;
-       }
-       SvMAGIC(sv) = SvMAGIC(osv);
-       SvFLAGS(sv) |= SvMAGICAL(osv);
-       localizing = 1;
-       SvSETMAGIC(sv);
-       localizing = 0;
-    }
-    return sv;
-}
-
 AV *
 save_ary(gv)
 GV *gv;
@@ -450,26 +431,13 @@ I32 base;
         case SAVEt_SV:                         /* scalar reference */
            value = (SV*)SSPOPPTR;
            gv = (GV*)SSPOPPTR;
-           sv = GvSV(gv);
-           if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
-               SvTYPE(sv) != SVt_PVGV)
-           {
-               (void)SvUPGRADE(value, SvTYPE(sv));
-               SvMAGIC(value) = SvMAGIC(sv);
-               SvFLAGS(value) |= SvMAGICAL(sv);
-               SvMAGICAL_off(sv);
-               SvMAGIC(sv) = 0;
-           }
-            SvREFCNT_dec(sv);
-            GvSV(gv) = value;
-           localizing = 2;
-           SvSETMAGIC(value);
-           localizing = 0;
-            break;
+           ptr = &GvSV(gv);
+           goto restore_sv;
         case SAVEt_SVREF:                      /* scalar reference */
+           value = (SV*)SSPOPPTR;
            ptr = SSPOPPTR;
+       restore_sv:
            sv = *(SV**)ptr;
-           value = (SV*)SSPOPPTR;
            if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
                SvTYPE(sv) != SVt_PVGV)
            {
@@ -479,6 +447,14 @@ I32 base;
                SvMAGICAL_off(sv);
                SvMAGIC(sv) = 0;
            }
+           else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
+                    SvTYPE(value) != SVt_PVGV)
+           {
+               SvFLAGS(value) |= (SvFLAGS(value) &
+                                  (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+               SvMAGICAL_off(value);
+               SvMAGIC(value) = 0;
+           }
             SvREFCNT_dec(sv);
            *(SV**)ptr = value;
            localizing = 2;
@@ -694,6 +670,8 @@ CONTEXT* cx;
        if (cx->blk_loop.itervar)
            PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
                (long)cx->blk_loop.itersave);
+       PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%lx\n",
+               (long)cx->blk_loop.iterlval);
        break;
 
     case CXt_SUBST:
diff --git a/sv.c b/sv.c
index 87a1a2d..817da96 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1949,11 +1949,14 @@ register SV *sstr;
                                    (CvROOT(cv) || CvXSUB(cv)) )
                                warn("Subroutine %s redefined",
                                    GvENAME((GV*)dstr));
-                           SvFAKE_on(cv);
+                           if (SvREFCNT(cv) == 1)
+                               SvFAKE_on(cv);
                        }
                    }
+                   sub_generation++;
                    if (GvCV(dstr) != (CV*)sref) {
                        GvCV(dstr) = (CV*)sref;
+                       GvCVGEN(dstr) = 0; /* Switch off cacheness. */
                        GvASSUMECV_on(dstr);
                    }
                    if (curcop->cop_stash != GvSTASH(dstr))
@@ -2897,40 +2900,42 @@ register SV *sv2;
 }
 
 #ifdef USE_LOCALE_COLLATE
-
+/*
+ * Any scalar variable may carry an 'o' magic that contains the
+ * scalar data of the variable transformed to such a format that
+ * a normal memory comparison can be used to compare the data
+ * according to the locale settings.
+ */
 char *
 sv_collxfrm(sv, nxp)
      SV *sv;
      STRLEN *nxp;
 {
-    /* Any scalar variable may carry an 'o' magic that contains the
-     * scalar data of the variable transformed to such a format that
-     * a normal memory comparison can be used to compare the data
-     * according to the locale settings. */
+    MAGIC *mg;
 
-    MAGIC *mg = NULL;
-
-    if (SvMAGICAL(sv)) {
-       mg = mg_find(sv, 'o');
-       if (mg && *(U32*)mg->mg_ptr != collation_ix)
-           mg = NULL;
-    }
-
-    if (! mg) {
+    mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL;
+    if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) {
        char *s, *xf;
        STRLEN len, xlen;
 
+       if (mg)
+           Safefree(mg->mg_ptr);
        s = SvPV(sv, len);
        if ((xf = mem_collxfrm(s, len, &xlen))) {
-           sv_magic(sv, 0, 'o', 0, 0);
-           if ((mg = mg_find(sv, 'o'))) {
-               mg->mg_ptr = xf;
-               mg->mg_len = xlen;
+           if (! mg) {
+               sv_magic(sv, 0, 'o', 0, 0);
+               mg = mg_find(sv, 'o');
+               assert(mg);
            }
+           mg->mg_ptr = xf;
+           mg->mg_len = xlen;
+       }
+       else {
+           mg->mg_ptr = NULL;
+           mg->mg_len = -1;
        }
     }
-
-    if (mg) {
+    if (mg && mg->mg_ptr) {
        *nxp = mg->mg_len;
        return mg->mg_ptr + sizeof(collation_ix);
     }
index ac17683..f5d4544 100755 (executable)
@@ -1,11 +1,20 @@
 #!./perl
 
 BEGIN {
-    @INC = '../lib';
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
-       print "1..0\n";
-       exit 0;
+    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;
+        }
     }
 }
 
index 6f9d30c..1d050ff 100755 (executable)
@@ -1,11 +1,21 @@
 #!./perl
 
+
 BEGIN {
-    @INC = '../lib';
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
-       print "1..0\n";
-       exit 0;
+    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;
+        }
     }
 }
 
@@ -35,7 +45,7 @@ elsif(defined $pid)
  }
 else
  {
-  die "# error = $!";
+  die;
  }
 
 $pipe = new IO::Pipe;
index e69de29..44d9757 100755 (executable)
@@ -0,0 +1,108 @@
+#!./perl
+
+BEGIN {
+    unless(grep /blib/, @INC) {
+        chdir 't' if -d 't';
+        @INC = '../lib' if -d '../lib';
+    }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print "1..21\n";
+
+use IO::Select 1.09;
+
+my $sel = new IO::Select(\*STDIN);
+$sel->add(4, 5) == 2 or print "not ";
+print "ok 1\n";
+
+$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
+print "ok 2\n";
+
+@handles = $sel->handles;
+print "not " unless $sel->count == 4 && @handles == 4;
+print "ok 3\n";
+#print $sel->as_string, "\n";
+
+$sel->remove(\*STDIN) == 1 or print "not ";
+print "ok 4\n",
+;
+$sel->remove(\*STDIN, 5, 6) == 1  # two of there are not present
+  or print "not ";
+print "ok 5\n";
+
+print "not " unless $sel->count == 2;
+print "ok 6\n";
+#print $sel->as_string, "\n";
+
+$sel->remove(1, 4);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 7\n";
+
+$sel = new IO::Select;
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 8\n";
+
+$sel->remove([\*STDOUT, 5]);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 9\n";
+
+@a = $sel->can_read();  # should return imediately
+print "not " unless @a == 0;
+print "ok 10\n";
+
+# we assume that we can write to STDOUT :-)
+$sel->add([\*STDOUT, "ok 12\n"]);
+
+@a = $sel->can_write;
+print "not " unless @a == 1;
+print "ok 11\n";
+
+my($fd, $msg) = @{shift @a};
+print $fd $msg;
+
+$sel->add(\*STDOUT);  # update
+
+@a = IO::Select::select(undef, $sel, undef, 1);
+print "not " unless @a == 3;
+print "ok 13\n";
+
+($r, $w, $e) = @a;
+
+print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
+print "ok 14\n";
+
+$fd = $w->[0];
+print $fd "ok 15\n";
+
+# Test new exists() method
+$sel->exists(\*STDIN) and print "not ";
+print "ok 16\n";
+
+($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
+print "ok 17\n";
+
+$fd = $sel->exists(\*STDOUT);
+if ($fd) {
+    print $fd "ok 18\n";
+} else {
+    print "not ok 18\n";
+}
+
+$fd = $sel->exists([1, 'foo']);
+if ($fd) {
+    print $fd "ok 19\n";
+} else {
+    print "not ok 19\n";
+}
+
+# Try self clearing
+$sel->add(5,6,7,8,9,10);
+print "not " unless $sel->count == 7;
+print "ok 20\n";
+
+$sel->remove($sel->handles);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 21\n";
index 156f6cb..c3701c5 100755 (executable)
@@ -1,14 +1,22 @@
 #!./perl
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib' if -d '../lib';
-    require Config; import Config;
-    if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
-          $Config{'extensions'} !~ /\bIO\b/)    &&
-          !(($^O eq 'VMS') && $Config{d_socket})) {
-       print "1..0\n";
-       exit 0;
+    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;
+        }
     }
 }
 
@@ -17,24 +25,15 @@ print "1..5\n";
 
 use IO::Socket;
 
-srand(time);
-$port = 4002 + int(rand 0xff);
-print "# using port $port.\n";
-$SIG{ALRM} = sub {};
-
-$pid =  fork();
-
-if($pid) {
+$listen = IO::Socket::INET->new(Listen => 2,
+                               Proto => 'tcp',
+                              ) or die "$!";
 
-    $listen = IO::Socket::INET->new(Listen => 2,
-                                   Proto => 'tcp',
-                                   LocalPort => $port
-                                  ) or die "$!";
+print "ok 1\n";
 
-    print "ok 1\n";
+$port = $listen->sockport;
 
-    # Wake out child
-    kill(ALRM => $pid);
+if($pid = fork()) {
 
     $sock = $listen->accept();
     print "ok 2\n";
@@ -49,12 +48,8 @@ if($pid) {
     waitpid($pid,0);
 
     print "ok 5\n";
-} elsif(defined $pid) {
-
-    # Wait for a small pause, so that we can ensure the listen socket is setup
-    # the parent will awake us with a SIGALRM
 
-    sleep(10);
+} elsif(defined $pid) {
 
     $sock = IO::Socket::INET->new(PeerPort => $port,
                                  Proto => 'tcp',
@@ -62,9 +57,13 @@ if($pid) {
                                 ) or die "$!";
 
     $sock->autoflush(1);
+
     print $sock "ok 3\n";
+
     print $sock->getline();
+
     $sock->close;
+
     exit;
 } else {
  die;
index 5a706fb..f45d21e 100755 (executable)
@@ -1,14 +1,24 @@
 #!./perl
 
-# $RCSfile: tell.t,v $$Revision: 1.1 $$Date: 1996/05/01 10:52:47 $
+BEGIN {
+    unless(grep /blib/, @INC) {
+       chdir 't' if -d 't';
+       @INC = '../lib' if -d '../lib';
+       $tell_file = "TEST";
+    }
+    else {
+       $tell_file = "Makefile";
+    }
+}
+
+use Config;
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib' if -d '../lib';
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) {
-       print "1..0\n";
-       exit 0;
+    if(-d "lib" && -f "TEST") {
+        if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+           print "1..0\n";
+           exit 0;
+        }
     }
 }
 
@@ -16,7 +26,7 @@ print "1..13\n";
 
 use IO::File;
 
-$tst = IO::File->new("TEST","r") || die("Can't open TEST");
+$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
 
 if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
 
index e85583f..d8377f6 100755 (executable)
@@ -1,15 +1,23 @@
 #!./perl
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib' if -d '../lib';
-    require Config; import Config;
-    if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
-          $Config{'extensions'} !~ /\bIO\b/    ||
-         $^O eq 'os2')    &&
-          !(($^O eq 'VMS') && $Config{d_socket})) {
-       print "1..0\n";
-       exit 0;
+    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 'os2')    &&
+              !(($^O eq 'VMS') && $Config{d_socket})) {
+           print "1..0\n";
+           exit 0;
+        }
     }
 }
 
@@ -25,7 +33,7 @@ $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost');
 print "ok 1\n";
 
 $udpa->send("ok 2\n",0,$udpb->sockname);
-$rem = $udpb->recv($buf="",5);
+$udpb->recv($buf="",5);
 print $buf;
 $udpb->send("ok 3\n");
 $udpa->recv($buf="",5);
index bff3d69..3426ebe 100755 (executable)
@@ -1,13 +1,20 @@
 #!./perl
-$| = 1;
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib' if -d '../lib';
-    require Config; import Config;
-    if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) {
-       print "1..0\n";
-       exit 0;
+    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;
+        }
     }
 }