File Coverage

blib/lib/Devel/Chitin.pm

Criterion	Covered	Total	%
statement	125	425	29.4
branch	14	138	10.1
condition	2	76	2.6
subroutine	34	92	36.9
pod	36	51	70.5
total	211	782	26.9

use 5.008009;
use warnings;
use strict;

package Devel::Chitin;

our $VERSION = '0.15';

use Scalar::Util;
use IO::File;
use B;

use Devel::Chitin::Actionable;  # Breakpoints and Actions
use Devel::Chitin::Eval;
use Devel::Chitin::Stack;
use Devel::Chitin::Location;
use Devel::Chitin::SubroutineLocation;
use Devel::Chitin::Exception;
use Devel::Chitin::OpTree;

use base 'Exporter';
our @EXPORT_OK = qw( $VERSION );

# lexicals shared between the interface package and the DB package
my(%attached_clients,
   @attached_clients,
   %trace_clients,
   $is_initialized,
   @pending_eval,
   $current_location,
   $previous_location,
   @new_watch_exprs,
   @watch_exprs,
);
sub attach {
    my $self = shift;

    unless ($attached_clients{$self}) {
        $attached_clients{$self} = $self;
        push @attached_clients, $self;

        if ($is_initialized) {
            $self->init();
        }
    }
    return $self;
}

sub _turn_off_trace_if_not_needed {
    $DB::trace = %trace_clients || @watch_exprs;
}

sub detach {
    my $self = shift;
    my $deleted = delete $attached_clients{$self};
    delete $trace_clients{$self};
    _turn_off_trace_if_not_needed();
    if ($deleted) {
        for (my $i = 0; $i < @attached_clients; $i++) {
            my $same = ref($self)
                    ? Scalar::Util::refaddr($self) == Scalar::Util::refaddr($attached_clients[$i])
                    : $self eq $attached_clients[$i];
            if ($same) {
                splice(@attached_clients, $i, 1);
            }
        }
    }
    return $deleted;
}


sub _clients {
    return @attached_clients;
}

## Methods callable from client code

sub step {
    $DB::single=1;
}

sub stepover {
    local $DB::in_debugger = 1;
    $DB::single=1;
    $DB::step_over_depth = $DB::stack_depth;
    return 1;
}

sub stepout {
    $DB::single=0;
    $DB::step_over_depth = $DB::stack_depth - 1;
    return 1;
}

# Should support running to a subname, or file+line
sub continue {
    $DB::single=0;
    return 1;
}

sub trace {
    local $DB::in_debugger = 1;
    my $class = shift;
    my $rv;
    if (@_) {
        my $new_val = shift;
        if ($new_val) {
            # turning trace on
            $trace_clients{$class} = $class;
            $DB::trace = 1;
            $rv = 1;
        } else {
            # turning it off
            delete $trace_clients{$class};
            _turn_off_trace_if_not_needed();
            $rv = 0;
        }

    } else {
        # Checking value
        $rv = exists $trace_clients{$class};
    }
    return $rv;
}



sub eval {
    my($class, $eval_string, $wantarray, $cb) = @_;
    push @pending_eval, [ $eval_string, $wantarray, $cb ];
}


sub eval_at {
    my($class, $eval_string, $level) = @_;

    {   no warnings 'numeric';
        $level = 0 if ($level < 1);
    }

}

sub stack {
    return Devel::Chitin::Stack->new();
}

sub current_location {
    return $current_location;
}

sub disable_debugger {
    # Setting $^P disables single stepping and subrouting entry
    # but if the program sets $DB::single explicitly, it'll still enter DB()
    $^P = 0;  # Stops single-stepping
    $DB::debugger_disabled = 1;
}

sub is_loaded {
    my($self, $filename) = @_;
    #no strict 'refs';
    return $main::{'_<' . $filename};
}

sub loaded_files {
    my @files = grep /^_
    return map { substr($_,2) } @files; # remove the <_
}

sub add_watchexpr {
    my($class, $expr) = @_;
    $DB::trace = 1;
    push @new_watch_exprs, { expr => $expr, client => $class, value => undef };
}

