package ExtUtils::ParseXS;
-use strict 'subs';
-use strict 'refs';
+use strict;
use 5.006; # We use /??{}/ in regexes
use Cwd;
valid_proto_string
process_typemaps
make_targetable
+ map_type
);
our (@ISA, @EXPORT_OK, $VERSION);
$thisdone, $retvaldone, $deferred, $gotRETVAL, $condnum, $cond,
$RETVAL_code, $printed_name, $func_args, @XSStack, $ALIAS,
);
-our ($DoSetMagic, $newXS, $proto, $Module_cname, $XsubAliases, $Interfaces, );
+our ($DoSetMagic, $newXS, $proto, $Module_cname, $XsubAliases, $Interfaces, $var_num, );
sub process_file {
my $out_type = $1;
next if $out_type eq 'IN';
$only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
- # $name in line below appears to a global not previously declared or
- # defined
-# push @outlist, $name if $out_type =~ /OUTLIST$/;
if ($out_type =~ /OUTLIST$/) {
- if (defined $name) {
-print STDERR "CRITICAL: matched OUTLIST, \$name: <$name>\n";
- push @outlist, $name;
- }
- else {
-print STDERR "SOMEWHAT CRITICAL: matched OUTLIST, but \$name is undefined\n";
- push @outlist, undef;
- }
+ push @outlist, undef;
}
$in_out{$_} = $out_type;
}
if (defined($static) or $func_name eq 'new') {
print "\tchar *";
$var_types{"CLASS"} = "char *";
- &generate_init("char *", 1, "CLASS");
+# &generate_init("char *", 1, "CLASS", undef);
+ generate_init( {
+ type => "char *",
+ num => 1,
+ var => "CLASS",
+ printed_name => undef,
+ } );
}
else {
print "\t$class *";
$var_types{"THIS"} = "$class *";
- &generate_init("$class *", 1, "THIS");
+# &generate_init("$class *", 1, "THIS", undef);
+ generate_init( {
+ type => "$class *",
+ num => 1,
+ var => "THIS",
+ printed_name => undef,
+ } );
}
}
}
else {
if ($ret_type ne "void") {
- print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
+ print "\t" . &map_type($ret_type, 'RETVAL', $hiertype) . ";\n"
if !$retvaldone;
$args_match{"RETVAL"} = 0;
$var_types{"RETVAL"} = $ret_type;
undef %outargs;
process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
- &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
- for grep $in_out{$_} =~ /OUT$/, keys %in_out;
+# &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
+ generate_output( {
+ type => $var_types{$_},
+ num => $args_match{$_},
+ var => $_,
+ do_setmagic => $DoSetMagic,
+ do_push => undef,
+ } ) for grep $in_out{$_} =~ /OUT$/, keys %in_out;
# all OUTPUT done, so now push the return value on the stack
if ($gotRETVAL && $RETVAL_code) {
}
elsif ($gotRETVAL || $wantRETVAL) {
my $t = $args{optimize} && $targetable{$type_kind{$ret_type}};
+ # Although the '$var' declared in the next line is never explicitly
+ # used within this 'elsif' block, commenting it out leads to
+ # 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 = $ret_type;
}
else {
# RETVAL almost never needs SvSETMAGIC()
- &generate_output($ret_type, 0, 'RETVAL', 0);
+# &generate_output($ret_type, 0, 'RETVAL', 0);
+ generate_output( {
+ type => $ret_type,
+ num => 0,
+ var => 'RETVAL',
+ do_setmagic => 0,
+ do_push => undef,
+ } );
}
}
print "\tXSprePUSH;" if $c and not $prepush_done;
print "\tEXTEND(SP,$c);\n" if $c;
$xsreturn += $c;
- generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
+# generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
+ generate_output( {
+ type => $var_types{$_},
+ num => $num++,
+ var => $_,
+ do_setmagic => 0,
+ do_push => 1,
+ } ) for @outlist;
# do cleanup
process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
# Process the length(foo) declarations
if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
- # $name in line below is global ?
-# $lengthof{$2} = $name;
- if (defined $name) {
-print STDERR "CRITICAL: Inside INPUT_handler: \$name defined as: <$name>\t\$2: <$2>\n";
- $lengthof{$2} = $name;
- }
- else {
-print STDERR "CRITICAL: Inside INPUT_handler: \$name is undefined\t\$2: <$2>\n";
- $lengthof{$2} = undef;
- }
+ $lengthof{$2} = undef;
$deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
}
# one can use 2-args map_type() unconditionally.
if ($var_type =~ / \( \s* \* \s* \) /x) {
# Function pointers are not yet supported with &output_init!
- print "\t" . &map_type($var_type, $var_name);
+ print "\t" . &map_type($var_type, $var_name, $hiertype);
$printed_name = 1;
}
else {
- print "\t" . &map_type($var_type);
+ print "\t" . &map_type($var_type, undef, $hiertype);
$printed_name = 0;
}
$var_num = $args_match{$var_name};
}
elsif ($var_num) {
# generate initialization code
- &generate_init($var_type, $var_num, $var_name, $printed_name);
+# &generate_init($var_type, $var_num, $var_name, $printed_name);
+ generate_init( {
+ type => $var_type,
+ num => $var_num,
+ var => $var_name,
+ printed_name => $printed_name,
+ } );
}
else {
print ";\n";
print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
}
else {
- &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
+# &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
+ generate_output( {
+ type => $var_types{$outarg},
+ num => $var_num,
+ var => $outarg,
+ do_setmagic => $DoSetMagic,
+ do_push => undef,
+ } );
}
delete $in_out{$outarg} # No need to auto-OUTPUT
if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
}
sub PushXSStack {
+ my %args = @_;
# Save the current file context.
push(@XSStack, {
type => 'file',
if ($lastline =~
/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
- $Module = $1;
+ my $Module = $1;
$Package = defined($2) ? $2 : ''; # keep -w happy
$Prefix = defined($3) ? $3 : ''; # keep -w happy
$Prefix = quotemeta $Prefix;
}
sub output_init {
- local($type, $num, $var, $init, $printed_name) = @_;
- local($arg) = "ST(" . ($num - 1) . ")";
+ my ($type, $num, $var, $init, $printed_name) = @_;
+ my $arg = "ST(" . ($num - 1) . ")";
if ( $init =~ /^=/ ) {
if ($printed_name) {
}
else {
if ( $init =~ s/^\+// && $num ) {
- &generate_init($type, $num, $var, $printed_name);
+# &generate_init($type, $num, $var, $printed_name);
+ generate_init( {
+ type => $type,
+ num => $num,
+ var => $var,
+ printed_name => $printed_name,
+ } );
}
elsif ($printed_name) {
print ";\n";
}
sub generate_init {
- local($type, $num, $var) = @_;
- local($arg) = "ST(" . ($num - 1) . ")";
- local($argoff) = $num - 1;
- local($ntype);
- local($tk);
+# my ($type, $num, $var, $printed_name) = @_;
+ my $argsref = shift;
+ my ($type, $num, $var, $printed_name) = (
+ $argsref->{type},
+ $argsref->{num},
+ $argsref->{var},
+ $argsref->{printed_name},
+ );
+ my $arg = "ST(" . ($num - 1) . ")";
+ my ($argoff, $ntype, $tk);
+ $argoff = $num - 1;
$type = tidy_type($type);
blurt("Error: '$type' not in typemap"), return
unless defined($type_kind{$type});
($ntype = $type) =~ s/\s*\*/Ptr/g;
+ my $subtype;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
$tk = $type_kind{$type};
$tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
if ($tk eq 'T_PV' and exists $lengthof{$var}) {
-print STDERR "SOMEWHAT CRITICAL: Inside generate_init(): \$var <$var>\n";
print "\t$var" unless $printed_name;
print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
die "default value not supported with length(NAME) supplied"
$type =~ tr/:/_/ unless $hiertype;
blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
unless defined $input_expr{$tk};
- $expr = $input_expr{$tk};
+ my $expr = $input_expr{$tk};
if ($expr =~ /DO_ARRAY_ELEM/) {
blurt("Error: '$subtype' not in typemap"), return
unless defined($type_kind{$subtype});
blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
unless defined $input_expr{$type_kind{$subtype}};
- $subexpr = $input_expr{$type_kind{$subtype}};
+ my $subexpr = $input_expr{$type_kind{$subtype}};
$subexpr =~ s/\$type/\$subtype/g;
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
}
else {
eval qq/print "\\t$var;\\n"/;
- warn $@ if $@;
+ warn $@ if $@;
}
if ($defaults{$var} eq 'NO_INIT') {
$deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
else {
$deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
}
- warn $@ if $@;
+ warn $@ if $@;
}
elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
if ($printed_name) {
}
else {
eval qq/print "\\t$var;\\n"/;
- warn $@ if $@;
+ warn $@ if $@;
}
$deferred .= eval qq/"\\n$expr;\\n"/;
- warn $@ if $@;
+ warn $@ if $@;
}
else {
die "panic: do not know how to handle this branch for function pointers"
if $printed_name;
eval qq/print "$expr;\\n"/;
- warn $@ if $@;
+ warn $@ if $@;
}
}
sub generate_output {
- local($type, $num, $var, $do_setmagic, $do_push) = @_;
- local($arg) = "ST(" . ($num - ($num != 0)) . ")";
- local($argoff) = $num - 1;
- local($ntype);
+# my ($type, $num, $var, $do_setmagic, $do_push) = @_;
+ my $argsref = shift;
+ my ($type, $num, $var, $do_setmagic, $do_push) = (
+ $argsref->{type},
+ $argsref->{num},
+ $argsref->{var},
+ $argsref->{do_setmagic},
+ $argsref->{do_push}
+ );
+ my $arg = "ST(" . ($num - ($num != 0)) . ")";
+ my $ntype;
$type = tidy_type($type);
if ($type =~ /^array\(([^,]*),(.*)\)/) {
unless defined $output_expr{$type_kind{$type}};
($ntype = $type) =~ s/\s*\*/Ptr/g;
$ntype =~ s/\(\)//g;
+ my $subtype;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
- $expr = $output_expr{$type_kind{$type}};
+ my $expr = $output_expr{$type_kind{$type}};
if ($expr =~ /DO_ARRAY_ELEM/) {
blurt("Error: '$subtype' not in typemap"), return
unless defined($type_kind{$subtype});
blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
unless defined $output_expr{$type_kind{$subtype}};
- $subexpr = $output_expr{$type_kind{$subtype}};
+ my $subexpr = $output_expr{$type_kind{$subtype}};
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
$subexpr =~ s/\$var/${var}[ix_$var]/g;
$subexpr =~ s/\n\t/\n\t\t/g;
$expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
eval "print qq\a$expr\a";
- warn $@ if $@;
+ warn $@ if $@;
print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
}
elsif ($var eq 'RETVAL') {
# We expect that $arg has refcnt 1, so we need to
# mortalize it.
eval "print qq\a$expr\a";
- warn $@ if $@;
+ warn $@ if $@;
print "\tsv_2mortal(ST($num));\n";
print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
}
# We expect that $arg has refcnt >=1, so we need
# to mortalize it!
eval "print qq\a$expr\a";
- warn $@ if $@;
+ warn $@ if $@;
print "\tsv_2mortal(ST(0));\n";
print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
}
# works too.
print "\tST(0) = sv_newmortal();\n";
eval "print qq\a$expr\a";
- warn $@ if $@;
+ warn $@ if $@;
# new mortals don't have set magic
}
}
print "\tPUSHs(sv_newmortal());\n";
$arg = "ST($num)";
eval "print qq\a$expr\a";
- warn $@ if $@;
+ warn $@ if $@;
print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
}
elsif ($arg =~ /^ST\(\d+\)$/) {
eval "print qq\a$expr\a";
- warn $@ if $@;
+ warn $@ if $@;
print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
}
}
}
-sub map_type {
- my($type, $varname) = @_;
-
- # C++ has :: in types too so skip this
- $type =~ tr/:/_/ unless $hiertype;
- $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
- if ($varname) {
- if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
- (substr $type, pos $type, 0) = " $varname ";
- }
- else {
- $type .= "\t$varname";
- }
- }
- $type;
-}
-
1;