view release on metacpan or  search on metacpan

lib/ExtUtils/XSpp/Node/Function.pm  view on Meta::CPAN

  my $state              = shift;

  my $out                = '';
  my $fname              = $this->perl_function_name;
  my $args               = $this->arguments;
  my $ret_type           = $this->ret_type;
  my $ret_typemap        = $this->{TYPEMAPS}{RET_TYPE};
  my $aliases            = $this->{ALIAS} || {};

  my $has_aliases = scalar(keys %$aliases);

  $out .= '#if ' . $this->emit_condition . "\n" if $this->emit_condition;

  my( $init, $arg_list, $call_arg_list, $code, $output, $cleanup,
      $postcall, $precall, $alias ) = ( ('') x 9 );

  # compute the precall code, XS argument list and C++ argument list using
  # the typemap information
  if( $args && @$args ) {
    my $has_self = $this->is_method ? 1 : 0;
    my( @arg_list, @call_arg_list );
    foreach my $i ( 0 .. $#$args ) {
      my $arg = ${$args}[$i];
      my $t   = $this->{TYPEMAPS}{ARGUMENTS}[$i];
      my $pc  = $t->precall_code( sprintf( 'ST(%d)', $i + $has_self ),
                                  $arg->name );

      push @arg_list, $t->cpp_type . ' ' . $arg->name .
                      ( $arg->has_default ? ' = ' . $arg->default : '' );

      my $call_code = $t->call_parameter_code( $arg->name );
      push @call_arg_list, defined( $call_code ) ? $call_code : $arg->name;
      $precall .= $pc . ";\n" if $pc
    }

    $arg_list = ' ' . join( ', ', @arg_list ) . ' ';
    $call_arg_list = ' ' . join( ', ', @call_arg_list ) . ' ';
  }

  # If there's %alias{foo = 123} definitions, generate ALIAS section
  if ($has_aliases) {
    # order by ordinal for consistent hash-order-independent output
    my @alias_list = map "    $_ = $aliases->{$_}\n",
                     sort {$aliases->{$a} <=> $aliases->{$b}}
                     keys %$aliases;
    $alias = "  ALIAS:\n" . join("", @alias_list);
  }

  my $retstr = $ret_typemap ? $ret_typemap->cpp_type : 'void';

  # special case: constructors with name different from 'new'
  # need to be declared 'static' in XS
  if( $this->isa( 'ExtUtils::XSpp::Node::Constructor' ) &&
      $this->perl_name ne $this->cpp_name ) {
    $retstr = "static $retstr";
  }

  my $has_ret = $ret_typemap && !$ret_typemap->type->is_void;

  my $ppcode = $has_ret && $ret_typemap->output_list( '' ) ? 1 : 0;
  my $code_type = $ppcode ? "PPCODE" : "CODE";
  my $ccode = $this->_call_code( $call_arg_list );
  if ($this->{CALL_CODE}) {
    $ccode = join( "\n", @{$this->{CALL_CODE}} );
  } elsif ($this->isa('ExtUtils::XSpp::Node::Destructor')) {
    $ccode = 'delete THIS';
    $has_ret = 0;
  } elsif( $has_ret && defined $ret_typemap->call_function_code( '', '' ) ) {
    $ccode = $ret_typemap->call_function_code( $ccode, 'RETVAL' );
  } elsif( $has_ret ) {
    if ($has_aliases) {
      $ccode = $this->_generate_alias_conditionals($call_arg_list, 1); # 1 == use RETVAL
    } else {
      $ccode = "RETVAL = $ccode";
    }
  } elsif( $has_aliases ) { # aliases but no RETVAL
    $ccode = $this->_generate_alias_conditionals($call_arg_list, 0); # 0 == no RETVAL
  }

  my @catchers = @{$this->{EXCEPTIONS}};
  $code .= "  $code_type:\n";
  $code .= "    try {\n" if @catchers;
  if ($precall) {
    $code .= '      ' . $precall;
  }
  $code .= (@catchers ? '  ' : '') . '    ' . $ccode . ";\n";
  if( $has_ret && defined $ret_typemap->output_code( '', '' ) ) {
    my $retcode = $ret_typemap->output_code( 'ST(0)', 'RETVAL' );
    $code .= '      ' . $retcode . ";\n";
  }
  if( $has_ret && defined $ret_typemap->output_list( '' ) ) {
    my $retcode = $ret_typemap->output_list( 'RETVAL' );
    $code .= '      ' . $retcode . ";\n";
  }
  $code .= "    }\n" if @catchers;
  foreach my $exception_handler (@catchers) {
    my $handler_code = $exception_handler->handler_code;
    $code .= $handler_code;
  }

  $output = "  OUTPUT: RETVAL\n" if $has_ret;

  if( $has_ret && defined $ret_typemap->cleanup_code( '', '' ) ) {
    $cleanup .= "  CLEANUP:\n";
    my $cleanupcode = $ret_typemap->cleanup_code( 'ST(0)', 'RETVAL' );
    $cleanup .= '    ' . $cleanupcode . ";\n";
  }

  if( $this->code ) {
    $code = "  $code_type:\n    " . join( "\n", @{$this->code} ) . "\n";
    $output = "  OUTPUT: RETVAL\n" if $code =~ m/\bRETVAL\b/;
  }
  if( $this->postcall ) {
    $postcall = "  POSTCALL:\n    " . join( "\n", @{$this->postcall} ) . "\n";
    $output ||= "  OUTPUT: RETVAL\n" if $has_ret;
  }
  if( $this->cleanup ) {
    $cleanup ||= "  CLEANUP:\n";
    my $clcode = join( "\n", @{$this->cleanup} );
    $cleanup .= "    $clcode\n";
  }