From: Tony Cook <tony@develop-help.com>
Date: Thu, 25 Oct 2012 13:12:10 +0000 (+1100)
Subject: test thread context handling for logging
X-Git-Tag: v0.93_02~16
X-Git-Url: http://git.imager.perl.org/imager.git/commitdiff_plain/ac594e50c722d4e66767878edafb9b8bebacbd95

test thread context handling for logging
---

diff --git a/MANIFEST b/MANIFEST
index 1db747f8..ff71eee6 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -50,11 +50,11 @@ Flines/Flines.xs
 Flines/Makefile.PL
 Flines/t/t00flines.t
 flip.im
-fontft1.c
 fontfiles/dodge.ttf
 fontfiles/ExistenceTest.ttf	generated using pfaedit
 fontfiles/ImUgly.ttf
 fontfiles/NameTest.ttf		test glyph_names() - see FT2/t/t10ft2.t
+fontft1.c
 FT2/fontfiles/dodge.ttf
 FT2/fontfiles/ExistenceTest.afm
 FT2/fontfiles/ExistenceTest.pfb
@@ -317,6 +317,7 @@ t/t023palette.t			Test paletted images
 t/t03test.t			Test Imager::Test
 t/t05error.t
 t/t07iolayer.t
+t/t080log.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/lib/Imager/Test.pm b/lib/Imager/Test.pm
index fe3391ff..88bcd838 100644
--- a/lib/Imager/Test.pm
+++ b/lib/Imager/Test.pm
@@ -4,6 +4,7 @@ use Test::Builder;
 require Exporter;
 use vars qw(@ISA @EXPORT_OK $VERSION);
 use Carp qw(croak);
+use Config;
 
 $VERSION = "1.000";
 
@@ -35,7 +36,9 @@ $VERSION = "1.000";
      mask_tests
      test_colorf_gpix
      test_color_gpix
-     test_colorf_glin);
+     test_colorf_glin
+     can_test_threads
+     );
 
 sub diff_text_with_nul {
   my ($desc, $text1, $text2, @params) = @_;
diff --git a/t/t080log.t b/t/t080log.t
new file mode 100644
index 00000000..738e8f2d
--- /dev/null
+++ b/t/t080log.t
@@ -0,0 +1,108 @@
+#!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;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t080log1.log")
+  or plan skip_all => "Cannot open log file: " . Imager->errstr;
+
+plan tests => 3;
+
+Imager->log("main thread a\n");
+
+my $t1 = threads->create
+  (
+   sub {
+     Imager->log("child thread a\n");
+     Imager->open_log(log => "testout/t080log2.log")
+       or die "Cannot open second log file: ", Imager->errstr;
+     Imager->log("child thread b\n");
+     sleep(1);
+     Imager->log("child thread c\n");
+     sleep(1);
+     1;
+   }
+   );
+
+Imager->log("main thread b\n");
+sleep(1);
+Imager->log("main thread c\n");
+ok($t1->join, "join child thread");
+Imager->log("main thread d\n");
+Imager->close_log();
+
+my %log1 = parse_log("testout/t080log1.log");
+my %log2 = parse_log("testout/t080log2.log");
+
+my @log1 =
+  (
+   "main thread a",
+   "main thread b",
+   "child thread a",
+   "main thread c",
+   "main thread d",
+  );
+
+my @log2 =
+  (
+   "child thread b",
+   "child thread c",
+  );
+
+is_deeply(\%log1, { map {; $_ => 1 } @log1 },
+	  "check messages in main thread log");
+is_deeply(\%log2, { map {; $_ => 1 } @log2 },
+	  "check messages in child thread log");
+
+# grab the messages from the given log
+sub parse_log {
+  my ($filename) = @_;
+
+  open my $fh, "<", $filename
+    or die "Cannot open log file $filename: $!";
+
+  my %lines;
+  while (<$fh>) {
+    chomp;
+    my ($date, $time, $file_line, $level, $message) = split ' ', $_, 5;
+    $lines{$message} = 1;
+  }
+
+  delete $lines{"Imager - log started (level = 1)"};
+  delete $lines{"Imager $Imager::VERSION starting"};
+
+  return %lines;
+}
+
+END {
+  unlink "testout/t080log1.log", "testout/t080log2.log"
+    unless $ENV{IMAGER_KEEP_FILES};
+}