Stopping a profiler created with DB::DB to show a call a second time where it wasn't really cal-CodePudding

While searching for the possibility to log all used subroutines in the framework i use, i found this question. The top answer uses the subroutine DB::DB to log all used subroutines. This works somewhat, used with caller(), to find out which path the program took. But i have the Problem, that a subroutine is "called" a second time, when the program returns from a function and enters a new one.

My DB::DB in /etc/perl/Devel/AllSubs.pm

package Devel::AllSubs;

use Data::Dumper;
$Data::Dumper::Sortkeys = 1;

my $LastSub = '::';

sub DB::DB {

    my ($Package, $Filename, $Line, $Subroutine) = caller(1);

    if ($Subroutine ne $LastSub ){
        print STDERR Data::Dumper->Dump(
            [
                $Package,
                $Filename,
                $Line,
                $Subroutine
            ],
            ['Package-1', 'Filename-1', 'Line-1', "Subroutine-1"]
        );

        COUNT:
        for ( my $Count = 2; $Count < 30; $Count   ) {

            my ( $NextPackage, $NextFilename, $NextLine, $NextSubroutine ) = caller( $Count );

            last COUNT if !$NextLine;
            print STDERR Data::Dumper->Dump(
                [
                    $NextPackage,
                    $NextFilename,
                    $NextLine,
                    $NextSubroutine
                ],
                ["Package-$Count", "Filename-$Count", "Line-$Count", "Subroutine-$Count",]
            );
        }
        say STDERR "";

        $LastSub = $Subroutine;
    }

}

1;

The program whose calls i want to check perl -d:AllSubs AllTest.pl

&One();

sub One {
    &Two();
}

sub Two {
    &Three();
    &Six();
}

sub Three {
    &Four();
    &Five();
}

sub Four {}

sub Five {}

sub Six {}

1;

The above mentioned answer claims, that DB::DB is called for every subroutine, so my expected result was:

# One
#   Two
#     Three
#       Four
#       Five
#     Six

What i got was:

# One
#   Two
#     Three
#       Four
#     Three
#       Five
#   Two
#     Six

The complete dumper output is:

$Package-1 = undef;
$Filename-1 = undef;
$Line-1 = undef;
$Subroutine-1 = undef;

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 30;
$Subroutine-1 = 'main::One';

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 34;
$Subroutine-1 = 'main::Two';
$Package-2 = 'main';
$Filename-2 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-2 = 30;
$Subroutine-2 = 'main::One';

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 38;
$Subroutine-1 = 'main::Three';
$Package-2 = 'main';
$Filename-2 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-2 = 34;
$Subroutine-2 = 'main::Two';
$Package-3 = 'main';
$Filename-3 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-3 = 30;
$Subroutine-3 = 'main::One';

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 43;
$Subroutine-1 = 'main::Four';
$Package-2 = 'main';
$Filename-2 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-2 = 38;
$Subroutine-2 = 'main::Three';
$Package-3 = 'main';
$Filename-3 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-3 = 34;
$Subroutine-3 = 'main::Two';
$Package-4 = 'main';
$Filename-4 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-4 = 30;
$Subroutine-4 = 'main::One';

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 38;
$Subroutine-1 = 'main::Three';
$Package-2 = 'main';
$Filename-2 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-2 = 34;
$Subroutine-2 = 'main::Two';
$Package-3 = 'main';
$Filename-3 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-3 = 30;
$Subroutine-3 = 'main::One';

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 44;
$Subroutine-1 = 'main::Five';
$Package-2 = 'main';
$Filename-2 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-2 = 38;
$Subroutine-2 = 'main::Three';
$Package-3 = 'main';
$Filename-3 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-3 = 34;
$Subroutine-3 = 'main::Two';
$Package-4 = 'main';
$Filename-4 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-4 = 30;
$Subroutine-4 = 'main::One';

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 34;
$Subroutine-1 = 'main::Two';
$Package-2 = 'main';
$Filename-2 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-2 = 30;
$Subroutine-2 = 'main::One';

