This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
authorNick Ing-Simmons <nik@tiuk.ti.com>
Mon, 11 Dec 2000 23:59:59 +0000 (23:59 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Mon, 11 Dec 2000 23:59:59 +0000 (23:59 +0000)
p4raw-id: //depot/perlio@8088

16 files changed:
ext/B/B.pm
ext/B/B/Deparse.pm
installperl
lib/CGI.pm
lib/ExtUtils/MM_Unix.pm
lib/ExtUtils/MakeMaker.pm
pod/perldiag.pod
pod/perlop.pod
pp.c
pp_hot.c
scope.c
t/io/utf8.t
t/lib/b.t
t/op/local.t
t/pragma/warn/toke
toke.c

index a9ea704..982395b 100644 (file)
@@ -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";
 }
index 7d16752..37c0855 100644 (file)
@@ -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);
index 99d376f..f3788cf 100755 (executable)
@@ -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;
index e9c916f..617c605 100644 (file)
@@ -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';
index e926ca7..c88f8f7 100644 (file)
@@ -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
index 7edcfed..78175f9 100644 (file)
@@ -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<make> and will be installed during C<make install>.
 
 =item MAP_TARGET
 
index 830faab..9baf175 100644 (file)
@@ -59,17 +59,6 @@ L<perlfunc/accept>.
 (F) The '!' is allowed in pack() and unpack() only after certain types.
 See L<perlfunc/pack>.
 
-=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<r w x o R W X O e z s
-f d l p S u g k b c t T B M A 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
index 70fef45..0bb506d 100644 (file)
@@ -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 (file)
--- 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;
        }
index 979d111..2dedcdd 100644 (file)
--- 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 (file)
--- 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;
index f4be69d..ea19a05 100755 (executable)
@@ -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 = <F>;
+chomp($x);
+print "not " unless $x eq chr(300);
+print "ok 14\n";
+
+open F, "a" or die $!; # Not UTF
+$x = <F>;
+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 = <F>;
+chomp($x);
+print "not " unless $x eq v196.172.194.130;
+print "ok 20\n";
+
+open F, "<:utf8", "a" or die $!;
+$x = <F>;
+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 = <F>; 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 = <F>; 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 = <F>; chomp $x;
+{ local $SIG{__WARN__} = sub { print "ok 25\n"; };
+eval { sprintf "%vd\n", $x; }
+}
+
+unlink('a');
 
index ee49213..cd5d61a 100755 (executable)
--- 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($_ = <ARGV>)) {
     @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;
+}
index b478e01..781afa5 100755 (executable)
@@ -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"; 
+}
index 1f8b142..2c9433b 100644 (file)
@@ -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 (file)
--- 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;
            }
        }