Skip to content

Commit

Permalink
Allow for optional Bullwinkle processor. Add superclass Processor for…
Browse files Browse the repository at this point in the history 
… common CmdProcessor and BWProcessor code.
  • Loading branch information
Rocky Bernstein committed Dec 11, 2012
1 parent 8581e5b commit 0bc435e
Show file tree
Hide file tree
Showing 6 changed files with 283 additions and 195 deletions.
4 changes: 2 additions & 2 deletions lib/Devel/Trepan/CmdProcessor.pm
View file
Expand Up @@ -31,11 +31,11 @@ unless (@ISA) {
require Devel::Trepan::CmdProcessor::Msg;
require Devel::Trepan::CmdProcessor::Help;
require Devel::Trepan::CmdProcessor::Hook;
require Devel::Trepan::CmdProcessor::Frame;
require Devel::Trepan::CmdProcessor::Location;
require Devel::Trepan::CmdProcessor::Eval;
require Devel::Trepan::CmdProcessor::Running;
require Devel::Trepan::CmdProcessor::Validate;
require Devel::Trepan::Processor::Frame;
require Devel::Trepan::Processor::Running;
}
use strict;

Expand Down
128 changes: 0 additions & 128 deletions lib/Devel/Trepan/CmdProcessor/Frame.pm 100755 → 100644
View file
Expand Up @@ -8,31 +8,6 @@ use Devel::Trepan::Complete;
package Devel::Trepan::CmdProcessor;
use English qw( -no_match_vars );

sub adjust_frame($$$)
{
my ($self, $frame_num, $absolute_pos) = @_;
my $frame;
($frame, $frame_num) = $self->get_frame($frame_num, $absolute_pos);
if ($frame) {
$self->{frame} = $frame;
$self->{frame_index} = $frame_num;
unless ($self->{settings}{traceprint}) {
my $opts = {
basename => $self->{settings}{basename},
current_pos => $frame_num,
maxwidth => $self->{settings}{maxwidth},
};
$self->print_stack_trace_from_to($frame_num, $frame_num, $self->{frames}, $opts);
$self->print_location ;
}
$self->{list_line} = $self->line();
$self->{list_filename} = $self->filename();
$self->{frame};
} else {
undef
}
}

sub frame_complete($$;$)
{
my ($self, $prefix, $direction) = @_;
Expand All @@ -42,109 +17,6 @@ sub frame_complete($$;$)
Devel::Trepan::Complete::complete_token(\@ary, $prefix);
}

sub frame_low_high($;$)
{
my ($self, $direction) = @_;
$direction = 1 unless defined $direction;
my $stack_size = $self->{stack_size};
my ($low, $high) = (-$stack_size, $stack_size-1);
($low, $high) = ($high, $low) if ($direction < 0);
return ($low, $high);
}

sub frame_setup($$)
{
my ($self, $frame_aref) = @_;

if (defined $frame_aref) {
$self->{frames} = $frame_aref;
$self->{stack_size} = $#{$self->{frames}}+1;
} else {
### FIXME: look go over this code.
my $stack_size = $DB::stack_depth;
my $i=0;
my @frames = $self->{dbgr}->backtrace(0);
@frames = splice(@frames, 2) if $self->{dbgr}{caught_signal};

if ($self->{event} eq 'post-mortem') {
$stack_size = 0;
for my $frame (@frames) {
next unless defined($frame) && exists($frame->{file});
$stack_size ++;
}
} else {
while (my ($pkg, $file, $line, $fn) = caller($i++)) {
last if 'DB::DB' eq $fn or ('DB' eq $pkg && 'DB' eq $fn);
}
if ($stack_size <= 0) {
# Dynamic debugging didn't set $DB::stack_depth correctly.
my $j=$i;
while (caller($j++)) {
$stack_size++;
}
$stack_size++;
$DB::stack_depth = $j;
} else {
$stack_size -= ($i-3);
}
}
$self->{frames} = \@frames;
$self->{stack_size} = $stack_size;
}

$self->{frame_index} = 0;
$self->{hide_level} = 0;
$self->{frame} = $self->{frames}[0];
$self->{list_line} = $self->line();
$self->{list_filename} = $self->filename();
}

