Language::Zcode::Runtime::IO - IO for Perl runtimes created by L::Z translations

Language-Zcode documentation  | view source Contained in the Language-Zcode distribution.

Index

NAME

Top

Language::Zcode::Runtime::IO - IO for Perl runtimes created by L::Z translations

DESCRIPTION

Top

This package contains a number of different packages that support the IO features needed for a running Z-machine. This includes windows, input and output streams, cursors, lines, and fonts. See the Z-machine Spec for descriptions of what all these things means.

This package supports more than one "terminal", i.e., Perl toolkit for handling the I/O into and out of the Z-machine. OK, right now, it only supports 2: dumb, which is just regular print statements; and win32, which involves Win32::Console tools. But in theory, it won't be hard to add support for Tk, Curses, and others. Why? Because I stole nearly all the code in these packages from Games::Rezrov, which already does support multiple terminal types.

This package implements many of the Z-machine I/O opcodes, things like print, output_stream, and read. It also handles the header, which mostly deals with I/O.

This package is currently the most hacked of all the packages in the Language::Zcode distribution. I hope it gets cleaner eventually.

    # So [ADK] split to a SECOND window. This split will be internal to
    # the Z-machine emulator: the Z-machine isn't able to split to more
    # than one window (in v5), but presumably any I/O that can split once
    # can split more than once. Put status in that window.
    #
    # Tk already does that. Just use manual_status_line for
    # everything.
=cut

    if ($main::Constants{version} <= 3 &&
            $zio->can_split() &&
            !$zio->manual_status_line()) {
        split_window(1);
    }

    #  XXX ADK I think we don't need the $current_window line below - that
    #  is taken care of by set_window
    #  $current_window = Games::Rezrov::ZConst::LOWER_WIN;
    set_window(Games::Rezrov::ZConst::LOWER_WIN);
}

# Read IO stuff from header, write some back depending on interpreter/IO sub update_header { my $version = $main::Constants{version};

    # First do flags1 stuff
    # a "time" game: 8.2.3.2
    #my $f1 = PlotzMemory::get_byte_at(FLAGS_1);
    my $f1 = $PlotzMemory::Memory[FLAGS_1];

    my $start_rows = rows();
    my $start_columns = columns();

    #  $f1 |= TANDY if Games::Rezrov::ZOptions::TANDY_BIT();
    # turn on the "tandy bit"

    if ($version <= 3) {
	if ($zio->can_split()) {
	  $f1 |= SCREEN_SPLITTING_AVAILABLE;
	  $f1 &= ~ STATUS_NOT_AVAILABLE;
	} else {
	  $f1 &= ~ SCREEN_SPLITTING_AVAILABLE;
	  $f1 |= STATUS_NOT_AVAILABLE;
	}

	# XXX copied from Games::Rezrov::ZHeader. Isn't this backwards?!
	if ($zio->fixed_font_default()) {
	  $f1 |= VARIABLE_FONT_DEFAULT;
	} else {
	  $f1 &= ~VARIABLE_FONT_DEFAULT;
	}

    # versions 4+
    } else {
	  # Are they always available? Even for dumb term?
	$f1 |= BOLDFACE_AVAILABLE;
	$f1 |= ITALIC_AVAILABLE;
	$f1 |= FIXED_FONT_AVAILABLE;

	#      $f1 |= 0x80;
	$f1 &= ~TIMED_INPUT_AVAILABLE; # timed input NOT available

	set_header_columns($start_columns);
	set_header_rows($start_rows);
	if ($version >= 5) {
	    if ($zio->can_use_color()) {
		$f1 |= COLOURS_AVAILABLE;
	    }
	}
    }
    # write back flag1
    PlotzMemory::set_byte_at(FLAGS_1, $f1);

    # Now do flags2 stuff
    if ($version >= 5) {
	# 8.3.3: default foreground and background
	# FIX ME!

	my $f2 = PlotzMemory::get_word_at(FLAGS_2);
	#      if ($zio->groks_font_3() and
	#	  !Games::Rezrov::StoryFile::font_3_disabled()) {
	    # ZIO can decode font 3 characters
	#	$f2 |= WANTS_PICTURES;
	#      } else {
	    # nope
	#	$f2 &= ~ WANTS_PICTURES;
	#      }

	#      $f2 |= WANTS_UNDO;
	$f2 &= ~ WANTS_UNDO;
	  # FIX ME: should we never use this???

	#      if ($f2 & WANTS_COLOR) {
	    # 8.3.4: the game wants to use colors
	#	print "wants color!\n";
	# }
	PlotzMemory::set_word_at(FLAGS_2, $f2);
    }

    # Other
    # XXX ADK Why isn't this default/default?!
    if ($version >= 5) {
	PlotzMemory::set_byte_at(BACKGROUND_COLOR, Games::Rezrov::ZConst::COLOR_BLACK);
	PlotzMemory::set_byte_at(FOREGROUND_COLOR, Games::Rezrov::ZConst::COLOR_WHITE);
    }

    # Now read bits that get saved during restart/restore
    Language::Zcode::Runtime::IO::restore_restart_bits();
}

