1 package # hide from pause
7 # load Carp early to prevent tickling of the ::Internal stash being
8 # interpreted as "Carp is already loaded" by some braindead loader
10 $Carp::Internal{ (__PACKAGE__) }++;
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 )
20 local $SIG{__DIE__} if $SIG{__DIE__};
24 $cref = $_[0]->can( $_[1] );
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';
34 # can not use DBIC::_Util::emit_loud_diag - it uses us internally
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] ),
46 my ($skip_pattern, $class) = @_;
48 my $skip_class_data = $class->_skip_namespace_frames
49 if ($class and __safe_can($class, '_skip_namespace_frames') );
51 $skip_pattern = qr/$skip_pattern|$skip_class_data/
54 my $fr_num = 1; # skip us and the calling carp*
56 my (@f, $origin, $eval_src);
57 while (@f = CORE::caller($fr_num++)) {
64 # there is no value reporting a sourceless eval frame
66 ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ )
68 not defined ( $eval_src = (CORE::caller($fr_num))[6] )
71 $f[3] =~ /::__ANON__$/
75 $f[3] =~ /^ (.+) :: ([^\:]+) $/x
79 #############################
80 # Need a way to parameterize this for Carp::Skip
81 $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
83 $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
84 #############################
88 __safe_can( $f[0], '_skip_namespace_frames' )
90 my $extra_skip = $f[0]->_skip_namespace_frames
92 $skip_pattern = qr/$skip_pattern|$extra_skip/;
95 last if $f[0] !~ $skip_pattern;
98 my $site = @f # if empty - nothing matched - full stack
99 ? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n === BEGIN $f[1]\n$eval_src\n === END $f[1]" : '' ) )
106 # cargo-cult from Carp::Clan
107 ! defined $origin ? ''
108 : $origin =~ /::/ ? "$origin(): "
115 my ($ln, @warn) = @_;
116 @warn = "Warning: something's wrong" unless @warn;
118 # back-compat with Carp::Clan - a warning ending with \n does
119 # not include caller info
122 $warn[-1] =~ /\n$/ ? '' : " $ln\n"
127 my (undef, $skip_pattern) = @_;
130 $skip_pattern = $skip_pattern
131 ? qr/ ^ $into $ | $skip_pattern /x
137 *{"${into}::carp"} = sub {
139 __find_caller($skip_pattern, $into),
145 *{"${into}::carp_once"} = sub {
146 return if $fired->{$_[0]};
150 __find_caller($skip_pattern, $into),
156 *{"${into}::carp_unique"} = sub {
157 my ($ln, $calling) = __find_caller($skip_pattern, $into);
158 my $msg = join ('', $calling, @_);
160 # unique carping with a hidden caller makes no sense
163 return if $seen->{$ln}{$msg};
164 $seen->{$ln}{$msg} = 1;
174 die (__PACKAGE__ . " does not implement unimport yet\n");
183 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
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).
192 In addition to the classic interface:
194 use DBIx::Class::Carp '^DBIx::Class'
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
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.
202 =head1 CLASS ATTRIBUTES
204 =head2 _skip_namespace_frames
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>)
211 =head1 EXPORTED FUNCTIONS
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>.
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>.
225 Like L</carp> but warns once for every distinct callsite (subject to the
226 same ruleset as L</carp>).
230 Like L</carp> but warns only once for the life of the perl interpreter
231 (regardless of callsite).
233 =head1 FURTHER QUESTIONS?
235 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
237 =head1 COPYRIGHT AND LICENSE
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>.