File Coverage

blib/lib/Carp/Object.pm

Criterion	Covered	Total	%
statement	137	141	97.1
branch	42	52	80.7
condition	19	28	67.8
subroutine	22	23	95.6
pod	6	7	85.7
total	226	251	90.0

package Carp::Object;
use 5.10.0;
use utf8;
use strict;
use warnings;
use Devel::StackTrace;
use Module::Load qw/load/;
use Clone        qw/clone/;

our $VERSION = 1.02;

my %export_groups = (carp => [qw/carp croak confess/],
                     all  => [qw/carp croak confess cluck/],  );

# ======================================================================
# METHODS
# ======================================================================

sub new {
  my ($class, %args) = @_;

  # create $self, consume the 'verbose' arg
  my $self = {verbose => delete $args{verbose}};

  # class for stack traces
  $self->{stacktrace_class} = delete $args{stacktrace_class} // 'Devel::StackTrace';

  # if there is a 'clan' argument, compute a frame filter -- see L
  if (my $clan = delete $args{clan}) {
    not $args{frame_filter} or $class->new->croak("can't have arg 'clan' if arg 'frame_filter' is present");
    $args{frame_filter} = sub {my $raw_frame_ref = shift;
                               my $pkg = $raw_frame_ref->{caller}[0];
                               return $pkg !~ /$clan/};
  }

  #  handler for displaying stack frames
  $self->{display_frame}       = delete $args{display_frame} // \&_default_display_frame;
  $self->{display_frame_param} = delete $args{display_frame_param};

  # classes to be ignored by Devel::StackTrace : list supplied by caller + current class
  my $ignore_class = delete $args{ignore_class} // [];
  $ignore_class    = [$ignore_class] if not ref $ignore_class;
  push @$ignore_class, $class;
  $args{ignore_class} = $ignore_class;

  # remaining args will be passed to Devel::StackTrace->new
  $args{message} //= ''; # to avoid the 'Trace begun' string from StackTrace::Frame::as_string
  $args{indent}  //= 1;
  $self->{stacktrace_args} = \%args;

  # return the carper object
  bless $self, $class;
}

sub croak   {my $self = shift; die  $self->msg(join("", @_), 1)} # 1 means "just one frame"
sub carp    {my $self = shift; warn $self->msg(join("", @_), 1)} # idem
sub confess {my $self = shift; die  $self->msg(join("", @_)   )} # no second arg means "the whole stack"
sub cluck   {my $self = shift; warn $self->msg(join("", @_)   )} # idem

