view release on metacpan or  search on metacpan

lib/Data/SCS/DefParser.pm  view on Meta::CPAN

# The list of directories or archives to mount.
field @mounts :reader;

# The data source to use (game name, game/sii directory, array reference
# of mountable paths, Archive::SCS instance).
field $mount :param;

# The list of def file names to parse.
field @filenames = (
  "def/country.sii",
  "def/city.sii",
  "def/company.sii",
);

field $archive;
field %archive_has_entry;
field @company_files;

ADJUST :params ( :$parse = undef ) {
  if (defined $parse) {
    @filenames = ref $parse eq 'ARRAY' ? $parse->@* : $parse;
    @filenames or croak '"parse" cannot be an empty array';
  }
  if (ref $mount eq 'ARRAY') {
    @mounts = $mount->@*;
    @mounts or croak '"mount" cannot be an empty array';
  }
  elsif ($mount isa Archive::SCS) {
    $archive = $mount;
  }
  elsif (defined $mount) {
    $self->init_def($mount);
  }
  else {
    croak '"mount" cannot be undef';
  }
}


sub trim :prototype($) {
  my $str = shift;
  $str =~ s/^\s+//s;
  $str =~ s/\s+$//s;
  return $str;
}


sub parse_block {
  my $data = shift;
  my ($pre, $in) = $data =~ m/^([^\{]*)\{(.*)\}/s;
  return (trim $pre, trim $in);
}


method include_file ($file) {
  $archive_has_entry{$file} or croak
    sprintf "Couldn't find file '%s' in: %s", $file, join ", ", @mounts;
  my $inc = $archive->read_entry($file);
  utf8::decode($inc);
  my @inc = grep {$_} map {trim $_} split m/\n/, $inc;
  return @inc;
}


method parse_sii ($file) {
  utf8::decode my $sii = $archive->read_entry($file);
  my ($magic, $unit) = parse_block $sii;
  $magic =~ m/^ \N{ BYTE ORDER MARK }? SiiNunit $/x or die
    sprintf "Expected SiiNunit, found '%s' in %s", $magic, $file;
  my @input = grep {$_} map {trim $_} split m/\n/, $unit;
  my @lines;
  while (my $line = shift @input) {
    if (my ($inc) = $line =~ m/^\@include\s+"([^"]+)"$/) {
      my $inc_path = path("/$file")->parent->relative("/")->child($inc);
      unshift @input, $self->include_file($inc_path);
      next;
    }
    push @lines, $line;
  }
  @lines = map {trim $_} map {
    s{/\* .*? \*/}{}gx;
    m{/\*|\*/} and die "Multi-line comments unimplemented";
    # clip comments
    s{#.*$|//.*$}{}r;
  } @lines;
  @lines = grep {$_} map {trim $_} map {
    # make sure { and } stand by their own on a line
    my @line = ($_);
    while ($line[$#line] =~ m/^([^\{]+)([\{\}])(.*)/) {
      pop @line;
      push @line, $1, $2, $3;
    }
    @line;
  } @lines;
  return @lines;
}


sub parse_sui_data_value {
  my $value = shift;
  if ( $value =~ m/^&([0-9A-Fa-f]{8})$/ ) {  # IEEE 754 binary32 float
    return 'Inf' if lc $1 eq '7f7fffff';  # max finite value / no data marker
    return sprintf '%.9g', unpack 'f', pack 'h8', scalar reverse $1;
    # 9 significant digits are sufficient to represent any 32-bit float.
  }
  if ( $value =~ m/^\(([^()]+)\)$/ ) {
    return join ', ', map { parse_sui_data_value( trim $_ ) } split m/,/, $1;
  }
  if ( $value =~ m/^"([^"]+)"$/ ) {
    my $str = $1 =~ s{ \\x( [0-9A-Fa-f]{2} ) }{ chr hex $1 }egrx;
    utf8::decode $str;
    return $str;
  }
  if ( $value =~ m/^0x( [0-9A-Fa-f]{6,8} )$/x ) {
    return $1;
  }
  if ( $value eq 'true' ) {
    no warnings 'experimental::builtin';
    return builtin::true;
  }
  if ( $value eq 'false' ) {
    no warnings 'experimental::builtin';
    return builtin::false;
  }
  if ( Scalar::Util::looks_like_number $value ) {
    return 0 + $value;
  }
  if ( $value =~ m/^(\S+)$/ ) {
    return $1;
  }
  die "Unknown value format: '$value'";
}