sub remove_watchexpr {
    my($class, $expr) = @_;
    my $deleted;

    SEARCH:
    foreach my $store ( \@watch_exprs, \@new_watch_exprs) {
        for (my $i = 0; $i < @$store; $i++) {
            if ($store->[$i]->{client} eq $class
                and
                $store->[$i]->{expr} eq $expr
            ) {
                $deleted = splice(@$store, $i, 1);
                last SEARCH;
            }
        }
    }

    _turn_off_trace_if_not_needed();

    return $deleted;
}

sub is_breakable {
    my($class, $filename, $line) = @_;

    use vars qw(@dbline);
    local(*dbline) = $main::{'_<' . $filename};
    return $dbline[$line] + 0;   # FIXME change to == 0
}

sub add_break {
    my $self = shift;
    Devel::Chitin::Breakpoint->new(@_);
}

sub get_breaks {
    my $self = shift;
    my %params = @_;
    if (defined $params{file}) {
        return Devel::Chitin::Breakpoint->get(@_);
    } else {
        return map { Devel::Chitin::Breakpoint->get(@_, file => $_) }
                $self->loaded_files;
    }
}

sub remove_break {
    my $self = shift;
    if (ref $_[0]) {
        # given a breakpoint object
        shift->delete();
    } else {
        # given breakpoint params
        Devel::Chitin::Breakpoint->delete(@_);
    }
}

sub add_action {
    my $self = shift;
    Devel::Chitin::Action->new(@_);
}

sub remove_action {
    my $self = shift;
    if (ref $_[0]) {
        # given an action object
        shift->delete();
    } else {
        # given breakpoint params
        Devel::Chitin::Action->delete(@_);
    }
}

sub get_actions {
    my $self = shift;
    my %params = @_;
    if (defined $params{file}) {
        Devel::Chitin::Action->get(@_);
    } else {
        return map { Devel::Chitin::Action->get(@_, file => $_) }
                $self->loaded_files;
    }
}

sub get_var_at_level {
    my($class, $varname, $level) = @_;

    require Devel::Chitin::GetVarAtLevel;
    return Devel::Chitin::GetVarAtLevel::get_var_at_level($varname, $level);
}


sub subroutine_location {
    my $class = shift;
    my $subname = shift;
    return Devel::Chitin::SubroutineLocation->new_from_db_sub($subname);
}

# NOTE: This postpones until a named file is loaded.
# Have another interface for postponing until a module is loaded
sub postpone {
    my($class, $filename, $sub) = @_;

    if ($class->is_loaded($filename)) {
        # already loaded, run immediately
        $sub->($filename);
    } else {
        $DB::postpone_until_loaded{$filename} ||= [];
        push @{ $DB::postpone_until_loaded{$filename} }, $sub;
    }
}

sub user_requested_exit {
    $DB::user_requested_exit = 1;
}

sub file_source {
    my($class, $file) = @_;

    my $glob = $main::{'_<' . $file};
    return unless $glob;
    return *{$glob}{ARRAY};
}

my %optrees;
our $current_sub;
sub _get_optree_for_current_sub {
    my $loc = current_location;

    my $optree_cache_key = ref($current_sub) ? "$current_sub" : $loc->subroutine;
    my $optree = $optrees{$optree_cache_key} ||= Devel::Chitin::OpTree->build_from_location(ref($current_sub) ? $current_sub : $loc);
}

# Some OPs don't deparse to anything useful on their own
my %fragment_transforms = (
    enterloop    => sub { shift->sibling->children->[0]->children->[0] },  # deparse the conditional
    leaveloop    => sub { shift->children->[0]->sibling->children->[0]->children->[0] },  # deparse the conditional
    pushmark     => sub {
                        # deparse either the list or entersub
                        my $parent = shift->parent;
                        my $grandparent = $parent->parent;
                        $grandparent->op->name eq 'entersub'
                            ? $grandparent
                            : $parent;
                    },
    padrange    => sub {
                        # deparse either the list or entersub
                        my $parent = shift->parent;
                        my $grandparent = $parent->parent;
                        $grandparent->op->name eq 'entersub'
                            ? $grandparent
                            : $parent;
                    },
);

