Add an explicit Sub::Quote dep in ::_Util
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Carp.pm
CommitLineData
9851271f 1package # hide from pause
2 DBIx::Class::Carp;
70c28808 3
4use strict;
5use 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 9use Carp ();
5e0e5426 10$Carp::Internal{ (__PACKAGE__) }++;
11
17d4e610 12use 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 )
18sub __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 45sub __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
56 my (@f, $origin);
821edc09 57 while (@f = CORE::caller($fr_num++)) {
5e0e5426 58
59 next if
60 ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
61
62 $origin ||= (
63 $f[3] =~ /^ (.+) :: ([^\:]+) $/x
64 and
65 ! $Carp::Internal{$1}
66 and
cc414f09 67#############################
68# Need a way to parameterize this for Carp::Skip
821edc09 69 $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
cc414f09 70 and
ddcc02d1 71 $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
cc414f09 72#############################
5e0e5426 73 ) ? $f[3] : undef;
74
cd122820 75 if (
17d4e610 76 __safe_can( $f[0], '_skip_namespace_frames' )
cd122820 77 and
78 my $extra_skip = $f[0]->_skip_namespace_frames
79 ) {
80 $skip_pattern = qr/$skip_pattern|$extra_skip/;
81 }
81fecf64 82
83 last if $f[0] !~ $skip_pattern;
70c28808 84 }
85
5e0e5426 86 my $site = @f # if empty - nothing matched - full stack
87 ? "at $f[1] line $f[2]"
88 : Carp::longmess()
70c28808 89 ;
90
91 return (
5e0e5426 92 $site,
821edc09 93 (
94 # cargo-cult from Carp::Clan
95 ! defined $origin ? ''
96 : $origin =~ /::/ ? "$origin(): "
97 : "$origin: "
98 ),
70c28808 99 );
100};
101
102my $warn = sub {
103 my ($ln, @warn) = @_;
104 @warn = "Warning: something's wrong" unless @warn;
105
106 # back-compat with Carp::Clan - a warning ending with \n does
107 # not include caller info
108 warn (
109 @warn,
110 $warn[-1] =~ /\n$/ ? '' : " $ln\n"
111 );
112};
113
114sub import {
115 my (undef, $skip_pattern) = @_;
116 my $into = caller;
117
118 $skip_pattern = $skip_pattern
569b96bb 119 ? qr/ ^ $into $ | $skip_pattern /x
120 : qr/ ^ $into $ /x
70c28808 121 ;
122
123 no strict 'refs';
124
125 *{"${into}::carp"} = sub {
126 $warn->(
127 __find_caller($skip_pattern, $into),
128 @_
129 );
130 };
131
8fda97d5 132 my $fired = {};
70c28808 133 *{"${into}::carp_once"} = sub {
8fda97d5 134 return if $fired->{$_[0]};
135 $fired->{$_[0]} = 1;
70c28808 136
137 $warn->(
138 __find_caller($skip_pattern, $into),
139 @_,
140 );
141 };
142
143 my $seen;
144 *{"${into}::carp_unique"} = sub {
145 my ($ln, $calling) = __find_caller($skip_pattern, $into);
146 my $msg = join ('', $calling, @_);
147
148 # unique carping with a hidden caller makes no sense
149 $msg =~ s/\n+$//;
150
151 return if $seen->{$ln}{$msg};
152 $seen->{$ln}{$msg} = 1;
153
154 $warn->(
155 $ln,
156 $msg,
157 );
158 };
70c28808 159}
160
161sub unimport {
162 die (__PACKAGE__ . " does not implement unimport yet\n");
163}
164
1651;
166
a2bd3796 167__END__
168
70c28808 169=head1 NAME
170
171DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
172
173=head1 DESCRIPTION
174
175Documentation is lacking on purpose - this an experiment not yet fit for
176mass consumption. If you use this do not count on any kind of stability,
177in fact don't even count on this module's continuing existence (it has
178been noindexed for a reason).
179
180In addition to the classic interface:
181
182 use DBIx::Class::Carp '^DBIx::Class'
183
184this module also supports a class-data based way to specify the exclusion
185regex. A message is only carped from a callsite that matches neither the
186closed over string, nor the value of L</_skip_namespace_frames> as declared
cd122820 187on any callframe already skipped due to the same mechanism. This is to ensure
188that intermediate callsites can declare their own additional skip-namespaces.
70c28808 189
190=head1 CLASS ATTRIBUTES
191
192=head2 _skip_namespace_frames
193
194A classdata attribute holding the stringified regex matching callsites that
195should be skipped by the carp methods below. An empty string C<q{}> is treated
196like no setting/C<undef> (the distinction is necessary due to semantics of the
197class data accessors provided by L<Class::Accessor::Grouped>)
198
199=head1 EXPORTED FUNCTIONS
200
201This module export the following 3 functions. Only warning related C<carp*>
202is being handled here, for C<croak>-ing you must use
203L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
204
205=head2 carp
206
207Carps message with the file/line of the first callsite not matching
208L</_skip_namespace_frames> nor the closed-over arguments to
209C<use DBIx::Class::Carp>.
210
211=head2 carp_unique
212
213Like L</carp> but warns once for every distinct callsite (subject to the
214same ruleset as L</carp>).
215
216=head2 carp_once
217
218Like L</carp> but warns only once for the life of the perl interpreter
219(regardless of callsite).
220
a2bd3796 221=head1 FURTHER QUESTIONS?
222
223Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
224
225=head1 COPYRIGHT AND LICENSE
226
227This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
228by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
229redistribute it and/or modify it under the same terms as the
230L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
231
70c28808 232=cut