File Coverage

File:local/lib/perl5/Devel/StackTrace/Frame.pm
Coverage:17.0%

linestmtbrancondsubtimecode
1package Devel::StackTrace::Frame;
2$Devel::StackTrace::Frame::VERSION = '1.32';
3
6
6
6
6
19
4
108
use strict;
4
6
6
6
6
15
5
119
use warnings;
5
6# Create accessor routines
7BEGIN {
8
6
6
6
6
15
2
315
    no strict 'refs';
9
6
6
15
    foreach my $f (
10        qw( package filename line subroutine hasargs
11        wantarray evaltext is_require hints bitmask args )
12        ) {
13
66
100
2735
        next if $f eq 'args';
14
60
60
0
0
0
95
131
        *{$f} = sub { my $s = shift; return $s->{$f} };
15    }
16}
17
18{
19    my @fields = (
20        qw( package filename line subroutine hasargs wantarray
21            evaltext is_require hints bitmask )
22    );
23
24    sub new {
25
0
0
        my $proto = shift;
26
0
0
        my $class = ref $proto || $proto;
27
28
0
        my $self = bless {}, $class;
29
30
0
0
0
        @{$self}{@fields} = @{ shift() };
31
32        # fixup unix-style paths on win32
33
0
        $self->{filename} = File::Spec->canonpath( $self->{filename} );
34
35
0
        $self->{args} = shift;
36
37
0
        $self->{respect_overload} = shift;
38
39
0
        $self->{max_arg_length} = shift;
40
41
0
        $self->{message} = shift;
42
43
0
        $self->{indent} = shift;
44
45
0
        return $self;
46    }
47}
48
49sub args {
50
0
0
    my $self = shift;
51
52
0
0
    return @{ $self->{args} };
53}
54
55sub as_string {
56
0
0
    my $self  = shift;
57
0
    my $first = shift;
58
0
    my $p     = shift;
59
60
0
    my $sub = $self->subroutine;
61
62    # This code stolen straight from Carp.pm and then tweaked.  All
63    # errors are probably my fault  -dave
64
0
0
    if ($first) {
65
0
0
        $sub
66            = defined $self->{message}
67            ? $self->{message}
68            : 'Trace begun';
69    }
70    else {
71
72        # Build a string, $sub, which names the sub-routine called.
73        # This may also be "require ...", "eval '...' or "eval {...}"
74
0
0
0
        if ( my $eval = $self->evaltext ) {
75
0
0
            if ( $self->is_require ) {
76
0
                $sub = "require $eval";
77            }
78            else {
79
0
                $eval =~ s/([\\\'])/\\$1/g;
80
0
                $sub = "eval '$eval'";
81            }
82        }
83        elsif ( $sub eq '(eval)' ) {
84
0
            $sub = 'eval {...}';
85        }
86
87        # if there are any arguments in the sub-routine call, format
88        # them according to the format variables defined earlier in
89        # this file and join them onto the $sub sub-routine string
90        #
91        # We copy them because they're going to be modified.
92        #
93
0
0
        if ( my @a = $self->args ) {
94
0
            for (@a) {
95
96                # set args to the string "undef" if undefined
97
0
0
                $_ = "undef", next unless defined $_;
98
99                # hack!
100
0
0
                $_ = $self->Devel::StackTrace::_ref_to_string($_)
101                    if ref $_;
102
103
0
                local $SIG{__DIE__};
104
0
                local $@;
105
106
0
                eval {
107
0
0
                    my $max_arg_length
108                        = exists $p->{max_arg_length}
109                        ? $p->{max_arg_length}
110                        : $self->{max_arg_length};
111
112
0
0
0
                    if ( $max_arg_length
113                        && length $_ > $max_arg_length ) {
114
0
                        substr( $_, $max_arg_length ) = '...';
115                    }
116
117
0
                    s/'/\\'/g;
118
119                    # 'quote' arg unless it looks like a number
120
0
0
                    $_ = "'$_'" unless /^-?[\d.]+$/;
121
122                    # print control/high ASCII chars as 'M-<char>' or '^<char>'
123
0
0
                    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
124
0
0
                    s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
125                };
126
127
0
0
                if ( my $e = $@ ) {
128
0
0
                    $_ = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?';
129                }
130            }
131
132            # append ('all', 'the', 'arguments') to the $sub string
133
0
            $sub .= '(' . join( ', ', @a ) . ')';
134
0
            $sub .= ' called';
135        }
136    }
137
138    # If the user opted into indentation (a la Carp::confess), pre-add a tab
139
0
0
0
    my $tab = $self->{indent} && !$first ? "\t" : q{};
140
141
0
    return "${tab}$sub at " . $self->filename . ' line ' . $self->line;
142}
143
1441;
145
146# ABSTRACT: A single frame in a stack trace
147