File Coverage

blib/lib/Data/Resolver/FromDir.pm

Criterion	Covered	Total	%
statement	95	95	100.0
branch	5	10	50.0
condition	2	4	50.0
subroutine	20	20	100.0
pod	6	6	100.0
total	128	135	94.8

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

use File::Spec::Functions qw< catdir catpath splitdir splitpath >;
use File::Spec::Unix ();

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

extends 'Data::Resolver::Base';

has root   => (is => 'ro', required => 1);
has _volume => (is => 'lazy', init_arg => undef);
has _dirs   => (is => 'rwp', init_arg => undef);

sub _build__volume ($self) {
   my ($volume, $dirs) = splitpath($self->root, 'no_file');
   $self->_set__dirs([splitdir($dirs)]);
   return $volume;
}

sub _child ($self, $key) {
   my (undef, $dirs, $target) = File::Spec::Unix->splitpath($key);
   my $v = $self->_volume; # makes sure that _dirs is initialized too
   $dirs = catdir($self->_dirs->@*, File::Spec::Unix->splitdir($dirs));
   return catpath($v, $dirs, $target)
}

sub _children ($self, $test) {
   my $root = $self->root;
   opendir my $dh, $root
     or $self->complain(400, "opendir('$root'): $OS_ERROR");
   my @rv = readdir($dh)
     or $self->complain(400, "readdir('$root'): $OS_ERROR");
   closedir $dh
     or $self->complain(400, "closedir('$root'): $OS_ERROR");
   return grep { $test->($_) } @rv;
} ## end sub _children

sub get_asset ($self, $key) {
   my $child = $self->_child($key);
   $self->not_found($key) unless -f $child;
   my (undef, undef, $basename) = File::Spec::Unix->splitpath($key);
   return $self->asset($basename => file => $child);
}

sub get_sub_resolver ($self, $key) {
   my $child = $self->_child($key);
   $self->not_found($key) unless -d $child;
   return $self->new(root => $child);
}

sub has_asset ($self, $key)        { -f ($self->_child($key) // '') }

sub has_sub_resolver ($self, $key) { -d ($self->_child($key) // '') }

sub list_asset_keys ($self) {
   my $v = $self->_volume;
   my $dirs = catdir($self->_dirs->@*);
   $self->_children(sub ($item) { -f catpath($v, $dirs, $item) });
}

sub list_sub_resolver_keys ($self) {
   my $v = $self->_volume;
   my $dirs = catdir($self->_dirs->@*);
   $self->_children(sub ($item) { -d catpath($v, $dirs, $item) });
}

1;