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