Alien-Build

 view release on metacpan or  search on metacpan

lib/Alien/Build.pm  view on Meta::CPAN

      }
    }

    # sufficiently new Autotools have a aclocal_dir which will
    # give us the directories we need.
    if($mod eq 'Alien::Autotools' && $mod->can('aclocal_dir'))
    {
      push @{ $self->{aclocal_path} }, $mod->aclocal_dir;
    }

    if($mod->can('alien_helper'))
    {
      my $helpers = $mod->alien_helper;
      foreach my $name (sort keys %$helpers)
      {
        my $code = $helpers->{$name};
        $self->meta->interpolator->replace_helper($name => $code);
      }
    }

  }
  1;
}

sub _call_hook
{
  my $self = shift;

  local $ENV{PATH} = $ENV{PATH};
  unshift @PATH, @{ $self->{bin_dir} };

  local $ENV{PKG_CONFIG_PATH} = $ENV{PKG_CONFIG_PATH};
  unshift @PKG_CONFIG_PATH, @{ $self->{pkg_config_path} };

  local $ENV{ACLOCAL_PATH} = $ENV{ACLOCAL_PATH};
  # autoconf uses MSYS paths, even for the ACLOCAL_PATH environment variable, so we can't use Env for this.
  {
    my @path;
    @path = split /:/, $ENV{ACLOCAL_PATH} if defined $ENV{ACLOCAL_PATH};
    unshift @path, @{ $self->{aclocal_path} };
    $ENV{ACLOCAL_PATH} = join ':', @path;
  }

  my $config = ref($_[0]) eq 'HASH' ? shift : {};
  my($name, @args) = @_;

  local $self->{hook_prop} = {};

  $self->meta->call_hook( $config, $name => $self, @args );
}


