From 22d921a6e9c4fc98cda05e898a8137c7e8dae970 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Sat, 1 Nov 2014 18:05:53 +0000 Subject: Devel-StackTrace-2.00 --- lib/Devel/StackTrace.pm | 531 ++++++++++++++++++++++++++++++++++++++++++ lib/Devel/StackTrace/Frame.pm | 216 +++++++++++++++++ 2 files changed, 747 insertions(+) create mode 100644 lib/Devel/StackTrace.pm create mode 100644 lib/Devel/StackTrace/Frame.pm (limited to 'lib/Devel') diff --git a/lib/Devel/StackTrace.pm b/lib/Devel/StackTrace.pm new file mode 100644 index 0000000..cf7ef43 --- /dev/null +++ b/lib/Devel/StackTrace.pm @@ -0,0 +1,531 @@ +package Devel::StackTrace; +# git description: v1.34-10-g810fd3f + +$Devel::StackTrace::VERSION = '2.00'; +use 5.006; + +use strict; +use warnings; + +use Devel::StackTrace::Frame; +use File::Spec; +use Scalar::Util qw( blessed ); + +use overload + '""' => \&as_string, + fallback => 1; + +sub new { + my $class = shift; + my %p = @_; + + $p{unsafe_ref_capture} = !delete $p{no_refs} + if exists $p{no_refs}; + + my $self = bless { + index => undef, + frames => [], + raw => [], + %p, + }, $class; + + $self->_record_caller_data(); + + return $self; +} + +sub _record_caller_data { + my $self = shift; + + my $filter = $self->{filter_frames_early} && $self->_make_frame_filter(); + + # We exclude this method by starting at least one frame back. + my $x = 1 + ( $self->{skip_frames} || 0 ); + + while ( + my @c + = $self->{no_args} + ? caller( $x++ ) + : do { + package # the newline keeps dzil from adding a version here + DB; + @DB::args = (); + caller( $x++ ); + } + ) { + + my @args; + + @args = $self->{no_args} ? () : @DB::args; + + my $raw = { + caller => \@c, + args => \@args, + }; + + next if $filter && !$filter->($raw); + + unless ( $self->{unsafe_ref_capture} ) { + $raw->{args} = [ map { ref $_ ? $self->_ref_to_string($_) : $_ } + @{ $raw->{args} } ]; + } + + push @{ $self->{raw} }, $raw; + } +} + +sub _ref_to_string { + my $self = shift; + my $ref = shift; + + return overload::AddrRef($ref) + if blessed $ref && $ref->isa('Exception::Class::Base'); + + return overload::AddrRef($ref) unless $self->{respect_overload}; + + local $@; + local $SIG{__DIE__}; + + my $str = eval { $ref . '' }; + + return $@ ? overload::AddrRef($ref) : $str; +} + +sub _make_frames { + my $self = shift; + + my $filter = !$self->{filter_frames_early} && $self->_make_frame_filter(); + + my $raw = delete $self->{raw}; + for my $r ( @{$raw} ) { + next if $filter && !$filter->($r); + + $self->_add_frame( $r->{caller}, $r->{args} ); + } +} + +my $default_filter = sub { 1 }; + +sub _make_frame_filter { + my $self = shift; + + my ( @i_pack_re, %i_class ); + if ( $self->{ignore_package} ) { + local $@; + local $SIG{__DIE__}; + + $self->{ignore_package} = [ $self->{ignore_package} ] + unless eval { @{ $self->{ignore_package} } }; + + @i_pack_re + = map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $self->{ignore_package} }; + } + + my $p = __PACKAGE__; + push @i_pack_re, qr/^\Q$p\E$/; + + if ( $self->{ignore_class} ) { + $self->{ignore_class} = [ $self->{ignore_class} ] + unless ref $self->{ignore_class}; + %i_class = map { $_ => 1 } @{ $self->{ignore_class} }; + } + + my $user_filter = $self->{frame_filter}; + + return sub { + return 0 if grep { $_[0]{caller}[0] =~ /$_/ } @i_pack_re; + return 0 if grep { $_[0]{caller}[0]->isa($_) } keys %i_class; + + if ($user_filter) { + return $user_filter->( $_[0] ); + } + + return 1; + }; +} + +sub _add_frame { + my $self = shift; + my $c = shift; + my $p = shift; + + # eval and is_require are only returned when applicable under 5.00503. + push @$c, ( undef, undef ) if scalar @$c == 6; + + push @{ $self->{frames} }, + Devel::StackTrace::Frame->new( + $c, + $p, + $self->{respect_overload}, + $self->{max_arg_length}, + $self->{message}, + $self->{indent} + ); +} + +sub next_frame { + my $self = shift; + + # reset to top if necessary. + $self->{index} = -1 unless defined $self->{index}; + + my @f = $self->frames(); + if ( defined $f[ $self->{index} + 1 ] ) { + return $f[ ++$self->{index} ]; + } + else { + $self->{index} = undef; + return undef; + } +} + +sub prev_frame { + my $self = shift; + + my @f = $self->frames(); + + # reset to top if necessary. + $self->{index} = scalar @f unless defined $self->{index}; + + if ( defined $f[ $self->{index} - 1 ] && $self->{index} >= 1 ) { + return $f[ --$self->{index} ]; + } + else { + $self->{index} = undef; + return undef; + } +} + +sub reset_pointer { + my $self = shift; + + $self->{index} = undef; +} + +sub frames { + my $self = shift; + + if (@_) { + die + "Devel::StackTrace->frames() can only take Devel::StackTrace::Frame args\n" + if grep { !$_->isa('Devel::StackTrace::Frame') } @_; + + $self->{frames} = \@_; + } + else { + $self->_make_frames() if $self->{raw}; + } + + return @{ $self->{frames} }; +} + +sub frame { + my $self = shift; + my $i = shift; + + return unless defined $i; + + return ( $self->frames() )[$i]; +} + +sub frame_count { + my $self = shift; + + return scalar( $self->frames() ); +} + +sub as_string { + my $self = shift; + my $p = shift; + + my $st = ''; + my $first = 1; + foreach my $f ( $self->frames() ) { + $st .= $f->as_string( $first, $p ) . "\n"; + $first = 0; + } + + return $st; +} + +{ + package # hide from PAUSE + Devel::StackTraceFrame; + + our @ISA = 'Devel::StackTrace::Frame'; +} + +1; + +# ABSTRACT: An object representing a stack trace + +__END__ + +=pod + +=head1 NAME + +Devel::StackTrace - An object representing a stack trace + +=head1 VERSION + +version 2.00 + +=head1 SYNOPSIS + + use Devel::StackTrace; + + my $trace = Devel::StackTrace->new(); + + print $trace->as_string(); # like carp + + # from top (most recent) of stack to bottom. + while ( my $frame = $trace->next_frame() ) { + print "Has args\n" if $frame->hasargs(); + } + + # from bottom (least recent) of stack to top. + while ( my $frame = $trace->prev_frame() ) { + print "Sub: ", $frame->subroutine(), "\n"; + } + +=head1 DESCRIPTION + +The C module contains two classes, C,Devel::StackTrace> and +L. These objects encapsulate the information that +can retrieved via Perl's C function, as well as providing a simple +interface to this data. + +The C object contains a set of C +objects, one for each level of the stack. The frames contain all the data +available from C. + +This code was created to support my L class (part of +L) but may be useful in other contexts. + +=encoding UTF-8 + +=head1 'TOP' AND 'BOTTOM' OF THE STACK + +When describing the methods of the trace object, I use the words 'top' and +'bottom'. In this context, the 'top' frame on the stack is the most recent +frame and the 'bottom' is the least recent. + +Here's an example: + + foo(); # bottom frame is here + + sub foo { + bar(); + } + + sub bar { + Devel::StackTrace->new(); # top frame is here. + } + +=head1 METHODS + +This class provide the following methods: + +=head2 Devel::StackTrace->new(%named_params) + +Returns a new Devel::StackTrace object. + +Takes the following parameters: + +=over 4 + +=item * frame_filter => $sub + +By default, Devel::StackTrace will include all stack frames before the +call to its constructor. + +However, you may want to filter out some frames with more granularity +than 'ignore_package' or 'ignore_class' allow. + +You can provide a subroutine which is called with the raw frame data +for each frame. This is a hash reference with two keys, "caller", and +"args", both of which are array references. The "caller" key is the +raw data as returned by Perl's C function, and the "args" +key are the subroutine arguments found in C<@DB::args>. + +The filter should return true if the frame should be included, or +false if it should be skipped. + +=item * filter_frames_early => $boolean + +If this parameter is true, C will be called as soon as the +stacktrace is created, and before refs are stringified (if +C is not set), rather than being filtered lazily when +L objects are first needed. + +This is useful if you want to filter based on the frame's arguments and want +to be able to examine object properties, for example. + +=item * ignore_package => $package_name OR \@package_names + +Any frames where the package is one of these packages will not be on +the stack. + +=item * ignore_class => $package_name OR \@package_names + +Any frames where the package is a subclass of one of these packages +(or is the same package) will not be on the stack. + +Devel::StackTrace internally adds itself to the 'ignore_package' +parameter, meaning that the Devel::StackTrace package is B +ignored. However, if you create a subclass of Devel::StackTrace it +will not be ignored. + +=item * skip_frames => $integer + +This will cause this number of stack frames to be excluded from top of the +stack trace. This prevents the frames from being captured at all, and applies +before the C, C, or C options, +even with C. + +=item * unsafe_ref_capture => $boolean + +If this parameter is true, then Devel::StackTrace will store +references internally when generating stacktrace frames. + +B. Using this option will keep any objects or references alive past +their normal lifetime, until the stack trace object goes out of scope. It can +keep objects alive even after their C sub is called, resulting it it +being called multiple times on the same object. + +If not set, Devel::StackTrace replaces any references with their stringified +representation. + +=item * no_args => $boolean + +If this parameter is true, then Devel::StackTrace will not store caller +arguments in stack trace frames at all. + +=item * respect_overload => $boolean + +By default, Devel::StackTrace will call C to get +the underlying string representation of an object, instead of +respecting the object's stringification overloading. If you would +prefer to see the overloaded representation of objects in stack +traces, then set this parameter to true. + +=item * max_arg_length => $integer + +By default, Devel::StackTrace will display the entire argument for each +subroutine call. Setting this parameter causes truncates each subroutine +argument's string representation if it is longer than this number of +characters. + +=item * message => $string + +By default, Devel::StackTrace will use 'Trace begun' as the message for the +first stack frame when you call C. You can supply an alternative +message using this option. + +=item * indent => $boolean + +If this parameter is true, each stack frame after the first will start with a +tab character, just like C. + +=back + +=head2 $trace->next_frame() + +Returns the next L object on the stack, going +down. If this method hasn't been called before it returns the first frame. It +returns C when it reaches the bottom of the stack and then resets its +pointer so the next call to C<< $trace->next_frame() >> or C<< +$trace->prev_frame() >> will work properly. + +=head2 $trace->prev_frame() + +Returns the next L object on the stack, going up. If +this method hasn't been called before it returns the last frame. It returns +undef when it reaches the top of the stack and then resets its pointer so the +next call to C<< $trace->next_frame() >> or C<< $trace->prev_frame() >> will +work properly. + +=head2 $trace->reset_pointer + +Resets the pointer so that the next call to C<< $trace->next_frame() >> or C<< +$trace->prev_frame() >> will start at the top or bottom of the stack, as +appropriate. + +=head2 $trace->frames() + +When this method is called with no arguments, it returns a list of +L objects. They are returned in order from top (most +recent) to bottom. + +This method can also be used to set the object's frames if you pass it a list +of L objects. + +This is useful if you want to filter the list of frames in ways that are more +complex than can be handled by the C<< $trace->filter_frames() >> method: + + $stacktrace->frames( my_filter( $stacktrace->frames() ) ); + +=head2 $trace->frame($index) + +Given an index, this method returns the relevant frame, or undef if there is +no frame at that index. The index is exactly like a Perl array. The first +frame is 0 and negative indexes are allowed. + +=head2 $trace->frame_count() + +Returns the number of frames in the trace object. + +=head2 $trace->as_string(\%p) + +Calls C<< $frame->as_string() >> on each frame from top to bottom, producing +output quite similar to the Carp module's cluck/confess methods. + +The optional C<\%p> parameter only has one option. The C +parameter truncates each subroutine argument's string representation if it is +longer than this number of characters. + +=head1 SUPPORT + +Please submit bugs to the CPAN RT system at +http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Devel%3A%3AStackTrace +or via email at bug-devel-stacktrace@rt.cpan.org. + +=head1 AUTHOR + +Dave Rolsky + +=head1 CONTRIBUTORS + +=for stopwords Dagfinn Ilmari Mannsåker David Cantrell Graham Knop Ricardo Signes + +=over 4 + +=item * + +Dagfinn Ilmari Mannsåker + +=item * + +David Cantrell + +=item * + +Graham Knop + +=item * + +Ricardo Signes + +=back + +=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 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-' or '^' + 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 for details. + +=for Pod::Coverage new + +=head1 METHODS + +See Perl's C 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 + +=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 -- cgit v1.2.1