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 | |
47 | sub import { |
48 | my (undef, $skip_pattern) = @_; |
49 | my $into = caller; |
50 | |
51 | $skip_pattern = $skip_pattern |
52 | ? qr/ ^ $into $ | $skip_pattern /xo |
53 | : qr/ ^ $into $ /xo |
54 | ; |
55 | |
56 | no strict 'refs'; |
57 | |
58 | *{"${into}::carp"} = sub { |
59 | $warn->( |
60 | __find_caller($skip_pattern, $into), |
61 | @_ |
62 | ); |
63 | }; |
64 | |
65 | my $fired; |
66 | *{"${into}::carp_once"} = sub { |
67 | return if $fired; |
68 | $fired = 1; |
69 | |
70 | $warn->( |
71 | __find_caller($skip_pattern, $into), |
72 | @_, |
73 | ); |
74 | }; |
75 | |
76 | my $seen; |
77 | *{"${into}::carp_unique"} = sub { |
78 | my ($ln, $calling) = __find_caller($skip_pattern, $into); |
79 | my $msg = join ('', $calling, @_); |
80 | |
81 | # unique carping with a hidden caller makes no sense |
82 | $msg =~ s/\n+$//; |
83 | |
84 | return if $seen->{$ln}{$msg}; |
85 | $seen->{$ln}{$msg} = 1; |
86 | |
87 | $warn->( |
88 | $ln, |
89 | $msg, |
90 | ); |
91 | }; |
92 | |
93 | # cleanup after ourselves |
94 | namespace::clean->import(-cleanee => $into, qw/carp carp_once carp_unique/); |
95 | } |
96 | |
97 | sub unimport { |
98 | die (__PACKAGE__ . " does not implement unimport yet\n"); |
99 | } |
100 | |
101 | 1; |
102 | |
103 | =head1 NAME |
104 | |
105 | DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals |
106 | |
107 | =head1 DESCRIPTION |
108 | |
109 | Documentation is lacking on purpose - this an experiment not yet fit for |
110 | mass consumption. If you use this do not count on any kind of stability, |
111 | in fact don't even count on this module's continuing existence (it has |
112 | been noindexed for a reason). |
113 | |
114 | In addition to the classic interface: |
115 | |
116 | use DBIx::Class::Carp '^DBIx::Class' |
117 | |
118 | this module also supports a class-data based way to specify the exclusion |
119 | regex. A message is only carped from a callsite that matches neither the |
120 | closed over string, nor the value of L</_skip_namespace_frames> as declared |
121 | on the B<first> callframe origin. |
122 | |
123 | =head1 CLASS ATTRIBUTES |
124 | |
125 | =head2 _skip_namespace_frames |
126 | |
127 | A classdata attribute holding the stringified regex matching callsites that |
128 | should be skipped by the carp methods below. An empty string C<q{}> is treated |
129 | like no setting/C<undef> (the distinction is necessary due to semantics of the |
130 | class data accessors provided by L<Class::Accessor::Grouped>) |
131 | |
132 | =head1 EXPORTED FUNCTIONS |
133 | |
134 | This module export the following 3 functions. Only warning related C<carp*> |
135 | is being handled here, for C<croak>-ing you must use |
136 | L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>. |
137 | |
138 | =head2 carp |
139 | |
140 | Carps message with the file/line of the first callsite not matching |
141 | L</_skip_namespace_frames> nor the closed-over arguments to |
142 | C<use DBIx::Class::Carp>. |
143 | |
144 | =head2 carp_unique |
145 | |
146 | Like L</carp> but warns once for every distinct callsite (subject to the |
147 | same ruleset as L</carp>). |
148 | |
149 | =head2 carp_once |
150 | |
151 | Like L</carp> but warns only once for the life of the perl interpreter |
152 | (regardless of callsite). |
153 | |
154 | =cut |