SOOT
view release on metacpan or search on metacpan
inc/inc_ExtUtils-ParseXS/ExtUtils/ParseXS.pm view on Meta::CPAN
}
else {
@args = split(/\s*,\s*/, $orig_args);
Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split");
}
}
else {
@args = split(/\s*,\s*/, $orig_args);
for (@args) {
if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
my $out_type = $1;
next if $out_type eq 'IN';
$only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST";
if ($out_type =~ /OUTLIST$/) {
push @{ $outlist_ref }, undef;
}
$self->{in_out}->{$_} = $out_type;
}
}
}
if (defined($class)) {
my $arg0 = ((defined($static) or $func_name eq 'new')
? "CLASS" : "THIS");
unshift(@args, $arg0);
}
my $extra_args = 0;
my @args_num = ();
my $num_args = 0;
my $report_args = '';
my $ellipsis;
foreach my $i (0 .. $#args) {
if ($args[$i] =~ s/\.\.\.//) {
$ellipsis = 1;
if ($args[$i] eq '' && $i == $#args) {
$report_args .= ", ...";
pop(@args);
last;
}
}
if ($only_C_inlist_ref->{$args[$i]}) {
push @args_num, undef;
}
else {
push @args_num, ++$num_args;
$report_args .= ", $args[$i]";
}
if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
$extra_args++;
$args[$i] = $1;
$self->{defaults}->{$args[$i]} = $2;
$self->{defaults}->{$args[$i]} =~ s/"/\\"/g;
}
$self->{proto_arg}->[$i+1] = '$';
}
my $min_args = $num_args - $extra_args;
$report_args =~ s/"/\\"/g;
$report_args =~ s/^,\s+//;
$self->{func_args} = assign_func_args($self, \@args, $class);
@{ $self->{args_match} }{@args} = @args_num;
my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} });
my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} });
# Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
# to set explicit return values.
my $EXPLICIT_RETURN = ($CODE &&
("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
# The $ALIAS which follows is only explicitly called within the scope of
# process_file(). In principle, it ought to be a lexical, i.e., 'my
# $ALIAS' like the other nearby variables. However, implementing that
# change produced a slight difference in the resulting .c output in at
# least two distributions: B/BD/BDFOY/Crypt-Rijndael and
# G/GF/GFUJI/Hash-FieldHash. The difference is, arguably, an improvement
# in the resulting C code. Example:
# 388c388
# < GvNAME(CvGV(cv)),
# ---
# > "Crypt::Rijndael::encrypt",
# But at this point we're committed to generating the *same* C code that
# the current version of ParseXS.pm does. So we're declaring it as 'our'.
$ALIAS = grep(/^\s*ALIAS\s*:/, @{ $self->{line} });
my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} });
$xsreturn = 1 if $EXPLICIT_RETURN;
$externC = $externC ? qq[extern "C"] : "";
# print function header
print Q(<<"EOF");
#$externC
#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS(XS_${Full_func_name})
#[[
##ifdef dVAR
# dVAR; dXSARGS;
##else
# dXSARGS;
##endif
EOF
print Q(<<"EOF") if $ALIAS;
# dXSI32;
EOF
print Q(<<"EOF") if $INTERFACE;
# dXSFUNCTION($self->{ret_type});
EOF
$self->{cond} = set_cond($ellipsis, $min_args, $num_args);
print Q(<<"EOF") if $self->{except};
# char errbuf[1024];
# *errbuf = '\0';
EOF
if($self->{cond}) {
print Q(<<"EOF");
# if ($self->{cond})
# croak_xs_usage(cv, "$report_args");
EOF
}
else {
# cv likely to be unused
print Q(<<"EOF");
# PERL_UNUSED_VAR(cv); /* -W */
EOF
}
#gcc -Wall: if an xsub has PPCODE is used
#it is possible none of ST, XSRETURN or XSprePUSH macros are used
#hence `ax' (setup by dXSARGS) is unused
#XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
#but such a move could break third-party extensions
print Q(<<"EOF") if $PPCODE;
# PERL_UNUSED_VAR(ax); /* -Wall */
EOF
print Q(<<"EOF") if $PPCODE;
# SP -= items;
EOF
# Now do a block of some sort.
$self->{condnum} = 0;
$self->{cond} = ''; # last CASE: conditional
push(@{ $self->{line} }, "$END:");
push(@{ $self->{line_no} }, $self->{line_no}->[-1]);
$_ = '';
check_conditional_preprocessor_statements();
while (@{ $self->{line} }) {
$self->CASE_handler($_) if $self->check_keyword("CASE");
print Q(<<"EOF");
# $self->{except} [[
EOF
# do initialization of input variables
$self->{thisdone} = 0;
$self->{retvaldone} = 0;
$self->{deferred} = "";
%{ $self->{arg_list} } = ();
$self->{gotRETVAL} = 0;
$self->INPUT_handler($_);
$self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
print Q(<<"EOF") if $self->{ScopeThisXSUB};
# ENTER;
# [[
EOF
if (!$self->{thisdone} && defined($class)) {
if (defined($static) or $func_name eq 'new') {
print "\tchar *";
$self->{var_types}->{"CLASS"} = "char *";
generate_init( {
type => "char *",
num => 1,
var => "CLASS",
printed_name => undef,
} );
}
else {
print "\t$class *";
$self->{var_types}->{"THIS"} = "$class *";
generate_init( {
type => "$class *",
num => 1,
var => "THIS",
printed_name => undef,
} );
}
}
my ($wantRETVAL);
# do code
if (/^\s*NOT_IMPLEMENTED_YET/) {
print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
$_ = '';
}
else {
if ($self->{ret_type} ne "void") {
print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n"
if !$self->{retvaldone};
$self->{args_match}->{"RETVAL"} = 0;
$self->{var_types}->{"RETVAL"} = $self->{ret_type};
my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
print "\tdXSTARG;\n"
if $self->{optimize} and $outputmap and $outputmap->targetable;
}
if (@fake_INPUT or @fake_INPUT_pre) {
unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_;
$_ = "";
$self->{processing_arg_with_types} = 1;
$self->INPUT_handler($_);
}
print $self->{deferred};
$self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
if ($self->check_keyword("PPCODE")) {
$self->print_section();
$self->death("PPCODE must be last thing") if @{ $self->{line} };
print "\tLEAVE;\n" if $self->{ScopeThisXSUB};
print "\tPUTBACK;\n\treturn;\n";
}
elsif ($self->check_keyword("CODE")) {
$self->print_section();
}
elsif (defined($class) and $func_name eq "DESTROY") {
print "\n\t";
print "delete THIS;\n";
}
else {
print "\n\t";
if ($self->{ret_type} ne "void") {
print "RETVAL = ";
$wantRETVAL = 1;
}
if (defined($static)) {
if ($func_name eq 'new') {
$func_name = "$class";
}
else {
print "${class}::";
}
}
elsif (defined($class)) {
if ($func_name eq 'new') {
$func_name .= " $class";
}
else {
print "THIS->";
}
}
$func_name =~ s/^\Q$args{'s'}//
if exists $args{'s'};
$func_name = 'XSFUNCTION' if $self->{interface};
print "$func_name($self->{func_args});\n";
}
}
# do output variables
$self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section;
undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section);
# $wantRETVAL set if 'RETVAL =' autogenerated
($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return;
undef %{ $self->{outargs} };
$self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
generate_output( {
type => $self->{var_types}->{$_},
num => $self->{args_match}->{$_},
var => $_,
do_setmagic => $self->{DoSetMagic},
do_push => undef,
} ) for grep $self->{in_out}->{$_} =~ /OUT$/, keys %{ $self->{in_out} };
my $prepush_done;
# all OUTPUT done, so now push the return value on the stack
if ($self->{gotRETVAL} && $self->{RETVAL_code}) {
print "\t$self->{RETVAL_code}\n";
}
inc/inc_ExtUtils-ParseXS/ExtUtils/ParseXS.pm view on Meta::CPAN
# disaster, starting with the first 'eval qq' inside the 'elsif' block
# below.
# It appears that this is related to the fact that at this point the
# value of $t is a reference to an array whose [2] element includes
# '$var' as a substring:
# <i> <> <(IV)$var>
my $var = 'RETVAL';
my $type = $self->{ret_type};
if ($t and not $t->{with_size} and $t->{type} eq 'p') {
# PUSHp corresponds to setpvn. Treat setpv directly
my $what = eval qq("$t->{what}");
warn $@ if $@;
print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
$prepush_done = 1;
}
elsif ($t) {
my $what = eval qq("$t->{what}");
warn $@ if $@;
my $tsize = $t->{what_size};
$tsize = '' unless defined $tsize;
$tsize = eval qq("$tsize");
warn $@ if $@;
print "\tXSprePUSH; PUSH$t->{type}($what$tsize);\n";
$prepush_done = 1;
}
else {
# RETVAL almost never needs SvSETMAGIC()
generate_output( {
type => $self->{ret_type},
num => 0,
var => 'RETVAL',
do_setmagic => 0,
do_push => undef,
} );
}
}
$xsreturn = 1 if $self->{ret_type} ne "void";
my $num = $xsreturn;
my $c = @{ $outlist_ref };
print "\tXSprePUSH;" if $c and not $prepush_done;
print "\tEXTEND(SP,$c);\n" if $c;
$xsreturn += $c;
generate_output( {
type => $self->{var_types}->{$_},
num => $num++,
var => $_,
do_setmagic => 0,
do_push => 1,
} ) for @{ $outlist_ref };
# do cleanup
$self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
print Q(<<"EOF") if $self->{ScopeThisXSUB};
# ]]
EOF
print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE;
# LEAVE;
EOF
# print function trailer
print Q(<<"EOF");
# ]]
EOF
print Q(<<"EOF") if $self->{except};
# BEGHANDLERS
# CATCHALL
# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
# ENDHANDLERS
EOF
if ($self->check_keyword("CASE")) {
$self->blurt("Error: No `CASE:' at top of function")
unless $self->{condnum};
$_ = "CASE: $_"; # Restore CASE: label
next;
}
last if $_ eq "$END:";
$self->death(/^$self->{BLOCK_re}/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
}
print Q(<<"EOF") if $self->{except};
# if (errbuf[0])
# Perl_croak(aTHX_ errbuf);
EOF
if ($xsreturn) {
print Q(<<"EOF") unless $PPCODE;
# XSRETURN($xsreturn);
EOF
}
else {
print Q(<<"EOF") unless $PPCODE;
# XSRETURN_EMPTY;
EOF
}
print Q(<<"EOF");
#]]
#
EOF
$self->{newXS} = "newXS";
$self->{proto} = "";
# Build the prototype string for the xsub
if ($self->{ProtoThisXSUB}) {
$self->{newXS} = "newXSproto_portable";
if ($self->{ProtoThisXSUB} eq 2) {
# User has specified empty prototype
}
elsif ($self->{ProtoThisXSUB} eq 1) {
my $s = ';';
if ($min_args < $num_args) {
$s = '';
$self->{proto_arg}->[$min_args] .= ";";
}
push @{ $self->{proto_arg} }, "$s\@"
if $ellipsis;
$self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } );
}
else {
# User has specified a prototype
$self->{proto} = $self->{ProtoThisXSUB};
}
$self->{proto} = qq{, "$self->{proto}"};
}
if (%{ $self->{XsubAliases} }) {
$self->{XsubAliases}->{$pname} = 0
unless defined $self->{XsubAliases}->{$pname};
while ( my ($xname, $value) = each %{ $self->{XsubAliases} }) {
push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
# cv = $self->{newXS}(\"$xname\", XS_$Full_func_name, file$self->{proto});
# XSANY.any_i32 = $value;
EOF
}
}
elsif (@{ $self->{Attributes} }) {
push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
# cv = $self->{newXS}(\"$pname\", XS_$Full_func_name, file$self->{proto});
# apply_attrs_string("$Package", cv, "@{ $self->{Attributes} }", 0);
EOF
}
elsif ($self->{interface}) {
while ( my ($yname, $value) = each %{ $self->{Interfaces} }) {
$yname = "$Package\::$yname" unless $yname =~ /::/;
push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
# cv = $self->{newXS}(\"$yname\", XS_$Full_func_name, file$self->{proto});
# $self->{interface_macro_set}(cv,$value);
EOF
( run in 1.501 second using v1.01-cache-2.11-cpan-5511b514fd6 )