/
Carp.pm
244 lines (185 loc) · 6.36 KB
/
Carp.pm
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
package # hide from pause
DBIx::Class::Carp;
use strict;
use warnings;
# load Carp early to prevent tickling of the ::Internal stash being
# interpreted as "Carp is already loaded" by some braindead loader
use Carp ();
$Carp::Internal{ (__PACKAGE__) }++;
use Scalar::Util ();
# Because... sigh
# There are cases out there where a user provides a can() that won't actually
# work as perl intends it. Since this is a reporting library, we *have* to be
# extra paranoid ( e.g. https://rt.cpan.org/Ticket/Display.html?id=90715 )
sub __safe_can ($$) {
local $@;
local $SIG{__DIE__} if $SIG{__DIE__};
my $cref;
eval {
$cref = $_[0]->can( $_[1] );
# in case the can() isn't an actual UNIVERSAL::can()
die "Return value of $_[0]" . "->can(q($_[1])) is true yet not a code reference...\n"
if $cref and Scalar::Util::reftype($cref) ne 'CODE';
1;
} or do {
undef $cref;
# can not use DBIC::_Util::emit_loud_diag - it uses us internally
printf STDERR
"\n$0: !!! INTERNAL PANIC !!!\nClass '%s' implements or inherits a broken can() - PLEASE FIX ASAP!: %s\n\n",
( length ref $_[0] ? ref $_[0] : $_[0] ),
$@,
;
};
$cref;
}
sub __find_caller {
my ($skip_pattern, $class) = @_;
my $skip_class_data = $class->_skip_namespace_frames
if ($class and __safe_can($class, '_skip_namespace_frames') );
$skip_pattern = qr/$skip_pattern|$skip_class_data/
if $skip_class_data;
my $fr_num = 1; # skip us and the calling carp*
my (@f, $origin, $eval_src);
while (@f = CORE::caller($fr_num++)) {
undef $eval_src;
next if (
$f[2] == 0
or
# there is no value reporting a sourceless eval frame
(
( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ )
and
not defined ( $eval_src = (CORE::caller($fr_num))[6] )
)
or
$f[3] =~ /::__ANON__$/
);
$origin ||= (
$f[3] =~ /^ (.+) :: ([^\:]+) $/x
and
! $Carp::Internal{$1}
and
#############################
# Need a way to parameterize this for Carp::Skip
$1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
and
$2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
#############################
) ? $f[3] : undef;
if (
__safe_can( $f[0], '_skip_namespace_frames' )
and
my $extra_skip = $f[0]->_skip_namespace_frames
) {
$skip_pattern = qr/$skip_pattern|$extra_skip/;
}
last if $f[0] !~ $skip_pattern;
}
my $site = @f # if empty - nothing matched - full stack
? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n === BEGIN $f[1]\n$eval_src\n === END $f[1]" : '' ) )
: Carp::longmess()
;
return (
$site,
(
# cargo-cult from Carp::Clan
! defined $origin ? ''
: $origin =~ /::/ ? "$origin(): "
: "$origin: "
),
);
};
my $warn = sub {
my ($ln, @warn) = @_;
@warn = "Warning: something's wrong" unless @warn;
# back-compat with Carp::Clan - a warning ending with \n does
# not include caller info
warn (
@warn,
$warn[-1] =~ /\n$/ ? '' : " $ln\n"
);
};
sub import {
my (undef, $skip_pattern) = @_;
my $into = caller;
$skip_pattern = $skip_pattern
? qr/ ^ $into $ | $skip_pattern /x
: qr/ ^ $into $ /x
;
no strict 'refs';
*{"${into}::carp"} = sub {
$warn->(
__find_caller($skip_pattern, $into),
@_
);
};
my $fired = {};
*{"${into}::carp_once"} = sub {
return if $fired->{$_[0]};
$fired->{$_[0]} = 1;
$warn->(
__find_caller($skip_pattern, $into),
@_,
);
};
my $seen;
*{"${into}::carp_unique"} = sub {
my ($ln, $calling) = __find_caller($skip_pattern, $into);
my $msg = join ('', $calling, @_);
# unique carping with a hidden caller makes no sense
$msg =~ s/\n+$//;
return if $seen->{$ln}{$msg};
$seen->{$ln}{$msg} = 1;
$warn->(
$ln,
$msg,
);
};
}
sub unimport {
die (__PACKAGE__ . " does not implement unimport yet\n");
}
1;
__END__
=head1 NAME
DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
=head1 DESCRIPTION
Documentation is lacking on purpose - this an experiment not yet fit for
mass consumption. If you use this do not count on any kind of stability,
in fact don't even count on this module's continuing existence (it has
been noindexed for a reason).
In addition to the classic interface:
use DBIx::Class::Carp '^DBIx::Class'
this module also supports a class-data based way to specify the exclusion
regex. A message is only carped from a callsite that matches neither the
closed over string, nor the value of L</_skip_namespace_frames> as declared
on any callframe already skipped due to the same mechanism. This is to ensure
that intermediate callsites can declare their own additional skip-namespaces.
=head1 CLASS ATTRIBUTES
=head2 _skip_namespace_frames
A classdata attribute holding the stringified regex matching callsites that
should be skipped by the carp methods below. An empty string C<q{}> is treated
like no setting/C<undef> (the distinction is necessary due to semantics of the
class data accessors provided by L<Class::Accessor::Grouped>)
=head1 EXPORTED FUNCTIONS
This module export the following 3 functions. Only warning related C<carp*>
is being handled here, for C<croak>-ing you must use
L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
=head2 carp
Carps message with the file/line of the first callsite not matching
L</_skip_namespace_frames> nor the closed-over arguments to
C<use DBIx::Class::Carp>.
=head2 carp_unique
Like L</carp> but warns once for every distinct callsite (subject to the
same ruleset as L</carp>).
=head2 carp_once
Like L</carp> but warns only once for the life of the perl interpreter
(regardless of callsite).
=head1 FURTHER QUESTIONS?
Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
=head1 COPYRIGHT AND LICENSE
This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
redistribute it and/or modify it under the same terms as the
L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
=cut