File Coverage

blib/lib/FFI/TinyCC.pm

Criterion	Covered	Total	%
statement	127	162	78.4
branch	24	54	44.4
condition	1	9	11.1
subroutine	32	35	91.4
pod	15	15	100.0
total	199	275	72.3

package FFI::TinyCC;

use strict;
use warnings;
use 5.008001;
use Config;
use FFI::Platypus;
use FFI::Platypus::Memory qw( malloc free );
use Carp qw( croak carp );
use File::Spec;
use File::ShareDir::Dist qw( dist_share );

# ABSTRACT: Tiny C Compiler for FFI
our $VERSION = '0.30'; # VERSION


sub _dlext ()
{
  $^O eq 'MSWin32' ? 'dll' : $Config{dlext};
}

our $ffi = FFI::Platypus->new;
$ffi->lib(
  File::Spec->catfile(dist_share( 'FFI-TinyCC' ), 'libtcc.' . _dlext)
);

$ffi->custom_type( tcc_t => {
  perl_to_native => sub {
    $_[0]->{handle},
  },

  native_to_perl => sub {
    {
      handle   => $_[0],
      relocate => 0,
      error    => [],
    };
  },

});

do {
  my %output_type = qw(
    memory 0
    exe    1
    dll    2
    obj    3
  );

  $ffi->custom_type( output_t => {
    native_type => 'int',
    perl_to_native => sub { $output_type{$_[0]} },
  });
};

$ffi->type('int' => 'error_t');
$ffi->type('(opaque,string)->void' => 'error_handler_t');

$ffi->attach([tcc_new             => '_new']             => []                                     => 'tcc_t');
$ffi->attach([tcc_delete          => '_delete']          => ['tcc_t']                              => 'void');
$ffi->attach([tcc_set_error_func  => '_set_error_func']  => ['tcc_t', 'opaque', 'error_handler_t'] => 'void');
$ffi->attach([tcc_add_symbol      => '_add_symbol']      => ['tcc_t', 'string', 'opaque']          => 'int');
$ffi->attach([tcc_get_symbol      => '_get_symbol']      => ['tcc_t', 'string']                    => 'opaque');
$ffi->attach([tcc_relocate        => '_relocate']        => ['tcc_t', 'opaque']                    => 'int');
$ffi->attach([tcc_run             => '_run']             => ['tcc_t', 'int', 'opaque']             => 'int');

sub _method ($;@)
{
  my($name, @args) = @_;
  $ffi->attach(["tcc_$name" => "_$name"] => ['tcc_t', @args] => 'error_t');
  eval  '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) .qq{
    sub $name
    {
      my \$r = _$name (\@_);
      die FFI::TinyCC::Exception->new(\$_[0]) if \$r == -1;
      \$_[0];
    }
  };
  die $@ if $@;
}


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

  my $self = bless _new(), $class;

  $self->{error_cb} = $ffi->closure(sub {
    push @{ $self->{error} }, $_[1];
  });
  _set_error_func($self, undef, $self->{error_cb});

  if($^O eq 'MSWin32')
  {
    require File::Basename;
    require File::Spec;
    my $path = File::Spec->catdir(File::Basename::dirname($ffi->lib), 'lib');
    $self->add_library_path($path);
  }

  $self->{no_free_store} = 1 if $opt{_no_free_store};

  $self;
}

sub _error
{
  my($self, $msg) = @_;
  push @{ $self->{error} }, $msg;
  $self;
}

if(defined ${^GLOBAL_PHASE})
{
  *DESTROY = sub
  {
    my($self) = @_;
    return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
    _delete($self);
    # TODO: should we do this?
    free($self->{store});
  }
}
else
{
  require Devel::GlobalDestruction;
  *DESTROY = sub
  {
    my($self) = @_;
    return if Devel::GlobalDestruction::in_global_destruction();
    _delete($self);
    # TODO: should we do this?
    free($self->{store});
  }
}


_method set_options => qw( string );


_method add_file => qw( string );


_method compile_string => qw( string );


