File Coverage

blib/lib/File/ShareDir/ProjectDistDir.pm

Criterion	Covered	Total	%
statement	120	153	78.4
branch	35	62	56.4
condition	4	6	66.6
subroutine	21	24	87.5
pod	2	2	100.0
total	182	247	73.6

use 5.006;
use strict;
use warnings;

package File::ShareDir::ProjectDistDir;

our $VERSION = '1.000009';

# ABSTRACT: Simple set-and-forget using of a '/share' directory in your projects root

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











use Path::IsDev qw();
use Path::FindDev qw(find_dev);
use Sub::Exporter qw(build_exporter);
use File::ShareDir qw();

my ($exporter) = build_exporter(
  {
    exports => [ dist_dir => \&build_dist_dir, dist_file => \&build_dist_file ],
    groups  => {
      all       => [qw( dist_dir dist_file )],
      'default' => [qw( dist_dir dist_file )],
    },
    collectors => [ 'defaults', ],
  },
);
my $env_key = 'FILE_SHAREDIR_PROJECTDISTDIR_DEBUG';

## no critic (Subroutines::ProhibitSubroutinePrototypes)
sub _debug($) { }
## use critic

if ( $ENV{$env_key} ) {
  ## no critic (ProtectPrivateVars,TestingAndDebugging::ProhibitNoWarnings)
  no warnings 'redefine';
  *File::ShareDir::ProjectDistDir::_debug = sub ($) {
    *STDERR->printf( qq{[ProjectDistDir] %s\n}, $_[0] );
  };
  $Path::IsDev::DEBUG   = 1;
  $Path::FindDev::DEBUG = 1;
}

## no critic (RequireArgUnpacking)
sub _croak { require Carp; goto &Carp::croak }
sub _carp  { require Carp; goto &Carp::carp }

sub _path { require Path::Tiny; goto &Path::Tiny::path }

sub _need_pathclass {
  for my $package ( q[], q[::File], q[::Dir] ) {
    ## no critic (Variables::RequireInitializationForLocalVars)
    local $@ = undef;
    my $code = sprintf 'require %s%s;1', 'Path::Class', $package;
    ## no critic (BuiltinFunctions::ProhibitStringyEval,Lax::ProhibitStringyEval::ExceptForRequire)
    next if eval $code;
    my $err = $@;
    _carp('Path::Class is not installed.');
    ## no critic (RequireCarping, ErrorHandling::RequireUseOfExceptions)
    die $err;
  }
  return 1;
}
































































































































sub import {
  my ( $class, @args ) = @_;

  my ( undef, $xfilename, undef ) = caller;

  my $defaults = {
    filename   => $xfilename,
    projectdir => 'share',
    pathclass  => undef,
    strict     => undef,
  };

  if ( not @args ) {
    @_ = ( $class, ':all', defaults => $defaults );
    goto $exporter;
  }

  for ( 0 .. $#args - 1 ) {
    my ( $key, $value );
    next unless $key = $args[$_] and $value = $args[ $_ + 1 ];

    if ( 'defaults' eq $key ) {
      $defaults = $value;
      undef $args[$_];
      undef $args[ $_ + 1 ];
      next;
    }
    for my $setting (qw( projectdir filename distname pathclass pathtiny strict )) {
      if ( $key eq $setting and not ref $value ) {
        $defaults->{$setting} = $value;
        undef $args[$_];
        undef $args[ $_ + 1 ];
        last;
      }
    }
  }

  $defaults->{filename}   = $xfilename if not defined $defaults->{filename};
  $defaults->{projectdir} = 'share'    if not defined $defaults->{projectdir};

  if ( defined $defaults->{pathclass} ) {
    _carp( 'Path::Class support depecated and will be removed from a future release.' . ' see Documentation for details' );
    _need_pathclass();
  }

  @_ = ( $class, ( grep { defined } @args ), 'defaults' => $defaults );

  goto $exporter;
}
















































sub _get_defaults {
  my ( $field, $arg, $col ) = @_;
  my $result;
  $result = $col->{defaults}->{$field} if $col->{defaults}->{$field};
  $result = $arg->{$field}             if $arg->{$field};
  return $result;
}

