SecBSD's official ports repository

infrastructure/lib/OpenBSD/Trace.pm

@@ -0,0 +1,246 @@
+# 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