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