File Coverage

blib/lib/FFI/Build.pm

Criterion	Covered	Total	%
statement	164	202	81.1
branch	39	62	62.9
condition	11	18	61.1
subroutine	32	32	100.0
pod	14	14	100.0
total	260	328	79.2

package FFI::Build;

use strict;
use warnings;
use 5.008004;
use FFI::Build::Plugin;
use FFI::Build::PluginData qw( plugin_data );
use FFI::Build::File::Library;
use Carp ();
use File::Glob ();
use File::Basename ();
use List::Util 1.45 ();
use Capture::Tiny ();
use File::Path ();

# ABSTRACT: Build shared libraries for use with FFI
our $VERSION = '2.06_01'; # TRIAL VERSION

# Platypus-Man,
# Platypus-Man,
# Friendly Neighborhood Platypus-Man
# Is He Strong?
# Listen Bud
# He's got Proportional Strength of a Platypus
# Hey Man!
# There Goes The Platypus-Man


{
  my $plugins = FFI::Build::Plugin->new;
  # PLUGIN: require
  # ARGS: NONE
  $plugins->call('build-require');
  sub _plugins { $plugins ||= FFI::Build::Plugin->new };
}

sub import
{
  my @caller = caller;
  # PLUGIN: import
  # ARGS: @caller, \@args
  _plugins->call('build-import', \@caller, \@_);
}

sub _native_name
{
  my($self, $name) = @_;
  join '', $self->platform->library_prefix, $name, scalar $self->platform->library_suffix;
}

sub new
{
  my($class, $name, %args) = @_;

  Carp::croak "name is required" unless defined $name;

  # PLUGIN: new-pre
  # ARGS: $name, \%args
  _plugins->call('build-new-pre', $name, \%args);

  my $self = bless {
    source   => [],
    cflags_I => [],
    cflags   => [],
    libs_L   => [],
    libs     => [],
    alien    => [],
  }, $class;

  my $platform  = $self->{platform}  = $args{platform}  || FFI::Build::Platform->default;
  my $file      = $self->{file}      = $args{file}      || FFI::Build::File::Library->new([$args{dir} || '.', $self->_native_name($name)], platform => $self->platform);
  my $buildname = $self->{buildname} = $args{buildname} || '_build';
  my $verbose   = $self->{verbose}   = $args{verbose}   || 0;
  my $export    = $self->{export}    = $args{export}    || [];

  $self->{verbose} = $verbose = 2 if $ENV{V};

  if(defined $args{cflags})
  {
    my @flags = ref $args{cflags} ? @{ $args{cflags} } : $self->platform->shellwords($args{cflags});
    push @{ $self->{cflags}   }, grep !/^-I/, @flags;
    push @{ $self->{cflags_I} }, grep  /^-I/, @flags;
  }

  if(defined $args{libs})
  {
    my @flags = ref $args{libs} ? @{ $args{libs} } : $self->platform->shellwords($args{libs});
    push @{ $self->{libs} },   grep !/^-L/, @flags;
    push @{ $self->{libs_L} }, grep  /^-L/, @flags;
  }

  if(defined $args{alien})
  {
    my @aliens = ref $args{alien} ? @{ $args{alien} } : ($args{alien});
    foreach my $alien (@aliens)
    {
      unless(eval { $alien->can('cflags') && $alien->can('libs') })
      {
        my $pm = "$alien.pm";
        $pm =~ s/::/\//g;
        require $pm;
      }
      push @{ $self->{alien} }, $alien;
      push @{ $self->{cflags}   }, grep !/^-I/, $self->platform->shellwords($alien->cflags);
      push @{ $self->{cflags_I} }, grep  /^-I/, $self->platform->shellwords($alien->cflags);
      push @{ $self->{libs}     }, grep !/^-L/, $self->platform->shellwords($alien->libs);
      push @{ $self->{libs_L}   }, grep  /^-L/, $self->platform->shellwords($alien->libs);
    }
  }

  $self->source(ref $args{source} ? @{ $args{source} } : ($args{source})) if $args{source};

  # PLUGIN: new-post
  # ARGS: $self
  _plugins->call('build-new-post', $self);

  $self;
}


sub buildname { shift->{buildname} }
sub export    { shift->{export}    }
sub file      { shift->{file}      }
sub platform  { shift->{platform}  }
sub verbose   { shift->{verbose}   }
sub cflags    { shift->{cflags}    }
sub cflags_I  { shift->{cflags_I}  }
sub libs      { shift->{libs}      }
sub libs_L    { shift->{libs_L}    }
sub alien     { shift->{alien}     }

