File Coverage

blib/lib/alienfile.pm

Criterion	Covered	Total	%
statement	172	174	98.8
branch	26	28	92.8
condition	12	13	92.3
subroutine	35	36	97.2
pod	24	24	100.0
total	269	275	97.8

package alienfile;

use strict;
use warnings;
use 5.008004;
use Alien::Build;
use Exporter ();
use Path::Tiny ();
use Carp ();

sub _path { Path::Tiny::path(@_) }

# ABSTRACT: Specification for defining an external dependency for CPAN
our $VERSION = '2.47'; # VERSION


our @EXPORT = qw( requires on plugin probe configure share sys download fetch decode prefer extract patch patch_ffi build build_ffi gather gather_ffi meta_prop ffi log test start_url before after );


sub requires
{
  my($module, $version) = @_;
  $version ||= 0;
  my $caller = caller;
  my $meta = $caller->meta;
  $meta->add_requires($meta->{phase}, $module, $version);
  ();
}


sub plugin
{
  my($name, @args) = @_;

  my $caller = caller;
  $caller->meta->apply_plugin($name, @args);
  return;
}


sub probe
{
  my($instr) = @_;
  my $caller = caller;
  if(my $phase = $caller->meta->{phase})
  {
    Carp::croak "probe must not be in a $phase block" if $phase ne 'any';
  }
  $caller->meta->register_hook(probe => $instr);
  return;
}


sub _phase
{
  my($code, $phase) = @_;
  my $caller = caller(1);
  my $meta = $caller->meta;
  local $meta->{phase} = $phase;
  $code->();
  return;
}

sub configure (&)
{
  _phase($_[0], 'configure');
}


sub sys (&)
{
  _phase($_[0], 'system');
}



sub share (&)
{
  _phase($_[0], 'share');
}


sub _in_phase
{
  my($phase) = @_;
  my $caller = caller(1);
  my(undef, undef, undef, $sub) = caller(1);
  my $meta = $caller->meta;
  $sub =~ s/^.*:://;
  Carp::croak "$sub must be in a $phase block"
    unless $meta->{phase} eq $phase;
}

sub start_url
{
  my($url) = @_;
  _in_phase 'share';
  my $caller = caller;
  my $meta = $caller->meta;
  $meta->prop->{start_url} = $url;
  $meta->add_requires('configure' => 'Alien::Build' => '1.19');
  return;
}


sub download
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(download => $instr);
  return;
}


sub fetch
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(fetch => $instr);
  return;
}


sub decode
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(decode => $instr);
  return;
}


sub prefer
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(prefer => $instr);
  return;
}


sub extract
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(extract => $instr);
  return;
}


sub patch
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  my $suffix = $caller->meta->{build_suffix};
  $caller->meta->register_hook("patch$suffix" => $instr);
  return;
}


sub patch_ffi
{
  my($instr) = @_;
  Carp::carp("patch_ffi is deprecated, use ffi { patch ... } } instead");
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(patch_ffi => $instr);
  return;
}


sub build
{
  my($instr) = @_;
  _in_phase 'share';
  my $caller = caller;
  my $suffix = $caller->meta->{build_suffix};
  $caller->meta->register_hook("build$suffix" => $instr);
  return;
}


sub build_ffi
{
  my($instr) = @_;
  Carp::carp("build_ffi is deprecated, use ffi { build ... } } instead");
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(build_ffi => $instr);
  return;
}


sub gather
{
  my($instr) = @_;
  my $caller = caller;
  my $meta = $caller->meta;
  my $phase = $meta->{phase};
  Carp::croak "gather is not allowed in configure block"
    if $phase eq 'configure';
  my $suffix = $caller->meta->{build_suffix};
  if($suffix eq '_ffi')
  {
    $meta->register_hook(gather_ffi => $instr)
  }
  else
  {
    $meta->register_hook(gather_system => $instr) if $phase =~ /^(any|system)$/;
    $meta->register_hook(gather_share => $instr)  if $phase =~ /^(any|share)$/;
  }
  return;
}


sub gather_ffi
{
  my($instr) = @_;
  Carp::carp("gather_ffi is deprecated, use ffi { gather ... } } instead");
  _in_phase 'share';
  my $caller = caller;
  $caller->meta->register_hook(gather_ffi => $instr);
  return;
}


sub ffi (&)
{
  my($code) = @_;
  _in_phase 'share';
  my $caller = caller;
  local $caller->meta->{build_suffix} = '_ffi';
  $code->();
  return;
}


sub meta_prop
{
  my $caller = caller;
  my $meta = $caller->meta;
  $meta->prop;
}


sub log
{
  unshift @_, 'Alien::Build';
  goto &Alien::Build::log;
}


sub test
{
  my($instr) = @_;
  my $caller = caller;
  my $meta = $caller->meta;
  my $phase = $meta->{phase};
  Carp::croak "test is not allowed in $phase block"
    if $phase eq 'any' || $phase eq 'configure';

  $meta->add_requires('configure' => 'Alien::Build' => '1.14');

  if($phase eq 'share')
  {
    my $suffix = $caller->meta->{build_suffix} || '_share';
    $meta->register_hook(
      "test$suffix" => $instr,
    );
  }
  elsif($phase eq 'system')
  {
    $meta->register_hook(
      "test_system" => $instr,
    );
  }
  else
  {
    die "unknown phase: $phase";
  }
}


my %modifiers = (
  probe    => { any   => 'probe'    },
  download => { share => 'download' },
  fetch    => { share => 'fetch'    },
  decode   => { share => 'fetch'    },
  prefer   => { share => 'prefer'   },
  extract  => { share => 'extract'  },
  patch    => { share => 'patch$'   },
  build    => { share => 'build$'   },
  test     => { share => 'test$'    },
  # Note: below special case gather_ffi for the ffi block :P
  gather   => { share => 'gather_share', system => 'gather_system', any => 'gather_share,gather_system' },
);

sub _add_modifier
{
  my($type, $stage, $sub) = @_;

  my $method = "${type}_hook";

  Carp::croak "No such stage $stage" unless defined $modifiers{$stage};
  Carp::croak "$type $stage argument must be a code reference" unless defined $sub && ref($sub) eq 'CODE';

  my $caller = caller;
  my $meta = $caller->meta;
  Carp::croak "$type $stage is not allowed in sys block" unless defined $modifiers{$stage}->{$meta->{phase}};

  $meta->add_requires('configure' => 'Alien::Build' => '1.40');

  my $suffix = $meta->{build_suffix};
  if($suffix eq '_ffi' && $stage eq 'gather')
  {
    $meta->$method('gather_ffi' => $sub);
  }

  foreach my $hook (
    map { split /,/, $_ }                        # split on , for when multiple hooks must be attachewd (gather in any)
    map { my $x = $_ ; $x =~ s/\$/$suffix/; $x } # substitute $ at the end for a suffix (_ffi) if any
    $modifiers{$stage}->{$meta->{phase}})        # get the list of modifiers
  {
    $meta->$method($hook => $sub);
  }

  return;
}

sub before
{
  my($stage, $sub) = @_;
  @_ = ('before', @_);
  goto &alienfile::_add_modifier;
}


sub after
{
  my($stage, $sub) = @_;
  @_ = ('after', @_);
  goto &alienfile::_add_modifier;
}

sub import
{
  strict->import;
  warnings->import;
  goto &Exporter::import;
}

1;

__END__