File Coverage

blib/lib/Alien/Build/Interpolate.pm

Criterion	Covered	Total	%
statement	102	102	100.0
branch	27	30	90.0
condition	4	4	100.0
subroutine	18	18	100.0
pod	8	8	100.0
total	159	162	98.1

package Alien::Build::Interpolate;

use strict;
use warnings;
use 5.008004;

# ABSTRACT: Advanced interpolation engine for Alien builds
our $VERSION = '2.45'; # VERSION


sub new
{
  my($class) = @_;
  my $self = bless {
    helper  => {},
    classes => {},
  }, $class;
  $self;
}


sub add_helper
{
  my $self = shift;
  my $name = shift;
  my $code = shift;

  if(defined $self->{helper}->{$name})
  {
    require Carp;
    Carp::croak("duplicate implementation for interpolated key $name");
  }

  my $require;

  if(ref $_[0] eq 'CODE')
  {
    $require = shift;
  }
  else
  {
    $require = [];
    while(@_)
    {
      my $module = shift;
      my $version = shift;
      $version ||= 0;
      push @$require, $module => $version;
    }
  }

  $self->{helper}->{$name} = Alien::Build::Helper->new(
    $name,
    $code,
    $require,
  );
}


sub replace_helper
{
  my $self = shift;
  my($name) = @_;
  delete $self->{helper}->{$name};
  $self->add_helper(@_);
}


sub has_helper
{
  my($self, $name) = @_;

  return unless defined $self->{helper}->{$name};

  my @require = $self->{helper}->{$name}->require;

  while(@require)
  {
    my $module  = shift @require;
    my $version = shift @require;

    {
      my $pm = "$module.pm";
      $pm =~ s/::/\//g;
      require $pm;
      $module->VERSION($version) if $version;
    }

    unless($self->{classes}->{$module})
    {
      if($module->can('alien_helper'))
      {
        my $helpers = $module->alien_helper;
        foreach my $k (keys %$helpers)
        {
          $self->{helper}->{$k}->code($helpers->{$k});
        }
      }
      $self->{classes}->{$module} = 1;
    }
  }

  my $code = $self->{helper}->{$name}->code;

  return unless defined $code;

  if(ref($code) ne 'CODE')
  {
    my $perl = $code;
    package Alien::Build::Interpolate::Helper;
    $code = sub {
      ##  no critic
      my $value = eval $perl;
      ## use critic
      die $@ if $@;
      $value;
    };
  }

  $code;
}


sub execute_helper
{
  my($self, $name) = @_;

  my $code = $self->has_helper($name);
  die "no helper defined for $name" unless defined $code;

  $code->();
}


sub _get_prop
{
  my($name, $prop, $orig) = @_;

  $name =~ s/^\./alien./;

  if($name =~ /^(.*?)\.(.*)$/)
  {
    my($key,$rest) = ($1,$2);
    return _get_prop($rest, $prop->{$key}, $orig);
  }
  elsif(exists $prop->{$name})
  {
    return $prop->{$name};
  }
  else
  {
    require Carp;
    Carp::croak("No property $orig is defined");
  }
}

sub interpolate
{
  my($self, $string, $prop) = @_;
  $prop ||= {};

  $string =~ s{(?execute_helper($1)}eg;
  $string =~ s{(?
  $string =~ s/\%(?=\%)//g;
  $string;
}


sub requires
{
  my($self, $string) = @_;
  map {
    my $helper = $self->{helper}->{$_};
    $helper ? $helper->require : ();
  } $string =~ m{(?
}


sub clone
{
  my($self) = @_;

  require Storable;

  my %helper;
  foreach my $name (keys %{ $self->{helper} })
  {
    $helper{$name} = $self->{helper}->{$name}->clone;
  }

  my $new = bless {
    helper => \%helper,
    classes => Storable::dclone($self->{classes}),
  }, ref $self;
}

package Alien::Build::Helper;

sub new
{
  my($class, $name, $code, $require) = @_;
  bless {
    name    => $name,
    code    => $code,
    require => $require,
  }, $class;
}

sub name { shift->{name} }

sub code
{
  my($self, $code) = @_;
  $self->{code} = $code if $code;
  $self->{code};
}

sub require
{
  my($self) = @_;
  if(ref $self->{require} eq 'CODE')
  {
    $self->{require} = [ $self->{require}->($self) ];
  }
  @{ $self->{require} };
}

sub clone
{
  my($self) = @_;
  my $class = ref $self;
  $class->new(
    $self->name,
    $self->code,
    [ $self->require ],
  );
}

1;

__END__