view release on metacpan or  search on metacpan

XSBuilder/WrapXS.pm  view on Meta::CPAN

    my $retdecl = @$retargs?(join "\n",
      (map { my $type = $self -> cname($_->{class}) ; $type =~ s/\*$//; '    ' . $type . " $_->{name};"} @$retargs), 
      #'    ' . $self -> cname($return_type) . ' RETVAL',
      ''):'';

    my($dispatch, $orig_args) =
      @{ $func } {qw(dispatch orig_args)};

    if ($dispatch =~ /^$myprefix/io) {
        $name =~ s/^$myprefix//;
        $name =~ s/^$func->{prefix}//;
        push @{ $self->{newXS}->{ $module } },
          ["$class\::$name", $dispatch];
        return;
    }

    my $passthru = @$args && $args->[0]->{name} eq '...';
    if ($passthru) {
        $parms = '...';
        $proto = '';
    }

    my $attrs = $self->attrs($name);

    my $code = <<EOF;
$return_type
$name($xs_parms)
EOF
    $code .= "$proto\n"  if ($proto) ;
    $code .= "$attrs\n"  if ($attrs) ;
    $code .= "PREINIT:\n$retdecl" if ($retdecl) ;

    if ($dispatch || $orig_args) {
        my $thx = "";

        if ($dispatch) {
            $thx = 'aTHX_ ' if $dispatch =~ /^$myprefix/i;
            if ($orig_args && !$func -> {dispatch_argspec}) {
                $parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args;
            }
        }
        else {
            ### ??? gr ### if ($orig_args and @$orig_args == @$args) {
            if ($orig_args && @$orig_args) {
                #args were reordered
                $parms = join ', ',  map { $retargs{$_}?"&$_":$_} @$orig_args;
            }

            $dispatch = $func->{name};
        }

        if ($passthru) {
            $thx ||= 'aTHX_ ';
            $parms = 'items, MARK+1, SP';
        }

        my $retval = $return_type eq 'void' ?
          ["", ""] : ["RETVAL = ", "OUTPUT:\n    RETVAL\n"];

        my $retnum = $retdecl?scalar(@$retargs) + ($return_type eq 'void' ?0:1):0 ;
        $code .= $retdecl?"PPCODE:":"CODE:" ;
        $code .= "\n    $retval->[0]$dispatch($thx$parms);\n" ;
        if ($retdecl) {
            my $retclass = $self -> typemap -> map_class ($return_type) || $return_type ;
            if ($retclass =~ / /) 
                {
                print "ERROR: return class '$retclass' contains spaces" ;
                }
            $code .= "    XSprePUSH;\n" ;
            $code .= "    EXTEND(SP, $retnum) ;\n" ;
            $code .= '    PUSHs(' . $self -> convert_2obj ($retclass, 'RETVAL') . ") ;\n" ;
            foreach (@$retargs) {
                if ($_->{class} =~ / /) 
                    {
                    print "ERROR: $_->{class} contains spaces; retargs = ", Dumper ($_) ;
                    }
                $code .= '    PUSHs(' . $self -> convert_2obj ($_->{class}, $_->{name}) . ") ;\n" ;
            }
        }
        else {
            $code .= "$retval->[1]\n" ;
        }
    }

    $code .= "\n" ;

    $func->{code} = $code;
    push @{ $self->{XS}->{ $module } }, $func;
}

# ============================================================================


sub get_functions {
    my $self = shift;

    my $typemap = $self->typemap;
    my %seen ;
    for my $entry (@{ $self->function_list() }) {
        #print "get_func ", Dumper ($entry) ;
        my $func = $typemap->map_function($entry);
        #print "FAILED to map $entry->{name}\n" unless $func;
        next unless $func;
        print "WARNING: Duplicate function: $entry->{name}\n" if ($seen{$entry->{name}}++) ;
        $self -> get_function ($func) ;
    }
}


# ============================================================================

sub get_value {
    my $e = shift;
    my $val = 'val';

    if ($e->{class} eq 'PV') {
        if (my $pool = $e->{pool}) {
            $pool .= '(obj)';
            $val = "((ST(1) == &PL_sv_undef) ? NULL :
                    apr_pstrndup($pool, val, val_len))"
        }