lib/DBIx/Class/Carp.pm

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