File Coverage

blib/lib/Data/Resolver/FromTar.pm

Criterion	Covered	Total	%
statement	99	102	97.0
branch	18	22	81.8
condition			n/a
subroutine	19	19	100.0
pod	6	6	100.0
total	142	149	95.3

#!/usr/bin/env perl
package Data::Resolver::FromTar;
use v5.24;
use warnings;
use experimental 'signatures';

use File::Spec::Unix ();
use Archive::Tar ();
use Archive::Tar::Constant ();

sub __pass_if_type ($taf, $t) { $taf if defined($taf) && $taf->type == $t }

sub __trim    ($key) { $key =~ s{\A \./+ | /+ \z}{}rgmxs }

sub __normalize_prefix ($key) {
   $key =~ s{\A \./+ }{}mxs;
   return '' unless length($key);
   return $key =~ s{/*\z}{/}rmxs;
}

use Moo;
no warnings 'experimental::signatures';
use namespace::clean;

extends 'Data::Resolver::Base';

has root   => (is => 'ro', required => 1);
has _lists => (is => 'lazy');
has prefix => (is => 'lazy', coerce => \&__normalize_prefix);
has _ta    => (is => 'lazy');

sub _build__lists ($self) {
   my (@assets, %sub_resolvers);
   my $prefix = $self->prefix;
   my $lp = length($prefix);
   for my $item ($self->_ta->list_files([qw< name type >])) {
      my ($name, $type) = $item->@{qw< name type >};

      $name =~ s{\A \./+ | /+ \z}{}gmxs;
      next if length($name) <= $lp;
      next if substr($name, 0, $lp) ne $prefix;

      my $subname = substr($name, $lp);

      if ($subname =~ m{\A (.*?) /}mxs) {
         $sub_resolvers{$1} = 1;
      }
      elsif ($type == Archive::Tar::Constant::DIR) {
         $sub_resolvers{$subname} = 1;
      }
      elsif ($type == Archive::Tar::Constant::FILE) {
         push @assets, $subname;
      }
      else {} # ignore this
   }
   return {
      assets => [ sort { $a cmp $b } @assets ],
      sub_resolvers => [ sort { $a cmp $b } keys %sub_resolvers ],
   };
}

sub _build_prefix ($self) { return '' }

sub _build__ta ($self) {
   my $tar = Archive::Tar->new;
   $tar->read($self->root);
   return $tar;
}

sub _child ($self, $key, $type) {
   $key = __trim($key);
   $key = $self->prefix . $key;
   my $tar = $self->_ta;
   for my $post ('', '/') {
      for my $pre ('', './') {
         my $full_key = join '', $pre, $key, $post;
         next unless $tar->contains_file($full_key);
         my ($file) = $tar->get_files($full_key);
         return $file if $file->type == $type;
         return;
      }
   }
   return;
}

sub get_asset ($self, $key) {
   my $child = $self->_child($key, Archive::Tar::Constant::FILE)
      or $self->not_found($key);
   my (undef, undef, $basename) = File::Spec::Unix->splitpath($key);
   return $self->asset($basename => raw => $child->get_content);
}

sub get_sub_resolver ($self, $key) {
   my $child = $self->_child($key, Archive::Tar::Constant::DIR)
      or $self->not_found($key);
   return $self->new(root => $self->root, prefix => $child->name);
}

sub has_asset ($self, $key) {
   defined($self->_child($key, Archive::Tar::Constant::FILE)) ? 1 : 0;
}

sub has_sub_resolver ($self, $key) {
   defined($self->_child($key, Archive::Tar::Constant::DIR)) ? 1 : 0;
}

sub list_asset_keys ($self) { return $self->_lists->{assets}->@* }

sub list_sub_resolver_keys ($s) { return $s->_lists->{sub_resolvers}->@* }

1;