sub probe
{
  my($self) = @_;
  local $CWD = $self->root;
  my $dir;

  my $env = $self->_call_hook('override');
  my $type;
  my $error;

  $env = '' if $env eq 'default';

  if($env eq 'share')
  {
    $type = 'share';
  }
  else
  {
    $type = eval {
      $self->_call_hook(
        {
          before   => sub {
            $dir = Alien::Build::TempDir->new($self, "probe");
            $CWD = "$dir";
          },
          after    => sub {
            $CWD = $self->root;
          },
          ok       => 'system',
          continue => sub {
            if($_[0] eq 'system')
            {
              foreach my $name (qw( probe_class probe_instance_id ))
              {
                if(exists $self->hook_prop->{$name} && defined $self->hook_prop->{$name})
                {
                  $self->install_prop->{"system_$name"} = $self->hook_prop->{$name};
                }
              }
              return undef;
            }
            else
            {
              return 1;
            }
          },
        },
        'probe',
      );
    };
    $error = $@;
    $type = 'share' unless defined $type;
  }

  if($error)
  {
    if($env eq 'system')
    {
      die $error;
    }
    $self->log("error in probe (will do a share install): $@");
    $self->log("Don't panic, we will attempt a share build from source if possible.");
    $self->log("Do not file a bug unless you expected a system install to succeed.");
    $type = 'share';
  }

  if($env && $env ne $type)
  {
    die "requested $env install not available";
  }

  if($type !~ /^(system|share)$/)
  {
    Carp::croak "probe hook returned something other than system or share: $type";
  }

  if($type eq 'share' && (!$self->meta_prop->{network}) && (!$self->meta_prop->{local_source}))
  {
    $self->log("install type share requested or detected, but network fetch is turned off");
    $self->log("see https://metacpan.org/pod/Alien::Build::Manual::FAQ#Network-fetch-is-turned-off");
    Carp::croak "network fetch is turned off";
  }

  $self->runtime_prop->{install_type} = $type;

  $type;
}


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

  return $self unless $self->install_type eq 'share';
  return $self if $self->install_prop->{complete}->{download};

  if($self->meta->has_hook('download'))
  {
    my $tmp;
    local $CWD;
    my $valid = 0;

    $self->_call_hook(
      {
        before => sub {
          $tmp = Alien::Build::TempDir->new($self, "download");
          $CWD = "$tmp";
        },
        verify => sub {
          my @list = grep { $_->basename !~ /^\./, } _path('.')->children;

          my $count = scalar @list;

          if($count == 0)
          {
            die "no files downloaded";
          }
          elsif($count == 1)
          {
            my($archive) = $list[0];
            if(-d $archive)

lib/Alien/Build.pm  view on Meta::CPAN

    if(defined $detail)
    {
      if(defined $detail->{digest})
      {
        my($algo, $expected) = @{ $detail->{digest} };
        my $file = {
          type     => 'file',
          filename => Path::Tiny->new($archive)->basename,
          path     => $archive,
          tmp      => 0,
        };
        $checked_digest = $self->meta->call_hook( check_digest => $self, $file, $algo, $expected )
      }
      if(!defined $detail->{protocol})
      {
        $self->log("warning: extract did not receive protocol details for $archive") unless $checked_digest;
      }
      elsif($detail->{protocol} !~ /^(https|file)$/)
      {
        $self->log("warning: extracting from a file that was fetched via insecure protocol @{[ $detail->{protocol} ]}") unless $checked_digest ;
      }
      else
      {
        $encrypted_fetch = 1;
      }
    }
    else
    {
      $self->log("warning: extract received no download details for $archive");
    }

    if($self->download_rule eq 'digest')
    {
      die "required digest missing for $archive" unless $checked_digest;
    }
    elsif($self->download_rule eq 'encrypt')
    {
      die "file was fetched insecurely for $archive" unless $encrypted_fetch;
    }
    elsif($self->download_rule eq 'digest_or_encrypt')
    {
      die "file was fetched insecurely and required digest missing for $archive" unless $checked_digest || $encrypted_fetch;
    }
    elsif($self->download_rule eq 'digest_and_encrypt')
    {
      die "file was fetched insecurely and required digest missing for $archive" unless $checked_digest || $encrypted_fetch;
      die "required digest missing for $archive" unless $checked_digest;
      die "file was fetched insecurely for $archive" unless $encrypted_fetch;
    }
    elsif($self->download_rule eq 'warn')
    {
      unless($checked_digest || $encrypted_fetch)
      {
        $self->log("!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!");
        $self->log("a future version of Alien::Build will die here by default with this exception: file was fetched insecurely and required digest missing for $archive");
        $self->log("!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!");
      }
    }
    else
    {
      die "internal error, unknown download rule: @{[ $self->download_rule ]}";
    }

  }

  my $nick_name = 'build';

  if($self->meta_prop->{out_of_source})
  {
    $nick_name = 'extract';
    my $extract = $self->install_prop->{extract};
    return $extract if defined $extract && -d $extract;
  }

  my $tmp;
  local $CWD;
  my $ret;

  $self->_call_hook({

    before => sub {
      # called build instead of extract, because this
      # will be used for the build step, and technically
      # extract is a substage of build anyway.
      $tmp = Alien::Build::TempDir->new($self, $nick_name);
      $CWD = "$tmp";
    },
    verify => sub {

      my $path = '.';
      if($self->meta_prop->{out_of_source} && $self->install_prop->{extract})
      {
        $path = $self->install_prop->{extract};
      }

      my @list = grep { $_->basename !~ /^\./ && $_->basename ne 'pax_global_header' } _path($path)->children;

      my $count = scalar @list;

      if($count == 0)
      {
        die "no files extracted";
      }
      elsif($count == 1 && -d $list[0])
      {
        $ret = $list[0]->absolute->stringify;
      }
      else
      {
        $ret = "$tmp";
      }

    },
    after => sub {
      $CWD = $self->root;
    },

  }, 'extract', $archive);

  $self->install_prop->{extract} ||= $ret;
  $ret ? $ret : ();

lib/Alien/Build.pm  view on Meta::CPAN

sub default_hook
{
  my($self, $name, $instr) = @_;
  $self->{default_hook}->{$name} = _instr $self, $name, $instr;
  $self;
}


sub around_hook
{
  my($self, $name, $code) = @_;
  if(my $old = $self->{around}->{$name})
  {
    # this is the craziest shit I have ever
    # come up with.
    $self->{around}->{$name} = sub {
      my $orig = shift;
      $code->(sub { $old->($orig, @_) }, @_);
    };
  }
  else
  {
    $self->{around}->{$name} = $code;
  }
}


sub after_hook
{
  my($self, $name, $code) = @_;
  $self->around_hook(
    $name => sub {
      my $orig = shift;
      my $ret = $orig->(@_);
      $code->(@_);
      $ret;
    }
  );
}


sub before_hook
{
  my($self, $name, $code) = @_;
  $self->around_hook(
    $name => sub {
      my $orig = shift;
      $code->(@_);
      my $ret = $orig->(@_);
      $ret;
    }
  );
}


sub call_hook
{
  my $self = shift;
  my %args = ref $_[0] ? %{ shift() } : ();
  my($name, @args) = @_;
  my $error;

  my @hooks = @{ $self->{hook}->{$name} || []};

  if(@hooks == 0)
  {
    if(defined $self->{default_hook}->{$name})
    {
      @hooks = ($self->{default_hook}->{$name})
    }
    elsif(!$args{all})
    {
      Carp::croak "No hooks registered for $name";
    }
  }

  my $value;

  foreach my $hook (@hooks)
  {
    if(eval { $args[0]->isa('Alien::Build') })
    {
      %{ $args[0]->{hook_prop} } = (
        name => $name,
      );
    }

    my $wrapper = $self->{around}->{$name} || sub { my $code = shift; $code->(@_) };
    my $value;
    $args{before}->() if $args{before};
    if(ref($hook) eq 'CODE')
    {
      $value = eval {
        my $value = $wrapper->(sub { $hook->(@_) }, @args);
        $args{verify}->('code') if $args{verify};
        $value;
      };
    }
    else
    {
      $value = $wrapper->(sub {
        eval {
          $hook->execute(@_);
          $args{verify}->('command') if $args{verify};
        };
        defined $args{ok} ? $args{ok} : 1;
      }, @args);
    }
    $error = $@;
    $args{after}->() if $args{after};
    if($args{all})
    {
      die if $error;
    }
    else
    {
      next if $error;
      next if $args{continue} && $args{continue}->($value);
      return $value;
    }
  }

  die $error if $error && ! $args{all};

  $value;
}


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

  my $class;
  my $pm;
  my $found;

  if($name =~ /^=(.*)$/)
  {
    $class = $1;
    $pm    = "$class.pm";
    $pm    =~ s!::!/!g;
    $found = 1;
  }

  if($name !~ /::/ && !$found)
  {
    foreach my $inc (@INC)
    {
      # TODO: allow negotiators to work with @INC hooks
      next if ref $inc;
      my $file = Path::Tiny->new("$inc/Alien/Build/Plugin/$name/Negotiate.pm");
      if(-r $file)
      {
        $class = "Alien::Build::Plugin::${name}::Negotiate";
        $pm    = "Alien/Build/Plugin/$name/Negotiate.pm";
        $found = 1;
        last;
      }
    }
  }

  unless($found)
  {
    $class = "Alien::Build::Plugin::$name";
    $pm    = "Alien/Build/Plugin/$name.pm";
    $pm    =~ s{::}{/}g;
  }

  require $pm unless $class->can('new');
  my $plugin = $class->new(@args);
  $plugin->init($self);
  $self;
}

package Alien::Build::TempDir;

# TODO: it's confusing that there is both a AB::TempDir and AB::Temp
# although they do different things.  there could maybe be a better
# name for AB::TempDir (maybe AB::TempBuildDir, though that is a little
# redundant).  Happily both are private classes, and either are able to
# rename, if a good name can be thought of.

use overload '""' => sub { shift->as_string }, bool => sub { 1 }, fallback => 1;