Redo badly named constant folding arg introduced in 8d73fcd4
[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 sub __find_caller {
13   my ($skip_pattern, $class) = @_;
14
15   my $skip_class_data = $class->_skip_namespace_frames
16     if ($class and $class->can('_skip_namespace_frames'));
17
18   $skip_pattern = qr/$skip_pattern|$skip_class_data/
19     if $skip_class_data;
20
21   my $fr_num = 1; # skip us and the calling carp*
22
23   my (@f, $origin);
24   while (@f = caller($fr_num++)) {
25
26     next if
27       ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
28
29     $origin ||= (
30       $f[3] =~ /^ (.+) :: ([^\:]+) $/x
31         and
32       ! $Carp::Internal{$1}
33         and
34 #############################
35 # Need a way to parameterize this for Carp::Skip
36       $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime )$/x
37         and
38       $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/x
39 #############################
40     ) ? $f[3] : undef;
41
42     if (
43       $f[0]->can('_skip_namespace_frames')
44         and
45       my $extra_skip = $f[0]->_skip_namespace_frames
46     ) {
47       $skip_pattern = qr/$skip_pattern|$extra_skip/;
48     }
49
50     last if $f[0] !~ $skip_pattern;
51   }
52
53   my $site = @f # if empty - nothing matched - full stack
54     ? "at $f[1] line $f[2]"
55     : Carp::longmess()
56   ;
57   $origin ||= '{UNKNOWN}';
58
59   return (
60     $site,
61     $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
62   );
63 };
64
65 my $warn = sub {
66   my ($ln, @warn) = @_;
67   @warn = "Warning: something's wrong" unless @warn;
68
69   # back-compat with Carp::Clan - a warning ending with \n does
70   # not include caller info
71   warn (
72     @warn,
73     $warn[-1] =~ /\n$/ ? '' : " $ln\n"
74   );
75 };
76
77 sub import {
78   my (undef, $skip_pattern) = @_;
79   my $into = caller;
80
81   $skip_pattern = $skip_pattern
82     ? qr/ ^ $into $ | $skip_pattern /x
83     : qr/ ^ $into $ /x
84   ;
85
86   no strict 'refs';
87
88   *{"${into}::carp"} = sub {
89     $warn->(
90       __find_caller($skip_pattern, $into),
91       @_
92     );
93   };
94
95   my $fired = {};
96   *{"${into}::carp_once"} = sub {
97     return if $fired->{$_[0]};
98     $fired->{$_[0]} = 1;
99
100     $warn->(
101       __find_caller($skip_pattern, $into),
102       @_,
103     );
104   };
105
106   my $seen;
107   *{"${into}::carp_unique"} = sub {
108     my ($ln, $calling) = __find_caller($skip_pattern, $into);
109     my $msg = join ('', $calling, @_);
110
111     # unique carping with a hidden caller makes no sense
112     $msg =~ s/\n+$//;
113
114     return if $seen->{$ln}{$msg};
115     $seen->{$ln}{$msg} = 1;
116
117     $warn->(
118       $ln,
119       $msg,
120     );
121   };
122 }
123
124 sub unimport {
125   die (__PACKAGE__ . " does not implement unimport yet\n");
126 }
127
128 1;
129
130 __END__
131
132 =head1 NAME
133
134 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
135
136 =head1 DESCRIPTION
137
138 Documentation is lacking on purpose - this an experiment not yet fit for
139 mass consumption. If you use this do not count on any kind of stability,
140 in fact don't even count on this module's continuing existence (it has
141 been noindexed for a reason).
142
143 In addition to the classic interface:
144
145   use DBIx::Class::Carp '^DBIx::Class'
146
147 this module also supports a class-data based way to specify the exclusion
148 regex. A message is only carped from a callsite that matches neither the
149 closed over string, nor the value of L</_skip_namespace_frames> as declared
150 on any callframe already skipped due to the same mechanism. This is to ensure
151 that intermediate callsites can declare their own additional skip-namespaces.
152
153 =head1 CLASS ATTRIBUTES
154
155 =head2 _skip_namespace_frames
156
157 A classdata attribute holding the stringified regex matching callsites that
158 should be skipped by the carp methods below. An empty string C<q{}> is treated
159 like no setting/C<undef> (the distinction is necessary due to semantics of the
160 class data accessors provided by L<Class::Accessor::Grouped>)
161
162 =head1 EXPORTED FUNCTIONS
163
164 This module export the following 3 functions. Only warning related C<carp*>
165 is being handled here, for C<croak>-ing you must use
166 L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
167
168 =head2 carp
169
170 Carps message with the file/line of the first callsite not matching
171 L</_skip_namespace_frames> nor the closed-over arguments to
172 C<use DBIx::Class::Carp>.
173
174 =head2 carp_unique
175
176 Like L</carp> but warns once for every distinct callsite (subject to the
177 same ruleset as L</carp>).
178
179 =head2 carp_once
180
181 Like L</carp> but warns only once for the life of the perl interpreter
182 (regardless of callsite).
183
184 =head1 FURTHER QUESTIONS?
185
186 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
187
188 =head1 COPYRIGHT AND LICENSE
189
190 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
191 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
192 redistribute it and/or modify it under the same terms as the
193 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
194
195 =cut