sub update results from the CPAN

sub update

Language-Zcode

view release on metacpan or search on metacpan

lib/Language/Zcode/Runtime/IO.pm view on Meta::CPAN


    if ($t eq "dumb") {
	$zio = new Games::Rezrov::ZIO_dumb(rows=>$r, columns =>$c);
    } elsif ($t eq "win32") {
	$zio = new Games::Rezrov::ZIO_Win32(rows=>$r, columns =>$c);
    } else {
	die "Unknown terminal '$t'\n";
    }
    $zio->set_window(Games::Rezrov::ZConst::LOWER_WIN);
    PlotzPerl::Output::start_output($zio);
# erase_window call in setup_IO calls clear_screen
#    $zio->clear_screen();
}

# Call again for restart
sub setup_IO {
  # XXX I don't handle undo yet ADK
#  $undo_slots = [];
    # cursor positions for individual windows
    $window_cursors = [];
  
    PlotzPerl::Output::setup();
    Language::Zcode::Runtime::Input::setup();

  
  # HACKS, FIX ME
#  $zio->set_version($self);
    # collapses the upper window
    # XXX do we really want to clear screen on a restart?
    erase_window(-1);

    # Centralized management of the status line.
    # Perform a split_window(), we'll use the "upper window" 
    # for the status line.
    # This is BROKEN: Seastalker is a v3 game that uses the upper window!

=pod
  
    # 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;

lib/Language/Zcode/Runtime/IO.pm view on Meta::CPAN

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

lib/Language/Zcode/Runtime/IO.pm view on Meta::CPAN

    $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);

( run in 1.837 second using v1.01-cache-2.11-cpan-5b529ec07f3 )