view release on metacpan or  search on metacpan

lib/Archive/SCS/HashFS.pm  view on Meta::CPAN

    $dir .= '/' if length $dir;
    push @dirs,  map { "$dir$_" } $data->dirs;
    push @files, map { "$dir$_" } $data->files;
  }
}


method list_dirs () {
  return @dirs;
}


method list_files () {
  return @files;
}


method entry_meta ($hash) {
  return $entries{ $hash };
}


method read_entry ($hash) {
  $fh or croak sprintf "%s: Not mounted", $path->basename;

  my $entry = $entries{ $hash };

  seek $fh, $entry->{offset}, SEEK_SET;
  my $length = read $fh, my $data, $entry->{zsize};

  defined $length or croak
    sprintf "%s: %s", $path->basename, $!;
  $length == $entry->{zsize} or croak
    sprintf "%s: Read %i bytes, expected %i bytes",
    $path->basename, $length, $entry->{zsize};

  my $crc;
  if ($entry->{is_compressed}) {
    my $status = $zlib->inflate( \(my $raw = $data), \$data );

    $status == Z_OK || $status == Z_STREAM_END
      or warnings::warnif io =>
      sprintf "%s: Inflation failed: %s (%i)",
      $path->basename, $zlib->msg // "", $status;

    $crc = $zlib->crc32;
    $zlib->inflateReset;

    length $data == $entry->{size}
      or warnings::warnif io =>
      sprintf "%s: Inflated to %i bytes, expected %i bytes",
      $path->basename, length $data, $entry->{size};
  }
  else {
    $crc = crc32($data);
  }
  $crc == $entry->{crc}
    or warnings::warnif io =>
    sprintf "%s: Found CRC32 %08X, expected %08X",
    $path->basename, $crc, $entry->{crc};
  # The official SCS extractor doesn't seem to verify the CRC

  # Parse directory listing

  $entry->{is_dir} or return $data;
  my %dir_index;
  for my $item (split /\n/, $data) {
    if ('*' eq substr $item, 0, 1) {
      push $dir_index{dirs}->@*, substr $item, 1;
    }
    else {
      push $dir_index{files}->@*, $item;
    }
  }
  return Archive::SCS::DirIndex->new(%dir_index);
}


method entries () {
  keys %entries
}


sub create_file ($pathname, $scs) {
  $scs isa Archive::SCS or die;

  # This subroutine is designed for internal testing. It may or may not
  # produce files that are compatible with SCS. All entry contents are
  # loaded into memory.

  my (@entries, %entries);
  push @entries, map { cityhash64 $_ } $scs->list_dirs, $scs->list_files;
  push @entries, map { cityhash64_hex $_ } $scs->list_orphans;
  push @entries, cityhash64 '' if eval { $scs->read_entry(''); 1 };
  @entries = sort @entries;
  $entries{$_} = {
    data => $scs->read_entry(cityhash64_as_hex $_),
    flags => 0,
  } for @entries;

  # Serialize directory listings
  do {
    $entries{$_}->{flags} |= 0x1;
    $entries{$_}->{data} = join "\n",
      $entries{$_}->{data}->files,
      map { "*$_" } $entries{$_}->{data}->dirs;
  } for grep {
    $entries{$_}->{data} isa Archive::SCS::DirIndex
  } keys %entries;

  my %opts2 = ( -CRC32 => 1, -WindowBits => 15, -Level => 9, -AppendOutput => 1 );
  my $zlib_d = Compress::Raw::Zlib::Deflate->new(%opts2) or die;

  my $offset = 0;
  for my $hash (@entries) {

    # Compress entry contents
    $zlib_d->deflate( \($entries{$hash}->{data}), \(my $compressed = '') );
    $zlib_d->flush( \$compressed );
    $entries{$hash}->{crc} = $zlib_d->crc32;
    $entries{$hash}->{size} = $zlib_d->total_in;