sub parse_sui_data {
  my ($ats_data, $key, @raw) = @_;
  my $data = {};
  # parse key and insert data
  my ($type, $path) = $key =~ m/^(\S+)\s*:\s+(\S+)$/;
  if ($tidy) {
    # skip currently useless clutter
    return if $type eq 'license_plate_data';
  }
  # parse block contents
  for (@raw) {
    if ($tidy) {
      # skip currently useless clutter
      next if /city_name_localized/ || /sort_name/ || /time_zone/;
      next if /city_pin_scale_factor/;
      next if /map_._offsets/ || /license_plate/;
      next if $type eq 'prefab_model' && (/model_desc/ || /semaphore_profile/ || /use_semaphores/ || /gps_avoid/ || /use_perlin/ || /detail_veg_max_distance/ || /traffic_rules_input/ || /traffic_rules_output/ || /invisible/ || /category/ || /tweak_de...
      next if $type eq 'prefab_model' && (/dynamic_lod_/ || /corner\d/);  # code dies for these; not sure why
    }
    if (/(\w+)\s*:\s*(.+)$/) {
      $data->{$1} = parse_sui_data_value $2;
      next;
    }
    if (/(\w+)\[(\d*)\]\s*:\s*(.+)$/) {
      # init array, overwriting scalar array size if present
      $data->{$1} = [] unless ref $data->{$1};
      if (length $2) {
        $data->{$1}[0+$2] = parse_sui_data_value $3;
      }
      else {
        push @{$data->{$1}}, parse_sui_data_value $3;
      }
      next;
    }
    die "Unkown data format: '$_'";
  }
  #$data->{_raw} = [@raw];
  #$data->{_key_raw} = $key;
  #$data->{_type} = $type;
  if ($path =~ m/^[\.\w]+$/) {
    my $hashpath = $path =~ s/\./'}{'/gr;
    $hashpath =~ s/^\'}/_$type'}/;
    eval "\$ats_data->{'$hashpath'} = \$data";
  }
  else {
    die "Unimplemented path '$path'";
  }
}


sub parse_sui_blocks {
  my ($ats_data, @lines) = @_;
  my $block = 0;
  my @raw;
  my $key;
  for my $i (0..$#lines) {
    0 <= $block <= 1 or die $block;
    if ($lines[$i] eq '{') {
      $block++;
      $key = $lines[$i-1];
      @raw = ();
      next;
    }
    if ($lines[$i] eq '}') {
      parse_sui_data $ats_data, $key, @raw;
      $key = undef;
      $block--;
      next;
    }
    if ($block && $lines[$i] !~ m/"/ && $lines[$i] =~ m/:/) {  # parse Reforma one-liners
      push @raw, split m/(?<=[a-z])\s+/, $lines[$i];
      next;
    }
    if ($block) {
      push @raw, $lines[$i];
      next;
    }
  }
}


method init_def ($source) {
  my $is_path = $source isa Path::Tiny || $source =~ m|/|;
  if ( $is_path && path($source)->realpath->is_dir ) {
    @mounts = sort map { "$_" } path( $source )->children( qr/^def|^dlc_/ );

    # ATS_DB originally expected def.scs to be extracted directly into the
    # source dir. In this legacy case, the source dir must be mounted first.
    my $def_dir = "$source/def";
    if ( path($def_dir)->is_dir && ! path($def_dir)->child('def')->is_dir ) {
      @mounts = ( $source, grep { $_ ne $def_dir } @mounts );
    }
  }
  else {  # $source is abstract, e.g. 'ATS'
    my $gamedir = Archive::SCS::GameDir->new(game => $source);
    @mounts = grep { /^def|^dlc_/ } $gamedir->archives;

    if ( $gamedir->game =~ m/^A/i ) {
      # The DLC file names for ATS are well-known; limiting the mounts
      # to essentially the ones suggested by country.sii saves a bunch of time.
      # Using only the DLC file list for this would be unreliable unless you
      # always run the latest game version and always get all DLC immediately.
      my %countries = Data::SCS::DefParser->new(
        mount => $gamedir->mounted('def.scs'),
        parse => 'def/country.sii',
      )->raw_data->{country}{data}->%*;
      my %mount;
      $mount{$_}++ for (
        'def.scs',
        'dlc_kenworth_t680.scs',
        'dlc_peterbilt_579.scs',
        'dlc_westernstar_49x.scs',
        'dlc_arizona.scs',
        'dlc_nevada.scs',
        map { lc sprintf 'dlc_%s.scs', $_->{country_code} } values %countries,
      );
      @mounts = grep { $mount{$_} } $gamedir->archives;
    }

    @mounts = map { $gamedir->path->child($_)->stringify } @mounts;
  }
}


method sii_files () {
  my @files = grep $archive_has_entry{$_}, @filenames;
  for my $path (@mounts) {
    # Include files from DLCs, with file names containing the DLC archive name.
    my $dlc_name = path($path)->basename =~ s/\.scs$//r;
    push @files, grep $archive_has_entry{$_}, map { s/\.sii$/.$dlc_name.sii/r } @filenames;
  }