Redo badly named constant folding arg introduced in 8d73fcd4
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Carp.pm
CommitLineData
9851271f 1package # hide from pause
2 DBIx::Class::Carp;
70c28808 3
4use strict;
5use warnings;
6
8c49cf15 7# load Carp early to prevent tickling of the ::Internal stash being
8# interpreted as "Carp is already loaded" by some braindead loader
70c28808 9use Carp ();
5e0e5426 10$Carp::Internal{ (__PACKAGE__) }++;
11
70c28808 12sub __find_caller {
13 my ($skip_pattern, $class) = @_;
14
15 my $skip_class_data = $class->_skip_namespace_frames
16 if ($class and $class->can('_skip_namespace_frames'));
17
18 $skip_pattern = qr/$skip_pattern|$skip_class_data/
19 if $skip_class_data;
20
21 my $fr_num = 1; # skip us and the calling carp*
5e0e5426 22
23 my (@f, $origin);
70c28808 24 while (@f = caller($fr_num++)) {
5e0e5426 25
26 next if
27 ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
28
29 $origin ||= (
30 $f[3] =~ /^ (.+) :: ([^\:]+) $/x
31 and
32 ! $Carp::Internal{$1}
33 and
cc414f09 34#############################
35# Need a way to parameterize this for Carp::Skip
36 $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime )$/x
37 and
38 $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/x
39#############################
5e0e5426 40 ) ? $f[3] : undef;
41
cd122820 42 if (
43 $f[0]->can('_skip_namespace_frames')
44 and
45 my $extra_skip = $f[0]->_skip_namespace_frames
46 ) {
47 $skip_pattern = qr/$skip_pattern|$extra_skip/;
48 }
81fecf64 49
50 last if $f[0] !~ $skip_pattern;
70c28808 51 }
52
5e0e5426 53 my $site = @f # if empty - nothing matched - full stack
54 ? "at $f[1] line $f[2]"
55 : Carp::longmess()
70c28808 56 ;
5e0e5426 57 $origin ||= '{UNKNOWN}';
70c28808 58
59 return (
5e0e5426 60 $site,
61 $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
70c28808 62 );
63};
64
65my $warn = sub {
66 my ($ln, @warn) = @_;
67 @warn = "Warning: something's wrong" unless @warn;
68
69 # back-compat with Carp::Clan - a warning ending with \n does
70 # not include caller info
71 warn (
72 @warn,
73 $warn[-1] =~ /\n$/ ? '' : " $ln\n"
74 );
75};
76
77sub import {
78 my (undef, $skip_pattern) = @_;
79 my $into = caller;
80
81 $skip_pattern = $skip_pattern
569b96bb 82 ? qr/ ^ $into $ | $skip_pattern /x
83 : qr/ ^ $into $ /x
70c28808 84 ;
85
86 no strict 'refs';
87
88 *{"${into}::carp"} = sub {
89 $warn->(
90 __find_caller($skip_pattern, $into),
91 @_
92 );
93 };
94
8fda97d5 95 my $fired = {};
70c28808 96 *{"${into}::carp_once"} = sub {
8fda97d5 97 return if $fired->{$_[0]};
98 $fired->{$_[0]} = 1;
70c28808 99
100 $warn->(
101 __find_caller($skip_pattern, $into),
102 @_,
103 );
104 };
105
106 my $seen;
107 *{"${into}::carp_unique"} = sub {
108 my ($ln, $calling) = __find_caller($skip_pattern, $into);
109 my $msg = join ('', $calling, @_);
110
111 # unique carping with a hidden caller makes no sense
112 $msg =~ s/\n+$//;
113
114 return if $seen->{$ln}{$msg};
115 $seen->{$ln}{$msg} = 1;
116
117 $warn->(
118 $ln,
119 $msg,
120 );
121 };
70c28808 122}
123
124sub unimport {
125 die (__PACKAGE__ . " does not implement unimport yet\n");
126}
127
1281;
129
a2bd3796 130__END__
131
70c28808 132=head1 NAME
133
134DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
135
136=head1 DESCRIPTION
137
138Documentation is lacking on purpose - this an experiment not yet fit for
139mass consumption. If you use this do not count on any kind of stability,
140in fact don't even count on this module's continuing existence (it has
141been noindexed for a reason).
142
143In addition to the classic interface:
144
145 use DBIx::Class::Carp '^DBIx::Class'
146
147this module also supports a class-data based way to specify the exclusion
148regex. A message is only carped from a callsite that matches neither the
149closed over string, nor the value of L</_skip_namespace_frames> as declared
cd122820 150on any callframe already skipped due to the same mechanism. This is to ensure
151that intermediate callsites can declare their own additional skip-namespaces.
70c28808 152
153=head1 CLASS ATTRIBUTES
154
155=head2 _skip_namespace_frames
156
157A classdata attribute holding the stringified regex matching callsites that
158should be skipped by the carp methods below. An empty string C<q{}> is treated
159like no setting/C<undef> (the distinction is necessary due to semantics of the
160class data accessors provided by L<Class::Accessor::Grouped>)
161
162=head1 EXPORTED FUNCTIONS
163
164This module export the following 3 functions. Only warning related C<carp*>
165is being handled here, for C<croak>-ing you must use
166L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
167
168=head2 carp
169
170Carps message with the file/line of the first callsite not matching
171L</_skip_namespace_frames> nor the closed-over arguments to
172C<use DBIx::Class::Carp>.
173
174=head2 carp_unique
175
176Like L</carp> but warns once for every distinct callsite (subject to the
177same ruleset as L</carp>).
178
179=head2 carp_once
180
181Like L</carp> but warns only once for the life of the perl interpreter
182(regardless of callsite).
183
a2bd3796 184=head1 FURTHER QUESTIONS?
185
186Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
187
188=head1 COPYRIGHT AND LICENSE
189
190This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
191by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
192redistribute it and/or modify it under the same terms as the
193L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
194
70c28808 195=cut