File Coverage

blib/lib/DBIx/Class/Carp.pm

Criterion	Covered	Total	%
statement	58	61	95.0
branch	29	34	85.2
condition	23	27	85.1
subroutine	11	12	91.6
pod			n/a
total	121	134	90.3

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__) }++;

use Scalar::Util ();

# Because... sigh
# There are cases out there where a user provides a can() that won't actually
# work as perl intends it. Since this is a reporting library, we *have* to be
# extra paranoid ( e.g. https://rt.cpan.org/Ticket/Display.html?id=90715 )
sub __safe_can ($$) {
  local $@;
  local $SIG{__DIE__} if $SIG{__DIE__};

  my $cref;
  eval {
    $cref = $_[0]->can( $_[1] );

    # in case the can() isn't an actual UNIVERSAL::can()
    die "Return value of $_[0]" . "->can(q($_[1])) is true yet not a code reference...\n"
      if $cref and Scalar::Util::reftype($cref) ne 'CODE';

    1;
  } or do {
    undef $cref;

    # can not use DBIC::_Util::emit_loud_diag - it uses us internally
    printf STDERR
      "\n$0: !!! INTERNAL PANIC !!!\nClass '%s' implements or inherits a broken can() - PLEASE FIX ASAP!: %s\n\n",
      ( length ref $_[0] ? ref $_[0] : $_[0] ),
      $@,
    ;
  };

  $cref;
}

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

  my $skip_class_data = $class->_skip_namespace_frames
    if ($class and __safe_can($class, '_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, $eval_src);
  while (@f = CORE::caller($fr_num++)) {

    undef $eval_src;

    next if (
      $f[2] == 0
        or
      # there is no value reporting a sourceless eval frame
      (
        ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ )
          and
        not defined ( $eval_src = (CORE::caller($fr_num))[6] )
      )
        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 | Sub::Uplevel )$/x
        and
      $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
#############################
    ) ? $f[3] : undef;

    if (
      __safe_can( $f[0], '_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]" . ( $eval_src ? "\n    === BEGIN $f[1]\n$eval_src\n    === END $f[1]" : '' ) )
    : Carp::longmess()
  ;

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

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__