view release on metacpan or  search on metacpan

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

        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;
}


# Set up the proper namespace.
sub _build_namespace {
  my ($module, $proper_pkg) = @_;