# -*- coding: utf-8 -*-
# Copyright (C) 2011-2013 Rocky Bernstein <rocky@cpan.org>
# A base class for debugger subcommands.
#
use Exporter;
use warnings;
no warnings 'redefine';
use rlib '../../../../..';
use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
package Devel::Trepan::CmdProcessor::Command::Subsubcmd;
use Devel::Trepan::CmdProcessor::Validate;
BEGIN {
@SUBCMD_VARS = qw($HELP $IN_LIST $RUN_CMD $MIN_ABBREV
$NAME $SHORT_HELP @SUBCMD_VARS
@SUBCMD_ISA);
}
use strict;
my $NotImplementedMessage =
"This method must be overridden in a subsubclass";
use vars qw(@SUBCMD_VARS @EXPORT @ISA @SUBCMD_ISA);
use vars @SUBCMD_VARS;
@ISA = qw(Exporter);
@SUBCMD_ISA = qw(Devel::Trepan::CmdProcessor::Command::Subsubcmd);
@EXPORT = @SUBCMD_VARS;
# attr_reader :name
$IN_LIST = 1; # Show item in help list of commands
$RUN_CMD = 1; # Run subcommand for those subcommands like "show"
# which append current settings to list output.
use constant MIN_ARGS => 0;
use constant MAX_ARGS => 0;
$MIN_ABBREV = 1;
use constant NEED_STACK => 0;
$NAME = 'your_command_name';
# $cmd contains the command object that this
# command is invoked through. A debugger field gives access to
# the stack frame and I/O.
sub new($$$)
{
my ($class, $parent, $name) = @_;
my $self = {parent => $parent};
# Convenience class access. We don't expect that any of these
# will change over the course of the program execution like
# errmsg(), msg(), and msg_nocr() might. (See the note below
# on these latter 3 methods.)
#
$self->{dbgr} = $parent->{dbgr};
$self->{proc} = $parent->{proc};
# FIXME: Inheritence of vars is not working the way I had hoped.
# So this is a workaround.
my $base_prefix="Devel::Trepan::CmdProcessor::Command::Subcmd::";
for my $field (@SUBCMD_VARS) {
my $sigil = substr($field, 0, 1);
my $new_field = index('$@', $sigil) >= 0 ? substr($field, 1) : $field;
if ($sigil eq '$') {
$self->{lc $new_field} =
eval "\$${class}::${new_field} || \$${base_prefix}${new_field}";
} elsif ($sigil eq '@') {
$self->{lc $new_field} = eval "[\@${class}::${new_field}]";
} else {
die "Woah - bad sigil: $sigil";
}
}
# Done after above since $NAME is in @SUBCMD_VARS;
$self->{name} = $name;
$self->{short_help} ||= $self->{help};
bless $self, $class;
$self->set_name_prefix($class);
$self;
}
# Convenience short-hand for @proc.confirm
sub confirm($$;$) {
my ($self, $msg, $default) = @_;
return($self->{proc}->confirm($msg, $default));
}
# Set a Boolean-valued debugger setting.
sub run_set_bool($$;$)
{
my ($self, $args, $default) = @_;
$default = 1 if scalar @_ < 3;
my $onoff_arg = @$args < 4 ? 'on' : $args->[3];
my $key = $self->{subcmd_setting_key};
$self->{proc}{settings}{$key} = $self->{proc}->get_onoff($onoff_arg);
$self->run_show_bool();
}
# set an Integer-valued debugger setting.
sub run_set_int($$$;$$)
{
my ($self, $arg, $msg_on_error, $min_value, $max_value) = @_;
my $proc = $self->{proc};
if ($arg =~/^\s*$/) {
$proc->errmsg('You need to supply a number.');
return undef;
}
my $val = $proc->get_an_int($arg,
{max_value => $max_value,
min_value => $min_value,
msg_on_error => $msg_on_error
});
if (defined ($val)) {
my $subcmd_setting_key = $self->{subcmd_setting_key};
$proc->{settings}{$subcmd_setting_key} = $val;
$self->run_show_int();
}
}
# Generic subcommand showing a boolean-valued debugger setting.
sub run_show_bool($;$)
{
my ($self, $what) = @_;
my $proc = $self->{proc};
my $key = $self->{subcmd_setting_key};
my $val = $self->show_onoff($proc->{settings}{$key});
$what = $self->{cmd_str} unless $what;
$proc->msg(sprintf "%s is %s.", $what, $val);
}
# Generic subcommand integer value display
sub run_show_int($;$)
{
my ($self, $what) = @_;
my $proc = $self->{proc};
my $subcmd_setting_key = $self->{subcmd_setting_key};
my $val = $proc->{settings}{$subcmd_setting_key};
$what = $self->{cmd_str} unless ($what);
$proc->msg(sprintf "%s is %d.", $what, $val);
}
# Generic subcommand value display. Pass in a hash which may
# which optionally contain:
#
# :name - the String name of key in settings to use. If :value
# (described below) is set, then setting :name does
# nothing.
#
# :what - the String name of what we are showing. If none is
# given, then we use the part of the SHORT_HELP string.
#
# :value - a String value associated with "what" above. If none
# is given, then we pick up the value from settings.
#
sub run_show_val($;$)
{
my ($self, $opts) = @_;
$opts ||= {};
my $what = exists $opts->{what} ? $opts->{what} : $self->{string_in_show};
my $name = exists $opts->{name} ? $opts->{name} : $self->{name};
my $val = exists $opts->{value} ? $opts->{value} : $self->{settings}{$name};
my $msg = sprintf("%s is %s.", $what, $val);
$self->msg($msg);
}
# sub save_command_from_settings
# ["${subcmd_prefix_string} ${settings[subcmd_setting_key]}"]
# }
sub subcmd_prefix_string($)
{
my $self = shift;
join(' ', $self->{prefix});
}
sub subcmd_setting_key($)
{
my $self = shift;
return $self->{subcmd_setting_key} if $self->{subcmd_setting_key};
my @prefix = @{$self->{prefix}}; shift @prefix;
$self->{subcmd_setting_key} = join('', @prefix);
}
# Return 'on' for true and 'off' for false, and ?? for anything else.
sub show_onoff($$)
{
my ($self, $bool) = @_;
if (!defined($bool)) {
return 'unset';
} elsif ($bool) {
return 'on';
} else {
return 'off'
}
}
sub set_name_prefix($$)
{
my ($self, $class) = @_;
my @prefix = split(/::/, $class);
splice(@prefix, 0, 4); # Remove Devel::Trepan::CmdProcessor::Command
@prefix = map {lc $_} @prefix;
$self->{prefix} = \@prefix;
$self->{cmd_str} = join(' ', @prefix);
$self->{subcmd_setting_key} = "$prefix[1]$prefix[2]";
}
sub string_in_show($)
{
my ($self, $bool) = @_;
my $skip_len = length('Show ');
ucfirst substr($self->{short_help}, $skip_len);
}
sub summary_help($$)
{
my ($self, $subcmd_name) = @_;
my $msg = sprintf("%-12s: %s", $subcmd_name, $self->{short_help});
$self->msg_nocr($msg);
}
package Devel::Trepan::CmdProcessor::Command::SetBoolSubsubcmd;
use vars qw(@ISA);
@ISA = qw(Exporter Devel::Trepan::CmdProcessor::Command::Subsubcmd);
# completion %w(on off)
sub complete($$)
{
my ($self, $prefix) = @_;
Devel::Trepan::Complete::complete_token(['on', 'off'],
$prefix);
}
sub run($$) {
my ($self, $args) = @_;
$self->run_set_bool($args);
}
sub save_command($) {
my ($self) = @_;
my %settings = $self->{settings};
my $val = $settings{$self->subcmd_setting_key()} ? 'on' : 'off';
[$self->subcmd_prefix_string . " ${val}"];
}
package Devel::Trepan::CmdProcessor::Command::ShowBoolSubsubcmd;
use vars qw(@ISA);
@ISA = qw(Exporter Devel::Trepan::CmdProcessor::Command::Subsubcmd);
sub run($)
{
my ($self, $args) = @_;
$self->run_show_bool($self->string_in_show());
}
package Devel::Trepan::CmdProcessor::Command::ShowIntSubsubcmd;
use vars qw(@ISA);
@ISA = qw(Exporter Devel::Trepan::CmdProcessor::Command::Subsubcmd);
sub run($) {
my ($self, $args) = @_;
my $doc = $self->{short_help};
my $len = length($doc) - 5;
$doc = ucfirst substr($doc, 5, $len);
$self->run_show_int($doc);
}
unless (caller) {
# Demo it.
# require Devel::Trepan::CmdProcessor::Mock;
# my $proc = Devel::Trepan::CmdProcessor::Mock::setup();
# my %cmds = %{$proc->{commands}};
# print join(', ', keys %cmds), "\n";
# my $subcmd =
# Devel::Trepan::CmdProcessor::Command::Subcmd->new($cmds{'quit'});
# print join(', ', keys %{$subcmd->{settings}}), "\n";
# print $subcmd->show_onoff($subcmd->{settings}{autoeval}), "\n";
# $subcmd->run_set_int($proc, 'Just a test');
}
1;