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, $eval_src);
  57   while (@f = CORE::caller($fr_num++)) {
  58
  59     undef $eval_src;
  60
  61     next if (
  62       $f[2] == 0
  63         or
  64       # there is no value reporting a sourceless eval frame
  65       (
  66         ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ )
  67           and
  68         not defined ( $eval_src = (CORE::caller($fr_num))[6] )
  69       )
  70         or
  71       $f[3] =~ /::__ANON__$/
  72     );
  73
  74     $origin ||= (
  75       $f[3] =~ /^ (.+) :: ([^\:]+) $/x
  76         and
  77       ! $Carp::Internal{$1}
  78         and
  79 #############################
  80 # Need a way to parameterize this for Carp::Skip
  81       $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
  82         and
  83       $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
  84 #############################
  85     ) ? $f[3] : undef;
  86
  87     if (
  88       __safe_can( $f[0], '_skip_namespace_frames' )
  89         and
  90       my $extra_skip = $f[0]->_skip_namespace_frames
  91     ) {
  92       $skip_pattern = qr/$skip_pattern|$extra_skip/;
  93     }
  94
  95     last if $f[0] !~ $skip_pattern;
  96   }
  97
  98   my $site = @f # if empty - nothing matched - full stack
  99     ? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n    === BEGIN $f[1]\n$eval_src\n    === END $f[1]" : '' ) )
 100     : Carp::longmess()
 101   ;
 102
 103   return (
 104     $site,
 105     (
 106       # cargo-cult from Carp::Clan
 107       ! defined $origin   ? ''
 108     : $origin =~ /::/     ? "$origin(): "
 109                           : "$origin: "
 110     ),
 111   );
 112 };
 113
 114 my $warn = sub {
 115   my ($ln, @warn) = @_;
 116   @warn = "Warning: something's wrong" unless @warn;
 117
 118   # back-compat with Carp::Clan - a warning ending with \n does
 119   # not include caller info
 120   warn (
 121     @warn,
 122     $warn[-1] =~ /\n$/ ? '' : " $ln\n"
 123   );
 124 };
 125
 126 sub import {
 127   my (undef, $skip_pattern) = @_;
 128   my $into = caller;
 129
 130   $skip_pattern = $skip_pattern
 131     ? qr/ ^ $into $ | $skip_pattern /x
 132     : qr/ ^ $into $ /x
 133   ;
 134
 135   no strict 'refs';
 136
 137   *{"${into}::carp"} = sub {
 138     $warn->(
 139       __find_caller($skip_pattern, $into),
 140       @_
 141     );
 142   };
 143
 144   my $fired = {};
 145   *{"${into}::carp_once"} = sub {
 146     return if $fired->{$_[0]};
 147     $fired->{$_[0]} = 1;
 148
 149     $warn->(
 150       __find_caller($skip_pattern, $into),
 151       @_,
 152     );
 153   };
 154
 155   my $seen;
 156   *{"${into}::carp_unique"} = sub {
 157     my ($ln, $calling) = __find_caller($skip_pattern, $into);
 158     my $msg = join ('', $calling, @_);
 159
 160     # unique carping with a hidden caller makes no sense
 161     $msg =~ s/\n+$//;
 162
 163     return if $seen->{$ln}{$msg};
 164     $seen->{$ln}{$msg} = 1;
 165
 166     $warn->(
 167       $ln,
 168       $msg,
 169     );
 170   };
 171 }
 172
 173 sub unimport {
 174   die (__PACKAGE__ . " does not implement unimport yet\n");
 175 }
 176
 177 1;
 178
 179 __END__
 180
 181 =head1 NAME
 182
 183 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
 184
 185 =head1 DESCRIPTION
 186
 187 Documentation is lacking on purpose - this an experiment not yet fit for
 188 mass consumption. If you use this do not count on any kind of stability,
 189 in fact don't even count on this module's continuing existence (it has
 190 been noindexed for a reason).
 191
 192 In addition to the classic interface:
 193
 194   use DBIx::Class::Carp '^DBIx::Class'
 195
 196 this module also supports a class-data based way to specify the exclusion
 197 regex. A message is only carped from a callsite that matches neither the
 198 closed over string, nor the value of L</_skip_namespace_frames> as declared
 199 on any callframe already skipped due to the same mechanism. This is to ensure
 200 that intermediate callsites can declare their own additional skip-namespaces.
 201
 202 =head1 CLASS ATTRIBUTES
 203
 204 =head2 _skip_namespace_frames
 205
 206 A classdata attribute holding the stringified regex matching callsites that
 207 should be skipped by the carp methods below. An empty string C<q{}> is treated
 208 like no setting/C<undef> (the distinction is necessary due to semantics of the
 209 class data accessors provided by L<Class::Accessor::Grouped>)
 210
 211 =head1 EXPORTED FUNCTIONS
 212
 213 This module export the following 3 functions. Only warning related C<carp*>
 214 is being handled here, for C<croak>-ing you must use
 215 L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
 216
 217 =head2 carp
 218
 219 Carps message with the file/line of the first callsite not matching
 220 L</_skip_namespace_frames> nor the closed-over arguments to
 221 C<use DBIx::Class::Carp>.
 222
 223 =head2 carp_unique
 224
 225 Like L</carp> but warns once for every distinct callsite (subject to the
 226 same ruleset as L</carp>).
 227
 228 =head2 carp_once
 229
 230 Like L</carp> but warns only once for the life of the perl interpreter
 231 (regardless of callsite).
 232
 233 =head1 FURTHER QUESTIONS?
 234
 235 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 236
 237 =head1 COPYRIGHT AND LICENSE
 238
 239 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 240 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 241 redistribute it and/or modify it under the same terms as the
 242 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 243
 244 =cut