view release on metacpan or  search on metacpan

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

# 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

      for my $thing (sort { $a->{name} cmp $b->{name} }
        @{$data->{class}{$class}})
      {
        my ($name, $scope, $type) = @{$thing}{qw(name scope thing)};
        next unless $scope eq 'public' and $type eq 'method';
        next
          unless $o->check_type($thing, $name eq $class, $name eq "~$class",);
        my $rtype = $thing->{rtype} || q{};
        push @class, "\t\t$rtype" . ($rtype ? q{ } : q{});
        push @class, $class . "::$name(";
        my @args = grep { $_->{name} ne '...' } @{$thing->{args}};
        my $ellipsis = (scalar @{$thing->{args}} - scalar @args) != 0;
        push @class, join ', ', (map {"$_->{type} $_->{name}"} @args),
          $ellipsis ? '...' : ();
        push @class, ");\n";
      }
      push @class, "\t};\n";
    }
  }
  if (defined $data->{functions}) {
    for my $function (sort @{$data->{functions}}) {
      my $func = $data->{function}{$function};
      next if $function =~ m/::/x;
      next unless $o->check_type($func, 0, 0);
      push @func, "\t" . $func->{rtype} . q{ };
      push @func, $func->{name} . '(';
      my @args = grep { $_->{name} ne '...' } @{$func->{args}};
      my $ellipsis = (scalar @{$func->{args}} - scalar @args) != 0;
      push @func, join ', ', (map {"$_->{type} $_->{name}"} @args),
        $ellipsis ? '...' : ();
      push @func, ");\n";
    }
  }

  # Report:
  {
    local $" = q{};
    $info .= "The following classes have been bound to Perl:\n@class\n"
      if @class;
    $info .= "The following functions have been bound to Perl:\n@func\n"
      if @func;
  }
  $info .= Inline::Struct::info($o) if $o->{STRUCT}{'.any'};
  return $info;
}

#============================================================================
# Generate a C++ parser
#============================================================================
sub get_parser {
  my $o = shift;
  return Inline::CPP::Parser::RecDescent::get_parser_recdescent($o);
}

#============================================================================
# Intercept xs_generate and create the typemap file
#============================================================================
sub xs_generate {
  my $o = shift;
  $o->write_typemap;
  return $o->SUPER::xs_generate;
}

#============================================================================
# Return bindings for functions and classes
#============================================================================
sub xs_bindings {
  my $o = shift;

  # What is modfname, and why are we taking it from a slice but not using it?
  my ($pkg, $module) = @{$o->{API}}{qw(pkg module)};
  my $data = $o->{ILSM}{parser}{data};
  my @XS;

  warn "Warning: No Inline C++ functions or classes bound to Perl\n"
    . "Check your C++ for Inline compatibility.\n\n"
    if !defined $data->{classes} && !defined $data->{functions} && $^W;
  for my $class (@{$data->{classes}}) {
    my $proper_pkg;

    # Possibly override package and class names
    if (exists $o->{API}{classes_override}) {
      my $ref_classes_override = ref($o->{API}{classes_override});
      if ($ref_classes_override eq 'HASH') {
        if (exists $o->{API}{classes_override}->{$class})
        {    # Override class name only
          $proper_pkg = $pkg . '::' . $o->{API}{classes_override}->{$class};
        }
        else {
          # Do not override package or class names
          $proper_pkg = $pkg . '::' . $class;
        }
      }
      elsif ($ref_classes_override eq 'CODE')
      {
        # Override both package and class names
        $proper_pkg = &{$o->{API}{classes_override}}($class);
        if   ($proper_pkg eq '') { $proper_pkg = 'main'; }
      }
    }
    else {        # Do not override package or class names
      $proper_pkg = $pkg . '::' . $class;
    }

    # Strip main:: from packages.  There cannot be a package main::Foo!
    $proper_pkg =~ s/^main::(.+)/$1/;

    # Set up the proper namespace
    push @XS, _build_namespace($module, $proper_pkg);
    push @XS, _generate_member_xs_wrappers($o, $pkg, $class, $proper_pkg);
  }

  push @XS, _remove_xs_prefixes($o, $module, $pkg);
  push @XS, _generate_nonmember_xs_wrappers($o);

  for (@{$data->{enums}}) {

    # Global enums.
    $o->{ILSM}{XS}{BOOT} .= make_enum($pkg, @{$_}{qw( name body )});
  }
  return join q{}, @XS;