From 77644ee620b6a79cf8c538abaf7cd301a875528d Mon Sep 17 00:00:00 2001
From: markm <markm@FreeBSD.org>
Date: Sun, 2 May 1999 14:33:17 +0000
Subject: Maintenance releace 3 of perl5.005. Includes support for threads.

---
 contrib/perl5/t/op/array.t     |   7 +-
 contrib/perl5/t/op/die_exit.t  |   6 +-
 contrib/perl5/t/op/eval.t      |  98 +++++++++++++++++++++++-
 contrib/perl5/t/op/goto.t      |  23 +++++-
 contrib/perl5/t/op/grep.t      |  31 ++++++++
 contrib/perl5/t/op/local.t     |  43 ++++++++++-
 contrib/perl5/t/op/misc.t      |  30 +++++++-
 contrib/perl5/t/op/mkdir.t     |   2 +-
 contrib/perl5/t/op/oct.t       |   5 +-
 contrib/perl5/t/op/pack.t      | 168 +++++++++++++++++++++++++++++++++++++++--
 contrib/perl5/t/op/pat.t       |   7 +-
 contrib/perl5/t/op/range.t     |  11 ++-
 contrib/perl5/t/op/re_tests    |   6 ++
 contrib/perl5/t/op/repeat.t    |  53 ++++++++++++-
 contrib/perl5/t/op/runlevel.t  |  20 +++++
 contrib/perl5/t/op/sort.t      |  36 ++++++++-
 contrib/perl5/t/op/sysio.t     |  40 +++++++---
 contrib/perl5/t/op/taint.t     |   5 +-
 contrib/perl5/t/op/tie.t       |  13 ++++
 contrib/perl5/t/op/tiehandle.t |  18 ++++-
 contrib/perl5/t/op/tr.t        |  33 ++++++++
 contrib/perl5/t/op/undef.t     |  11 ++-
 contrib/perl5/t/op/write.t     |  25 +++++-
 23 files changed, 640 insertions(+), 51 deletions(-)
 create mode 100755 contrib/perl5/t/op/grep.t
 create mode 100755 contrib/perl5/t/op/tr.t

(limited to 'contrib/perl5/t/op')

diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t
index 8dea44d..3409556 100755
--- a/contrib/perl5/t/op/array.t
+++ b/contrib/perl5/t/op/array.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..63\n";
+print "1..65\n";
 
 #
 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -206,3 +206,8 @@ t("@bar" eq "foo bar");						# 43
     t("@bee" eq "foo bar burbl blah");				# 63
 }
 
+# make sure reification behaves
+my $t = 63;
+sub reify { $_[1] = ++$t; print "@_\n"; }
+reify('ok');
+reify('ok');
diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t
index ffbb1e0..26b477a 100755
--- a/contrib/perl5/t/op/die_exit.t
+++ b/contrib/perl5/t/op/die_exit.t
@@ -31,7 +31,7 @@ my %tests = (
 	15 => [ 255,   1],
 	16 => [ 255, 256],
 	# see if implicit close preserves $?
-	17 => [  42,  42, '{ local *F; open F, q[TEST]; close F } die;'],
+	17 => [  0,  512, '{ local *F; open F, q[TEST]; close F } die;'],
 );
 
 my $max = keys %tests;
@@ -46,8 +46,8 @@ foreach my $test (1 .. $max) {
 	 ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul)
 	 : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null));
 
-    printf "# 0x%04x  0x%04x  0x%04x\nnot ", $exit, $bang, $query
-	unless $exit == (($bang || ($query >> 8) || 255) << 8);
+    printf "# 0x%04x  0x%04x  0x%04x\n", $exit, $bang, $query;
+    print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8);
     print "ok $test\n";
 }
     
diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t
index 9368281..dc163e9 100755
--- a/contrib/perl5/t/op/eval.t
+++ b/contrib/perl5/t/op/eval.t
@@ -1,8 +1,6 @@
 #!./perl
 
-# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $
-
-print "1..23\n";
+print "1..36\n";
 
 eval 'print "ok 1\n";';
 
@@ -79,3 +77,97 @@ eval {
   };
   &$x();
 }
