246 lines
5.4 KiB
Perl
246 lines
5.4 KiB
Perl
# ex:ts=8 sw=4:
|
|
# $OpenBSD: Trace.pm,v 1.3 2023/05/09 15:37:54 espie Exp $
|
|
#
|
|
# Copyright (c) 2015-2019 Marc Espie <espie@openbsd.org>
|
|
#
|
|
# Permission to use, copy, modify, and distribute this software for any
|
|
# purpose with or without fee is hereby granted, provided that the above
|
|
# copyright notice and this permission notice appear in all copies.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
use v5.36;
|
|
package OpenBSD::Trace;
|
|
|
|
# this is a base class meant to be inherited from
|
|
|
|
# 'smart' dump param
|
|
# -> objects with a debug_dump will be stringified by it
|
|
# -> other objects will be passed to Data::Dumper for writing
|
|
# -> 'weird' characters get filtered out (think SHA contents)
|
|
|
|
|
|
my $forbidden = qr{[^[:print:]\s]};
|
|
|
|
sub dumper($self, @parms)
|
|
{
|
|
require Data::Dumper;
|
|
return Data::Dumper->new(@parms)->
|
|
Indent(0)->Maxdepth(1)->Quotekeys(0)->Sortkeys(1)->
|
|
Deparse(1);
|
|
}
|
|
|
|
sub dump_param($self, $arg = undef, $full = 0)
|
|
{
|
|
if (!defined $arg) {
|
|
return '<undef>';
|
|
} else {
|
|
my $string;
|
|
eval { $string = $arg->debug_dump };
|
|
if (defined $string) {
|
|
return "$arg($string)";
|
|
}
|
|
}
|
|
if ($full) {
|
|
my $msg = $self->dumper([$arg])->Dump;
|
|
|
|
$msg =~ s/^\$VAR1 = //;
|
|
$msg =~ s/\;$//;
|
|
$msg =~ s/$forbidden/?/g;
|
|
|
|
return $msg;
|
|
} else {
|
|
return $arg;
|
|
}
|
|
}
|
|
|
|
# the stack, mostly identical to Carp::Always
|
|
sub stack($self, $full = 0)
|
|
{
|
|
my $msg = '';
|
|
my $x = 1;
|
|
while (1) {
|
|
my @c;
|
|
{
|
|
package DB;
|
|
our @args;
|
|
@c = caller($x+1);
|
|
}
|
|
last if !@c;
|
|
# XXX do better with anon fn ?
|
|
my $fn = "$c[3]";
|
|
$msg .= $fn."(".
|
|
join(', ', map { $self->dump_param($_, $full); } @DB::args).
|
|
") called at $c[1] line $c[2]\n";
|
|
$x++;
|
|
}
|
|
return $msg;
|
|
}
|
|
|
|
# note that derived classes like DPB::Trace use the extra parms
|
|
sub new($class, @p)
|
|
{
|
|
my $o = bless {}, $class;
|
|
$o->init(@p);
|
|
return $o;
|
|
}
|
|
|
|
# XXX this is necessary to avoid endless recursion
|
|
|
|
END {
|
|
$SIG{__DIE__} = 'DEFAULT';
|
|
$SIG{__WARN__} = 'DEFAULT';
|
|
}
|
|
|
|
sub init($self)
|
|
{
|
|
$self->setup_warn;
|
|
$self->setup_die;
|
|
}
|
|
|
|
sub setup_warn($self)
|
|
{
|
|
$SIG{__WARN__} = sub {
|
|
local $SIG{__WARN__} = 'DEFAULT';
|
|
# let CORE:: do its job during compile and evals
|
|
unless (defined $^S and !$^S) {
|
|
warn @_;
|
|
return;
|
|
}
|
|
my $a = pop @_; # XXX need copy because contents of @_ are RO.
|
|
$a =~ s/(.*)( at .*? line .*?)\n$/$1$2/s;
|
|
push @_, $a;
|
|
my $msg = join("\n", @_, $self->stack(0));
|
|
$self->do_warn($msg);
|
|
};
|
|
}
|
|
|
|
sub setup_die($self)
|
|
{
|
|
$SIG{__DIE__} = sub {
|
|
local $SIG{__DIE__} = 'DEFAULT';
|
|
# let CORE:: do its job during compile and evals
|
|
unless (defined $^S and !$^S) {
|
|
die @_;
|
|
return;
|
|
}
|
|
my $a = pop @_; # XXX need copy because contents of @_ are RO.
|
|
$a =~ s/(.*)( at .*? line .*?)\n$/$1$2/s;
|
|
push @_, $a;
|
|
my $msg = join("\n", @_, $self->stack(1));
|
|
$self->do_die($msg);
|
|
};
|
|
}
|
|
|
|
sub do_warn($self, $msg)
|
|
{
|
|
warn $msg;
|
|
|
|
}
|
|
|
|
sub dump_data($self, @p)
|
|
{
|
|
require Data::Dumper;
|
|
|
|
my $msg = Data::Dumper->new(@p)->
|
|
Quotekeys(0)->Sortkeys(1)->Deparse(1)->Dump;
|
|
$msg =~ s/$forbidden/?/g;
|
|
|
|
return $msg;
|
|
}
|
|
|
|
sub do_die($self, $msg)
|
|
{
|
|
die $msg;
|
|
}
|
|
1;
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
OpenBSD::Trace - Base class for run time diagnostics
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
package MyTrace;
|
|
use parent qw(OpenBSD::Trace);
|
|
# ... specialize methods
|
|
|
|
# ... at start of main program
|
|
package main;
|
|
my $t = MyTrace;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
L<OpenBSD::Trace> provides a base class for stack dumping on warn and die.
|
|
By default, it does a standard stack dump on warn, and a "full" stack dump
|
|
on die (with arguments passed through L<Data::Dumper> with limited recursion).
|
|
|
|
Additionally, arguments for classes that define a C<debug_dump> method will
|
|
be stringified by calling C<debug_dump> instead.
|
|
|
|
L<OpenBSD::Trace> also provides an C<OpenBSD::Trace-E<gt>data_dump>
|
|
which does the same thing as L<Data::Dumper>'s C<dump> with some extras:
|
|
|
|
=over 4
|
|
|
|
=item *
|
|
|
|
non printable characters are replaced with '?'
|
|
|
|
=item *
|
|
|
|
nice options, such as Deparse and Sortkeys are set.
|
|
|
|
=back
|
|
|
|
Inheriting from L<OpenBSD::Trace> offers the following overridable methods:
|
|
|
|
=over 4
|
|
|
|
=item *
|
|
|
|
the stack dumping message is built using C<$self-E<gt>stack_dump($full)>
|
|
|
|
=item *
|
|
|
|
the Data::Dumper object with options is built using C<$self-E<gt>dumper(@_)>
|
|
|
|
=item *
|
|
|
|
the C<$SIG{__WARN__}> handler calls C<$self-E<gt>do_warn($msg)> after doing a
|
|
C<local $SIG{__WARN__} = 'DEFAULT';>
|
|
|
|
=item *
|
|
|
|
the C<$SIG{__DIE__}> handler calls C<$self-E<gt>do_die($msg)> after doing a
|
|
C<local $SIG{__DIE__} = 'DEFAULT';>
|
|
|
|
=item *
|
|
|
|
those handlers are set using C<$self-E<gt>setup_warn> and
|
|
C<$self->E<gt>setup_die> respectively
|
|
|
|
=item *
|
|
|
|
once the base constructor is done, it calls C<$self-E<gt>init(@_)>
|
|
with the rest of the parameters.
|
|
|
|
=item *
|
|
|
|
the base object is an empty hash where keys may be set as needed.
|
|
|
|
=back
|
|
|
|
Thus, a derived class can easily reuse the message creation in other contexts
|
|
(doing a C<stack_dump> on C<$SIG{STATUS}> for instance).
|
|
It's also easy to override C<do_warn> or C<do_die> to log the message
|
|
somewhere or to ensure terminal consistency.
|
|
|
|
=cut
|