lib/DBIx/Class/Carp.pm

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