+
+my $b = 'wrong';
+my $X = sub {
+   my $b = "right";
+   print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
+};
+&$X();
+
+
+# check navigation of multiple eval boundaries to find lexicals
+
+my $x = 25;
+eval <<'EOT'; die if $@;
+  print "# $x\n";	# clone into eval's pad
+  sub do_eval1 {
+     eval $_[0]; die if $@;
+  }
+EOT
+do_eval1('print "ok $x\n"');
+$x++;
+do_eval1('eval q[print "ok $x\n"]');
+$x++;
+do_eval1('sub { eval q[print "ok $x\n"] }->()');
+$x++;
+
+# calls from within eval'' should clone outer lexicals
+
+eval <<'EOT'; die if $@;
+  sub do_eval2 {
+     eval $_[0]; die if $@;
+  }
+do_eval2('print "ok $x\n"');
+$x++;
+do_eval2('eval q[print "ok $x\n"]');
+$x++;
+do_eval2('sub { eval q[print "ok $x\n"] }->()');
+$x++;
+EOT
+
+# calls outside eval'' should NOT clone lexicals from called context
+
+$main::x = 'ok';
+eval <<'EOT'; die if $@;
+  # $x unbound here
+  sub do_eval3 {
+     eval $_[0]; die if $@;
+  }
+EOT
+do_eval3('print "$x ' . $x . '\n"');
+$x++;
+do_eval3('eval q[print "$x ' . $x . '\n"]');
+$x++;
+do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()');
+$x++;
+
+# can recursive subroutine-call inside eval'' see its own lexicals?
+sub recurse {
+  my $l = shift;
+  if ($l < $x) {
+     ++$l;
+     eval 'print "# level $l\n"; recurse($l);';
+     die if $@;
+  }
+  else {
+    print "ok $l\n";
+  }
+}
+{
+  local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
+  recurse($x-5);
+}
+$x++;
+
+# do closures created within eval bind correctly?
+eval <<'EOT';
+  sub create_closure {
+    my $self = shift;
+    return sub {
+       print $self;
+    };
+  }
+EOT
+create_closure("ok $x\n")->();
+$x++;
+
+# does lexical search terminate correctly at subroutine boundary?
+$main::r = "ok $x\n";
+sub terminal { eval 'print $r' }
+{
+   my $r = "not ok $x\n";
+   eval 'terminal($r)';
+}
+$x++;
+
diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t
index 1b34acd..8096aff 100755
--- a/contrib/perl5/t/op/goto.t
+++ b/contrib/perl5/t/op/goto.t
@@ -1,10 +1,8 @@
 #!./perl
 
-# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $
-
 # "This IS structured code.  It's just randomly structured."
 
-print "1..9\n";
+print "1..13\n";
 
 while ($?) {
     $foo = 1;
@@ -56,7 +54,7 @@ sub bar {
 exit;
 
 FINALE:
-print "ok 9\n";
+print "ok 13\n";
 exit;
 
 bypass:
@@ -86,5 +84,22 @@ $wherever = NOWHERE;
 eval { goto $wherever };
 print $@ =~ /Can't find label NOWHERE/ ? "ok 8\n" : "not ok 8\n";
 
+# see if a modified @_ propagates
+{
+  package Foo;
+  sub DESTROY	{ my $s = shift; print "ok $s->[0]\n"; }
+  sub show	{ print "# @_\nnot ok $_[0][0]\n" if @_ != 5; }
+  sub start	{ push @_, 1, "foo", {}; goto &show; }
+  for (9..11)	{ start(bless([$_]), 'bar'); }
+}
+
+sub auto {
+    goto &loadit;
+}
+
+sub AUTOLOAD { print @_ }
+
+auto("ok 12\n");
+
 $wherever = FINALE;
 goto $wherever;
diff --git a/contrib/perl5/t/op/grep.t b/contrib/perl5/t/op/grep.t
new file mode 100755
index 0000000..45d0e25
--- /dev/null
+++ b/contrib/perl5/t/op/grep.t
@@ -0,0 +1,31 @@
+#!./perl
+
+#
+# grep() and map() tests
+#
+
+print "1..3\n";
+
+$test = 1;
+
+sub ok {
+    my ($got,$expect) = @_;
+    print "# expected [$expect], got [$got]\nnot " if $got ne $expect;
+    print "ok $test\n";
+}
+
+{
+   my @lol = ([qw(a b c)], [], [qw(1 2 3)]);
+   my @mapped = map  {scalar @$_} @lol;
+   ok "@mapped", "3 0 3";
+   $test++;
+
+   my @grepped = grep {scalar @$_} @lol;
+   ok "@grepped", "$lol[0] $lol[2]";
+   $test++;
+
+   @grepped = grep { $_ } @mapped;
+   ok "@grepped", "3 3";
+   $test++;
+}
+
diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t
index 2f674d1..b478e01 100755
--- a/contrib/perl5/t/op/local.t
+++ b/contrib/perl5/t/op/local.t
@@ -1,8 +1,6 @@
 #!./perl
 
-# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
-
-print "1..58\n";
+print "1..69\n";
 
 # XXX known to leak scalars
 $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
@@ -198,3 +196,42 @@ print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n";
 print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n";
 print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n";
 
+# does implicit localization in foreach skip magic?
+
+$_ = "ok 59,ok 60,";
+my $iter = 0;
+while (/(o.+?),/gc) {
+    print "$1\n";
+    foreach (1..1) { $iter++ }
+    if ($iter > 2) { print "not ok 60\n"; last; }
+}
+
+{
+    package UnderScore;
+    sub TIESCALAR { bless \my $self, shift }
+    sub FETCH { die "read  \$_ forbidden" }
+    sub STORE { die "write \$_ forbidden" }
+    tie $_, __PACKAGE__;
+    my $t = 61;
+    my @tests = (
+	"Nesting"     => sub { print '#'; for (1..3) { print }
+			       print "\n" },			1,
+	"Reading"     => sub { print },				0,
+	"Matching"    => sub { $x = /badness/ },		0,
+	"Concat"      => sub { $_ .= "a" },			0,
+	"Chop"        => sub { chop },				0,
+	"Filetest"    => sub { -x },				0,
+	"Assignment"  => sub { $_ = "Bad" },			0,
+	# XXX whether next one should fail is debatable
+	"Local \$_"   => sub { local $_  = 'ok?'; print },	0,
+	"for local"   => sub { for("#ok?\n"){ print } },	1,
+    );
+    while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
+	print "# Testing $name\n";
+	eval { &$code };
+	print(($ok xor $@) ? "ok $t\n" : "not ok $t\n");
+	++$t;
+    }
+    untie $_;
+}
+
diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t
index 7292ffe..c9050ef 100755
--- a/contrib/perl5/t/op/misc.t
+++ b/contrib/perl5/t/op/misc.t
@@ -36,7 +36,9 @@ for (@prgs){
     $status = $?;
     $results = `$CAT $tmpfile`;
     $results =~ s/\n+$//;
-    $results =~ s/syntax error/syntax error/i;
+# bison says 'parse error' instead of 'syntax error',
+# various yaccs may or may not capitalize 'syntax'.
+    $results =~ s/^(syntax|parse) error/syntax error/mig;
     $expected =~ s/\n+$//;
     if ( $results ne $expected){
 	print STDERR "PROG: $switch\n$prog\n";
@@ -418,3 +420,29 @@ EXPECT
 destroyed
 destroyed
 ########
+BEGIN {
+  $| = 1;
+  $SIG{__WARN__} = sub {
+    eval { print $_[0] };
+    die "bar\n";
+  };
+  warn "foo\n";
+}
+EXPECT
+foo
+bar
+BEGIN failed--compilation aborted at - line 8.
+########
+use strict;
+my $foo = "ZZZ\n";
+END { print $foo }
+EXPECT
+ZZZ
+########
+eval '
+use strict;
+my $foo = "ZZZ\n";
+END { print $foo }
+';
+EXPECT
+ZZZ
diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t
index 5ba0a0f..acf16c1 100755
--- a/contrib/perl5/t/op/mkdir.t
+++ b/contrib/perl5/t/op/mkdir.t
@@ -15,4 +15,4 @@ print ($! =~ /exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n");
 print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n");
 print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n");
 print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n");
-print ($! =~ /such|exist/ ? "ok 7\n" : "not ok 7\n");
+print ($! =~ /such|exist|not found/i ? "ok 7\n" : "not ok 7\n");
diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t
index 24b5c43..6623089 100755
--- a/contrib/perl5/t/op/oct.t
+++ b/contrib/perl5/t/op/oct.t
@@ -1,8 +1,6 @@
 #!./perl
 
-# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $
-
-print "1..8\n";
+print "1..9\n";
 
 print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n";
 print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n";
@@ -12,3 +10,4 @@ print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n";
 print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n";
 print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n";
 print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n";
+print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 9\n";
diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t
index 9b7bc35..902fc28 100755
--- a/contrib/perl5/t/op/pack.t
+++ b/contrib/perl5/t/op/pack.t
@@ -1,8 +1,12 @@
 #!./perl
 
-# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib' if -d '../lib';
+    require Config; import Config;
+}
 
-print "1..60\n";
+print "1..142\n";
 
 $format = "c2 x5 C C x s d i l a6";
 # Need the expression in here to force ary[5] to be numeric.  This avoids
@@ -31,7 +35,7 @@ print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
 	? "ok 6\n" : "not ok 6 $x\n";
 
 my $sum = 129; # ASCII
-$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant.
+$sum = 103 if ($Config{ebcdic} eq 'define');
 
 print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
 	? "ok 7\n" : "not ok 7 $x\n";
@@ -160,7 +164,12 @@ foreach my $t (@templates) {
 
 # 57..60: uuencode/decode
 
-$in = join "", map { chr } 0..255;
+# Note that first uuencoding known 'text' data and then checking the
+# binary values of the uuencoded version would not be portable between
+# character sets.  Uuencoding is meant for encoding binary data, not
+# text data.
+ 
+$in = pack 'C*', 0 .. 255;
 
 # just to be anal, we do some random tr/`/ /
 $uu = <<'EOUU';
@@ -199,7 +208,150 @@ EOUU
 print "not " unless unpack('u', $uu) eq $in;
 print "ok ", $test++, "\n";
 
-# Note that first uuencoding known 'text' data and then checking the
-# binary values of the uuencoded version would not be portable between
-# character sets.  Uuencoding is meant for encoding binary data, not
-# text data.
+# 61..72: test the ascii template types (A, a, Z)
+
+print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0   ";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 ";
+print "ok ", $test++, "\n";
+
+print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('Z*', "foo\0bar \0") eq "foo";
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('Z8', "foo\0bar \0") eq "foo";
+print "ok ", $test++, "\n";
+
+# 73..78: packing native shorts/ints/longs
+
+# integrated from mainline and don't want to change numbers all the way
+# down. native ints are not supported in _0x so comment out checks
+#print "not " unless length(pack("s!", 0)) == $Config{shortsize};
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("i!", 0)) == $Config{intsize};
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("l!", 0)) == $Config{longsize};
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0));
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0));
+print "ok ", $test++, "\n";
+
+#print "not " unless length(pack("i!", 0)) == length(pack("i", 0));
+print "ok ", $test++, "\n";
+
+# 79..138: pack <-> unpack bijectionism
+
+#  79.. 83 c
+foreach my $c (-128, -1, 0, 1, 127) {
+    print "not " unless unpack("c", pack("c", $c)) == $c;
+    print "ok ", $test++, "\n";
+}
+
+#  84.. 88: C
+foreach my $C (0, 1, 127, 128, 255) {
+    print "not " unless unpack("C", pack("C", $C)) == $C;
+    print "ok ", $test++, "\n";
+}
+
+#  89.. 93: s
+foreach my $s (-32768, -1, 0, 1, 32767) {
+    print "not " unless unpack("s", pack("s", $s)) == $s;
+    print "ok ", $test++, "\n";
+}
+
+#  94.. 98: S
+foreach my $S (0, 1, 32767, 32768, 65535) {
+    print "not " unless unpack("S", pack("S", $S)) == $S;
+    print "ok ", $test++, "\n";
+}
+
+#  99..103: i
+foreach my $i (-2147483648, -1, 0, 1, 2147483647) {
+    print "not " unless unpack("i", pack("i", $i)) == $i;
+    print "ok ", $test++, "\n";
+}
+
+# 104..108: I
+foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) {
+    print "not " unless unpack("I", pack("I", $I)) == $I;
+    print "ok ", $test++, "\n";
+}
+
+# 109..113: l
+foreach my $l (-2147483648, -1, 0, 1, 2147483647) {
+    print "not " unless unpack("l", pack("l", $l)) == $l;
+    print "ok ", $test++, "\n";
+}
+
+# 114..118: L
+foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) {
+    print "not " unless unpack("L", pack("L", $L)) == $L;
+    print "ok ", $test++, "\n";
+}
+
+# 119..123: n
+foreach my $n (0, 1, 32767, 32768, 65535) {
+    print "not " unless unpack("n", pack("n", $n)) == $n;
+    print "ok ", $test++, "\n";
+}
+
+# 124..128: v
+foreach my $v (0, 1, 32767, 32768, 65535) {
+    print "not " unless unpack("v", pack("v", $v)) == $v;
+    print "ok ", $test++, "\n";
+}
+
+# 129..133: N
+foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) {
+    print "not " unless unpack("N", pack("N", $N)) == $N;
+    print "ok ", $test++, "\n";
+}
+
+# 134..138: V
+foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) {
+    print "not " unless unpack("V", pack("V", $V)) == $V;
+    print "ok ", $test++, "\n";
+}
+
+# 139..142: pack nvNV byteorders
+
+print "not " unless pack("n", 0xdead) eq "\xde\xad";
+print "ok ", $test++, "\n";
+
+print "not " unless pack("v", 0xdead) eq "\xad\xde";
+print "ok ", $test++, "\n";
+
+print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef";
+print "ok ", $test++, "\n";
+
+print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde";
+print "ok ", $test++, "\n";
diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t
index 7d4278f..ed8c778 100755
--- a/contrib/perl5/t/op/pat.t
+++ b/contrib/perl5/t/op/pat.t
@@ -4,7 +4,7 @@
 # the format supported by op/regexp.t.  If you want to add a test
 # that does fit that format, add it to op/re_tests, not here.
 
