File Coverage

lib/Devel/Trepan/DB/Sub.pm

Criterion	Covered	Total	%
statement	76	243	31.2
branch	0	92	0.0
condition	0	36	0.0
subroutine	24	30	80.0
pod	1	6	16.6
total	101	407	24.8

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

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

use vars qw($return_value @return_value @ret $ret @stack %fn_brkpt $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';
    %DB::fn_brkpt    = ();

    # $deep: Maximium stack depth before we complain.
    # See RT #117407
    # https://rt.perl.org/rt3//Public/Bug/Display.html?id=117407
    # for justification for why this should be 1000 rather than something
    # smaller.
    $DB::deep = 500;

    # $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.
    $DB::stack_depth = 0;
    @DB::stack = (0);     # Per-frame debugger flags
}

sub subcall_debugger {
    if ($DB::single || $DB::signal) {
        _warnall($#DB::stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
	local $DB::event = 'call';
        $DB::single = 0;
        $DB::signal = 0;
        $DB::running = 0;

	# lock the debugger and get the thread id for the prompt
	if ($ENV{PERL5DB_THREADED}) {
	    require threads;
	    require threads::shared;
	    import threads::shared qw(share);
	    no strict; no warnings;
	    lock($DBGR);
	    $tid = eval { "[".threads->tid."]" };
	}

	local $OP_addr = Devel::Callsite::callsite(1);

	$DB::subroutine =  $sub;
	my $entry = $DB::sub{$sub};
	if ($entry =~ /^(.*)\:(\d+)-(\d+)$/) {
	    $DB::filename   = $1;
	    $DB::lineno     = $2;
	    $DB::caller = [
		$DB::filename, $DB::lineno, $DB::subroutine,
		0 != scalar(@_), $DB::wantarray
		];
	}
        for my $c (@clients) {
            # Now sit in an event loop until something sets $running
            my $after_eval = 0;
            do {
                # Show display expresions
                my $display_aref = $c->display_lists;
                for my $disp (@$display_aref) {
                    next unless $disp && $disp->enabled;
                    my $opts = {return_type => $disp->return_type,
                                namespace_package => $namespace_package,
                                fix_file_and_line => 1,
                                hide_position     => 0};
                    # FIXME: allow more than just scalar contexts.
		    &DB::save_vars();
                    my $eval_result =
                        &DB::eval_with_return($disp->arg, $opts, @DB::saved);
		    my $mess;
		    if (defined($eval_result)) {
			$mess = sprintf("%d: $eval_result", $disp->number);
		    } else {
			$mess = sprintf("%d: undef", $disp->number);
		    }
                    $c->output($mess);
                }

                if (1 == $after_eval ) {
                    $event = 'after_eval';
                } elsif (2 == $after_eval) {
                    $event = 'after_nest'
                }

                # call client event loop; must not block
                $c->idle($event, $watch_triggered);
                $after_eval = 0;
                if ($running == 2 && defined($eval_str)) {
                    # client wants something eval-ed
                    # FIXME: turn into subroutine.

                    local $nest = $eval_opts->{nest};
                    my $return_type = $eval_opts->{return_type};
                    $return_type = '' unless defined $return_type;
                    my $opts = $eval_opts;
                    $opts->{namespace_package} = $namespace_package;

		    &DB::save_vars();
                    if ('@' eq $return_type) {
                        &DB::eval_with_return($eval_str, $opts, @DB::saved);
                    } elsif ('%' eq $return_type) {
                        &DB::eval_with_return($eval_str, $opts, @DB::saved);
                    } else {
                        $eval_result =
                            &DB::eval_with_return($eval_str, $opts, @DB::saved);
                    }

                    if ($nest) {
                        $DB::in_debugger = 1;
                        $after_eval = 2;
                    } else {
                        $after_eval = 1;
                    }
                    $running = 0;
                }
            } until $running;
        }
    }
}

sub check_for_stop()
{
    my $brkpts = $DB::fn_brkpt{$sub};
    if ($brkpts) {
	my @action = ();
        for (my $i=0; $i < @$brkpts; $i++) {
            my $brkpt = $brkpts->[$i];
            next unless defined $brkpt;
            if ($brkpt->type eq 'action') {
                push @action, $brkpt;
                next ;
            }
            $stop = 0;
            if ($brkpt->condition eq '1') {
                # A cheap and simple test for unconditional.
                $stop = 1;
            } else  {
                my $eval_str = sprintf("\$DB::stop = do { %s; }",
                                       $brkpt->condition);
                my $opts = {return_type => ';',  # ignore return
                            namespace_package => $namespace_package,
                            fix_file_and_line => 1,
                            hide_position     => 0};
		&DB::save_vars();
                &DB::eval_with_return($eval_str, $opts, @DB::saved);
            }
            if ($stop && $brkpt->enabled && !($DB::single & RETURN_EVENT)) {
                $DB::brkpt = $brkpt;
                $event = $brkpt->type;
                if ($event eq 'tbrkpt') {
                    # breakpoint is temporary and remove it.
                    undef $brkpts->[$i];
                } else {
                    my $hits = $brkpt->hits + 1;
                    $brkpt->hits($hits);
                }
		$DB::single = 1;
		$DB::wantarray = wantarray;
		local $OP_addr = Devel::Callsite::callsite(1);
		&subcall_debugger() ;
                last;
            }
        }
    }
}

# Push the $DB:single onto @DB::stack and set $DB_single.
sub push_DB_single_and_set()
{
    # Expand @stack.
    $#DB::stack = $DB::stack_depth;

    # Save current single-step setting.
    $DB::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;
}


####
# When debugging is enabled, this routine gets called instead of
# the orignal subroutine. $DB::sub contains the intended subroutine
# to be called. Thus, this routine must run &$DB::sub
# in order to get the original routine called. The fact that
# this routine is called instead allows us to wrap or put code
# around subroutine calls
#
sub DB::sub {
    # Do not use a regex in this subroutine -> results in corrupted
    # memory See: [perl #66110]

    # lock ourselves under threads
    lock($DBGR) if $ENV{PERL5DB_THREADED};

    # 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 ($DB::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 $DB::sub.
    if ( length($DB::sub) > 10 && substr( $DB::sub, -10, 10 ) eq '::AUTOLOAD' ) {
        no strict 'refs';
        $al = " for $$DB::sub" if defined $$DB::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
    push_DB_single_and_set();

    if (defined($DB::running) && $DB::running == 1) {
	local @DB::_ = @_;
	local(*DB::dbline) = "::_<$DB::filename";

	# FIXME: this isn't quite right;
	$DB::addr = +B::svref_2object(\$DB::subroutine);

	check_for_stop();
    }

    # FIXME: this isn't quite right. For mysterious reasons $DB::wantarray
    # is tracking the wrong frame and is always @
    # $DB::wantarray = $DB::wantarray ? '@' : ( defined $wantarray ? '$' : '.' );
    $DB::wantarray = '?';

    if ($DB::sub eq 'DESTROY' or
        substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
        &$DB::sub;
	no warnings 'uninitialized';
        $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.

	{
	    no strict 'refs';
	    # call the original subroutine and save the array value.
	    @ret = &$DB::sub;
	}

        # Pop the single-step value back off the stack.
	if ($stack[$stack_depth]) {
	    $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 {
        # 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.

        if ( defined wantarray ) {
            no strict 'refs';
	    # call the original subroutine and save the array value.
            $ret = &$DB::sub;
        } else {
            no strict 'refs';
	    # Call the original lvalue sub and explicitly void the return
            # value.
            &$DB::sub;
            undef $ret;
        }

        # Pop the single-step value back off the stack.
        $DB::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.
        return $ret;
    }
}

####
# When debugging is enabled, this routine gets called instead of the
# orignal subroutine in a left-hand (assignment) context. $DB::sub
# contains the intended subroutine to be called. Thus, this routine
# must run &$DB::sub in order to get the original routine called. The
# fact that this routine is called instead allows us to wrap or
# instrument code around subroutine calls.
#
sub DB::lsub : lvalue {
    # Possibly [perl #66110] also applies here as in sub.

    # lock ourselves under threads
    lock($DBGR) if $ENV{PERL5DB_THREADED};

    # 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 ($DB::sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
        print "creating new thread\n";
    }

    # If the last ten characters are '::AUTOLOAD', note we've traced
    # into AUTOLOAD for $DB::sub.
    if ( length($DB::sub) > 10 && substr( $DB::sub, -10, 10 ) eq '::AUTOLOAD' ) {
        $al = " for $$DB::sub" if defined $$DB::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
    push_DB_single_and_set();

    local(*DB::dbline) = "::_<$DB::filename";

    # FIXME: this isn't quite right;
    $DB::addr = +B::svref_2object(\$DB::subroutine);

    check_for_stop();

    if (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.
	{
	    no strict 'refs';
	    @ret = &$DB::sub;
	}

        # Pop the single-step value back off the stack.
        $DB::single |= $stack[ $stack_depth-- ];
        if ($DB::single & RETURN_EVENT) {
            $DB::return_type = 'array';
            @DB::return_value = @ret;
            DB::DB($DB::sub) ;
            return @DB::return_value;
        }
        @ret;
    } else {
        # 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.

        if ( defined wantarray ) {
            no strict 'refs';
            # Save the value if it's wanted at all.
            $ret = &$DB::sub;
        } else {
            no strict 'refs';
            # Void return, explicitly.
            &$DB::sub;
            undef $ret;
        }

        # Pop the single-step value back off the stack.
        $DB::single |= $stack[ $stack_depth-- ] if $stack[$stack_depth];
        if ($DB::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.
        return $ret;
    }
}

####
# 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;
      next unless $name;
      push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
        if exists $DB::sub{$name};
    }
    return @ret;
  }
  return keys %DB::sub;
}

1;