Upgrade to IO 1.22 from gbarr

- Adjust the regression tests to use t/test.pl from bleadperl
  when $ENV{PERL_CORE} is defined
- Add can_ok and isa_ok to t/test.pl from the implementation
  found in the IO CPAN distribution

p4raw-id: //depot/perl@25355

diff --git a/ext/IO/ChangeLog b/ext/IO/ChangeLog
index c45e785..c9f71e7 100644 (file)
--- a/ext/IO/ChangeLog
+++ b/ext/IO/ChangeLog
@@ -1,4 +1,6 @@
-For more recent changes, see the Perl Changes* file(s).
+IO 1.22 -- Mon Sep  5 10:29:35 CDT 2005
+
+ * Update with changes made in perl core distribution
 
 Change 173 on 1998/07/14 by <gbarr@pobox.com> (Graham Barr)
 

diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm
index 2a368e7..9fccc3a 100644 (file)
--- a/ext/IO/IO.pm
+++ b/ext/IO/IO.pm
@@ -7,7 +7,7 @@ use Carp;
 use strict;
 use warnings;
 
-our $VERSION = "1.21";
+our $VERSION = "1.22";
 XSLoader::load 'IO', $VERSION;
 
 sub import {

diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs
index b3125aa..4abc135 100644 (file)
--- a/ext/IO/IO.xs
+++ b/ext/IO/IO.xs
@@ -49,6 +49,14 @@ typedef FILE * OutputStream;
 #define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
 #endif
 
+#ifndef __attribute__noreturn__
+#  define __attribute__noreturn__
+#endif
+
+#ifndef NORETURN_FUNCTION_END
+# define NORETURN_FUNCTION_END /* NOT REACHED */ return 0
+#endif
+
 static int not_here(const char *s) __attribute__noreturn__;
 static int
 not_here(const char *s)
@@ -125,21 +133,32 @@ fgetpos(handle)
     CODE:
        if (handle) {
 #ifdef PerlIO
-           ST(0) = sv_2mortal(newSV(0));
+           ST(0) = sv_newmortal();
+#if PERL_VERSION < 8
+           Fpos_t pos;
+           if (PerlIO_getpos(handle, &pos) != 0) {
+               ST(0) = &PL_sv_undef;
+           }
+           else {
+               sv_setpvn(ST(0), (char *)&pos, sizeof(Fpos_t));
+           }
+#else
            if (PerlIO_getpos(handle, ST(0)) != 0) {
                ST(0) = &PL_sv_undef;
            }
+#endif
 #else
+           Fpos_t pos;
            if (fgetpos(handle, &pos)) {
                ST(0) = &PL_sv_undef;
            } else {
-               ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
+               ST(0) = sv_2mortal(newSVpvn((char*)&pos, sizeof(Fpos_t)));
            }
 #endif
        }
        else {
-           ST(0) = &PL_sv_undef;
            errno = EINVAL;
+           ST(0) = &PL_sv_undef;
        }
 
 SysRet
@@ -149,7 +168,19 @@ fsetpos(handle, pos)
     CODE:
        if (handle) {
 #ifdef PerlIO
+#if PERL_VERSION < 8
+           char *p;
+           STRLEN len;
+           if (SvOK(pos) && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) {
+               RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
+           }
+           else {
+               RETVAL = -1;
+               errno = EINVAL;
+           }
+#else
            RETVAL = PerlIO_setpos(handle, pos);
+#endif
 #else
            char *p;
            STRLEN len;
@@ -173,7 +204,7 @@ MODULE = IO PACKAGE = IO::File      PREFIX = f
 
 void
 new_tmpfile(packname = "IO::File")
-    const char *       packname
+    char *     packname
     PREINIT:
        OutputStream fp;
        GV *gv;

diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL
index 095d7c2..6855ee4 100644 (file)
--- a/ext/IO/Makefile.PL
+++ b/ext/IO/Makefile.PL
@@ -1,9 +1,49 @@
+# This -*- perl -*- script makes the Makefile
+
+require 5.006_001;
 use ExtUtils::MakeMaker;
 use Config qw(%Config);
 
+#--- MY package
+
+sub MY::libscan {
+  my($self,$path) = @_;
+
+  return '' 
+       if($path =~ m:/(RCS|CVS|SCCS|\.svn)/: ||
+          $path =~ m:[~%]$: ||
+          $path =~ m:\.(orig|rej)$:
+         );
+ 
+  $path;
+}
+
+
+#--- Attempt to find <poll.h>
+
+my $define = "";
+
+unless (exists $Config{'i_poll'}) {
+  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(
        VERSION_FROM    => "IO.pm",
        NAME            => "IO",
        OBJECT          => '$(O_FILES)', 
-       MAN3PODS        => {},          # Pods will be built by installman.
+       DEFINE          => $define,
+ 
+       'clean'         => {FILES => join(" ",
+                                       map { "$_ */$_ */*/$_" }
+                                       qw(*% *.html *.b[ac]k *.old *.orig))
+                          },
+       INSTALLDIRS => 'perl',
 );

diff --git a/ext/IO/README b/ext/IO/README
index 191d550..e4d9dfa 100644 (file)
--- a/ext/IO/README
+++ b/ext/IO/README
@@ -1,5 +1,27 @@
-This directory contains files from the IO distribution created by
-Graham Barr.  It is currently maintained by the Perl Porters as part
-of the Perl source distribution. If you find that you have to modify
-any files in this directory then please forward them a patch at
-<perl5-porters@perl.org>.
+This is the perl5 IO distribution.
+
+This distribution is included in the perl5 core distribution. You should
+only need to install this distribution if it is newer than your perl
+installation.
+
+To install this distribution you will need access rights to the perl
+install ation on your system, as it overwrites your currently installed
+version of IO.
+
+This distribution relies upon the Socket module (version 1.3), which is
+avaliable from CPAN. Although you should not need to get this if your
+version of perl is fairly recent, as Socket is also distributed in the
+core perl distribution.
+
+If you do not have the required modules, you will see a warning when 
+the Makefile is built.
+
+To build, test and install this distribution type:
+
+ perl Makefile.PL
+ make test
+ make install
+
+Share and Enjoy!
+Graham Barr <gbarr@pobox.com>
+

diff --git a/ext/IO/lib/IO/Dir.pm b/ext/IO/lib/IO/Dir.pm
index c7de8b3..fccd02c 100644 (file)
--- a/ext/IO/lib/IO/Dir.pm
+++ b/ext/IO/lib/IO/Dir.pm
@@ -19,7 +19,7 @@ use File::stat;
 use File::Spec;
 
 @ISA = qw(Tie::Hash Exporter);
-$VERSION = "1.04";
+$VERSION = "1.05";
 $VERSION = eval $VERSION;
 @EXPORT_OK = qw(DIR_UNLINK);
 

diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm
index 4f53771..e7cdbbe 100644 (file)
--- a/ext/IO/lib/IO/File.pm
+++ b/ext/IO/lib/IO/File.pm
@@ -137,7 +137,7 @@ require Exporter;
 
 @ISA = qw(IO::Handle IO::Seekable Exporter);
 
-$VERSION = "1.12";
+$VERSION = "1.13";
 
 @EXPORT = @IO::Seekable::EXPORT;
 

diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm
index 0e61ce1..329d26a 100644 (file)
--- a/ext/IO/lib/IO/Handle.pm
+++ b/ext/IO/lib/IO/Handle.pm
@@ -264,7 +264,7 @@ use IO ();  # Load the XS module
 require Exporter;
 @ISA = qw(Exporter);
 
-$VERSION = "1.24";
+$VERSION = "1.25";
 $VERSION = eval $VERSION;
 
 @EXPORT_OK = qw(

diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm
index 1d43b6e..827cc48 100644 (file)
--- a/ext/IO/lib/IO/Pipe.pm
+++ b/ext/IO/lib/IO/Pipe.pm
@@ -14,7 +14,7 @@ our($VERSION);
 use Carp;
 use Symbol;
 
-$VERSION = "1.123";
+$VERSION = "1.13";
 
 sub new {
     my $type = shift;

diff --git a/ext/IO/lib/IO/Poll.pm b/ext/IO/lib/IO/Poll.pm
index cd8da30..e7fb013 100644 (file)
--- a/ext/IO/lib/IO/Poll.pm
+++ b/ext/IO/lib/IO/Poll.pm
@@ -13,7 +13,7 @@ use Exporter ();
 our(@ISA, @EXPORT_OK, @EXPORT, $VERSION);
 
 @ISA = qw(Exporter);
-$VERSION = "0.06";
+$VERSION = "0.07";
 
 @EXPORT = qw( POLLIN
              POLLOUT

diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm
index 240b288..db1effd 100644 (file)
--- a/ext/IO/lib/IO/Seekable.pm
+++ b/ext/IO/lib/IO/Seekable.pm
@@ -107,7 +107,7 @@ require Exporter;
 @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
 @ISA = qw(Exporter);
 
-$VERSION = "1.09";
+$VERSION = "1.10";
 $VERSION = eval $VERSION;
 
 sub seek {

diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm
index 3e23cc0..fc05fe7 100644 (file)
--- a/ext/IO/lib/IO/Select.pm
+++ b/ext/IO/lib/IO/Select.pm
@@ -11,7 +11,7 @@ use warnings::register;
 use     vars qw($VERSION @ISA);
 require Exporter;
 
-$VERSION = "1.16";
+$VERSION = "1.17";
 
 @ISA = qw(Exporter); # This is only so we can do version checking
 

diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm
index 4ea07d0..4429f2b 100644 (file)
--- a/ext/IO/lib/IO/Socket.pm
+++ b/ext/IO/lib/IO/Socket.pm
@@ -23,7 +23,7 @@ require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
 
 @ISA = qw(IO::Handle);
 
-$VERSION = "1.28";
+$VERSION = "1.29";
 
 @EXPORT_OK = qw(sockatmark);
 

diff --git a/ext/IO/lib/IO/Socket/INET.pm b/ext/IO/lib/IO/Socket/INET.pm
index b4041b1..96b4991 100644 (file)
--- a/ext/IO/lib/IO/Socket/INET.pm
+++ b/ext/IO/lib/IO/Socket/INET.pm
@@ -15,7 +15,7 @@ use Exporter;
 use Errno;
 
 @ISA = qw(IO::Socket);
-$VERSION = "1.28";
+$VERSION = "1.29";
 
 my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
 

diff --git a/ext/IO/lib/IO/Socket/UNIX.pm b/ext/IO/lib/IO/Socket/UNIX.pm
index 6d0e95a..952a0f4 100644 (file)
--- a/ext/IO/lib/IO/Socket/UNIX.pm
+++ b/ext/IO/lib/IO/Socket/UNIX.pm
@@ -13,7 +13,7 @@ use Socket;
 use Carp;
 
 @ISA = qw(IO::Socket);
-$VERSION = "1.21";
+$VERSION = "1.22";
 $VERSION = eval $VERSION;
 
 IO::Socket::UNIX->register_domain( AF_UNIX );

diff --git a/ext/IO/t/IO.t b/ext/IO/t/IO.t
index 388be4e..ae67a25 100644 (file)
--- a/ext/IO/t/IO.t
+++ b/ext/IO/t/IO.t
@@ -1,9 +1,10 @@
 #!/usr/bin/perl -w
 
-BEGIN
-{
+BEGIN {
+    unless(grep /blib/, @INC) {
        chdir 't' if -d 't';
        @INC = '../lib';
+    }
        require Config;
        if ($Config::Config{'extensions'} !~ /\bSocket\b/) {
                print "1..0 # Skip: Socket not built - IO.pm uses Socket";
@@ -14,14 +15,15 @@ BEGIN
 use strict;
 use File::Path;
 use File::Spec;
-use Test::More tests => 18;
+require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
+plan(tests => 18);
 
 {
-       local $INC{'XSLoader.pm'} = 1;
-       local *XSLoader::load;
+       require XSLoader;
 
        my @load;
-       *XSLoader::load = sub {
+       local $^W;
+       local *XSLoader::load = sub {
                push @load, \@_;
        };
 

diff --git a/ext/IO/t/io_file.t b/ext/IO/t/io_file.t
index 22d177e..546c611 100755 (executable)
--- a/ext/IO/t/io_file.t
+++ b/ext/IO/t/io_file.t
@@ -1,10 +1,15 @@
 #!./perl -w
 
-BEGIN { chdir 't' if -d 't'; }
+BEGIN {
+    unless(grep /blib/, @INC) {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+    }
+}
 
 use strict;
-use lib '../lib';
-use Test::More tests => ($^O =~ /MSWin32/ ? 9 : 6);
+require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
+plan(tests => ($^O =~ /MSWin32/ ? 9 : 6));
 
 my $Class       = 'IO::File';
 my $All_Chars   = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r";

diff --git a/ext/IO/t/io_linenum.t b/ext/IO/t/io_linenum.t
index cf55c98..a1b1bc6 100755 (executable)
--- a/ext/IO/t/io_linenum.t
+++ b/ext/IO/t/io_linenum.t
@@ -5,16 +5,14 @@
 
 my $File;
 
-BEGIN
-{
-  $File = __FILE__;
-  if (-d 't')
-  {
-    chdir 't';
-    $File =~ s/^t\W+//;                                 # Remove first directory
-  }
-  @INC = '../lib';
-  require strict; import strict;
+BEGIN {
+    $File = __FILE__;
+    unless(grep /blib/, @INC) {
+       chdir 't' if -d 't';
+       $File =~ s/^t\W+//;                                 # Remove first directory
+       @INC = '../lib';
+    }
+    require strict; import strict;
 }
 
 use Test;

diff --git a/ext/IO/t/io_pipe.t b/ext/IO/t/io_pipe.t
index a8bc483..1c3ab80 100755 (executable)
--- a/ext/IO/t/io_pipe.t
+++ b/ext/IO/t/io_pipe.t
@@ -1,10 +1,16 @@
 #!./perl
 
+my $perl;
+
 BEGIN {
     unless(grep /blib/, @INC) {
+       $perl = './perl';
        chdir 't' if -d 't';
        @INC = '../lib';
     }
+    else {
+       $perl = $^X;
+    }
 }
 
 use Config;
@@ -27,7 +33,6 @@ BEGIN {
 
 use IO::Pipe;
 
-my $perl = './perl';
 
 $| = 1;
 print "1..10\n";

diff --git a/ext/IO/t/io_sel.t b/ext/IO/t/io_sel.t
index 1e72e38..5d27549 100755 (executable)
--- a/ext/IO/t/io_sel.t
+++ b/ext/IO/t/io_sel.t
@@ -1,4 +1,4 @@
-#!./perl
+#!./perl -w
 
 BEGIN {
     unless(grep /blib/, @INC) {
@@ -119,15 +119,20 @@ print "ok 21\n";
 # check warnings
 $SIG{__WARN__} = sub { 
     ++ $w 
-      if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ 
+      if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ ;
     } ;
 $w = 0 ;
+{
+no warnings 'IO::Select' ;
 IO::Select::has_error();
+}
 print "not " unless $w == 0 ;
 $w = 0 ;
 print "ok 22\n" ;
+{
 use warnings 'IO::Select' ;
 IO::Select::has_error();
+}
 print "not " unless $w == 1 ;
 $w = 0 ;
 print "ok 23\n" ;

diff --git a/ext/IO/t/io_sock.t b/ext/IO/t/io_sock.t
index c278850..918e96b 100755 (executable)
--- a/ext/IO/t/io_sock.t
+++ b/ext/IO/t/io_sock.t
@@ -28,7 +28,7 @@ BEGIN {
     }
 }
 
-my $has_perlio = find PerlIO::Layer 'perlio';
+my $has_perlio = $] >= 5.008 and find PerlIO::Layer 'perlio';
 
 $| = 1;
 print "1..26\n";

diff --git a/ext/IO/t/io_utf8.t b/ext/IO/t/io_utf8.t
index 7c87dc7..c4ba3de 100644 (file)
--- a/ext/IO/t/io_utf8.t
+++ b/ext/IO/t/io_utf8.t
@@ -1,15 +1,17 @@
 #!./perl
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
-    unless (find PerlIO::Layer 'perlio') {
+    unless(grep /blib/, @INC) {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+    }
+    unless ($] >= 5.008 and find PerlIO::Layer 'perlio') {
        print "1..0 # Skip: not perlio\n";
        exit 0;
     }
 }
 
-require "./test.pl";
+require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
 
 plan(tests => 5);
 

diff --git a/t/test.pl b/t/test.pl
index 179b2f1..1e8ed9c 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -649,4 +649,66 @@ sub fresh_perl_like {
                $runperl_args, $name);
 }
 
+sub can_ok ($@) {
+    my($proto, @methods) = @_;
+    my $class = ref $proto || $proto;
+
+    unless( @methods ) {
+        return _ok( 0, _where(), "$class->can(...)" );
+    }
+
+    my @nok = ();
+    foreach my $method (@methods) {
+        local($!, $@);  # don't interfere with caller's $@
+                        # eval sometimes resets $!
+        eval { $proto->can($method) } || push @nok, $method;
+    }
+
+    my $name;
+    $name = @methods == 1 ? "$class->can('$methods[0]')" 
+                          : "$class->can(...)";
+    
+    _ok( !@nok, _where(), $name );
+}
+
+sub isa_ok ($$;$) {
+    my($object, $class, $obj_name) = @_;
+
+    my $diag;
+    $obj_name = 'The object' unless defined $obj_name;
+    my $name = "$obj_name isa $class";
+    if( !defined $object ) {
+        $diag = "$obj_name isn't defined";
+    }
+    elsif( !ref $object ) {
+        $diag = "$obj_name isn't a reference";
+    }
+    else {
+        # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+        local($@, $!);  # eval sometimes resets $!
+        my $rslt = eval { $object->isa($class) };
+        if( $@ ) {
+            if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+                if( !UNIVERSAL::isa($object, $class) ) {
+                    my $ref = ref $object;
+                    $diag = "$obj_name isn't a '$class' it's a '$ref'";
+                }
+            } else {
+                die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+This should never happen.  Please contact the author immediately.
+Here's the error.
+$@
+WHOA
+            }
+        }
+        elsif( !$rslt ) {
+            my $ref = ref $object;
+            $diag = "$obj_name isn't a '$class' it's a '$ref'";
+        }
+    }
+
+    _ok( !$diag, _where(), $name );
+}
+
 1;