File Coverage

blib/lib/File/ShareDir/Dist.pm

Criterion	Covered	Total	%
statement	58	58	100.0
branch	20	24	83.3
condition	5	9	55.5
subroutine	8	8	100.0
pod	2	2	100.0
total	93	101	92.0

package File::ShareDir::Dist;

use strict;
use warnings;
use 5.008001;
use base qw( Exporter );
use File::Spec;

our @EXPORT_OK = qw( dist_share dist_config );

# ABSTRACT: Locate per-dist shared files
our $VERSION = '0.07'; # VERSION


# TODO: Works with PAR

our %over;

sub dist_share ($)
{
  my($dist_name) = @_;

  $dist_name =~ s/::/-/g;

  local $over{$1} = $2
    if defined $ENV{PERL_FILE_SHAREDIR_DIST} && $ENV{PERL_FILE_SHAREDIR_DIST} =~ /^(.*?)=(.*)$/;

  return File::Spec->rel2abs($over{$dist_name}) if $over{$dist_name};

  my @pm = split /-/, $dist_name;
  $pm[-1] .= ".pm";

  foreach my $inc (@INC)
  {
    my $pm = File::Spec->catfile( $inc, @pm );
    if(-f $pm)
    {
      my $share = File::Spec->catdir( $inc, qw( auto share dist ), $dist_name );
      if(-d $share)
      {
        return File::Spec->rel2abs($share);
      }

      if(!File::Spec->file_name_is_absolute($inc))
      {
        my($v,$dir) = File::Spec->splitpath( File::Spec->rel2abs($inc), 1 );
        my @dirs = File::Spec->splitdir($dir);
        if(defined $dirs[-1] && $dirs[-1] eq 'lib')
        {
          pop @dirs; # pop off the 'lib';
          # put humpty dumpty back together again
          my $share = File::Spec->catdir(
            File::Spec->catpath($v,
              File::Spec->catdir(@dirs),
              '',
            ),
            'share',
          );

          if(-d $share)
          {
            return $share;
          }
        }
      }

      last;
    }
  }

  return;
}


sub dist_config
{
  my($dist_name) = @_;
  my $dir = dist_share $dist_name;
  return {} unless defined $dir && -d $dir;
  my $fn = File::Spec->catfile($dir, 'config.pl');
  return {} unless -f $fn;
  my $fh;
  open($fh, '<', $fn) || die "unable to read $fn $!";
  my $pl = do { local $/; <$fh> };
  close $fh;
  my $config = eval $pl;
  die $@ if $@;
  $config;
}

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

  my @modify;

  foreach my $arg (@args)
  {
    if($arg =~ /^-(.*?)=(.*)$/)
    {
      $over{$1} = $2;
    }
    else
    {
      push @modify, $arg;
    }
  }

  @_ = ($class, @modify);

  goto \&Exporter::import;
}

1;

__END__