my @file_classes;
sub _file_classes
{
  unless(@file_classes)
  {
    if(defined $FFI::Build::VERSION)
    {
      foreach my $inc (@INC)
      {
        push @file_classes,
          map { my $f = $_; $f =~ s/\.pm$//; "FFI::Build::File::$f" }
          grep !/^Base\.pm$/,
          map { File::Basename::basename($_) }
          File::Glob::bsd_glob(
            File::Spec->catfile($inc, 'FFI', 'Build', 'File', '*.pm')
          );
      }
    }
    else
    {
      # When building out of git without dzil, $VERSION will not
      # usually be defined and any file plugins that require a
      # specific version will break, so we only use core file
      # classes for that.
      push @file_classes, map { "FFI::Build::File::$_" } qw( C CXX Library Object );
    }

    # also anything already loaded, that might not be in the
    # @INC path (for testing ususally)
    push @file_classes,
      map { my $f = $_; $f =~ s/::$//; "FFI::Build::File::$f" }
      grep !/Base::/,
      grep /::$/,
      keys %{FFI::Build::File::};

    @file_classes = List::Util::uniq(@file_classes);
    foreach my $class (@file_classes)
    {
      next if(eval { $class->can('new') });
      my $pm = $class . ".pm";
      $pm =~ s/::/\//g;
      require $pm;
    }
  }
  @file_classes;
}


sub source
{
  my($self, @file_spec) = @_;

  foreach my $file_spec (@file_spec)
  {
    if(eval { $file_spec->isa('FFI::Build::File::Base') })
    {
      push @{ $self->{source} }, $file_spec;
      next;
    }
    if(ref $file_spec eq 'ARRAY')
    {
      my($type, $content, @args) = @$file_spec;
      my $class = "FFI::Build::File::$type";
      unless($class->can('new'))
      {
        my $pm = "FFI/Build/File/$type.pm";
        require $pm;
      }
      push @{ $self->{source} }, $class->new(
        $content,
        build    => $self,
        platform => $self->platform,
        @args
      );
      next;
    }
    my @paths = File::Glob::bsd_glob($file_spec);
path:
    foreach my $path (@paths)
    {
      foreach my $class (_file_classes)
      {
        foreach my $regex ($class->accept_suffix)
        {
          if($path =~ $regex)
          {
            push @{ $self->{source} }, $class->new($path, platform => $self->platform, build => $self);
            next path;
          }
        }
      }
      Carp::croak("Unknown file type: $path");
    }
  }

  @{ $self->{source} };
}


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

  # PLUGIN: build
  # ARGS: $self
  _plugins->call('build-build', $self);

  my @objects;

  my $ld = $self->platform->ld;

  foreach my $source ($self->source)
  {
    # PLUGIN: build-item
    # ARGS: $self, $source
    _plugins->call('build-build-item', $self, $source);

    if($source->can('build_all'))
    {
      my $count = scalar $self->source;
      if($count == 1)
      {
        return $source->build_all($self->file);
      }
      else
      {
        die "@{[ ref $source ]} has build_all method, but there is not exactly one source";
      }
    }

    $ld = $source->ld if $source->ld;
    my $output;
    while(my $next = $source->build_item)
    {
      $ld = $next->ld if $next->ld;
      $output = $source = $next;
    }
    push @objects, $output;
  }

  my $needs_rebuild = sub {
    my(@objects) = @_;
    return 1 unless -f $self->file->path;
    my $target_time = [stat $self->file->path]->[9];
    foreach my $object (@objects)
    {
      my $object_time = [stat "$object"]->[9];
      return 1 if $object_time > $target_time;
    }
    return 0;
  };

  return $self->file unless $needs_rebuild->(@objects);

  File::Path::mkpath($self->file->dirname, 0, oct(755));

  my @cmd = (
    $ld,
    $self->libs_L,
    $self->platform->ldflags,
    (map { "$_" } @objects),
    $self->libs,
    $self->platform->flag_export(@{ $self->export }),
    $self->platform->flag_library_output($self->file->path),
  );

  # PLUGIN: build-link
  # ARGS: $self, \@cmd
  _plugins->call('build-build-link', $self, \@cmd);

  my($out, $exit) = Capture::Tiny::capture_merged(sub {
    $self->platform->run(@cmd);
  });

  if($exit || !-f $self->file->path)
  {
    print $out;
    die "error building @{[ $self->file->path ]} from @objects";
  }
  elsif($self->verbose >= 2)
  {
    print $out;
  }
  elsif($self->verbose >= 1)
  {
    print "LD @{[ $self->file->path ]}\n";
  }

  # PLUGIN: link-postlink
  # ARGS: $self, \@cmd
  _plugins->call('build-build-postlink', $self);

  $self->file;
}


sub clean
{
  my($self) = @_;
  my $dll = $self->file->path;
  if(-f $dll)
  {
    # PLUGIN: clean
    # ARGS: $self, $path
    _plugins->call('build-clean', $self, $dll);
    unlink $dll;
  }
  foreach my $source ($self->source)
  {
    my $dir = File::Spec->catdir($source->dirname, $self->buildname);
    if(-d $dir)
    {
      foreach my $path (File::Glob::bsd_glob("$dir/*"))
      {
        _plugins->call('build-clean', $self, $path);
        unlink $path;
      }
      _plugins->call('build-clean', $self, $dir);
      rmdir $dir;
    }
  }
}

1;

__END__