{ my $restart_bits; # Get the bits that stay even when you do a restart # Namely, transcript and force-fixed-font bits in Flags 2 sub store_restart_bits { my $f2 = PlotzMemory::get_word_at(FLAGS_2); $restart_bits = $f2 & 3; return; } # Write the bits that stay even when you do a restart # Namely, transcript and force-fixed-font bits in Flags 2 sub restore_restart_bits { # Doesn't do anything if we're starting program for the first time return unless defined $restart_bits; my $f2 = PlotzMemory::get_word_at(FLAGS_2); $f2 &= ~3; # clear bits PlotzMemory::set_word_at(FLAGS_2, $f2 || $restart_bits); return; } }

sub set_header_columns { # 8.4: set the dimensions of the screen. # only needed in v4+ my $columns = shift; my $version = $main::Constants{version}; PlotzMemory::set_byte_at(SCREEN_WIDTH_CHARS, $columns); if ($version >= 5) { PlotzMemory::set_byte_at($version >= 6 ? FONT_WIDTH_UNITS_V6 : FONT_WIDTH_UNITS_V5, 1); PlotzMemory::set_word_at(SCREEN_WIDTH_UNITS, $columns); # ? } }

sub set_header_rows { my $rows = shift; my $version = $main::Constants{version}; PlotzMemory::set_byte_at(SCREEN_HEIGHT_LINES, $rows); if ($version >= 5) { PlotzMemory::set_byte_at($version >= 6 ? FONT_HEIGHT_UNITS_V6 : FONT_HEIGHT_UNITS_V5, 1); PlotzMemory::set_word_at(SCREEN_HEIGHT_UNITS, $rows); } }

sub rows { if (defined $_[0]) { $Rows = $_[0]; if ($zio) { set_header_rows($Rows); PlotzPerl::Output::reset_write_count(); } $lower_lines = $Rows - $upper_lines if defined $upper_lines; } return $Rows; }

sub columns { if (defined $_[0]) { # ZIO notifies us of its columns $Columns = $_[0]; set_header_columns($_[0]) if $zio; show_status() if $main::Constants{version} <= 3 and $zio; } return $Columns; }

sub is_time_game { my $f1 = $PlotzMemory::Memory[FLAGS_1]; return $f1 & IS_TIME_GAME; }

# The I/O-heavy part of the "read" opcode sub read_command { my ($max_text_length, $time, $routine, $initial_buf) = @_; # XXX can initial_buf affect read from script, too? # Does game set initial buf or do we?! my $version = $main::Constants{version};

    # flush any buffered output (e.g. the '>') before the prompt.
    PlotzPerl::Output::flush();

    # Get commands from a script file? Returns undef if not
    # currently reading from a file OR if that file ended
    # (newline at end of command is NOT returned)
    my ($s, $textref);
    if (defined ($s = Language::Zcode::Runtime::Input::get_line_from_file())) {
	$textref = new Language::Zcode::Runtime::Text::Input::File::Line $s;

    } else { # read from keyboard
	show_status() if $version <= 3;
	# Restart the counter for [MORE] prompts. Note: do this only when
	# reading from the screen, not from a file.
	PlotzPerl::Output::reset_write_count();

	$s = $zio->get_input($max_text_length, 0,
				"-time" => $time,
				"-routine" => $routine,
				"-preloaded" => $initial_buf,
			    );
	$textref = new Language::Zcode::Runtime::Text::Input::Screen::Line $s;
    }
    # Record command to transcript/command file(s)
    $$textref .= chr Games::Rezrov::ZConst::Z_NEWLINE; # we chomped $s
    PlotzPerl::Output->output($textref);
    #  printf STDERR "cmd: $s\n";

    return $s;
}

# ascii use constant LINEFEED => 10;

# Stolen from Games::Rezrov. I don't know what rezrov did with $zi arg. # read a single character # 10.7: only return characters defined in input stream # 3.8: character "10" (linefeed) only defined for output. sub read_char { my ($useless, $time, $routine) = @_; #my ($argv, $zi) = @_; PlotzPerl::Output::reset_write_count(); PlotzPerl::Output::flush(); die("read_char: 1st arg must be 1") unless $useless == 1; my $result = screen_zio()->get_input(1, 1, "-time" => $time, "-routine" => $routine, #"-zi" => $zi ); # remap keyboard "linefeed" to what the Z-machine will recognize as a # "carriage return". Required for startup form in "Bureaucracy" # XXX - does keyboard ever return 13 (non-IBM-clones)? # XXX can we just do s/\n/chr(Z_NEWLINE)/e? my $code = ord(substr($result,0,1)); $code = Games::Rezrov::ZConst::Z_NEWLINE if ($code == LINEFEED); return $code; }

This package handles (some) output from the game.

That output may go to various streams, one of which is the screen (which includes windows et al.)

 wrote_something should only be set when doing stream 1? Also stream 2
 will always be fixed font. In fact we will need to store x position
 for stream 2 (but not y because we dont have to worry about scrolling)

PlotzPerl::OutputStream

This class handles a single output stream, like the screen or a transcript file.

PlotzPerl::OutputStream::File

This abstract class handles output streams that write to files.

PlotzPerl::OutputStream::Buffered

This abstract class handles output streams that write buffered (word-wrapped) output. We handle this by buffering output instead of writing it, and whenever we flush, we replace spaces near the edge of the current line with newlines.

 Note that changing screen size, font changes the number of chars needed to
 finish the line so I need to call maybe_flush (which flushes only if nec.)
 from add_to_buffer as well as any time I change one of the above.

 I need to call flush for sure any time I switch windows OR from, e.g.,
 filename_prompt or read_command, where I want to make sure the user sees
 something so that they can input. (Just call it from get_input instead?)
 I shouldn't need to call word_wrap, tho, cuz anything that went into
 buffer should already be wrapped.

PlotzPerl::OutputStream::Screen

This class handles the screen output stream.

 Need to change this to just add newlines, not actually print!
      #
      #  Variable font; graphical wrapping
      #
      my ($x, $y) = $zio->get_pixel_position();
      my $total_width = ($zio->get_pixel_geometry())[0];
      my $pixels_left = $total_width - $x;
      my $plen;
      while ($len = length($str)) {
	$plen = $zio->string_width($str);
	if ($plen < $pixels_left) {
	  # it'll fit; we're done
    #	  print STDERR "fits: $str\n";
   Add $str to $ret
	  $zio->write_string($str);
	  last;
	} else {
	  my $wrapped = 0;
	  my $i = int(length($str) * ($pixels_left / $plen));
    #	  print STDERR "pl=$pixels_left, plen=$plen i=$i\n";
    # Do this with rindex
	  while (substr($str,$i,1) ne " ") {
	    # move ahead to a word boundary
    #	    print STDERR "boundarizing\n";
	    last if ++$i >= $len;
	  }

	  while (1) {
	    $plen = $zio->string_width(substr($str,0,$i));
    #	    printf STDERR "%s = %s\n", substr($str,0,$i), $plen;
	    if ($plen < $pixels_left) {
	      # it'll fit
     Change this to add to $ret
	      $zio->write_string(substr($str,0,$i));
	      $zio->newline();
	      $str = substr($str, $i + 1);
	      $wrapped = 1;
	      last;
	    } else {
	      # retreat back a word
	      while (--$i >= 0 and substr($str,$i,1) ne " ") { }
	      last if ($i < 0);
	    }
	  }

	  $zio->newline() unless ($wrapped);
	  # if couldn't wrap at all on this line
	  $pixels_left = $total_width;
	}
      }

PlotzPerl::OutputStream::Transcript

This class handles the output stream that stores the user's commands (to @read) as well as the game's screen output.

PlotzPerl::OutputStream::Memory

This class handles the output stream that stores game output to memory.

PlotzPerl::OutputStream::UserInput

This class handles the output stream that stores the user's commands (to @read) as well as the game's screen output.

  return $fm2;
}

sub set_text_style { my $text_style = $_[0]; PlotzPerl::Output::flush(); my $mask = font_mask(); if ($text_style == Games::Rezrov::ZConst::STYLE_ROMAN) { # turn off all $mask = 0; } else { $mask |= $text_style; } $mask = font_mask($mask); # might be modified for upper window

  screen_zio()->set_text_style($mask);
}

######################################## # # Windows # sub split_window { my ($lines) = @_; my $zio = screen_zio();

    $upper_lines = $lines;
    $lower_lines = rows() - $lines;
    #  print STDERR "split_window to $lines, ll=$lower_lines ul=$upper_lines\n";

    my ($x, $y) = $zio->get_position();
    if ($y < $upper_lines) {
	# 8.7.2.2
	$zio->absolute_move($x, $upper_lines);
    }
    screen_zio()->split_window($lines);
    # any local housekeeping
}

sub set_window { my ($window) = @_; my $version = $main::Constants{version}; my $rows = rows(); # print STDERR "set_window $window\n"; PlotzPerl::Output::flush(); my $zio = screen_zio();

    $window_cursors->[$current_window] = $zio->get_position(1);
    # save callback to restore cursor position when we return to
    # this window

    $current_window = $window;
    # set current window

    if ($version >= 4) {
	if ($current_window == Games::Rezrov::ZConst::UPPER_WIN) {
	  # 8.7.2: whenever upper window selected, cursor goes to top left
	  set_cursor(1,1);
	} else {
	    # restore old cursor position
	    my $restore;
	    if (defined $window_cursors->[$current_window]) {
		# restore former cursor position
		&{$window_cursors->[$current_window]};
	    } else {
		# first switch to window
		# 8.7.2.2: in v4 lower window cursor is always on last line.
		$zio->absolute_move(0, $rows - 1);
	    }
	}

    } else {
	# in v3, cursor always in lower left
	$zio->absolute_move(0, $rows - 1);
    }

    # for any local housekeeping
    $zio->set_window($window);
    # since we always print in fixed font in the upper window,
    # make sure the zio gets a chance to turn this on/off as we enter/leave;
    # example: photopia.
    $zio->set_text_style(font_mask());
}

sub erase_window { # $window will be signed my ($window) = @_; my $zio = screen_zio(); my $version = $main::Constants{version}; my $rows = rows(); if ($window == -1) { # 8.7.3.3: # $self->split_window(Games::Rezrov::ZConst::UPPER_WIN, 0); # WRONG! split_window(0); # collapse upper window to size 0 clear_screen(); # erase the entire screen PlotzPerl::Output::reset_write_count(); set_window(Games::Rezrov::ZConst::LOWER_WIN); set_cursor(($version == 4 ? $rows : 1), 1); # move cursor to the appropriate line for this version; # hack: at least it\'s abstracted :) } elsif ($window < 0 or $window > 1) { $zio->fatal_error("erase_window $window !");

    } else {
	#
	#  erase specified window
	#
	my $restore = $zio->get_position(1);
	my ($start, $end);
	if ($window == Games::Rezrov::ZConst::UPPER_WIN) {
	    $start = 0;
	    $end = $upper_lines;
	} elsif ($window == Games::Rezrov::ZConst::LOWER_WIN) {
	    $start = $upper_lines;
	    $end = $rows;
	    PlotzPerl::Output::reset_write_count();
	} else {
	    die "clear window $window!";
	}
	for (my $i = $start; $i < $end; $i++) {
	#      $zio->erase_line($i);
	    $zio->absolute_move(0, $i);
	    $zio->clear_to_eol();
	}
	&$restore();
	# restore cursor position
    }
}

sub clear_screen { my $zio = screen_zio();

    if ($zio->can_use_color()) {
	my $fg = $zio->fg() || "";
	my $bg = $zio->bg() || "";
	my $dbg = $zio->default_bg() || "";
	# FIX ME!

	#  printf STDERR "fg=%s/%s bg=%s/%s\n",$fg,$zio->default_fg, $bg, $zio->default_bg;
	if ($bg ne $dbg) {
	  # the background color has changed; change the cursor color
	  # to the current foreground color so we don't run the risk of it 
	  # "disappearing".
	  $zio->cc($fg);
	}
	$zio->default_bg($bg);
	$zio->default_fg($fg);
	$zio->set_background_color();
    }

    $zio->clear_screen();
}

sub prompt_buffer { $prompt_buffer = $_[0] if defined $_[0]; return $prompt_buffer; }

################################################################################

package Games::Rezrov::ZIO_Generic; # # shared z-machine i/o # use strict;

#use Games::Rezrov::ZIO_Tools; #use Games::Rezrov::ZConst;

sub new { return bless {}, $_[0]; }

sub current_window { return (defined $_[1] ? $_[0]->{"current_window"} = $_[1] : $_[0]->{"current_window"}); }

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_use_color { return 0; }

# I/O part of show_status opcode sub show_status { # right_chunk is scores/moves or hours:minutes my ($self, $room_name, $right_chunk) = @_;

    my $columns = Language::Zcode::Runtime::IO::columns();
    if ($self->manual_status_line()) {
	# the ZIO wants to handle it
	$self->status_hook($room_name, $right_chunk);
    } else {
	# "generic" status line handling; broken for screen-splitting v3 games
	my $restore = $self->get_position(1);
	$self->status_hook(0);
	# erase
	$self->write_string((" " x $columns), 0, 0);
	$self->write_string($room_name, 0, 0);

	$self->write_string($right_chunk, $columns - length($right_chunk), 0);
	$self->status_hook(1);
	&$restore();
    }
}

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