$Package-1 = 'main';
$Filename-1 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-1 = 39;
$Subroutine-1 = 'main::Six';
$Package-2 = 'main';
$Filename-2 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-2 = 34;
$Subroutine-2 = 'main::Two';
$Package-3 = 'main';
$Filename-3 = '/opt/frameworks/test/scripts/AllTest.pl';
$Line-3 = 30;
$Subroutine-3 = 'main::One';

$Package-1 = undef;
$Filename-1 = undef;
$Line-1 = undef;
$Subroutine-1 = undef;

Is there any way to skip the cases where DB::DB is called, even though it it not called a second time within the code?

EDIT: I made some progress. DB::DB is called for each line of the code. DB::sub on the other hand is what i needed. If i use caller() here, i get the previous sub for caller(0). The current sub is in $DB::sub. But i also need the filename and the line where this sub was called. It says here that $DB::filename should contain the filename, but it is empty. I also found some information in this perl4 book, but not enough to help me at this point.

CodePudding user response：

Here is an example that seems to work:

lib/Devel/MyDebugger.pm:

package Devel::MyDebugger;
package DB;
use feature qw(say);
use warnings;

our $sub;
our $dbline;
our $dbpack;
our $dbfile;

our $START_DEBUG = 0;
sub DB  {
    ($dbpack, $dbfile, $dbline) = caller;
}

sub sub {
    if ("$sub" eq "main::One") {
        $START_DEBUG = 1;
    }
    if ($START_DEBUG) {
        say "";
        say "[sub = $sub, lineno = $dbline, pack = $dbpack, file = $dbfile]";
        for ( my $frame = 0; $frame < 30; $frame   ) {
            my @info = my ($package, $filename, $line, $subroutine) = caller $frame;
            last if !$line;
            print_info($frame, @info);
        }
    }
    &$sub;
}

sub print_info {
    my ($frame, $package, $filename, $line, $subroutine) = @_;

    my $indent = " " x $frame;
    say "${indent}Package-$frame: $package";
    say "${indent}Filename-$frame: $filename";
    say "${indent}Line-$frame: $line";
    say "${indent}Subroutine-$frame: $subroutine";
}

p.pl:

#! /usr/bin/env perl
use strict;
use warnings;
&One();
sub One {
    &Two();
}
sub Two {
    &Three();
    &Six();
}
sub Three {
    &Four();
    &Five();
}
sub Four { }
sub Five { }
sub Six { }

The run the debugger like this:

$ perl -I./lib -d:MyDebugger p.pl

Output:

[sub = main::One, lineno = 6, pack = main, file = p.pl]

[sub = main::Two, lineno = 8, pack = main, file = p.pl]
Package-0: main
Filename-0: p.pl
Line-0: 6
Subroutine-0: main::One

[sub = main::Three, lineno = 11, pack = main, file = p.pl]
Package-0: main
Filename-0: p.pl
Line-0: 8
Subroutine-0: main::Two
 Package-1: main
 Filename-1: p.pl
 Line-1: 6
 Subroutine-1: main::One

[sub = main::Four, lineno = 15, pack = main, file = p.pl]
Package-0: main
Filename-0: p.pl
Line-0: 11
Subroutine-0: main::Three
 Package-1: main
 Filename-1: p.pl
 Line-1: 8
 Subroutine-1: main::Two
  Package-2: main
  Filename-2: p.pl
  Line-2: 6
  Subroutine-2: main::One

[sub = main::Five, lineno = 16, pack = main, file = p.pl]
Package-0: main
Filename-0: p.pl
Line-0: 11
Subroutine-0: main::Three
 Package-1: main
 Filename-1: p.pl
 Line-1: 8
 Subroutine-1: main::Two
  Package-2: main
  Filename-2: p.pl
  Line-2: 6
  Subroutine-2: main::One

[sub = main::Six, lineno = 12, pack = main, file = p.pl]
Package-0: main
Filename-0: p.pl
Line-0: 8
Subroutine-0: main::Two
 Package-1: main
 Filename-1: p.pl
 Line-1: 6
 Subroutine-1: main::One