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