File Coverage

lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Breakpoints.pm

Criterion	Covered	Total	%
statement	48	232	20.6
branch	0	96	0.0
condition	0	12	0.0
subroutine	16	24	66.6
pod			n/a
total	64	364	17.5

# -*- coding: utf-8 -*-
# Copyright (C) 2011-2012, 2014 Rocky Bernstein <[e-mail]>
use warnings; use utf8;
use rlib '../../../../..';

package Devel::Trepan::CmdProcessor::Command::Info::Breakpoints;
use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;

use strict;
use vars qw(@ISA @SUBCMD_VARS);
@ISA = qw(Devel::Trepan::CmdProcessor::Command::Subcmd);
# Values inherited from parent
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;

our $SHORT_HELP = 'List breakpoint information';

## FIXME: do automatically.
our $CMD = "info breakpoints";

our $HELP = <<'HELP';
=pod

B<info breakpoints> [I<num1> ...] [B<verbose>]

Show status of user-settable breakpoints. If no breakpoint numbers are
given, the show all breakpoints. Otherwise only those breakpoints
listed are shown and the order given. If B<verbose> is given, more
information provided about each breakpoint.

=head2 Examples:

  trepanpl: info breakpoints
  Num Type          Disp Enb Where
  1   breakpoint    keep y   at gcd.pl:8
 	breakpoint already hit 1 time
  No actions.
  No watch expressions defined.

The I<Disp> column contains one of I<keep>, I<del>, the disposition of
the breakpoint after it gets hit.

The I<Enb> column indicates whether the breakpoint is enabled.

The I<Where> column indicates where the breakpoint is located.

=head2 See also:

L<C<break>|Devel::Trepan::CmdProcessor::Command::Action>,
L<C<break>|Devel::Trepan::CmdProcessor::Command::Break>,
L<C<disable>|<Devel::Trepan::CmdProcessor::Command::Disable>,
L<C<enable>|<Devel::Trepan::CmdProcessor::Command::Enable>,
L<C<watch>|<Devel::Trepan::CmdProcessor::Command::Watch>, and
L<C<help syntax location>|Devel::Trepan::CmdProcessor::Command::Help::location>.


=cut
HELP

our $MIN_ABBREV  = length('br');

no warnings 'redefine';
sub complete($$)
{
    my ($self, $prefix) = @_;
    my @completions = $self->{proc}{brkpts}->ids;
    Devel::Trepan::Complete::complete_token(\@completions, $prefix);
}

sub bpprint($$;$)
{
    my ($self, $bp, $verbose) = @_;
    my $proc = $self->{proc};
    my $disp = ($bp->type eq 'tbreak') ? 'del  ' : 'keep ';
    $disp .= $bp->enabled ? 'y  '   : 'n  ';

    my $line_loc = sprintf('%s:%d', $proc->canonic_file($bp->filename),
                           $bp->line_num);

    my $mess = sprintf('%-4dbreakpoint    %s at %s',
                       $bp->id, $disp, $line_loc);
    $proc->msg($mess);

    if ($bp->condition && $bp->condition ne '1') {
        my $msg = sprintf("\tstop %s %s",
                          $bp->negate ? "unless" : "only if",
                          $bp->condition);
        $proc->msg($msg);
    }
    if ($bp->hits > 0) {
        my $ss = ($bp->hits > 1) ? 's' : '';
        my $msg = sprintf("\tbreakpoint already hit %d time%s",
                          $bp->hits, $ss);
        $proc->msg($msg);
    }
}

sub action_print($$;$)
{
    my ($self, $action, $verbose) = @_;
    my $proc = $self->{proc};
    my $disp = $action->enabled ? 'y  '   : 'n  ';

    my $line_loc = sprintf('%s:%d', $action->filename, $action->line_num);

    my $mess = sprintf('%-4daction     %s at %s',
                       $action->id, $disp, $line_loc);
    $proc->msg($mess);

    if ($action->condition && $action->condition ne '1') {
        my $msg = sprintf("\texpression: %s", $action->condition);
        $proc->msg($msg);
    }
    if ($action->hits > 0) {
        my $ss = ($action->hits > 1) ? 's' : '';
        my $msg = sprintf("\taction already hit %d time%s",
                          $action->hits, $ss);
        $proc->msg($msg);
    }
}


