File Coverage

blib/lib/Games/Rezrov/ZIO_Generic.pm

Criterion	Covered	Total	%
statement	40	74	54.0
branch	4	12	33.3
condition	0	6	0.0
subroutine	17	31	54.8
pod	0	24	0.0
total	61	147	41.5

package Games::Rezrov::ZIO_Generic;
#
# shared/skeleton z-machine i/o, options, and speech
#
# FIX ME: provide abstract stub methods which die() w/message
#         requiring implementation
#

use strict;

use Games::Rezrov::ZIO_Tools;
use Games::Rezrov::ZConst;
use Games::Rezrov::Speech;
use Games::Rezrov::MethodMaker qw(
			   current_window
                           zio_options
                           using_term_readline
			  );

@Games::Rezrov::ZIO_Generic::ISA = qw(Games::Rezrov::Speech);
# additional ZIO methods

my $buffer = "";

sub new {
  my ($type, %options) = @_;
  my $self = {};
  bless $self, $type;
  $self->zio_options(\%options);
  $self->init_speech_synthesis() if $options{"speak"};
  $self->init_speech_recognition() if $options{"listen"};
  return $self;
}

sub can_split {
  # true or false: can this zio split the screen?
  return 1;
}

sub groks_font_3 {
  # true or false: can this zio handle graphical "font 3" z-characters?
  return 0;
}

sub fixed_font_default {
  # true or false: does this zio use a fixed-width font?
  return 1;
}

sub can_change_title {
  # true or false: can this zio change title?
  return set_xterm_title();
}

sub can_use_color {
  return 0;
}

sub split_window {}
sub set_text_style {}
sub clear_screen {}
sub color_change_notify {}

sub set_game_title {
  set_xterm_title($_[1]);
}

sub manual_status_line {
  # true or false: does this zio want to draw the status line itself?
  return 0;
}

sub get_buffer {
  # get buffered text; fix me: return a ref?
#  print STDERR "get_buf: $buffer\n";
  return $buffer;
}

sub reset_buffer {
  $buffer = "";
}

sub buffer_zchunk {
  # receive a z-code string; newlines may be present.
  my $nl = chr(Games::Rezrov::ZConst::Z_NEWLINE);
  foreach (unpack "a" x length ${$_[1]}, ${$_[1]}) {
    # this unpack() seems a little faster than a split().
    # Any better way ???
    if ($_ eq $nl) {
      Games::Rezrov::StoryFile::flush();
      $_[0]->newline();
    } else {
      $buffer .= $_;
    }
  }
}

sub buffer_zchar {
  $buffer .= chr($_[1]);
}

sub set_font {
#  print STDERR "set_font $_[1]\n";
  return 0;
}

sub play_sound_effect {
  my ($self, $effect) = @_;
#  flash();
}

sub set_window {
  $_[0]->current_window($_[1]);
}

sub cleanup {
}

sub DESTROY {
  # in case of a crash, make sure we exit politely
  $_[0]->cleanup();
}

sub fatal_error {
  my ($self, $msg) = @_;
  $self->write_string("Fatal error: " . $msg);
  $self->newline();
  $self->get_input(1,1);
  $self->cleanup();
  exit 1;
}

sub set_background_color {
  # set the background to the current background color.
  # That's the *whole* background, not just for the next characters
  # to print (some games switch background colors before clearing
  # the screen, which should reset the entire background to that
  # color); eg "photopia.z5".
  #
  # "That's the *whole* bass..."
  1;
}

sub readline_init {
  #
  # try to initialize Term::Readline if desired and available
  #
  # FIX ME: rather than ->{readline}, ZOptions.pm?
  my ($self) = @_;
  if ($self->zio_options->{readline} and find_module('Term::ReadLine')) {
    require Term::ReadLine;
    my $tr = new Term::ReadLine "what?", \*main::STDIN, \*main::STDOUT;
    unless (ref $tr eq "Term::ReadLine::Stub") {
      $tr->ornaments(0);
      $self->using_term_readline($tr);
      # only set if available and active
    }
  }
}

sub readline {
  # read a line via Term::ReadLine
  # readline insists on resetting the line so we need to give it
  # everything up to the cursor position.
  my ($self, $preloaded) = @_;
  # FIX ME: preloaded input does NOT work with Term::ReadLine!

  my $line;
  {
    local $SIG{__WARN__} = sub {};
    # disable warnings for readline call.
    # Term::ReadLine::Perl spews undef messages when passed an
    # undef prompt (e.g. when "Plundered Hearts" starts)
    my $rl_ref = $_[0]->using_term_readline();
    my $prompt = Games::Rezrov::StoryFile::prompt_buffer();

    if ($prompt and $rl_ref->ReadLine eq "Term::ReadLine::Gnu") {
      # HACK:
      # Term::ReadLine::Perl seems to erase line before prompt,
      # but Term::ReadLine::Gnu doesn't.  Since the prompt has already
      # been displayed before ReadLine is called, when using Gnu
      # version we need to erase it so we don't wind up with two.
      $self->write_string(pack('c', Games::Rezrov::ZConst::ASCII_BS) x
			  length($prompt));
    }

    $line = $rl_ref->readline($prompt);
    # this doesn't work with v5+ preloaded input
  }
  return $line;
}

1;