sub msg {
  my ($self, $errstr, $n_frames) = @_;
  my $class = ref $self;
  $errstr //= "Died";

  # is this call a croak (single stackframe) or a confess (full stack) ?
  my $want_full_stack = ! defined $n_frames
                        || $self->{verbose} || do {no warnings 'once'; $Carp::Verbose || $Carp::Clan::Verbose};


  # if not doing a "confess", tell Devel::Stacktrace to skip frames from the first outside caller
  my $stacktrace_args = clone $self->{stacktrace_args};
  if (!$want_full_stack) {
    my $outside_caller;
    my $i = 0;
    do {$outside_caller = caller($i++) // ""} while $outside_caller->isa($class);
    push @{$stacktrace_args->{ignore_package}}, $outside_caller unless $outside_caller eq 'main';
  }

  # get stack frames from Devel::StackTrace and truncate the list to the requested number
  load $self->{stacktrace_class};
  my $trace   = $self->{stacktrace_class}->new(%{$stacktrace_args});
  my  @frames = $trace->frames;
  splice @frames, $n_frames  if @frames && !$want_full_stack;

  # complete the original $errstr with frame descriptions
  if (my $first_frame = shift @frames) {
    my $p    = $self->{display_frame_param};                   # see L
    $errstr .= $self->{display_frame}->($first_frame, 1, $p);  # 1 means "is first"
    $errstr .= $self->{display_frame}->($_, undef, $p)  foreach @frames;
  }

  return $errstr;
}

# ======================================================================
# SUBROUTINES (NOT METHODS) -- used as callback
# ======================================================================

sub _default_display_frame {
  my ($frame, $is_first, $p) = @_;

  # let Devel::StackTrace::Frame compute a string representation
  my $str = $frame->as_string($is_first, $p);

  # if this seems to be a method call, make it look like so
  $str =~ s{^ (\t)?              # optional tab    -- capture in $1
              ([\w:]+)           # class name      -- capture in $2
              ::
              (\w+)              # method name     -- capture in $3
              \('                # beginning arg list
                 ( \2            # first arg: again the class name
                   (?: = [^']+)? # .. possibly followed by the ref addr
                 )
                '                # end of fist arg -- capture in $4
                (?: ,\h* )?      # possibly followed by a comma
            }
           {$1$4->$3(}x;         # rewrite as a method call

  $str .= "." if $is_first;      # because Carp does add this colon to the first line

  return "$str\n";
}


# ======================================================================
# IMPORT API (CLASS METHOD)
# ======================================================================

sub import {
  my ($class, @import_list) = @_;
  my $calling_pkg = caller(0);

  # find out what the importer wants
  my ($exports, $options) = $class->parse_import_list(@import_list);

  # default exports : carp, croak and confess
  keys %$exports
    or $exports = { map {$_ => {name => $_}}  @{$export_groups{carp}} };

  # if required, apply prefix and suffix
  if (my $prefix = $options->{prefix}) {
    substr $exports->{$_}{name}, 0, 0, $prefix foreach keys %$exports;
  }
  if (my $suffix = $options->{suffix}) {
    $exports->{$_}{name} .= $suffix foreach keys %$exports;
  }

  # export the requested symbols into the caller
  while (my ($method, $hash) = each %$exports) {
    no strict "refs";
    my $export_as = $hash->{as} // $hash->{name};
    *{"$calling_pkg\::$export_as"} = sub (@) {

      # if present, the current value of %CARP_OBJECT_CONSTRUCTOR within the calling package
      # will be passed to the constructor
      my $constructor_args = *{"$calling_pkg\::CARP_OBJECT_CONSTRUCTOR"}{HASH} // {};

      # if present, the current value of @CARP_NOT within the calling package
      # will be passed as 'ignore_package' to the Devel::StackTrace constructor
      if (my $carp_not = *{"$calling_pkg\::CARP_NOT"}{ARRAY}) {
        $constructor_args->{ignore_package} = $carp_not;
      }

      # build a one-shot instance and call the requested method
      $class->new(%$constructor_args)->$method(@_);
    };
  }

  # install an import function into the caller if -reexport is requested
  if ($options->{reexport}) {
    no strict "refs";
    not *{"$calling_pkg\::import"}{CODE}
      or $class->new->croak("use $class -reexport => ... : $calling_pkg already has an import function");
    *{"$calling_pkg\::import"} = sub {
      my $further_calling_pkg = caller(0);
      foreach my $symbol (keys %$exports) {
        *{"$further_calling_pkg\::$symbol"} = *{"$calling_pkg\::$symbol"}{CODE};
      }
    };
  }

  # populate %CARP_OBJECT_CONSTRUCTOR within the caller from the 'constructor_args' option
  if (my $args = $options->{constructor_args}) {
    ref $args eq 'HASH'
      or $class->new->croak("use $class {-constructor_args => ...} : must be a hashref");
    no strict 'refs';
    *{"$calling_pkg\::CARP_OBJECT_CONSTRUCTOR"} = $args;
  }
}


sub parse_import_list {
  my ($class, @import_list) = @_;

  my %exports;
  my %options;
  my $last_export;

  # loop on import args
  while (my $arg = shift @import_list) {

    # hashref : options to the exporter
    if (my $ref = ref $arg) {
      $ref eq 'HASH' or $class->new->croak("$class->import() cannot handle $ref references");
      while (my ($k, $v) = each %$arg) {
        if ($k =~ /^-(prefix|suffix|constructor_args|reexport)$/) {
          $options{$1} = $v;
        }
        elsif ($k eq '-as') {
          $last_export or $class->new->croak("use $class ... : {-as => ...} must follow the name of a symbol to import");
          $exports{$last_export}{as} = $v;
        }
        else {
          $class->new->croak("$class->import(): unknown option: '$k'");
        }
      }
    }

    # the 'reexport' option -- different syntax for better readability, for ex: use C:O -reexport => qw/carp croak/;
    elsif ($arg eq '-reexport') {
      $options{reexport} = 1;
    }

    # groups of symbols (:carp, :all)
    elsif ($arg =~ /^[:-](\w+)/) {
      undef $last_export;
      my $group = $export_groups{$1} or $class->new->croak("use $class qw/:$1/ : group '$1' is not exported");
      $exports{$_}{name} = $_ foreach @$group;
    }

    # individual symbols
    elsif ($arg =~ /^(croak|carp|confess|cluck)$/) {
      $exports{$arg}{name} = $arg;
      $last_export = $arg;
    }

    # something that looks like a regexp -- probably intended for Carp::Clan-like behaviour
    elsif ($arg =~ /^\^/ or $arg =~ /[|(]/ ) {
      $options{constructor_args}{clan} = $arg;
    }

    else {
      $class->new->croak("use $class '$arg' : this symbol is not exported");
    }

  }
  return (\%exports, \%options);
}

1;


__END__