sub _wrap_return {
  my ( $type, $value ) = @_;
  if ( not $type ) {
    return $value unless ref $value;
    return "$value";
  }
  if ( 'pathtiny' eq $type ) {
    return $value if 'Path::Tiny' eq ref $value;
    return _path($value);
  }
  if ( 'pathclassdir' eq $type ) {
    return $value if 'Path::Class::Dir' eq ref $value;
    _need_pathclass;
    return Path::Class::Dir->new("$value");
  }
  if ( 'pathclassfile' eq $type ) {
    return $value if 'Path::Class::File' eq ref $value;
    _need_pathclass;
    return Path::Class::File->new("$value");
  }
  return _croak("Unknown return type $type");
}

our %DIST_DIR_CACHE;

sub _get_cached_dist_dir_result {
  my ( undef, $filename, $projectdir, $distname, $strict ) = @_;
  if ( defined $DIST_DIR_CACHE{$distname} ) {
    return $DIST_DIR_CACHE{$distname};
  }
  _debug( 'Working on: ' . $filename );
  my $dev = find_dev( _path($filename)->parent );

  if ( not defined $dev ) {
    ## no critic (Variables::ProhibitPackageVars)
    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    return File::ShareDir::dist_dir($distname);
  }

  my $devel_share_dir = $dev->child($projectdir);

  if ($strict) {
    $devel_share_dir = $devel_share_dir->child( 'dist', $distname );
  }
  if ( -d $devel_share_dir ) {
    _debug( 'ISDEV : exists : /' . $devel_share_dir->relative($dev) );
    return ( $DIST_DIR_CACHE{$distname} = $devel_share_dir );
  }
  _debug( 'ISPROD: does not exist : /' . $devel_share_dir->relative($dev) );
  ## no critic (Variables::ProhibitPackageVars)
  local $Carp::CarpLevel = $Carp::CarpLevel + 1;
  return File::ShareDir::dist_dir($distname);
}

sub build_dist_dir {
  my ( $class, undef, $arg, $col ) = @_;

  my $projectdir = _get_defaults( projectdir => $arg, $col );
  my $pathclass  = _get_defaults( pathclass  => $arg, $col );
  my $pathtiny   = _get_defaults( pathtiny   => $arg, $col );
  my $strict     = _get_defaults( strict     => $arg, $col );
  my $filename   = _get_defaults( filename   => $arg, $col );

  my $wrap_return_type;

  if ($pathclass) { $wrap_return_type = 'pathclassdir' }
  if ($pathtiny)  { $wrap_return_type = 'pathtiny' }

  my $distname = _get_defaults( distname => $arg, $col );

  if ( not $distname ) {
    return sub {
      my ($udistname) = @_;
      my $distdir = $class->_get_cached_dist_dir_result( $filename, $projectdir, $udistname, $strict );
      return _wrap_return( $wrap_return_type, $distdir );
    };
  }
  return sub {
    my $distdir = $class->_get_cached_dist_dir_result( $filename, $projectdir, $distname, $strict );
    return _wrap_return( $wrap_return_type, $distdir );
  };
}
















































sub build_dist_file {
  my ( $class, undef, $arg, $col ) = @_;

  my $projectdir = _get_defaults( projectdir => $arg, $col );
  my $pathclass  = _get_defaults( pathclass  => $arg, $col );
  my $pathtiny   = _get_defaults( pathtiny   => $arg, $col );

  my $strict   = _get_defaults( strict   => $arg, $col );
  my $filename = _get_defaults( filename => $arg, $col );

  my $distname = _get_defaults( distname => $arg, $col );

  my $wrap_return_type;

  if ($pathclass) { $wrap_return_type = 'pathclassfile' }
  if ($pathtiny)  { $wrap_return_type = 'pathtiny' }

  my $check_file = sub {
    my ( $distdir, $wanted_file ) = @_;
    my $child = _path($distdir)->child($wanted_file);
    return unless -e $child;
    if ( -d $child ) {
      return _croak("Found dist_file '$child', but is a dir");
    }
    if ( not -r $child ) {
      return _croak("File '$child', no read permissions");
    }
    return _wrap_return( $wrap_return_type, $child );
  };
  if ( not $distname ) {
    return sub {
      my ( $udistname, $wanted_file ) = @_;
      my $distdir = $class->_get_cached_dist_dir_result( $filename, $projectdir, $udistname, $strict );
      return $check_file->( $distdir, $wanted_file );
    };
  }
  return sub {
    my ($wanted_file) = @_;
    my $distdir = $class->_get_cached_dist_dir_result( $filename, $projectdir, $distname, $strict );
    return $check_file->( $distdir, $wanted_file );
  };
}

1;

__END__