sub add_symbol
{
  my($self, $name, $ptr) = @_;
  my $r;
  $r = _add_symbol($self, $name, $ptr);
  die FFI::TinyCC::Exception->new($self) if $r == -1;
  $self;
}


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

  my @path_list;

  if($^O eq 'MSWin32')
  {
    require File::Spec;
    push @path_list, File::Spec->catdir(dist_share('Alien-TinyCC'), 'include');
  }
  elsif($Config{incpth})
  {
    require Alien::TinyCC;
    require File::Spec;
    push @path_list, File::Spec->catdir(Alien::TinyCC->libtcc_library_path, qw( tcc include ));
    push @path_list, split /\s+/, $Config{incpth};
  }
  elsif($Config{ccname} eq 'gcc')
  {
    require File::Temp;
    my($fh, $filename) = File::Temp::tempfile( "tryXXXX", SUFFIX => '.c', UNLINK => 1 );
    close $fh;

    my @lines = `$Config{cpprun} -v $filename 2>&1`;

    shift @lines while defined $lines[0] && $lines[0] !~ /^#include
    shift @lines;
    pop @lines while defined $lines[-1] && $lines[-1] !~ /^End of search /;
    pop @lines;

    croak "Cannot detect sysinclude path" unless @lines;

    require Alien::TinyCC;
    require File::Spec;

    push @path_list, File::Spec->catdir(Alien::TinyCC->libtcc_library_path, qw( tcc include ));
    push @path_list, map { chomp; s/^ //; $_ } @lines;
  }
  else
  {
    croak "Cannot detect sysinclude path";
  }

  croak "Cannot detect sysinclude path" unless grep { -d $_ } @path_list;

  $self->add_sysinclude_path($_) for @path_list;

  @path_list;
}



_method add_include_path => qw( string );


_method add_sysinclude_path => qw( string );


_method set_lib_path => qw( string );


$ffi->attach([tcc_define_symbol=>'define_symbol'] => ['tcc_t', 'string', 'string'] => 'void');


$ffi->attach([tcc_undefine_symbol=>'undefine_symbol'] => ['tcc_t', 'string', 'string'] => 'void');


_method set_output_type => qw( output_t );


_method add_library => qw( string );


_method add_library_path => qw( string );


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

  croak "unable to use run method after get_symbol" if $self->{relocate};

  my $argc = scalar @args;
  my @c_strings = map { "$_\0" } @args;
  my $ptrs = pack 'P' x $argc, @c_strings;
  my $argv = unpack('L!', pack('P', $ptrs));

  my $r = _run($self, $argc, $argv);
  die FFI::TinyCC::Exception->new($self) if $r == -1;
  $r;
}


sub get_symbol
{
  my($self, $symbol_name) = @_;

  unless($self->{relocate})
  {
    my $size = _relocate($self, undef);
    $self->{store} = malloc($size);
    my $r = _relocate($self, $self->{store});
    die FFI::TinyCC::Exception->new($self) if $r == -1;
    $self->{relocate} = 1;
  }
  _get_symbol($self, $symbol_name);
}


_method output_file => qw( string );

package
  FFI::TinyCC::Exception;

use overload '""' => sub {
  my $self = shift;
  if(@{ $self->{fault} } == 2)
  {
    join(' ', $self->as_string,
      at => $self->{fault}->[0],
      line => $self->{fault}->[1],
    );
  }
  else
  {
    $self->as_string . "\n";
  }
};
use overload fallback => 1;

sub new
{
  my($class, $tcc) = @_;

  my @errors = @{ $tcc->{error} };
  $tcc->{errors} = [];
  my @stack;
  my @fault;

  my $i=2;
  while(my @frame = caller($i++))
  {
    push @stack, \@frame;
    if(@fault == 0 && $frame[0] !~ /^FFI::TinyCC/)
    {
      @fault = ($frame[1], $frame[2]);
    }
  }

  my $self = bless {
    errors => \@errors,
    stack  => \@stack,
    fault  => \@fault,
  }, $class;

  $self;
}

sub errors { shift->{errors} }

sub as_string
{
  my($self) = @_;
  join "\n", @{ $self->{errors} };
}

1;

__END__