sub next_statement {
    my $class = shift;

    my $optree = _get_optree_for_current_sub();
    my $loc = $class->current_location();
    $loc = $class->_fixup_location_inside_eval($loc);

    my $callsite = $loc->callsite;
    my($last_cop, $current_op);
    BREAKOUT:
    for(1) {
        $optree->walk_inorder(sub {
            my $op = shift;
            $last_cop = $op if ($op->isa('Devel::Chitin::OpTree::COP'));
            if (${$op->op} == $callsite) {
                $current_op = $op;
                no warnings 'exiting';
                last BREAKOUT;
            }
        });
    }

    my $op_to_deparse = $last_cop ? $last_cop->sibling : $current_op;

    if (my $xform = $fragment_transforms{$op_to_deparse->op->name}) {
        local $@;
        $op_to_deparse = eval { $xform->($op_to_deparse) } || $op_to_deparse;

    } elsif ($op_to_deparse->is_null
             and $op_to_deparse->children
             and $op_to_deparse->children->[0]->is_if_statement
    ) {
        $op_to_deparse = $op_to_deparse->children->[0]->children->[0];  # deparse the if-condition, not the whole block

    # !!! special deparsing for landing on a block-map/grep...
    # return just the list we're mapping/grepping over
    } elsif ($op_to_deparse->op->name eq 'mapwhile' or $op_to_deparse->op->name eq 'grepwhile'
             and ( $op_to_deparse->first->children->[1]->first->is_scopelike
                    or
                   ( $op_to_deparse->first->children->[1]->first->is_null
                     and
                     $op_to_deparse->first->children->[1]->first->first->is_scopelike
                   )
                 )
    ) {
        # This list contains a pushmark, the block, then all the args
        my $map_args = $op_to_deparse->first->children;
        my @maplist = @$map_args[2 .. $#$map_args];
        return join(', ', map { $_->deparse } @maplist);
    }

    if ($op_to_deparse) {
        local $@;
        my $deparsed = eval { $op_to_deparse->deparse };
        if ($@) {
            warn "failed to deparse: $@";
            $optree->print_as_tree($callsite);
        }
        return $deparsed;
    } else {
        Carp::carp("Cannot find current opcode at $callsite in ".$loc->subroutine);
        return '';
    }
}

sub next_fragment {
    my($class, $parents) = @_;

    my $optree = _get_optree_for_current_sub();
    my $loc = $class->current_location();
    $loc = $class->_fixup_location_inside_eval($loc);

    my $callsite = $loc->callsite;
    my $current_op = Devel::Chitin::OpTree->_obj_for_op(\$callsite);

    if (defined $parents) {
        while($current_op && $parents--) {
            my $parent = $current_op->parent;
            $current_op = $parent if $parent;
        }
    } elsif (my $xform = $fragment_transforms{$current_op->op->name}) {
        local $@;
        $current_op = eval { $xform->($current_op) };
    }

    if ($current_op) {
        local $@;
        my $deparsed = eval { $current_op->deparse };
        if ($@) {
            warn "failed to deparse: $@\ncurrent op name ",$current_op->op->name,"\n";
            $optree->print_as_tree($callsite);
        }
        return $deparsed;
    } else {
        Carp::carp("Cannot find current opcode at $callsite in ".$loc->subroutine);
        return '';
    }
}

sub _fixup_location_inside_eval {
    my($class, $loc) = @_;

    if ($loc->subroutine eq '(eval)') {
        my $stack = $class->stack->iterator;
        my $frame;
        for($frame = $stack->(); $frame; $frame = $stack->()) {
            last if $frame->subroutine ne '(eval)';
        }
        if ($frame) {
            return Devel::Chitin::Location->new(
                        (map { $_ => $frame->$_ } qw(package filename line subroutine)),
                        callsite => $loc->callsite
                    );
        }
    }
    return $loc;
}

## Methods called by the DB core - override in clients

sub init {}
sub poll {}
sub idle { 1;}
sub cleanup {}
sub notify_stopped {}
sub notify_resumed {}
sub notify_trace {}
sub notify_trace_resumed {}
sub notify_fork_parent {}
sub notify_fork_child {}
sub notify_program_terminated {}
sub notify_program_exit {}
sub notify_uncaught_exception {}
sub notify_watch_expr {}

sub _do_each_client {
    my($method, @args) = @_;

    $_->$method(@args) foreach @attached_clients;
}

package DB;

use vars qw( %dbline @dbline );

our($stack_depth,
    $single,
    $signal,
    $trace,
    $debugger_disabled,
    $no_stopping,
    $step_over_depth,
    $ready,
    @saved,
    $usercontext,
    $in_debugger,
    $finished,
    $user_requested_exit,
    @AUTOLOAD_names,
    $sub,
    $uncaught_exception,
    %postpone_until_loaded,
);

BEGIN {
    $stack_depth    = 0;
    $single         = 0;
    $trace          = 0;
    $debugger_disabled = 0;
    $no_stopping    = 0;
    $step_over_depth = undef;
    $ready          = 0;
    @saved          = ();
    $usercontext    = '';
    $in_debugger    = 0;

    # Controlling program end of life
    $finished       = 0;
    $user_requested_exit = 0;

    # Remember AUTOLOAD sub names
    @AUTOLOAD_names = ();
}

sub save {
    # Save eval failure, command failure, extended OS error, output field
    # separator, input record separator, output record separator and
    # the warning setting.
    @saved = ( $@, $!, $^E, $,, $/, $\, $^W );

    $,  = "";      # output field separator is null string
    $/  = "\n";    # input record separator is newline
    $\  = "";      # output record separator is null string
    $^W = 0;       # warnings are off
}

sub restore {
    ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
}

sub _evaluate_watch_exprs {
    EXPR:
    foreach my $details ( @watch_exprs ) {
        my($current_value) = _eval_in_program_context($details->{expr}, 1);
        my $old_value = $details->{value};

        if (@$current_value != @$old_value) {
            $details->{client}->notify_watch_expr($previous_location, $details->{expr}, $old_value, $current_value);
            $details->{value} = $current_value;
            next EXPR;
        }

        for (my $i = 0; $i < @$current_value; $i++) {
            no warnings 'uninitialized';
            if ((defined($current_value->[$i]) xor defined($old_value->[$i]))
                or
                $current_value->[$i] ne $old_value->[$i]
            ) {
                $details->{client}->notify_watch_expr($previous_location, $details->{expr}, $old_value, $current_value);
                $details->{value} = $current_value;
                next EXPR;
            }
        }
    }
}

sub is_breakpoint {
    my($package, $filename, $line) = @_;

    if ($single and defined($step_over_depth) and $step_over_depth < $stack_depth) {
        # This is from a step-over
        $single = 0;
        return 0;
    }

    if ($single || $signal) {
        $single = $signal = 0;
        return 1;
    }

    local(*dbline)= $main::{'_<' . $filename};

    my $should_break = 0;
    my $breakpoint_key = Devel::Chitin::Breakpoint->type;
    if ($dbline{$line} && $dbline{$line}->{$breakpoint_key}) {
        my @delete;
        foreach my $condition ( @{ $dbline{$line}->{$breakpoint_key} }) {
            next if $condition->inactive;
            my $code = $condition->code;
            if ($code eq '1') {
                $should_break = 1;
            } else {
                ($should_break) = _eval_in_program_context($condition->code, 0);
            }
            push @delete, $condition if $condition->once;
        }
        $_->delete for @delete;
    }

    if ($should_break) {
        $single = $signal = 0;
    }
    return $should_break;
}


sub _parent_stack_location {
    my($package, $filename, $line) = caller(1);
    my(undef, undef, undef, $subname) = caller(2);
    my $callsite = Devel::Chitin::Location::get_callsite(2);
    $subname ||= 'MAIN';
    return ($package, $filename, $line, $subname, $callsite);
}

BEGIN {
    # Code to get control when the debugged process forks
    *CORE::GLOBAL::fork = sub {
        my $pid = CORE::fork();
        return $pid unless $ready;

        my($package, $filename, $line, $subname, $callsite) = _parent_stack_location();
        my $location = Devel::Chitin::Location->new(
            'package'   => $package,
            line        => $line,
            filename    => $filename,
            subroutine  => $subname,
            callsite    => $callsite,
        );

        my $notify = $pid ? 'notify_fork_parent' : 'notify_fork_child';
        Devel::Chitin::_do_each_client($notify, $location, $pid);
        return $pid;
    };
};

# Reporting uncaught exceptions back to the debugger clients
# inside the handler, note the value for $^S:
# undef - died while parsing something
# 1 - died while executing an eval
# 0 - Died not inside an eval
# We could re-throw the die if $^S is 1
$SIG{__DIE__} = sub {
    if (defined($^S) && $^S == 0) {
        $in_debugger = 1;
        my $exception = $_[0];
        # It's interesting to note that if we pass an arg to caller() to
        # find out the offending subroutine name, then the line reported
        # changes.  Instead of reporting the line the exception occurred
        # (which it correctly does with no args), it returns the line which
        # called the function which threw the exception.
        # We'll work around it by calling it twice
        my($package, $filename, $line, $subname, $callsite) = _parent_stack_location();

        $uncaught_exception = Devel::Chitin::Exception->new(
            'package'   => $package,
            line        => $line,
            filename    => $filename,
            exception   => $exception,
            subroutine  => $subname,
            callsite    => $callsite,
        );
        # After we fall off the end, the interpreter will try and exit,
        # triggering the END block that calls DB::fake::at_exit()
    }
};


sub _execute_actions {
    my($filename, $line) = @_;
    local(*dbline) = $main::{'_<' . $filename};
    if ($dbline{$line} && $dbline{$line}->{action}) {
        my @delete;
        foreach my $action ( @{ $dbline{$line}->{action}} ) {
            next if $action->inactive;
            _eval_in_program_context($action->code, undef);
            push @delete, $action if $action->once;
        }
        $_->delete for @delete;
    }
}

sub fill_in_values_for_new_watch_exprs {
    foreach my $detail ( @new_watch_exprs ) {
        my($value) = _eval_in_program_context($detail->{expr}, 1);
        $detail->{value} = $value;
        push @watch_exprs, $detail;
    }
    @new_watch_exprs = ();
}

sub DB {
    return if (!$ready or $debugger_disabled or $in_debugger);

    local($in_debugger) = 1;

    my($package, $filename, $line) = caller;
    my(undef, undef, undef, $subroutine) = caller(1);
    if ($package eq 'DB::fake') {
        $package = 'main';
    }
    $subroutine ||= 'MAIN';

    unless ($is_initialized) {
        $is_initialized = 1;
        Devel::Chitin::_do_each_client('init');
    }

    # set up the context for DB::eval, so it can properly execute
    # code on behalf of the user. We add the package in so that the
    # code is eval'ed in the proper package (not in the debugger!).
    save();
    local $usercontext =
        'no strict; no warnings; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;' . "package $package;";

    $current_location = Devel::Chitin::Location->new(
        'package'   => $package,
        filename    => $filename,
        line        => $line,
        subroutine  => $subroutine,
        callsite    => scalar Devel::Chitin::Location::get_callsite(),
    );

    $_->notify_trace($current_location) foreach values(%trace_clients);

    _execute_actions($filename, $line);

    goto RETURN_TO_DEBUGGED_PROGRAM if $no_stopping;

    _evaluate_watch_exprs();

    if (! is_breakpoint($package, $filename, $line)) {
        goto RETURN_TO_DEBUGGED_PROGRAM;
    }
    $step_over_depth = undef;

    Devel::Chitin::_do_each_client('notify_stopped', $current_location);

    STOPPED_LOOP:
    foreach (1) {

        while (my $e = shift @pending_eval) {
            _eval_in_program_context(@$e);
        }

        my $should_continue = 0;
        until ($should_continue) {
            my @ready_clients = grep { $_->poll($current_location) } @attached_clients;
            last STOPPED_LOOP unless (@ready_clients);
            do { $should_continue |= $_->idle($current_location) } foreach @ready_clients;
        }

        redo if ($finished || @pending_eval);
    }

    fill_in_values_for_new_watch_exprs();

    Devel::Chitin::_do_each_client('notify_resumed', $current_location);

    RETURN_TO_DEBUGGED_PROGRAM:

    $_->notify_trace_resumed($current_location) foreach values(%trace_clients);

    $previous_location = $current_location;
    undef $current_location;
    Devel::Chitin::Stack::invalidate();
    restore();
}

BEGIN {
    my $sub_serial = 1;
    @Devel::Chitin::stack_serial = ( [ 'main::MAIN', $sub_serial++ ] );
    %Devel::Chitin::eval_serial = ();

    sub _allocate_sub_serial {
        $sub_serial++;
    }
}


# When using Class::Autouse, the B::* objects created below to determine if an
# anon sub has a name (such as via Sub::Name) trigger calls to its UNIVERSAL
# DESTROY as the B::* objects go out of scope as you step in to a call to
# that named sub.  This hack gives those classes a DESTROY method to avoid that
foreach my $class ( qw(B::HV B::GV B::CV) ) {
    next if $class->can('DESTROY');
    my $destroy = $class . '::DESTROY';
    no strict 'refs';
    *$destroy = sub {};
}

sub sub {
    no strict 'refs';
    goto &$sub if (! $ready or index($sub, 'Devel::Chitin::StackTracker') == 0 or $debugger_disabled);
    #goto &$sub if (! $ready or $in_debugger or index($sub, 'Devel::Chitin::StackTracker') == 0 or $debugger_disabled);

    local $Devel::Chitin::current_sub = $sub unless $in_debugger;

    local @AUTOLOAD_names = @AUTOLOAD_names;
    if (index($sub, '::AUTOLOAD', -10) >= 0) {
        my $caller_pkg = substr($sub, 0, length($sub)-8);
        my $caller_AUTOLOAD = ${ $caller_pkg . 'AUTOLOAD'};
        unshift @AUTOLOAD_names, $caller_AUTOLOAD;
    }
    my $stack_tracker;
    local @Devel::Chitin::stack_serial = @Devel::Chitin::stack_serial;
    unless ($in_debugger) {
        $stack_depth++;
        $stack_tracker = _new_stack_tracker(_allocate_sub_serial());

        my $subname = $sub;
        if (ref $sub) {
            my $cv = B::svref_2object($sub);
            my $gv = $cv->GV;
            if (my $name = $gv->NAME) {
                my $package = $gv->STASH->NAME;
                $subname = join('::', $package, $name);
            }
        }

        push(@Devel::Chitin::stack_serial, [ $subname, $$stack_tracker]);
    }

    my @rv;
    if (wantarray) {
        @rv = &$sub;
    } elsif (defined wantarray) {
        $rv[0] = &$sub;
    } else {
        &$sub;
    }

    delete $Devel::Chitin::eval_serial{$$stack_tracker} if $stack_tracker;

    return wantarray ? @rv : $rv[0];
}

sub _new_stack_tracker {
    my $token = shift;
    my $self = bless \$token, 'Devel::Chitin::StackTracker';
}

sub Devel::Chitin::StackTracker::DESTROY {
    $stack_depth--;
    $single = 1 if (defined($step_over_depth) and $step_over_depth >= $stack_depth);
}



# This gets called after a require'd file is compiled, but before it's executed
# it's called as DB::postponed(*{"_<$filename"})
# We can use this to break on module load, for example.
# If $DB::postponed{$subname} exists, then this is called as
# DB::postponed($subname)
sub postponed {
    my($filename) = ($_[0] =~ m/_\<(.*)$/);

    if (my $actions = delete $postpone_until_loaded{$filename}) {
        $_->($filename) foreach @$actions;
    }
}

END {
    $trace = 0;

    return if $debugger_disabled;

    $single=0;
    $in_debugger = 1;

    eval {
        Devel::Chitin::_do_each_client('notify_uncaught_exception', $uncaught_exception) if $uncaught_exception;

        if ($user_requested_exit) {
            Devel::Chitin::_do_each_client('notify_program_exit');
        } else {
            Devel::Chitin::_do_each_client('notify_program_terminated', $?);
            $finished = 1;
            # These two will trigger DB::DB and the event loop
            $in_debugger = 0;
            $single=1;
            Devel::Chitin::exiting::at_exit();
        }
    }
}

package Devel::Chitin::exiting;
sub at_exit {
    1;
}

package DB;
BEGIN { $DB::ready = 1; }

1;

__END__