Commit | Line | Data |
9851271f |
1 | package # hide from pause |
2 | DBIx::Class::Carp; |
70c28808 |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
8c49cf15 |
7 | # load Carp early to prevent tickling of the ::Internal stash being |
8 | # interpreted as "Carp is already loaded" by some braindead loader |
70c28808 |
9 | use Carp (); |
5e0e5426 |
10 | $Carp::Internal{ (__PACKAGE__) }++; |
11 | |
17d4e610 |
12 | use Scalar::Util (); |
13 | |
14 | # Because... sigh |
15 | # There are cases out there where a user provides a can() that won't actually |
16 | # work as perl intends it. Since this is a reporting library, we *have* to be |
17 | # extra paranoid ( e.g. https://rt.cpan.org/Ticket/Display.html?id=90715 ) |
18 | sub __safe_can ($$) { |
19 | local $@; |
20 | local $SIG{__DIE__} if $SIG{__DIE__}; |
21 | |
22 | my $cref; |
23 | eval { |
24 | $cref = $_[0]->can( $_[1] ); |
25 | |
26 | # in case the can() isn't an actual UNIVERSAL::can() |
27 | die "Return value of $_[0]" . "->can(q($_[1])) is true yet not a code reference...\n" |
28 | if $cref and Scalar::Util::reftype($cref) ne 'CODE'; |
29 | |
30 | 1; |
31 | } or do { |
32 | undef $cref; |
33 | |
34 | # can not use DBIC::_Util::emit_loud_diag - it uses us internally |
35 | printf STDERR |
36 | "\n$0: !!! INTERNAL PANIC !!!\nClass '%s' implements or inherits a broken can() - PLEASE FIX ASAP!: %s\n\n", |
37 | ( length ref $_[0] ? ref $_[0] : $_[0] ), |
38 | $@, |
39 | ; |
40 | }; |
41 | |
42 | $cref; |
43 | } |
44 | |
70c28808 |
45 | sub __find_caller { |
46 | my ($skip_pattern, $class) = @_; |
47 | |
48 | my $skip_class_data = $class->_skip_namespace_frames |
17d4e610 |
49 | if ($class and __safe_can($class, '_skip_namespace_frames') ); |
70c28808 |
50 | |
51 | $skip_pattern = qr/$skip_pattern|$skip_class_data/ |
52 | if $skip_class_data; |
53 | |
54 | my $fr_num = 1; # skip us and the calling carp* |
5e0e5426 |
55 | |
73f54e27 |
56 | my (@f, $origin, $eval_src); |
821edc09 |
57 | while (@f = CORE::caller($fr_num++)) { |
5e0e5426 |
58 | |
73f54e27 |
59 | undef $eval_src; |
60 | |
61 | next if ( |
62 | $f[2] == 0 |
63 | or |
64 | # there is no value reporting a sourceless eval frame |
65 | ( |
66 | ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ ) |
67 | and |
68 | not defined ( $eval_src = (CORE::caller($fr_num))[6] ) |
69 | ) |
70 | or |
71 | $f[3] =~ /::__ANON__$/ |
72 | ); |
5e0e5426 |
73 | |
74 | $origin ||= ( |
75 | $f[3] =~ /^ (.+) :: ([^\:]+) $/x |
76 | and |
77 | ! $Carp::Internal{$1} |
78 | and |
cc414f09 |
79 | ############################# |
80 | # Need a way to parameterize this for Carp::Skip |
821edc09 |
81 | $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x |
cc414f09 |
82 | and |
ddcc02d1 |
83 | $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x |
cc414f09 |
84 | ############################# |
5e0e5426 |
85 | ) ? $f[3] : undef; |
86 | |
cd122820 |
87 | if ( |
17d4e610 |
88 | __safe_can( $f[0], '_skip_namespace_frames' ) |
cd122820 |
89 | and |
90 | my $extra_skip = $f[0]->_skip_namespace_frames |
91 | ) { |
92 | $skip_pattern = qr/$skip_pattern|$extra_skip/; |
93 | } |
81fecf64 |
94 | |
95 | last if $f[0] !~ $skip_pattern; |
70c28808 |
96 | } |
97 | |
5e0e5426 |
98 | my $site = @f # if empty - nothing matched - full stack |
73f54e27 |
99 | ? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n === BEGIN $f[1]\n$eval_src\n === END $f[1]" : '' ) ) |
5e0e5426 |
100 | : Carp::longmess() |
70c28808 |
101 | ; |
102 | |
103 | return ( |
5e0e5426 |
104 | $site, |
821edc09 |
105 | ( |
106 | # cargo-cult from Carp::Clan |
107 | ! defined $origin ? '' |
108 | : $origin =~ /::/ ? "$origin(): " |
109 | : "$origin: " |
110 | ), |
70c28808 |
111 | ); |
112 | }; |
113 | |
114 | my $warn = sub { |
115 | my ($ln, @warn) = @_; |
116 | @warn = "Warning: something's wrong" unless @warn; |
117 | |
118 | # back-compat with Carp::Clan - a warning ending with \n does |
119 | # not include caller info |
120 | warn ( |
121 | @warn, |
122 | $warn[-1] =~ /\n$/ ? '' : " $ln\n" |
123 | ); |
124 | }; |
125 | |
126 | sub import { |
127 | my (undef, $skip_pattern) = @_; |
128 | my $into = caller; |
129 | |
130 | $skip_pattern = $skip_pattern |
569b96bb |
131 | ? qr/ ^ $into $ | $skip_pattern /x |
132 | : qr/ ^ $into $ /x |
70c28808 |
133 | ; |
134 | |
135 | no strict 'refs'; |
136 | |
137 | *{"${into}::carp"} = sub { |
138 | $warn->( |
139 | __find_caller($skip_pattern, $into), |
140 | @_ |
141 | ); |
142 | }; |
143 | |
8fda97d5 |
144 | my $fired = {}; |
70c28808 |
145 | *{"${into}::carp_once"} = sub { |
8fda97d5 |
146 | return if $fired->{$_[0]}; |
147 | $fired->{$_[0]} = 1; |
70c28808 |
148 | |
149 | $warn->( |
150 | __find_caller($skip_pattern, $into), |
151 | @_, |
152 | ); |
153 | }; |
154 | |
155 | my $seen; |
156 | *{"${into}::carp_unique"} = sub { |
157 | my ($ln, $calling) = __find_caller($skip_pattern, $into); |
158 | my $msg = join ('', $calling, @_); |
159 | |
160 | # unique carping with a hidden caller makes no sense |
161 | $msg =~ s/\n+$//; |
162 | |
163 | return if $seen->{$ln}{$msg}; |
164 | $seen->{$ln}{$msg} = 1; |
165 | |
166 | $warn->( |
167 | $ln, |
168 | $msg, |
169 | ); |
170 | }; |
70c28808 |
171 | } |
172 | |
173 | sub unimport { |
174 | die (__PACKAGE__ . " does not implement unimport yet\n"); |
175 | } |
176 | |
177 | 1; |
178 | |
a2bd3796 |
179 | __END__ |
180 | |
70c28808 |
181 | =head1 NAME |
182 | |
183 | DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals |
184 | |
185 | =head1 DESCRIPTION |
186 | |
187 | Documentation is lacking on purpose - this an experiment not yet fit for |
188 | mass consumption. If you use this do not count on any kind of stability, |
189 | in fact don't even count on this module's continuing existence (it has |
190 | been noindexed for a reason). |
191 | |
192 | In addition to the classic interface: |
193 | |
194 | use DBIx::Class::Carp '^DBIx::Class' |
195 | |
196 | this module also supports a class-data based way to specify the exclusion |
197 | regex. A message is only carped from a callsite that matches neither the |
198 | closed over string, nor the value of L</_skip_namespace_frames> as declared |
cd122820 |
199 | on any callframe already skipped due to the same mechanism. This is to ensure |
200 | that intermediate callsites can declare their own additional skip-namespaces. |
70c28808 |
201 | |
202 | =head1 CLASS ATTRIBUTES |
203 | |
204 | =head2 _skip_namespace_frames |
205 | |
206 | A classdata attribute holding the stringified regex matching callsites that |
207 | should be skipped by the carp methods below. An empty string C<q{}> is treated |
208 | like no setting/C<undef> (the distinction is necessary due to semantics of the |
209 | class data accessors provided by L<Class::Accessor::Grouped>) |
210 | |
211 | =head1 EXPORTED FUNCTIONS |
212 | |
213 | This module export the following 3 functions. Only warning related C<carp*> |
214 | is being handled here, for C<croak>-ing you must use |
215 | L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>. |
216 | |
217 | =head2 carp |
218 | |
219 | Carps message with the file/line of the first callsite not matching |
220 | L</_skip_namespace_frames> nor the closed-over arguments to |
221 | C<use DBIx::Class::Carp>. |
222 | |
223 | =head2 carp_unique |
224 | |
225 | Like L</carp> but warns once for every distinct callsite (subject to the |
226 | same ruleset as L</carp>). |
227 | |
228 | =head2 carp_once |
229 | |
230 | Like L</carp> but warns only once for the life of the perl interpreter |
231 | (regardless of callsite). |
232 | |
a2bd3796 |
233 | =head1 FURTHER QUESTIONS? |
234 | |
235 | Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. |
236 | |
237 | =head1 COPYRIGHT AND LICENSE |
238 | |
239 | This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> |
240 | by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can |
241 | redistribute it and/or modify it under the same terms as the |
242 | L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. |
243 | |
70c28808 |
244 | =cut |