File Coverage

lib/Devel/Trepan/Core.pm

Criterion	Covered	Total	%
statement	92	161	57.1
branch	14	52	26.9
condition	7	19	36.8
subroutine	21	31	67.7
pod	2	8	25.0
total	136	271	50.1

# -*- coding: utf-8 -*-
# Copyright (C) 2011-2014 Rocky Bernstein <[e-mail]>
# Top-level require that pulls in the rest of the debugger.
# It's also the thing that gets called from DB:: hooks

use warnings; use utf8;
# FIXME: Can't use strict;

package Devel::Trepan::Core;

# Something in the require process munges $0 into 'trepan.pl'.
# To make matters more sensitive, Enbugger processes $0 special
# to make it debuggable. Thereore...
#    save and restore $0.
my $dollar0_save;
BEGIN {
    $dollar0_save = $0;
}

use rlib '.';
use Devel::Trepan::DB;
use Devel::Trepan::DB::Use;
use Devel::Trepan::DB::LineCache;  # for remap_e_string_to_file();
use Devel::Trepan::CmdProcessor;
use Devel::Trepan::SigHandler;
use Devel::Trepan::WatchMgr;
use Devel::Trepan::IO::Output;
use Devel::Trepan::Interface::Script;
use Devel::Trepan::Interface::Server;
use Devel::Trepan::Util;
# print join(', ', @INC, "\n");

use vars qw(@ISA $dbgr $invoke_opts);

use constant HAVE_BULLWINKLE => eval q(use Devel::Trepan::BWProcessors; 1) ? 1 : 0;


@ISA = qw(DB);

sub add_startup_files($$;$) {
    my ($cmdproc, $startup_file, $nowarn) = @_;
    my $errmsg = Devel::Trepan::Util::invalid_filename($startup_file);
    if ($errmsg) {
        print STDERR "${errmsg}.\n" unless $nowarn;
    }  else {
        push @{$cmdproc->{cmd_queue}}, "source $startup_file";
    }
}

sub new {
    my $class = shift;
    my %ORIG_SIG = %SIG; # Makes a copy of %SIG;
    my $self = {
        watch  => Devel::Trepan::WatchMgr->new(), # List of watch expressions
        orig_sig => \%ORIG_SIG,
        caught_signal => 0,
        exec_strs     => [],
        need_e_remap  => 0
    };
    bless $self, $class;
    $self->awaken();
    $self->skippkg('Devel::Trepan::Core');
    $self->skippkg('Devel::Trepan::DB::Use');
    $self->skippkg('SelfLoader');
    $self->register();
    $self->ready();
    return $self;
}

# Called when debugger is ready for reading commands. Main
# entry point.
sub idle($$$)
{
    my ($self, $event, $args) = @_;
    my $proc = $self->{proc};
    $event = 'terminated' if $DB::package eq 'Devel::Trepan::Terminated';
    if ($self->{need_e_remap} && $DB::filename eq '-e') {
        remap_dbline_to_file();
        $self->{need_e_remap} = 0;
    }

    $proc->process_commands($DB::caller, $event, $args);
    $self->{caught_signal} = 0;
}

# Called on catching a signal that SigHandler says
# we should enter the debugger for. That it there is 'stop'
# set on that signal.
sub signal_handler($$$)
{
    my ($self, $signame) = @_;
    $DB::running = 0;
    $DB::step    = 0;
    $DB::caller = [caller(1)];
    ($DB::package, $DB::filename, $DB::lineno, $DB::subroutine, $DB::hasargs,
     $DB::wantarray, $DB::evaltext, $DB::is_require, $DB::hints, $DB::bitmask,
     $DB::hinthash
    ) = @{$DB::caller};
    my $proc = $self->{proc};
    $self->{caught_signal} = 1;
    $DB::signal |= 2;
}

sub output($)
{
    my ($self, $msg) = @_;
    my $proc = $self->{proc};
    chomp($msg);
    $proc->msg($msg);
}

sub warning($)
{
    my ($self, $msg) = @_;
    my $proc = $self->{proc};
    chomp($msg);
    $proc->errmsg($msg);
}

sub awaken($;$) {
    my ($self, $opts) = @_;
    no warnings 'once';
    # Process options
    if (!defined($opts) && $ENV{'TREPANPL_OPTS'}) {
        $opts = eval "$ENV{'TREPANPL_OPTS'}";
    }
    $invoke_opts = $opts;

    # require Data::Dumper;
    # import Data::Dumper;
    # print Dumper($opts), "\n";

    my $exec_strs_ary = $opts->{exec_strs};
    if (defined $exec_strs_ary && scalar @{$exec_strs_ary}) {
        $self->{exec_strs} = $opts->{exec_strs};
        $self->{need_e_remap} = 1;
    }

    $0 = $opts->{dollar_0} if $opts->{dollar_0};

    $DB::fall_off_on_end = 1 if $opts->{fall_off_end} || $opts->{traceprint};

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

    my $proc;
    my $batch_filename = $opts->{testing};
    if ($opts->{bw} && HAVE_BULLWINKLE) {
	my $bw_opts = $opts->{bw};
	$bw_opts = {} unless ref($bw_opts) eq 'HASH';
	if (defined $batch_filename) {
	    my $fh = IO::File->new($batch_filename, 'r');
	    $bw_opts = {input => $fh,
			bw_opts => {
			    echo_read  => 1,
			    input_opts => {readline => 0}}
			};
	}
	$proc = Devel::Trepan::BWProcessor->new(undef, $self, $bw_opts);
    } else {
	$batch_filename = $opts->{batchfile} unless defined $batch_filename;
	my %cmdproc_opts = ();
	for my $field
	    (qw(basename cmddir highlight readline traceprint)) {
		# print "field $field $opts->{$field}\n";
		$cmdproc_opts{$field} = $opts->{$field};
	}

	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 = $opts->{server};
		if ($server_opts->[0] eq 'tcp') {
		    $server_opts = {
			io     => 'tcp',
			host   => $opts->{host},
			port   => $opts->{port},
			logger => *STDOUT
		    };
		} elsif ($server_opts->[0] eq 'fifo') {
		    $server_opts = {
			io     => 'fifo',
			logger => *STDOUT
		    };
		} elsif ($server_opts->[0] eq 'tty') {
		    $server_opts = {
			io     => 'tty',
			logger => *STDOUT
		    }
		} else {
		    die "Unknown server protocol: $server_opts->[0]";
		}
		$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};
    }
    $self->{proc} = $proc;
    $self->{sigmgr} =
        Devel::Trepan::SigMgr->new(sub{ $DB::running = 0; $DB::single = 0;
                                        $self->signal_handler(@_) },
                                   sub {$proc->msg(@_)},
                                   sub {$proc->errmsg(@_)},
                                   sub {$proc->section(@_)});
}

sub display_lists ($)
{
    my $self = shift;
    return $self->{proc}{displays}{list};
}

# Restore the value of $0 that we had when we came in here.
# See above for why we have to save and restore $0.
$0 = $dollar0_save;

END {
    $DB::ready = 0;
};

# FIXME: remove the next line and make this really OO.
$dbgr = __PACKAGE__->new();

1;