# ex:ts=8 sw=4: # $OpenBSD: Trace.pm,v 1.2 2023/06/16 04:17:56 espie Exp $ # # Copyright (c) 2015-2018 Marc Espie # # 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 Trace; # inspired by Carp::Always sub trace_message() { my $msg = ''; my $x = 1; while (1) { my @c; { package DB; our @args; @c = caller($x+1); } last if !@c; $msg .= "$c[3](". join(', ', map { if (!defined $_) { ''; } else { my $string; eval { $string = $_->debug_dump }; if (defined $string) { "$_($string)"; } else { $_; } } } @DB::args). ") called at $c[1] line $c[2]\n"; $x++; } return $msg; } my ($sig, $olddie, $oldwarn); sub setup($class, $sig) { $olddie = $SIG{__DIE__}; $oldwarn = $SIG{__WARN__}; $sig->{__WARN__} = sub { $sig->{__WARN__} = $oldwarn; my $a = pop @_; $a =~ s/(.*)( at .*? line .*?)\n$/$1$2/s; push @_, $a; my $msg = join("\n", @_, &trace_message()); warn $msg; }; $sig->{__DIE__} = sub { die @_ if $^S; $sig->{__DIE__} = $olddie; my $a = pop @_; $a =~ s/(.*)( at .*? line .*?)\n$/$1$2/s; push @_, $a; my $msg = join("\n", @_, &trace_message()); die $msg; }; $sig->{INFO} = sub { print "Trace:\n", &trace_message(); sleep 1; }; } END { $sig->{__DIE__} = $olddie; $sig->{__WARN__} = $oldwarn; } 1;