From: Vincent Pit <vince@profvince.com>
Date: Thu, 26 Mar 2009 00:46:11 +0000 (+0100)
Subject: Test unwind in threads
X-Git-Tag: v0.08~2
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=3a414dec45c3c2519b8384e8d81a986e9b76329f

Test unwind in threads
---

diff --git a/MANIFEST b/MANIFEST
index 158b3a0..b74a7ca 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -30,6 +30,7 @@ t/44-localize_delete-magic.t
 t/50-unwind-target.t
 t/55-unwind-multi.t
 t/56-unwind-context.t
+t/59-unwind-threads.t
 t/81-stress-level.t
 t/85-stress-unwind.t
 t/90-boilerplate.t
diff --git a/t/59-unwind-threads.t b/t/59-unwind-threads.t
new file mode 100644
index 0000000..30e16d3
--- /dev/null
+++ b/t/59-unwind-threads.t
@@ -0,0 +1,72 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw/%Config/;
+
+BEGIN {
+ skipall 'This perl wasn\'t built to support threads'
+                                                    unless $Config{useithreads};
+ skipall 'threads required to test thread safety' unless eval "use threads; 1";
+}
+
+my $num;
+BEGIN { $num = 20; }
+
+use Test::More tests => $num;
+
+BEGIN {
+ defined and diag "Using threads $_" for $threads::VERSION;
+
+ if (eval "use Time::HiRes; 1") {
+  defined and diag "Using Time::HiRes $_" for $Time::HiRes::VERSION;
+  *usleep = \&Time::HiRes::usleep;
+ } else {
+  diag 'Using fallback usleep';
+  *usleep = sub {
+   my $s = int($_[0] / 2.5e5);
+   sleep $s if $s;
+  };
+ }
+}
+
+use Scope::Upper qw/unwind UP/;
+
+our $z;
+
+BEGIN {
+}
+
+sub up1 {
+ my $tid  = threads->tid();
+ local $z = $tid;
+ my $p    = "[$tid] up1";
+
+ usleep rand(1e6);
+
+ my @res = (
+  -1,
+  sub {
+   my @dummy = (
+    999,
+    sub {
+     my $foo = unwind $tid .. $tid + 2 => UP;
+     fail "$p: not reached";
+    }->()
+   );
+   fail "$p: not reached";
+  }->(),
+  -2
+ );
+
+ is_deeply \@res, [ -1, $tid .. $tid + 2, -2 ], "$p: unwinded correctly";
+}
+
+$_->join for map threads->create(\&up1), 1 .. $num;