File Coverage

blib/lib/DBIx/Class/Carp.pm

Criterion	Covered	Total	%
statement	47	48	97.9
branch	22	22	100.0
condition	15	17	88.2
subroutine	10	11	90.9
pod			n/a
total	94	98	95.9

package # hide from pause
  DBIx::Class::Carp;

use strict;
use warnings;

# load Carp early to prevent tickling of the ::Internal stash being
# interpreted as "Carp is already loaded" by some braindead loader
use Carp ();
$Carp::Internal{ (__PACKAGE__) }++;

sub __find_caller {
  my ($skip_pattern, $class) = @_;

  my $skip_class_data = $class->_skip_namespace_frames
    if ($class and $class->can('_skip_namespace_frames'));

  $skip_pattern = qr/$skip_pattern|$skip_class_data/
    if $skip_class_data;

  my $fr_num = 1; # skip us and the calling carp*

  my (@f, $origin);
  while (@f = caller($fr_num++)) {

    next if
      ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );

    $origin ||= (
      $f[3] =~ /^ (.+) :: ([^\:]+) $/x
        and
      ! $Carp::Internal{$1}
        and
#############################
# Need a way to parameterize this for Carp::Skip
      $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime )$/x
        and
      $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/x
#############################
    ) ? $f[3] : undef;

    if (
      $f[0]->can('_skip_namespace_frames')
        and
      my $extra_skip = $f[0]->_skip_namespace_frames
    ) {
      $skip_pattern = qr/$skip_pattern|$extra_skip/;
    }

    last if $f[0] !~ $skip_pattern;
  }

  my $site = @f # if empty - nothing matched - full stack
    ? "at $f[1] line $f[2]"
    : Carp::longmess()
  ;
  $origin ||= '{UNKNOWN}';

  return (
    $site,
    $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
  );
};

my $warn = sub {
  my ($ln, @warn) = @_;
  @warn = "Warning: something's wrong" unless @warn;

  # back-compat with Carp::Clan - a warning ending with \n does
  # not include caller info
  warn (
    @warn,
    $warn[-1] =~ /\n$/ ? '' : " $ln\n"
  );
};

sub import {
  my (undef, $skip_pattern) = @_;
  my $into = caller;

  $skip_pattern = $skip_pattern
    ? qr/ ^ $into $ | $skip_pattern /x
    : qr/ ^ $into $ /x
  ;

  no strict 'refs';

  *{"${into}::carp"} = sub {
    $warn->(
      __find_caller($skip_pattern, $into),
      @_
    );
  };

  my $fired = {};
  *{"${into}::carp_once"} = sub {
    return if $fired->{$_[0]};
    $fired->{$_[0]} = 1;

    $warn->(
      __find_caller($skip_pattern, $into),
      @_,
    );
  };

  my $seen;
  *{"${into}::carp_unique"} = sub {
    my ($ln, $calling) = __find_caller($skip_pattern, $into);
    my $msg = join ('', $calling, @_);

    # unique carping with a hidden caller makes no sense
    $msg =~ s/\n+$//;

    return if $seen->{$ln}{$msg};
    $seen->{$ln}{$msg} = 1;

    $warn->(
      $ln,
      $msg,
    );
  };
}

sub unimport {
  die (__PACKAGE__ . " does not implement unimport yet\n");
}

1;

__END__