Skip to content
Browse files

Use Devel::Callsite if available to figure out current OP location.

More help text podification. Trim newline in help showing help text. Untabify
more source files.
  • Loading branch information...
1 parent 2eb40af commit db2e1bcdc2a6bcf6d0a3a5b9ebcc0987c3b0c3a8 Rocky Bernstein committed Sep 9, 2012
View
7 Build.PL
@@ -56,11 +56,12 @@ my $builder = Module::Build->new(
'Test::More' => '0.81',
},
recommends => {
- 'Term::ReadLine::Perl' => 0,
- 'Term::ReadKey' => 0,
- 'Eval::WithLexicals' => 0,
'Data::Printer' => 0,
+ 'Devel::Callsite' => 0,
+ 'Eval::WithLexicals' => 0,
'Pod::Text::Color' => 0,
+ 'Term::ReadKey' => 0,
+ 'Term::ReadLine::Perl' => 0,
},
requires => {
View
2 Changes
@@ -7,6 +7,8 @@ Revision history for Devel-Trepan
This means terminal width settings can be adjusted (with set max width)
and terminal highlighting is handled. We are also closer to automating
a Devel::Trepan manual
+- If Devel::Callsite is installed we can show a more exact location of
+ where we are.
- Continuation of a command now allowed if you end a line with '\'
This should make writing macros for example easier and may help
in eval
View
6 lib/Devel/Trepan/CmdProcessor/Command/Help.pm
@@ -38,7 +38,7 @@ Without argument, print the list of available debugger commands.
When an argument is given, it is first checked to see if it is command
name. C<help backtrace> gives help on the C<backtrace> debugger command.
-If the environment variable I<\$PAGER> is defined, the file is
+If the environment variable I<$PAGER> is defined, the file is
piped through that command. You will notice this only for long help
output.
@@ -264,13 +264,13 @@ sub run($$)
}
my $cmd_obj = $proc->{commands}{$real_name};
my $help_text =
- $cmd_obj->can("help") ? $cmd_obj->help($args)
+ $cmd_obj->can('help') ? $cmd_obj->help($args)
: $cmd_obj->{help};
if ($help_text) {
$help_text = help2podstring($help_text,
$proc->{settings}{highlight},
$proc->{settings}{maxwidth});
- chomp $help_text;
+ chomp $help_text; chomp $help_text;
$self->msg($help_text) ;
if (scalar @{$cmd_obj->{aliases}} && scalar @$args == 2) {
my $aliases_str = join(', ', @{$cmd_obj->{aliases}});
View
22 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Program.pm
@@ -31,26 +31,26 @@ sub run($$)
my $line = $frame->{line};
my $m;
if (defined($DB::ini_dollar0) && $DB::ini_dollar0) {
- $m = sprintf "Program: %s.", $DB::ini_dollar0;
- $proc->msg($m);
+ $m = sprintf "Program: %s.", $DB::ini_dollar0;
+ $proc->msg($m);
}
$m = sprintf "Program stop event: %s.", $proc->{event};
$proc->msg($m);
- if (defined($DB::dbline[$line]) && 0 != $DB::dbline[$line]) {
- $m = sprintf "COP address: 0x%x.", $DB::dbline[$line];
- $proc->msg($m);
+ if (defined($DB::OP_addr)) {
+ $m = sprintf "OP address: 0x%x.", $DB::OP_addr;
+ $proc->msg($m);
}
if ('return' eq $proc->{event}) {
- $proc->{commands}{info}->run(['info', 'return']);
+ $proc->{commands}{info}->run(['info', 'return']);
} elsif ('raise' eq $proc->{event}) {
- # $self->msg($proc->core.hook_arg) if $proc->core.hook_arg;
+ # $self->msg($proc->core.hook_arg) if $proc->core.hook_arg;
}
if ($DB::brkpt) {
- my $m = sprintf('It is stopped at %sbreakpoint %d.',
- $DB::brkpt->type eq 'tbrkpt' ? 'temporary ' : '',
- $DB::brkpt->id);
- $proc->msg($m);
+ my $m = sprintf('It is stopped at %sbreakpoint %d.',
+ $DB::brkpt->type eq 'tbrkpt' ? 'temporary ' : '',
+ $DB::brkpt->id);
+ $proc->msg($m);
}
}
View
11 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Return.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rockb@cpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rockb@cpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
@@ -13,7 +13,14 @@ use vars qw(@ISA @SUBCMD_VARS);
# Values inherited from parent
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
-our $HELP = "Show the value about to be returned";
+our $SHORT_HELP = "Show the value about to be returned";
+our $HELP = <<'HELP';
+=pod
+
+Show the value about to be returned.
+=cut
+HELP
+
our $MIN_ABBREV = length('ret');
use constant NEED_STACK => 1;
View
26 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Signals.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rockbcpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rockbcpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
@@ -15,23 +15,27 @@ use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
use constant MAX_ARGS => undef; # Need at most this many - undef -> unlimited.
our $CMD = "info signals";
-our $HELP = <<"EOH";
-${CMD}
-${CMD} SIG1 [SIG2 ..]
+our $HELP = <<'HELP';
+=pod
+
+info signals
+
+info signals I<signal1> [I<signal2> ..]
In the first form a list of the existing signals and actions are shown.
In the second form, list just the given signals and their definitions
are shown.
-Signals can be either their signal name or number. For a signal name
-the case is not significant and can be prefaced by SIG or not. For a
-signal number, you can preface the number with + or -, but both are
-ignored. A negative number is the same as its corresponding positive
-number.
+Signals can be either their signal name or number. The case is not
+significant when giving a signal name. A signal name C<SIG> or
+not. For a signal number, you can preface the number with C<+> or
+C<->, but both are ignored. A negative number is the same as its
+corresponding positive number.
-See "handle" for descriptions of the settable fields shown
-EOH
+See C<handle> for descriptions of the settable fields shown.
+=cut
+HELP
our $MIN_ABBREV = length('sig');
our $SHORT_HELP = 'What debugger does when program gets various signals';
View
9 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Variables.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rocky@cpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rocky@cpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
use strict;
@@ -12,8 +12,11 @@ use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
use Devel::Trepan::CmdProcessor::Command::Subcmd::SubsubMgr;
use vars qw(@ISA @SUBCMD_VARS);
our $MIN_ABBREV = length('va');
-our $HELP = <<"HELP";
-Information on 'our' or 'my' variables.
+our $HELP = <<'HELP';
+=pod
+
+Information on C<our> or C<my> variables.
+=cut
HELP
our $SHORT_HELP = "List 'our' or 'my' variables.";
View
26 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Variables_Subcmd/Lexicals.pm
@@ -16,19 +16,25 @@ use constant MAX_ARGS => undef;
use constant NEED_STACK => 1;
our $MIN_ABBREV = length('l');
-our $HELP = <<"HELP";
-${CMD}
-${CMD} -v
-${CMD} VAR1 [VAR2...]
+our $HELP = <<'HELP';
+=pod
-Lists 'my' or 'lexical' variables at the current frame. Use the frame changing
-commands like 'up', 'down' or 'frame' set the current frame.
+info variables lexicals
-In the first form, give a list of 'my' or 'our' variable names only.
-In the second form, list variable names and values
-In the third form, list variable names and values of VAR1, etc.
+info variables lexicals -v
-See also 'set variable', and frame changing commands
+info variables lexicals I<var1> [I<var2>...]
+
+Lists C<my> or C<lexical> variables at the current frame. Use the
+frame changing commands like C<up>, C<down> or C<frame> set the
+current frame.
+
+In the first form, give a list of C<my> or C<our> variable names only.
+In the second form, list variable names and values In the third form,
+list variable names and values of I<var1>, etc.
+
+See also C<set variable>, and frame changing commands
+=cut
HELP
our $SHORT_HELP = "Information about 'my' or 'our' variables.";
View
25 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Variables_Subcmd/My.pm
@@ -21,19 +21,24 @@ use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
our $CMD = "info variables my";
our @CMD = split(/ /, $CMD);
our $MIN_ABBREV = length('m');
-our $HELP = <<"HELP";
-${CMD}
-${CMD} -v
-${CMD} VAR1 [VAR2...]
+our $HELP = <<'HELP';
+=pod
-Lists 'my' variables at the current frame. Use the frame changing
-commands like 'up', 'down' or 'frame' set the current frame.
+info variables my
-In the first form, give a list of 'my' variable names only.
-In the second form, list variable names and values
-In the third form, list variable names and values of VAR1, etc.
+info variables my -v
-See also 'set variable', and frame changing commands
+info variables my I<var1> [I<var2>...]
+
+Lists C<my> variables at the current frame. Use the frame changing
+commands like C<up>, C<down> or C<frame> set the current frame.
+
+In the first form, give a list of C<my> variable names only. In the
+second form, list variable names and values In the third form, list
+variable names and values of VAR1, etc.
+
+See also C<set variable>, and frame changing commands.
+=cut
HELP
our $SHORT_HELP = "Information about 'my' variables.";
View
9 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Variables_Subcmd/Our.pm
@@ -14,10 +14,13 @@ my @CMD = split(/ /, $CMD);
use constant MAX_ARGS => undef;
use constant NEED_STACK => 1;
our $MIN_ABBREV = length('o');
-our $HELP = <<"HELP";
-${CMD}
+our $HELP = <<'HELP';
+=pod
-List 'our' variables at the current stack level.
+info variables our
+
+List C<our> variables at the current stack level.
+=cut
HELP
our $SHORT_HELP = "Information about 'our' variables.";
View
13 lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Watch.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rockbcpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rockbcpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
@@ -12,14 +12,17 @@ use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
use constant MAX_ARGS => undef; # Need at most this many - undef -> unlimited.
-our $CMD = "info watch";
-our $HELP = <<"EOH";
-${CMD} [WATCHPOINT1 WATCHPOINT2 ...]
+our $CMD = 'info watch';
+our $HELP = <<'HELP';
+=pod
+
+info watch [I<watchpoint1> I<watchpoint2> ...]
List watch information. If watchpoints are specified, only information
about them is shown. If no watchpoints are specified, show information
about all watchpoints.
-EOH
+=cut
+HELP
our $MIN_ABBREV = length('wa');
our $SHORT_HELP = "Show watchpoint information";
View
24 lib/Devel/Trepan/CmdProcessor/Command/Kill.pm
@@ -26,30 +26,30 @@ use strict;
use vars @CMD_VARS; # Value inherited from parent
our $NAME = set_name();
-our $HELP = <<"HELP";
+our $HELP = <<'HELP';
=pod
-B<$NAME> [I<signal-number>|I<signal-name>]
+kill [I<signal-number>|I<signal-name>]
Kill execution of program being debugged.
-Equivalent of C<kill('KILL', \$\$)>. This is an unmaskable
-signal\. Use this when all else fails, e.g. in thread code, use this.
+Equivalent of C<kill('KILL', $$)>. This is an unmaskable
+signal. Use this when all else fails, e.g. in thread code, use this.
If you are in interactive mode, you are prompted to confirm killing.
However when this command is aliased from a command ending in C<!>, no
questions are asked.
=head2 Examples:
- $NAME
- $NAME KILL # same as above
- $NAME kill # same as above
- $NAME -9 # same as above
- $NAME 9 # same as above
- $NAME! 9 # same as above, but no questions asked
- $NAME unconditionally # same as above
- $NAME TERM # Send "TERM" signal
+ kill
+ kill KILL # same as above
+ kill kill # same as above
+ kill -9 # same as above
+ kill 9 # same as above
+ kill! 9 # same as above, but no questions asked
+ kill unconditionally # same as above
+ kill TERM # Send "TERM" signal
See also C<set confirm> and C<quit>.
=cut
View
10 lib/Devel/Trepan/CmdProcessor/Command/Set_Subcmd/Abbrev.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011, 2012 Rocky Bernstein <rocky@cpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rocky@cpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
@@ -11,7 +11,13 @@ use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
# Values inherited from parent
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
-our $HELP = "Set to allow unique abbreviations of commands";
+our $SHORT_HELP = 'Set to allow unique abbreviations of commands';
+our $HELP = <<'HELP';
+=pod
+
+Set to allow unique abbreviations of commands.
+=cut
+HELP
our $MIN_ABBREV = length('ab');
if (__FILE__ eq $0) {
View
30 lib/Devel/Trepan/CmdProcessor/Command/Set_Subcmd/Auto.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rocky@cpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rocky@cpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
use strict;
@@ -11,11 +11,14 @@ use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
use Devel::Trepan::CmdProcessor::Command::Subcmd::SubsubMgr;
use vars qw(@ISA @SUBCMD_VARS);
our $MIN_ABBREV = length('au');
-our $HELP = <<"HELP";
-Set controls for things with some sort of \"automatic\" default behavior
+our $HELP = <<'HELP';
+=pod
-See 'help set auto *' for a list of subcommands or 'help set auto <name>'
+Set controls for things with some sort of automatic default behavior.
+
+See C<help set auto *> for a list of subcommands or C<help set auto I<name>>
for help on a particular trace subcommand.
+=cut
HELP
our $SHORT_HELP =
"Set controls for some \"automatic\" default behaviors";
@@ -31,11 +34,20 @@ our $SHORT_HELP =
unless (caller) {
# Demo it.
- require Devel::Trepan;
- # require_relative '../../mock'
- # dbgr, parent_cmd = MockDebugger::setup('set', false);
- # $cmd = __PACKAGE__->new(dbgr.core.processor,
- # parent_cmd);
+ require Devel::Trepan::CmdProcessor;
+ my $proc = Devel::Trepan::CmdProcessor->new;
+ my $parent = Devel::Trepan::CmdProcessor::Command::Set->new($proc, 'set');
+ # use Enbugger 'trepan'; Enbugger->stop;
+ my $cmd = __PACKAGE__->new($parent, 'auto');
+ print $cmd->{help}, "\n";
+ # print "min args: ", eval('$' . __PACKAGE__ . "::MIN_ARGS"), "\n";
+ # for my $arg ('e', 'lis', 'foo') {
+ # my $aref = $cmd->complete_token_with_next($arg);
+ # print "$aref\n";
+ # printf("complete($arg) => %s\n",
+ # join(", ", @{$aref})) if $aref;
+ # }
+
# $cmd->run(($cmd->prefix ('string', '30'));
# for my $prefix qw(s lis foo) {
View
11 lib/Devel/Trepan/CmdProcessor/Command/Set_Subcmd/Basename.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rocky@cpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rocky@cpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
@@ -11,7 +11,14 @@ use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
# Values inherited from parent
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
-our $HELP = "Set to show only file basename in showing file names";
+our $SHORT_HELP = 'Set to show only file basename in showing file names';
+our $HELP = <<'HELP';
+=pod
+
+Set to show only file basename in showing file names
+=cut
+HELP
+
our $MIN_ABBREV = length('ba');
if (__FILE__ eq $0) {
View
11 lib/Devel/Trepan/CmdProcessor/Command/Set_Subcmd/Return.pm
@@ -1,5 +1,5 @@
# -*- coding: utf-8 -*-
-# Copyright (C) 2011 Rocky Bernstein <rockb@cpan.org>
+# Copyright (C) 2011-2012 Rocky Bernstein <rocky@cpan.org>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';
@@ -13,7 +13,14 @@ use vars qw(@ISA @SUBCMD_VARS);
# Values inherited from parent
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
-our $HELP = "Set the value about to be returned";
+our $SHORT_HELP = "Set the value about to be returned";
+our $HELP = <<'HELP';
+=pod
+
+Set the value about to be returned.
+=cut
+HELP
+
use constant MIN_ARGS => 1;
use constant MAX_ARGS => 1;
use constant NEED_STACK => 1;
View
172 lib/Devel/Trepan/CmdProcessor/Command/Subcmd/SubMgr.pm
@@ -38,27 +38,27 @@ sub new($$)
my @prefix = split('::', $class);
shift @prefix; shift @prefix; shift @prefix; shift @prefix;
my $self = {
- subcmds => {},
- name => $name,
- proc => $proc,
- prefix => \@prefix,
- cmd_str => join(' ', map {lc $_} @prefix)
+ subcmds => {},
+ name => $name,
+ proc => $proc,
+ prefix => \@prefix,
+ cmd_str => join(' ', map {lc $_} @prefix)
};
# Initialization
my $base_prefix="Devel::Trepan::CmdProcessor::Command::";
my $excluded_cmd_vars = {'$HELP' => 1, '$NAME'=>2};
for my $field (@CMD_VARS) {
- next if exists $excluded_cmd_vars->{$field} &&
- $excluded_cmd_vars->{$field} == 2;
- my $sigil = substr($field, 0, 1);
- my $new_field = index('$@', $sigil) >= 0 ? substr($field, 1) : $field;
- if ($sigil eq '$') {
- my $lc_field = lc $new_field;
- $self->{$lc_field} = eval "\$${class}::${new_field}";
- next if exists $excluded_cmd_vars->{$field} ||
- exists $self->{$lc_field};
- $self->{$lc_field} = "\$${base_prefix}${new_field}";
- }
+ next if exists $excluded_cmd_vars->{$field} &&
+ $excluded_cmd_vars->{$field} == 2;
+ my $sigil = substr($field, 0, 1);
+ my $new_field = index('$@', $sigil) >= 0 ? substr($field, 1) : $field;
+ if ($sigil eq '$') {
+ my $lc_field = lc $new_field;
+ $self->{$lc_field} = eval "\$${class}::${new_field}";
+ next if exists $excluded_cmd_vars->{$field} ||
+ exists $self->{$lc_field};
+ $self->{$lc_field} = "\$${base_prefix}${new_field}";
+ }
}
my @ary = eval "${class}::ALIASES()";
$self->{aliases} = @ary ? [@ary] : [];
@@ -87,25 +87,25 @@ sub load_debugger_subcommands($$)
my $cmd_dir = dirname(__FILE__);
my $parent_name = ucfirst $self->{name};
my $subcmd_dir = File::Spec->catfile($cmd_dir, '..',
- $parent_name . '_Subcmd');
+ $parent_name . '_Subcmd');
if (-d $subcmd_dir) {
- my @files = glob(File::Spec->catfile($subcmd_dir, '*.pm'));
- for my $pm (@files) {
- my $basename = basename($pm, '.pm');
- my $item = sprintf("%s::%s", ucfirst($parent_name), ucfirst($basename));
- if (-d File::Spec->catfile(dirname($pm), $basename . '_Subcmd')) {
- push @{$self->{subcmd_names}}, $item;
- } else {
- push @{$self->{cmd_names}}, $item;
- push @{$self->{cmd_basenames}}, $basename;
- }
- if (eval "require '$pm'; 1") {
- $self->setup_subcommand($parent_name, $basename);
- } else {
- $self->errmsg("Trouble reading ${pm}:");
- $self->errmsg($@);
- }
- }
+ my @files = glob(File::Spec->catfile($subcmd_dir, '*.pm'));
+ for my $pm (@files) {
+ my $basename = basename($pm, '.pm');
+ my $item = sprintf("%s::%s", ucfirst($parent_name), ucfirst($basename));
+ if (-d File::Spec->catfile(dirname($pm), $basename . '_Subcmd')) {
+ push @{$self->{subcmd_names}}, $item;
+ } else {
+ push @{$self->{cmd_names}}, $item;
+ push @{$self->{cmd_basenames}}, $basename;
+ }
+ if (eval "require '$pm'; 1") {
+ $self->setup_subcommand($parent_name, $basename);
+ } else {
+ $self->errmsg("Trouble reading ${pm}:");
+ $self->errmsg($@);
+ }
+ }
}
}
@@ -115,14 +115,14 @@ sub setup_subcommand($$$$)
my $cmd_obj;
my $cmd_name = lc $name;
my $new_cmd = "\$cmd_obj=Devel::Trepan::CmdProcessor::Command::" .
- "${parent_name}::${name}->new(\$self, '$cmd_name'); 1";
+ "${parent_name}::${name}->new(\$self, '$cmd_name'); 1";
if (eval $new_cmd) {
- # Add to hash of commands, and list of subcmds
- $self->{subcmds}->{$cmd_name} = $cmd_obj;
- $self->add($cmd_obj, $cmd_name);
+ # Add to hash of commands, and list of subcmds
+ $self->{subcmds}->{$cmd_name} = $cmd_obj;
+ $self->add($cmd_obj, $cmd_name);
} else {
- $self->errmsg("Error instantiating ${parent_name}::$name");
- $self->errmsg($@);
+ $self->errmsg("Error instantiating ${parent_name}::$name");
+ $self->errmsg($@);
}
}
@@ -134,20 +134,20 @@ sub lookup($$;$)
$use_regexp = 0 if scalar @_ < 3;
my $compare;
if (!$self->{proc}{settings}{abbrev}) {
- $compare = sub($) { my $name = shift; $name eq $subcmd_prefix};
+ $compare = sub($) { my $name = shift; $name eq $subcmd_prefix};
} elsif ($use_regexp) {
- $compare = sub($) { my $name = shift; $name =~ /^${subcmd_prefix}/};
+ $compare = sub($) { my $name = shift; $name =~ /^${subcmd_prefix}/};
} else {
- $compare = sub($) {
- my $name = shift; 0 == index($name, $subcmd_prefix)
- };
+ $compare = sub($) {
+ my $name = shift; 0 == index($name, $subcmd_prefix)
+ };
}
my @candidates = ();
while (my ($subcmd_name, $subcmd) = each %{$self->{subcmds}}) {
if ($compare->($subcmd_name) &&
length($subcmd_prefix) >= $subcmd->{min_abbrev}) {
- push @candidates, $subcmd;
- }
+ push @candidates, $subcmd;
+ }
}
if (scalar @candidates == 1) {
return $candidates[0];
@@ -162,12 +162,12 @@ sub short_help($$$;$)
$label = 0 unless defined $label;
my $entry = $self->lookup($subcmd_name);
if ($entry) {
- my $prefix = '';
- $prefix = $entry->{name} if $label;
+ my $prefix = '';
+ $prefix = $entry->{name} if $label;
if (exist $entry->{short_help}) {
- $prefix .= ' -- ' if $prefix;
- $self->{proc}->msg($prefix . $entry->{short_help});
- }
+ $prefix .= ' -- ' if $prefix;
+ $self->{proc}->msg($prefix . $entry->{short_help});
+ }
} else {
$self->{proc}->undefined_subcmd("help", $subcmd_name);
}
@@ -193,8 +193,8 @@ sub help($$)
{
my ($self, $args) = @_;
if (scalar @$args <= 2) {
- # "help cmd". Give the general help for the command part.
- return $self->{help};
+ # "help cmd". Give the general help for the command part.
+ return $self->{help};
}
my $subcmd_name = $args->[2];
@@ -203,37 +203,37 @@ sub help($$)
my @subcmds = $self->list();
if ('*' eq $subcmd_name) {
- @help_text = (sprintf("List of subcommands for command '%s':",
- $self->{name}));
- my $subcmds = $self->columnize_commands(\@subcmds); chomp $subcmds;
- push @help_text, $subcmds;
- return join("\n", @help_text);
+ @help_text = (sprintf("List of subcommands for command '%s':",
+ $self->{name}));
+ my $subcmds = $self->columnize_commands(\@subcmds); chomp $subcmds;
+ push @help_text, $subcmds;
+ return join("\n", @help_text);
}
# "help cmd subcmd". Give help specific for that subcommand.
my $cmd = $self->lookup($subcmd_name, 0);
if (defined $cmd) {
- if ($cmd->can("help")) {
- return $cmd->help($args);
- } else {
- return $cmd->{help};
- }
+ if ($cmd->can("help")) {
+ return $cmd->help($args);
+ } else {
+ return $cmd->{help};
+ }
} else {
- my $proc = $self->{proc};
- my @matches = sort(grep /^#{subcmd_name}/, @subcmds);
- my $name = $self->{name};
- if (0 == scalar @matches) {
- $proc->errmsg("No ${name} subcommands found matching /^#{$subcmd_name}/. Try \"help\" $name.");
- return undef;
- } elsif (1 == scalar @matches) {
- $args->[-1] = $matches[0];
- $self->help($args);
- } else {
- @help_text = ("Subcommands of \"$name\" matching /^#{$subcmd_name}/:");
- my @sort_matches = sort @matches;
- push @help_text, $self->{cmd}->columnize_commands(\@sort_matches);
- return @help_text;
- }
+ my $proc = $self->{proc};
+ my @matches = sort(grep /^#{subcmd_name}/, @subcmds);
+ my $name = $self->{name};
+ if (0 == scalar @matches) {
+ $proc->errmsg("No ${name} subcommands found matching /^#{$subcmd_name}/. Try \"help\" $name.");
+ return undef;
+ } elsif (1 == scalar @matches) {
+ $args->[-1] = $matches[0];
+ $self->help($args);
+ } else {
+ @help_text = ("Subcommands of \"$name\" matching /^#{$subcmd_name}/:");
+ my @sort_matches = sort @matches;
+ push @help_text, $self->{cmd}->columnize_commands(\@sort_matches);
+ return @help_text;
+ }
}
}
@@ -262,21 +262,21 @@ sub run($$)
$self->{last_args} = $args;
my $args_len = scalar @$args;
if ($args_len < 2 || $args_len == 2 && $args->[-1] eq '*') {
- $self->{proc}->summary_list($self->{name}, $self->{subcmds});
- return 0;
+ $self->{proc}->summary_list($self->{name}, $self->{subcmds});
+ return 0;
}
my $subcmd_prefix = $args->[1];
# We were given: cmd subcmd ...
# Run that.
my $subcmd = $self->lookup($subcmd_prefix);
if ($subcmd) {
- if ($self->{proc}->ok_for_running($subcmd, $subcmd->{cmd_str},
- $args_len-2)) {
- $subcmd->run($args);
- }
+ if ($self->{proc}->ok_for_running($subcmd, $subcmd->{cmd_str},
+ $args_len-2)) {
+ $subcmd->run($args);
+ }
} else {
- $self->{proc}->undefined_subcmd($self->{name}, $subcmd_prefix);
+ $self->{proc}->undefined_subcmd($self->{name}, $subcmd_prefix);
}
}
View
190 lib/Devel/Trepan/CmdProcessor/Command/Subcmd/SubsubMgr.pm
@@ -37,27 +37,27 @@ sub new($$$)
my @prefix = split('::', $class);
shift @prefix; shift @prefix; shift @prefix; shift @prefix;
my $self = {
- subcmds => {},
- name => $name,
- proc => $parent->{proc},
- parent => $parent,
- prefix => \@prefix,
- cmd_str => join(' ', map {lc $_} @prefix)
+ subcmds => {},
+ name => $name,
+ proc => $parent->{proc},
+ parent => $parent,
+ prefix => \@prefix,
+ cmd_str => join(' ', map {lc $_} @prefix)
};
# Initialization
my $parent_name = ucfirst $parent->{name};
my $base_prefix="Devel::Trepan::CmdProcessor::Command::$parent_name";
my $excluded_cmd_vars = {'$HELP' => 1,
- '$NAME'=>2};
+ '$NAME'=>2};
for my $field (@Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS) {
- next if exists $excluded_cmd_vars->{$field} &&
- $excluded_cmd_vars->{$field} == 2;
- my $sigil = substr($field, 0, 1);
- my $new_field = index('$@', $sigil) >= 0 ? substr($field, 1) : $field;
- if ($sigil eq '$') {
- my $lc_field = lc $new_field;
- $self->{$lc_field} = eval "\$${class}::${new_field}";
- }
+ next if exists $excluded_cmd_vars->{$field} &&
+ $excluded_cmd_vars->{$field} == 2;
+ my $sigil = substr($field, 0, 1);
+ my $new_field = index('$@', $sigil) >= 0 ? substr($field, 1) : $field;
+ if ($sigil eq '$') {
+ my $lc_field = lc $new_field;
+ $self->{$lc_field} = eval "\$${class}::${new_field}";
+ }
}
my @ary = eval "${class}::ALIASES()";
$self->{aliases} = @ary ? [@ary] : [];
@@ -86,33 +86,33 @@ sub load_debugger_subsubcommands($$)
my $parent_name = ucfirst $self->{name};
my $cmd_name = $self->{prefix}[0];
my @path = ($cmd_dir, '..', "${cmd_name}_Subcmd",
- $parent_name . '_Subcmd');
+ $parent_name . '_Subcmd');
my $subcmd_dir = File::Spec->catfile(@path);
if (-d $subcmd_dir) {
- my @files = glob(File::Spec->catfile($subcmd_dir, '*.pm'));
- for my $pm (@files) {
- my $basename = basename($pm, '.pm');
- my $item = sprintf("%s::%s::%s",
- ucfirst($cmd_name),
- ucfirst($parent_name),
- ucfirst($basename));
- if (-d File::Spec->catfile(dirname($pm), $basename . '_Subcmd')) {
- push @{$self->{subcmd_names}}, $item;
- } else {
- push @{$self->{cmd_names}}, $item;
- push @{$self->{cmd_basenames}}, $basename;
- }
- my $rc = eval "require '$pm' || 1";
- if ($rc eq 'Skip me!') {
- ;
- } elsif ($rc) {
- $self->setup_subsubcommand($parent, $item, $basename);
- } else {
- my $proc = $parent->{proc};
- $proc->errmsg("Trouble reading ${pm}:");
- $proc->errmsg($@);
- }
- }
+ my @files = glob(File::Spec->catfile($subcmd_dir, '*.pm'));
+ for my $pm (@files) {
+ my $basename = basename($pm, '.pm');
+ my $item = sprintf("%s::%s::%s",
+ ucfirst($cmd_name),
+ ucfirst($parent_name),
+ ucfirst($basename));
+ if (-d File::Spec->catfile(dirname($pm), $basename . '_Subcmd')) {
+ push @{$self->{subcmd_names}}, $item;
+ } else {
+ push @{$self->{cmd_names}}, $item;
+ push @{$self->{cmd_basenames}}, $basename;
+ }
+ my $rc = eval "require '$pm' || 1";
+ if ($rc eq 'Skip me!') {
+ ;
+ } elsif ($rc) {
+ $self->setup_subsubcommand($parent, $item, $basename);
+ } else {
+ my $proc = $parent->{proc};
+ $proc->errmsg("Trouble reading ${pm}:");
+ $proc->errmsg($@);
+ }
+ }
}
}
@@ -123,15 +123,15 @@ sub setup_subsubcommand($$$$)
my $cmd_obj;
my $cmd_name = lc $name;
my $new_cmd = "\$cmd_obj=Devel::Trepan::CmdProcessor::Command::" .
- "${cmd_prefix}->new(\$self, '$cmd_name'); 1";
+ "${cmd_prefix}->new(\$self, '$cmd_name'); 1";
if (eval $new_cmd) {
- # Add to hash of commands, and list of subcmds
- $self->{subcmds}{$cmd_name} = $cmd_obj;
- $self->add($cmd_obj, $cmd_name);
+ # Add to hash of commands, and list of subcmds
+ $self->{subcmds}{$cmd_name} = $cmd_obj;
+ $self->add($cmd_obj, $cmd_name);
} else {
- my $proc = $parent->{proc};
- $proc->errmsg("Error instantiating ${cmd_prefix}");
- $proc->errmsg($@);
+ my $proc = $parent->{proc};
+ $proc->errmsg("Error instantiating ${cmd_prefix}");
+ $proc->errmsg($@);
}
}
@@ -143,19 +143,19 @@ sub lookup($$;$)
$use_regexp = 0 if scalar @_ < 3;
my $compare;
if (!$self->{proc}{settings}{abbrev}) {
- $compare = sub($) { my $name = shift; $name eq $subcmd_prefix};
+ $compare = sub($) { my $name = shift; $name eq $subcmd_prefix};
} elsif ($use_regexp) {
- $compare = sub($) { my $name = shift; $name =~ /^${subcmd_prefix}/};
+ $compare = sub($) { my $name = shift; $name =~ /^${subcmd_prefix}/};
} else {
- $compare = sub($) {
- my $name = shift; 0 == index($name, $subcmd_prefix)
- };
+ $compare = sub($) {
+ my $name = shift; 0 == index($name, $subcmd_prefix)
+ };
}
my @candidates = ();
while (my ($subcmd_name, $subcmd) = each %{$self->{subcmds}}) {
if ($compare->($subcmd_name)) {
- push @candidates, $subcmd;
- }
+ push @candidates, $subcmd;
+ }
}
if (scalar @candidates == 1) {
@@ -171,12 +171,12 @@ sub short_help($$$;$)
$label = 0 unless defined $label;
my $entry = $self->lookup($subcmd_name);
if ($entry) {
- my $prefix = '';
- $prefix = $entry->{name} if $label;
+ my $prefix = '';
+ $prefix = $entry->{name} if $label;
if (exist $entry->{short_help}) {
- $prefix .= ' -- ' if $prefix;
- $self->{proc}->msg($prefix . $entry->{short_help});
- }
+ $prefix .= ' -- ' if $prefix;
+ $self->{proc}->msg($prefix . $entry->{short_help});
+ }
} else {
$self->{proc}->undefined_subcmd($self->{cmd_str}, $subcmd_name);
}
@@ -205,8 +205,8 @@ sub help($$)
{
my ($self, $args) = @_;
if (scalar @$args <= 3) {
- # "help cmd subcmd". Give the general help for the command part.
- return $self->{help};
+ # "help cmd subcmd". Give the general help for the command part.
+ return $self->{help};
}
my $subcmd_name = $args->[3];
@@ -215,39 +215,39 @@ sub help($$)
my @subcmds = $self->list();
if ('*' eq $subcmd_name) {
- @help_text = (sprintf("List of subcommands for command '%s':",
- $self->{cmd_str}));
+ @help_text = (sprintf("List of subcommands for command '%s':",
+ $self->{cmd_str}));
- my $subcmds = $self->{parent}->columnize_commands(\@subcmds);
- chomp $subcmds;
- push @help_text, $subcmds;
- return join("\n", @help_text);
+ my $subcmds = $self->{parent}->columnize_commands(\@subcmds);
+ chomp $subcmds;
+ push @help_text, $subcmds;
+ return join("\n", @help_text);
}
# "help cmd subcmd". Give help specific for that subcommand.
my $cmd = $self->lookup($subcmd_name, 0);
if (defined $cmd) {
- if ($cmd->can("help")) {
- return $cmd->help($args);
- } else {
- return $cmd->{help};
- }
+ if ($cmd->can("help")) {
+ return $cmd->help($args);
+ } else {
+ return $cmd->{help};
+ }
} else {
- my $proc = $self->{proc};
- my @matches = sort(grep /^#{subcmd_name}/, @subcmds);
- my $name = $self->{cmd_str};
- if (0 == scalar @matches) {
- $proc->errmsg("No ${name} subcommands found matching /^#{$subcmd_name}/. Try \"help\" $name.");
- return undef;
- } elsif (1 == scalar @matches) {
- $args->[-1] = $matches[0];
- $self->help($args);
- } else {
- @help_text = ("Subcommands of \"$name\" matching /^#{$subcmd_name}/:");
- my @sort_matches = sort @matches;
- push @help_text, $self->{parent}{cmd}->columnize_commands(\@sort_matches);
- return @help_text;
- }
+ my $proc = $self->{proc};
+ my @matches = sort(grep /^#{subcmd_name}/, @subcmds);
+ my $name = $self->{cmd_str};
+ if (0 == scalar @matches) {
+ $proc->errmsg("No ${name} subcommands found matching /^#{$subcmd_name}/. Try \"help\" $name.");
+ return undef;
+ } elsif (1 == scalar @matches) {
+ $args->[-1] = $matches[0];
+ $self->help($args);
+ } else {
+ @help_text = ("Subcommands of \"$name\" matching /^#{$subcmd_name}/:");
+ my @sort_matches = sort @matches;
+ push @help_text, $self->{parent}{cmd}->columnize_commands(\@sort_matches);
+ return @help_text;
+ }
}
}
@@ -268,7 +268,7 @@ sub complete_token_with_next($)
my ($self, $prefix) = @_;
my $subcmds = $self->{subcmds};
return Devel::Trepan::Complete::complete_token_with_next($subcmds,
- $prefix);
+ $prefix);
}
sub run($$)
@@ -278,21 +278,21 @@ sub run($$)
# require Enbugger; Enbugger->stop;
my $args_len = scalar @$args;
if ($args_len < 3 || $args_len == 3 && $args->[-1] eq '*') {
- $self->{proc}->summary_list($self->{cmd_str}, $self->{subcmds});
- return 0;
+ $self->{proc}->summary_list($self->{cmd_str}, $self->{subcmds});
+ return 0;
}
my $subcmd_prefix = $args->[2];
# We were given: cmd subcmd subcmd ...
# Run that.
my $subcmd = $self->lookup($subcmd_prefix);
if ($subcmd) {
- if ($self->{proc}->ok_for_running($subcmd, $subcmd->{cmd_str},
- $args_len-3)) {
- $subcmd->run($args);
- }
+ if ($self->{proc}->ok_for_running($subcmd, $subcmd->{cmd_str},
+ $args_len-3)) {
+ $subcmd->run($args);
+ }
} else {
- $self->{proc}->undefined_subcmd($self->{name}, $subcmd_prefix);
+ $self->{proc}->undefined_subcmd($self->{name}, $subcmd_prefix);
}
}
View
16 lib/Devel/Trepan/DB.pm
@@ -6,11 +6,10 @@
use rlib '../..';
-=head1 C<Devel::Trepan::Terminated>
+=head1 C<DB>
-Contains the C<at_exit> routine that the debugger uses to issue the
-C<Debugged program terminated ...> message after the program completes. See
-the C<END> block documentation for more details.
+Devel::Trepan customized DB package. Down the line this should be split off
+and merged with DB that perl5db.pl and other use
=cut
@@ -32,7 +31,7 @@ use Devel::Trepan::DB::Sub;
use Devel::Trepan::Terminated;
# "private" globals
-my ($deep, @saved, @skippkg);
+my ($deep, @saved, @skippkg, $HAVE_DEVEL_CALLSITE);
my $ineval = {};
@@ -136,6 +135,9 @@ BEGIN {
# No extry/exit tracing.
$frame = 0;
+
+ $HAVE_DEVEL_CALLSITE = eval("use Devel::Callsite; 1") ? 1 : 0;
+
}
END {
@@ -173,8 +175,12 @@ sub DB {
$DB::wantarray, $DB::evaltext, $DB::is_require, $DB::hints, $DB::bitmask,
$DB::hinthash
) = @{$DB::caller};
+
local $filename_ini = $filename;
+ local $OP_addr = ($HAVE_DEVEL_CALLSITE)
+ ? Devel::Callsite::callsite() : undef;
+
return if @skippkg and grep { $_ eq $DB::package } @skippkg;
# Set package namespace for running eval's in the user context.
View
2 t/data/alias.right
@@ -18,7 +18,6 @@ New alias 'upper' for command string 'up' created.
most recent frame. If no count is given, move up 1.
See also "down" and "frame".
-
Aliases: upper
Alias for upper removed.
up [*count*]
@@ -27,6 +26,5 @@ Alias for upper removed.
most recent frame. If no count is given, move up 1.
See also "down" and "frame".
-
set auto eval is off.
*** Undefined command: "upper". Try "help".

0 comments on commit db2e1bc

Please sign in to comment.
Something went wrong with that request. Please try again.