Integrate mainline (t/lib/b.t fails test 2...)

p4raw-id: //depot/perlio@9726

18 files changed, 798 insertions, 21 deletions

diff --git a/t/lib/cwd.t b/t/lib/cwd.t
index 1ddaf250c2..831ad083cd 100644
--- a/t/lib/cwd.t
+++ b/t/lib/cwd.t
@@ -105,21 +105,29 @@ else {
 }
 
 if ($Config{d_symlink}) {
-    my @dirs = split " " => $Config{libpth};
-    my $target = pop @dirs;
-    symlink $target => "linktest";
-    mkdir "pteerslt";
-    chdir "pteerslt";
-    my $rel = "../../t/linktest";
-
-    my $abs_path      = Cwd::abs_path($rel);
-    my $fast_abs_path = Cwd::fast_abs_path($rel);
-    print +($abs_path      eq $target ? "" : "not "), "ok 13\n";
-    print +($fast_abs_path eq $target ? "" : "not "), "ok 14\n";
-
-    chdir "..";
-    rmdir "pteerslt";
-    unlink "linktest";
+    my @dirs = grep(! -l $_ => (split " " => $Config{libpth}));
+    if (@dirs) {
+	my $target = pop @dirs;
+	symlink $target => "linktest";
+	mkdir "pteerslt";
+	chdir "pteerslt";
+	my $rel = "../../t/linktest";
+	
+	my $abs_path      = Cwd::abs_path($rel);
+	my $fast_abs_path = Cwd::fast_abs_path($rel);
+	print "# abs_path      $abs_path\n";
+	print "# fast_abs_path $fast_abs_path\n";
+	print "# target        $target\n";
+	print +($abs_path      eq $target ? "" : "not "), "ok 13\n";
+	print +($fast_abs_path eq $target ? "" : "not "), "ok 14\n";
+	
+	chdir "..";
+	rmdir "pteerslt";
+	unlink "linktest";
+    } else {
+	print "ok 13 # skipped\n";
+	print "ok 14 # skipped\n";
+    }
 } else {
     print "ok 13 # skipped\n";
     print "ok 14 # skipped\n";
diff --git a/t/lib/exporter.t b/t/lib/exporter.t
new file mode 100644
index 0000000000..d5c40731a0
--- /dev/null
+++ b/t/lib/exporter.t
@@ -0,0 +1,145 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+# Utility testing functions.
+my $test_num = 1;
+sub ok ($;$) {
+    my($test, $name) = @_;
+    print "not " unless $test;
+    print "ok $test_num";
+    print " - $name" if defined $name;
+    print "\n";
+    $test_num++;
+}
+
+
+my $loaded;
+BEGIN { $| = 1; $^W = 1; }
+END {print "not ok $test_num\n" unless $loaded;}
+print "1..$Total_tests\n";
+use Exporter;
+$loaded = 1;
+ok(1, 'compile');
+
+
+BEGIN {
+    # Methods which Exporter says it implements.
+    @Exporter_Methods = qw(import
+                           export_to_level
+                           require_version
+                           export_fail
+                          );
+}
+
+BEGIN { $Total_tests = 14 + @Exporter_Methods }
+
+package Testing;
+require Exporter;
+@ISA = qw(Exporter);
+
+# Make sure Testing can do everything its supposed to.
+foreach my $meth (@::Exporter_Methods) {
+    ::ok( Testing->can($meth), "subclass can $meth()" );
+}
+
+%EXPORT_TAGS = (
+                This => [qw(stuff %left)],
+                That => [qw(Above the @wailing)],
+                tray => [qw(Fasten $seatbelt)],
+               );
+@EXPORT    = qw(lifejacket);
+@EXPORT_OK = qw(under &your $seat);
+$VERSION = '1.05';
+
+::ok( Testing->require_version(1.05),   'require_version()' );
+eval { Testing->require_version(1.11); 1 };
+::ok( $@,                               'require_version() fail' );
+::ok( Testing->require_version(0),      'require_version(0)' );
+
+sub lifejacket  { 'lifejacket'  }
+sub stuff       { 'stuff'       }
+sub Above       { 'Above'       }
+sub the         { 'the'         }
+sub Fasten      { 'Fasten'      }
+sub your        { 'your'        }
+sub under       { 'under'       }
+use vars qw($seatbelt $seat @wailing %left);
+$seatbelt = 'seatbelt';
+$seat     = 'seat';
+@wailing = qw(AHHHHHH);
+%left = ( left => "right" );
+
+
+Exporter::export_ok_tags;
+
+my %tags     = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS;
+my %exportok = map { $_ => 1 } @EXPORT_OK;
+my $ok = 1;
+foreach my $tag (keys %tags) {
+    $ok = exists $exportok{$tag};
+}
+::ok( $ok, 'export_ok_tags()' );
+
+
+package Foo;
+Testing->import;
+
+::ok( defined &lifejacket,      'simple import' );
+
+
+package Bar;
+my @imports = qw($seatbelt &Above stuff @wailing %left);
+Testing->import(@imports);
+
+::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)),
+      'import by symbols' );
+
+
+package Yar;
+my @tags = qw(:This :tray);
+Testing->import(@tags);
+
+::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
+             map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}),
+      'import by tags' );
+
+
+package Arrr;
+Testing->import(qw(!lifejacket));
+
+::ok( !defined &lifejacket,     'deny import by !' );
+
+
+package Mars;
+Testing->import('/e/');
+
+::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
+            grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
+      'import by regex');
+
+
+package Venus;
+Testing->import('!/e/');
+
+::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ }
+            grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
+      'deny import by regex');
+::ok( !defined &lifejacket, 'further denial' );
+
+
+package More::Testing;
+@ISA = qw(Exporter);
+$VERSION = 0;
+eval { More::Testing->require_version(0); 1 };
+::ok(!$@,       'require_version(0) and $VERSION = 0');
+
+
+package Yet::More::Testing;
+@ISA = qw(Exporter);
+$VERSION = 0;
+eval { Yet::More::Testing->require_version(10); 1 };
+::ok($@ !~ /\(undef\)/,       'require_version(10) and $VERSION = 0');
diff --git a/t/lib/time-hires.t b/t/lib/time-hires.t
index 50c20f09ca..cc741e7669 100644
--- a/t/lib/time-hires.t
+++ b/t/lib/time-hires.t
@@ -3,7 +3,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-BEGIN { $| = 1; print "1..17\n"; }
+BEGIN { $| = 1; print "1..19\n"; }
 
 END {print "not ok 1\n" unless $loaded;}
 
