File Coverage

blib/lib/Path/ScanINC.pm

Criterion	Covered	Total	%
statement	90	137	65.6
branch	24	50	48.0
condition	6	12	50.0
subroutine	22	24	91.6
pod	4	5	80.0
total	146	228	64.0

use 5.008;    # utf8
use strict;
use warnings;
use utf8;

package Path::ScanINC;

our $VERSION = '1.000003';

# ABSTRACT: Emulate Perls internal handling of @INC.

our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY

# Sub Lazy-Aliases
use subs 'inc';
use Class::Tiny qw(inc immutable);
use Try::Tiny qw( try catch );
use Scalar::Util qw( blessed reftype );
use Carp qw( croak );
use Path::Tiny qw( path );

## no critic (Bangs::ProhibitDebuggingModules)
sub __pp { require Data::Dump; goto \&Data::Dump::pp; }
## no critic (RequireArgUnpacking)
sub __croakf { require Carp; @_ = ( sprintf $_[0], splice @_, 1 ); goto \&Carp::croak; }
## use critic


















sub _bad_param {
  my ( $self, $name, $expected, $got ) = @_;
  my $format =
    qq[Initialization parameter '%s' to \$object->new( ) ( %s->new() ) expects %s.\n] . qq[\tYou gave \$object->new( %s => %s )];
  return __croakf( $format, $name, blessed($self), $expected, $name, __pp($got) );
}

sub _fix_immutable {
  my ($self) = @_;
  if ( exists $self->{immutable} ) {
    return $self->_bad_param( 'immutable', 'undef/a true value', $self->{immutable} ) if ref $self->{immutable};
    $self->{immutable} = !!( $self->{immutable} );
  }
  return;
}

sub _fix_inc {
  my ($self) = @_;
  if ( exists $self->{inc} ) {
    return $self->_bad_param( 'inc', 'an array-reference', $self->{inc} )
      if not try { scalar $self->{inc}->[0]; 1 } catch { undef };
  }
  if ( $self->immutable ) {
    if ( exists $self->{inc} ) {
      $self->{inc} = [ @{ $self->{inc} } ];
    }
    else {
      $self->{inc} = [@INC];
    }
  }
  return;
}









sub BUILD {
  my ( $self, ) = @_;
  $self->_fix_immutable;
  $self->_fix_inc;
  return;
}



























sub inc {
  my ( $self, ) = @_;
  return @INC if ( not exists $self->{inc} );
  return @{ $self->{inc} };
}

sub _pm_inc_path {
  my ( undef, @path_parts ) = @_;
  return join q[/], @path_parts;
}

# This method deals with the fact there are refs in @INC, and they have special magic behaviour.
#
# Perl itself, simply invokes special behaviours on those refs, passing the path given in `require`
#
# So in comparison
#
# $self->_ref_expand( $ref, @query )
#
# Invokes those methods, after converting @query to notional format.
#

sub _ref_expand {
  my ( $self, $ref, @query ) = @_;

  # See perldoc perlfunc / require
  if ( blessed($ref) ) {
    my (@result) = $ref->INC( $self->_pm_inc_path(@query) );
    if ( not @result ) {
      return [ undef, ];
    }
    return [ 1, @result ];
  }
  if ( 'CODE' eq reftype($ref) ) {
    my (@result) = $ref->( $ref, $self->_pm_inc_path(@query) );
    if ( not @result ) {
      return [ undef, ];
    }
    return [ 1, @result ];
  }
  if ( 'ARRAY' eq reftype($ref) ) {
    my $code = $ref->[0];
    my (@result) = $code->( $ref, $self->_pm_inc_path(@query) );
    if ( not @result ) {
      return [ undef, ];
    }
    return [ 1, @result ];
  }
  ## no critic (RequireInterpolationOfMetachars)

  __croakf( 'Unknown type of ref in @INC not supported: %s', reftype($ref) );
  return [ undef, ];
}























































sub first_file {
  my ( $self, @args ) = @_;

  for my $path ( $self->inc ) {
    if ( ref $path ) {
      my $result = $self->_ref_expand( $path, @args );
      if ( $result->[0] ) {
        shift @{$result};
        return $result;
      }
      next;
    }
    my $fullpath = path($path)->child(@args);
    if ( -e $fullpath and not -d $fullpath ) {
      return $fullpath;
    }
  }
  return;
}


































sub all_files {
  my ( $self, @args ) = @_;

  my @out;
  for my $path ( $self->inc ) {
    if ( ref $path ) {
      my $result = $self->_ref_expand( $path, @args );
      if ( $result->[0] ) {
        shift @{$result};
        push @out, $result;
      }
      next;
    }
    my $fullpath = path($path)->child(@args);
    if ( -e $fullpath and not -d $fullpath ) {
      push @out, $fullpath;
    }
  }
  return @out;
}







sub first_dir {
  my ( $self, @args ) = @_;

  for my $path ( $self->inc ) {
    if ( ref $path ) {
      my $result = $self->_ref_expand( $path, @args );
      if ( $result->[0] ) {
        shift @{$result};
        return $result;
      }
      next;
    }
    my $fullpath = path($path)->child(@args);
    if ( -e $fullpath and -d $fullpath ) {
      return $fullpath;
    }
  }
  return;
}







sub all_dirs {
  my ( $self, @args ) = @_;
  my @out;
  for my $path ( $self->inc ) {
    if ( ref $path ) {
      my $result = $self->_ref_expand( $path, @args );
      if ( $result->[0] ) {
        shift @{$result};
        push @out, $result;
      }
      next;
    }
    my $fullpath = path($path)->child(@args);
    if ( -e $fullpath and -d $fullpath ) {
      push @out, $fullpath;
    }
  }
  return @out;
}

1;

__END__