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