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