@@ -23,6 +23,8 @@ import Time::HiRes 'gettimeofday'	if $have_gettimeofday;
 import Time::HiRes 'usleep'		if $have_usleep;
 import Time::HiRes 'ualarm'		if $have_ualarm;
 
+use Config;
+
 sub skip {
     map { print "ok $_ (skipped)\n" } @_;
 }
@@ -159,18 +161,56 @@ unless (defined &Time::HiRes::gettimeofday
     $SIG{ALRM} = "tick";
     while ($i)
     {
-	alarm(2.5);
+	alarm(0.3);
 	select (undef, undef, undef, 10);
-	print "# Select returned! ", Time::HiRes::tv_interval ($r), "\n";
+	print "# Select returned! $i ", Time::HiRes::tv_interval ($r), "\n";
     }
 
     sub tick
     {
-	print "# Tick! ", Time::HiRes::tv_interval ($r), "\n";
 	$i--;
+	print "# Tick! $i ", Time::HiRes::tv_interval ($r), "\n";
     }
     $SIG{ALRM} = 'DEFAULT';
 
     print "ok 17\n";
 }
 
+unless (defined &Time::HiRes::setitimer
+	&& defined &Time::HiRes::getitimer
+	&& exists &Time::HiRes::ITIMER_VIRTUAL
+	&& $Config{d_select}) {
+    for (18..19) {
+	print "ok $_ # Skip: no virtual interval timers\n";
+    }
+} else {
+    use Time::HiRes qw (setitimer getitimer ITIMER_VIRTUAL);
+
+    my $i = 3;
+    my $r = [Time::HiRes::gettimeofday];
+
+    $SIG{VTALRM} = sub {
+	$i ? $i-- : setitimer(ITIMER_VIRTUAL, 0);
+	print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n";
+    };	
+
+    print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n";
+
+    # Assume interval timer granularity of 0.05 seconds.  Too bold?
+    print "not " unless abs(getitimer(ITIMER_VIRTUAL) / 0.5) - 1 < 0.1;
+    print "ok 18\n";
+
+    print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
+
+    while (getitimer(ITIMER_VIRTUAL)) {
+	my $j; $j++ for 1..1000; # Can't be unbreakable, must test getitimer().
+    }
+
+    print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
+
+    print "not " unless getitimer(ITIMER_VIRTUAL) == 0;
+    print "ok 19\n";
+
+    $SIG{VTALRM} = 'DEFAULT';
+}
+
diff --git a/t/lib/u-blessed.t b/t/lib/u-blessed.t
new file mode 100755
index 0000000000..d70e023b6a
--- /dev/null
+++ b/t/lib/u-blessed.t
@@ -0,0 +1,34 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use Scalar::Util qw(blessed);
+use vars qw($t $y $x);
+
+print "1..7\n";
+
+print "not " if blessed(1);
+print "ok 1\n";
+
+print "not " if blessed('A');
+print "ok 2\n";
+
+print "not " if blessed({});
+print "ok 3\n";
+
+print "not " if blessed([]);
+print "ok 4\n";
+
+$y = \$t;
+
+print "not " if blessed($y);
+print "ok 5\n";
+
+$x = bless [], "ABC";
+
+print "not " unless blessed($x);
+print "ok 6\n";
+
+print "not " unless blessed($x) eq 'ABC';
+print "ok 7\n";
diff --git a/t/lib/u-dualvar.t b/t/lib/u-dualvar.t
new file mode 100755
index 0000000000..acee8ad91a
--- /dev/null
+++ b/t/lib/u-dualvar.t
@@ -0,0 +1,41 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+BEGIN {
+  require Scalar::Util;
+
+  if (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) {
+    print "1..0\n";
+    exit;
+  }
+}
+
+use Scalar::Util qw(dualvar);
+
+print "1..6\n";
+
+$var = dualvar 2.2,"string";
+
+print "not " unless $var == 2.2;
+print "ok 1\n";
+
+print "not " unless $var eq "string";
+print "ok 2\n";
+
+$var2 = $var;
+
+$var++;
+
+print "not " unless $var == 3.2;
+print "ok 3\n";
+
+print "not " unless $var ne "string";
+print "ok 4\n";
+
+print "not " unless $var2 == 2.2;
+print "ok 5\n";
+
+print "not " unless $var2 eq "string";
+print "ok 6\n";
diff --git a/t/lib/u-first.t b/t/lib/u-first.t
new file mode 100755
index 0000000000..71f3de41f5
--- /dev/null
+++ b/t/lib/u-first.t
@@ -0,0 +1,20 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use List::Util qw(first);
+
+print "1..4\n";
+
+print "not " unless defined &first;
+print "ok 1\n";
+
+print "not " unless 9 == first { 8 == ($_ - 1) } 9,4,5,6;
+print "ok 2\n";
+
+print "not " if defined(first { 0 } 1,2,3,4);
+print "ok 3\n";
+
+print "not " if defined(first { 0 });
+print "ok 4\n";
diff --git a/t/lib/u-max.t b/t/lib/u-max.t
new file mode 100755
index 0000000000..f4873bdaa1
--- /dev/null
+++ b/t/lib/u-max.t
@@ -0,0 +1,25 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use List::Util qw(max);
+
+print "1..5\n";
+
+print "not " unless defined &max;
+print "ok 1\n";
+
+print "not " unless max(1) == 1;
+print "ok 2\n";
+
+print "not " unless max(1,2) == 2;
+print "ok 3\n";
+
+print "not " unless max(2,1) == 2;
+print "ok 4\n";
+
+my @a = map { rand() } 1 .. 20;
+my @b = sort { $a <=> $b } @a;
+print "not " unless max(@a) == $b[-1];
+print "ok 5\n";
diff --git a/t/lib/u-maxstr.t b/t/lib/u-maxstr.t
new file mode 100755
index 0000000000..79646136e1
--- /dev/null
+++ b/t/lib/u-maxstr.t
@@ -0,0 +1,25 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use List::Util qw(maxstr);
+
+print "1..5\n";
+
+print "not " unless defined &maxstr;
+print "ok 1\n";
+
+print "not " unless maxstr('a') eq 'a';
+print "ok 2\n";
+
+print "not " unless maxstr('a','b') eq 'b';
+print "ok 3\n";
+
+print "not " unless maxstr('B','A') eq 'B';
+print "ok 4\n";
+
+my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
+my @b = sort { $a cmp $b } @a;
+print "not " unless maxstr(@a) eq $b[-1];
+print "ok 5\n";
diff --git a/t/lib/u-min.t b/t/lib/u-min.t
new file mode 100755
index 0000000000..124d88a095
--- /dev/null
+++ b/t/lib/u-min.t
@@ -0,0 +1,25 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use List::Util qw(min);
+
+print "1..5\n";
+
+print "not " unless defined &min;
+print "ok 1\n";
+
+print "not " unless min(9) == 9;
+print "ok 2\n";
+
+print "not " unless min(1,2) == 1;
+print "ok 3\n";
+
+print "not " unless min(2,1) == 1;
+print "ok 4\n";
+
+my @a = map { rand() } 1 .. 20;
+my @b = sort { $a <=> $b } @a;
+print "not " unless min(@a) == $b[0];
+print "ok 5\n";
diff --git a/t/lib/u-minstr.t b/t/lib/u-minstr.t
new file mode 100755
index 0000000000..12dc2fb476
--- /dev/null
+++ b/t/lib/u-minstr.t
@@ -0,0 +1,25 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use List::Util qw(minstr);
+
+print "1..5\n";
+
+print "not " unless defined &minstr;
+print "ok 1\n";
+
+print "not " unless minstr('a') eq 'a';
+print "ok 2\n";
+
+print "not " unless minstr('a','b') eq 'a';
+print "ok 3\n";
+
+print "not " unless minstr('B','A') eq 'A';
+print "ok 4\n";
+
+my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
+my @b = sort { $a cmp $b } @a;
+print "not " unless minstr(@a) eq $b[0];
+print "ok 5\n";
diff --git a/t/lib/u-readonly.t b/t/lib/u-readonly.t
new file mode 100644
index 0000000000..50797250ec
--- /dev/null
+++ b/t/lib/u-readonly.t
@@ -0,0 +1,41 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use Scalar::Util qw(readonly);
+
+print "1..9\n";
+
+print "not " unless readonly(1);
+print "ok 1\n";
+
+my $var = 2;
+
+print "not " if readonly($var);
+print "ok 2\n";
+
+print "not " unless $var == 2;
+print "ok 3\n";
+
+print "not " unless readonly("fred");
+print "ok 4\n";
+
+$var = "fred";
+
+print "not " if readonly($var);
+print "ok 5\n";
+
+print "not " unless $var eq "fred";
+print "ok 6\n";
+
+$var = \2;
+
+print "not " if readonly($var);
+print "ok 7\n";
+
+print "not " unless readonly($$var);
+print "ok 8\n";
+
+print "not " if readonly(*STDOUT);
+print "ok 9\n";
diff --git a/t/lib/u-reduce.t b/t/lib/u-reduce.t
new file mode 100755
index 0000000000..d00dea1533
--- /dev/null
+++ b/t/lib/u-reduce.t
@@ -0,0 +1,25 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use List::Util qw(reduce min);
+
+print "1..5\n";
+
+print "not " if defined reduce {};
+print "ok 1\n";
+
+print "not " unless 9 == reduce { $a / $b } 756,3,7,4;
+print "ok 2\n";
+
+print "not " unless 9 == reduce { $a / $b } 9;
+print "ok 3\n";
+
+@a = map { rand } 0 .. 20;
+print "not " unless min(@a) == reduce { $a < $b ? $a : $b } @a;
+print "ok 4\n";
+
+@a = map { pack("C", int(rand(256))) } 0 .. 20;
+print "not " unless join("",@a) eq reduce { $a . $b } @a;
+print "ok 5\n";
diff --git a/t/lib/u-reftype.t b/t/lib/u-reftype.t
new file mode 100755
index 0000000000..06f9ffb3d0
--- /dev/null
+++ b/t/lib/u-reftype.t
@@ -0,0 +1,50 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use Scalar::Util qw(reftype);
+use vars qw($t $y $x *F);
+use Symbol qw(gensym);
+
+# Ensure we do not trigger and tied methods
+tie *F, 'MyTie';
+
+@test = (
+ [ undef, 1],
+ [ undef, 'A'],
+ [ HASH => {} ],
+ [ ARRAY => [] ],
+ [ SCALAR => \$t ],
+ [ REF    => \(\$t) ],
+ [ GLOB   => \*F ],
+ [ GLOB   => gensym ],
+ [ CODE   => sub {} ],
+# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
+);
+
+print "1..", @test*4, "\n";
+
+my $i = 1;
+foreach $test (@test) {
+  my($type,$what) = @$test;
+  my $pack;
+  foreach $pack (undef,"ABC","0",undef) {
+    print "# $what\n";
+    my $res = reftype($what);
+    printf "# %s - %s\n", map { defined($_) ? $_ : 'undef' } $type,$res;
+    print "not " if $type ? $res ne $type : defined($res);
+    bless $what, $pack if $type && defined $pack;
+    print "ok ",$i++,"\n";
+  }
+}
+
+package MyTie;
+
+sub TIEHANDLE { bless {} }
+sub DESTROY {}
+
+sub AUTOLOAD {
+  warn "$AUTOLOAD called";
+  exit 1; # May be in an eval
+}
diff --git a/t/lib/u-sum.t b/t/lib/u-sum.t
new file mode 100755
index 0000000000..9c1c7cb6db
--- /dev/null
+++ b/t/lib/u-sum.t
@@ -0,0 +1,18 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use List::Util qw(sum);
+
+print "1..3\n";
+
+print "not " if defined sum;
+print "ok 1\n";
+
+print "not " unless sum(9) == 9;
+print "ok 2\n";
+
+print "not " unless sum(1,2,3,4) == 10;
+print "ok 3\n";
+
diff --git a/t/lib/u-tainted.t b/t/lib/u-tainted.t
new file mode 100644
index 0000000000..c38cf1a0d9
--- /dev/null
+++ b/t/lib/u-tainted.t
@@ -0,0 +1,33 @@
+#!./perl -T
+
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use lib qw(blib/lib blib/arch);
+use Scalar::Util qw(tainted);
+use Config;
+
+print "1..5\n";
+
+print "not " if tainted(1);
+print "ok 1\n";
+
+my $var = 2;
+
+print "not " if tainted($var);
+print "ok 2\n";
+
+my $key = (keys %ENV)[0];
+
+$var = $ENV{$key};
+
+print "not " unless tainted($var);
+print "ok 3\n";
+
+print "not " unless tainted($ENV{$key});
+print "ok 4\n";
+
+print "not " if @ARGV and not tainted($ARGV[0]);
+print "ok 5\n";
diff --git a/t/lib/u-weak.t b/t/lib/u-weak.t
new file mode 100755
index 0000000000..bab61973cd
--- /dev/null
+++ b/t/lib/u-weak.t
@@ -0,0 +1,201 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+BEGIN {
+  $|=1;
+  require Scalar::Util;
+  if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
+    print("1..0\n");
+    exit;
+  }
+
+  $DEBUG = 0;
+
+  if ($DEBUG && eval { require Devel::Peek } ) {
+    Devel::Peek->import('Dump');
+  }
+  else {
+    *Dump = sub {};
+  }
+}
+
+use Scalar::Util qw(weaken isweak);
+print "1..17\n";
+
+######################### End of black magic.
+
+$cnt = 0;
+
+sub ok {
+	++$cnt;
+	if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; }
+}
+
+$| = 1;
+
+if(1) {
+
+my ($y,$z);
+
+#
+# Case 1: two references, one is weakened, the other is then undef'ed.
+#
+
+{
+	my $x = "foo";
+	$y = \$x;
+	$z = \$x;
+}
+print "# START:\n";
+Dump($y); Dump($z);
+
+ok( $y ne "" and $z ne "" );
+weaken($y);
+
+print "# WEAK:\n";
+Dump($y); Dump($z);
+
+ok( $y ne "" and $z ne "" );
+undef($z);
+
+print "# UNDZ:\n";
+Dump($y); Dump($z);
+
+ok( not (defined($y) and defined($z)) );
+undef($y);
+
+print "# UNDY:\n";
+Dump($y); Dump($z);
+
+ok( not (defined($y) and defined($z)) );
+
+print "# FIN:\n";
+Dump($y); Dump($z);
+
+# exit(0);
+
+# }
+# {
+
+# 
+# Case 2: one reference, which is weakened
+#
+
+# kill 5,$$;
+
+print "# CASE 2:\n";
+
+{
+	my $x = "foo";
+	$y = \$x;
+}
+
+ok( $y ne "" );
+print "# BW: \n";
+Dump($y);
+weaken($y);
+print "# AW: \n";
+Dump($y);
+ok( not defined $y  );
+
+print "# EXITBLOCK\n";
+}
+
+# exit(0);
+
+# 
+# Case 3: a circular structure
+#
+
+# kill 5, $$;
+
+$flag = 0;
+{
+	my $y = bless {}, Dest;
+	Dump($y);
+	print "# 1: $y\n";
+	$y->{Self} = $y;
+	Dump($y);
+	print "# 2: $y\n";
+	$y->{Flag} = \$flag;
+	print "# 3: $y\n";
+	weaken($y->{Self});
+	print "# WKED\n";
+	ok( $y ne "" );
+	print "# VALS: HASH ",$y,"   SELF ",\$y->{Self},"  Y ",\$y, 
+		"    FLAG: ",\$y->{Flag},"\n";
+	print "# VPRINT\n";
+}
+print "# OUT $flag\n";
+ok( $flag == 1 );
+
+print "# AFTER\n";
+
+undef $flag;
+
+print "# FLAGU\n";
+
+#
+# Case 4: a more complicated circular structure
+#
+
+$flag = 0;
+{
+	my $y = bless {}, Dest;
+	my $x = bless {}, Dest;
+	$x->{Ref} = $y;
+	$y->{Ref} = $x;
+	$x->{Flag} = \$flag;
+	$y->{Flag} = \$flag;
+	weaken($x->{Ref});
+}
+ok( $flag == 2 );
+
+#
+# Case 5: deleting a weakref before the other one
+#
+
+{
+	my $x = "foo";
+	$y = \$x;
+	$z = \$x;
+}
+
+print "# CASE5\n";
+Dump($y);
+
+weaken($y);
+Dump($y);
+undef($y);
+
+ok( not defined $y);
+ok($z ne "");
+
+
+#
+# Case 6: test isweakref
+#
+
+$a = 5;
+ok(!isweak($a));
+$b = \$a;
+ok(!isweak($b));
+weaken($b);
+ok(isweak($b));
+$b = \$a;
+ok(!isweak($b));
+
+$x = {};
+weaken($x->{Y} = \$a);
+ok(isweak($x->{Y}));
+ok(!isweak($x->{Z}));
+
+
+package Dest;
+
+sub DESTROY {
+	print "# INCFLAG\n";
+	${$_[0]{Flag}} ++;
+}
diff --git a/t/op/loopctl.t b/t/op/loopctl.t
index a7416f2046..2ed9df1432 100644
--- a/t/op/loopctl.t
+++ b/t/op/loopctl.t
@@ -31,7 +31,7 @@
 #
 #  -- .robin. <robin@kitsite.com>  2001-03-13
 
-print "1..39\n";
+print "1..41\n";
 
 my $ok;
 
@@ -923,3 +923,24 @@ TEST39: {
     }
 }
 print ($ok ? "ok 39\n" : "not ok 39\n");
+
+
+### Test that loop control is dynamicly scoped.
+
+sub test_last_label { last TEST40 }
+
+TEST40: {
+    $ok = 1;
+    test_last_label();
+    $ok = 0;
+}
+print ($ok ? "ok 40\n" : "not ok 40\n");
+
+sub test_last { last }
+
+TEST41: {
+    $ok = 1;
+    test_last();
+    $ok = 0;
+}
+print ($ok ? "ok 41\n" : "not ok 41\n");
diff --git a/t/pragma/warnings.t b/t/pragma/warnings.t
index e2c7500582..591f0399ab 100644
--- a/t/pragma/warnings.t
+++ b/t/pragma/warnings.t
@@ -27,7 +27,7 @@ else
 my $files = 0;
 foreach my $file (@w_files) {
 
-    next if /(~|\.orig|,v)$/;
+    next if $file =~ /(~|\.orig|,v)$/;
 
     open F, "<$file" or die "Cannot open $file: $!\n" ;
     my $line = 0;