| Subject: | Enhancement proposal: Allow user to format stacktrace |
(As outlined by mail privately the other day:)
Currently, the user has limited control over the way the stacktrace is
formatted for display. It would be nice to be able to have stacktraces
in ANSI colors, for example. They stand out better in the logfile.
The modifications required to accomodate this new feature are relatively
minor. See the attached patch (not the same as the one
| Subject: | dst.diff |
--- /usr/lib/perl5/site_perl/5.10/devel/stacktrace.pm 2010-02-10 22:28:43.000000000 +0100
+++ lib/Devel/StackTrace.pm 2010-02-15 03:07:29.453125000 +0100
@@ -32,6 +32,51 @@
%p,
}, $class;
+ # provide missing main formatter
+
+ $self->{formatter} ||= sub {
+ my( $sub, $args, $filename, $line, $first) = @_;
+ return sprintf '%s at %s line %s',
+ $first ? 'Trace begun' : "$sub$args called", $filename, $line;
+ };
+
+ # provide missing argument formatter
+ # if there are any arguments in the sub-routine call, format them
+ # according to the format variables defined elsewhere in this file
+
+ $self->{arg_formatter} ||= sub {
+ my($arg) = @_;
+ # set args to the string "undef" if undefined
+ $arg = "undef", next unless defined $arg;
+
+ $arg = $self->_ref_to_string($arg)
+ if ref $arg;
+
+ eval
+ {
+ if ( $self->{max_arg_length}
+ && length $arg > $self->{max_arg_length} )
+ {
+ substr( $arg, $self->{max_arg_length} ) = '...';
+ }
+
+ s/'/\\'/g;
+
+ # 'quote' arg unless it looks like a number
+ $arg = "'$arg'" 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 = $@ )
+ {
+ $arg = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?';
+ }
+ return $arg;
+ };
+
$self->_record_caller_data();
return $self;
@@ -147,7 +192,7 @@
push @{ $self->{frames} },
Devel::StackTraceFrame->new( $c, $args,
- $self->{respect_overload}, $self->{max_arg_length} );
+ $self->{formatter}, $self->{arg_formatter} );
}
sub next_frame
@@ -277,9 +322,9 @@
$self->{args} = $_[1];
- $self->{respect_overload} = $_[2];
+ $self->{formatter} = $_[2];
- $self->{max_arg_length} = $_[3];
+ $self->{arg_formatter} = $_[3];
return $self;
}
@@ -298,13 +343,10 @@
my $first = shift;
my $sub = $self->subroutine;
+ my $sub_args = '';
# This code stolen straight from Carp.pm and then tweaked. All
# errors are probably my fault -dave
- if ($first)
- {
- $sub = 'Trace begun';
- }
- else
+ unless ($first)
{
# Build a string, $sub, which names the sub-routine called.
# This may also be "require ...", "eval '...' or "eval {...}"
@@ -325,54 +367,14 @@
$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 $_;
-
- eval
- {
- if ( $self->{max_arg_length}
- && length $_ > $self->{max_arg_length} )
- {
- substr( $_, $self->{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)' : '?';
- }
- }
+ # format subroutine arguments for inclusion in output
+ my @a = map $self->{arg_formatter}($_), $self->args;
- # append ('all', 'the', 'arguments') to the $sub string
- $sub .= '(' . join(', ', @a) . ')';
- $sub .= ' called';
- }
+ # append ('all', 'the', 'arguments') to the $sub string
+ $sub_args = '(' . join(', ', @a) . ')';
}
- return "$sub at " . $self->filename . ' line ' . $self->line;
+ return $self->{formatter}( $sub, $sub_args, $self->filename, $self->line, $first);
}
1;
@@ -506,6 +508,16 @@
argument's string representation if it is longer than this number of
characters.
+=item * formatter => $subroutine_reference
+
+You can take control of how the stacktrace is formatted. Details to
+be specified.
+
+=item * arg_formatter => $subroutine_reference
+
+You can take control of how arguments to subroutine calls appearing in
+the stacktrace are formatted. Details to be specified.
+
=back
=item * $trace->next_frame
| Subject: | ColorStackTrace.pm |
package ColorStackTrace;
use strict;
use warnings;
use base 'Devel::StackTrace';
use Term::ANSIColor; # use colors in output
use Cwd (); # clear up paths
use constant DFLT_LOGFILE =>
sprintf '/tmp/%s.log', join '-', split '::', __PACKAGE__;
my %counters; # count subroutine invocations
# print colored stacktrace
# aggressively try to get relative path
sub new {
my( $self, $cwd, %args ) = @_;
$cwd ||= Cwd::cwd;
my $fmt = sub { # callback for stacktrace formatting
my( $pkg_and_sub, $subargs, $file, $line, $first ) = @_;
$counters{ $pkg_and_sub }++;
# match package (1), subroutine (2) and arguments (3)
$pkg_and_sub =~ m/((?:\w+::)*)(\w+)$/;
my $func = color('bold blue'); # package color
$func .= ( $1 && $2 )
# subroutine and arguments colors
? $1 . color('bold green') . $2 . color('magenta') . $subargs
: $pkg_and_sub;
(my $rel = Cwd::abs_path( $file )) =~ s#^$cwd/##; # get relative path
return sprintf "%s%s %s %s %s",
$first ? "\n" : '', # insert newline to mark ST beginning
color('bold red') . $rel,
color('bold yellow') . $line,
$func,
color('bold yellow') . "($counters{ $pkg_and_sub })"
. color('reset');
};
# add myself to the list of ignored packages
return $self->SUPER::new( formatter => $fmt,
# arg_formatter => sub { 'xxx' },
ignore_class => __PACKAGE__, %args );
}
# convenience constructor
sub cwd {
my $frame_filter = sub {
#use Data::Dumper; warn Dumper \@_;
my %args = %{ $_[0] };
my $pkg = $args{caller}[0];
return if $pkg =~ m/^Class::MOP\b/;
return 1;
};
return $_[0]->new( '/virtual/www/michael.ludwig/sandbox/eins/perl',
frame_filter => $frame_filter,
);
}
sub logfile {
my( $self, $logfile ) = @_;
$logfile ||= DFLT_LOGFILE;
open my $fh, '>>', $logfile or die "open $logfile: $!";
return print $fh $self->as_string;
close $fh;
}
1;