[inseparable changes from patch from perl5.003_17 to perl5.003_18]

 CORE LANGUAGE CHANGES

Subject: Inherited overloading
Date: Sun, 29 Dec 1996 08:12:54 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: gv.c lib/overload.pm perl.h sv.c sv.h t/op/overload.t

    Chip Salzenberg writes:
    > 
    > Patch now, tarchive later:
    
    Below is the fixed overloading patch.
    
    Note that in between AMG_names got const on it (a good thing!), but as
    a corollary I needed to cast away const-ness to actually use it
    (since, say, newSVpv does not have const args).
    
    Enjoy,
    
    p5p-msgid: <199612291312.IAA02134@monk.mps.ohio-state.edu>

Subject: Closures at file scope must be anonymous
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c

Subject: Warn on '{if,while} ($x = X)' where X is glob, readdir, or <FH>
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c pod/perldiag.pod

 DOCUMENTATION

Subject: Re: perldiag.pod entry for "Scalar value @%s{%s} ..."
Date: Tue, 31 Dec 1996 11:50:19 -0500
From: Roderick Schertler <roderick@gate.net>
Files: pod/perldiag.pod
Msg-ID: <2043.852051019@eeyore.ibcinc.com>

    (applied based on p5p patch as commit c885792efecf3f527b3b5099727cc16b03eee1dc)

 OTHER CORE CHANGES

Subject: Get rid of 'Leaked scalars'
From: Chip Salzenberg <chip@atlantic.net>
Files: cop.h gv.c op.c

 TESTS

Subject: Expanded locale.t and misc.t
From: Jarkko Hietaniemi <jhi@cc.hut.fi>
Files: t/lib/locale.t t/lib/misc.t

Subject: Expanded my.t
From: Chip Salzenberg <chip@atlantic.net>
Files: t/lib/my.t

4 files changed, 326 insertions, 52 deletions

diff --git a/t/lib/locale.t b/t/lib/locale.t
index 83fa46bd73..7f8c858f1f 100755
--- a/t/lib/locale.t
+++ b/t/lib/locale.t
@@ -1,6 +1,6 @@
 #!./perl -wT
 
-print "1..67\n";
+print "1..104\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -74,15 +74,15 @@ check_taint      19, $+;
 check_taint      20, $1;
 check_taint_not  21, $2;
 
-/(\W)/;	# taint $&, $`, $', $+, $1.
-check_taint      22, $&;
-check_taint      23, $`;
-check_taint      24, $';
-check_taint      25, $+;
-check_taint      26, $1;
+/(.)/;	# untaint $&, $`, $', $+, $1.
+check_taint_not  22, $&;
+check_taint_not  23, $`;
+check_taint_not  24, $';
+check_taint_not  25, $+;
+check_taint_not  26, $1;
 check_taint_not  27, $2;
 
-/(\s)/;	# taint $&, $`, $', $+, $1.
+/(\W)/;	# taint $&, $`, $', $+, $1.
 check_taint      28, $&;
 check_taint      29, $`;
 check_taint      30, $';
@@ -90,7 +90,7 @@ check_taint      31, $+;
 check_taint      32, $1;
 check_taint_not  33, $2;
 
-/(\S)/;	# taint $&, $`, $', $+, $1.
+/(\s)/;	# taint $&, $`, $', $+, $1.
 check_taint      34, $&;
 check_taint      35, $`;
 check_taint      36, $';
@@ -98,45 +98,105 @@ check_taint      37, $+;
 check_taint      38, $1;
 check_taint_not  39, $2;
 
+/(\S)/;	# taint $&, $`, $', $+, $1.
+check_taint      40, $&;
+check_taint      41, $`;
+check_taint      42, $';
+check_taint      43, $+;
+check_taint      44, $1;
+check_taint_not  45, $2;
+
 $_ = $a;	# untaint $_
 
-check_taint_not  40, $_;
+check_taint_not  46, $_;
 
 /(b)/;		# this must not taint
-check_taint_not  41, $&;
-check_taint_not  42, $`;
-check_taint_not  43, $';
-check_taint_not  44, $+;
-check_taint_not  45, $1;
-check_taint_not  46, $2;
+check_taint_not  47, $&;
+check_taint_not  48, $`;
+check_taint_not  49, $';
+check_taint_not  50, $+;
+check_taint_not  51, $1;
+check_taint_not  52, $2;
 
 $_ = $a;	# untaint $_
 
-check_taint_not  47, $_;
+check_taint_not  53, $_;
 
 $b = uc($a);	# taint $b
 s/(.+)/$b/;	# this must taint only the $_
 
-check_taint      48, $_;
-check_taint_not  49, $&;
-check_taint_not  50, $`;
-check_taint_not  51, $';
-check_taint_not  52, $+;
-check_taint_not  53, $1;
-check_taint_not  54, $2;
+check_taint      54, $_;
+check_taint_not  55, $&;
+check_taint_not  56, $`;
+check_taint_not  57, $';
+check_taint_not  58, $+;
+check_taint_not  59, $1;
+check_taint_not  60, $2;
 
 $_ = $a;	# untaint $_
 
 s/(.+)/b/;	# this must not taint
-check_taint_not  55, $_;
-check_taint_not  56, $&;
-check_taint_not  57, $`;
-check_taint_not  58, $';
-check_taint_not  59, $+;
-check_taint_not  60, $1;
-check_taint_not  61, $2;
+check_taint_not  61, $_;
+check_taint_not  62, $&;
+check_taint_not  63, $`;
+check_taint_not  64, $';
+check_taint_not  65, $+;
+check_taint_not  66, $1;
+check_taint_not  67, $2;
+
+$b = $a;	# untaint $b
+
+($b = $a) =~ s/\w/$&/;
+check_taint      68, $b;	# $b should be tainted.
+check_taint_not  69, $a;	# $a should be not.
+
+$_ = $a;	# untaint $_
+
+s/(\w)/\l$1/;	# this must taint
+check_taint      70, $_;
+check_taint      71, $&;
+check_taint      72, $`;
+check_taint      73, $';
+check_taint      74, $+;
+check_taint      75, $1;
+check_taint_not  76, $2;
+
+$_ = $a;	# untaint $_
+
+s/(\w)/\L$1/;	# this must taint
+check_taint      77, $_;
+check_taint      78, $&;
+check_taint      79, $`;
+check_taint      80, $';
+check_taint      81, $+;
+check_taint      82, $1;
+check_taint_not  83, $2;
+
+$_ = $a;	# untaint $_
+
+s/(\w)/\u$1/;	# this must taint
+check_taint      84, $_;
+check_taint      85, $&;
+check_taint      86, $`;
+check_taint      87, $';
+check_taint      88, $+;
+check_taint      89, $1;
+check_taint_not  90, $2;
 
