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