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