Remove dead code commented out since 2006 ( 953a18ef )
[dbsrgits/DBIx-Class.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);
821edc09 24 while (@f = CORE::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
821edc09 36 $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
cc414f09 37 and
84efb6d7 38 $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback )$/x
cc414f09 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 ;
57
58 return (
5e0e5426 59 $site,
821edc09 60 (
61 # cargo-cult from Carp::Clan
62 ! defined $origin ? ''
63 : $origin =~ /::/ ? "$origin(): "
64 : "$origin: "
65 ),
70c28808 66 );
67};
68
69my $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
81sub import {
82 my (undef, $skip_pattern) = @_;
83 my $into = caller;
84
85 $skip_pattern = $skip_pattern
569b96bb 86 ? qr/ ^ $into $ | $skip_pattern /x
87 : qr/ ^ $into $ /x
70c28808 88 ;
89
90 no strict 'refs';
91
92 *{"${into}::carp"} = sub {
93 $warn->(
94 __find_caller($skip_pattern, $into),
95 @_
96 );
97 };
98
8fda97d5 99 my $fired = {};
70c28808 100 *{"${into}::carp_once"} = sub {
8fda97d5 101 return if $fired->{$_[0]};
102 $fired->{$_[0]} = 1;
70c28808 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 };
70c28808 126}
127
128sub unimport {
129 die (__PACKAGE__ . " does not implement unimport yet\n");
130}
131
1321;
133
a2bd3796 134__END__
135
70c28808 136=head1 NAME
137
138DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
139
140=head1 DESCRIPTION
141
142Documentation is lacking on purpose - this an experiment not yet fit for
143mass consumption. If you use this do not count on any kind of stability,
144in fact don't even count on this module's continuing existence (it has
145been noindexed for a reason).
146
147In addition to the classic interface:
148
149 use DBIx::Class::Carp '^DBIx::Class'
150
151this module also supports a class-data based way to specify the exclusion
152regex. A message is only carped from a callsite that matches neither the
153closed over string, nor the value of L</_skip_namespace_frames> as declared
cd122820 154on any callframe already skipped due to the same mechanism. This is to ensure
155that intermediate callsites can declare their own additional skip-namespaces.
70c28808 156
157=head1 CLASS ATTRIBUTES
158
159=head2 _skip_namespace_frames
160
161A classdata attribute holding the stringified regex matching callsites that
162should be skipped by the carp methods below. An empty string C<q{}> is treated
163like no setting/C<undef> (the distinction is necessary due to semantics of the
164class data accessors provided by L<Class::Accessor::Grouped>)
165
166=head1 EXPORTED FUNCTIONS
167
168This module export the following 3 functions. Only warning related C<carp*>
169is being handled here, for C<croak>-ing you must use
170L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
171
172=head2 carp
173
174Carps message with the file/line of the first callsite not matching
175L</_skip_namespace_frames> nor the closed-over arguments to
176C<use DBIx::Class::Carp>.
177
178=head2 carp_unique
179
180Like L</carp> but warns once for every distinct callsite (subject to the
181same ruleset as L</carp>).
182
183=head2 carp_once
184
185Like L</carp> but warns only once for the life of the perl interpreter
186(regardless of callsite).
187
a2bd3796 188=head1 FURTHER QUESTIONS?
189
190Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
191
192=head1 COPYRIGHT AND LICENSE
193
194This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
195by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
196redistribute it and/or modify it under the same terms as the
197L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
198
70c28808 199=cut