view release on metacpan or  search on metacpan

inc/Inline/CPP.pm  view on Meta::CPAN

package Inline::CPP;

use strict;
use warnings;
use 5.008001;
use Fcntl qw( :DEFAULT :flock );

require Inline::C;
require Inline::CPP::Parser::RecDescent;
require Inline::CPP::Config;

# Note: Parse::RecDescent 'require'd within get_parser().

use Carp;

# use base doesn't work because Inline::C cannot be "use"d directly.
our @ISA = qw( Inline::C );    ## no critic (ISA)

# Development releases will have a _0xx version suffix.
# We eval the version number to accommodate dev. version numbering, as
# described in perldoc perlmodstyle.
our $VERSION = '0.68';
# $VERSION = eval $VERSION; ## no critic (eval)

my $TYPEMAP_KIND;
{
  no warnings 'once';          ## no critic (warnings)
  $TYPEMAP_KIND = $Inline::CPP::Parser::RecDescent::TYPEMAP_KIND;
}

#============================================================================
# Register Inline::CPP as an Inline language module
#============================================================================
sub register {
  use Config;
  return {
    language => 'CPP',
    aliases  => ['cpp', 'C++', 'c++', 'Cplusplus', 'cplusplus', 'CXX', 'cxx'],
    type     => 'compiled',
    suffix   => $Config{dlext},
  };
}    ### Tested.

#============================================================================
# Validate the C++ config options: Now mostly done in Inline::C
#============================================================================
sub validate {
  my ($o, @config_options) = @_;
  my ($flavor_defs, $iostream);

  {    # "used only once" warning. We know it's ok.
    no warnings 'once';    ## no critic (warnings)
    ## no critic (package variable)

    # Set default compiler and libraries.
    $o->{ILSM}{MAKEFILE}{CC}   ||= $Inline::CPP::Config::compiler;
    $o->{ILSM}{MAKEFILE}{LIBS} ||= _make_arrayref($Inline::CPP::Config::libs);

    $flavor_defs = $Inline::CPP::Config::cpp_flavor_defs;  # "Standard"?
    $iostream    = $Inline::CPP::Config::iostream_fn;      # iostream filename.
  }

  # I haven't traced it out yet, but $o->{STRUCT} gets set before getting
  # properly set from Inline::C's validate().
  $o->{STRUCT} ||= {'.macros' => q{}, '.any' => 0, '.xs' => q{}, '.all' => 0,};

  _build_auto_include($o, $flavor_defs, $iostream);

  $o->{ILSM}{PRESERVE_ELLIPSIS} = 0
    unless defined $o->{ILSM}{PRESERVE_ELLIPSIS};

  # Filter out the parameters we treat differently than Inline::C,
  # forwarding unknown requests back up to Inline::C.
  my @propagate = _handle_config_options($o, @config_options);
  $o->SUPER::validate(@propagate) if @propagate;

  return;
}


sub _build_auto_include {
  my ($o, $flavor_defs, $iostream) = @_;
  my $auto_include = <<'END';
#define __INLINE_CPP 1
#ifndef bool
#include <%iostream%>
#endif
extern "C" {
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "INLINE.h"
}
#ifdef bool
#undef bool
#include <%iostream%>
#endif

END

  $o->{ILSM}{AUTO_INCLUDE} ||= $auto_include;
  $o->{ILSM}{AUTO_INCLUDE} = $flavor_defs . $o->{ILSM}{AUTO_INCLUDE};

  # Replace %iostream% with the correct iostream library
  $o->{ILSM}{AUTO_INCLUDE} =~ s{%iostream%}{$iostream}xg;
  return;
}


