Test cloning

diff --git a/MANIFEST b/MANIFEST
index fb5f7abd7139cf790a1a005bf629d58ee708770b..6be236ec30931217e1cea77299da7154844e41cf 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -32,6 +32,7 @@ t/32-hash.t
 t/33-code.t
 t/34-glob.t
 t/40-threads.t
+t/41-clone.t
 t/90-boilerplate.t
 t/91-pod.t
 t/92-pod-coverage.t

diff --git a/t/41-clone.t b/t/41-clone.t
new file mode 100644 (file)
index 0000000..032fa92
--- /dev/null
+++ b/t/41-clone.t
@@ -0,0 +1,87 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Config qw/%Config/;
+
+BEGIN {
+ if (!$Config{useithreads}) {
+  require Test::More;
+  Test::More->import;
+  plan(skip_all => 'This perl wasn\'t built to support threads');
+ }
+}
+
+use threads; # Before Test::More
+use threads::shared;
+
+use Test::More;
+
+use Variable::Magic qw/wizard cast dispell getdata getsig VMG_THREADSAFE/;
+
+if (VMG_THREADSAFE) {
+ plan tests => 3 + 2 * (2 * 8 + 2) + 2 * (2 * 5 + 2);
+ diag 'This will leak a few scalars';
+} else {
+ plan skip_all => 'This Variable::Magic isn\'t thread safe';
+}
+
+my $destroyed : shared = 0;
+my $c         : shared = 0;
+my $wiz = wizard get  => sub { ++$c },
+                 data => sub { $_[1] + threads->tid() },
+                 free => sub { ++$destroyed };
+is($@,     '',    "wizard in main thread doesn't croak");
+isnt($wiz, undef, "wizard in main thread is defined");
+is($c,     0,     "wizard in main thread doesn't trigger magic");
+
+my $sig;
+
+sub try {
+ my ($dispell) = @_;
+ my $tid = threads->tid();
+ my $a   = 3;
+ my $res = eval { cast $a, $sig, sub { 5 }->() };
+ is($@, '', "cast in thread $tid doesn't croak");
+ my $b;
+ eval { $b = $a };
+ is($@, '', "get in thread $tid doesn't croak");
+ is($b, 3,  "get in thread $tid returns the right thing");
+ my $d = eval { getdata $a, $sig };
+ is($@, '',       "getdata in thread $tid doesn't croak");
+ is($d, 5 + $tid, "getdata in thread $tid returns the right thing");
+ if ($dispell) {
+  $res = eval { dispell $a, $sig };
+  is($@, '', "dispell in thread $tid doesn't croak");
+  undef $b;
+  eval { $b = $a };
+  is($@, '', "get in thread $tid after dispell doesn't croak");
+  is($b, 3,  "get in thread $tid after dispell returns the right thing");
+ }
+ return; # Ugly if not here
+}
+
+for my $dispell (1, 0) {
+ $c = 0;
+ $destroyed = 0;
+ $sig = $wiz;
+
+ my @t = map { threads->create(\&try, $dispell) } 1 .. 2;
+ $t[0]->join;
+ $t[1]->join;
+
+ is($c, 2, "get triggered twice");
+ is($destroyed, (1 - $dispell) * 2, 'destructors');
+
+ $c = 0;
+ $destroyed = 0;
+ $sig = getsig $wiz;
+
+ @t = map { threads->create(\&try, $dispell) } 1 .. 2;
+ $t[0]->join;
+ $t[1]->join;
+
+ is($c, 2, "get triggered twice");
+ is($destroyed, (1 - $dispell) * 2, 'destructors');
+}