package Unexpected::TraitFor::TracingStacks;
use namespace::autoclean;
use Scalar::Util qw( weaken );
use Unexpected::Types qw( HashRef LoadableClass Tracer );
use Moo::Role;
requires qw( BUILD );
# Object attributes (public)
has 'trace' => is => 'lazy', isa => Tracer, builder => sub {
$_[ 0 ]->trace_class->new( %{ $_[ 0 ]->trace_args } ) },
handles => [ qw( frames ) ], init_arg => undef;
has 'trace_args' => is => 'lazy', isa => HashRef, builder => sub { {
filter_frames_early => 1,
no_refs => 1,
respect_overload => 0,
max_arg_length => 0,
frame_filter => $_[ 0 ]->trace_frame_filter, } };
has 'trace_class' => is => 'ro', isa => LoadableClass,
default => 'Devel::StackTrace';
# Construction
before 'BUILD' => sub {
my $self = shift; $self->trace; return;
};
# Public methods
sub message { # Stringify self and a full stack trace
my $self = shift; return "${self}\n".$self->trace->as_string."\n";
}
sub stacktrace {
my ($self, $skip) = @_; my (@lines, %seen, $subr);
for my $frame (reverse $self->frames) {
my $package = $frame->package; my $l_no;
unless ($l_no = $seen{ $package } and $l_no == $frame->line) {
my $lead = $subr || $package; # uncoverable condition false
$lead !~ m{ :: __ANON__ \z }mx # uncoverable branch false
and push @lines, join q( ), $lead, 'line', $frame->line;
$seen{ $package } = $frame->line;
}
$frame->subroutine !~ m{ :: __ANON__ \z }mx # uncoverable branch false
and $subr = $frame->subroutine;
}
defined $skip or $skip = 0; pop @lines while ($skip--);
return wantarray ? reverse @lines : (join "\n", reverse @lines)."\n";
}
sub trace_frame_filter { # Lifted from StackTrace::Auto
my $self = shift; my $found_mark = 0; weaken( $self );
return sub {
my ($raw) = @_;
my $subr = $raw->{caller}->[ 3 ];
(my $package = $subr) =~ s{ :: \w+ \z }{}mx;
$ENV{UNEXPECTED_SHOW_RAW_TRACE} and warn "$subr\n";
if ($found_mark == 2) { return 1 }
elsif ($found_mark == 1) {
# uncoverable branch true
# uncoverable condition right
$subr =~ m{ :: new \z }mx and $self->isa( $package ) and return 0;
$found_mark++; return 1;
}
# uncoverable condition right
$subr =~ m{ :: new \z }mx and $self->isa( $package ) and $found_mark++;
return 0;
}
}
1;
__END__
=pod
=encoding utf8
=head1 Name
Unexpected::TraitFor::TracingStacks - Provides a minimalist stacktrace
=head1 Synopsis
use Moo;
with 'Unexpected::TraitFor::TracingStacks';
=head1 Description
Provides a minimalist stacktrace
=head1 Configuration and Environment
Modifies C<BUILD> in the consuming class. Forces the instantiation of
the C<trace> attribute
Defines the following attributes;
=over 3
=item C<trace>
An instance of the C<trace_class>
=item C<trace_args>
A hash ref of arguments passed the C<trace_class> constructor when the
C<trace> attribute is instantiated
=item C<trace_class>
A loadable class which defaults to L<Devel::StackTrace>
=back
=head1 Subroutines/Methods
=head2 message
$error_text_and_stack_trace = $self->message;
Returns the stringified object and a full stack trace
=head2 stacktrace
$lines = $self->stacktrace( $num_frames_to_skip );
Returns a minimalist stack trace. Defaults to skipping zero frames
from the stack
=head2 trace_frame_filter
Lifted from L<StackTrace::Auto> this method filters out frames from the
raw stacktrace that are not of interest. It is very clever
=head1 Diagnostics
None
=head1 Dependencies
=over 3
=item L<namespace::autoclean>
=item L<Moo::Role>
=item L<Unexpected::Types>
=back
=head1 Incompatibilities
There are no known incompatibilities in this module
=head1 Bugs and Limitations
There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome
=head1 Acknowledgements
Larry Wall - For the Perl programming language
=head1 Author
Peter Flanigan, C<< <pjfl@cpan.org> >>
=head1 License and Copyright
Copyright (c) 2014 Peter Flanigan. All rights reserved
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>
This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
=cut
# Local Variables:
# mode: perl
# tab-width: 3
# End: