Merge maint-5.004 branch (5.004_03) with mainline.

MANIFEST is out of sync.

p4raw-id: //depot/perl@114

9 files changed, 307 insertions, 86 deletions

diff --git a/t/op/local.t b/t/op/local.t
index 043201072d..f527c9c9a9 100755
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
 
-print "1..20\n";
+print "1..23\n";
 
 sub foo {
     local($a, $b) = @_;
@@ -43,3 +43,12 @@ $d{''} = "ok 18\n";
 print &foo2("ok 11\n","ok 12\n");
 
 print $a,@b,@c,%d,$x,$y;
+
+eval 'local($$e)';
+print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n";
+
+eval 'local(@$e)';
+print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n";
+
+eval 'local(%$e)';
+print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n";
diff --git a/t/op/magic.t b/t/op/magic.t
index 49caab56b4..bddcd27679 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -46,9 +46,9 @@ else {
 
     $| = 1;		# command buffering
 
-    $SIG{"INT"} = "ok3"; kill "INT",$$;
-    $SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";
-    $SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";
+    $SIG{"INT"} = "ok3";     kill "INT",$$;
+    $SIG{"INT"} = "IGNORE";  kill "INT",$$; print "ok 4\n";
+    $SIG{"INT"} = "DEFAULT"; kill "INT",$$; print "not ok\n";
 
     sub ok3 {
 	if (($x = pop(@_)) eq "INT") {
@@ -106,24 +106,41 @@ ok 17, $@ eq "foo\n", $@;
 ok 18, $$ > 0, $$;
 
 # $^X and $0
-if ($Is_MSWin32) {
-    for (19 .. 25) { ok $_, 1 }
-}
-else {
+{
     if ($^O eq 'qnx') {
 	chomp($wd = `pwd`);
     }
     else {
 	$wd = '.';
     }
+    my $perl = "$wd/perl";
+    my $headmaybe = '';
+    my $tailmaybe = '';
     $script = "$wd/show-shebang";
-    $s1 = $s2 = "\$^X is $wd/perl, \$0 is $script\n";
+    if ($Is_MSWin32) {
+	chomp($wd = `cd`);
+	$perl = "$wd\\perl.exe";
+	$script = "$wd\\show-shebang.bat";
+	$headmaybe = <<EOH ;
+\@rem ='
+\@echo off
+$perl -x \%0
+goto endofperl
+\@rem ';
+EOH
+	$tailmaybe = <<EOT ;
+
+__END__
+:endofperl
+EOT
+    }
+    $s1 = $s2 = "\$^X is $perl, \$0 is $script\n";
     if ($^O eq 'os2') {
 	# Started by ksh, which adds suffixes '.exe' and '.' to perl and script
 	$s2 = "\$^X is $wd/perl.exe, \$0 is $script.\n";
     }
     ok 19, open(SCRIPT, ">$script"), $!;
-    ok 20, print(SCRIPT <<EOB . <<'EOF'), $!;
+    ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!;
 #!$wd/perl
 EOB
 print "\$^X is $^X, \$0 is $0\n";
@@ -132,10 +149,10 @@ EOF
     ok 22, chmod(0755, $script), $!;
     $_ = `$script`;
     s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
-    s{is perl}{is $wd/perl}; # for systems where $^X is only a basename
-    ok 23, $_ eq $s2, ":$_:!=:$s2:";
-    $_ = `$wd/perl $script`;
-    ok 24, $_ eq $s1, ":$_:!=:$s1: after `$wd/perl $script`";
+    s{is perl}{is $perl}; # for systems where $^X is only a basename
+    ok 23, ($Is_MSWin32 ? uc($_) eq uc($s2) : $_ eq $s2), ":$_:!=:$s2:";
+    $_ = `$perl $script`;
+    ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`";
     ok 25, unlink($script), $!;
 }
 
diff --git a/t/op/pack.t b/t/op/pack.t
index 223b9d169b..f9a89a3ec0 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
 
-print "1..25\n";
+print "1..29\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
@@ -76,3 +76,27 @@ print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
 print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
 
+#
+# test the "p" template
+
+# literals
+print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n");
+
+# scalars
+print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n");
+
+# temps
+sub foo { my $a = "a"; return $a . $a++ . $a++ }
+{
+  local $^W = 1;
+  my $last = $test;
+  local $SIG{__WARN__} = sub {
+	print "ok ",$test++,"\n" if $_[0] =~ /temporary val/
+  };
+  my $junk = pack("p", &foo);
+  print "not ok ", $test++, "\n" if $last == $test;
+}
+
+# undef should give null pointer
+print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n");
+
diff --git a/t/op/re_tests b/t/op/re_tests
index 77d97e2aeb..ce4c5a51a2 100644
--- a/t/op/re_tests
+++ b/t/op/re_tests
@@ -42,9 +42,9 @@ a[b-d]e	ace	y	$&	ace
 a[b-d]	aac	y	$&	ac
 a[-b]	a-	y	$&	a-
 a[b-]	a-	y	$&	a-
-a[b-a]	-	c	-	-
-a[]b	-	c	-	-
-a[	-	c	-	-
+a[b-a]	-	c	-	/a[b-a]/: invalid [] range in regexp
+a[]b	-	c	-	/a[]b/: unmatched [] in regexp
+a[	-	c	-	/a[/: unmatched [] in regexp
 a]	a]	y	$&	a]
 a[]]b	a]b	y	$&	a]b
 a[^bc]d	aed	y	$&	aed
@@ -92,21 +92,21 @@ a[\S]b	a-b	y	-	-
 ab|cd	abc	y	$&	ab
 ab|cd	abcd	y	$&	ab
 ()ef	def	y	$&-$1	ef-
-*a	-	c	-	-
-(*)b	-	c	-	-
+*a	-	c	-	/*a/: ?+*{} follows nothing in regexp
+(*)b	-	c	-	/(*)b/: ?+*{} follows nothing in regexp
 $b	b	n	-	-
-a\	-	c	-	-
+a\	-	c	-	Search pattern not terminated
 a\(b	a(b	y	$&-$1	a(b-
 a\(*b	ab	y	$&	ab
 a\(*b	a((b	y	$&	a((b
 a\\b	a\b	y	$&	a\b
-abc)	-	c	-	-
-(abc	-	c	-	-
+abc)	-	c	-	/abc)/: unmatched () in regexp
+(abc	-	c	-	/(abc/: unmatched () in regexp
 ((a))	abc	y	$&-$1-$2	a-a-a
 (a)b(c)	abc	y	$&-$1-$2	abc-a-c
 a+b+c	aabbabc	y	$&	abc
 a{1,}b{1,}c	aabbabc	y	$&	abc
-a**	-	c	-	-
+a**	-	c	-	/a**/: nested *?+ in regexp
 a.+?c	abcabc	y	$&	abc
 (a+|b)*	ab	y	$&-$1	ab-b
 (a+|b){0,}	ab	y	$&-$1	ab-b
@@ -114,7 +114,7 @@ a.+?c	abcabc	y	$&	abc
 (a+|b){1,}	ab	y	$&-$1	ab-b
 (a+|b)?	ab	y	$&-$1	a-a
 (a+|b){0,1}	ab	y	$&-$1	a-a
-)(	-	c	-	-
+)(	-	c	-	/)(/: unmatched () in regexp
 [^ab]*	cde	y	$&	cde
 abc		n	-	-
 a*		y	$&	
@@ -205,9 +205,9 @@ a[-]?c	ac	y	$&	ac
 'a[b-d]'i	AAC	y	$&	AC
 'a[-b]'i	A-	y	$&	A-
 'a[b-]'i	A-	y	$&	A-
-'a[b-a]'i	-	c	-	-
-'a[]b'i	-	c	-	-
-'a['i	-	c	-	-
+'a[b-a]'i	-	c	-	/a[b-a]/: invalid [] range in regexp
+'a[]b'i	-	c	-	/a[]b/: unmatched [] in regexp
+'a['i	-	c	-	/a[/: unmatched [] in regexp
 'a]'i	A]	y	$&	A]
 'a[]]b'i	A]B	y	$&	A]B
 'a[^bc]d'i	AED	y	$&	AED
@@ -219,21 +219,21 @@ a[-]?c	ac	y	$&	ac
 'ab|cd'i	ABC	y	$&	AB
 'ab|cd'i	ABCD	y	$&	AB
 '()ef'i	DEF	y	$&-$1	EF-
-'*a'i	-	c	-	-
-'(*)b'i	-	c	-	-
+'*a'i	-	c	-	/*a/: ?+*{} follows nothing in regexp
+'(*)b'i	-	c	-	/(*)b/: ?+*{} follows nothing in regexp
 '$b'i	B	n	-	-
-'a\'i	-	c	-	-
+'a\'i	-	c	-	Search pattern not terminated
 'a\(b'i	A(B	y	$&-$1	A(B-
 'a\(*b'i	AB	y	$&	AB
 'a\(*b'i	A((B	y	$&	A((B
 'a\\b'i	A\B	y	$&	A\B
-'abc)'i	-	c	-	-
-'(abc'i	-	c	-	-
+'abc)'i	-	c	-	/abc)/: unmatched () in regexp
+'(abc'i	-	c	-	/(abc/: unmatched () in regexp
 '((a))'i	ABC	y	$&-$1-$2	A-A-A
 '(a)b(c)'i	ABC	y	$&-$1-$2	ABC-A-C
 'a+b+c'i	AABBABC	y	$&	ABC
 'a{1,}b{1,}c'i	AABBABC	y	$&	ABC
-'a**'i	-	c	-	-
+'a**'i	-	c	-	/a**/: nested *?+ in regexp
 'a.+?c'i	ABCABC	y	$&	ABC
 'a.*?c'i	ABCABC	y	$&	ABC
 'a.{0,5}?c'i	ABCABC	y	$&	ABC
@@ -244,7 +244,7 @@ a[-]?c	ac	y	$&	ac
 '(a+|b)?'i	AB	y	$&-$1	A-A
 '(a+|b){0,1}'i	AB	y	$&-$1	A-A
 '(a+|b){0,1}?'i	AB	y	$&-$1	-
-')('i	-	c	-	-
+')('i	-	c	-	/)(/: unmatched () in regexp
 '[^ab]*'i	CDE	y	$&	CDE
 'abc'i		n	-	-
 'a*'i		y	$&	
@@ -304,3 +304,5 @@ a(?:b|(c|e){1,2}?|d)+?(.)	ace	y	$1$2	ce
 '([a-z]+)\s\1'i	Aa aa 	y	$&-$1	Aa aa-Aa
 '([a-z]+)\s\1'i	Ab ab 	y	$&-$1	Ab ab-Ab
 foo\w*\d{4}baz	foobar1234baz	y	$&	foobar1234baz
+((foo)|(bar))*	foobar	y	$1-$2-$3	bar-foo-bar
+:(?:	-	c	-	Sequence (? incomplete
diff --git a/t/op/ref.t b/t/op/ref.t
index 4e024d8828..e83a04fbee 100755
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..47\n";
+print "1..50\n";
 
 # Test glob operations.
 
@@ -207,12 +207,28 @@ print @baa == 3 ? "ok 42\n" : "not ok 42\n";
 print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n";
 print @bzz == 3 ? "ok 44\n" : "not ok 44\n";
 
+# test for proper destruction of lexical objects
+
+sub larry::DESTROY { print "# larry\nok 45\n"; }
+sub curly::DESTROY { print "# curly\nok 46\n"; }
+sub moe::DESTROY   { print "# moe\nok 47\n"; }
+
+{
+    my ($joe, @curly, %larry);
+    my $moe = bless \$joe, 'moe';
+    my $curly = bless \@curly, 'curly';
+    my $larry = bless \%larry, 'larry';
+    print "# leaving block\n";
+}
+
+print "# left block\n";
+
 package FINALE;
 
 {
-    $ref3 = bless ["ok 47\n"];		# package destruction
-    my $ref2 = bless ["ok 46\n"];	# lexical destruction
-    local $ref1 = bless ["ok 45\n"];	# dynamic destruction
+    $ref3 = bless ["ok 50\n"];		# package destruction
+    my $ref2 = bless ["ok 49\n"];	# lexical destruction
+    local $ref1 = bless ["ok 48\n"];	# dynamic destruction
     1;					# flush any temp values on stack
 }
 
diff --git a/t/op/regexp.t b/t/op/regexp.t
index ea470f879b..803f1d0dab 100755
--- a/t/op/regexp.t
+++ b/t/op/regexp.t
@@ -14,7 +14,7 @@
 # 	n	expect no match
 # 	c	expect an error
 #
-# Columns 4 and 5 are used only of column 3 contains C<y>.
+# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
 #
 # Column 4 contains a string, usually C<$&>.
 #
@@ -35,11 +35,11 @@ TEST:
 while (<TESTS>) {
     ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_);
     $input = join(':',$pat,$subject,$result,$repl,$expect);
-    $pat = "'$pat'" unless $pat =~ /^'/;
+    $pat = "'$pat'" unless $pat =~ /^[:']/;
     for $study ("", "study \$subject") {
 	eval "$study; \$match = (\$subject =~ m$pat); \$got = \"$repl\";";
 	if ($result eq 'c') {
-	    if ($@ eq '') { print "not ok $.\n"; next TEST }
+	    if ($@ !~ m!^\Q$expect!) { print "not ok $.\n"; next TEST }
 	    last;  # no need to study a syntax error
 	}
 	elsif ($result eq 'n') {
diff --git a/t/op/stat.t b/t/op/stat.t
index aea5cc147c..97f8192885 100755
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -75,8 +75,8 @@ if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
 eval '$> = $olduid;';		# switch uid back (may not be implemented)
 print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid);
 
-if ($Is_MSWin32 or ! -x 'Op.stat.tmp') {print "ok 11\n";}
-else                                   {print "not ok 11\n";}
+if (! -x 'Op.stat.tmp') {print "ok 11\n";}
+else                    {print "not ok 11\n";}
 
 foreach ((12,13,14,15,16,17)) {
     print "ok $_\n";		#deleted tests
diff --git a/t/op/substr.t b/t/op/substr.t
index e34216fb17..bb655f5209 100755
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -2,25 +2,40 @@
 
 # $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $
 
-print "1..25\n";
+print "1..97\n";
+
+#P = start of string  Q = start of substr  R = end of substr  S = end of string
 
 $a = 'abcdefxyz';
+BEGIN { $^W = 1 };
+
+$SIG{__WARN__} = sub {
+     if ($_[0] =~ /^substr outside of string/) {
+          $w++;
+     } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) {
+          $w += 2;
+     } else {
+          warn @_;
+     }
+};
 
-print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");
-print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");
-print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n");
-print (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n");
-print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n");
-print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");
+sub fail { !defined(shift) && $w-- };
+
+print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");   # P=Q R S
+print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");   # P Q R S
+print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R
+print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n");  # P R Q S
+print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n");  # P=Q R S
+print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");    # P Q R S
 
 $[ = 1;
 
-print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");
-print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");
-print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n");
-print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n");
-print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");
-print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");
+print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");   # P=Q R S
+print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");   # P Q R S
+print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R
+print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S
+print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S
+print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");  # P Q R S
 
 $[ = 0;
 
@@ -28,7 +43,6 @@ substr($a,3,3) = 'XYZ';
 print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
 substr($a,0,2) = '';
 print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
-y/a/a/;
 substr($a,0,0) = 'ab';
 print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
 substr($a,0,0) = '12345678';
@@ -42,9 +56,103 @@ print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
 
 $a = 'abcdefxyz';
 
-print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n");
-print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n");
-print (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n");
+print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n");   # P Q R=S
+print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n");  # P Q R=S
+print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n");    # P R=S Q
+print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S
+print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n");      # P Q=R=S
+print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S
+print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n");  # P=Q R=S
+
+$a = '54321';
+
+print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n");  # Q R P S
+print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n");  # Q R P S
+print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n");  # R P=Q S
+print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n");  # R P Q S
+print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n");  # R P Q S
+print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n");  # P=R Q S
+print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n");  # P=R Q S
+print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n");  # P R Q S
+print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n");  # P R Q S
+print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n");  # R P Q=S
+print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n");  # P=R Q S
+print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n");  # P R Q=S
+print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n");  # R P S Q
+print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n");  # P=R S Q
+print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n");  # P R S Q
+print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n");  # P S Q=R
+
+print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n");   # Q P=R S
+print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S
+print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S
+print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R
+print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n");   # P=Q=R S
+print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S
+print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S
+print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R
+print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n");   # P Q=R S
+print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S
+print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R
+print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n");   # P=Q=R S
+print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n");   # P Q=R S
+print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n");    # P=Q=R S
+print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S
+print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R
+print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n");    # P Q=R S
+print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S
+print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n");    # P Q=R=S
+print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n");    # P Q=S R
+print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n");  # Q P=R S
+print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S
+print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n");  # P=Q=R S
+print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S
+print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n");  # P Q=R S
+print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S
+
+$a = '';
+
+print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n");   # Q P=R=S
+print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n");    # P=Q=R=S
+print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n");    # P=Q=S R
+print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n");   # Q P=S R
+print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n");     # Q P=R=S
+print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n");      # P=Q=R=S
+
+
+print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n");   # R P=Q=S
+print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n");   # Q=R P=S
+print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n");   # Q R P=S
+print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n");  # Q R P=S
+print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n");  # Q=R P=S
+print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n");   # R P=S Q
+print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n");    # P=S Q R
+print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n");    # P=S Q=R
+print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n");      # P=R=S Q
+
+
+my $a = 'zxcvbnm';
+substr($a,2,0) = '';
+print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n";
+substr($a,7,0) = '';
+print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n";
+substr($a,5,0) = '';
+print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n";
+substr($a,0,2) = 'pq';
+print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n";
+substr($a,2,0) = 'r';
+print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n";
+substr($a,8,0) = 'asd';
+print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n";
+substr($a,0,2) = 'iop';
+print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n";
+substr($a,0,5) = 'fgh';
+print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n";
+substr($a,3,5) = 'jkl';
+print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n";
+substr($a,3,2) = '1234';
+print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n";
+
 
 # with lexicals (and in re-entered scopes)
 for (0,1) {
@@ -52,17 +160,21 @@ for (0,1) {
   unless ($_) {
     $txt = "Foo";
     substr($txt, -1) = "X";
-    print $txt eq "FoX" ? "ok 23\n" : "not ok 23\n";
+    print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n";
   }
   else {
+    local $^W = 0;    # because of (spurious?) "uninitialised value"
     substr($txt, 0, 1) = "X";
-    print $txt eq "X" ? "ok 24\n" : "not ok 24\n";
+    print $txt eq "X" ? "ok 95\n" : "not ok 95\n";
   }
 }
 
-# coersion of references
+# coercion of references
 {
   my $s = [];
   substr($s, 0, 1) = 'Foo';
-  print substr($s,0,7) eq "FooRRAY" ? "ok 25\n" : "not ok 25\n";
+  print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n";
 }
+
+# check no spurious warnings
+print $w ? "not ok 97\n" : "ok 97\n";
diff --git a/t/op/universal.t b/t/op/universal.t
index 03f0fbdd9d..bd6c73afe9 100755
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -3,7 +3,12 @@
 # check UNIVERSAL
 #
 
-print "1..11\n";
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib' if -d '../lib';
+}
+
+print "1..72\n";
 
 $a = {};
 bless $a, "Bob";
@@ -21,35 +26,71 @@ package Alice;
 sub drink {}
 sub new { bless {} }
 
+$Alice::VERSION = 2.718;
+
 package main;
+
+my $i = 2;
+sub test { print "not " unless shift; print "ok $i\n"; $i++; }
+
 $a = new Alice;
 
-print "not " unless $a->isa("Alice");
-print "ok 2\n";
+test $a->isa("Alice");
 
-print "not " unless $a->isa("Bob");
-print "ok 3\n";
+test $a->isa("Bob");
+
+test $a->isa("Female");
+
+test $a->isa("Human");
+
+test ! $a->isa("Male");
+
+test $a->can("drink");
+
+test $a->can("eat");
+
+test ! $a->can("sleep");
+
+my $b = 'abc';
+my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
+my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
+for ($p=0; $p < @refs; $p++) {
+    for ($q=0; $q < @vals; $q++) {
+        test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1);
+    };
+};
+
+test ! UNIVERSAL::can(23, "can");
+
+test $a->can("VERSION");
+
+test $a->can("can");
+test ! $a->can("export_tags");	# a method in Exporter
+
+test (eval { $a->VERSION }) == 2.718;
+
+test ! (eval { $a->VERSION(2.719) }) &&
+         $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /;
+
+test (eval { $a->VERSION(2.718) }) && ! $@;
 
-print "not " unless $a->isa("Female");
-print "ok 4\n";
+my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
+test $subs eq "VERSION can isa";
 
-print "not " unless $a->isa("Human");
-print "ok 5\n";
+test $a->isa("UNIVERSAL");
 
-print "not " if $a->isa("Male");
-print "ok 6\n";
+# now use UNIVERSAL.pm and see what changes
+eval "use UNIVERSAL";
 
-print "not " unless $a->can("drink");
-print "ok 7\n";
+test $a->isa("UNIVERSAL");
 
-print "not " unless $a->can("eat");
-print "ok 8\n";
+my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; 
+# XXX import being here is really a bug
+test $sub2 eq "VERSION can import isa";
 
-print "not " if $a->can("sleep");
-print "ok 9\n";
+eval 'sub UNIVERSAL::sleep {}';
+test $a->can("sleep");
 
-print "not " unless UNIVERSAL::isa([], "ARRAY");
-print "ok 10\n";
+test ! UNIVERSAL::can($b, "can");
 
-print "not " unless UNIVERSAL::isa({}, "HASH");
-print "ok 11\n";
+test ! $a->can("export_tags");	# a method in Exporter