diff options
Diffstat (limited to 'lib/Devel/StackTrace/Frame.pm')
| -rw-r--r-- | lib/Devel/StackTrace/Frame.pm | 216 |
1 files changed, 216 insertions, 0 deletions
diff --git a/lib/Devel/StackTrace/Frame.pm b/lib/Devel/StackTrace/Frame.pm new file mode 100644 index 0000000..aad497a --- /dev/null +++ b/lib/Devel/StackTrace/Frame.pm @@ -0,0 +1,216 @@ +package Devel::StackTrace::Frame; +$Devel::StackTrace::Frame::VERSION = '2.00'; +use strict; +use warnings; + +# Create accessor routines +BEGIN { + 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 + $_ = "undef", next unless defined $_; + + # hack! + $_ = $self->Devel::StackTrace::_ref_to_string($_) + if ref $_; + + local $SIG{__DIE__}; + local $@; + + 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 ) { + 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; + }; + + 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 + +=head1 NAME + +Devel::StackTrace::Frame - A single frame in a stack trace + +=head1 VERSION + +version 2.00 + +=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 AUTHOR + +Dave Rolsky <autarch@urth.org> + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2000 - 2014 by David Rolsky. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut |