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