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