File Coverage

blib/lib/Games/Rezrov/ZText.pm

Criterion	Covered	Total	%
statement	59	59	100.0
branch	28	30	93.3
condition	1	3	33.3
subroutine	7	7	100.0
pod	0	2	0.0
total	95	101	94.0

package Games::Rezrov::ZText;
# text decoder

use Carp qw(cluck);
use strict;

use Games::Rezrov::StoryFile;
use Games::Rezrov::Inliner;

use constant SPACE => 32;

my @alpha_table = (
		   [ 'a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z' ],
		   [ 'A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z' ],
		   [ '_','^','0','1','2','3','4','5','6','7','8','9','.',',','!','?','_','#','\'','"','/','\\','-',':','(',')' ]
);

my $INLINE_CODE = '
sub decode_text {
  my ($self, $address, $buf_ref) = @_;
  # decode and return text at this address; see spec section 3
  # in array context, returns address after decoding.
  my $buffer = "";
  $buf_ref = \$buffer unless ($buf_ref);
  # $buf_ref supplied if called recursively

  my ($word, $zshift, $zchar);
  my $alphabet = 0;
  my $abbreviation = 0;
  my $two_bit_code = 0;
  my $two_bit_flag = 0;
  # spec 3.4
  my $zh = Games::Rezrov::StoryFile::header();
  my $flen = $zh->file_length();

  while (1) {
    last if $address >= $flen;
    $word = GET_WORD_AT($address);
    $address += 2;
    # spec 3.2
    for ($zshift = 10; $zshift >= 0; $zshift -= 5) {
      # break word into 3 zcharacters of 5 bytes each
      $zchar = ($word >> $zshift) & 0x1f;
      if ($two_bit_flag > 0) {
	# spec 3.4
	if ($two_bit_flag++ == 1) {
	  $two_bit_code = $zchar << 5; # first 5 bits
	} else {
	  $two_bit_code |= $zchar; # last 5
#	  $receiver->write_zchar($two_bit_code);
	  $$buf_ref .= chr($two_bit_code);
	  $two_bit_code = $two_bit_flag = 0;
	  # done
	}
      } elsif ($abbreviation) {
	# synonym/abbreviation; spec 3.3
	my $entry = (32 * ($abbreviation - 1)) + $zchar;
#	print STDERR "abbrev $abbreviation\n";
	my $addr = $zh->get_abbreviation_addr($entry);
	$self->decode_text($addr, $buf_ref);
	$abbreviation = 0;
      } elsif ($zchar < 6) {
	if ($zchar == 0) {
	  #	$receiver->write_zchar(SPACE);
	  $$buf_ref .= " ";
	} elsif ($zchar == 4) {
	  # spec 3.2.3: shift character; alphabet 1
	  $alphabet = 1;
	} elsif ($zchar == 5) {
	  # spec 3.2.3: shift character; alphabet 2
	  $alphabet = 2;
	} elsif ($zchar >= 1 && $zchar <= 3) {
	  # spec 3.3: next zchar is an abbreviation code
	  $abbreviation = $zchar;
	}
      } else {
	# spec 3.5: convert remaining chars from alpha table
	$zchar -= 6;
	# convert to string index
	if ($alphabet < 2) {
	  $$buf_ref .= $alpha_table[$alphabet]->[$zchar];
	} else {
	  # alphabet 2; some special cases (3.5.3)
	  if ($zchar == 0) {
	    $two_bit_flag = 1;
	  } elsif ($zchar == 1) {
	    $$buf_ref .= chr(Games::Rezrov::ZConst::Z_NEWLINE());
	  } else {
	    $$buf_ref .= $alpha_table[$alphabet]->[$zchar];
	  }
	}
	$alphabet = 0;
	# applies to this character only (3.2.3)
      }
      # unset temp flags!
    }
    last if (($word & 0x8000) > 0);
  }

#  print STDERR "dc at $address = \"$buffer\"\n";
  return wantarray ? (\$buffer, $address) : \$buffer;
}
';

Games::Rezrov::Inliner::inline(\$INLINE_CODE);
eval $INLINE_CODE;
undef $INLINE_CODE;

sub new {
  my $self = [];
  bless $self, shift;
  return $self;
}

1;