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