sub set_game_title { Games::Rezrov::ZIO_Tools::set_xterm_title($_[1]); }

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

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]); }

# write [MORE] at end of page sub more_prompt { my ($self, $lower_lines) = @_; # Don't even bother doing Language::Zcode::Runtime::IO::font_mask, since we just # reset it. I guess we do need to # call Language::Zcode::Runtime::IO::set_cursor, but prob. only at end # (other call can be an internal ZIO call) my $restore = $self->get_position(1);

    # XXX Change these to internal ZIO calls (absolute move)
    Language::Zcode::Runtime::IO::set_cursor($lower_lines, 1);
    my $more_prompt = "[MORE]";
    my $old = Language::Zcode::Runtime::IO::font_mask();
    $self->set_text_style(Games::Rezrov::ZConst::STYLE_REVERSE);
    $self->write_string($more_prompt);
    $self->set_text_style(Games::Rezrov::ZConst::STYLE_ROMAN);
    Language::Zcode::Runtime::IO::font_mask($old);
    $self->update();
    $self->get_input(1,1);
    Language::Zcode::Runtime::IO::set_cursor($lower_lines, 1);
    $self->clear_to_eol();
    #    $zio->erase_line($lower_lines);
    #    $zio->erase_line($lower_lines - 1);

    # restore old position
    &$restore();
}

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; }

