File Coverage

lib/Devel/Trepan/Interface/Script.pm

Criterion	Covered	Total	%
statement	57	90	63.3
branch	3	18	16.6
condition	1	3	33.3
subroutine	15	23	65.2
pod	0	7	0.0
total	76	141	53.9

# -*- coding: utf-8 -*-
# This line is for testing purposes \
# Copyright (C) 2011-2012 Rocky Bernstein <[e-mail]>

# Module for reading debugger scripts

use warnings; no warnings 'redefine';
use Exporter;
use IO::File;

use rlib '../../..';

package Devel::Trepan::Interface::Script;
our (@ISA);
use if !@ISA, Devel::Trepan::Interface;
use if !@ISA, Devel::Trepan::Interface::ComCodes;
use Devel::Trepan::IO::Input;
use Devel::Trepan::IO::StringArray;
use Devel::Trepan::Util qw(hash_merge);
use strict;
use vars qw(@EXPORT @ISA);
@ISA = qw(Devel::Trepan::Interface Exporter);

use constant DEFAULT_OPTS => {
    abort_on_error => 1,
    confirm_val    => 0,
    verbose        => 0
};

sub new
{
    my ($class, $script_name, $out, $opts) = @_;
    $opts = {} unless defined $opts;

    $opts = hash_merge($opts, DEFAULT_OPTS);

    my $self = {};
    #  FIXME if $script_name is invalid, we get undef $fh and then
    # Interface->new uses STDIN.
    my $fh = IO::File->new($script_name, 'r');
    $self = Devel::Trepan::Interface->new($fh, $out, $opts);
    $self->{script_name}   = $script_name;
    $self->{input_lineno}  = 0;
    $self->{buffer_output} = [];
    unless ($opts->{verbose} or $out) {
        $self->{output} = Devel::Trepan::IO::StringArrayOutput->new($self->{buffer_output});
    }
    bless $self, $class;
    $self;
}


# Closes input only.
sub close($)
{
    my $self = shift;
    $self->{input}->close;
}

# Called when a dangerous action is about to be done, to make
# sure it's okay.
#
# Could look also look for interactive input and
# use that. For now, though we'll simplify.
sub confirm($$$)
{
    my ($self, $prompt, $default) = @_;
    $self->{opts}{default_confirm};
}

# Common routine for reporting debugger error messages.
#
sub errmsg($$;$)
{
    my ($self, $msg, $prefix) = @_;
    $prefix = '*** ' unless defined $prefix;
    #  self.verbose shows lines so we don't have to duplicate info
    #  here. Perhaps there should be a 'terse' mode to never show
    #  position info.
    my $mess = sprintf "%s%s", $prefix, $msg;

    if ($self->{opts}{verbose}) {
        my $location = sprintf("%s:%s: Error in source command file",
                               $self->{script_name},
                               $self->{input_lineno});
        $mess = sprintf("%s:\n%s%s", $prefix, $location, $prefix, $msg);
    }

    $self->msg($mess);
    # FIXME: should we just set a flag and report eof? to be more
    # consistent with File and IO?
    die if $self->{opts}{abort_on_error};
}

sub msg($$)
{
    my ($self, $msg) = @_;
    ## FIXME: there must be a better way to do this...
    if ($self->{output}->isa('Devel::Trepan::IO::TCPServer')) {
        $self->{output}->writeline(PRINT . $msg);
    } else {
        $self->{output}->writeline($msg);
    }
}

sub is_interactive() { 0; }

sub is_closed($)
{
    my($self)  = shift;
    $self->{input}->eof;
}

sub has_completion() { 0; }
sub has_term_readline($) { 0; }

# Script interface to read a command. `prompt' is a parameter for
# compatibilty and is ignored.
sub read_command($;$)
{
    my ($self, $prompt)=@_;
    $prompt = '' unless defined $prompt;
    $self->{input_lineno} += 1;
    my $last = $self->readline();
    my $line = '';
    while ('\\' eq substr($last, -1)) {
        $line .= substr($last, 0, -1) . "\n";
        $last = $self->readline();
    }
    $line .= $last;

    if ($self->{opts}{verbose}) {
        my $location = sprintf("%s line %s",
                               $self->{script_name},
                               $self->{input_lineno});
        my $mess = sprintf '+ %s: %s', $location, $line;
        $self->msg($mess);
    }
    # Do something with history?
    return $line;
}

# Script interface to read a line. `prompt' is a parameter for
# compatibilty and is ignored.
#
# Could decide make this look for interactive input?
sub readline($;$)
{
    my ($self, $prompt) = @_;
    $prompt = '' unless defined $prompt;
    my $line = $self->{input}->getline;
    chomp $line;
    return $line;
}

sub remove_history($;$)
{
}

# sub DESTROY($)
# {
#     my $self = shift;
#     Devel::Trepan::Interface::DESTROY($self);
# }

# Demo
unless (caller) {
    my $intf = __PACKAGE__->new(__FILE__);
    my $line = $intf->readline();
    print "Line read: ${line}\n";
    $line = $intf->read_command();
    print "Second Line read: ${line}\n";
}

1;