File Coverage

lib/Devel/Trepan/CmdProcessor/Location.pm

Criterion	Covered	Total	%
statement	52	145	35.8
branch	1	70	1.4
condition	1	30	3.3
subroutine	16	25	64.0
pod	0	8	0.0
total	70	278	25.1

# Copyright (C) 2011-2015 Rocky Bernstein <[e-mail]>
use strict;
use Exporter;
use warnings;
no warnings 'redefine'; no warnings 'once';
use rlib '../../..';
# require_relative '../app/default'

package Devel::Trepan::CmdProcessor;

# Because we use Exporter we want to silence:
#   Use of inherited AUTOLOAD for non-method ... is deprecated
sub AUTOLOAD
{
    my $name = our $AUTOLOAD;
    $name =~ s/.*:://;  # lose package name
    my $target = "DynaLoader::$name";
    goto &$target;
}

sub DESTROY{}

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 = filename_is_eval($filename);
        return $is_eval ? $filename : (basename($filename) || $filename);
    } elsif ($resolve) {
        my $mapped_filename = map_file($filename);
        $filename = $mapped_filename if defined($mapped_filename);
        my $is_eval = 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.
# Devel::Trepan::DB:LineCache::getline actually does the retrieval.
sub current_source_text(;$)
{
    my ($self, $opts) = @_;
    $opts = {maxlines => 5} unless defined $opts;
    my $filename    = $self->{frame}{file};
    my $line_number = $self->{frame}{line};
    my $text        = (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 (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 = map_script($filename, $string);
                $text = getline($filename, $line_no, $opts);
            }
        }
    } else {
        $text = line_at($filename, $line_no, $opts);
        my ($map_file, $map_line) =
            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 => $self->{settings}{lines},
    } 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_str = '';
    $self->{op_addr} = undef;
    if ($self->{settings}{displayop}) {
	my $frame_index = $self->{frame_index};
	if ($DB::OP_addr && $frame_index == 0) {
	    $self->{op_addr} = $DB::OP_addr;
	} else {
	    my $skip = DB::caller_levels_skip();
	    my $addr = Devel::Callsite::callsite($frame_index + $skip);
	    $self->{op_addr} = $addr if defined $addr and $addr > 0;
	}
	$op_addr_str = sprintf(" \@0x%x", $self->{op_addr}) if $self->{op_addr}
    }
    if (filename_is_eval($filename)) {
	### FIXME: put this all into DB::LineCache
        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') {
		my $string = undef;
		if (@DB::dbline) {
		    no warnings;
		    $string = join('', @DB::dbline);
		    use warnings;
		} elsif ($filename =~/^sub (\S+)/) {
		    my $func = $1;
		    if (%SelfLoader::Cache) {
			$string = $SelfLoader::Cache{$func};
			$string =~ s/^\n#line 1.+\n//;
		    }
		}
		unless (defined($string)) {
		    return "${filename}:${line_number}$op_addr_str";
		}
                my $try_filename = map_script($filename, $string);
		$filename = $try_filename if defined($try_filename);
            }
            return $self->filename() .
                " remapped $filename:$line_number$op_addr_str";
        }
    }
    $canonic_filename = $self->canonic_file($self->filename(), 0)
	|| $filename;
    return "${canonic_filename}:${line_number}$op_addr_str";
}

unless (caller()) {
    # Demo it.
    require Devel::Trepan::CmdProcessor;
    my $proc  = Devel::Trepan::CmdProcessor->new;
    eval <<'EOE';
    sub create_frame() {
        my ($pkg, $file, $line, $fn) = caller(0);
        return [
            {
                 file      => $file,
                 fn        => $fn,
                 line      => $line,
                 pkg       => $pkg,
            }];
    }
EOE
    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;