view release on metacpan or  search on metacpan

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

      }
      else
      {
        return $root;
      }
    };
  };

  if($args{source})
  {
    my $file = $get_temp_root->()->child('alienfile');
    $file->spew_utf8($args{source});
    $args{filename} = $file->stringify;
  }
  else
  {
    unless(defined $args{filename})
    {
      croak "You must specify at least one of filename or source";
    }
    $args{filename} = path($args{filename})->absolute->stringify;
  }

  $args{stage}  ||= $get_temp_root->('stage')->stringify;
  $args{prefix} ||= $get_temp_root->('prefix')->stringify;
  $args{root}   ||= $get_temp_root->('root')->stringify;

  require Alien::Build;

  _alienfile_clear();
  my $out = capture_merged {
    $build_targ = $args{targ};
    $build = Alien::Build->load($args{filename}, root => $args{root});
    $build->set_stage($args{stage});
    $build->set_prefix($args{prefix});
  };

  my $ctx = context();
  $ctx->note($out) if $out;
  $ctx->release;

  $build_alienfile = $args{filename};
  $build_root      = $temp;
  $build
}

sub _alienfile_clear
{
  eval { defined $build_root && -d $build_root && path($build_root)->remove_tree };
  undef $build;
  undef $build_alienfile;
  undef $build_root;
  undef $build_targ;
}


sub alienfile_ok
{
  my $build;
  my $name;
  my $error;

  if(@_ == 1 && ! defined $_[0])
  {
    $build = $_[0];
    $error = 'no alienfile given';
    $name = 'alienfile compiled';
  }
  elsif(@_ == 1 && eval { $_[0]->isa('Alien::Build') })
  {
    $build = $_[0];
    $name = 'alienfile compiled';
  }
  else
  {
    $build = eval { alienfile(@_) };
    $error = $@;
    $name = 'alienfile compiles';
  }

  my $ok = !! $build;

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag("error: $error") if $error;
  $ctx->release;

  $build;
}


sub alienfile_skip_if_missing_prereqs
{
  my($phase) = @_;

  if($build)
  {
    eval { $build->load_requires('configure', 1) };
    if(my $error = $@)
    {
      my $reason = "Missing configure prereq";
      if($error =~ /Required (.*) (.*),/)
      {
        $reason .= ": $1 $2";
      }
      my $ctx = context();
      $ctx->plan(0, SKIP => $reason);
      $ctx->release;
      return;
    }
    $phase ||= $build->install_type;
    eval { $build->load_requires($phase, 1) };
    if(my $error = $@)
    {
      my $reason = "Missing $phase prereq";
      if($error =~ /Required (.*) (.*),/)
      {
        $reason .= ": $1 $2";
      }
      my $ctx = context();
      $ctx->plan(0, SKIP => $reason);
      $ctx->release;
      return;
    }
  }
}


