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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
#!perl
use strict;
use warnings;
my $tests;
BEGIN { $tests = 9 }
use Test::More tests => (1 + $tests + 1) + 3 + 5 + 2 + 4;
BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
use lib 't/lib';
my %wrong = map { $_ => 1 } 2, 3, 5, 6, 7, 9;
sub expect {
my ($pkg, $file, $prefix) = @_;
$file = defined $file ? quotemeta $file : '\(eval \d+\)';
$prefix = defined $prefix ? quotemeta $prefix : 'warn:';
qr/^${prefix}Indirect call of method "new" on object "$pkg" at $file line \d+/;
}
{
my $code = do { local $/; <DATA> };
my (%res, $num, @left);
{
local $SIG{__WARN__} = sub {
++$num;
my $w = join '', 'warn:', @_;
if ($w =~ /"P(\d+)"/ and not exists $res{$1}) {
$res{$1} = $w;
} else {
push @left, "[$num] $w";
}
};
eval "return; $code";
}
is $@, '', 'DATA compiled fine';
for (1 .. $tests) {
my $w = $res{$_};
if ($wrong{$_}) {
like $w, expect("P$_"), "$_ should warn";
} else {
is $w, undef, "$_ shouldn't warn";
}
}
is @left, 0, 'nothing left';
diag "Extraneous warnings:\n", @left if @left;
}
{
my @w;
{
local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
eval 'return; { no indirect "global" }; BEGIN { eval q[return; new XYZ] }';
}
is $@, '', 'eval test did not croak prematurely';
is @w, 1, 'eval test threw one warning';
diag join "\n", 'All warnings:', @w if @w > 1;
like $w[0], expect('XYZ'), 'eval test threw the correct warning';
}
{
my @w;
{
local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
eval 'return; { no indirect "global" }; use indirect::TestRequiredGlobal';
}
is $@, '', 'require test did not croak prematurely';
is @w, 3, 'require test threw three warnings';
diag join "\n", 'All warnings:', @w if @w > 3;
like $w[0], expect('ABC', 't/lib/indirect/TestRequiredGlobal.pm'),
'require test first warning is correct';
like $w[1], expect('DEF'), 'require test second warning is correct';
like $w[2], expect('GHI'), 'require test third warning is correct';
}
{
my @w;
{
local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
eval 'return; { no indirect qw<global fatal> }; new MNO';
}
like $@, expect('MNO', undef, ''), 'fatal test throw the correct exception';
is @w, 0, 'fatal test did not throw any warning';
diag join "\n", 'All warnings:', @w if @w;
}
{
my @w;
my @h;
my $hook = sub { push @h, join '', 'hook:', indirect::msg(@_) };
{
local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
eval 'return; { no indirect hook => $hook, "global" }; new PQR';
}
is $@, '', 'hook test did not croak prematurely';
is @w, 0, 'hook test did not throw any warning';
diag join "\n", 'All warnings:', @w if @w;
is @h, 1, 'hook test hooked up three violations';
diag join "\n", 'All captured violations:', @h if @h > 1;
like $h[0], expect('PQR', undef, 'hook:'),
'hook test captured the correct error';
}
__DATA__
my $a = new P1;
{
no indirect 'global';
my $b = new P2;
{
my $c = new P3;
}
{
use indirect;
my $d = new P4;
}
my $e = new P5;
}
my $f = new P6;
no indirect;
my $g = new P7;
use indirect;
my $h = new P8;
{
no indirect;
eval { my $i = new P9 };
}
|
