libdevel-stacktrace-perl 2.0200-1 / usr / share / perl5 / Devel / StackTrace / Frame.pm

package Devel::StackTrace::Frame;

use strict;
use warnings;

our $VERSION = '2.02';

# Create accessor routines
BEGIN {
    ## no critic (TestingAndDebugging::ProhibitNoStrict)
    no strict 'refs';
    foreach my $f (
        qw( package filename line subroutine hasargs
        wantarray evaltext is_require hints bitmask args )
        ) {
        next if $f eq 'args';
        *{$f} = sub { my $s = shift; return $s->{$f} };
    }
}

{
    my @fields = (
        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}{@fields} = @{ shift() };

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

        $self->{args} = shift;

        $self->{respect_overload} = shift;

        $self->{max_arg_length} = shift;

        $self->{message} = shift;

        $self->{indent} = shift;

        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-<char>' or '^<char>'
                    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__

=pod

=encoding UTF-8

=head1 NAME

Devel::StackTrace::Frame - A single frame in a stack trace

=head1 VERSION

version 2.02

=head1 DESCRIPTION

See L<Devel::StackTrace> for details.

=for Pod::Coverage new

=head1 METHODS

See Perl's C<caller> documentation for more information on what these
methods return.

=head2 $frame->package

=head2 $frame->filename

=head2 $frame->line

=head2 $frame->subroutine

=head2 $frame->hasargs

=head2 $frame->wantarray

=head2 $frame->evaltext

Returns undef if the frame was not part of an eval.

=head2 $frame->is_require

Returns undef if the frame was not part of a require.

=head2 $frame->args

Returns the arguments passed to the frame. Note that any arguments that are
references are returned as references, not copies.

=head2 $frame->hints

=head2 $frame->bitmask

=head2 $frame->as_string

Returns a string containing a description of the frame.

=head1 SUPPORT

Bugs may be submitted through L<https://github.com/houseabsolute/Devel-StackTrace/issues>.

I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.

=head1 AUTHOR

Dave Rolsky <autarch@urth.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2000 - 2016 by David Rolsky.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut