view release on metacpan or  search on metacpan

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

        : ''
    );

    my $prototypes = defined($o->{CONFIG}{PROTOTYPES})
        ? $o->{CONFIG}{PROTOTYPES}
        : 'DISABLE';

    my $XS = <<END;

MODULE = $module  PACKAGE = $pkg  $prefix

PROTOTYPES: $prototypes

END

    my $parser = $o->{ILSM}{parser};
    my $data = $parser->{data};

    warn(
        "Warning. No Inline C functions bound to Perl in ", $o->{API}{script},
        "\n" .
         "Check your C function definition(s) for Inline compatibility\n\n"
    ) if ((not defined$data->{functions}) and ($^W));

    for my $function (@{$data->{functions}}) {
        my $return_type = $data->{function}->{$function}->{return_type};
        my @arg_names = @{$data->{function}->{$function}->{arg_names}};
        my @arg_types = @{$data->{function}->{$function}->{arg_types}};

        $XS .= join '', (
            "\n$return_type\n$function (",
            join(', ', @arg_names), ")\n"
        );

        for my $arg_name (@arg_names) {
            my $arg_type = shift @arg_types;
            last if $arg_type eq '...';
            $XS .= "\t$arg_type\t$arg_name\n";
        }

        my %h;
        if (defined($o->{CONFIG}{PROTOTYPE})) {
            %h = %{$o->{CONFIG}{PROTOTYPE}};
        }

        if (defined($h{$function})) {
            $XS .= "  PROTOTYPE: $h{$function}\n";
        }

        my $listargs = '';
        $listargs = pop @arg_names
            if (@arg_names and $arg_names[-1] eq '...');
        my $arg_name_list = join(', ', @arg_names);

        if ($return_type eq 'void') {
            if ($o->{CONFIG}{_TESTING}) {
                $XS .= <<END;
        PREINIT:
        PerlIO* stream;
        I32* temp;
        PPCODE:
        temp = PL_markstack_ptr++;
        $function($arg_name_list);
      stream = PerlIO_open(\"$dir/void_test\", \"a\");
      if (stream == NULL) warn(\"%s\\n\", \"Unable to open $dir/void_test for appending\");
        if (PL_markstack_ptr != temp) {
          PerlIO_printf(stream, \"%s\\n\", \"TRULY_VOID\");
          PerlIO_close(stream);
          PL_markstack_ptr = temp;
          XSRETURN_EMPTY; /* return empty stack */
        }
        PerlIO_printf(stream, \"%s\\n\", \"LIST_CONTEXT\");
        PerlIO_close(stream);
        return; /* assume stack size is correct */
END
            }
            else {
                $XS .= <<END;
        PREINIT:
        I32* temp;
        PPCODE:
        temp = PL_markstack_ptr++;
        $function($arg_name_list);
        if (PL_markstack_ptr != temp) {
          /* truly void, because dXSARGS not invoked */
          PL_markstack_ptr = temp;
          XSRETURN_EMPTY; /* return empty stack */
        }
        /* must have used dXSARGS; list context implied */
        return; /* assume stack size is correct */
END
            }
        }
        elsif ($listargs) {
            $XS .= <<END;
        PREINIT:
        I32* temp;
        CODE:
        temp = PL_markstack_ptr++;
        RETVAL = $function($arg_name_list);
        PL_markstack_ptr = temp;
        OUTPUT:
        RETVAL
END
        }
    }
    $XS .= "\n";
    return $XS;
}

#==============================================================================
# Generate the INLINE.h file.
#==============================================================================
sub write_Inline_headers {
    my $o = shift;

    open HEADER, "> ".File::Spec->catfile($o->{API}{build_dir},"INLINE.h")
        or croak;

    print HEADER <<'END';
#define Inline_Stack_Vars dXSARGS
#define Inline_Stack_Items items
#define Inline_Stack_Item(x) ST(x)
#define Inline_Stack_Reset sp = mark
#define Inline_Stack_Push(x) XPUSHs(x)
#define Inline_Stack_Done PUTBACK
#define Inline_Stack_Return(x) XSRETURN(x)
#define Inline_Stack_Void XSRETURN(0)

#define INLINE_STACK_VARS Inline_Stack_Vars
#define INLINE_STACK_ITEMS Inline_Stack_Items
#define INLINE_STACK_ITEM(x) Inline_Stack_Item(x)
#define INLINE_STACK_RESET Inline_Stack_Reset
#define INLINE_STACK_PUSH(x) Inline_Stack_Push(x)
#define INLINE_STACK_DONE Inline_Stack_Done
#define INLINE_STACK_RETURN(x) Inline_Stack_Return(x)
#define INLINE_STACK_VOID Inline_Stack_Void

#define inline_stack_vars Inline_Stack_Vars
#define inline_stack_items Inline_Stack_Items
#define inline_stack_item(x) Inline_Stack_Item(x)