1 package # hide from pause
7 # This is here instead of DBIx::Class because of load-order issues
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)
19 use namespace::clean ();
21 $Carp::Internal{ (__PACKAGE__) }++;
24 my ($skip_pattern, $class) = @_;
26 my $skip_class_data = $class->_skip_namespace_frames
27 if ($class and $class->can('_skip_namespace_frames'));
29 $skip_pattern = qr/$skip_pattern|$skip_class_data/
32 my $fr_num = 1; # skip us and the calling carp*
35 while (@f = caller($fr_num++)) {
38 ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
41 $f[3] =~ /^ (.+) :: ([^\:]+) $/x
45 $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once )$/x
49 $f[0]->can('_skip_namespace_frames')
51 my $extra_skip = $f[0]->_skip_namespace_frames
53 $skip_pattern = qr/$skip_pattern|$extra_skip/;
56 last if $f[0] !~ $skip_pattern;
59 my $site = @f # if empty - nothing matched - full stack
60 ? "at $f[1] line $f[2]"
63 $origin ||= '{UNKNOWN}';
67 $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
73 @warn = "Warning: something's wrong" unless @warn;
75 # back-compat with Carp::Clan - a warning ending with \n does
76 # not include caller info
79 $warn[-1] =~ /\n$/ ? '' : " $ln\n"
84 my (undef, $skip_pattern) = @_;
87 $skip_pattern = $skip_pattern
88 ? qr/ ^ $into $ | $skip_pattern /x
94 *{"${into}::carp"} = sub {
96 __find_caller($skip_pattern, $into),
102 *{"${into}::carp_once"} = sub {
103 return if $fired->{$_[0]};
107 __find_caller($skip_pattern, $into),
113 *{"${into}::carp_unique"} = sub {
114 my ($ln, $calling) = __find_caller($skip_pattern, $into);
115 my $msg = join ('', $calling, @_);
117 # unique carping with a hidden caller makes no sense
120 return if $seen->{$ln}{$msg};
121 $seen->{$ln}{$msg} = 1;
129 # cleanup after ourselves
130 namespace::clean->import(-cleanee => $into, qw/carp carp_once carp_unique/)
131 ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading
132 # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie()
133 # see if this starts working
134 unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN;
138 die (__PACKAGE__ . " does not implement unimport yet\n");
145 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
149 Documentation is lacking on purpose - this an experiment not yet fit for
150 mass consumption. If you use this do not count on any kind of stability,
151 in fact don't even count on this module's continuing existence (it has
152 been noindexed for a reason).
154 In addition to the classic interface:
156 use DBIx::Class::Carp '^DBIx::Class'
158 this module also supports a class-data based way to specify the exclusion
159 regex. A message is only carped from a callsite that matches neither the
160 closed over string, nor the value of L</_skip_namespace_frames> as declared
161 on any callframe already skipped due to the same mechanism. This is to ensure
162 that intermediate callsites can declare their own additional skip-namespaces.
164 =head1 CLASS ATTRIBUTES
166 =head2 _skip_namespace_frames
168 A classdata attribute holding the stringified regex matching callsites that
169 should be skipped by the carp methods below. An empty string C<q{}> is treated
170 like no setting/C<undef> (the distinction is necessary due to semantics of the
171 class data accessors provided by L<Class::Accessor::Grouped>)
173 =head1 EXPORTED FUNCTIONS
175 This module export the following 3 functions. Only warning related C<carp*>
176 is being handled here, for C<croak>-ing you must use
177 L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
181 Carps message with the file/line of the first callsite not matching
182 L</_skip_namespace_frames> nor the closed-over arguments to
183 C<use DBIx::Class::Carp>.
187 Like L</carp> but warns once for every distinct callsite (subject to the
188 same ruleset as L</carp>).
192 Like L</carp> but warns only once for the life of the perl interpreter
193 (regardless of callsite).