view release on metacpan or  search on metacpan

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

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


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 {