-print "1..141\n";
+print "1..142\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -595,3 +595,8 @@ print "not " if @_;
 print "ok $test\n";
 $test++;
 
+# see if matching against temporaries (created via pp_helem()) is safe
+{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g;
+print "$1\n";
+$test++;
+
diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t
index 7999b86..01f5f70 100755
--- a/contrib/perl5/t/op/range.t
+++ b/contrib/perl5/t/op/range.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..10\n";
+print "1..12\n";
 
 print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n";
 
@@ -46,3 +46,12 @@ foreach ('09'..'08') {
 print "not " unless join(",", @y) eq join(",", @x);
 print "ok 10\n";
 
+# check bounds
+@a = 0x7ffffffe..0x7fffffff;
+print "not " unless "@a" eq "2147483646 2147483647";
+print "ok 11\n";
+
+@a = -0x7fffffff..-0x7ffffffe;
+print "not " unless "@a" eq "-2147483647 -2147483646";
+print "ok 12\n";
+
diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests
index a5295f5..3471cc3 100644
--- a/contrib/perl5/t/op/re_tests
+++ b/contrib/perl5/t/op/re_tests
@@ -335,6 +335,9 @@ a(?:b|(c|e){1,2}?|d)+?(.)	ace	y	$1$2	ce
 ^(a(?(1)\1)){4}$	aaaaaaaaaa	y	$1	aaaa
 ^(a(?(1)\1)){4}$	aaaaaaaaa	n	-	-
 ^(a(?(1)\1)){4}$	aaaaaaaaaaa	n	-	-
+((a{4})+)	aaaaaaaaa	y	$1	aaaaaaaa
+(((aa){2})+)	aaaaaaaaaa	y	$1	aaaaaaaa
+(((a{2}){2})+)	aaaaaaaaaa	y	$1	aaaaaaaa
 (?:(f)(o)(o)|(b)(a)(r))*	foobar	y	$1:$2:$3:$4:$5:$6	f:o:o:b:a:r
 (?<=a)b	ab	y	$&	b
 (?<=a)b	cb	n	-	-
@@ -483,3 +486,6 @@ b\Z	a\nb\n	y	-	-
 b\z	a\nb\n	n	-	-
 b\Z	a\nb	y	-	-
 b\z	a\nb	y	-	-
+(^|x)(c)	ca	y	$2	c
+a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz	x	n	-	-
+round\(((?>[^()]+))\)	_I(round(xs * sz),1)	y	$1	xs * sz
diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t
index 54fa590..f935bf1 100755
--- a/contrib/perl5/t/op/repeat.t
+++ b/contrib/perl5/t/op/repeat.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $
 
-print "1..19\n";
+print "1..20\n";
 
 # compile time
 
@@ -40,3 +40,54 @@ print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n";
 print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n";
 print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n";
 print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n";
+
+#
+# The test #20 is actually testing for Digital C compiler optimizer bug.
+#
+# Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS) used
+# to produce (as of December 1998) broken code for util.c:repeatcpy()
+# (a utility function for the 'x' operator) in the case *all* these
+# four conditions held:
+#
+# (1) len == 1
+# (2) "from" had the 8th bit on in its single character
+# (3) count > 7 (the 'x' count > 16)
+# (4) the highest optimization level was used in compilation
+#     (which is the default when compiling Perl)
+#
+# The bug looked like this (. being the eight-bit character and ? being \xff):
+#
+# 16 ................
+# 17 .........???????.
+# 18 .........???????..
+# 19 .........???????...
+# 20 .........???????....
+# 21 .........???????.....
+# 22 .........???????......
+# 23 .........???????.......
+# 24 .........???????.???????
+# 25 .........???????.???????.
+#
+# The bug could be (obscurely) avoided by changing "from" to
+# be an unsigned char pointer.
+#
+# The bug was triggered in the "if (len == 1)" branch.  The fix
+# was to introduce a new temporary variable.  In diff -u format:
+#
+#     register char *frombase = from;
+# 
+#     if (len == 1) {
+#-       todo = *from;
+#+       register char c = *from;
+#        while (count-- > 0)
+#-           *to++ = todo;
+#+           *to++ = c;
+#        return;
+#     }
+#
+# This obscure bug was not found by the then test suite but instead
+# by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00.
+#
+# jhi@iki.fi
+#
+print "\xdd" x 24 eq "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd" ? "ok 20\n" : "not ok 20\n";
diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t
index 307e2a0..bff3c36 100755
--- a/contrib/perl5/t/op/runlevel.t
+++ b/contrib/perl5/t/op/runlevel.t
@@ -315,3 +315,23 @@ main|-|9|main::__ANON__
 In DIE
 main|-|10|(eval)
 main|-|10|main::foo
+########
+package TEST;
+ 
+sub TIEARRAY {
+  return bless [qw(foo fee fie foe)], $_[0];
+}
+sub FETCH {
+  my ($s,$i) = @_;
+  if ($i) {
+    goto bbb;
+  }
+bbb:
+  return $s->[$i];
+}
+ 
+package main;
+tie my @bar, 'TEST';
+print join('|', @bar[0..3]), "\n"; 
+EXPECT
+foo|fee|fie|foe
diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t
index 70341b9..fdb4e34 100755
--- a/contrib/perl5/t/op/sort.t
+++ b/contrib/perl5/t/op/sort.t
@@ -1,8 +1,9 @@
 #!./perl
 
-# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $
+print "1..29\n";
 
-print "1..21\n";
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 
 sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 
@@ -125,3 +126,34 @@ eval <<'CODE';
     my @result = sort 'one', 'two';
 CODE
 print $@ ? "not ok 21\n# $@" : "ok 21\n";
+
+{
+  my $sortsub = \&backwards;
+  my $sortglob = *backwards;
+  my $sortglobr = \*backwards;
+  my $sortname = 'backwards';
+  @b = sort $sortsub 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n");
+  @b = sort $sortglob 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n");
+  @b = sort $sortname 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
+}
+
+{
+  local $sortsub = \&backwards;
+  local $sortglob = *backwards;
+  local $sortglobr = \*backwards;
+  local $sortname = 'backwards';
+  @b = sort $sortsub 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
+  @b = sort $sortglob 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
+  @b = sort $sortname 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
+  @b = sort $sortglobr 4,1,3,2;
+  print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
+}
+
diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t
index 826cf38..22e60e3 100755
--- a/contrib/perl5/t/op/sysio.t
+++ b/contrib/perl5/t/op/sysio.t
@@ -1,12 +1,13 @@
 #!./perl
 
-print "1..36\n";
+print "1..39\n";
 
 chdir('op') || die "sysio.t: cannot look for myself: $!";
 
 open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!";
 
-$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos');
+$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' ||
+	   $^O eq 'mpeix');
 
 $x = 'abc';
 
@@ -151,6 +152,21 @@ if ($reopen) {  # must close file to update EOF marker for stat
 print 'not ' unless (-s $outfile == 7);
 print "ok 28\n";
 
+# with implicit length argument
+print 'not ' unless (syswrite(O, $x) == 3);
+print "ok 29\n";
+
+# $a still intact
+print 'not ' unless ($x eq "abc");
+print "ok 30\n";
+
+# $outfile should have grown now
+if ($reopen) {  # must close file to update EOF marker for stat
+  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+}
+print 'not ' unless (-s $outfile == 10);
+print "ok 31\n";
+
 close(O);
 
 open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";
@@ -158,30 +174,30 @@ open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";
 $b = 'xyz';
 
 # reading too much only return as much as available
-print 'not ' unless (sysread(I, $b, 100) == 7);
-print "ok 29\n";
+print 'not ' unless (sysread(I, $b, 100) == 10);
+print "ok 32\n";
 # this we should have
-print 'not ' unless ($b eq '#!ererl');
-print "ok 30\n";
+print 'not ' unless ($b eq '#!ererlabc');
+print "ok 33\n";
 
 # test sysseek
 
 print 'not ' unless sysseek(I, 2, 0) == 2;
-print "ok 31\n";
+print "ok 34\n";
 sysread(I, $b, 3);
 print 'not ' unless $b eq 'ere';
-print "ok 32\n";
+print "ok 35\n";
 
 print 'not ' unless sysseek(I, -2, 1) == 3;
-print "ok 33\n";
+print "ok 36\n";
 sysread(I, $b, 4);
 print 'not ' unless $b eq 'rerl';
-print "ok 34\n";
+print "ok 37\n";
 
 print 'not ' unless sysseek(I, 0, 0) eq '0 but true';
-print "ok 35\n";
+print "ok 38\n";
 print 'not ' if defined sysseek(I, -1, 1);
-print "ok 36\n";
+print "ok 39\n";
 
 close(I);
 
diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t
index d2cae8e..379093f 100755
--- a/contrib/perl5/t/op/taint.t
+++ b/contrib/perl5/t/op/taint.t
@@ -366,7 +366,10 @@ else {
     test 72, $@ eq '', $@;		# NB: This should be allowed
 
     # Try first new style but allow also old style.
-    test 73, $!{ENOENT} || $! == 2 || ($Is_Dos && $! == 22); # File not found
+    test 73, $!{ENOENT} ||
+	$! == 2 || # File not found
+	($Is_Dos && $! == 22) ||
+	($^O eq 'mint' && $! == 33);
 
     test 74, eval { open FOO, "> $foo" } eq '', 'open for write';
     test 75, $@ =~ /^Insecure dependency/, $@;
diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t
index 77e74db..472a6a7 100755
--- a/contrib/perl5/t/op/tie.t
+++ b/contrib/perl5/t/op/tie.t
@@ -153,3 +153,16 @@ $C = $B = tied %H ;
 }
 untie %H;
 EXPECT
+########
+
+# verify no leak when underlying object is selfsame tied variable
+my ($a, $b);
+sub Self::TIEHASH { bless $_[1], $_[0] }
+sub Self::DESTROY { $b = $_[0] + 0; }
+{
+    my %b5;
+    $a = \%b5 + 0;
+    tie %b5, 'Self', \%b5;
+}
+die unless $a == $b;
+EXPECT
diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t
index e3d2472..d7e6a78 100755
--- a/contrib/perl5/t/op/tiehandle.t
+++ b/contrib/perl5/t/op/tiehandle.t
@@ -64,7 +64,7 @@ sub READ {
 sub WRITE {
     compare(WRITE => @_);
     $data = substr($_[1],$_[3] || 0, $_[2]);
-    4;
+    length($data);
 }
 
 sub CLOSE {
@@ -77,7 +77,7 @@ package main;
 
 use Symbol;
 
-print "1..23\n";
+print "1..29\n";
 
 my $fh = gensym;
 
@@ -132,6 +132,20 @@ $r = syswrite $fh,$buf,4,1;
 ok($r == 4);
 ok($data eq "wert");
 
+$buf = "qwerty";
+@expect = (WRITE => $ob, $buf, 4);
+$data = "";
+$r = syswrite $fh,$buf,4;
+ok($r == 4);
+ok($data eq "qwer");
+
+$buf = "qwerty";
+@expect = (WRITE => $ob, $buf, 6);
+$data = "";
+$r = syswrite $fh,$buf;
+ok($r == 6);
+ok($data eq "qwerty");
+
 @expect = (CLOSE => $ob);
 $r = close $fh;
 ok($r == 5);
diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t
new file mode 100755
index 0000000..3503c3c
--- /dev/null
+++ b/contrib/perl5/t/op/tr.t
@@ -0,0 +1,33 @@
+# tr.t
+
+print "1..4\n";
+
+$_ = "abcdefghijklmnopqrstuvwxyz";
+
+tr/a-z/A-Z/;
+
+print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+print "ok 1\n";
+
+tr/A-Z/a-z/;
+
+print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz";
+print "ok 2\n";
+
+tr/b-y/B-Y/;
+
+print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz";
+print "ok 3\n";
+
+# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
+# Yes, discontinuities.  Regardless, the \xca in the below should stay
+# untouched (and not became \x8a).
+
+$_ = "I\xcaJ";
+
+tr/I-J/i-j/;
+
+print "not " unless $_ eq "i\xcaj";
+print "ok 4\n";
+
+#
diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t
index 8ab2ec4..5b3c7ef 100755
--- a/contrib/perl5/t/op/undef.t
+++ b/contrib/perl5/t/op/undef.t
@@ -1,8 +1,6 @@
 #!./perl
 
-# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $
-
-print "1..21\n";
+print "1..23\n";
 
 print defined($a) ? "not ok 1\n" : "ok 1\n";
 
@@ -54,3 +52,10 @@ sub foo { print "ok 19\n"; }
 print defined &foo ? "ok 20\n" : "not ok 20\n";
 undef &foo;
 print defined(&foo) ? "not ok 21\n" : "ok 21\n";
+
+eval { undef $1 };
+print $@ =~ /^Modification of a read/ ? "ok 22\n" : "not ok 22\n";
+
+eval { $1 = undef };
+print $@ =~ /^Modification of a read/ ? "ok 23\n" : "not ok 23\n";
+
diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t
index 705fa79..9918b2f 100755
--- a/contrib/perl5/t/op/write.t
+++ b/contrib/perl5/t/op/write.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $
 
-print "1..5\n";
+print "1..6\n";
 
 my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
 
@@ -167,3 +167,26 @@ for (0..10) {
 print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
 print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
 
+$^A = '';
+
+# more test
+
+format OUT3 =
+^<<<<<<...
+$foo
+.
+
+open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+$foo = 'fit          ';
+write(OUT3);
+close OUT3;
+
+$right =
+"fit\n";
+
+if (`$CAT Op_write.tmp` eq $right)
+    { print "ok 6\n"; unlink 'Op_write.tmp'; }
+else
+    { print "not ok 6\n"; }
+
-- 
cgit v1.1