1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
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 threads support with no threads";
$] > 5.008007
or plan skip_all => "require a perl with CLONE_SKIP to test Imager's 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};
}
|
