package ExtUtils::ParseXS;
use strict;
-use 5.006; # We use /??{}/ in regexes
+use 5.008001; # We use /??{}/ in regexes
use Cwd;
use Config;
use Exporter;
use File::Basename;
use File::Spec;
use Symbol;
-use ExtUtils::ParseXS::Constants ();
-use ExtUtils::ParseXS::CountLines;
+
+our $VERSION;
+BEGIN {
+ $VERSION = '3.07';
+}
+use ExtUtils::ParseXS::Constants $VERSION;
+use ExtUtils::ParseXS::CountLines $VERSION;
+use ExtUtils::ParseXS::Utilities $VERSION;
+$VERSION = eval $VERSION if $VERSION =~ /_/;
+
use ExtUtils::ParseXS::Utilities qw(
standard_typemap_locations
trim_whitespace
make_targetable
map_type
standard_XS_defs
+ assign_func_args
+ analyze_preprocessor_statements
+ set_cond
+ Warn
+ current_line_number
+ blurt
+ death
+ check_conditional_preprocessor_statements
);
our @ISA = qw(Exporter);
process_file
report_error_count
);
-our $VERSION = '3';
-$VERSION = eval $VERSION if $VERSION =~ /_/;
# The scalars in the line below remain as 'our' variables because pulling
# them into $self led to build problems. In most cases, strings being
# 'eval'-ed contain the variables' names hard-coded.
our (
- $FH, $Package, $func_name, $Full_func_name, $Packid, $pname, $ALIAS,
+ $Package, $func_name, $Full_func_name, $pname, $ALIAS,
);
-our $self = {};
+our $self = bless {} => __PACKAGE__;
sub process_file {
prototypes => 0,
typemap => [],
versioncheck => 1,
+ FH => Symbol::gensym(),
%options,
);
$args{except} = $args{except} ? ' TRY' : '';
# Establish set of global symbols with max length 28, since xsubpp
# will later add the 'XS_' prefix.
require ExtUtils::XSSymSet;
- $SymSet = new ExtUtils::XSSymSet 28;
+ $SymSet = ExtUtils::XSSymSet->new(28);
}
@{ $self->{XSStack} } = ({type => 'none'});
$self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ];
- $FH = $ExtUtils::ParseXS::Constants::FH;
- $self->{Overload} = $ExtUtils::ParseXS::Constants::Overload;
- $self->{errors} = $ExtUtils::ParseXS::Constants::errors;
- $self->{Fallback} = $ExtUtils::ParseXS::Constants::Fallback;
+ $self->{Overload} = 0;
+ $self->{errors} = 0;
+ $self->{Fallback} = '&PL_sv_undef';
# 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
}
# Really, we shouldn't have to chdir() or select() in the first
- # place. For now, just save & restore.
+ # place. For now, just save and restore.
my $orig_cwd = cwd();
my $orig_fh = select();
select $args{output};
}
- (
- $self->{type_kind},
- $self->{proto_letter},
- $self->{input_expr},
- $self->{output_expr},
- ) = process_typemaps( $args{typemap}, $pwd );
-
- foreach my $value (values %{ $self->{input_expr} }) {
- $value =~ s/;*\s+\z//;
- # Move C pre-processor instructions to column 1 to be strictly ANSI
- # conformant. Some pre-processors are fussy about this.
- $value =~ s/^\s+#/#/mg;
- }
- foreach my $value (values %{ $self->{output_expr} }) {
- # And again.
- $value =~ s/^\s+#/#/mg;
- }
-
- my %targetable = make_targetable($self->{output_expr});
+ $self->{typemap} = process_typemaps( $args{typemap}, $pwd );
my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
# Match an XS keyword
$self->{BLOCK_re} = '\s*(' .
- join('|' => @ExtUtils::ParseXS::Constants::keywords) .
+ join('|' => @ExtUtils::ParseXS::Constants::XSKeywords) .
"|$END)\\s*:";
our ($C_group_rex, $C_arg);
# Open the input file (using $self->{filename} which
# is a basename'd $args{filename} due to chdir above)
- open($FH, $self->{filename}) or die "cannot open $self->{filename}: $!\n";
+ open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n";
firstmodule:
- while (<$FH>) {
+ while (readline($self->{FH})) {
if (/^=/) {
my $podstartline = $.;
do {
next firstmodule
}
- } while (<$FH>);
+ } while (readline($self->{FH}));
# At this point $. is at end of file so die won't state the start
# of the problem, and as we haven't yet read any lines &death won't
# show the correct line in the message either.
$self->{lastline} = $_;
$self->{lastline_no} = $.;
- my ($prepush_done, $xsreturn, $func_header, $orig_args, );
my $BootCode_ref = [];
- my $outlist_ref = [];
my $XSS_work_idx = 0;
my $cpp_next_tmp = 'XSubPPtmpAAAA';
PARAGRAPH:
- while (fetch_para()) {
+ while ($self->fetch_para()) {
+ my $outlist_ref = [];
# Print initial preprocessor statements and blank lines
while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) {
my $ln = shift(@{ $self->{line} });
print $ln, "\n";
next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
+ my $statement = $+;
( $self, $XSS_work_idx, $BootCode_ref ) =
- print_preprocessor_statements( $self, $XSS_work_idx, $BootCode_ref );
+ analyze_preprocessor_statements(
+ $self, $statement, $XSS_work_idx, $BootCode_ref
+ );
}
next PARAGRAPH unless @{ $self->{line} };
$self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++;
}
- death ("Code is not inside a function"
- ." (maybe last function was ended by a blank line "
- ." followed by a statement on column one?)")
+ $self->death(
+ "Code is not inside a function"
+ ." (maybe last function was ended by a blank line "
+ ." followed by a statement on column one?)")
if $self->{line}->[0] =~ /^\s/;
- my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
- my (@fake_INPUT_pre); # For length(s) generated variables
- my (@fake_INPUT);
-
# initialize info arrays
- undef(%{ $self->{args_match} });
- undef(%{ $self->{var_types} });
- undef(%{ $self->{defaults} });
- undef(%{ $self->{arg_list} });
- undef(@{ $self->{proto_arg} });
- undef($self->{processing_arg_with_types});
- undef(%{ $self->{argtype_seen} });
- undef(@{ $outlist_ref });
- undef(%{ $self->{in_out} });
- undef(%{ $self->{lengthof} });
- undef($self->{proto_in_this_xsub});
- undef($self->{scope_in_this_xsub});
- undef($self->{interface});
- undef($prepush_done);
- $self->{interface_macro} = 'XSINTERFACE_FUNC';
- $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
- $self->{ProtoThisXSUB} = $self->{WantPrototypes};
- $self->{ScopeThisXSUB} = 0;
- $xsreturn = 0;
+ foreach my $member (qw(args_match var_types defaults arg_list
+ argtype_seen in_out lengthof))
+ {
+ $self->{$member} = {};
+ }
+ $self->{proto_arg} = [];
+ $self->{processing_arg_with_types} = undef;
+ $self->{proto_in_this_xsub} = undef;
+ $self->{scope_in_this_xsub} = undef;
+ $self->{interface} = undef;
+ $self->{interface_macro} = 'XSINTERFACE_FUNC';
+ $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
+ $self->{ProtoThisXSUB} = $self->{WantPrototypes};
+ $self->{ScopeThisXSUB} = 0;
+
+ my $xsreturn = 0;
$_ = shift(@{ $self->{line} });
- while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
- no strict 'refs';
- &{"${kwd}_handler"}();
- use strict 'refs';
+ while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
+ my $method = $kwd . "_handler";
+ $self->$method($_);
next PARAGRAPH unless @{ $self->{line} };
$_ = shift(@{ $self->{line} });
}
- if (check_keyword("BOOT")) {
- check_cpp($self);
+ if ($self->check_keyword("BOOT")) {
+ check_conditional_preprocessor_statements($self);
push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"$self->{filepathname}\"")
if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/;
push (@{ $BootCode_ref }, @{ $self->{line} }, "");
# extract return type, function name and arguments
($self->{ret_type}) = tidy_type($_);
- $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;
+ my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;
# Allow one-line ANSI-like declaration
unshift @{ $self->{line} }, $2
and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
# a function definition needs at least 2 lines
- blurt ("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH
+ $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH
unless @{ $self->{line} };
- $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
- $static = 1 if $self->{ret_type} =~ s/^static\s+//;
+ my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
+ my $static = 1 if $self->{ret_type} =~ s/^static\s+//;
- $func_header = shift(@{ $self->{line} });
- blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
+ my $func_header = shift(@{ $self->{line} });
+ $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
+ my ($class, $orig_args);
($class, $func_name, $orig_args) = ($1, $2, $3);
$class = "$4 $class" if $4;
($pname = $func_name) =~ s/^($self->{Prefix})?/$self->{Packprefix}/;
my $clean_func_name;
($clean_func_name = $func_name) =~ s/^$self->{Prefix}//;
- $Full_func_name = "${Packid}_$clean_func_name";
+ $Full_func_name = "$self->{Packid}_$clean_func_name";
if ($Is_VMS) {
$Full_func_name = $SymSet->addsym($Full_func_name);
}
# Check for duplicate function definition
for my $tmp (@{ $self->{XSStack} }) {
next unless defined $tmp->{functions}{$Full_func_name};
- Warn("Warning: duplicate function definition '$clean_func_name' detected");
+ Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected");
last;
}
$self->{XSStack}->[$XSS_work_idx]{functions}{$Full_func_name}++;
$orig_args =~ s/\\\s*/ /g; # process line continuations
my @args;
+ my (@fake_INPUT_pre); # For length(s) generated variables
+ my (@fake_INPUT);
my $only_C_inlist_ref = {}; # Not in the signature of Perl function
if ($self->{argtypes} and $orig_args =~ /\S/) {
my $args = "$orig_args ,";
if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) {
$len_name = "XSauto_length_of_$1";
$islength = 1;
- die "Default value on length() argument: `$_'"
+ die "Default value on length() argument: '$_'"
if length $default;
}
if (length $pre or $islength) { # Has a type
}
else {
@args = split(/\s*,\s*/, $orig_args);
- Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
+ Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split");
}
}
else {
my @args_num = ();
my $num_args = 0;
my $report_args = '';
+ my $ellipsis;
foreach my $i (0 .. $#args) {
if ($args[$i] =~ s/\.\.\.//) {
$ellipsis = 1;
my $min_args = $num_args - $extra_args;
$report_args =~ s/"/\\"/g;
$report_args =~ s/^,\s+//;
- my @func_args = @args;
- shift @func_args if defined($class);
-
- for (@func_args) {
- s/^/&/ if $self->{in_out}->{$_};
- }
- $self->{func_args} = join(", ", @func_args);
+ $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.
+ # to set explicit return values.
my $EXPLICIT_RETURN = ($CODE &&
("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
# print function header
print Q(<<"EOF");
#$externC
-#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
-#XS(XS_${Full_func_name})
+#XS_EUPXS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
+#XS_EUPXS(XS_${Full_func_name})
#[[
-##ifdef dVAR
# dVAR; dXSARGS;
-##else
-# dXSARGS;
-##endif
EOF
print Q(<<"EOF") if $ALIAS;
# dXSI32;
print Q(<<"EOF") if $INTERFACE;
# dXSFUNCTION($self->{ret_type});
EOF
- if ($ellipsis) {
- $self->{cond} = ($min_args ? qq(items < $min_args) : 0);
- }
- elsif ($min_args == $num_args) {
- $self->{cond} = qq(items != $min_args);
- }
- else {
- $self->{cond} = qq(items < $min_args || items > $num_args);
- }
+
+ $self->{cond} = set_cond($ellipsis, $min_args, $num_args);
print Q(<<"EOF") if $self->{except};
# char errbuf[1024];
-# *errbuf = '\0';
+# *errbuf = '\\0';
EOF
if($self->{cond}) {
#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
+ #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;
# Now do a block of some sort.
$self->{condnum} = 0;
- $self->{cond} = ''; # last CASE: condidional
+ $self->{cond} = ''; # last CASE: conditional
push(@{ $self->{line} }, "$END:");
push(@{ $self->{line_no} }, $self->{line_no}->[-1]);
$_ = '';
- check_cpp($self);
+ check_conditional_preprocessor_statements();
while (@{ $self->{line} }) {
- &CASE_handler if check_keyword("CASE");
+
+ $self->CASE_handler($_) if $self->check_keyword("CASE");
print Q(<<"EOF");
# $self->{except} [[
EOF
$self->{deferred} = "";
%{ $self->{arg_list} } = ();
$self->{gotRETVAL} = 0;
-
- INPUT_handler();
- process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
+ $self->INPUT_handler($_);
+ $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
print Q(<<"EOF") if $self->{ScopeThisXSUB};
# ENTER;
}
}
+ # These are set if OUTPUT is found and/or CODE using RETVAL
+ $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0;
+
+ 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->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n"
+ 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 $targetable{$self->{type_kind}->{$self->{ret_type}}};
+ 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;
- INPUT_handler();
+ $self->INPUT_handler($_);
}
print $self->{deferred};
- process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
+ $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
- if (check_keyword("PPCODE")) {
- print_section();
- death ("PPCODE must be last thing") if @{ $self->{line} };
+ 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 (check_keyword("CODE")) {
- print_section();
+ elsif ($self->check_keyword("CODE")) {
+ my $consumed_code = $self->print_section();
+ if ($consumed_code =~ /\bRETVAL\b/) {
+ $self->{have_CODE_with_RETVAL} = 1;
+ }
}
elsif (defined($class) and $func_name eq "DESTROY") {
print "\n\t";
# $wantRETVAL set if 'RETVAL =' autogenerated
($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return;
undef %{ $self->{outargs} };
- process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
+
+ $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
+
+ # A CODE section with RETVAL, but no OUTPUT? FAIL!
+ if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') {
+ $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section.");
+ }
generate_output( {
type => $self->{var_types}->{$_},
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";
}
elsif ($self->{gotRETVAL} || $wantRETVAL) {
- my $t = $self->{optimize} && $targetable{$self->{type_kind}->{$self->{ret_type}}};
+ my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
+ my $t = $self->{optimize} && $outputmap && $outputmap->targetable;
# 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
my $var = 'RETVAL';
my $type = $self->{ret_type};
- # 0: type, 1: with_size, 2: how, 3: how_size
- if ($t and not $t->[1] and $t->[0] eq 'p') {
- # PUSHp corresponds to setpvn. Treate setpv directly
- my $what = eval qq("$t->[2]");
+ 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->[2]");
+ my $what = eval qq("$t->{what}");
warn $@ if $@;
- my $tsize = $t->[3];
+ my $tsize = $t->{what_size};
$tsize = '' unless defined $tsize;
$tsize = eval qq("$tsize");
warn $@ if $@;
- print "\tXSprePUSH; PUSH$t->[0]($what$tsize);\n";
+ print "\tXSprePUSH; PUSH$t->{type}($what$tsize);\n";
$prepush_done = 1;
}
else {
} ) for @{ $outlist_ref };
# do cleanup
- process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
+ $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
print Q(<<"EOF") if $self->{ScopeThisXSUB};
# ]]
# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
# ENDHANDLERS
EOF
- if (check_keyword("CASE")) {
- blurt ("Error: No `CASE:' at top of function")
+ 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:";
- death(/^$self->{BLOCK_re}/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
+ $self->death(/^$self->{BLOCK_re}/o ? "Misplaced '$1:'" : "Junk at end of function ($_)");
}
print Q(<<"EOF") if $self->{except};
if ($self->{Overload}) { # make it findable with fetchmethod
print Q(<<"EOF");
-#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
-#XS(XS_${Packid}_nil)
+#XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */
+#XS_EUPXS(XS_$self->{Packid}_nil)
#{
# dXSARGS;
# XSRETURN_EMPTY;
/* Making a sub named "${Package}::()" allows the package */
/* to be findable via fetchmethod(), and causes */
/* overload::Overloaded("${Package}") to return true. */
- (void)$self->{newXS}("${Package}::()", XS_${Packid}_nil, file$self->{proto});
+ (void)$self->{newXS}("${Package}::()", XS_$self->{Packid}_nil, file$self->{proto});
MAKE_FETCHMETHOD_WORK
}
EOF
print Q(<<"EOF");
-#XS(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
-#XS(boot_$self->{Module_cname})
+#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
+#XS_EXTERNAL(boot_$self->{Module_cname})
EOF
print Q(<<"EOF");
#[[
-##ifdef dVAR
# dVAR; dXSARGS;
-##else
-# dXSARGS;
-##endif
EOF
#Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
#file name argument. If the wrong qualifier is used, it causes breakage with
#C++ compilers and warnings with recent gcc.
#-Wall: if there is no $Full_func_name there are no xsubs in this .xs
- #so `file' is unused
+ #so 'file' is unused
print Q(<<"EOF") if $Full_func_name;
##if (PERL_REVISION == 5 && PERL_VERSION < 9)
# char* file = __FILE__;
print Q(<<"EOF");
# PERL_UNUSED_VAR(cv); /* -W */
# PERL_UNUSED_VAR(items); /* -W */
+##ifdef XS_APIVERSION_BOOTCHECK
+# XS_APIVERSION_BOOTCHECK;
+##endif
EOF
print Q(<<"EOF") if $self->{WantVersionChk};
if (@{ $BootCode_ref }) {
print "\n /* Initialisation Section */\n\n";
@{ $self->{line} } = @{ $BootCode_ref };
- print_section();
+ $self->print_section();
print "\n /* End of Initialisation Section */\n\n";
}
chdir($orig_cwd);
select($orig_fh);
untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
- close $FH;
+ close $self->{FH};
return 1;
}
sub report_error_count { $self->{errors} }
-# Input: ($_, @{ $self->{line} }) == unparsed input.
+# Input: ($self, $_, @{ $self->{line} }) == unparsed input.
# Output: ($_, @{ $self->{line} }) == (rest of line, following lines).
# Return: the matched keyword if found, otherwise 0
sub check_keyword {
+ my $self = shift;
$_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} };
s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
}
sub print_section {
+ my $self = shift;
+
# the "do" is required for right semantics
do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} };
+ my $consumed_code = '';
+
print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"$self->{filepathname}\"\n")
if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
for (; defined($_) && !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
print "$_\n";
+ $consumed_code .= "$_\n";
}
print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
+
+ return $consumed_code;
}
sub merge_section {
+ my $self = shift;
my $in = '';
while (!/\S/ && @{ $self->{line} }) {
return $in;
}
-sub process_keyword($) {
- my($pattern) = @_;
- my $kwd;
+sub process_keyword {
+ my($self, $pattern) = @_;
- no strict 'refs';
- &{"${kwd}_handler"}()
- while $kwd = check_keyword($pattern);
- use strict 'refs';
+ while (my $kwd = $self->check_keyword($pattern)) {
+ my $method = $kwd . "_handler";
+ $self->$method($_);
+ }
}
sub CASE_handler {
- blurt ("Error: `CASE:' after unconditional `CASE:'")
+ my $self = shift;
+ $_ = shift;
+ $self->blurt("Error: 'CASE:' after unconditional 'CASE:'")
if $self->{condnum} && $self->{cond} eq '';
$self->{cond} = $_;
trim_whitespace($self->{cond});
}
sub INPUT_handler {
+ my $self = shift;
+ $_ = shift;
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
last if /^\s*NOT_IMPLEMENTED_YET/;
next unless /\S/; # skip blank lines
my $var_init = '';
$var_init = $1 if s/\s*([=;+].*)$//s;
$var_init =~ s/"/\\"/g;
+ # *sigh* It's valid to supply explicit input typemaps in the argument list...
+ my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/;
s/\s+/ /g;
my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
- or blurt("Error: invalid argument declaration '$ln'"), next;
+ or $self->blurt("Error: invalid argument declaration '$ln'"), next;
# Check for duplicate definitions
- blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
+ $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next
if $self->{arg_list}->{$var_name}++
or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types};
# one can use 2-args map_type() unconditionally.
my $printed_name;
if ($var_type =~ / \( \s* \* \s* \) /x) {
- # Function pointers are not yet supported with &output_init!
- print "\t" . &map_type($var_type, $var_name, $self->{hiertype});
+ # Function pointers are not yet supported with output_init()!
+ print "\t" . map_type($self, $var_type, $var_name);
$printed_name = 1;
}
else {
- print "\t" . &map_type($var_type, undef, $self->{hiertype});
+ print "\t" . map_type($self, $var_type, undef);
$printed_name = 0;
}
$self->{var_num} = $self->{args_match}->{$var_name};
if ($self->{var_num}) {
- $self->{proto_arg}->[$self->{var_num}] = $self->{proto_letter}->{$var_type} || "\$";
+ my $typemap = $self->{typemap}->get_typemap(ctype => $var_type);
+ $self->death("Could not find a typemap for C type '$var_type'")
+ if not $typemap and not $is_overridden_typemap;
+ $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$";
}
$self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr;
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
}
sub OUTPUT_handler {
+ my $self = shift;
+ $self->{have_OUTPUT} = 1;
+
+ $_ = shift;
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
next;
}
my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s;
- blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
+ $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next
if $self->{outargs}->{$outarg}++;
if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') {
# deal with RETVAL last
$self->{gotRETVAL} = 1;
next;
}
- blurt ("Error: OUTPUT $outarg not an argument"), next
+ $self->blurt("Error: OUTPUT $outarg not an argument"), next
unless defined($self->{args_match}->{$outarg});
- blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
+ $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
unless defined $self->{var_types}->{$outarg};
$self->{var_num} = $self->{args_match}->{$outarg};
if ($outcode) {
}
}
-sub C_ARGS_handler() {
- my $in = merge_section();
+sub C_ARGS_handler {
+ my $self = shift;
+ $_ = shift;
+ my $in = $self->merge_section();
trim_whitespace($in);
$self->{func_args} = $in;
}
-sub INTERFACE_MACRO_handler() {
- my $in = merge_section();
+sub INTERFACE_MACRO_handler {
+ my $self = shift;
+ $_ = shift;
+ my $in = $self->merge_section();
trim_whitespace($in);
if ($in =~ /\s/) { # two
$self->{interfaces} = 1; # global
}
-sub INTERFACE_handler() {
- my $in = merge_section();
+sub INTERFACE_handler {
+ my $self = shift;
+ $_ = shift;
+ my $in = $self->merge_section();
trim_whitespace($in);
$self->{interfaces} = 1; # global
}
-sub CLEANUP_handler() { print_section() }
-sub PREINIT_handler() { print_section() }
-sub POSTCALL_handler() { print_section() }
-sub INIT_handler() { print_section() }
+sub CLEANUP_handler {
+ my $self = shift;
+ $self->print_section();
+}
+
+sub PREINIT_handler {
+ my $self = shift;
+ $self->print_section();
+}
+
+sub POSTCALL_handler {
+ my $self = shift;
+ $self->print_section();
+}
-sub GetAliases {
+sub INIT_handler {
+ my $self = shift;
+ $self->print_section();
+}
+
+sub get_aliases {
+ my $self = shift;
my ($line) = @_;
my ($orig) = $line;
$alias = $self->{Packprefix} . $alias if $alias !~ /::/;
# check for duplicate alias name & duplicate value
- Warn("Warning: Ignoring duplicate alias '$orig_alias'")
+ Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'")
if defined $self->{XsubAliases}->{$alias};
- Warn("Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
+ Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values")
if $self->{XsubAliasValues}->{$value};
$self->{xsubaliases} = 1;
$self->{XsubAliasValues}->{$value} = $orig_alias;
}
- blurt("Error: Cannot parse ALIAS definitions from '$orig'")
+ blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'")
if $line;
}
-sub ATTRS_handler () {
+sub ATTRS_handler {
+ my $self = shift;
+ $_ = shift;
+
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
trim_whitespace($_);
}
}
-sub ALIAS_handler () {
+sub ALIAS_handler {
+ my $self = shift;
+ $_ = shift;
+
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
trim_whitespace($_);
- GetAliases($_) if $_;
+ $self->get_aliases($_) if $_;
}
}
-sub OVERLOAD_handler() {
+sub OVERLOAD_handler {
+ my $self = shift;
+ $_ = shift;
+
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
next unless /\S/;
trim_whitespace($_);
}
}
-sub FALLBACK_handler() {
+sub FALLBACK_handler {
+ my $self = shift;
+ $_ = shift;
+
# the rest of the current line should contain either TRUE,
# FALSE or UNDEF
);
# check for valid FALLBACK value
- death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
+ $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
$self->{Fallback} = $map{uc $_};
}
-sub REQUIRE_handler () {
+sub REQUIRE_handler {
+ my $self = shift;
# the rest of the current line should contain a version number
- my ($Ver) = $_;
+ my $Ver = shift;
trim_whitespace($Ver);
- death ("Error: REQUIRE expects a version number")
+ $self->death("Error: REQUIRE expects a version number")
unless $Ver;
# check that the version number is of the form n.n
- death ("Error: REQUIRE: expected a number, got '$Ver'")
+ $self->death("Error: REQUIRE: expected a number, got '$Ver'")
unless $Ver =~ /^\d+(\.\d*)?/;
- death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
+ $self->death("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
unless $VERSION >= $Ver;
}
-sub VERSIONCHECK_handler () {
+sub VERSIONCHECK_handler {
+ my $self = shift;
+ $_ = shift;
+
# the rest of the current line should contain either ENABLE or
# DISABLE
trim_whitespace($_);
# check for ENABLE/DISABLE
- death ("Error: VERSIONCHECK: ENABLE/DISABLE")
+ $self->death("Error: VERSIONCHECK: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)/i;
$self->{WantVersionChk} = 1 if $1 eq 'ENABLE';
}
-sub PROTOTYPE_handler () {
+sub PROTOTYPE_handler {
+ my $self = shift;
+ $_ = shift;
+
my $specified;
- death("Error: Only 1 PROTOTYPE definition allowed per xsub")
+ $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub")
if $self->{proto_in_this_xsub}++;
for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) {
else {
# remove any whitespace
s/\s+//g;
- death("Error: Invalid prototype '$_'")
+ $self->death("Error: Invalid prototype '$_'")
unless valid_proto_string($_);
$self->{ProtoThisXSUB} = C_string($_);
}
$self->{ProtoUsed} = 1;
}
-sub SCOPE_handler () {
- death("Error: Only 1 SCOPE declaration allowed per xsub")
+sub SCOPE_handler {
+ my $self = shift;
+ $_ = shift;
+
+ $self->death("Error: Only 1 SCOPE declaration allowed per xsub")
if $self->{scope_in_this_xsub}++;
trim_whitespace($_);
- death ("Error: SCOPE: ENABLE/DISABLE")
+ $self->death("Error: SCOPE: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)\b/i;
$self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' );
}
-sub PROTOTYPES_handler () {
+sub PROTOTYPES_handler {
+ my $self = shift;
+ $_ = shift;
+
# the rest of the current line should contain either ENABLE or
# DISABLE
trim_whitespace($_);
# check for ENABLE/DISABLE
- death ("Error: PROTOTYPES: ENABLE/DISABLE")
+ $self->death("Error: PROTOTYPES: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)/i;
$self->{WantPrototypes} = 1 if $1 eq 'ENABLE';
$self->{WantPrototypes} = 0 if $1 eq 'DISABLE';
$self->{ProtoUsed} = 1;
+}
+
+sub EXPORT_XSUB_SYMBOLS_handler {
+ my $self = shift;
+ $_ = shift;
+ # the rest of the current line should contain either ENABLE or
+ # DISABLE
+
+ trim_whitespace($_);
+
+ # check for ENABLE/DISABLE
+ $self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE")
+ unless /^(ENABLE|DISABLE)/i;
+
+ my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL';
+
+ print Q(<<"EOF");
+##undef XS_EUPXS
+##if defined(PERL_EUPXS_ALWAYS_EXPORT)
+## define XS_EUPXS(name) XS_EXTERNAL(name)
+##elif defined(PERL_EUPXS_NEVER_EXPORT)
+## define XS_EUPXS(name) XS_INTERNAL(name)
+##else
+## define XS_EUPXS(name) $xs_impl(name)
+##endif
+EOF
}
+
sub PushXSStack {
+ my $self = shift;
my %args = @_;
# Save the current file context.
push(@{ $self->{XSStack} }, {
LineNo => $self->{line_no},
Filename => $self->{filename},
Filepathname => $self->{filepathname},
- Handle => $FH,
+ Handle => $self->{FH},
IsPipe => scalar($self->{filename} =~ /\|\s*$/),
%args,
});
}
-sub INCLUDE_handler () {
+sub INCLUDE_handler {
+ my $self = shift;
+ $_ = shift;
# the rest of the current line should contain a valid filename
trim_whitespace($_);
- death("INCLUDE: filename missing")
+ $self->death("INCLUDE: filename missing")
unless $_;
- death("INCLUDE: output pipe is illegal")
+ $self->death("INCLUDE: output pipe is illegal")
if /^\s*\|/;
# simple minded recursion detector
- death("INCLUDE loop detected")
+ $self->death("INCLUDE loop detected")
if $self->{IncludedFiles}->{$_};
++$self->{IncludedFiles}->{$_} unless /\|\s*$/;
if (/\|\s*$/ && /^\s*perl\s/) {
- Warn("The INCLUDE directive with a command is discouraged." .
- " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
- " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
- " up the correct perl. The INCLUDE_COMMAND directive allows" .
- " the use of \$^X as the currently running perl, see" .
- " 'perldoc perlxs' for details.");
+ Warn( $self, "The INCLUDE directive with a command is discouraged." .
+ " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
+ " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
+ " up the correct perl. The INCLUDE_COMMAND directive allows" .
+ " the use of \$^X as the currently running perl, see" .
+ " 'perldoc perlxs' for details.");
}
- PushXSStack();
+ $self->PushXSStack();
- $FH = Symbol::gensym();
+ $self->{FH} = Symbol::gensym();
# open the new file
- open ($FH, "$_") or death("Cannot open '$_': $!");
+ open($self->{FH}, $_) or $self->death("Cannot open '$_': $!");
print Q(<<"EOF");
#
EOF
$self->{filename} = $_;
- $self->{filepathname} = File::Spec->catfile($self->{dir}, $self->{filename});
+ $self->{filepathname} = ( $^O =~ /^mswin/i )
+ ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32?
+ : File::Spec->catfile($self->{dir}, $self->{filename});
# Prime the pump by reading the first
# non-blank line
# skip leading blank lines
- while (<$FH>) {
+ while (readline($self->{FH})) {
last unless /^\s*$/;
}
return join (' ', ($cmd, @args));
}
-sub INCLUDE_COMMAND_handler () {
+sub INCLUDE_COMMAND_handler {
+ my $self = shift;
+ $_ = shift;
# the rest of the current line should contain a valid command
trim_whitespace($_);
$_ = QuoteArgs($_) if $^O eq 'VMS';
- death("INCLUDE_COMMAND: command missing")
+ $self->death("INCLUDE_COMMAND: command missing")
unless $_;
- death("INCLUDE_COMMAND: pipes are illegal")
+ $self->death("INCLUDE_COMMAND: pipes are illegal")
if /^\s*\|/ or /\|\s*$/;
- PushXSStack( IsPipe => 1 );
+ $self->PushXSStack( IsPipe => 1 );
- $FH = Symbol::gensym();
+ $self->{FH} = Symbol::gensym();
# If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
# the same perl interpreter as we're currently running
s/^\s*\$\^X/$^X/;
# open the new file
- open ($FH, "-|", "$_")
- or death("Cannot run command '$_' to include its output: $!");
+ open ($self->{FH}, "-|", $_)
+ or $self->death( $self, "Cannot run command '$_' to include its output: $!");
print Q(<<"EOF");
#
$self->{filename} = $_;
$self->{filepathname} = $self->{filename};
- $self->{filepathname} =~ s/\"/\\"/g;
+ #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21
+ $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938
# Prime the pump by reading the first
# non-blank line
# skip leading blank lines
- while (<$FH>) {
+ while (readline($self->{FH})) {
last unless /^\s*$/;
}
$self->{lastline_no} = $.;
}
-sub PopFile() {
+sub PopFile {
+ my $self = shift;
+
return 0 unless $self->{XSStack}->[-1]{type} eq 'file';
my $data = pop @{ $self->{XSStack} };
--$self->{IncludedFiles}->{$self->{filename}}
unless $isPipe;
- close $FH;
+ close $self->{FH};
- $FH = $data->{Handle};
+ $self->{FH} = $data->{Handle};
# $filename is the leafname, which for some reason isused for diagnostic
# messages, whereas $filepathname is the full pathname, and is used for
# #line directives.
return 1;
}
-sub check_cpp {
- my ($self) = @_;
- my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} });
- if (@cpp) {
- my ($cpp, $cpplevel);
- for $cpp (@cpp) {
- if ($cpp =~ /^\#\s*if/) {
- $cpplevel++;
- }
- elsif (!$cpplevel) {
- Warn("Warning: #else/elif/endif without #if in this function");
- print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
- if $self->{XSStack}->[-1]{type} eq 'if';
- return;
- }
- elsif ($cpp =~ /^\#\s*endif/) {
- $cpplevel--;
- }
- }
- Warn("Warning: #if without #endif in this function") if $cpplevel;
- }
-}
-
-
sub Q {
my($text) = @_;
$text =~ s/^#//gm;
$text;
}
-# Read next xsub into @{ $self->{line} } from ($lastline, <$FH>).
+# Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})).
sub fetch_para {
+ my $self = shift;
+
# parse paragraph
- death ("Error: Unterminated `#if/#ifdef/#ifndef'")
+ $self->death("Error: Unterminated '#if/#ifdef/#ifndef'")
if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if';
@{ $self->{line} } = ();
@{ $self->{line_no} } = ();
- return PopFile() if !defined $self->{lastline};
+ return $self->PopFile() if !defined $self->{lastline};
if ($self->{lastline} =~
/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
$self->{Prefix} = defined($3) ? $3 : ''; # keep -w happy
$self->{Prefix} = quotemeta $self->{Prefix};
($self->{Module_cname} = $Module) =~ s/\W/_/g;
- ($Packid = $Package) =~ tr/:/_/;
+ ($self->{Packid} = $Package) =~ tr/:/_/;
$self->{Packprefix} = $Package;
$self->{Packprefix} .= "::" if $self->{Packprefix} ne "";
$self->{lastline} = "";
for (;;) {
# Skip embedded PODs
while ($self->{lastline} =~ /^=/) {
- while ($self->{lastline} = <$FH>) {
+ while ($self->{lastline} = readline($self->{FH})) {
last if ($self->{lastline} =~ /^=cut\s*$/);
}
- death ("Error: Unterminated pod") unless $self->{lastline};
- $self->{lastline} = <$FH>;
+ $self->death("Error: Unterminated pod") unless $self->{lastline};
+ $self->{lastline} = readline($self->{FH});
chomp $self->{lastline};
$self->{lastline} =~ s/^\s+$//;
}
+
+ # This chunk of code strips out (and parses) embedded TYPEMAP blocks
+ # which support a HEREdoc-alike block syntax.
+ # This is special cased from the usual paragraph-handler logic
+ # due to the HEREdoc-ish syntax.
+ if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+))\s*;?\s*$/) {
+ my $end_marker = quotemeta(defined($1) ? $2 : $3);
+ my @tmaplines;
+ while (1) {
+ $self->{lastline} = readline($self->{FH});
+ $self->death("Error: Unterminated typemap") if not defined $self->{lastline};
+ last if $self->{lastline} =~ /^$end_marker\s*$/;
+ push @tmaplines, $self->{lastline};
+ }
+
+ my $tmapcode = join "", @tmaplines;
+ my $tmap = ExtUtils::Typemaps->new(
+ string => $tmapcode,
+ lineno_offset => $self->current_line_number()+1,
+ fake_filename => $self->{filename},
+ );
+ $self->{typemap}->merge(typemap => $tmap, replace => 1);
+
+ last unless defined($self->{lastline} = readline($self->{FH}));
+ next;
+ }
+
if ($self->{lastline} !~ /^\s*#/ ||
# CPP directives:
# ANSI: if ifdef ifndef elif else endif define undef
}
# Read next line and continuation lines
- last unless defined($self->{lastline} = <$FH>);
+ last unless defined($self->{lastline} = readline($self->{FH}));
$self->{lastline_no} = $.;
my $tmp_line;
$self->{lastline} .= $tmp_line
- while ($self->{lastline} =~ /\\$/ && defined($tmp_line = <$FH>));
+ while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH})));
chomp $self->{lastline};
$self->{lastline} =~ s/^\s+$//;
$argsref->{printed_name},
);
my $arg = "ST(" . ($num - 1) . ")";
- my ($argoff, $ntype, $tk);
+ my ($argoff, $ntype);
$argoff = $num - 1;
+ my $typemaps = $self->{typemap};
+
$type = tidy_type($type);
- blurt("Error: '$type' not in typemap"), return
- unless defined($self->{type_kind}->{$type});
+ $self->blurt("Error: '$type' not in typemap"), return
+ unless $typemaps->get_typemap(ctype => $type);
($ntype = $type) =~ s/\s*\*/Ptr/g;
my $subtype;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
- $tk = $self->{type_kind}->{$type};
- $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
- if ($tk eq 'T_PV' and exists $self->{lengthof}->{$var}) {
+ my $typem = $typemaps->get_typemap(ctype => $type);
+ my $xstype = $typem->xstype;
+ $xstype =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
+ if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) {
print "\t$var" unless $printed_name;
print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
die "default value not supported with length(NAME) supplied"
return;
}
$type =~ tr/:/_/ unless $self->{hiertype};
- blurt("Error: No INPUT definition for type '$type', typekind '$self->{type_kind}->{$type}' found"), return
- unless defined $self->{input_expr}->{$tk};
- my $expr = $self->{input_expr}->{$tk};
+
+ my $inputmap = $typemaps->get_inputmap(xstype => $xstype);
+ $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"), return
+ unless defined $inputmap;
+
+ my $expr = $inputmap->cleaned_code;
+ # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen
if ($expr =~ /DO_ARRAY_ELEM/) {
- blurt("Error: '$subtype' not in typemap"), return
- unless defined($self->{type_kind}->{$subtype});
- blurt("Error: No INPUT definition for type '$subtype', typekind '$self->{type_kind}->{$subtype}' found"), return
- unless defined $self->{input_expr}->{$self->{type_kind}->{$subtype}};
- my $subexpr = $self->{input_expr}->{$self->{type_kind}->{$subtype}};
+ my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
+ $self->blurt("Error: C type '$subtype' not in typemap"), return
+ if not $subtypemap;
+ my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype);
+ $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
+ unless $subinputmap;
+ my $subexpr = $subinputmap->cleaned_code;
$subexpr =~ s/\$type/\$subtype/g;
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
my $arg = "ST(" . ($num - ($num != 0)) . ")";
my $ntype;
+ my $typemaps = $self->{typemap};
+
$type = tidy_type($type);
if ($type =~ /^array\(([^,]*),(.*)\)/) {
print "\t$arg = sv_newmortal();\n";
print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
}
else {
- blurt("Error: '$type' not in typemap"), return
- unless defined($self->{type_kind}->{$type});
- blurt("Error: No OUTPUT definition for type '$type', typekind '$self->{type_kind}->{$type}' found"), return
- unless defined $self->{output_expr}->{$self->{type_kind}->{$type}};
+ my $typemap = $typemaps->get_typemap(ctype => $type);
+ $self->blurt("Could not find a typemap for C type '$type'"), return
+ if not $typemap;
+ my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype);
+ $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"), return
+ unless $outputmap;
($ntype = $type) =~ s/\s*\*/Ptr/g;
$ntype =~ s/\(\)//g;
my $subtype;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
- my $expr = $self->{output_expr}->{$self->{type_kind}->{$type}};
+
+ my $expr = $outputmap->cleaned_code;
if ($expr =~ /DO_ARRAY_ELEM/) {
- blurt("Error: '$subtype' not in typemap"), return
- unless defined($self->{type_kind}->{$subtype});
- blurt("Error: No OUTPUT definition for type '$subtype', typekind '$self->{type_kind}->{$subtype}' found"), return
- unless defined $self->{output_expr}->{$self->{type_kind}->{$subtype}};
- my $subexpr = $self->{output_expr}->{$self->{type_kind}->{$subtype}};
+ my $subtypemap = $typemaps->get_typemap(ctype => $subtype);
+ $self->blurt("Could not find a typemap for C type '$subtype'"), return
+ if not $subtypemap;
+ my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype);
+ $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return
+ unless $suboutputmap;
+ my $subexpr = $suboutputmap->cleaned_code;
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
$subexpr =~ s/\$var/${var}[ix_$var]/g;
}
}
-sub Warn {
- # work out the line number
- my $warn_line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1];
-
- print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
-}
-
-sub blurt {
- Warn @_;
- $self->{errors}++
-}
-
-sub death {
- Warn @_;
- exit 1;
-}
-
-sub print_preprocessor_statements {
- my ($self, $XSS_work_idx, $BootCode_ref) = @_;
-
- my $statement = $+;
- if ($statement eq 'if') {
- $XSS_work_idx = @{ $self->{XSStack} };
- push(@{ $self->{XSStack} }, {type => 'if'});
- }
- else {
- death ("Error: `$statement' with no matching `if'")
- if $self->{XSStack}->[-1]{type} ne 'if';
- if ($self->{XSStack}->[-1]{varname}) {
- push(@{ $self->{InitFileCode} }, "#endif\n");
- push(@{ $BootCode_ref }, "#endif");
- }
-
- my(@fns) = keys %{$self->{XSStack}->[-1]{functions}};
- if ($statement ne 'endif') {
- # Hide the functions defined in other #if branches, and reset.
- @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns;
- @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {});
- }
- else {
- my($tmp) = pop(@{ $self->{XSStack} });
- 0 while (--$XSS_work_idx
- && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if');
- # Keep all new defined functions
- push(@fns, keys %{$tmp->{other_functions}});
- @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
- }
- }
- return ($self, $XSS_work_idx, $BootCode_ref);
-}
-
1;
+
+# vim: ts=2 sw=2 et:
https://perl5.git.perl.org / perl5.git / blobdiff