From: Rafael Garcia-Suarez Date: Tue, 6 Sep 2005 08:46:37 +0000 (+0000) Subject: Upgrade to IO 1.22 from gbarr X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=35a603864810a769960255e50b84d5fab2473ee8;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 (Graham Barr) diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm index 2a368e7..9fccc3a 100644 --- 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 --- 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 --- 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 + +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 --- 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 -. +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 + diff --git a/ext/IO/lib/IO/Dir.pm b/ext/IO/lib/IO/Dir.pm index c7de8b3..fccd02c 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 <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;