1;

################################################################################ package Games::Rezrov::ZIO_dumb; # z-machine i/o for dumb/semi-dumb terminals.

BEGIN { $ENV{"PERL_RL"} = 'Perl'; }

use strict;

#use Games::Rezrov::GetKey; #use Games::Rezrov::GetSize; #use Games::Rezrov::ZIO_Tools; #use Games::Rezrov::ZIO_Generic;

@Games::Rezrov::ZIO_dumb::ISA = qw(Games::Rezrov::ZIO_Generic);

my $have_term_readline = 0; my $tr;

my $have_term_readkey; my ($rows, $columns); my ($clear_prog);

my $abs_x = 0; my $abs_y = 0;

$|=1;

sub new { my ($type, %options) = @_; my $self = new Games::Rezrov::ZIO_Generic(); bless $self, $type; $self->io_setup($options{"readline"});

  ($columns, $rows) = Games::Rezrov::GetSize::get_size();
  $columns = $options{columns} if $options{columns};
  $rows = $options{rows} if $options{rows};

  unless ($columns and $rows) {
   #print "I couldn't guess the number of rows and columns in your display,\n";
   #print "so you must use -r and -c to specify them manually.\n";
   #exit;
   # XXX HACK!
    $columns = 80; $rows = 250;
  }
  Language::Zcode::Runtime::IO::rows($rows);
  Language::Zcode::Runtime::IO::columns($columns);
  return $self;
}

sub io_setup { my ($self, $readline_ok) = @_;

  if (eval('require Term::ReadKey')) {
    import Term::ReadKey;
    $have_term_readkey = 1;
#    ReadMode(3);
    # disable echoing
#    ReadLine(-1);
    # make sure we don't buffer any (invisible) characters
  }

  if ($readline_ok && eval('require Term::ReadLine')) {
      require Term::ReadLine;
    $have_term_readline = 1;
    $tr = new Term::ReadLine 'what?', \*main::STDIN, \*main::STDOUT;
    $tr->ornaments(0);
  }

  # TODO if $^O == windows, "cls". If unix, `which clear`
  $clear_prog = undef; # find_prog("clear");
}

