lib/DBIx/Class/Carp.pm

   1 package # hide from pause
   2   DBIx::Class::Carp;
   3
   4 use strict;
   5 use warnings;
   6
   7 # load Carp early to prevent tickling of the ::Internal stash being
   8 # interpreted as "Carp is already loaded" by some braindead loader
   9 use Carp ();
  10 $Carp::Internal{ (__PACKAGE__) }++;
  11
  12 use Scalar::Util ();
  13
  14 # Because... sigh
  15 # There are cases out there where a user provides a can() that won't actually
  16 # work as perl intends it. Since this is a reporting library, we *have* to be
  17 # extra paranoid ( e.g. https://rt.cpan.org/Ticket/Display.html?id=90715 )
  18 sub __safe_can ($$) {
  19   local $@;
  20   local $SIG{__DIE__} if $SIG{__DIE__};
  21
  22   my $cref;
  23   eval {
  24     $cref = $_[0]->can( $_[1] );
  25
  26     # in case the can() isn't an actual UNIVERSAL::can()
  27     die "Return value of $_[0]" . "->can(q($_[1])) is true yet not a code reference...\n"
  28       if $cref and Scalar::Util::reftype($cref) ne 'CODE';
  29
  30     1;
  31   } or do {
  32     undef $cref;
  33
  34     # can not use DBIC::_Util::emit_loud_diag - it uses us internally
  35     printf STDERR
  36       "\n$0: !!! INTERNAL PANIC !!!\nClass '%s' implements or inherits a broken can() - PLEASE FIX ASAP!: %s\n\n",
  37       ( length ref $_[0] ? ref $_[0] : $_[0] ),
  38       $@,
  39     ;
  40   };
  41
  42   $cref;
  43 }
  44
  45 sub __find_caller {
  46   my ($skip_pattern, $class) = @_;
  47
  48   my $skip_class_data = $class->_skip_namespace_frames
  49     if ($class and __safe_can($class, '_skip_namespace_frames') );
  50
  51   $skip_pattern = qr/$skip_pattern|$skip_class_data/
  52     if $skip_class_data;
  53
  54   my $fr_num = 1; # skip us and the calling carp*
  55
  56   my (@f, $origin);
  57   while (@f = CORE::caller($fr_num++)) {
  58
  59     next if
  60       ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
  61
  62     $origin ||= (
  63       $f[3] =~ /^ (.+) :: ([^\:]+) $/x
  64         and
  65       ! $Carp::Internal{$1}
  66         and
  67 #############################
  68 # Need a way to parameterize this for Carp::Skip
  69       $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
  70         and
  71       $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
  72 #############################
  73     ) ? $f[3] : undef;
  74
  75     if (
  76       __safe_can( $f[0], '_skip_namespace_frames' )
  77         and
  78       my $extra_skip = $f[0]->_skip_namespace_frames
  79     ) {
  80       $skip_pattern = qr/$skip_pattern|$extra_skip/;
  81     }
  82
  83     last if $f[0] !~ $skip_pattern;
  84   }
  85
  86   my $site = @f # if empty - nothing matched - full stack
  87     ? "at $f[1] line $f[2]"
  88     : Carp::longmess()
  89   ;
  90
  91   return (
  92     $site,
  93     (
  94       # cargo-cult from Carp::Clan
  95       ! defined $origin   ? ''
  96     : $origin =~ /::/     ? "$origin(): "
  97                           : "$origin: "
  98     ),
  99   );
 100 };
 101
 102 my $warn = sub {
 103   my ($ln, @warn) = @_;
 104   @warn = "Warning: something's wrong" unless @warn;
 105
 106   # back-compat with Carp::Clan - a warning ending with \n does
 107   # not include caller info
 108   warn (
 109     @warn,
 110     $warn[-1] =~ /\n$/ ? '' : " $ln\n"
 111   );
 112 };
 113
 114 sub import {
 115   my (undef, $skip_pattern) = @_;
 116   my $into = caller;
 117
 118   $skip_pattern = $skip_pattern
 119     ? qr/ ^ $into $ | $skip_pattern /x
 120     : qr/ ^ $into $ /x
 121   ;
 122
 123   no strict 'refs';
 124
 125   *{"${into}::carp"} = sub {
 126     $warn->(
 127       __find_caller($skip_pattern, $into),
 128       @_
 129     );
 130   };
 131
 132   my $fired = {};
 133   *{"${into}::carp_once"} = sub {
 134     return if $fired->{$_[0]};
 135     $fired->{$_[0]} = 1;
 136
 137     $warn->(
 138       __find_caller($skip_pattern, $into),
 139       @_,
 140     );
 141   };
 142
 143   my $seen;
 144   *{"${into}::carp_unique"} = sub {
 145     my ($ln, $calling) = __find_caller($skip_pattern, $into);
 146     my $msg = join ('', $calling, @_);
 147
 148     # unique carping with a hidden caller makes no sense
 149     $msg =~ s/\n+$//;
 150
 151     return if $seen->{$ln}{$msg};
 152     $seen->{$ln}{$msg} = 1;
 153
 154     $warn->(
 155       $ln,
 156       $msg,
 157     );
 158   };
 159 }
 160
 161 sub unimport {
 162   die (__PACKAGE__ . " does not implement unimport yet\n");
 163 }
 164
 165 1;
 166
 167 __END__
 168
 169 =head1 NAME
 170
 171 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
 172
 173 =head1 DESCRIPTION
 174
 175 Documentation is lacking on purpose - this an experiment not yet fit for
 176 mass consumption. If you use this do not count on any kind of stability,
 177 in fact don't even count on this module's continuing existence (it has
 178 been noindexed for a reason).
 179
 180 In addition to the classic interface:
 181
 182   use DBIx::Class::Carp '^DBIx::Class'
 183
 184 this module also supports a class-data based way to specify the exclusion
 185 regex. A message is only carped from a callsite that matches neither the
 186 closed over string, nor the value of L</_skip_namespace_frames> as declared
 187 on any callframe already skipped due to the same mechanism. This is to ensure
 188 that intermediate callsites can declare their own additional skip-namespaces.
 189
 190 =head1 CLASS ATTRIBUTES
 191
 192 =head2 _skip_namespace_frames
 193
 194 A classdata attribute holding the stringified regex matching callsites that
 195 should be skipped by the carp methods below. An empty string C<q{}> is treated
 196 like no setting/C<undef> (the distinction is necessary due to semantics of the
 197 class data accessors provided by L<Class::Accessor::Grouped>)
 198
 199 =head1 EXPORTED FUNCTIONS
 200
 201 This module export the following 3 functions. Only warning related C<carp*>
 202 is being handled here, for C<croak>-ing you must use
 203 L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
 204
 205 =head2 carp
 206
 207 Carps message with the file/line of the first callsite not matching
 208 L</_skip_namespace_frames> nor the closed-over arguments to
 209 C<use DBIx::Class::Carp>.
 210
 211 =head2 carp_unique
 212
 213 Like L</carp> but warns once for every distinct callsite (subject to the
 214 same ruleset as L</carp>).
 215
 216 =head2 carp_once
 217
 218 Like L</carp> but warns only once for the life of the perl interpreter
 219 (regardless of callsite).
 220
 221 =head1 FURTHER QUESTIONS?
 222
 223 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 224
 225 =head1 COPYRIGHT AND LICENSE
 226
 227 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 228 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 229 redistribute it and/or modify it under the same terms as the
 230 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 231
 232 =cut