# Derived from perl5db.pl
# Tracks calls and returns and stores some stack frame
# information.
package DB;
use warnings; no warnings 'redefine';
no warnings 'once';
use English qw( -no_match_vars );

use constant SINGLE_STEPPING_EVENT =>  1;
use constant NEXT_STEPPING_EVENT   =>  2;
use constant DEEP_RECURSION_EVENT  =>  4;
use constant RETURN_EVENT          => 32;

use vars qw($return_value @return_value @stack);

my ($deep);

BEGIN {
    @DB::ret = ();    # return value of last sub executed in list context
    $DB::ret = '';    # return value of last sub executed in scalar context
    $DB::return_type = 'undef';
    $deep = 70;      # Max stack depth before we complain.

    # $stack_depth is to track the current stack depth using the
    # auto-stacked-variable trick. It is 'local'ized repeatedly as
    # a simple way to keep track of #stack.
    $stack_depth = 0;
    @stack = (0);     # Per-frame debugger flags
}

####
# entry point for all subroutine calls
#
sub sub {
    # Do not use a regex in this subroutine -> results in corrupted
    # memory See: [perl #66110]

    # lock ourselves under threads
    lock($DBGR);

    # Whether or not the autoloader was running, a scalar to put the
    # sub's return value in (if needed), and an array to put the sub's
    # return value in (if needed).
    my ( $al, $ret, @ret ) = "";
    if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
	print "creating new thread\n"; 
    }
    
    # If the last ten characters are '::AUTOLOAD', note we've traced
    # into AUTOLOAD for $sub.
    if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
        $al = " for $$sub" if defined $$sub;
    }
    
    # We stack the stack pointer and then increment it to protect us
    # from a situation that might unwind a whole bunch of call frames
    # at once. Localizing the stack pointer means that it will automatically
    # unwind the same amount when multiple stack frames are unwound.
    local $stack_depth = $stack_depth + 1;    # Protect from non-local exits

    # Expand @stack.
    $#stack = $stack_depth;

    # Save current single-step setting.
    $stack[-1] = $DB::single;

    ## printf "++ \$DB::single for $sub: 0%x\n", $DB::single if $DB::single;
    # Turn off all flags except single-stepping or return event.
    $DB::single &= SINGLE_STEPPING_EVENT;

    # If we've gotten really deeply recursed, turn on the flag that will
    # make us stop with the 'deep recursion' message.
    $DB::single |= DEEP_RECURSION_EVENT if $#stack == $deep;

    if ($DB::sub eq 'DESTROY' or
	substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
	&$DB::sub;
	$DB::single |= pop(@stack);
	$DB::ret = undef;
    }
    elsif (wantarray) {
        # Called in array context. call sub and capture output.
        # DB::DB will recursively get control again if appropriate; we'll come
        # back here when the sub is finished.
	@ret = &$sub;

        # Pop the single-step value back off the stack.
        $DB::single |= $stack[ $stack_depth-- ];
	if ($single & RETURN_EVENT) {
	    $DB::return_type = 'array';
	    @DB::return_value = @ret;
	    DB::DB($DB::sub) ;
	    return @DB::return_value;
	}
	@ret;
    }
    else {
	if ( defined wantarray ) {
	    # Save the value if it's wanted at all.
	    $ret = &$sub;
	}
	else {
	    # Void return, explicitly.
	    &$sub;
	    undef $ret;
	}

        # Pop the single-step value back off the stack.
        $single |= $stack[ $stack_depth-- ] if $stack[$stack_depth];
	if ($single & RETURN_EVENT) {
	    $DB::return_type = defined $ret ? 'scalar' : 'undef';
	    $DB::return_value = $ret;
	    DB::DB($DB::sub) ;
	    return $DB::return_value;
	}

        # Return the appropriate scalar value.
	$ret;
    }
}

sub lsub : lvalue {

    # lock ourselves under threads
    lock($DBGR);
    
    # Whether or not the autoloader was running, a scalar to put the
    # sub's return value in (if needed), and an array to put the sub's
    # return value in (if needed).
    my ( $al, $ret, @ret ) = "";
    if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
	print "creating new thread\n";
    }
    
    # If the last ten characters are C'::AUTOLOAD', note we've traced
    # into AUTOLOAD for $sub.
    if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
        $al = " for $$sub";
    }
    
    # We stack the stack pointer and then increment it to protect us
    # from a situation that might unwind a whole bunch of call frames
    # at once. Localizing the stack pointer means that it will automatically
    # unwind the same amount when multiple stack frames are unwound.
    local $stack_depth = $stack_depth + 1;    # Protect from non-local exits
    
    # Expand @stack.
    $#stack = $stack_depth;
    
    # Save current single-step setting.
    $stack[-1] = $single;
    
    # Turn off all flags except single-stepping.
    $single &= SINGLE_STEPPING_EVENT;
    
    # If we've gotten really deeply recursed, turn on the flag that will
    # make us stop with the 'deep recursion' message.
    $single |= DEEP_RECURSION_EVENT if $stack_depth == $deep;
    
    # Pop the single-step value back off the stack.
    $single |= $stack[ $stack_depth-- ];
    
    # call the original lvalue sub.
    &$sub;
}

####
# without args: returns all defined subroutine names
# with subname args: returns a listref [file, start, end]
#
sub subs {
  my $s = shift;
  if (@_) {
    my(@ret) = ();
    while (@_) {
      my $name = shift;
      push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/] 
	if exists $DB::sub{$name};
    }
    return @ret;
  }
  return keys %DB::sub;
}

1;