# sub save_command($)
# {
#     my $self = shift;
#     my $proc = $self->{proc};
#     my $bpmgr = $proc->{brkpts};
#     my @res = ();
#     for my $bp ($bpmgr->list) {
#       push @res, "break ${loc}";
#     }
#    return @res;
# }

sub run($$) {
    my ($self, $args) = @_;
    my $verbose = 0;
    my $proc = $self->{proc};
    unless (scalar @$args) {
        if ('verbose' eq $args->[-1]) {
            $verbose = 1;
            pop @{$args};
        }
    }

    my $show_all = 1;
    my $show_actions = 1;
    my $show_watch = 1;
    my @args = ();
    if (scalar @{$args} > 2) {
        @args = splice(@{$args}, 2);
        my $max = $proc->{brkpts}->max;
        my $opts = {
            msg_on_error =>
                "An '${CMD}' argument must eval to a breakpoint between 1..${max}.",
                min_value => 1,
                max_value => $max
        };
        @args = $proc->get_int_list(\@args);
        $show_all = $show_watch = $show_actions = 0;
    }

    my $bpmgr = $proc->{brkpts};
    $bpmgr->compact;
    my @brkpts = @{$bpmgr->{list}};
    if (0 == scalar @brkpts) {
        $proc->msg('No breakpoints.');
    } else {
        # There's at least one
        $proc->section("Num Type          Disp Enb Where");
        if ($show_all) {
            for my $bp (@brkpts) {
                $self->bpprint($bp, $verbose);
            }
        } else  {
            my @not_found = ();
            for my $bp_num (@args)  {
                next unless $bp_num;
                my $bp = $bpmgr->find($bp_num);
                if ($bp) {
                    $self->bpprint($bp, $verbose);
                } else {
                    push @not_found, $bp_num;
                }
            }
            if (scalar @not_found) {
                my $msg = sprintf("No breakpoint number(s) %s.\n",
                                  join(', ', @not_found));
                $proc->errmsg($msg);
            }
        }
    }

    if ($show_actions) {
        my $actmgr = $proc->{actions};
        $actmgr->compact;
        my @actions = @{$actmgr->{list}};
        if (0 == scalar @actions) {
            $proc->msg('No actions.');
        } else {
            # There's at least one
            $proc->section("Num Type       Enb Where");
            if ($show_all) {
                for my $action (@actions) {
                    $self->action_print($action, $verbose);
                }
            } else  {
                my @not_found = ();
                for my $action_num (@args)  {
                    my $action = $actmgr->find($action_num);
                    if ($action) {
                    $self->actino_print($action, $verbose);
                    } else {
                        push @not_found, $action_num;
                    }
                }
                unless (scalar @not_found) {
                    my $msg = sprintf("No action number(s) %s.\n",
                                      join(', ', @not_found));
                    $proc->errmsg($msg);
                }
            }
        }
    }
    if ($show_watch) {
        $self->{proc}->run_command('info watch');
    }
}

if (caller) {
  # Demo it.
  # use rlib '../../mock'
  # name = File.basename(__FILE__, '.rb')
  # dbgr, cmd = MockDebugger::setup('info')
  # subcommand = Trepan::Subcommand::InfoBreakpoints.new(cmd)

  # print '-' * 20
  # subcommand.run(%w(info break))
  # print '-' * 20
  # subcommand.summary_help(name)
  # print
  # print '-' * 20

  # require 'thread_frame'
  # tf = RubyVM::ThreadFrame.current
  # pc_offset = tf.pc_offset
  # sub foo
  #   5
  # end

  # brk_cmd = dbgr.core.processor.commands['break']
  # brk_cmd.run(['break', "O${pc_offset}"])
  # cmd.run(%w(info break))
  # print '-' * 20
  # brk_cmd.run(['break', 'foo'])
  # subcommand.run(%w(info break))
  # print '-' * 20
  # print subcommand.save_command
}

1;