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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
#!/usr/bin/env perl
use strict;
use warnings;
use lib qw(t/lib);
use vars qw($COUNTER $ERR);
use Test::More tests => 24;
# when tests fail here, it tends to be because one or more of them hasn't run, for whatever reason, rather than failures
# thus each test is numbered sequentially so that tests that haven't executed can easily be tracked down
{
use Devel::Pragma qw(on_require);
BEGIN { $COUNTER = 1 }
BEGIN {
on_require(
sub { ok($COUNTER < 3, 'test 1: pre-require callback called at compile-time ' . $COUNTER) },
sub { ok($COUNTER < 3, 'test 2: post-require callback called at compile-time ' . $COUNTER); ++$COUNTER },
);
}
use require_1;
use require_1; # make sure requiring an already required module doesn't trigger another callback
BEGIN { is(require_1::test(), 'require_1', 'test 3: require_1 loaded') }
use require_2;
use require_2; # make sure requiring an already required module doesn't trigger another callback
BEGIN { is(require_2::test(), 'require_2', 'test 4: require_2 loaded') }
BEGIN { is($COUNTER, 3, 'test 5: callbacks called twice') }
require require_3; # runtime require should not be hooked
is(require_3::test(), 'require_3', 'test 6: require_3 loaded');
}
{
use Devel::Pragma qw(:all);
BEGIN { hints->{'PRE_REQUIRE_EXCEPTION_CAUGHT'} = 1 }
BEGIN {
on_require(
sub { die "pre-require exception" },
sub { },
);
}
BEGIN {
local $SIG{__WARN__} = sub {
like($_[0],
qr{Devel::Pragma: exception in pre-require callback: pre-require exception},
'test 7: exception in pre-require callback raises warning'
);
};
eval 'use require_4';
eval 'use require_4'; # make sure requiring an already required module doesn't trigger another callback
}
BEGIN {
is(require_4::test(), 'require_4', 'test 8: require_4 loaded');
is(hints->{'PRE_REQUIRE_EXCEPTION_CAUGHT'}, 1, 'test 9: exception in pre-require callback caught');
}
}
{
use Devel::Pragma qw(:all);
BEGIN { hints->{'POST_REQUIRE_EXCEPTION_CAUGHT'} = 1 }
BEGIN {
on_require(
sub { },
sub { die "post-require exception" },
);
}
BEGIN {
local $SIG{__WARN__} = sub {
like($_[0],
qr{Devel::Pragma: exception in post-require callback: post-require exception},
'test 10: exception in post-require callback raises warning'
);
};
eval 'use require_5';
eval 'use require_5'; # make sure requiring an already required module doesn't trigger another callback
}
BEGIN {
is(require_5::test(), 'require_5', 'test 11: require_5 loaded');
is(hints->{'POST_REQUIRE_EXCEPTION_CAUGHT'}, 1, 'test 12: exception in post-require callback caught');
}
}
{
use Devel::Pragma qw(:all);
BEGIN { hints->{'CLEANUP_AFTER_NESTED_EXCEPTION'} = 1 }
BEGIN {
on_require(
sub { },
sub {
pass('test 13: post-require callback still called after require fails');
die 'nested exception'
}
);
}
BEGIN {
local $SIG{__WARN__} = sub {
like($_[0],
qr{Devel::Pragma: exception in post-require callback: nested exception},
'test 14: post-require callback exception after require exception raises warning'
);
};
eval 'use DevelPragmaNoSuchFile';
$ERR = $@; # BEGIN blocks don't appear to propagate $@
}
like($ERR, qr{^Can't locate DevelPragmaNoSuchFile.pm}, 'test 15: nested require raises a fatal exception');
BEGIN { is(hints->{'CLEANUP_AFTER_NESTED_EXCEPTION'}, 1, 'test 16: %^H value still set after nested exception') }
}
{
use Devel::Pragma qw(:all);
BEGIN { $COUNTER = 0 }
BEGIN {
on_require(
sub { is(++$COUNTER, 1, 'test 17: first pre-require callback called first') },
sub { is(++$COUNTER, 3, 'test 18: first post-require callback called first') },
);
}
BEGIN {
on_require(
sub { is(++$COUNTER, 2, 'test 19: second pre-require callback called second') },
sub { is(++$COUNTER, 4, 'test 20: second post-require callback called second') },
);
}
use require_6;
BEGIN { is(require_6::test(), 'require_6', 'test 21: require_6 loaded') }
}
# make sure the callbacks aren't called out of scope
use require_7;
BEGIN { is(require_7::test(), 'require_7', 'test 22: require_7 loaded') }
|
