File Coverage

blib/lib/ZMachine/ZSCII.pm

Criterion	Covered	Total	%
statement	152	155	98.0
branch	41	58	70.6
condition	15	22	68.1
subroutine	17	17	100.0
pod	10	10	100.0
total	235	262	89.6

package ZMachine::ZSCII;
{
  $ZMachine::ZSCII::VERSION = '0.004';
}
use 5.14.0;
use warnings;
# ABSTRACT: an encoder/decoder for Z-Machine text

use Carp ();
use charnames ':full';


my %DEFAULT_ZSCII = (
  chr(0x00) => "\N{NULL}",
  chr(0x08) => "\N{DELETE}",
  chr(0x0D) => "\x0D",
  chr(0x1B) => "\N{ESCAPE}",

  (map {; chr $_ => chr $_ } (0x20 .. 0x7E)), # ASCII maps over

  # 0x09B - 0x0FB are the "extra characters" and need Unicode translation table
  # 0x0FF - 0x3FF are undefined and never (?) used
);

# We can use these characters below because they all (save for the magic A2-C6)
# are the same in Unicode/ASCII/ZSCII. -- rjbs, 2013-01-18
my $DEFAULT_ALPHABET = join(q{},
  'a' .. 'z', # A0
  'A' .. 'Z', # A1
  (           # A2
    "\0", # special: read 2 chars for 10-bit zscii character
    "\x0D",
    (0 .. 9),
    do { no warnings 'qw'; qw[ . , ! ? _ # ' " / \ - : ( ) ] },
  ),
);

my @DEFAULT_EXTRA = map chr hex, qw(
  E4 F6 FC C4 D6 DC DF BB       AB EB EF FF CB CF E1 E9
  ED F3 FA FD C1 C9 CD D3       DA DD E0 E8 EC F2 F9 C0
  C8 CC D2 D9

  E2 EA EE F4 FB C2 CA CE       D4 DB E5 C5 F8 D8 E3 F1
  F5 C3 D1 D5 E6 C6 E7 C7       FE F0 DE D0 A3 153 152 A1
  BF
);

sub _validate_alphabet {
  my (undef, $alphabet) = @_;

  Carp::croak("alphabet table was not 78 entries long")
    unless length $alphabet == 78;

  Carp::carp("alphabet character 52 not set to 0x000")
    unless substr($alphabet, 52, 1) eq chr(0);

  Carp::croak("alphabet table contains characters over 0xFF")
    if grep {; ord > 0xFF } split //, $alphabet;
}

sub _shortcuts_for {
  my ($self, $alphabet) = @_;

  $self->_validate_alphabet($alphabet);

  my %shortcut = (q{ } => chr(0));

  for my $i (0 .. 2) {
    my $offset = $i * 26;
    my $prefix = $i ? chr(0x03 + $i) : '';

    for my $j (0 .. 25) {
      next if $i == 2 and $j == 0; # that guy is magic! -- rjbs, 2013-01-18

      $shortcut{ substr($alphabet, $offset + $j, 1) } = $prefix . chr($j + 6);
    }
  }

  return \%shortcut;
}


sub new {
  my ($class, $arg) = @_;

  if (! defined $arg) {
    $arg = { version => 5 };
  } if (! ref $arg) {
    $arg = { version => $arg };
  }

  my $guts = { version => $arg->{version} };

  Carp::croak("only Version 5, 7, and 8 ZSCII are supported at present")
    unless $guts->{version} == 5
        or $guts->{version} == 7
        or $guts->{version} == 8;

  $guts->{zscii} = { %DEFAULT_ZSCII };

  # Why is this an arrayref and not, like alphabets, a string?
  # Alphabets are strings because they're guaranteed to fit in bytestrings.
  # You can't put a ZSCII character over 0xFF in the alphabet, because it can't
  # be put in the story file's alphabet table!  By using a string, it's easy to
  # just pass in the alphabet from memory to/from the codec.  On the other
  # hand, the Unicode translation table stores Unicode codepoint values packed
  # into words, and it's not a good fit for use in the codec.  Maybe a
  # ZMachine::Util will be useful for packing/unpacking Unicode translation
  # tables.
  $guts->{extra} = $arg->{extra_characters}
                || \@DEFAULT_EXTRA;

  Carp::confess("Unicode translation table exceeds maximum length of 97")
    if @{ $guts->{extra} } > 97;

  for (0 .. $#{ $guts->{extra} }) {
    Carp::confess("tried to add ambiguous Z->U mapping")
      if exists $guts->{zscii}{ chr(155 + $_) };

    my $u_char = $guts->{extra}[$_];

    # Extra characters must go into the Unicode substitution table, which can
    # only represent characters with codepoints between 0 and 0xFFFF.  See
    # Z-Machine Spec v1.1 § 3.8.4.2.1
    Carp::confess("tried to add Unicode codepoint greater than U+FFFF")
      if ord($u_char) > 0xFFFF;

    $guts->{zscii}{ chr(155 + $_) } = $u_char;
  }

  $guts->{zscii_for} = { };
  for my $zscii_char (sort keys %{ $guts->{zscii} }) {
    my $unicode_char = $guts->{zscii}{$zscii_char};

    Carp::confess("tried to add ambiguous U->Z mapping")
      if exists $guts->{zscii_for}{ $unicode_char };

    $guts->{zscii_for}{ $unicode_char } = $zscii_char;
  }

  my $self = bless $guts => $class;

  # The default alphabet is entirely made up of characters that are the same in
  # Unicode and ZSCII.  If a user wants to put "extra characters" into the
  # alphabet table, though, the alphabet should contain ZSCII values.  When
  # we're building a ZMachine::ZSCII using the contents of the story file's
  # alphabet table, that's easy.  If we're building a codec to *produce* a
  # story file, it's less trivial, because we don't want to think about the
  # specific ZSCII codepoints for the Unicode text we'll encode.
  #
  # We provide alphabet_is_unicode to let the user say "my alphabet is supplied
  # in Unicode, please convert it to ZSCII during construction." -- rjbs,
  # 2013-01-19
  my $alphabet = $arg->{alphabet} || $DEFAULT_ALPHABET;

  # It's okay if the user supplies alphabet_is_unicode but not alphabet,
  # because the default alphabet is all characters with the same value in both
  # character sets! -- rjbs, 2013-01-20
  $alphabet = $self->unicode_to_zscii($alphabet)
    if $arg->{alphabet_is_unicode};

  $self->{alphabet} = $alphabet;
  $self->{shortcut} = $class->_shortcuts_for( $self->{alphabet} );

  return $self;
}


sub encode {
  my ($self, $string) = @_;

  $string =~ s/\n/\x0D/g;

  my $zscii  = $self->unicode_to_zscii($string);
  my $zchars = $self->zscii_to_zchars($zscii);

  return $self->pack_zchars($zchars);
}


sub decode {
  my ($self, $bytestring) = @_;

  my $zchars  = $self->unpack_zchars( $bytestring );
  my $zscii   = $self->zchars_to_zscii( $zchars );
  my $unicode = $self->zscii_to_unicode( $zscii );

  $unicode =~ s/\x0D/\n/g;

  return $unicode;
}


sub unicode_to_zscii {
  my ($self, $unicode_text) = @_;

  my $zscii = '';
  for (0 .. length($unicode_text) - 1) {
    my $char = substr $unicode_text, $_, 1;

    Carp::croak(
      sprintf "no ZSCII character available for Unicode U+%v05X <%s>",
        $char,
        charnames::viacode(ord $char),
    ) unless defined( my $zscii_char = $self->{zscii_for}{ $char } );

    $zscii .= $zscii_char;
  }

  return $zscii;
}


sub zscii_to_unicode {
  my ($self, $zscii) = @_;

  my $unicode = '';
  for (0 .. length($zscii) - 1) {
    my $char = substr $zscii, $_, 1;

    Carp::croak(
      sprintf "no Unicode character available for ZSCII %#v05x", $char,
    ) unless defined(my $unicode_char = $self->{zscii}{ $char });

    $unicode .= $unicode_char;
  }

  return $unicode;
}


sub zscii_to_zchars {
  my ($self, $zscii) = @_;

  return '' unless length $zscii;

  my $zchars = '';
  for (0 .. length($zscii) - 1) {
    my $zscii_char = substr($zscii, $_, 1);
    if (defined (my $shortcut = $self->{shortcut}{ $zscii_char })) {
      $zchars .= $shortcut;
      next;
    }

    my $ord = ord $zscii_char;

    if ($ord >= 1024) {
      Carp::croak(
        sprintf "can't encode ZSCII codepoint %#v05x in Z-characters",
          $zscii_char
      );
    }

    my $top = ($ord & 0b1111100000) >> 5;
    my $bot = ($ord & 0b0000011111);

    $zchars .= "\x05\x06"; # The escape code for a ten-bit ZSCII character.
    $zchars .= chr($top) . chr($bot);
  }

  return $zchars;
}


sub zchars_to_zscii {
  my ($self, $zchars, $arg) = @_;
  $arg ||= {};

  my $text = '';
  my $alphabet = 0;

  while (length( my $char = substr $zchars, 0, 1, '')) {
    my $ord = ord $char;

    if ($ord == 0) { $text .= q{ }; next; }

    if    ($ord == 0x04) { $alphabet = 1; next }
    elsif ($ord == 0x05) { $alphabet = 2; next }

    if ($alphabet == 2 && $ord == 0x06) {
      my $next_two = substr $zchars, 0, 2, '';
      if (length $next_two != 2) {
        last if $arg->{allow_early_termination};
        Carp::croak("ten-bit ZSCII encoding segment terminated early")
      }

      my $value = ord(substr $next_two, 0, 1) << 5
                | ord(substr $next_two, 1, 1);

      $text .= chr $value;
      $alphabet = 0;
      next;
    }

    if ($ord >= 0x06 && $ord <= 0x1F) {
      $text .= substr $self->{alphabet}, (26 * $alphabet) + $ord - 6, 1;
      $alphabet = 0;
      next;
    }

    Carp::croak("unknown zchar <$char> encountered in alphabet <$alphabet>");
  }

  return $text;
}


sub make_dict_length {
  my ($self, $zchars) = @_;

  my $length = $self->{version} >= 5 ? 9 : 6;
  $zchars = substr $zchars, 0, $length;
  $zchars .= "\x05" x ($length - length($zchars));

  return $zchars;
}


sub pack_zchars {
  my ($self, $zchars) = @_;

  my $bytestring = '';

  while (my $substr = substr $zchars, 0, 3, '') {
    $substr .= chr(5) until length $substr == 3;

    my $value = ord(substr($substr, 0, 1)) << 10
              | ord(substr($substr, 1, 1)) <<  5
              | ord(substr($substr, 2, 1));

    $value |= (0x8000) if ! length $zchars;

    $bytestring .= pack 'n', $value;
  }

  return $bytestring;
}


sub unpack_zchars {
  my ($self, $bytestring) = @_;

  Carp::croak("bytestring of packed zchars is not an even number of bytes")
    if length($bytestring) % 2;

  my $terminate;
  my $zchars = '';
  while (my $word = substr $bytestring, 0, 2, '') {
    # XXX: Probably allow this to warn and `last` -- rjbs, 2013-01-18
    Carp::croak("input continues after terminating byte") if $terminate;

    my $n = unpack 'n', $word;
    $terminate = $n & 0x8000;

    my $c1 = chr( ($n & 0b0111110000000000) >> 10 );
    my $c2 = chr( ($n & 0b0000001111100000) >>  5 );
    my $c3 = chr( ($n & 0b0000000000011111)       );

    $zchars .= "$c1$c2$c3";
  }

  return $zchars;
}

1;

__END__