Commit | Line | Data |
9851271f |
1 | package # hide from pause |
2 | DBIx::Class::Carp; |
70c28808 |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
e0b2dc74 |
7 | # This is here instead of DBIx::Class because of load-order issues |
8 | BEGIN { |
cd122820 |
9 | # something is tripping up V::M on 5.8.1, leading to segfaults. |
10 | # A similar test in n::c itself is disabled on 5.8.1 for the same |
11 | # reason. There isn't much motivation to try to find why it happens |
e0b2dc74 |
12 | *DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN = ($] < 5.008005) |
13 | ? sub () { 1 } |
14 | : sub () { 0 } |
15 | ; |
16 | } |
17 | |
8c49cf15 |
18 | # load Carp early to prevent tickling of the ::Internal stash being |
19 | # interpreted as "Carp is already loaded" by some braindead loader |
70c28808 |
20 | use Carp (); |
5e0e5426 |
21 | $Carp::Internal{ (__PACKAGE__) }++; |
22 | |
70c28808 |
23 | sub __find_caller { |
24 | my ($skip_pattern, $class) = @_; |
25 | |
26 | my $skip_class_data = $class->_skip_namespace_frames |
27 | if ($class and $class->can('_skip_namespace_frames')); |
28 | |
29 | $skip_pattern = qr/$skip_pattern|$skip_class_data/ |
30 | if $skip_class_data; |
31 | |
32 | my $fr_num = 1; # skip us and the calling carp* |
5e0e5426 |
33 | |
34 | my (@f, $origin); |
70c28808 |
35 | while (@f = caller($fr_num++)) { |
5e0e5426 |
36 | |
37 | next if |
38 | ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ ); |
39 | |
40 | $origin ||= ( |
41 | $f[3] =~ /^ (.+) :: ([^\:]+) $/x |
42 | and |
43 | ! $Carp::Internal{$1} |
44 | and |
cc414f09 |
45 | ############################# |
46 | # Need a way to parameterize this for Carp::Skip |
47 | $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime )$/x |
48 | and |
49 | $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/x |
50 | ############################# |
5e0e5426 |
51 | ) ? $f[3] : undef; |
52 | |
cd122820 |
53 | if ( |
54 | $f[0]->can('_skip_namespace_frames') |
55 | and |
56 | my $extra_skip = $f[0]->_skip_namespace_frames |
57 | ) { |
58 | $skip_pattern = qr/$skip_pattern|$extra_skip/; |
59 | } |
81fecf64 |
60 | |
61 | last if $f[0] !~ $skip_pattern; |
70c28808 |
62 | } |
63 | |
5e0e5426 |
64 | my $site = @f # if empty - nothing matched - full stack |
65 | ? "at $f[1] line $f[2]" |
66 | : Carp::longmess() |
70c28808 |
67 | ; |
5e0e5426 |
68 | $origin ||= '{UNKNOWN}'; |
70c28808 |
69 | |
70 | return ( |
5e0e5426 |
71 | $site, |
72 | $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan |
70c28808 |
73 | ); |
74 | }; |
75 | |
76 | my $warn = sub { |
77 | my ($ln, @warn) = @_; |
78 | @warn = "Warning: something's wrong" unless @warn; |
79 | |
80 | # back-compat with Carp::Clan - a warning ending with \n does |
81 | # not include caller info |
82 | warn ( |
83 | @warn, |
84 | $warn[-1] =~ /\n$/ ? '' : " $ln\n" |
85 | ); |
86 | }; |
87 | |
88 | sub import { |
89 | my (undef, $skip_pattern) = @_; |
90 | my $into = caller; |
91 | |
92 | $skip_pattern = $skip_pattern |
569b96bb |
93 | ? qr/ ^ $into $ | $skip_pattern /x |
94 | : qr/ ^ $into $ /x |
70c28808 |
95 | ; |
96 | |
97 | no strict 'refs'; |
98 | |
99 | *{"${into}::carp"} = sub { |
100 | $warn->( |
101 | __find_caller($skip_pattern, $into), |
102 | @_ |
103 | ); |
104 | }; |
105 | |
8fda97d5 |
106 | my $fired = {}; |
70c28808 |
107 | *{"${into}::carp_once"} = sub { |
8fda97d5 |
108 | return if $fired->{$_[0]}; |
109 | $fired->{$_[0]} = 1; |
70c28808 |
110 | |
111 | $warn->( |
112 | __find_caller($skip_pattern, $into), |
113 | @_, |
114 | ); |
115 | }; |
116 | |
117 | my $seen; |
118 | *{"${into}::carp_unique"} = sub { |
119 | my ($ln, $calling) = __find_caller($skip_pattern, $into); |
120 | my $msg = join ('', $calling, @_); |
121 | |
122 | # unique carping with a hidden caller makes no sense |
123 | $msg =~ s/\n+$//; |
124 | |
125 | return if $seen->{$ln}{$msg}; |
126 | $seen->{$ln}{$msg} = 1; |
127 | |
128 | $warn->( |
129 | $ln, |
130 | $msg, |
131 | ); |
132 | }; |
133 | |
134 | # cleanup after ourselves |
90cfe42b |
135 | namespace::clean->import(-cleanee => $into, qw/carp carp_once carp_unique/) |
136 | ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading |
137 | # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie() |
138 | # see if this starts working |
0d8817bc |
139 | unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN; |
70c28808 |
140 | } |
141 | |
142 | sub unimport { |
143 | die (__PACKAGE__ . " does not implement unimport yet\n"); |
144 | } |
145 | |
146 | 1; |
147 | |
148 | =head1 NAME |
149 | |
150 | DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals |
151 | |
152 | =head1 DESCRIPTION |
153 | |
154 | Documentation is lacking on purpose - this an experiment not yet fit for |
155 | mass consumption. If you use this do not count on any kind of stability, |
156 | in fact don't even count on this module's continuing existence (it has |
157 | been noindexed for a reason). |
158 | |
159 | In addition to the classic interface: |
160 | |
161 | use DBIx::Class::Carp '^DBIx::Class' |
162 | |
163 | this module also supports a class-data based way to specify the exclusion |
164 | regex. A message is only carped from a callsite that matches neither the |
165 | closed over string, nor the value of L</_skip_namespace_frames> as declared |
cd122820 |
166 | on any callframe already skipped due to the same mechanism. This is to ensure |
167 | that intermediate callsites can declare their own additional skip-namespaces. |
70c28808 |
168 | |
169 | =head1 CLASS ATTRIBUTES |
170 | |
171 | =head2 _skip_namespace_frames |
172 | |
173 | A classdata attribute holding the stringified regex matching callsites that |
174 | should be skipped by the carp methods below. An empty string C<q{}> is treated |
175 | like no setting/C<undef> (the distinction is necessary due to semantics of the |
176 | class data accessors provided by L<Class::Accessor::Grouped>) |
177 | |
178 | =head1 EXPORTED FUNCTIONS |
179 | |
180 | This module export the following 3 functions. Only warning related C<carp*> |
181 | is being handled here, for C<croak>-ing you must use |
182 | L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>. |
183 | |
184 | =head2 carp |
185 | |
186 | Carps message with the file/line of the first callsite not matching |
187 | L</_skip_namespace_frames> nor the closed-over arguments to |
188 | C<use DBIx::Class::Carp>. |
189 | |
190 | =head2 carp_unique |
191 | |
192 | Like L</carp> but warns once for every distinct callsite (subject to the |
193 | same ruleset as L</carp>). |
194 | |
195 | =head2 carp_once |
196 | |
197 | Like L</carp> but warns only once for the life of the perl interpreter |
198 | (regardless of callsite). |
199 | |
200 | =cut |