sub _handle_config_options {
  my ($o, @config_options) = @_;
  my @propagate;

  while (@config_options) {
    my ($key, $value) = (shift @config_options, shift @config_options);
    $key = uc $key;
    if ($key eq 'NAMESPACE') {
      _handle_namespace_cfg_option($o, $value);
    }
    elsif ($key eq 'CLASSES') {
      _handle_classes_cfg_option($o, $value);
    }
    elsif ($key eq 'LIBS') {
      _handle_libs_cfg_option($o, $value);
    }
    elsif ($key eq 'ALTLIBS') {
      _handle_altlibs_cfg_option($o, $value);
    }
    elsif ($key eq 'PRESERVE_ELLIPSIS' or $key eq 'STD_IOSTREAM') {
      croak "Argument to $key must be 0 or 1"
        unless $value == 0 or $value == 1;
      $o->{ILSM}{$key} = $value;
    }
    else {
      push @propagate, $key, $value;

inc/Inline/CPP.pm  view on Meta::CPAN

}


sub call_or_instantiate {
  my ($name, $ctor, $dtor, $class, $const, $type, @args) = @_;

  # Create an rvalue (which might be const-casted later).
  my $rval = q{};
  $rval .= 'new '    if $ctor;
  $rval .= 'delete ' if $dtor;
  $rval .= 'THIS->'  if ($class and not($ctor or $dtor));
  $rval .= $name . '(' . join(q{,}, @args) . ')';

  return const_cast($rval, $const, $type) . ";\n";
}    ### Tested.

sub const_cast {
  my ($value, $const, $type) = @_;
  return $value unless $const and $type =~ m/[*&]/x;
  return "const_cast<$type>($value)";
}    ### Tested.

sub write_typemap {
  my $o         = shift;
  my $filename  = "$o->{API}{build_dir}/CPP.map";
  my $type_kind = $o->{ILSM}{typeconv}{type_kind};
  my $typemap   = q{};
  $typemap .= $_ . "\t" x 2 . $TYPEMAP_KIND . "\n"
    for grep { $type_kind->{$_} eq $TYPEMAP_KIND } keys %{$type_kind};
  return unless length $typemap;

  my $tm_output = <<"END";
TYPEMAP
$typemap
OUTPUT
$TYPEMAP_KIND
$o->{ILSM}{typeconv}{output_expr}{$TYPEMAP_KIND}
INPUT
$TYPEMAP_KIND
$o->{ILSM}{typeconv}{input_expr}{$TYPEMAP_KIND}
END


  # Open an output file, create if necessary, then lock, then truncate.
  # This replaces the following, which wasn't lock-safe:

  sysopen(my $TYPEMAP_FH, $filename, O_WRONLY | O_CREAT)
    or croak "Error: Can't write to $filename: $!";

  # Flock and truncate (truncating to zero length to simulate '>' mode).
  flock $TYPEMAP_FH, LOCK_EX
    or croak "Error: Can't obtain lock for $filename: $!";
  truncate $TYPEMAP_FH, 0 or croak "Error: Can't truncate $filename: $!";

  # End of new lock-safe code.

  print {$TYPEMAP_FH} $tm_output;

  close $TYPEMAP_FH or croak "Error: Can't close $filename after write: $!";

  $o->validate(TYPEMAPS => $filename);
  return;
}

# Generate type conversion code: perl2c or c2perl.
sub typeconv {
  my ($o, $var, $arg, $type, $dir, $preproc) = @_;
  my $tkind = $o->{ILSM}{typeconv}{type_kind}{$type};
  my $ret;
  {
    no strict;   ## no critic (strict)
                 # The conditional avoids uninitialized warnings if user passes
                 # a C++ function with 'void' as param.
    if (defined $tkind) {

      # eval of typemap gives "Uninit"
      no warnings 'uninitialized';    ## no critic (warnings)
          # Even without the conditional this line must remain.
      $ret = eval    ## no critic (eval)
        qq{qq{$o->{ILSM}{typeconv}{$dir}{$tkind}}};
    }
    else {
      $ret = q{};
    }
  }
  chomp $ret;
  $ret =~ s/\n/\\\n/xg if $preproc;
  return $ret;
}

# Verify that the return type and all arguments can be bound to Perl.
sub check_type {
  my ($o, $thing, $ctor, $dtor) = @_;
  my $badtype;

  # strip "useless" modifiers so the type is found in typemap:
BADTYPE: while (1) {
    if (!($ctor || $dtor)) {
      my $t = $thing->{rtype};
      $t =~ s/^(\s|const|virtual|static)+//xg;
      if ($t ne 'void' && !$o->typeconv(q{}, q{}, $t, 'output_expr')) {
        $badtype = $t;
        last BADTYPE;
      }
    }
    foreach (map { $_->{type} } @{$thing->{args}}) {
      s/^(?:const|\s)+//xgo;
      if ($_ ne '...' && !$o->typeconv(q{}, q{}, $_, 'input_expr')) {
        $badtype = $_;
        last BADTYPE;
      }
    }
    return 1;
  }

  # I don't really like this verbosity. This is what 'info' is for. Maybe we
  # should ask Brian for an Inline=DEBUG option.
  warn "No typemap for type $badtype. "
    . "Skipping $thing->{rtype} $thing->{name}("
    . join(', ', map { $_->{type} } @{$thing->{args}}) . ")\n"
    if 0;