sub alien_install_type_is
{
  my($type, $name) = @_;

  croak "invalid install type" unless defined $type && $type =~ /^(system|share)$/;
  $name ||= "alien install type is $type";

  my $ok = 0;
  my @diag;

  if($build)
  {
    my($out, $actual) = capture_merged {
      $build->load_requires('configure');
      $build->install_type;
    };
    if($type eq $actual)
    {
      $ok = 1;
    }
    else
    {
      push @diag, "expected install type of $type, but got $actual";
    }
  }
  else
  {
    push @diag, 'no alienfile'
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->release;

  $ok;
}


sub alien_download_ok
{
  my($name) = @_;

  $name ||= 'alien download';

  my $ok;
  my $file;
  my @diag;
  my @note;

  if($build)
  {
    my($out, $error) = capture_merged {
      eval {
        $build->load_requires('configure');
        $build->load_requires($build->install_type);
        $build->download;
      };
      $@;
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out;
      push @diag, "extract threw exception: $error";
    }
    else
    {
      $file = $build->install_prop->{download};
      if(-d $file || -f $file)
      {
        $ok = 1;
        push @note, $out if defined $out;
      }
      else
      {
        $ok = 0;
        push @diag, $out if defined $out;
        push @diag, 'no file or directory';
      }
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->note($_) for @note;
  $ctx->diag($_) for @diag;
  $ctx->release;

  $file;
}


sub alien_extract_ok
{
  my($archive, $name) = @_;

  $name ||= $archive ? "alien extraction of $archive" : 'alien extraction';
  my $ok;
  my $dir;
  my @diag;
  my @note;

  if($build)
  {
    my($out, $error);
    ($out, $dir, $error) = capture_merged {
      my $dir = eval {
        $build->load_requires('configure');
        $build->load_requires($build->install_type);
        $build->download;
        $build->extract($archive);
      };
      ($dir, $@);
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out;
      push @diag, "extract threw exception: $error";
    }
    else
    {
      if(-d $dir)
      {
        $ok = 1;
        push @note, $out if defined $out;
      }
      else
      {
        $ok = 0;
        push @diag, $out if defined $out;
        push @diag, 'no directory';
      }
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->note($_) for @note;
  $ctx->diag($_) for @diag;
  $ctx->release;

  $dir;
}


my $count = 1;

sub alien_build_ok
{
  my $opt = defined $_[0] && ref($_[0]) eq 'HASH'
    ? shift : { class => 'Alien::Base' };

  my($name) = @_;

  $name ||= 'alien builds okay';
  my $ok;
  my @diag;
  my @note;
  my $alien;

  if($build)
  {
    my($out,$error) = capture_merged {
      eval {
        $build->load_requires('configure');
        $build->load_requires($build->install_type);
        $build->download;
        $build->build;
      };
      $@;
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out;
      push @diag, "build threw exception: $error";
    }
    else
    {
      $ok = 1;

      push @note, $out if defined $out;

      require Alien::Base;

      my $prefix = $build->runtime_prop->{prefix};
      my $stage  = $build->install_prop->{stage};
      my %prop   = %{ $build->runtime_prop };

      $prop{distdir} = $prefix;

      _mirror $stage, $prefix;

      my $dist_dir = sub {
        $prefix;
      };

      my $runtime_prop = sub {
        \%prop;
      };

      $alien = sprintf 'Test::Alien::Build::Faux%04d', $count++;
      {
        no strict 'refs';
        @{ "${alien}::ISA" }          = $opt->{class};
        *{ "${alien}::dist_dir" }     = $dist_dir;
        *{ "${alien}::runtime_prop" } = $runtime_prop;
      }
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->note($_) for @note;
  $ctx->release;

  $alien;
}


sub alien_build_clean
{
  my $ctx = context();
  if($build_root)
  {
    foreach my $child (path($build_root)->children)
    {
      next if $child->basename eq 'prefix';
      $ctx->note("clean: rm: $child");
      $child->remove_tree;
    }
  }
  else
  {
    $ctx->note("no build to clean");
  }
  $ctx->release;
}


sub alien_clean_install
{
  my($name) = @_;

  $name ||= "run clean_install";

  my $ok;
  my @diag;
  my @note;

  if($build)
  {
    my($out,$error) = capture_merged {
      eval {
        $build->clean_install;
      };
      $@;
    };
    if($error)
    {
      $ok = 0;
      push @diag, $out if defined $out && $out ne '';
      push @diag, "build threw exception: $error";
    }
    else
    {
      $ok = 1;
      push @note, $out if defined $out && $out ne '';
    }
  }
  else
  {
    $ok = 0;
    push @diag, 'no alienfile';
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->note($_) for @note;
  $ctx->release;
}


sub alien_checkpoint_ok
{
  my($name) = @_;

  $name ||= "alien checkpoint ok";
  my $ok;
  my @diag;

  if($build)
  {
    eval { $build->checkpoint };
    if($@)
    {
      push @diag, "error in checkpoint: $@";
      $ok = 0;
    }
    else
    {
      $ok = 1;
    }
    undef $build;
  }
  else
  {
    push @diag, "no build to checkpoint";
    $ok = 0;
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->release;

  $ok;
}


sub alien_resume_ok
{
  my($name) = @_;

  $name ||= "alien resume ok";
  my $ok;
  my @diag;

  if($build_alienfile && $build_root && !defined $build)
  {
    $build = eval { Alien::Build->resume($build_alienfile, "$build_root/root") };
    if($@)
    {
      push @diag, "error in resume: $@";
      $ok = 0;
    }
    else
    {
      $ok = 1;
    }
  }
  else
  {
    if($build)
    {
      push @diag, "build has not been checkpointed";
    }
    else
    {
      push @diag, "no build to resume";
    }
    $ok = 0;
  }

  my $ctx = context();
  $ctx->ok($ok, $name);
  $ctx->diag($_) for @diag;
  $ctx->release;

  ($ok && $build) || $ok;
}


my $alien_rc_root;

sub alien_rc
{
  my($code) = @_;

  croak "passed in undef rc" unless defined $code;
  croak "looks like you have already defined a rc.pl file" if $ENV{ALIEN_BUILD_RC} ne '-';

  my(undef, $filename, $line) = caller;
  my $code2 = "use strict; use warnings;\n" .
              '# line ' . $line . ' "' . path($filename)->absolute . "\n$code";

  $alien_rc_root ||= Alien::Build::Temp->newdir;

  my $rc = path($alien_rc_root)->child('rc.pl');
  $rc->spew_utf8($code2);
  $ENV{ALIEN_BUILD_RC} = "$rc";
  return 1;
}


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

  _alienfile_clear;

  my $ctx = context();
  my $pass = run_subtest($name, $code, { buffered => 1 }, @args);
  $ctx->release;