sub write_string { my ($self, $string, $x, $y) = @_; $self->absolute_move($x, $y) if defined($x) && defined($y); print $string; # print STDERR "ws: $string\n"; $abs_x += length($string); }

sub clear_to_eol { # print STDERR "clear to eol; at $abs_x\n"; my $diff = $columns - $abs_x; if ($diff > 0) { print " " x $diff; # erase print pack("c", 0x08) x $diff; # restore cursor } }

sub update { }

#sub find_prog { # foreach ("/bin/", "/usr/bin/") { # my $fn = $_ . $_[0]; # return $fn if -x $fn; # } # return undef; #}

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

sub set_version { die "Not using set_version any more"; # my ($self, $status_needed, $callback) = @_; # Games::Rezrov::StoryFile::rows($rows); # Games::Rezrov::StoryFile::columns($columns); # print STDERR "$columns\n"; # $self->clear_screen(); return 0; }

sub absolute_move { my ($nx, $ny) = @_[1,2]; # printf STDERR "move X to $nx from $abs_x\n"; if (0 and $nx < $abs_x) { # DISABLED # "this sidewalk's for regular walkin', not fancy walkin'..." my $diff = $abs_x - $nx; # printf STDERR "going back %d\n", $abs_x - $nx; print pack("c", 0x08) x $diff; # go back print " " x $diff; # erase print pack("c", 0x08) x $diff; # go back again } $abs_x = $nx; $abs_y = $ny; }

sub newline { # check to see if we need to pause print "\n"; $abs_x = 0; PlotzPerl::Output::register_newline(); }

sub write_zchar { if ($_[0]->current_window() == Games::Rezrov::ZConst::LOWER_WIN) { print chr($_[1]); # printf STDERR "wc: %s\n", chr($_[1]); $abs_x++; } else { # printf STDERR "ignoring char: %s\n", chr($_[1]); } }

sub get_input { my ($self, $max, $single_char, %options) = @_; if ($single_char) { # XXX ADK put in explicit package name cuz I'm not use'ing GetSize return Games::Rezrov::GetKey::get_key(); } else { if ($have_term_readkey) { # re-enable terminal before prompt ReadMode(0); # ReadLine(0); } my $line; if ($have_term_readline) { # readline insists on resetting the line so we need to give it # everything up to the cursor position. $line = $tr->readline(Language::Zcode::Runtime::IO::prompt_buffer()); # this doesn't work with v5+ preloaded input } else { $line = <STDIN>; # this doesn't work with v5+ preloaded input } unless (defined $line) { $line = ""; print "\n"; } chomp $line; if ($have_term_readkey) { ReadMode(3); # ReadLine(-1); } return $line; } }

sub get_position { my ($self, $sub) = @_; if ($sub) { return sub { }; } else { return ($abs_x, $abs_y); } }

sub clear_screen { system($clear_prog) if $clear_prog; for (my $i=0; $i < $rows; $i++) { # move cursor to lower left print "\n"; } }

my $warned; sub set_window { my ($self, $window) = @_; $self->SUPER::set_window($window); if ($window != Games::Rezrov::ZConst::LOWER_WIN) { # ignore output except on lower window unless ($warned++) { my $pb = Language::Zcode::Runtime::IO::prompt_buffer(); $self->newline(); Language::Zcode::Runtime::IO::set_window(Games::Rezrov::ZConst::LOWER_WIN); my $message = "WARNING: this game is attempting to use multiple windows, which this interface can't handle. The game may be unplayable using this interface. You should probably use the Tk, Curses, Termcap, or Win32 interfaces if you can; see the documentation."; # XXX ADK my replacement might not be 100% compatible to buffer_zchunk # $self->SUPER::buffer_zchunk(\$message); PlotzPerl::Output->write_to_screen(\$message); PlotzPerl::Output::flush(); $self->newline(); Language::Zcode::Runtime::IO::prompt_buffer($pb) if $pb; Language::Zcode::Runtime::IO::set_window($window); } } }

sub erase_chars { my $count = shift;

  print pack 'c', 0x0d;		# carriage return
  print ' ' x $count;		# erase
  print pack 'c', 0x0d;		# carriage return
  # 2nd pass required in case of user input on same line as more prompt;
  # example: start "enchanter" in 80x36 terminal.
  # I'm not sure why just sending $count 0x08's (backspace) doesn't
  # work in this case, but it doesn't.
}

sub cleanup { if ($have_term_readkey) { ReadMode(0); # ReadLine(0); } }

1;

################################################################################ # # Try as hard as we can to guess the number of rows and columns # in the display. # # Use a "nice" approach if available, wallow if we must. # Michael Edmonson 10/1/98 #

package Games::Rezrov::GetSize;

use strict; use Exporter;

@Games::Rezrov::GetSize::ISA = qw(Exporter); @Games::Rezrov::GetSize::EXPORT = qw(get_size);

$Games::Rezrov::GetSize::DEBUG = 0;

eval 'use Term::ReadKey'; if (!$@) { # # use Term::ReadKey # print STDERR "term::readkey\n" if $Games::Rezrov::GetSize::DEBUG;

  eval << 'DONE'
  sub get_size {
    my @terminal = GetTerminalSize();
    return @terminal ? ($terminal[0], $terminal[1]) : undef;
  }
DONE
} elsif ($ENV{"COLUMNS"} and $ENV{"ROWS"}) {
  #
  # use environment variables
  #
  print STDERR "environment vars\n" if $Games::Rezrov::GetSize::DEBUG;
  eval << 'DONE'
    sub get_size {
      return ($ENV{"COLUMNS"}, $ENV{"ROWS"});
    }
DONE
} else {
    foreach ("/bin/", "/usr/bin/") {
      my $fn = $_ . "/stty";
      $Games::Rezrov::GetSize::stty_prog = $fn, last if -x $fn;
    }
    if ($Games::Rezrov::GetSize::stty_prog) {
      #
      # use stty
      #
      print STDERR "stty\n" if $Games::Rezrov::GetSize::DEBUG;
      eval << 'DONE'
	sub get_size {
	  my ($columns, $rows);
	  my $data = `$Games::Rezrov::GetSize::stty_prog -a`;
	  foreach (["rows", \$rows],
		   ["columns", \$columns]) {
	    my ($what, $ref) = @{$_};
	    if ($data =~ /$what\s+=*\s*(\d+)/) {
	      $$ref = $1;
	    } elsif ($data =~ /(\d+)\s+$what/) {
	      $$ref = $1;
	    }
	  }
	  return ($columns, $rows);
	}
DONE
      } else {
      #
      # give up
      #
      print STDERR "giving up\n" if $Games::Rezrov::GetSize::DEBUG;
      eval << 'DONE'
	sub get_size {
	  return undef;
	}
DONE
      }
    }

1;

################################################################################

package Games::Rezrov::GetKey; # Try as hard as we can to read a single key from the keyboard. # Use a "nice" approach if available, wallow if we must. # Michael Edmonson 9/29/98 # # POSIX code taken from Tom Christiansen's "HotKey.pm", see # perlfaq8, or <6k403m$r1l$9@csnews.cs.colorado.edu> # # TO DO: add DOS and other OS-specific code if Term::ReadKey not available

use strict; use Exporter;

@Games::Rezrov::GetKey::ISA = qw(Exporter); @Games::Rezrov::GetKey::EXPORT = qw(get_key);

use constant DEBUG => 0;

$Games::Rezrov::GetKey::STTY = "";

my $CAN_READ_SINGLE = 1;

sub can_read_single { return $CAN_READ_SINGLE; }

eval 'use Term::ReadKey'; if (!$@) { # # use Term::ReadKey # print STDERR "term::readkey\n" if DEBUG; eval << 'DONE' sub get_key { ReadMode(3); my $z; read(STDIN, $z, 1); ReadMode(0); return $z; }

  sub END {
    ReadMode(0);
  }
DONE

} else { my $posix_ok = 0; eval 'use POSIX qw(:termios_h)'; if (!$@) { eval 'my $term = POSIX::Termios->new();'; if ($@) { # we have the POSIX module but Termios doesn't work! # die "aha"; } else { $posix_ok = 1; } } 

   if ($posix_ok) {
    #
    # use POSIX termios
    # 
    print STDERR "posix\n" if DEBUG;

    eval << 'DONE'

    my $fd_stdin = fileno(STDIN);
    my $term = POSIX::Termios->new();
    $term->getattr($fd_stdin);
    my $oterm     = $term->getlflag();
    my $echo     = ECHO | ECHOK | ICANON;
    my $noecho   = $oterm & ~$echo;

    sub cbreak {
      $term->setlflag($noecho);
      $term->setcc(VTIME, 1);
      $term->setattr($fd_stdin, TCSANOW);
    }

    sub cooked {
      $term->setlflag($oterm);
      $term->setcc(VTIME, 0);
      $term->setattr($fd_stdin, TCSANOW);
    }

    sub get_key {
      my $key = '';
      cbreak();
      sysread(STDIN, $key, 1);
      cooked();
      return $key;
    }

    sub END {
      cooked();
    }
DONE
  } else {
    #
    #  Ugh, hopefully it won't come to this :)
    # 
      my $prog;
    foreach ("/bin/", "/usr/bin/") {
      my $fn = $_ . "stty";
      $Games::Rezrov::GetKey::STTY = $fn, last if -x $fn;
    }

    if ($Games::Rezrov::GetKey::STTY) {
      # use stty program
      print STDERR "stty\n" if DEBUG;

      eval << 'DONE'
	sub get_key {
	  my $z;
	  system "$Games::Rezrov::GetKey::STTY -icanon -echo";
	  read(STDIN, $z, 1);
	  system "$Games::Rezrov::GetKey::STTY icanon echo";
	  return $z;
	}

	sub END {
	  system "$Games::Rezrov::GetKey::STTY icanon echo";
	}
DONE
      } else {
	$CAN_READ_SINGLE = 0;
	print STDERR "giving up" if DEBUG;
	eval << 'DONE'
	  sub get_key {
	    my $z;
	    read(STDIN, $z, 1);
	    return $z;
	  }
DONE
	}
      }
  }

1;

################################################################################ package Games::Rezrov::ZIO_Tools;

use strict; use Exporter;

@Games::Rezrov::ZIO_Tools::ISA = qw(Exporter); @Games::Rezrov::ZIO_Tools::EXPORT = qw(set_xterm_title find_module);

sub set_xterm_title { # if title is not defined, return whether or not the title *can* be # changed. my $title = shift; # see the comp.windows.x FAQ. if ($ENV{"DISPLAY"}) { # these are X-specific, so... my $term = $ENV{"TERM"}; my $esc = pack 'c', 27; # escape

    if ($term =~ /xterm/i) {
      # XTerm
      if (defined $title) {
	printf "%s]2;%s%s", $esc, $title, pack('c', 7);  # bell
      } else {
	return 1;
      }
    } elsif ($term eq "vt300") {
      # DECTerm?
      if (defined $title) {
	printf '%s]21;%s%s\\', $esc, $title, $esc;
      } else {
	return 1;
      }
    }
  }

  return 0;
}

sub find_module { # # Determine whether or not a given Perl module or library is installed # my $cmd = 'use ' . $_[0]; eval $cmd; return $@ ? 0 : 1; }

1;

################################################################################

package Games::Rezrov::ZIO_Color; # # stuff for ZIOs that have color support #

use strict;

my %Color; sub cc {$Color{cc} = $_[1] if defined $_[1]; return $Color{cc}} sub fg {$Color{fg} = $_[1] if defined $_[1]; return $Color{fg}} sub bg {$Color{bg} = $_[1] if defined $_[1]; return $Color{bg}} sub sfg {$Color{sfg} = $_[1] if defined $_[1]; return $Color{sfg}} sub sbg {$Color{sbg} = $_[1] if defined $_[1]; return $Color{sbg}} sub default_fg {$Color{default_fg} = $_[1] if defined $_[1]; return $Color{default_fg}} sub default_bg {$Color{default_bg} = $_[1] if defined $_[1]; return $Color{default_bg}}

use constant DEFAULT_BACKGROUND_COLOR => 'blue'; use constant DEFAULT_FOREGROUND_COLOR => 'white'; use constant DEFAULT_CURSOR_COLOR => 'black';

sub parse_color_options { # - interpret standard command-line options for colors # - set up defaults my ($self, $options) = @_; my $fg = lc($options->{"fg"} || DEFAULT_FOREGROUND_COLOR); my $bg = lc($options->{"bg"} || DEFAULT_BACKGROUND_COLOR); my $sfg = lc($options->{"sfg"} || $bg); my $sbg = lc($options->{"sbg"} || $fg); # status line: default to inverse of foreground/background colors

  $self->fg($fg);
  $self->bg($bg);
  $self->default_fg($fg);
  $self->default_bg($bg);
  $self->sfg($sfg);
  $self->sbg($sbg);

  my $cc = lc($options->{"cc"} || DEFAULT_CURSOR_COLOR);
  $self->cc($cc eq $bg ? $fg : $cc);
  # if cursor color is the same as the background color,
  # change it to the foreground color
}

1;

################################################################################ # UNBELIEVABLY UGLY HACK TO ALLOW RUNNING ON NON-WIN32 OSes. # TODO Move to LZ::Term::Win32 and require it only if we're on win32 # Note: can't split it now because Games::Rezrov::ZConst constants are # needed in this package (and others). We need to separate out GR::ZConst # and export all those constants or something, then use from here and other # LZ::Term packages. eval <<'ENDWIN32'; package Games::Rezrov::ZIO_Win32; # z-machine i/o for perls with Win32::Console # TO DO: # - can we set hourglass when busy?

use strict; use Win32::Console;

#use Games::Rezrov::ZIO_Generic; #use Games::Rezrov::ZIO_Color; #use Games::Rezrov::ZConst;

use constant WIN32_DEBUG => 0;

@Games::Rezrov::ZIO_Win32::ISA = qw(Games::Rezrov::ZIO_Generic Games::Rezrov::ZIO_Color );

my ($orig_columns, $orig_rows); my ($s_upper_lines, $s_rows, $s_columns, $in_status); # number of lines in upper window, geometry

my ($IN, $OUT); # Win32::Console instances

if (WIN32_DEBUG) { # debugging; tough to redirect STDERR under win32 :( open(LOG, ">zio.log") || die; select(LOG); $|=1; select(STDOUT); }

my %KEYCODES = ( 38 => Games::Rezrov::ZConst::Z_UP, 40 => Games::Rezrov::ZConst::Z_DOWN, 37 => Games::Rezrov::ZConst::Z_LEFT, 39 => Games::Rezrov::ZConst::Z_RIGHT, );

my (%FOREGROUND, %BACKGROUND); foreach (qw(black blue lightblue red lightred green lightgreen magenta lightmagenta cyan lightcyan brown yellow gray white)) { # make hash translating names to color codes exported by Win32::Console no strict "refs"; $FOREGROUND{$_} = ${"main::FG_" . uc($_)}; $BACKGROUND{$_} = ${"main::BG_" . uc($_)}; }

sub new { my ($type, %options) = @_; my $self = new Games::Rezrov::ZIO_Generic(); bless $self, $type;

    if ($options{fg}) {
	$options{fg} = "gray" if $options{fg} eq "white";
	# since INTENSITY mode has no effect "white",
	# use gray instead.  Feh.
	# How to get *true* bold here???
    } else {
	$options{fg} = "gray" unless $options{fg};
	$options{bg} = "blue" unless $options{bg};
	$options{sfg} = "black" unless $options{sfg};
	$options{sbg} = "cyan" unless $options{sbg};
    }

    $self->parse_color_options(\%options);

    foreach ("bg", "fg", "sfg", "sbg") {
      next unless exists $options{$_};
      my $c = $self->$_() || next;
      die sprintf "Unknown color \"%s\"; available colors: %s\n", $c, join(", ", sort keys %FOREGROUND)
	  unless exists $FOREGROUND{$c};
    }

    # set up i/o
    $IN = new Win32::Console(STD_INPUT_HANDLE);
    $OUT = new Win32::Console(STD_OUTPUT_HANDLE);

    my @size = $OUT->Size();
    $s_columns = $options{"-columns"} || $size[0] || die "need columns!";
    $s_rows = $options{"-rows"} || $size[1] || die "need rows!";
    ($orig_columns, $orig_rows) = @size;

########### # ADK XXX I have no idea if this is right, but it shrinks the Windows # buffer to be the same size as the screen, so that the status line # on row zero is visible without scrolling upward! # Seems like there should be a way to keep the scrollbar and to # allow the lower window to scroll up, always rewriting the upper # window. But maybe Win32::Console doesn't play nice with that. my @w = $OUT->Window(); my ($c, $r) = ($w[2]-$w[0]+1, $w[3]-$w[1]+1); # $OUT->Write($size[0]." "); $OUT->Write($size[1]." "); $OUT->Write("$r $c"); $OUT->Size($c, $r); $s_columns = $options{"-columns"} || $c || die "need columns!"; $s_rows = $options{"-rows"} || $r || die "need rows!"; ###########

    Language::Zcode::Runtime::IO::rows($s_rows);
    Language::Zcode::Runtime::IO::columns($s_columns);
    $s_upper_lines = 0;
    return $self;
}

sub update { $OUT->Flush(); }

sub set_version { # called by the game my ($self, $status_needed, $callback) = @_; Games::Rezrov::StoryFile::rows($s_rows); Games::Rezrov::StoryFile::columns($s_columns); return 0; }

sub absolute_move { # move to X, Y $OUT->Cursor($_[1], $_[2]); }

sub write_string { my ($self, $string, $x, $y) = @_; $self->absolute_move($x, $y) if defined($x) and defined($y); # $OUT->Attr($current_attr); $OUT->Attr($self->get_attr()); $OUT->Write($string); }

sub newline { # newline/scroll my ($x, $y) = $OUT->Cursor(); if (++$y >= $s_rows) { # scroll needed my $last_line = $s_rows - 1; $y = $last_line; my $top = $s_upper_lines; # $OUT->Write(sprintf "before: at %d,%d, top=%d last=%d\n", $x, $y, $top, $last_line); # log_it(sprintf "before: at %d,%d, top=%d last=%d\n", $x, $y, $top, $last_line); # sleep(1); $OUT->Scroll(0, $top + 1, $s_columns - 1, $last_line, 0, $top, Games::Rezrov::ZConst::ASCII_SPACE, $_[0]->get_attr(0), 0, $top, $s_columns - 1, $last_line); # ugh: we have to specify the clipping region, or else # Win32::Console barfs about uninitialized variables (with -w) } PlotzPerl::Output::register_newline(); $_[0]->absolute_move(0, $y); }

sub write_zchar { # log_it("wzchar: " . chr($_[1])); $OUT->Attr($_[0]->get_attr()); $OUT->Write(chr($_[1])); }

sub status_hook { my ($self, $type) = @_; # 0 = before # 1 = after if ($type == 0) { # before printing status line $OUT->Cursor(0,0); $in_status = 1; $OUT->FillAttr($self->get_attr(), $s_columns, 0, 0); } else { # after printing status line $in_status = 0; } }

sub get_input { my ($self, $max, $single_char, %options) = @_; # $IN->Flush(); # don't flush input (allow buffered keystrokes)

    my ($start_x, $y) = $OUT->Cursor();
    my $buf = $options{"-preloaded"} || "";
    # preloaded text in the buffer, but already displayed by the game; ugh.
    my @event;
    my ($code, $char);
    # TODO More keys F1, num lock, etc.- see NOTES.txt
    # Event type (1 keyboard, 2 mouse), key down or up (1,0)
    # repeat count, virtual keycode, virtual scan code (?)
    # char (if ASCII, otherwise 0), control key state
    while (1) {
	@event = $IN->Input() or next; # ignore changing window focus
	my $known;
	if ($event[0] == 1 and $event[1]) {
	    # a key pressed
	    $code = $event[5];
	    if ($code == 0) {
		# non-character key pressed
		if ($KEYCODES{$event[3]}) {
		    $code = $KEYCODES{$event[3]};
		    $known = 1;
		} else {
		    log_it(sprintf "got unknown non-char: %s", join ",", @event);
		}
	    }

	    if ($single_char and ($known or ($code >= 1 and $code <= 127))) {
		return chr($code);
	    } elsif ($code == Games::Rezrov::ZConst::ASCII_BS) {
		if (length($buf) > 0) {
#	  log_it("backsp " . length($buf) . " " . $buf);
		    my ($x, $y) = $OUT->Cursor();
		    $OUT->Cursor($x - 1, $y);
		    $OUT->Write(" ");
		    $OUT->Cursor($x - 1, $y);
		    $buf = substr($buf, 0, length($buf) - 1);
		}
	    } elsif ($code == Games::Rezrov::ZConst::ASCII_CR) {
		last;
	    } else {
		if ($code >= 32 and $code <= 127) {
		    $char = chr($code);
		    $buf .= $char;
		    $OUT->Attr($self->get_attr(0));
		    $OUT->Write($char);
		}
	    }
	}
    }
    $self->newline();
    return $buf;
}

sub clear_screen { $OUT->Cls($_[0]->get_attr(0)); # log_it("cls"); }

sub clear_to_eol { $OUT->Attr($_[0]->get_attr(0)); $OUT->Write(" " x ($s_columns - ($OUT->Cursor())[1])); }

sub split_window { # split upper window to specified number of lines my ($self, $lines) = @_; # $w_main->setscrreg($lines, $s_rows - 1); $s_upper_lines = $lines; # print STDERR "split_window to $lines\n"; }

sub can_change_title { return 1; }

sub can_use_color { return 1; }

sub set_game_title { $OUT->Title($_[1]); }

sub log_it { if (WIN32_DEBUG) { print LOG $_[0] . "\n"; } }

sub get_attr { # return attribute code for color/style currently in effect. my ($self, $mask) = @_;

    $mask = Language::Zcode::Runtime::IO::font_mask() unless defined($mask);
    # might be called with an override
    my ($fg, $bg);
    if ($in_status) {
	$fg = $self->sfg();
	$bg = $self->sbg();
    } else {
	if ($mask & Games::Rezrov::ZConst::STYLE_REVERSE) {
	  $fg = $self->bg();
	  $bg = $self->fg();
	} else {
	  $fg = $self->fg();
	  $bg = $self->bg();
	}
    }

    my $code = $BACKGROUND{$bg} | $FOREGROUND{$fg};

    # ADK What's main::FOREGROUND_INTENSITY? Couldn't find it in
    # any Games::Rezrov file!
=pod
    $code |= main::FOREGROUND_INTENSITY if 
	($mask & (Games::Rezrov::ZConst::STYLE_BOLD|Games::Rezrov::ZConst::STYLE_ITALIC));
=cut

    return $code;
}

sub get_position { # with no arguments, return absolute X and Y coordinates. # With an argument, return a sub that will restore the current cursor # position. my ($self, $sub) = @_; my ($x, $y) = $OUT->Cursor(); if ($sub) { return sub { $OUT->Cursor($x, $y); }; } else { return ($x, $y); } }

my $is_clean = ""; sub cleanup { my $self = shift; return if $is_clean++; # only clean once! if (defined $OUT) { $self->write_string("[Hit any key to exit]"); $self->get_input(1,1); # TODO save Attr so user gets back exactly the window they started with $OUT->Attr($main::ATTR_NORMAL); #print "rows is $orig_rows\n"; $OUT->Size($orig_columns, $orig_rows); } else {warn "cleanup called with undefined zio\n"} print "Cleaned IO\n"; } ENDWIN32

1;

Language-Zcode documentation  | view source Contained in the Language-Zcode distribution.