# Copyright (C) 2011, 2012 Rocky Bernstein <rocky@cpan.org>
use strict;
use Exporter;
use warnings;
no warnings 'redefine'; no warnings 'once';
use rlib '../../..';
# require_relative '../app/default'
package Devel::Trepan::CmdProcessor;
use English qw( -no_match_vars );
use Cwd 'abs_path';
use File::Basename;
use File::Spec;
use Devel::Trepan::DB::LineCache;
our $EVENT2ICON = {
'brkpt' => 'xx',
'call' => '->',
'debugger-call' => ':o',
'end' => '-|',
'interrupt' => 'oo',
'line' => '--',
'post-mortem' => 'XX',
'return' => '<-',
'signal' => '!!',
'tbrkpt' => 'x1',
'terminated' => ':x',
'trace' => '==',
'unknown' => '?!',
'watch' => 'wa'
};
sub canonic_file($$;$)
{
my ($self, $filename, $resolve) = @_;
return undef unless defined $filename;
$resolve = 1 unless defined $resolve;
# For now we want resolved filenames
if ($self->{settings}{basename}) {
my $is_eval = DB::LineCache::filename_is_eval($filename);
return $is_eval ? $filename : (basename($filename) || $filename);
} elsif ($resolve) {
my $mapped_filename = DB::LineCache::map_file($filename);
$filename = $mapped_filename if defined($mapped_filename);
my $is_eval = DB::LineCache::filename_is_eval($filename);
return $is_eval ? $filename : (abs_path($filename) || $filename);
} else {
return $filename;
}
}
sub min($$) {
my ($a, $b) = @_;
return $a < $b ? $a : $b;
}
# Return the text to the current source line. We use trace line
# information to try to retrieve all of the current source line up
# to some limit of lines. The lines returned may be colorized.
# DB::LineCache actually does the retrieval.
sub current_source_text(;$)
{
my ($self, $opts) = @_;
$opts = {max_continue => 5} unless defined $opts;
my $filename = $self->{frame}{file};
my $line_number = $self->{frame}{line};
my $text = (DB::LineCache::getline($filename, $line_number, $opts))
|| '';
chomp($text);
return $text;
}
sub resolve_file_with_dir($$)
{
my ($self, $path_suffix) = @_;
my @dirs = @$self->{settings}{directory};
for my $dir (split(/:/, @dirs)) {
if ('$cwd' eq $dir) {
$dir = `pwd`;
} elsif ('$cdir' eq $dir) {
$dir = $DB::OS_STARTUP_DIR;
}
next unless $dir && !-d ($dir);
my $try_file = File::Spec->catfile($dir, $path_suffix);
return $try_file if -f $try_file;
}
return undef;
}
sub text_at($;$)
{
my ($self, $opts) = @_;
$opts = {
reload_on_change => $self->{settings}{reload},
output => $self->{settings}{highlight},
} unless defined $opts;
my $line_no = $self->line();
my $text;
my $filename = $self->filename();
if (DB::LineCache::filename_is_eval($filename)) {
if ($DB::filename eq $filename) {
{
# Some lines in @DB::line might not be defined.
# So we have to turn off strict here.
no warnings;
my $string = join("\n", @DB::dbline);
use warnings;
$filename = DB::LineCache::map_script($filename, $string);
$text = DB::LineCache::getline($filename, $line_no, $opts);
}
}
} else {
$text = line_at($filename, $line_no, $opts);
my ($map_file, $map_line) =
DB::LineCache->map_file_line($filename, $line_no);
}
$text;
}
sub format_location($;$$$)
{
my ($self, $event, $frame, $frame_index) = @_;
$event = $self->{event} unless defined $event;
$frame = $self->{frame} unless defined $frame;
$frame_index = $self->{frame_index} unless defined $frame_index;
my $text = undef;
my $ev = ' ';
if (defined($self->{event}) && 0 == $frame_index) {
$ev = $EVENT2ICON->{$self->{event}};
}
$self->{line_no} = $self->{frame}{line};
my $loc = $self->source_location_info;
my $suffix = ($event eq 'return' && defined($DB::_[0])) ? " $DB::_[0]" : '';
my $pkg = $self->{frame}{pkg} || '??' ;
"${ev} ${pkg}::(${loc})$suffix";
}
sub print_location($;$)
{
my ($self,$opts) = @_;
$opts = {
output => $self->{settings}{highlight},
max_continue => 5,
} unless defined $opts;
my $loc = $self->format_location;
$self->msg(${loc});
my $text = $self->current_source_text($opts);
if ($text) {
$self->msg($text, {unlimited => 1});
}
}
sub source_location_info($)
{
my $self = shift;
# if (@frame.eval?)
my $canonic_filename;
# 'eval ' + safe_repr(@frame.eval_string.gsub("\n", ';').inspect, 20)
# else
my $filename = $self->{frame}{file};
my $line_number = $self->line() || 0;
my $op_addr = '';
if ($self->{settings}{displayop} && $DB::OP_addr) {
$op_addr = sprintf " \@0x%x", $DB::OP_addr;
}
if (DB::LineCache::filename_is_eval($filename)) {
if ($DB::filename eq $filename) {
# Some lines in @DB::line might not be defined.
# So we have to turn off strict here.
if ($filename ne '-e') {
no warnings;
my $string = join('', @DB::dbline);
use warnings;
$filename = DB::LineCache::map_script($filename, $string);
}
$canonic_filename = $self->canonic_file($self->filename(), 0);
return "${canonic_filename}:${line_number} " .
"remapped $filename:$line_number$op_addr";
}
}
$canonic_filename = $self->canonic_file($self->filename(), 0);
return "${canonic_filename}:${line_number}$op_addr";
}
unless (caller()) {
# Demo it.
require Devel::Trepan::CmdProcessor;
my $proc = Devel::Trepan::CmdProcessor->new;
sub create_frame() {
my ($pkg, $file, $line, $fn) = caller(0);
return [
{
file => $file,
fn => $fn,
line => $line,
pkg => $pkg,
}];
}
my $frame_ary = create_frame();
$proc->frame_setup($frame_ary);
$proc->{event} = 'return';
print $proc->format_location, "\n";
print $proc->current_source_text({output=>'plain'}), "\n";
print $proc->current_source_text({output=>'term'}), "\n";
# See if cached line is the same
print $proc->current_source_text({output=>'term'}), "\n";
# Try unhighlighted line.
print $proc->current_source_text, "\n";
# Now try an eval
$DB::filename = '';
$frame_ary = eval "create_frame()";
$proc->frame_setup($frame_ary);
$proc->{event} = 'line';
print $proc->format_location, "\n";
print $proc->current_source_text({output=>'plain'}), "\n";
}
1;