Warn on signs of Moose-borkage (in case it gets to be the first new())
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Carp.pm
1 package # hide from pause
2   DBIx::Class::Carp;
3
4 use strict;
5 use warnings;
6
7 # This is here instead of DBIx::Class because of load-order issues
8 BEGIN {
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
12   *DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN = ($] < 5.008005)
13     ? sub () { 1 }
14     : sub () { 0 }
15   ;
16 }
17
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;
34
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     }
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
85   my $fired = {};
86   *{"${into}::carp_once"} = sub {
87     return if $fired->{$_[0]};
88     $fired->{$_[0]} = 1;
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
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
118     unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN;
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
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.
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