tests for context handling of the error stack

diff --git a/MANIFEST b/MANIFEST
index ff71eee611c3bef01808895cdcdf47a61d941e7c..0bc4a85d5bca08493672e5842407224c37737ef9 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -318,6 +318,7 @@ t/t03test.t                 Test Imager::Test
 t/t05error.t
 t/t07iolayer.t
 t/t080log.t
+t/t081error.t
 t/t1000files.t                 Format independent file tests
 t/t1000lib/Imager/File/BAD.pm  Test failing to load a file handler
 t/t101nojpeg.t                 Test handling when jpeg not available

diff --git a/t/t081error.t b/t/t081error.t
new file mode 100644 (file)
index 0000000..1ee2489
--- /dev/null
+++ b/t/t081error.t
@@ -0,0 +1,78 @@
+#!perl -w
+use strict;
+
+# avoiding this prologue would be nice, but it seems to be unavoidable,
+# see "It is also important to note ..." in perldoc threads
+use Config;
+my $loaded_threads;
+BEGIN {
+  if ($Config{useithreads} && $] > 5.008007) {
+    $loaded_threads =
+      eval {
+       require threads;
+       threads->import;
+       1;
+      };
+  }
+}
+use Test::More;
+
+$Config{useithreads}
+  or plan skip_all => "can't test Imager's lack of threads support with no threads";
+$] > 5.008007
+  or plan skip_all => "require a perl with CLONE_SKIP to test Imager's lack of threads support";
+$loaded_threads
+  or plan skip_all => "couldn't load threads";
+
+$INC{"Devel/Cover.pm"}
+  and plan skip_all => "threads and Devel::Cover don't get along";
+
+use Imager;
+
+# test that the error contexts are separate under threads
+
+plan tests => 11;
+
+Imager->open_log(log => "testout/t081error.log");
+
+Imager::i_clear_error();
+Imager::i_push_error(0, "main thread a");
+
+my @threads;
+for my $tid (1..5) {
+  my $t1 = threads->create
+    (
+     sub {
+       my $id = shift;
+       Imager::i_push_error(0, "$id: child thread a");
+       sleep(1+rand(4));
+       Imager::i_push_error(1, "$id: child thread b");
+
+       is_deeply([ Imager::i_errors() ],
+                [
+                 [ "$id: child thread b", 1 ],
+                 [ "$id: child thread a", 0 ],
+                ], "$id: check errors in child");
+       1;
+     },
+     $tid
+    );
+  push @threads, [ $tid, $t1 ];
+}
+
+Imager::i_push_error(1, "main thread b");
+
+for my $thread (@threads) {
+  my ($id, $t1) = @$thread;
+  ok($t1->join, "join child $id");
+}
+
+Imager::i_push_error(2, "main thread c");
+
+is_deeply([ Imager::i_errors() ],
+         [
+          [ "main thread c", 2 ],
+          [ "main thread b", 1 ],
+          [ "main thread a", 0 ],
+         ], "check errors in parent");
+