package ExtUtils::ParseXS;
-use strict 'subs';
-use strict 'refs';
+use strict;
use 5.006; # We use /??{}/ in regexes
use Cwd;
use File::Basename;
use File::Spec;
use Symbol;
+use ExtUtils::ParseXS::Constants ();
use ExtUtils::ParseXS::CountLines;
use ExtUtils::ParseXS::Utilities qw(
standard_typemap_locations
trim_whitespace
tidy_type
+ C_string
+ valid_proto_string
+ process_typemaps
+ make_targetable
+ map_type
);
our (@ISA, @EXPORT_OK, $VERSION);
# use strict; # One of these days ...
-my(@XSStack); # Stack of conditionals and INCLUDEs
-my($XSS_work_idx, $cpp_next_tmp);
-
our (
$ProtoUsed, @InitFileCode, $FH, $proto_re, $Overload, $errors, $Fallback,
$hiertype, $WantPrototypes, $WantVersionChk, $WantLineNumbers, $filepathname,
@line_no, $ret_type, $func_name, $Full_func_name, $Packprefix, $Packid,
%XsubAliases, %XsubAliasValues, %Interfaces, @Attributes, %outargs, $pname,
$thisdone, $retvaldone, $deferred, $gotRETVAL, $condnum, $cond,
- $RETVAL_code, $name_printed, $func_args,
+ $RETVAL_code, $printed_name, $func_args, @XSStack, $ALIAS,
);
-#our $DoSetMagic;
+our ($DoSetMagic, $newXS, $proto, $Module_cname, $XsubAliases, $Interfaces, $var_num, );
sub process_file {
# Allow for $package->process_file(%hash) in the future
- my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
+ my ($pkg, %options) = @_ % 2 ? @_ : (__PACKAGE__, @_);
- $ProtoUsed = exists $args{prototypes};
+ $ProtoUsed = exists $options{prototypes};
# Set defaults.
- %args = (
+ my %args = (
argtypes => 1,
csuffix => '.c',
except => 0,
prototypes => 0,
typemap => [],
versioncheck => 1,
- %args,
+ %options,
);
+ $args{except} = $args{except} ? ' TRY' : '';
# Global Constants
$SymSet = new ExtUtils::XSSymSet 28;
}
@XSStack = ({type => 'none'});
- ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
- @InitFileCode = ();
- $FH = Symbol::gensym();
- $proto_re = "[" . quotemeta('\$%&*@;[]_') . "]";
- $Overload = 0;
- $errors = 0;
- $Fallback = '&PL_sv_undef';
+ my $XSS_work_idx = 0;
+ my $cpp_next_tmp = 'XSubPPtmpAAAA';
+ @InitFileCode = @ExtUtils::ParseXS::Constants::InitFileCode;
+ $FH = $ExtUtils::ParseXS::Constants::FH;
+ $proto_re = $ExtUtils::ParseXS::Constants::proto_re;
+ $Overload = $ExtUtils::ParseXS::Constants::Overload;
+ $errors = $ExtUtils::ParseXS::Constants::errors;
+ $Fallback = $ExtUtils::ParseXS::Constants::Fallback;
# Most of the 1500 lines below uses these globals. We'll have to
# clean this up sometime, probably. For now, we just pull them out
$hiertype = $args{hiertype};
$WantPrototypes = $args{prototypes};
$WantVersionChk = $args{versioncheck};
- my $except = $args{except} ? ' TRY' : '';
$WantLineNumbers = $args{linenumbers};
- my $WantOptimize = $args{optimize};
- my $process_inout = $args{inout};
- my $process_argtypes = $args{argtypes};
- my @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
-
- for ($args{filename}) {
- die "Missing required parameter 'filename'" unless $_;
- $filepathname = $_;
- ($dir, $filename) = (dirname($_), basename($_));
+
+ for my $f ($args{filename}) {
+ die "Missing required parameter 'filename'" unless $f;
+ $filepathname = $f;
+ ($dir, $filename) = (dirname($f), basename($f));
$filepathname =~ s/\\/\\\\/g;
- $IncludedFiles{$_}++;
+ $IncludedFiles{$f}++;
}
- # Open the input file
- open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
-
# Open the output file if given as a string. If they provide some
# other kind of reference, trust them that we can print to it.
if (not ref $args{output}) {
select $args{output};
}
- foreach my $typemap (@tm) {
- die "Can't find $typemap in $pwd\n" unless -r $typemap;
- }
+ my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
+ process_typemaps( $args{typemap}, $pwd );
- push @tm, standard_typemap_locations( \@INC );
-
- foreach my $typemap (@tm) {
- next unless -f $typemap;
- # skip directories, binary files etc.
- warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
- unless -T $typemap;
- open my $TYPEMAP, '<', $typemap
- or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
- my $mode = 'Typemap';
- my $junk = "";
- my $current = \$junk;
- while (<$TYPEMAP>) {
- next if /^\s*#/;
- if (/^INPUT\s*$/) {
- $mode = 'Input'; $current = \$junk; next;
- }
- if (/^OUTPUT\s*$/) {
- $mode = 'Output'; $current = \$junk; next;
- }
- if (/^TYPEMAP\s*$/) {
- $mode = 'Typemap'; $current = \$junk; next;
- }
- if ($mode eq 'Typemap') {
- chomp;
- my $line = $_;
- trim_whitespace($_);
- # skip blank lines and comment lines
- next if /^$/ or /^#/;
- my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
- warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
- $type = tidy_type($type);
- $type_kind{$type} = $kind;
- # prototype defaults to '$'
- $proto = "\$" unless $proto;
- warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
- unless ValidProtoString($proto);
- $proto_letter{$type} = C_string($proto);
- }
- elsif (/^\s/) {
- $$current .= $_;
- }
- elsif ($mode eq 'Input') {
- s/\s+$//;
- $input_expr{$_} = '';
- $current = \$input_expr{$_};
- }
- else {
- s/\s+$//;
- $output_expr{$_} = '';
- $current = \$output_expr{$_};
- }
- }
- close $TYPEMAP;
- }
+ %type_kind = %{ $type_kind_ref };
+ %proto_letter = %{ $proto_letter_ref };
+ %input_expr = %{ $input_expr_ref };
+ %output_expr = %{ $output_expr_ref };
foreach my $value (values %input_expr) {
$value =~ s/;*\s+\z//;
$value =~ s/^\s+#/#/mg;
}
- my ($cast, $size);
- our $bal;
- $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
- $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
- $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
-
- my %targetable;
- foreach my $key (keys %output_expr) {
- # We can still bootstrap compile 're', because in code re.pm is
- # available to miniperl, and does not attempt to load the XS code.
- use re 'eval';
-
- my ($t, $with_size, $arg, $sarg) =
- ($output_expr{$key} =~
- m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
- \s* \( \s* $cast \$arg \s* ,
- \s* ( (??{ $bal }) ) # Set from
- ( (??{ $size }) )? # Possible sizeof set-from
- \) \s* ; \s* $
- ]x
- );
- $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
- }
+ my %targetable = make_targetable(\%output_expr);
my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
print("#line 1 \"$filepathname\"\n")
if $WantLineNumbers;
+ # Open the input file (using basename'd $args{filename} due to chdir above)
+ open($FH, $filename) or die "cannot open $filename: $!\n";
+
firstmodule:
while (<$FH>) {
if (/^=/) {
# Allow one-line ANSI-like declaration
unshift @line, $2
- if $process_argtypes
+ if $args{argtypes}
and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
# a function definition needs at least 2 lines
my @args;
my %only_C_inlist; # Not in the signature of Perl function
- if ($process_argtypes and $orig_args =~ /\S/) {
+ if ($args{argtypes} and $orig_args =~ /\S/) {
my $args = "$orig_args ,";
if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
@args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
s/^\s+//;
s/\s+$//;
my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x);
- my ($pre, $name) = ($arg =~ /(.*?) \s*
+ my ($pre, $len_name) = ($arg =~ /(.*?) \s*
\b ( \w+ | length\( \s*\w+\s* \) )
\s* $ /x);
next unless defined($pre) && length($pre);
my $out_type = '';
my $inout_var;
- if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
+ if ($args{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
my $type = $1;
$out_type = $type if $type ne 'IN';
$arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
$pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
}
my $islength;
- if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
- $name = "XSauto_length_of_$1";
+ if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) {
+ $len_name = "XSauto_length_of_$1";
$islength = 1;
die "Default value on length() argument: `$_'"
if length $default;
push @fake_INPUT, $arg;
}
# warn "pushing '$arg'\n";
- $argtype_seen{$name}++;
- $_ = "$name$default"; # Assigns to @args
+ $argtype_seen{$len_name}++;
+ $_ = "$len_name$default"; # Assigns to @args
}
$only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
- push @outlist, $name if $out_type =~ /OUTLIST$/;
- $in_out{$name} = $out_type if $out_type;
+ push @outlist, $len_name if $out_type =~ /OUTLIST$/;
+ $in_out{$len_name} = $out_type if $out_type;
}
}
else {
else {
@args = split(/\s*,\s*/, $orig_args);
for (@args) {
- if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
+ if ($args{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{$_} = 1 if $out_type eq "OUTLIST";
- push @outlist, $name if $out_type =~ /OUTLIST$/;
+ if ($out_type =~ /OUTLIST$/) {
+ push @outlist, undef;
+ }
$in_out{$_} = $out_type;
}
}
unshift(@args, $arg0);
}
my $extra_args = 0;
- @args_num = ();
- $num_args = 0;
+ my @args_num = ();
+ my $num_args = 0;
my $report_args = '';
foreach my $i (0 .. $#args) {
if ($args[$i] =~ s/\.\.\.//) {
}
$proto_arg[$i+1] = '$';
}
- $min_args = $num_args - $extra_args;
+ my $min_args = $num_args - $extra_args;
$report_args =~ s/"/\\"/g;
$report_args =~ s/^,\s+//;
my @func_args = @args;
# to set explicit return values.
my $EXPLICIT_RETURN = ($CODE &&
("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
- my $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
+
+ # 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*:/, @line);
+
my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
$xsreturn = 1 if $EXPLICIT_RETURN;
$cond = qq(items < $min_args || items > $num_args);
}
- print Q(<<"EOF") if $except;
+ print Q(<<"EOF") if $args{except};
# char errbuf[1024];
# *errbuf = '\0';
EOF
while (@line) {
&CASE_handler if check_keyword("CASE");
print Q(<<"EOF");
-# $except [[
+# $args{except} [[
EOF
# do initialization of input variables
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;
print "\tdXSTARG;\n"
- if $WantOptimize and $targetable{$type_kind{$ret_type}};
+ if $args{optimize} and $targetable{$type_kind{$ret_type}};
}
if (@fake_INPUT or @fake_INPUT_pre) {
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) {
print "\t$RETVAL_code\n";
}
elsif ($gotRETVAL || $wantRETVAL) {
- my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
+ 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;
my $what = eval qq("$t->[2]");
warn $@ if $@;
- my $size = $t->[3];
- $size = '' unless defined $size;
- $size = eval qq("$size");
+ my $tsize = $t->[3];
+ $tsize = '' unless defined $tsize;
+ $tsize = eval qq("$tsize");
warn $@ if $@;
- print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
+ print "\tXSprePUSH; PUSH$t->[0]($what$tsize);\n";
$prepush_done = 1;
}
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");
print Q(<<"EOF");
# ]]
EOF
- print Q(<<"EOF") if $except;
+ print Q(<<"EOF") if $args{except};
# BEGHANDLERS
# CATCHALL
# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
}
- print Q(<<"EOF") if $except;
+ print Q(<<"EOF") if $args{except};
# if (errbuf[0])
# Perl_croak(aTHX_ errbuf);
EOF
#
EOF
- our $newXS = "newXS";
- our $proto = "";
+ $newXS = "newXS";
+ $proto = "";
# Build the prototype string for the xsub
if ($ProtoThisXSUB) {
if (%XsubAliases) {
$XsubAliases{$pname} = 0
unless defined $XsubAliases{$pname};
- while ( ($name, $value) = each %XsubAliases) {
+ while ( my ($xname, $value) = each %XsubAliases) {
push(@InitFileCode, Q(<<"EOF"));
-# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
+# cv = ${newXS}(\"$xname\", XS_$Full_func_name, file$proto);
# XSANY.any_i32 = $value;
EOF
}
EOF
}
elsif ($interface) {
- while ( ($name, $value) = each %Interfaces) {
- $name = "$Package\::$name" unless $name =~ /::/;
- push(@InitFileCode, Q(<<"EOF"));
-# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
+ while ( my ($yname, $value) = each %Interfaces) {
+ $yname = "$Package\::$yname" unless $yname =~ /::/;
+ push(@InitFileCode, Q(<<"EOF"));
+# cv = ${newXS}(\"$yname\", XS_$Full_func_name, file$proto);
# $interface_macro_set(cv,$value);
EOF
}
# 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";
- $lengthof{$2} = $name;
- # $islengthof{$name} = $1;
+ $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);
- $name_printed = 1;
+ print "\t" . &map_type($var_type, $var_name, $hiertype);
+ $printed_name = 1;
}
else {
- print "\t" . &map_type($var_type);
- $name_printed = 0;
+ print "\t" . &map_type($var_type, undef, $hiertype);
+ $printed_name = 0;
}
$var_num = $args_match{$var_name};
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
and $var_init !~ /\S/) {
- if ($name_printed) {
+ if ($printed_name) {
print ";\n";
}
else {
}
}
elsif ($var_init =~ /\S/) {
- &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
+ &output_init($var_type, $var_num, $var_name, $var_init, $printed_name);
}
elsif ($var_num) {
# generate initialization code
- &generate_init($var_type, $var_num, $var_name, $name_printed);
+# &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$/;
trim_whitespace($in);
foreach (split /[\s,]+/, $in) {
- my $name = $_;
- $name =~ s/^$Prefix//;
- $Interfaces{$name} = $_;
+ my $iface_name = $_;
+ $iface_name =~ s/^$Prefix//;
+ $Interfaces{$iface_name} = $_;
}
print Q(<<"EOF");
# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
# remove any whitespace
s/\s+//g;
death("Error: Invalid prototype '$_'")
- unless ValidProtoString($_);
+ unless valid_proto_string($_);
$ProtoThisXSUB = C_string($_);
}
}
}
sub PushXSStack {
+ my %args = @_;
# Save the current file context.
push(@XSStack, {
type => 'file',
return 1;
}
-sub ValidProtoString ($) {
- my($string) = @_;
-
- if ( $string =~ /^$proto_re+$/ ) {
- return $string;
- }
-
- return 0;
-}
-
-sub C_string ($) {
- my($string) = @_;
-
- $string =~ s[\\][\\\\]g;
- $string;
-}
-
sub ProtoString ($) {
my ($type) = @_;
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, $name_printed) = @_;
- local($arg) = "ST(" . ($num - 1) . ")";
+ my ($type, $num, $var, $init, $printed_name) = @_;
+ my $arg = "ST(" . ($num - 1) . ")";
if ( $init =~ /^=/ ) {
- if ($name_printed) {
+ if ($printed_name) {
eval qq/print " $init\\n"/;
}
else {
}
else {
if ( $init =~ s/^\+// && $num ) {
- &generate_init($type, $num, $var, $name_printed);
- }
- elsif ($name_printed) {
+# &generate_init($type, $num, $var, $printed_name);
+ generate_init( {
+ type => $type,
+ num => $num,
+ var => $var,
+ printed_name => $printed_name,
+ } );
+ }
+ elsif ($printed_name) {
print ";\n";
$init =~ s/^;//;
}
}
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 "\t$var" unless $name_printed;
+ print "\t$var" unless $printed_name;
print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
die "default value not supported with length(NAME) supplied"
if defined $defaults{$var};
$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;
if (defined($defaults{$var})) {
$expr =~ s/(\t+)/$1 /g;
$expr =~ s/ /\t/g;
- if ($name_printed) {
+ if ($printed_name) {
print ";\n";
}
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 ($name_printed) {
+ if ($printed_name) {
print ";\n";
}
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 $name_printed;
+ 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;