From: Nick Ing-Simmons Date: Fri, 1 Feb 2002 18:20:46 +0000 (+0000) Subject: Integrate mainline X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3e6618b7a3a573729d121d2ba204ea2164d47107;p=p5sagit%2Fp5-mst-13.2.git Integrate mainline p4raw-id: //depot/perlio@14517 --- diff --git a/Changes b/Changes index 4fba422..3bd5484 100644 --- a/Changes +++ b/Changes @@ -31,6 +31,181 @@ or any other branch. Version v5.7.2 Development release working toward v5.8 -------------- ____________________________________________________________________________ +[ 14502] By: jhi on 2002/01/30 14:32:25 + Log: Subject: [PATCH re bug 200713.003] Re: Perlbug - reminder of bug(20010713.003) status + From: Robin Barker + Date: Wed, 30 Jan 2002 11:58:33 GMT + Message-Id: <200201301158.LAA14883@tempest.npl.co.uk> + Branch: perl + ! lib/CPAN.pm +____________________________________________________________________________ +[ 14501] By: jhi on 2002/01/30 14:20:32 + Log: Move ext/Encode/lib/Encode.pm to ext/Encode/Encode.pm; + re-sort MANIFEST. + Branch: perl + + ext/Encode/Encode.pm + - ext/Encode/lib/Encode.pm + ! MANIFEST ext/Encode/Makefile.PL +____________________________________________________________________________ +[ 14500] By: jhi on 2002/01/30 14:05:13 + Log: Integrate perlio; + + Collect some stats during compile process. + Experiment with effect of bundling all EUC-JP, EUC-CN, EUC-KR + as one XS - inconclusive - marginal win? + Add some comments to encode.h + Branch: perl + !> ext/Encode/EUC_JP/Makefile.PL ext/Encode/compile + !> ext/Encode/encode.h +____________________________________________________________________________ +[ 14497] By: jhi on 2002/01/30 04:40:56 + Log: Subject: [PATCH] perl -V: (was: Re: Inline::C and Perl objects with C API's) + From: sthoenna@efn.org (Yitzchak Scott-Thoennes) + Date: Tue, 29 Jan 2002 01:13:09 -0800 + Message-ID: + Branch: perl + ! configpm +____________________________________________________________________________ +[ 14496] By: jhi on 2002/01/30 01:55:57 + Log: Subject: [PATCH t/op/inccode.t] new test + From: Rafael Garcia-Suarez + Date: Tue, 29 Jan 2002 22:03:45 +0100 + Message-ID: <20020129220345.A704@rafael> + Branch: perl + ! t/op/inccode.t +____________________________________________________________________________ +[ 14495] By: jhi on 2002/01/30 01:01:26 + Log: EBCDIC: t/op/lc.t now passes. + Branch: perl + ! t/op/lc.t +____________________________________________________________________________ +[ 14494] By: jhi on 2002/01/30 00:41:52 + Log: EBCDIC fix: t/op/lc.t failures 24-25, 29-30, 34-35, 39-40 + Branch: perl + ! utf8.c +____________________________________________________________________________ +[ 14493] By: jhi on 2002/01/29 22:32:05 + Log: Must find stuff during build. + Branch: perl + ! ext/Encode/compile +____________________________________________________________________________ +[ 14492] By: jhi on 2002/01/29 22:24:54 + Log: Integrate with perlio; + + Basics of a compiled Encode XS extension + Branch: perl + +> ext/Encode/EUC_JP/EUC_JP.pm ext/Encode/EUC_JP/Makefile.PL + +> ext/Encode/Encode/euc-jp.ucm + !> MANIFEST ext/Encode/Encode.xs ext/Encode/compile + !> ext/Encode/encode.h +____________________________________________________________________________ +[ 14491] By: jhi on 2002/01/29 22:23:25 + Log: EBCDIC tweaks-- no new test passes, but getting closer. + Branch: perl + ! utf8.c +____________________________________________________________________________ +[ 14488] By: jhi on 2002/01/29 16:38:58 + Log: Subject: Re: [PATCH] Attribute::Handlers lexical refcount skew (was Re: lexical with attribute, refcount high) + From: Richard Clamp + Date: Mon, 28 Jan 2002 02:17:55 +0000 + Message-ID: <20020128021755.GA28344@mirth.demon.co.uk> + Branch: perl + ! lib/Attribute/Handlers.pm lib/Attribute/Handlers/t/multi.t +____________________________________________________________________________ +[ 14487] By: jhi on 2002/01/29 14:23:03 + Log: OS/390 seems to do length 0 udp reads, Nicholas says + skippage is for now the best cause of action. + Branch: perl + ! ext/Socket/socketpair.t +____________________________________________________________________________ +[ 14486] By: jhi on 2002/01/29 14:09:21 + Log: Encode cleanup from Dan Kogai; reworked even further. + Branch: perl + + ext/Encode/MANIFEST ext/Encode/README ext/Encode/lib/Encode.pm + + ext/Encode/lib/Encode/Encoding.pm + + ext/Encode/lib/Encode/Internal.pm ext/Encode/lib/Encode/Tcl.pm + + ext/Encode/lib/Encode/Tcl/Escape.pm + + ext/Encode/lib/Encode/Tcl/Extended.pm + + ext/Encode/lib/Encode/Tcl/HanZi.pm + + ext/Encode/lib/Encode/Tcl/Table.pm + + ext/Encode/lib/Encode/Unicode.pm ext/Encode/lib/Encode/XS.pm + + ext/Encode/lib/Encode/iso10646_1.pm + + ext/Encode/lib/Encode/ucs2_le.pm ext/Encode/lib/Encode/utf8.pm + + ext/Encode/lib/EncodeFormat.pod ext/Encode/t/Encode.t + + ext/Encode/t/Tcl.t + - ext/Encode.t ext/Encode/Encode.pm + - ext/Encode/Encode/EncodeFormat.pod ext/Encode/Encode/Tcl.pm + - ext/Encode/Encode/Tcl.t ext/Encode/Todo + ! MANIFEST ext/Encode/Encode/8859-1.ucm + ! ext/Encode/Encode/8859-10.ucm ext/Encode/Encode/8859-13.ucm + ! ext/Encode/Encode/8859-14.ucm ext/Encode/Encode/8859-15.ucm + ! ext/Encode/Encode/8859-16.ucm ext/Encode/Encode/8859-2.ucm + ! ext/Encode/Encode/8859-3.ucm ext/Encode/Encode/8859-4.ucm + ! ext/Encode/Encode/8859-5.ucm ext/Encode/Encode/8859-6.ucm + ! ext/Encode/Encode/8859-7.ucm ext/Encode/Encode/8859-8.ucm + ! ext/Encode/Encode/8859-9.ucm ext/Encode/Encode/ascii.ucm + ! ext/Encode/Encode/cp1047.ucm ext/Encode/Encode/cp1250.ucm + ! ext/Encode/Encode/cp37.ucm ext/Encode/Encode/dingbats.ucm + ! ext/Encode/Encode/koi8-r.ucm ext/Encode/Encode/posix-bc.ucm + ! ext/Encode/Encode/symbol.ucm ext/Encode/Makefile.PL + ! ext/Encode/compile +____________________________________________________________________________ +[ 14485] By: jhi on 2002/01/28 23:17:20 + Log: Workaround for DJGPP broken F_GETFL from Laszlo. + Branch: perl + ! djgpp/djgpp.c perlio.c +____________________________________________________________________________ +[ 14484] By: jhi on 2002/01/28 23:15:22 + Log: Prettier printing from Michael Schwern. + Branch: perl + ! t/test.pl +____________________________________________________________________________ +[ 14483] By: jhi on 2002/01/28 23:08:27 + Log: Show also the debug and debugcolor as known pragmas. + Branch: perl + ! ext/re/re.pm +____________________________________________________________________________ +[ 14482] By: jhi on 2002/01/28 22:08:38 + Log: Subject: [PATCH] skip assembler.t when there is no ByteLoader + From: "Craig A. Berry" + Date: Mon, 28 Jan 2002 16:30:30 -0600 + Message-Id: <5.1.0.14.2.20020128162440.01ae7868@exchi01> + Branch: perl + ! ext/B/t/assembler.t +____________________________________________________________________________ +[ 14480] By: jhi on 2002/01/28 21:57:37 + Log: DJGPP needs to know its exe soon, too. + Branch: perl + ! Configure +____________________________________________________________________________ +[ 14479] By: jhi on 2002/01/28 21:36:34 + Log: Round #2 on EBCDICation. + Branch: perl + ! t/op/append.t +____________________________________________________________________________ +[ 14478] By: jhi on 2002/01/28 21:19:40 + Log: Integrate perlio; + + Set makefile.mk CCHOME etc. for default locations of MinGW and free + Borland compilers. (Borland builds one or two oddities.) + Branch: perl + !> win32/config.bc win32/makefile.mk +____________________________________________________________________________ +[ 14473] By: jhi on 2002/01/28 17:12:27 + Log: Misunderstood Merijn's patch. + Branch: perl + ! hints/hpux.sh +____________________________________________________________________________ +[ 14472] By: jhi on 2002/01/28 17:11:58 + Log: Misapplied Merijn's patch. + Branch: perl + ! Configure +____________________________________________________________________________ +[ 14471] By: jhi on 2002/01/28 14:51:20 + Log: Update Changes. + Branch: perl + ! Changes patchlevel.h +____________________________________________________________________________ [ 14470] By: jhi on 2002/01/28 14:33:36 Log: BeOS has sockets but not true ones. Branch: perl diff --git a/MANIFEST b/MANIFEST index a74b06c..6ff9a58 100644 --- a/MANIFEST +++ b/MANIFEST @@ -197,6 +197,7 @@ ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module ext/Encode/compile Encode extension ext/Encode/encengine.c Encode extension ext/Encode/encode.h Encode extension +ext/Encode/Encode.pm Encode extension ext/Encode/Encode.xs Encode extension ext/Encode/Encode/11643-1.enc Encode table ext/Encode/Encode/11643-2.enc Encode table @@ -328,6 +329,8 @@ ext/Encode/Encode/symbol.enc Encode table ext/Encode/Encode/symbol.ucm Encode table ext/Encode/Encode/viscii.enc Encode table ext/Encode/Encode/viscii.ucm Encode table +ext/Encode/EUC_JP/EUC_JP.pm Enode module for euc-jp +ext/Encode/EUC_JP/Makefile.PL Enode module for euc-jp ext/Encode/Encode.pm Encode extension ext/Encode/lib/Encode/Encoding.pm Encode extension ext/Encode/lib/Encode/Internal.pm Encode extension @@ -347,8 +350,6 @@ ext/Encode/MANIFEST Encode extension ext/Encode/README Encode extension ext/Encode/t/Encode.t Encode extension test ext/Encode/t/Tcl.t Encode extension test -ext/Encode/EUC_JP/Makefile.PL Enode module for euc-jp -ext/Encode/EUC_JP/EUC_JP.pm Enode module for euc-jp ext/Errno/ChangeLog Errno perl module change log ext/Errno/Errno.t See if Errno works ext/Errno/Errno_pm.PL Errno perl module create script @@ -952,9 +953,9 @@ lib/ExtUtils/Changes MakeMaker change log lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms lib/ExtUtils/Constant.pm generate XS code to import C header constants lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs -lib/ExtUtils/instmodsh Give information about installed extensions lib/ExtUtils/Install.pm Handles 'make install' on extensions lib/ExtUtils/Installed.pm Information on installed extensions +lib/ExtUtils/instmodsh Give information about installed extensions lib/ExtUtils/Liblist.pm Locates libraries lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files @@ -972,6 +973,7 @@ lib/ExtUtils/Packlist.pm Manipulates .packlist files lib/ExtUtils/t/Command.t See if ExtUtils::Command works (Win32 only) lib/ExtUtils/t/Embed.t See if ExtUtils::Embed and embedding works lib/ExtUtils/t/ExtUtils.t See if extutils work +lib/ExtUtils/t/hints.t See if hint files are honored. lib/ExtUtils/t/Installed.t See if ExtUtils::Installed works lib/ExtUtils/t/Manifest.t See if ExtUtils::Manifest works lib/ExtUtils/t/Mkbootstrap.t See if ExtUtils::Mkbootstrap works @@ -982,7 +984,6 @@ lib/ExtUtils/t/MM_Unix.t See if ExtUtils::MM_UNIX works lib/ExtUtils/t/MM_VMS.t See if ExtUtils::MM_VMS works lib/ExtUtils/t/MM_Win32.t See if ExtUtils::MM_Win32 works lib/ExtUtils/t/Packlist.t See if Packlist works -lib/ExtUtils/t/hints.t See if hint files are honored. lib/ExtUtils/t/testlib.t Fixes up @INC to use just-built extension lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension lib/ExtUtils/typemap Extension interface types @@ -1401,9 +1402,9 @@ lib/Unicode/Collate/t/test.t Unicode::Collate lib/Unicode/README Explanation what happened to lib/unicode. lib/Unicode/UCD.pm Unicode character database lib/Unicode/UCD.t See if Unicode character database works +lib/unicore/ArabicShaping.txt Unicode character database lib/unicore/ArabLink.pl Unicode character database lib/unicore/ArabLnkGrp.pl Unicode character database -lib/unicore/ArabicShaping.txt Unicode character database lib/unicore/BidiMirroring.txt Unicode character database lib/unicore/Bidirectional.pl Unicode character database lib/unicore/Blocks.pl Unicode character database diff --git a/configpm b/configpm index 86abd6d..6216f85 100755 --- a/configpm +++ b/configpm @@ -249,7 +249,7 @@ sub config_sh { sub config_re { my $re = shift; - my @matches = ($config_sh =~ /^$re=.*\n/mg); + my @matches = grep /^$re=/, split /^/, $config_sh; @matches ? (print @matches) : print "$re: not found\n"; } diff --git a/doio.c b/doio.c index ab74d4a..3c06585 100644 --- a/doio.c +++ b/doio.c @@ -1223,7 +1223,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } else if (DO_UTF8(sv)) { if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE) - && ckWARN(WARN_UTF8)) + && ckWARN_d(WARN_UTF8)) { Perl_warner(aTHX_ WARN_UTF8, "Wide character in print"); } diff --git a/lib/Attribute/Handlers.pm b/lib/Attribute/Handlers.pm index d4cbfff..78acbdb 100644 --- a/lib/Attribute/Handlers.pm +++ b/lib/Attribute/Handlers.pm @@ -145,11 +145,18 @@ sub _gen_handler_AH_() { _apply_handler_AH_($decl,$gphase) if $global_phases{$gphase} <= $global_phase; } - # if _gen_handler_AH_ is being called after CHECK it's - # for a lexical, so we don't want to keep a reference - # around - push @declarations, $decl - if $global_phase == 0; + if ($global_phase != 0) { + # if _gen_handler_AH_ is being called after + # CHECK it's for a lexical, so make sure + # it didn't want to run anything later + + local $Carp::CarpLevel = 2; + carp "Won't be able to apply END handler" + if $phase{$handler}{END}; + } + else { + push @declarations, $decl + } } $_ = undef; } @@ -805,6 +812,12 @@ Something is rotten in the state of the program. An attributed subroutine ceased to exist between the point it was declared and the point at which its attribute handler(s) would have been called. +=item C + +You have defined an END handler for an attribute that is being applied +to a lexical variable. Since the variable may not be available during END +this won't happen. + =back =head1 AUTHOR diff --git a/lib/Attribute/Handlers/t/multi.t b/lib/Attribute/Handlers/t/multi.t index c327b39..7bcb284 100644 --- a/lib/Attribute/Handlers/t/multi.t +++ b/lib/Attribute/Handlers/t/multi.t @@ -165,3 +165,11 @@ sub dummy_our { our $banjo : Dummy; } $applied = 0; dummy_our(); dummy_our(); ok( $applied == 0, 51 ); + +sub UNIVERSAL::Stooge :ATTR(END) {}; +eval { + local $SIG{__WARN__} = sub { die @_ }; + my $groucho : Stooge; +}; +my $match = $@ =~ /^Won't be able to apply END handler/; +ok( $match, 52 ); diff --git a/lib/CPAN.pm b/lib/CPAN.pm index cde8389..1ec2733 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1095,6 +1095,36 @@ sub init { 1; } +# This is a piece of repeated code that is abstracted here for +# maintainability. RMB +# +sub _configpmtest { + my($configpmdir, $configpmtest) = @_; + if (-w $configpmtest) { + return $configpmtest; + } elsif (-w $configpmdir) { + #_#_# following code dumped core on me with 5.003_11, a.k. + my $configpm_bak = "$configpmtest.bak"; + unlink $configpm_bak if -f $configpm_bak; + if( -f $configpmtest ) { + if( rename $configpmtest, $configpm_bak ) { + $CPAN::Frontend->mywarn(<new; + if ($fh->open(">$configpmtest")) { + $fh->print("1;\n"); + return $configpmtest; + } else { + # Should never happen + Carp::confess("Cannot open >$configpmtest"); + } + } else { return } +} + #-> sub CPAN::Config::load ; sub load { my($self) = shift; @@ -1125,39 +1155,14 @@ sub load { my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN"); my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm"); if (-d $configpmdir or File::Path::mkpath($configpmdir)) { - if (-w $configpmtest) { - $configpm = $configpmtest; - } elsif (-w $configpmdir) { - #_#_# following code dumped core on me with 5.003_11, a.k. - unlink "$configpmtest.bak" if -f "$configpmtest.bak"; - rename $configpmtest, "$configpmtest.bak" if -f $configpmtest; - my $fh = FileHandle->new; - if ($fh->open(">$configpmtest")) { - $fh->print("1;\n"); - $configpm = $configpmtest; - } else { - # Should never happen - Carp::confess("Cannot open >$configpmtest"); - } - } + $configpm = _configpmtest($configpmdir,$configpmtest); } unless ($configpm) { $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN"); File::Path::mkpath($configpmdir); $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm"); - if (-w $configpmtest) { - $configpm = $configpmtest; - } elsif (-w $configpmdir) { - #_#_# following code dumped core on me with 5.003_11, a.k. - my $fh = FileHandle->new; - if ($fh->open(">$configpmtest")) { - $fh->print("1;\n"); - $configpm = $configpmtest; - } else { - # Should never happen - Carp::confess("Cannot open >$configpmtest"); - } - } else { + $configpm = _configpmtest($configpmdir,$configpmtest); + unless ($configpm) { Carp::confess(qq{WARNING: CPAN.pm is unable to }. qq{create a configuration file.}); } diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 19d30b0..400366c 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -9,7 +9,7 @@ package Math::Complex; our($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $Inf); -$VERSION = 1.32; +$VERSION = 1.34; BEGIN { unless ($^O eq 'unicosmk') { @@ -37,6 +37,9 @@ use strict; my $i; my %LOGN; +# Regular expression for floating point numbers. +my $gre = qr'\s*([\+\-]?(?:(?:(?:\d+(?:_\d+)*(?:\.\d*(?:_\d+)*)?|\.\d+(?:_\d+)*)(?:[eE][\+\-]?\d+(?:_\d+)*)?)))'; + require Exporter; @ISA = qw(Exporter); @@ -108,6 +111,26 @@ sub _cannot_make { die "@{[(caller(1))[3]]}: Cannot take $_[0] of $_[1].\n"; } +sub _remake { + my $arg = shift; + my ($made, $p, $q); + + if ($arg =~ /^(?:$gre)?$gre\s*i\s*$/) { + ($p, $q) = ($1 || 0, $2); + $made = 'cart'; + } elsif ($arg =~ /^\s*\[\s*$gre\s*(?:,\s*$gre\s*)?\]\s*$/) { + ($p, $q) = ($1, $2 || 0); + $made = 'exp'; + } + + if ($made) { + $p =~ s/^\+//; + $q =~ s/^\+//; + } + + return ($made, $p, $q); +} + # # ->make # @@ -116,6 +139,16 @@ sub _cannot_make { sub make { my $self = bless {}, shift; my ($re, $im) = @_; + if (@_ == 1) { + my ($remade, $p, $q) = _remake($re); + if ($remade) { + if ($remade eq 'cart') { + ($re, $im) = ($p, $q); + } else { + return (ref $self)->emake($p, $q); + } + } + } my $rre = ref $re; if ( $rre ) { if ( $rre eq ref $self ) { @@ -132,6 +165,9 @@ sub make { _cannot_make("imaginary part", $rim); } } + _cannot_make("real part", $re) unless $re =~ /^$gre$/; + $im ||= 0; + _cannot_make("imaginary part", $im) unless $im =~ /^$gre$/; $self->{'cartesian'} = [ $re, $im ]; $self->{c_dirty} = 0; $self->{p_dirty} = 1; @@ -147,6 +183,16 @@ sub make { sub emake { my $self = bless {}, shift; my ($rho, $theta) = @_; + if (@_ == 1) { + my ($remade, $p, $q) = _remake($rho); + if ($remade) { + if ($remade eq 'exp') { + ($rho, $theta) = ($p, $q); + } else { + return (ref $self)->make($p, $q); + } + } + } my $rrh = ref $rho; if ( $rrh ) { if ( $rrh eq ref $self ) { @@ -167,6 +213,9 @@ sub emake { $rho = -$rho; $theta = ($theta <= 0) ? $theta + pi() : $theta - pi(); } + _cannot_make("rho", $rho) unless $rho =~ /^$gre$/; + $theta ||= 0; + _cannot_make("theta", $theta) unless $theta =~ /^$gre$/; $self->{'polar'} = [$rho, $theta]; $self->{p_dirty} = 0; $self->{c_dirty} = 1; @@ -183,8 +232,7 @@ sub new { &make } # For backward compatibility only. # This avoids the burden of writing Math::Complex->make(re, im). # sub cplx { - my ($re, $im) = @_; - return __PACKAGE__->make($re, defined $im ? $im : 0); + return __PACKAGE__->make(@_); } # @@ -194,8 +242,7 @@ sub cplx { # This avoids the burden of writing Math::Complex->emake(rho, theta). # sub cplxe { - my ($rho, $theta) = @_; - return __PACKAGE__->emake($rho, defined $theta ? $theta : 0); + return __PACKAGE__->emake(@_); } # @@ -1713,13 +1760,25 @@ but that will be silently converted into C<[3,-3pi/4]>, since the modulus must be non-negative (it represents the distance to the origin in the complex plane). -It is also possible to have a complex number as either argument of -either the C or C: the appropriate component of +It is also possible to have a complex number as either argument of the +C, C, C, and C: the appropriate component of the argument will be used. $z1 = cplx(-2, 1); $z2 = cplx($z1, 4); +The C, C, C, C, and C will also +understand a single (string) argument of the forms + + 2-3i + -3i + [2,3] + [2] + +in which case the appropriate cartesian and exponential components +will be parsed from the string and used to create new complex numbers. +The imaginary component and the theta, respectively, will default to zero. + =head1 STRINGIFICATION When printed, a complex number is usually shown under its cartesian @@ -1877,10 +1936,10 @@ Whatever it is, it does not manifest itself anywhere else where Perl runs. =head1 AUTHORS -Raphael Manfredi > and -Jarkko Hietaniemi >. +Daniel S. Lewart > -Extensive patches by Daniel S. Lewart >. +Original authors Raphael Manfredi > and +Jarkko Hietaniemi > =cut diff --git a/lib/Math/Complex.t b/lib/Math/Complex.t index 334374d..555d5b5 100755 --- a/lib/Math/Complex.t +++ b/lib/Math/Complex.t @@ -16,7 +16,7 @@ use Math::Complex; use vars qw($VERSION); -$VERSION = 1.91; +$VERSION = 1.92; my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); @@ -303,6 +303,42 @@ EOS test_display_format(); +sub test_remake { + $test++; + push @script, <make(2,3); + print "ok $test\n"; +EOS + + $test++; + push @script, <make('3i'); + print "not " unless \$z == cplx(0,3); + print "ok $test\n"; +EOS + + $test++; + push @script, <emake(2,3); + print "ok $test\n"; +EOS + + $test++; + push @script, <emake('[2]'); + print "not " unless \$z == cplxe(2); + print "ok $test\n"; +EOS +} + +test_remake(); + print "1..$test\n"; eval join '', @script; die $@ if $@; diff --git a/lib/open.pm b/lib/open.pm index 7eaea0f..b535d88 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -66,7 +66,7 @@ sub import { $type = 'IO'; $dscp = ":$1"; } else { - $dscp = shift(@args); + $dscp = shift(@args) || ''; } my @val; foreach my $layer (split(/\s+/,$dscp)) { @@ -123,7 +123,7 @@ open - perl pragma to set default disciplines for input and output use open IO => ":encoding(iso-8859-7)"; use open IO => ':locale'; - + use open ':utf8'; use open ':locale'; use open ':encoding(iso-8859-7)'; diff --git a/patchlevel.h b/patchlevel.h index e6ae688..d69d01c 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -79,7 +79,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL14470" + ,"DEVEL14502" ,NULL }; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 2a3f5d0..76fb6aa 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1846,12 +1846,6 @@ effective uids or gids failed. to check the return value of your socket() call? See L. -=item lstat() on filehandle %s - -(W io) You tried to do an lstat on a filehandle. What did you mean -by that? lstat() makes sense only on filenames. (Perl did a fstat() -instead on the filehandle.) - =item Lvalue subs returning %s not implemented yet (F) Due to limitations in the current implementation, array and hash @@ -4184,7 +4178,10 @@ So put in parentheses to say what you really mean. =item Wide character in %s -(W utf8) Perl met a wide character (>255) when it wasn't expecting one. +(W utf8) Perl met a wide character (>255) when it wasn't expecting +one. This warning is by default on for I/O (like print) but can be +turned off by C. You are supposed to explicitly +mark the filehandle with an encoding, see L and L. =item write() on closed filehandle %s @@ -4217,6 +4214,11 @@ supported. it already went past any symlink you are presumably trying to look for. Use a filename instead. +=item You can't use lstat() on a filehandle + +(F) You tried to do an lstat on a filehandle. lstat() makes sense only +on filenames. + =item YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! (F) And you probably never will, because you probably don't have the diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 8efe7cc..ea196c2 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -350,7 +350,9 @@ the special filehandle consisting of a solitary underline, then the stat structure of the previous file test (or stat operator) is used, saving a system call. (This doesn't work with C<-t>, and you need to remember that lstat() and C<-l> will leave values in the stat structure for the -symbolic link, not the real file.) Example: +symbolic link, not the real file.) (Also, if the stat buffer was filled by +a C call, C<-T> and C<-B> will reset it with the results of C). +Example: print "Can do.\n" if -r $a || -w _ || -x _; diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod index ba8f1ca..3703e10 100644 --- a/pod/perluniintro.pod +++ b/pod/perluniintro.pod @@ -147,17 +147,17 @@ Unicode strings. Specifically, if all code points in the string are 0xFF or less, Perl uses the native eight-bit character set. Otherwise, it uses UTF-8. -A user of Perl does not normally need to know nor care how Perl happens -to encodes its internal strings, but it becomes relevant when outputting -Unicode strings to a stream without a discipline (one with the "default -default"). In such a case, the raw bytes used internally (the native -character set or UTF-8, as appropriate for each string) will be used, -and if warnings are turned on, a "Wide character" warning will be issued -if those strings contain a character beyond 0x00FF. +A user of Perl does not normally need to know nor care how Perl +happens to encodes its internal strings, but it becomes relevant when +outputting Unicode strings to a stream without a discipline (one with +the "default default"). In such a case, the raw bytes used internally +(the native character set or UTF-8, as appropriate for each string) +will be used, and a "Wide character" warning will be issued if those +strings contain a character beyond 0x00FF. For example, - perl -w -e 'print "\x{DF}\n", "\x{0100}\x{DF}\n"' + perl -e 'print "\x{DF}\n", "\x{0100}\x{DF}\n"' produces a fairly useless mixture of native bytes and UTF-8, as well as a warning. @@ -275,10 +275,10 @@ Normally, writing out Unicode data produces raw bytes that Perl happens to use to internally encode the Unicode string (which depends on the system, as well as what characters happen to be in the string at the time). If any of the -characters are at code points 0x100 or above, you will get a warning -if you use C<-w> or C. To ensure that the output is -explicitly rendered in the encoding you desire (and to avoid the -warning), open the stream with the desired encoding. Some examples: +characters are at code points 0x100 or above, you will get a warning. +To ensure that the output is explicitly rendered in the encoding you +desire (and to avoid the warning), open the stream with the desired +encoding. Some examples: open FH, ">:ucs2", "file" open FH, ">:utf8", "file"; diff --git a/pp.c b/pp.c index 2d462c4..51facc0 100644 --- a/pp.c +++ b/pp.c @@ -3168,8 +3168,7 @@ PP(pp_chr) if (value > 255 && !IN_BYTES) { SvGROW(TARG, UNISKIP(value)+1); - tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, - UNICODE_ALLOW_SUPER); + tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); SvCUR_set(TARG, tmps - SvPVX(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); diff --git a/pp_sys.c b/pp_sys.c index 3fb4be9..b1ce18a 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -2726,12 +2726,10 @@ PP(pp_stat) if (PL_op->op_flags & OPf_REF) { gv = cGVOP_gv; if (PL_op->op_type == OP_LSTAT) { + if (gv != PL_defgv) + Perl_croak(aTHX_ "You can't use lstat() on a filehandle"); if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); - if (ckWARN(WARN_IO) && gv != PL_defgv) - Perl_warner(aTHX_ WARN_IO, - "lstat() on filehandle %s", GvENAME(gv)); - /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */ } do_fstat: @@ -3311,6 +3309,7 @@ PP(pp_fttext) really_filename: PL_statgv = Nullgv; PL_laststatval = -1; + PL_laststype = OP_STAT; sv_setpv(PL_statname, SvPV(sv, n_a)); if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) diff --git a/regexec.c b/regexec.c index 6512986..70d401d 100644 --- a/regexec.c +++ b/regexec.c @@ -1043,7 +1043,7 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta if ( f != c && (f == c1 || f == c2) && (ln == foldlen || - !ibcmp_utf8((char *)foldbuf, + !ibcmp_utf8((char *) foldbuf, (char **)0, foldlen, do_utf8, m, (char **)0, ln, UTF)) diff --git a/t/io/utf8.t b/t/io/utf8.t index e8caf72..337bd52 100755 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -12,7 +12,7 @@ BEGIN { no utf8; # needed for use utf8 not griping about the raw octets $| = 1; -print "1..26\n"; +print "1..31\n"; open(F,"+>:utf8",'a'); print F chr(0x100).'£'; @@ -186,7 +186,7 @@ if (ord('A') == 193) { close F; unlink('a'); -open F, ">a"; +open F, ">:utf8", "a"; @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000 unshift @a, chr(0); # ... and a null byte in front just for fun print F @a; @@ -216,6 +216,52 @@ for (@a) { close F; print "ok 26\n"; +{ + # Check that warnings are on on I/O, and that they can be muffled. + + local $SIG{__WARN__} = sub { $@ = shift }; + + undef $@; + open F, ">a"; + print F chr(0x100); + close(F); + + print $@ =~ /Wide character in print/ ? "ok 27\n" : "not ok 27\n"; + + undef $@; + open F, ">:utf8", "a"; + print F chr(0x100); + close(F); + + print defined $@ ? "not ok 28\n" : "ok 28\n"; + + undef $@; + open F, ">a"; + binmode(F, ":utf8"); + print F chr(0x100); + close(F); + + print defined $@ ? "not ok 29\n" : "ok 29\n"; + + no warnings 'utf8'; + + undef $@; + open F, ">a"; + print F chr(0x100); + close(F); + + print defined $@ ? "not ok 30\n" : "ok 30\n"; + + use warnings 'utf8'; + + undef $@; + open F, ">a"; + print F chr(0x100); + close(F); + + print $@ =~ /Wide character in print/ ? "ok 31\n" : "not ok 31\n"; +} + # sysread() and syswrite() tested in lib/open.t since Fnctl is used END { @@ -223,4 +269,3 @@ END { 1 while unlink "b"; } - diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys index e30637b..4b9c8b1 100644 --- a/t/lib/warnings/pp_sys +++ b/t/lib/warnings/pp_sys @@ -83,9 +83,6 @@ flock STDIN, 8; flock $a, 8; - The stat preceding lstat() wasn't an lstat %s [pp_stat] - lstat(STDIN); - warn(warn_nl, "stat"); [pp_stat] -T on closed filehandle %s @@ -347,24 +344,6 @@ stat "abc\ndef"; EXPECT Unsuccessful stat on filename containing newline at - line 3. ######## -# pp_sys.c [pp_stat] -use Config; -BEGIN { - if ($^O eq 'd_lstat') { - print < 43); +plan(tests => 44); my @tempfiles = (); @@ -172,3 +172,11 @@ ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ ); is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); pop @INC; + +my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm'; +{ + local @INC; + @INC = sub { $filename = 'seen'; return undef; }; + eval { require $filename; }; + is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' ); +} diff --git a/t/op/lc.t b/t/op/lc.t index 091df87..1fbb3e1 100644 --- a/t/op/lc.t +++ b/t/op/lc.t @@ -82,14 +82,31 @@ ok(lc($b) eq "\x{101}\x{101}aa", 'lc'); # \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is # \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N. -ok("\U\x{DF}ab\x{149}cd" eq "SSAB\x{2BC}NCD", - "multicharacter uppercase"); +# In EBCDIC \x{DF} is LATIN SMALL LETTER Y WITH DIAERESIS, +# and it's uppercase is \x{178}, LATIN CAPITAL LETTER Y WITH DIAERESIS. + +if (ord("A") == 193) { # EBCDIC + ok("\U\x{DF}aB\x{149}cD" eq "\x{178}AB\x{2BC}NCD", + "multicharacter uppercase"); +} elsif (ord("A") == 65) { + ok("\U\x{DF}aB\x{149}cD" eq "SSAB\x{2BC}NCD", + "multicharacter uppercase"); +} else { + ok(0, "what is your encoding?"); +} # The \x{DF} is its own lowercase, ditto for \x{149}. # There are no single character -> multiple characters lowercase mappings. -ok("\L\x{DF}AB\x{149}CD" eq "\x{DF}ab\x{149}cd", - "multicharacter lowercase"); +if (ord("A") == 193) { # EBCDIC + ok("\LaB\x{149}cD" eq "ab\x{149}cd", + "multicharacter lowercase"); +} elsif (ord("A") == 65) { + ok("\L\x{DF}aB\x{149}cD" eq "\x{DF}ab\x{149}cd", + "multicharacter lowercase"); +} else { + ok(0, "what is your encoding?"); +} # titlecase is used for \u / ucfirst. diff --git a/t/op/stat.t b/t/op/stat.t index c3bbe83..ad87c25 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -9,7 +9,7 @@ BEGIN { use Config; use File::Spec; -plan tests => 69; +plan tests => 75; my $Perl = which_perl(); @@ -106,6 +106,8 @@ SKIP: { # Check if you are on a tmpfs of some sort. Building in /tmp sometimes # has this problem. Also building on the ClearCase VOBS filesystem may # cause this failure. +# Darwins UFS doesn't have a ctime concept, and thus is +# expected to fail this test. DIAG } } @@ -376,3 +378,36 @@ unlink $tmpfile or print "# unlink failed: $!\n"; # bug id 20011101.069 my @r = \stat("."); is(scalar @r, 13, 'stat returns full 13 elements'); + +SKIP: { + skip "No lstat", 2 unless $Config{d_lstat}; + + stat $0; + eval { lstat _ }; + like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, + 'lstat _ croaks after stat' ); + eval { -l _ }; + like( $@, qr/^The stat preceding -l _ wasn't an lstat/, + '-l _ croaks after stat' ); + + eval { lstat STDIN }; + like( $@, qr/^You can't use lstat\(\) on a filehandle/, + 'lstat FILEHANDLE croaks' ); + eval { -l STDIN }; + like( $@, qr/^You can't use -l on a filehandle/, + '-l FILEHANDLE croaks' ); + + # bug id 20020124.004 + # If we have d_lstat, we should have symlink() + my $linkname = 'dolzero'; + symlink $0, $linkname or die "# Can't symlink $0: $!"; + lstat $linkname; + -T _; + eval { lstat _ }; + like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/, + 'lstat croaks after -T _' ); + eval { -l _ }; + like( $@, qr/^The stat preceding -l _ wasn't an lstat/, + '-l _ croaks after -T _' ); + unlink $linkname or print "# unlink $linkname failed: $!\n"; +} diff --git a/t/run/switches.t b/t/run/switches.t index f920f37..996ad5d 100644 --- a/t/run/switches.t +++ b/t/run/switches.t @@ -9,10 +9,11 @@ BEGIN { require "./test.pl"; -plan(tests => 14); +plan(tests => 19); # due to a bug in VMS's piping which makes it impossible for runperl() -# to emulate echo -n, these tests almost totally fail. +# to emulate echo -n (ie. stdin always winds up with a newline), these +# tests almost totally fail. $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS'; my $r; @@ -169,3 +170,33 @@ SWTESTPM is( $r, '', '-m with import parameters' ); push @tmpfiles, $filename; } + +# Tests for -V + +{ + local $TODO = ''; # these ones should work on VMS + + # basic perl -V should generate significant output. + # we don't test actual format since it could change + like( runperl( switches => ['-V'] ), qr/(\n.*){20}/, + '-V generates 20+ lines' ); + + # lookup a known config var + chomp( $r=runperl( switches => ['-V:osname'] ) ); + is( $r, "osname='$^O';", 'perl -V:osname'); + + # lookup a nonexistent var + chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) ); + is( $r, "this_var_makes_switches_test_fail='UNKNOWN';", + 'perl -V:unknown var'); + + # regexp lookup + # platforms that don't like this quoting can either skip this test + # or fix test.pl _quote_args + $r = runperl( switches => ['"-V:i\D+size"'] ); + # should be unlike( $r, qr/^$|not found|UNKNOWN/ ); + like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' ); + + # make sure each line we got matches the re + ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' ); +} diff --git a/utf8.c b/utf8.c index 6bb259c..60933cd 100644 --- a/utf8.c +++ b/utf8.c @@ -54,7 +54,7 @@ is the recommended Unicode-aware way of saying U8 * Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) { - if (ckWARN_d(WARN_UTF8)) { + if (ckWARN(WARN_UTF8)) { if (UNICODE_IS_SURROGATE(uv) && !(flags & UNICODE_ALLOW_SURROGATE)) Perl_warner(aTHX_ WARN_UTF8, "UTF-16 surrogate 0x%04"UVxf, uv); @@ -1285,16 +1285,14 @@ to the hash is by Perl_to_utf8_case(). */ UV -Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special) +Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special) { UV uv; if (!*swashp) *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0); uv = swash_fetch(*swashp, p, TRUE); - if (uv) - uv = UNI_TO_NATIVE(uv); - else { + if (!uv) { HV *hv; SV *keysv; HE *he; @@ -1307,6 +1305,7 @@ Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal SV *val = HeVAL(he); char *s = SvPV(val, *lenp); U8 c = *(U8*)s; + if (*lenp > 1 || UNI_IS_INVARIANT(c)) Copy(s, ustrp, *lenp, U8); else { @@ -1315,8 +1314,24 @@ Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal ustrp[1] = UTF8_EIGHT_BIT_LO(c); *lenp = 2; } +#ifdef EBCDIC + { + U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; + U8 *d = tmpbuf; + U8 *t, *tend; + STRLEN tlen; + + for (t = ustrp, tend = t + *lenp; t < tend; t += tlen) { + UV c = utf8_to_uvchr(t, &tlen); + d = uvchr_to_utf8(d, UNI_TO_NATIVE(c)); + } + *lenp = d - tmpbuf; + Copy(tmpbuf, ustrp, *lenp, U8); + } +#endif return utf8_to_uvchr(ustrp, 0); } + uv = NATIVE_TO_UNI(uv); } if (lenp) *lenp = UNISKIP(uv); @@ -1793,6 +1808,9 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)) return 1; /* mismatch; possible infinite loop or false positive */ + if (!u1 || !u2) + natbuf[1] = 0; /* Need to terminate the buffer. */ + while ((e1 == 0 || p1 < e1) && (f1 == 0 || p1 < f1) && (e2 == 0 || p2 < e2) &&