lib/DBIx/Class/Carp.pm

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