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