view release on metacpan or  search on metacpan

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

    my $offset = scalar @args;             # which is the first optional?
    my $total  = $offset + scalar @opts;
    for my $i ($offset .. $total - 1) {
      push @CODE, 'case ' . ($i + 1) . ":\n";
      my @tmp;
      for my $j ($offset .. $i) {
        my $targ = $opts[$j - $offset]{name};
        my $type = $opts[$j - $offset]{type};
        my $src  = "ST($j)";
        my $conv = $o->typeconv($targ, $src, $type, 'input_expr');
        push @CODE, $conv . ";\n";
        push @tmp,  $targ;
      }
      push @CODE, "\tRETVAL = " unless $void;
      push @CODE,
        call_or_instantiate($name, $ctor, $dtor, $class, $thing->{rconst},
        $thing->{rtype}, (map { $_->{name} } @args), @tmp);
      push @CODE, "\tbreak; /* case " . ($i + 1) . " */\n";
    }
    push @CODE, "default:\n";
    push @CODE, "\tRETVAL = " unless $void;
    push @CODE,
      call_or_instantiate($name, $ctor, $dtor, $class, $thing->{rconst},
      $thing->{rtype}, map { $_->{name} } @args);
    push @CODE, "} /* switch(items) */ \n";
  }
  elsif ($void) {
    push @CODE, "\t";
    push @CODE,
      call_or_instantiate($name, $ctor, $dtor, $class, 0, q{},
      map { $_->{name} } @args);
  }
  elsif ($ellipsis or $thing->{rconst}) {
    push @CODE, "\t";
    push @CODE, 'RETVAL = ';
    push @CODE,
      call_or_instantiate($name, $ctor, $dtor, $class, $thing->{rconst},
      $thing->{rtype}, map { $_->{name} } @args);
  }
  if ($void) {
    push @CODE, <<'END';
        if (PL_markstack_ptr != __temp_markstack_ptr) {
          /* truly void, because dXSARGS not invoked */
          PL_markstack_ptr = __temp_markstack_ptr;
          XSRETURN_EMPTY; /* return empty stack */
        }
        /* must have used dXSARGS; list context implied */
        return; /* assume stack size is correct */
END
  }
  elsif ($ellipsis) {
    push @CODE, "\tPL_markstack_ptr = __temp_markstack_ptr;\n";
  }

  # The actual function:
  local $" = q{};
  push @XS, "${t}PREINIT:\n@PREINIT" if @PREINIT;
  push @XS, $t;
  push @XS, 'PP' if $void and @CODE;
  push @XS, "CODE:\n@CODE" if @CODE;
  push @XS, "${t}OUTPUT:\nRETVAL\n" if @CODE and not $void;
  push @XS, "\n";
  return "@XS";
}


sub _map_subnames_cpp_to_perl {
  my ($thing, $name, $class) = @_;
  my ($XS, $ctor, $dtor) = (q{}, 0, 0);

  if ($name eq $class) {    # ctor
    $XS   = $class . " *\n" . $class . '::new';
    $ctor = 1;
  }
  elsif ($name eq "~$class") {    # dtor
    $XS   = "void\n$class" . '::DESTROY';
    $dtor = 1;
  }
  elsif ($class) {                # method
    $XS = "$thing->{rtype}\n$class" . "::$thing->{name}";
  }
  else {                          # function
    $XS = "$thing->{rtype}\n$thing->{name}";
  }
  return ($XS, $ctor, $dtor);
}


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)) {