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 = 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 )$/x
  37         and
  38       $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/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   $origin ||= '{UNKNOWN}';
  58
  59   return (
  60     $site,
  61     $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
  62   );
  63 };
  64
  65 my $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
  77 sub import {
  78   my (undef, $skip_pattern) = @_;
  79   my $into = caller;
  80
  81   $skip_pattern = $skip_pattern
  82     ? qr/ ^ $into $ | $skip_pattern /x
  83     : qr/ ^ $into $ /x
  84   ;
  85
  86   no strict 'refs';
  87
  88   *{"${into}::carp"} = sub {
  89     $warn->(
  90       __find_caller($skip_pattern, $into),
  91       @_
  92     );
  93   };
  94
  95   my $fired = {};
  96   *{"${into}::carp_once"} = sub {
  97     return if $fired->{$_[0]};
  98     $fired->{$_[0]} = 1;
  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   };
 122 }
 123
 124 sub unimport {
 125   die (__PACKAGE__ . " does not implement unimport yet\n");
 126 }
 127
 128 1;
 129
 130 =head1 NAME
 131
 132 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
 133
 134 =head1 DESCRIPTION
 135
 136 Documentation is lacking on purpose - this an experiment not yet fit for
 137 mass consumption. If you use this do not count on any kind of stability,
 138 in fact don't even count on this module's continuing existence (it has
 139 been noindexed for a reason).
 140
 141 In addition to the classic interface:
 142
 143   use DBIx::Class::Carp '^DBIx::Class'
 144
 145 this module also supports a class-data based way to specify the exclusion
 146 regex. A message is only carped from a callsite that matches neither the
 147 closed over string, nor the value of L</_skip_namespace_frames> as declared
 148 on any callframe already skipped due to the same mechanism. This is to ensure
 149 that intermediate callsites can declare their own additional skip-namespaces.
 150
 151 =head1 CLASS ATTRIBUTES
 152
 153 =head2 _skip_namespace_frames
 154
 155 A classdata attribute holding the stringified regex matching callsites that
 156 should be skipped by the carp methods below. An empty string C<q{}> is treated
 157 like no setting/C<undef> (the distinction is necessary due to semantics of the
 158 class data accessors provided by L<Class::Accessor::Grouped>)
 159
 160 =head1 EXPORTED FUNCTIONS
 161
 162 This module export the following 3 functions. Only warning related C<carp*>
 163 is being handled here, for C<croak>-ing you must use
 164 L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
 165
 166 =head2 carp
 167
 168 Carps message with the file/line of the first callsite not matching
 169 L</_skip_namespace_frames> nor the closed-over arguments to
 170 C<use DBIx::Class::Carp>.
 171
 172 =head2 carp_unique
 173
 174 Like L</carp> but warns once for every distinct callsite (subject to the
 175 same ruleset as L</carp>).
 176
 177 =head2 carp_once
 178
 179 Like L</carp> but warns only once for the life of the perl interpreter
 180 (regardless of callsite).
 181
 182 =cut