-check_taint_not  62, $a;
+$_ = $a;	# untaint $_
+
+s/(\w)/\U$1/;	# this must taint
+check_taint      91, $_;
+check_taint      92, $&;
+check_taint      93, $`;
+check_taint      94, $';
+check_taint      95, $+;
+check_taint      96, $1;
+check_taint_not  97, $2;
+
+# After all this tainting $a should be cool.
+
+check_taint_not  98, $a;
 
 # I think we've seen quite enough of taint.
 # Let us do some *real* locale work now.
@@ -246,7 +306,8 @@ for (@Locale) {
 
 # Cross-check the upper and the lower.
 # Yes, this is broken when the upper<->lower changes the number of
-# the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature.
+# the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature,
+# or the Dutch IJ or the Spanish LL or ...)
 # But so far all the implementations do this wrong so we can do it wrong too.
 
 for (keys %UPPER) {
@@ -257,7 +318,7 @@ for (keys %UPPER) {
 	}
     }
 }
-print "ok 63\n";
+print "ok 99\n";
 
 for (keys %lower) {
     if (defined $UPPER{$lower{$_}}) {
@@ -267,7 +328,7 @@ for (keys %lower) {
 	}
     }
 }
-print "ok 64\n";
+print "ok 100\n";
 
 # Find the alphabets that are not alphabets in the default locale.
 
@@ -290,15 +351,18 @@ print "ok 64\n";
 
     print 'not ' if ($1 ne $word);
 }
-print "ok 65\n";
+print "ok 101\n";
 
 # Find places where the collation order differs from the default locale.
 
 {
-    no locale;
+    my (@k, $i, $j, @d);
 
-    my @k = sort (keys %UPPER, keys %lower); 
-    my ($i, $j, @d);
+    {
+	no locale;
+
+	@k = sort (keys %UPPER, keys %lower); 
+    }
 
     for ($i = 0; $i < @k; $i++) {
 	for ($j = $i + 1; $j < @k; $j++) {
@@ -312,10 +376,15 @@ print "ok 65\n";
 
     for (@d) {
 	($i, $j) = @$_;
-	print 'not ' if ($i le $j or not (($i cmp $j) == 1));
+	if ($i gt $j) {
+	    print "# i = $i, j = $j, i ",
+	          $i le $j ? 'le' : 'gt', " j\n";
+	    print 'not ';
+	    last;
+	}
     }
 }
-print "ok 66\n";
+print "ok 102\n";
 
 # Cross-check whole character set.
 
@@ -325,7 +394,47 @@ for (map { chr } 0..255) {
     if (/\s/ and /\S/) { print 'not '; last }
     if (/\w/ and /\D/ and not /_/ and
 	not (exists $UPPER{$_} or exists $lower{$_})) {
-	print 'not '; last
+	print 'not ';
+	last;
+    }
+}
+print "ok 103\n";
+
+# The @Locale should be internally consistent.
+
+{
+    my ($from, $to, , $lesser, $greater);
+
+    for (0..9) {
+	# Select a slice.
+	$from = int(($_*@Locale)/10);
+	$to = $from + int(@Locale/10);
+        $to = $#Locale if ($to > $#Locale);
+	$lesser  = join('', @Locale[$from..$to]);
+	# Select a slice one character on.
+	$from++; $to++;
+        $to = $#Locale if ($to > $#Locale);
+	$greater = join('', @Locale[$from..$to]);
+	if (not ($lesser  lt $greater) or
+	    not ($lesser  le $greater) or
+	    not ($lesser  ne $greater) or
+	        ($lesser  eq $greater) or
+	        ($lesser  ge $greater) or
+	        ($lesser  gt $greater) or
+	        ($greater lt $lesser ) or
+	        ($greater le $lesser ) or
+	    not ($greater ne $lesser ) or
+	        ($greater eq $lesser ) or
+	    not ($greater ge $lesser ) or
+	    not ($greater gt $lesser ) or
+	    # Well, these two are sort of redundant because @Locale
+	    # was derived using cmp.
+	    not (($lesser  cmp $greater) == -1) or
+	    not (($greater cmp $lesser ) ==  1)
+	   ) {
+	    print 'not ';
+	    last;
+	}
     }
 }
-print "ok 67\n";
+print "ok 104\n";
diff --git a/t/op/misc.t b/t/op/misc.t
index 5bcc6a02a8..5b94e034bb 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -204,3 +204,54 @@ EXPECT
 This is a reversed sentence.
 -- Out of inspiration --
 and destroyed as well
+########
+my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
+EXPECT
+2 2 2
+########
+@a = ($a, $b, $c, $d) = (5, 6);
+print "ok\n"
+  if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
+EXPECT
+ok
+########
+print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
+EXPECT
+ok
+########
+print "ok\n" if ("\0" cmp "\xFF");
+EXPECT
+ok
+########
+open(H,'op/misc.t'); # must be in the 't' directory
+stat(H);
+print "ok\n" if (-e _ and -f _ and -r _);
+EXPECT
+ok
+########
+sub thing { 0 || return qw(now is the time) }
+print thing(), "\n";
+EXPECT
+nowisthetime
+########
+$ren = 'joy';
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print $ren, ' ' }
+print $ren, "\n";
+EXPECT
+happy joy
+########
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
+print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
+EXPECT
+happy joy
+########
+package p;
+sub func { print 'really ' unless wantarray; 'p' }
+sub groovy { 'groovy' }
+package main;
+print p::func()->groovy(), "\n"
+EXPECT
+really groovy
+########
diff --git a/t/op/my.t b/t/op/my.t
index 4ce020f206..06c6963534 100755
--- a/t/op/my.t
+++ b/t/op/my.t
@@ -1,8 +1,8 @@
 #!./perl
 
-# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
+# $RCSfile: my.t,v $
 
-print "1..20\n";
+print "1..28\n";
 
 sub foo {
     my($a, $b) = @_;
@@ -44,3 +44,42 @@ $d{''} = "ok 18\n";
 print &foo2("ok 11\n","ok 12\n");
 
 print $a,@b,@c,%d,$x,$y;
+
+my $i = "outer";
+
+if (my $i = "inner") {
+    print "not " if $i ne "inner";
+}
+print "ok 21\n";
+
+if ((my $i = 1) == 0) {
+    print "not ";
+}
+else {
+    print "not" if $i != 1;
+}
+print "ok 22\n";
+
+my $j = 5;
+while (my $i = --$j) {
+    print("not "), last unless $i > 0;
+}
+continue {
+    print("not "), last unless $i > 0;
+}
+print "ok 23\n";
+
+$j = 5;
+for (my $i = 0; (my $k = $i) < $j; ++$i) {
+    print("not "), last unless $i >= 0 && $i < $j && $i == $k;
+}
+print "ok 24\n";
+print "not " if defined $k;
+print "ok 25\n";
+
+foreach my $i (26, 27) {
+    print "ok $i\n";
+}
+
+print "not " if $i ne "outer";
+print "ok 28\n";
diff --git a/t/op/overload.t b/t/op/overload.t
index fca26b4085..9c897c31dc 100755
--- a/t/op/overload.t
+++ b/t/op/overload.t
@@ -33,7 +33,7 @@ qw(
 
 sub new {
   my $foo = $_[1];
-  bless \$foo;
+  bless \$foo, $_[0];
 }
 
 sub stringify { "${$_[0]}" }
@@ -55,7 +55,9 @@ $a = new Oscalar "087";
 $b= "$a";
 
 # All test numbers in comments are off by 1.
-# So much for hard-wiring them in :-)
+# So much for hard-wiring them in :-) To fix this:
+test(1);			# 1
+
 test ($b eq $a);		# 2
 test ($b eq "087");		# 3
 test (ref $a eq "Oscalar");	# 4
@@ -255,16 +257,89 @@ $a=new Oscalar "xx";
 
 test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
 
+# Check inheritance of overloading;
+{
+  package OscalarI;
+  @ISA = 'Oscalar';
+}
+
+$aI = new OscalarI "$a";
+test (ref $aI eq "OscalarI");	# 89
+test ("$aI" eq "xx");		# 90
+test ($aI eq "xx");		# 91
+test ("b${aI}c" eq "_._.b.__.xx._.__.c._");		# 92
+
 # Here we test blessing to a package updates hash
 
 eval "package Oscalar; no overload '.'";
 
-test ("b${a}" eq "_.b.__.xx._"); # 89
+test ("b${a}" eq "_.b.__.xx._"); # 93
 $x="1";
 bless \$x, Oscalar;
-test ("b${a}c" eq "bxxc");	# 90
+test ("b${a}c" eq "bxxc");	# 94
 new Oscalar 1;
-test ("b${a}c" eq "bxxc");	# 91
+test ("b${a}c" eq "bxxc");	# 95
+
+# Negative overloading:
+
+$na = eval { ~$a };
+test($@ =~ /no method found/);	# 96
+
+# Check AUTOLOADING:
+
+*Oscalar::AUTOLOAD = 
+  sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
+	goto &{"Oscalar::$AUTOLOAD"}};
+
+eval "package Oscalar; use overload '~' => 'comple'";
+
+$na = eval { ~$a };		# Hash was not updated
+test($@ =~ /no method found/);	# 97
+
+bless \$x, Oscalar;
+
+$na = eval { ~$a };		# Hash updated
+test !$@;			# 98
+test($na eq '_!_xx_!_');	# 99
+
+$na = 0;
+
+$na = eval { ~$aI };		# Hash was not updated
+test($@ =~ /no method found/);	# 100
+
+bless \$x, OscalarI;
+
+$na = eval { ~$aI };
+print $@;
+
+test !$@;			# 101
+test($na eq '_!_xx_!_');	# 102
+
+eval "package Oscalar; use overload '>>' => 'rshft'";
+
+$na = eval { $aI >> 1 };	# Hash was not updated
+test($@ =~ /no method found/);	# 103
+
+bless \$x, OscalarI;
+
+$na = 0;
+
+$na = eval { $aI >> 1 };
+print $@;
+
+test !$@;			# 104
+test($na eq '_!_xx_!_');	# 105
+
+test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
+test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
+test (overload::Overloaded($aI)); # 108
+test (!overload::Overloaded('overload')); # 109
+
+test (! defined overload::Method($aI, '<<')); # 110
+test (! defined overload::Method($a, '<')); # 111
+
+test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
+test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
 
-# Last test is number 90.
-sub last {90}
+# Last test is:
+sub last {113}