From 360eb788a3c30916019278c140e3ebfb207f591f Mon Sep 17 00:00:00 2001 From: Nick Ing-Simmons Date: Mon, 11 Dec 2000 23:59:59 +0000 Subject: [PATCH] Integrate mainline p4raw-id: //depot/perlio@8088 --- ext/B/B.pm | 12 ++--- ext/B/B/Deparse.pm | 6 ++- installperl | 4 +- lib/CGI.pm | 14 +++--- lib/ExtUtils/MM_Unix.pm | 1 + lib/ExtUtils/MakeMaker.pm | 9 ++-- pod/perldiag.pod | 11 ----- pod/perlop.pod | 9 +++- pp.c | 12 ++++- pp_hot.c | 13 +++++- scope.c | 1 - t/io/utf8.t | 109 +++++++++++++++++++++++++++++++++++++++++++++- t/lib/b.t | 16 +++++-- t/op/local.t | 13 +++++- t/pragma/warn/toke | 19 -------- toke.c | 7 ++- 16 files changed, 188 insertions(+), 68 deletions(-) diff --git a/ext/B/B.pm b/ext/B/B.pm index a9ea704..982395b 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -9,12 +9,16 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); + +# walkoptree comes from B.pm (you are there), walkoptree comes from B.xs @EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object opnumber amagic_generation + main_root main_start main_cv svref_2object opnumber + amagic_generation walkoptree_slow walkoptree walkoptree_exec walksymtable parents comppadlist sv_undef compile_stats timing_info begin_av init_av end_av); + sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @@ -80,7 +84,7 @@ sub peekop { return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); } -sub walkoptree { +sub walkoptree_slow { my($op, $method, $level) = @_; $op_count++; # just for statistics $level ||= 0; @@ -90,14 +94,12 @@ sub walkoptree { my $kid; unshift(@parents, $op); for ($kid = $op->first; $$kid; $kid = $kid->sibling) { - walkoptree($kid, $method, $level + 1); + walkoptree_slow($kid, $method, $level + 1); } shift @parents; } } -*walkoptree_slow = \&walkoptree; # Who is using this? - sub compile_stats { return "Total number of OPs processed: $op_count\n"; } diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 7d16752..37c0855 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -1792,7 +1792,7 @@ sub pp_leaveloop { my $state = $kid->first; my $cuddle = $self->{'cuddle'}; my($expr, @exprs); - for (; $$state != $$cont; $state = $state->sibling) { + for (; $$state != $$cont and can $state "sibling"; $state = $state->sibling) { $expr = ""; if (is_state $state) { $expr = $self->deparse($state, 0); @@ -1803,8 +1803,12 @@ sub pp_leaveloop { push @exprs, $expr if $expr; } $kid = join(";\n", @exprs); + if (class($cont) eq "LISTOP") { $cont = $cuddle . "continue {\n\t" . $self->deparse($cont, 0) . "\n\b}\cK"; + } else { + $cont = "\cK"; + } } else { $cont = "\cK"; $kid = $self->deparse($kid, 0); diff --git a/installperl b/installperl index 99d376f..f3788cf 100755 --- a/installperl +++ b/installperl @@ -162,8 +162,8 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid; -f 't/rantests' || $Is_W32 - || warn "WARNING: You've never run 'make test'!!!", - " (Installing anyway.)\n"; + || warn "WARNING: You've never run 'make test' or", + " some tests failed! (Installing anyway.)\n"; if ($Is_W32 or $Is_Cygwin) { my $perldll; diff --git a/lib/CGI.pm b/lib/CGI.pm index e9c916f..617c605 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -107,19 +107,17 @@ unless ($OS) { $OS = $Config::Config{'osname'}; } } -if ($OS=~/Win/i) { +if ($OS =~ /^MSWin/i) { $OS = 'WINDOWS'; -} elsif ($OS=~/vms/i) { +} elsif ($OS =~ /^VMS/i) { $OS = 'VMS'; -} elsif ($OS=~/bsdos/i) { - $OS = 'UNIX'; -} elsif ($OS=~/dos/i) { +} elsif ($OS =~ /^dos/i) { $OS = 'DOS'; -} elsif ($OS=~/^MacOS$/i) { +} elsif ($OS =~ /^MacOS/i) { $OS = 'MACINTOSH'; -} elsif ($OS=~/os2/i) { +} elsif ($OS =~ /^os2/i) { $OS = 'OS2'; -} elsif ($OS=~/epoc/) { +} elsif ($OS =~ /^epoc/i) { $OS = 'EPOC'; } else { $OS = 'UNIX'; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index e926ca7..c88f8f7 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1712,6 +1712,7 @@ from the perl source tree. $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now my $perl_h; + no warnings 'uninitialized' ; if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")) and not $old){ # Maybe somebody tries to build an extension with an diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 7edcfed..78175f9 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -1519,10 +1519,11 @@ at Configure time. =item MAN3PODS -Hashref of .pm and .pod files. MakeMaker will default this to all - .pod and any .pm files that include POD directives. The files listed -here will be converted to man pages and installed as was requested -at Configure time. +Hashref that assigns to *.pm and *.pod files the files into which the +manpages are to be written. MakeMaker parses all *.pod and *.pm files +for POD directives. Files that contain POD will be the default keys of +the MAN3PODS hashref. These will then be converted to man pages during +C and will be installed during C. =item MAP_TARGET diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 830faab..9baf175 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -59,17 +59,6 @@ L. (F) The '!' is allowed in pack() and unpack() only after certain types. See L. -=item Ambiguous -%c() resolved as a file test - -(W ambiguous) You used a "-" right in front a call to a subroutine -that has the same name as a Perl file test (C). - -To disambiguate it as a subroutine call, use either an extra space after -the "-", C<- f(...)>, or an extra set of parentheses, C<-(f(...))>. -To disambiguate it as a file test, use an extra space after the operator -name C<-f (...)>, or add the space and remove the parentheses, C<-f ...>. - =item Ambiguous call resolved as CORE::%s(), qualify as such or use & (W ambiguous) A subroutine you have declared has the same name as a Perl diff --git a/pod/perlop.pod b/pod/perlop.pod index 70fef45..0bb506d 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -300,8 +300,13 @@ to the right argument. Binary "<=>" returns -1, 0, or 1 depending on whether the left argument is numerically less than, equal to, or greater than the right argument. If your platform supports NaNs (not-a-numbers) as numeric -values, using them with "<=>" (or any other numeric comparison) -returns undef. +values, using them with "<=>" returns undef. NaN is not "<", "==", ">", +"<=" or ">=" anything (even NaN), so those 5 return false. NaN != NaN +returns true, as does NaN != anything else. If your platform doesn't +support NaNs then NaN is just a string with numeric value 0. + + perl -le '$a = NaN; print "No NaN support here" if $a == $a' + perl -le '$a = NaN; print "NaN support here" if $a != $a' Binary "eq" returns true if the left argument is stringwise equal to the right argument. diff --git a/pp.c b/pp.c index f125d56..eaa4d17 100644 --- a/pp.c +++ b/pp.c @@ -2833,6 +2833,7 @@ PP(pp_hslice) while (++MARK <= SP) { SV *keysv = *MARK; SV **svp; + I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0); if (realhv) { HE *he = hv_fetch_ent(hv, keysv, lval, 0); svp = he ? &HeVAL(he) : 0; @@ -2845,8 +2846,15 @@ PP(pp_hslice) STRLEN n_a; DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } - if (PL_op->op_private & OPpLVAL_INTRO) - save_helem(hv, keysv, svp); + if (PL_op->op_private & OPpLVAL_INTRO) { + if (preeminent) + save_helem(hv, keysv, svp); + else { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + save_delete(hv, key, keylen); + } + } } *MARK = svp ? *svp : &PL_sv_undef; } diff --git a/pp_hot.c b/pp_hot.c index 979d111..2dedcdd 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1532,8 +1532,11 @@ PP(pp_helem) U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; + I32 preeminent; if (SvTYPE(hv) == SVt_PVHV) { + if (PL_op->op_private & OPpLVAL_INTRO) + preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0); he = hv_fetch_ent(hv, keysv, lval && !defer, hash); svp = he ? &HeVAL(he) : 0; } @@ -1566,8 +1569,14 @@ PP(pp_helem) if (PL_op->op_private & OPpLVAL_INTRO) { if (HvNAME(hv) && isGV(*svp)) save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); - else - save_helem(hv, keysv, svp); + else { + if (!preeminent) { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + save_delete(hv, key, keylen); + } else + save_helem(hv, keysv, svp); + } } else if (PL_op->op_private & OPpDEREF) vivify_ref(*svp, PL_op->op_private & OPpDEREF); diff --git a/scope.c b/scope.c index 3f41a4e..7c83a41 100644 --- a/scope.c +++ b/scope.c @@ -852,7 +852,6 @@ Perl_leave_scope(pTHX_ I32 base) ptr = SSPOPPTR; (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD); SvREFCNT_dec(hv); - Safefree(ptr); break; case SAVEt_DESTRUCTOR: ptr = SSPOPPTR; diff --git a/t/io/utf8.t b/t/io/utf8.t index f4be69d..ea19a05 100755 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -11,7 +11,7 @@ BEGIN { } $| = 1; -print "1..13\n"; +print "1..25\n"; open(F,"+>:utf8",'a'); print F chr(0x100).'£'; @@ -54,5 +54,110 @@ print "not " unless $buf eq "\x{200}\x{100} print "ok 13\n"; close(F); -# unlink('a'); +{ +$a = chr(300); # This *is* UTF-encoded +$b = chr(130); # This is not. + +open F, ">:utf8", 'a' or die $!; +print F $a,"\n"; +close F; + +open F, "<:utf8", 'a' or die $!; +$x = ; +chomp($x); +print "not " unless $x eq chr(300); +print "ok 14\n"; + +open F, "a" or die $!; # Not UTF +$x = ; +chomp($x); +print "not " unless $x eq chr(196).chr(172); +print "ok 15\n"; +close F; + +open F, ">:utf8", 'a' or die $!; + +print F $a; +my $y; +{ my $x = tell(F); + { use bytes; $y = length($a);} + print "not " unless $x == $y; + print "ok 16\n"; +} + +{ # Check byte length of $b +use bytes; my $y = length($b); +print "not " unless $y == 1; +print "ok 17\n"; +} + +print F $b,"\n"; # This upgrades $b! + +{ # Check byte length of $b +use bytes; my $y = length($b); +print "not " unless $y == 2; +print "ok 18\n"; +} + +{ my $x = tell(F); + { use bytes; $y += 3;} + print "not " unless $x == $y; + print "ok 19\n"; +} + +close F; + +open F, "a" or die $!; # Not UTF +$x = ; +chomp($x); +print "not " unless $x eq v196.172.194.130; +print "ok 20\n"; + +open F, "<:utf8", "a" or die $!; +$x = ; +chomp($x); +close F; +print "not " unless $x eq chr(300).chr(130); +print "ok 21\n"; + +# Now let's make it suffer. +open F, ">", "a" or die $!; +eval { print F $a; }; +print "not " unless $@ and $@ =~ /Wide character in print/i; +print "ok 22\n"; +} + +# Hm. Time to get more evil. +open F, ">:utf8", "a" or die $!; +print F $a; +binmode(F, ":bytes"); +print F chr(130)."\n"; +close F; + +open F, "<", "a" or die $!; +$x = ; chomp $x; +print "not " unless $x eq v196.172.130; +print "ok 23\n"; + +# Right. +open F, ">:utf8", "a" or die $!; +print F $a; +close F; +open F, ">>", "a" or die $!; +print F chr(130)."\n"; +close F; + +open F, "<", "a" or die $!; +$x = ; chomp $x; +print "not " unless $x eq v196.172.130; +print "ok 24\n"; + +# Now we have a deformed file. +open F, "<:utf8", "a" or die $!; +$x = ; chomp $x; +{ local $SIG{__WARN__} = sub { print "ok 25\n"; }; +eval { sprintf "%vd\n", $x; } +} + +unlink('a'); diff --git a/t/lib/b.t b/t/lib/b.t index ee49213..cd5d61a 100755 --- a/t/lib/b.t +++ b/t/lib/b.t @@ -10,7 +10,7 @@ use warnings; use strict; use Config; -print "1..15\n"; +print "1..17\n"; my $test = 1; @@ -78,9 +78,6 @@ LINE: while (defined($_ = )) { @F = split(/\s+/, $_, 0); '???' } -continue { - '???' -} EOF print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; @@ -146,3 +143,14 @@ if ($is_thread) { print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; } ok; + +# Bug 20001204.07 +{ +my $foo = $deparse->coderef2text(sub { { 234; }}); +# Constants don't get optimised here. +print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; +ok; +$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); +print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; +ok; +} diff --git a/t/op/local.t b/t/op/local.t index b478e01..781afa5 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -1,6 +1,6 @@ #!./perl -print "1..69\n"; +print "1..71\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; @@ -235,3 +235,14 @@ while (/(o.+?),/gc) { untie $_; } +{ + # BUG 20001205.22 + my %x; + $x{a} = 1; + { local $x{b} = 1; } + print "not " if exists $x{b}; + print "ok 70\n"; + { local @x{c,d,e}; } + print "not " if exists $x{c}; + print "ok 71\n"; +} diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index 1f8b142..2c9433b 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -123,9 +123,6 @@ toke.c AOK Ambiguous use of %c resolved as operator %c *foo *foo - Ambiguous -f%c call resolved as a file test [yylex] - sub f { }; -f(0) - __END__ # toke.c use warnings 'deprecated' ; @@ -567,19 +564,3 @@ no warnings 'ambiguous'; "@mjd_previously_unused_array"; EXPECT Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. -######## -# toke.c -use warnings 'ambiguous'; -sub f { 24 } --f("TEST"); -print - f("TEST"); -print -(f("TEST")); -print -f ("TEST"); -print -f "TEST"; -sub Q { 42 }; -print -Q(); -EXPECT -Ambiguous -f() resolved as a file test at - line 4. -Ambiguous -f() resolved as a file test at - line 7. --24-2411-42 - diff --git a/toke.c b/toke.c index d8ffc1e..cd6ed1d 100644 --- a/toke.c +++ b/toke.c @@ -2850,15 +2850,14 @@ Perl_yylex(pTHX) DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw file test %c\n", ftst); } ) - if (*s == '(' && ckWARN(WARN_AMBIGUOUS)) - Perl_warner(aTHX_ WARN_AMBIGUOUS, - "Ambiguous -%c() resolved as a file test", - tmp); FTST(ftst); } else { /* Assume it was a minus followed by a one-letter named * subroutine call (or a -bareword), then. */ + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### %c looked like a file test but was not\n", ftst); + } ) s -= 2; } } -- 2.7.4