sub filename($)
{
my $self = shift;
DB::LineCache::map_file($self->{frame}{file});
}

sub funcname($)
{
my $self = shift;
$self->{frame}{fn};
}

sub get_frame($$$)
{
my ($self, $frame_num, $absolute_pos) = @_;
my $stack_size = $self->{stack_size};

if ($absolute_pos) {
$frame_num += $stack_size if $frame_num < 0;
} else {
$frame_num += $self->{frame_index};
}

if ($frame_num < 0) {
$self->errmsg('Adjusting would put us beyond the newest frame.');
return (undef, undef);
} elsif ($frame_num >= $stack_size) {
$self->errmsg('Adjusting would put us beyond the oldest frame.');
return (undef, undef);
}

my $frames = $self->{frames};
unless ($frames->[$frame_num]) {
my @new_frames = $self->{dbgr}->backtrace(0);
$self->{frames}[$frame_num] = $new_frames[$frame_num];
}
$self->{frame} = $frames->[$frame_num];
return ($self->{frame}, $frame_num);
}

sub line($)
{
my $self = shift;
$self->{frame}{line};
}

sub print_stack_entry()
{
my ($self, $frame, $i, $prefix, $opts) = @_;
Expand Down
135 changes: 73 additions & 62 deletions lib/Devel/Trepan/Core.pm
View file
Expand Up @@ -2,6 +2,7 @@
# Copyright (C) 2011, 2012 Rocky Bernstein <rocky@cpan.org>
use warnings;
# FIXME: Can't use strict;

use rlib '../..';
use Devel::Trepan::DB;
use Devel::Trepan::DB::LineCache; # for remap_e_string_to_file();
Expand All @@ -14,7 +15,13 @@ use Devel::Trepan::Interface::Server;
use Devel::Trepan::Util;

package Devel::Trepan::Core;
use vars qw(@ISA $dbgr);
use vars qw(@ISA $dbgr $HAVE_BULLWINKLE);

BEGIN {
$ENV{'PERL_RL'} ||= 'perl';
$HAVE_BULLWINKLE = eval("use Devel::Trepan::BWProcessor; 1") ? 1 : 0;
}

@ISA = qw(DB);

sub add_startup_files($$;$) {
Expand Down Expand Up @@ -115,72 +122,76 @@ sub awaken($;$) {

$SIG{__DIE__} = \&DB::catch if $opts->{post_mortem};

my %cmdproc_opts = ();
for my $field
(qw(basename cmddir highlight readline traceprint)) {
# print "field $field $opts->{$field}\n";
$cmdproc_opts{$field} = $opts->{$field};
}
my $cmdproc;

my $batch_filename = $opts->{testing};
$batch_filename = $opts->{batchfile} unless defined $batch_filename;
if (defined $batch_filename) {
my $result = Devel::Trepan::Util::invalid_filename($batch_filename);
if (defined $result) {
print STDERR "$result\n"
} else {
my $output = Devel::Trepan::IO::Output->new;
my $script_opts =
$opts->{testing} ? {abort_on_error => 0} : {};
my $script_intf =
Devel::Trepan::Interface::Script->new($batch_filename,
$output,
$script_opts);
$cmdproc = Devel::Trepan::CmdProcessor->new([$script_intf],
$self,
\%cmdproc_opts);
$self->{proc} = $cmdproc;
$main::TREPAN_CMDPROC = $self->{proc};
}
my $proc;
if ($opts->{bw} && $HAVE_BULLWINKLE) {
$proc = Devel::Trepan::BWProcessor->new(undef, $self);
} else {
my $intf = undef;
if (defined($dbgr) && exists($dbgr->{proc})) {
$intf = $dbgr->{proc}{interfaces};
$intf->[-1]{input}{term_readline} = $opts->{readline} if
exists($opts->{readline});
}
if ($opts->{server}) {
my $server_opts = {
host => $opts->{host},
port => $opts->{port},
logger => *STDOUT
};
$intf = [
Devel::Trepan::Interface::Server->new(undef, undef,
$server_opts)
];
}
$cmdproc = Devel::Trepan::CmdProcessor->new($intf, $self,
\%cmdproc_opts);
$self->{proc} = $cmdproc;
$main::TREPAN_CMDPROC = $self->{proc};
$opts = {} unless defined $opts;

for my $startup_file (@{$opts->{cmdfiles}}) {
add_startup_files($cmdproc, $startup_file);
}
if (!$opts->{nx} && exists $opts->{initfile}) {
add_startup_files($cmdproc, $opts->{initfile}, 1);
}
my %cmdproc_opts = ();
for my $field
(qw(basename cmddir highlight readline traceprint)) {
# print "field $field $opts->{$field}\n";
$cmdproc_opts{$field} = $opts->{$field};
}

my $batch_filename = $opts->{testing};
$batch_filename = $opts->{batchfile} unless defined $batch_filename;
if (defined $batch_filename) {
my $result = Devel::Trepan::Util::invalid_filename($batch_filename);
if (defined $result) {
print STDERR "$result\n"
} else {
my $output = Devel::Trepan::IO::Output->new;
my $script_opts =
$opts->{testing} ? {abort_on_error => 0} : {};
my $script_intf =
Devel::Trepan::Interface::Script->new($batch_filename,
$output,
$script_opts);
$proc = Devel::Trepan::CmdProcessor->new([$script_intf],
$self,
\%cmdproc_opts);
$self->{proc} = $proc;
$main::TREPAN_CMDPROC = $self->{proc};
}
} else {
my $intf = undef;
if (defined($dbgr) && exists($dbgr->{proc})) {
$intf = $dbgr->{proc}{interfaces};
$intf->[-1]{input}{term_readline} = $opts->{readline} if
exists($opts->{readline});
}
if ($opts->{server}) {
my $server_opts = {
host => $opts->{host},
port => $opts->{port},
logger => *STDOUT
};
$intf = [
Devel::Trepan::Interface::Server->new(undef, undef,
$server_opts)
];
}
$proc = Devel::Trepan::CmdProcessor->new($intf, $self,
\%cmdproc_opts);
$main::TREPAN_CMDPROC = $self->{proc};
$opts = {} unless defined $opts;

for my $startup_file (@{$opts->{cmdfiles}}) {
add_startup_files($proc, $startup_file);
}
if (!$opts->{nx} && exists $opts->{initfile}) {
add_startup_files($proc, $opts->{initfile}, 1);
}
}
$proc->{skip_count} = -1 if $opts->{traceprint};
}
$cmdproc->{skip_count} = -1 if $opts->{traceprint};
$self->{proc} = $proc;
$self->{sigmgr} =
Devel::Trepan::SigMgr->new(sub{ $DB::running = 0; $DB::single = 0;
$self->signal_handler(@_) },
sub {$cmdproc->msg(@_)},
sub {$cmdproc->errmsg(@_)},
sub {$cmdproc->section(@_)});
sub {$proc->msg(@_)},
sub {$proc->errmsg(@_)},
sub {$proc->section(@_)});
}

sub display_lists ($)
Expand Down
46 changes: 46 additions & 0 deletions lib/Devel/Trepan/Processor.pm
View file
@@ -0,0 +1,46 @@
# -*- coding: utf-8 -*-
# Copyright (C) 2012 Rocky Bernstein <rocky@cpan.org>

use rlib '../..';

# A debugger command processor. This includes the debugger commands
# and ties together the debugger core and I/O interface.
package Devel::Trepan::Processor;

use vars qw(@EXPORT @ISA);
@EXPORT = qw( adjust_frame running_initialize);
@ISA = qw( Exporter );

use English qw( -no_match_vars );
use Exporter;
use warnings; no warnings 'redefine';

eval "require Devel::Trepan::DB::Display";
use Devel::Trepan::Processor::Frame;
use Devel::Trepan::Processor::Running;
use strict;

# attr_reader :settings
sub new($$;$) {
my ($class, $interfaces, $settings) = @_;
$settings ||= {};
my $self = {
class => $class,
interfaces => $interfaces,
settings => $settings,
};
bless ($self, $class);
return $self;
}

unless (caller) {
require Devel::Trepan::Interface::User;
my $intf = Devel::Trepan::Interface::User->new;
my $proc = __PACKAGE__->new([$intf]);
print $proc->{class}, "\n";
require Data::Dumper;
print Data::Dumper::Dumper($proc->{interfaces});;
}


1;

0 comments on commit 0bc435e

Please sign in to comment.