File Coverage

blib/lib/Devel/StackTrace/Frame.pm

Criterion	Covered	Total	%
statement	59	67	88.0
branch	20	28	71.4
condition	6	9	66.6
subroutine	8	8	100.0
pod	2	3	66.6
total	95	115	82.6

package Devel::StackTrace::Frame;

use strict;
use warnings;

our $VERSION = '2.04';

# Create accessor routines
BEGIN {
    ## no critic (TestingAndDebugging::ProhibitNoStrict)
    no strict 'refs';

    my @attrs = qw(
        package
        filename
        line
        subroutine
        hasargs
        wantarray
        evaltext
        is_require
        hints
        bitmask
    );

    for my $attr (@attrs) {
        *{$attr} = sub { my $s = shift; return $s->{$attr} };
    }
}

{
    my @args = qw(
        package
        filename
        line
        subroutine
        hasargs
        wantarray
        evaltext
        is_require
        hints
        bitmask
    );

    sub new {
        my $proto = shift;
        my $class = ref $proto || $proto;

        my $self = bless {}, $class;

        @{$self}{@args} = @{ shift() };
        $self->{args}             = shift;
        $self->{respect_overload} = shift;
        $self->{max_arg_length}   = shift;
        $self->{message}          = shift;
        $self->{indent}           = shift;

        # fixup unix-style paths on win32
        $self->{filename} = File::Spec->canonpath( $self->{filename} );

        return $self;
    }
}

sub args {
    my $self = shift;

    return @{ $self->{args} };
}

sub as_string {
    my $self  = shift;
    my $first = shift;
    my $p     = shift;

    my $sub = $self->subroutine;

    # This code stolen straight from Carp.pm and then tweaked. All
    # errors are probably my fault  -dave
    if ($first) {
        $sub
            = defined $self->{message}
            ? $self->{message}
            : 'Trace begun';
    }
    else {

        # Build a string, $sub, which names the sub-routine called.
        # This may also be "require ...", "eval '...' or "eval {...}"
        if ( my $eval = $self->evaltext ) {
            if ( $self->is_require ) {
                $sub = "require $eval";
            }
            else {
                $eval =~ s/([\\\'])/\\$1/g;
                $sub = "eval '$eval'";
            }
        }
        elsif ( $sub eq '(eval)' ) {
            $sub = 'eval {...}';
        }

        # if there are any arguments in the sub-routine call, format
        # them according to the format variables defined earlier in
        # this file and join them onto the $sub sub-routine string
        #
        # We copy them because they're going to be modified.
        #
        if ( my @a = $self->args ) {
            for (@a) {

                # set args to the string "undef" if undefined
                unless ( defined $_ ) {
                    $_ = 'undef';
                    next;
                }

                # hack!
                ## no critic (Subroutines::ProtectPrivateSubs)
                $_ = $self->Devel::StackTrace::_ref_to_string($_)
                    if ref $_;
                ## use critic;

                ## no critic (Variables::RequireInitializationForLocalVars)
                local $SIG{__DIE__};
                local $@;
                ## use critic;

                ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
                eval {
                    my $max_arg_length
                        = exists $p->{max_arg_length}
                        ? $p->{max_arg_length}
                        : $self->{max_arg_length};

                    if ( $max_arg_length
                        && length $_ > $max_arg_length ) {
                        ## no critic (BuiltinFunctions::ProhibitLvalueSubstr)
                        substr( $_, $max_arg_length ) = '...';
                    }

                    s/'/\\'/g;

                    # 'quote' arg unless it looks like a number
                    $_ = "'$_'" unless /^-?[\d.]+$/;

                    # print control/high ASCII chars as 'M-' or '^'
                    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
                    s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
                };
                ## use critic

                if ( my $e = $@ ) {
                    $_ = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?';
                }
            }

            # append ('all', 'the', 'arguments') to the $sub string
            $sub .= '(' . join( ', ', @a ) . ')';
            $sub .= ' called';
        }
    }

    # If the user opted into indentation (a la Carp::confess), pre-add a tab
    my $tab = $self->{indent} && !$first ? "\t" : q{};

    return "${tab}$sub at " . $self->filename . ' line ' . $self->line;
}

1;

# ABSTRACT: A single frame in a stack trace

__END__