map_type
standard_XS_defs
assign_func_args
- print_preprocessor_statements
+ analyze_preprocessor_statements
set_cond
+ Warn
+ CurrentLineNumber
+ blurt
+ death
+ check_conditional_preprocessor_statements
);
our @ISA = qw(Exporter);
$FH, $Package, $func_name, $Full_func_name, $pname, $ALIAS,
);
-our $self = {};
+our $self = bless {} => __PACKAGE__;
sub process_file {
# 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 ];
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);
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/;
# 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(%{ $self->{in_out} });
- undef(%{ $self->{lengthof} });
- undef($self->{proto_in_this_xsub});
- undef($self->{scope_in_this_xsub});
- undef($self->{interface});
- $self->{interface_macro} = 'XSINTERFACE_FUNC';
- $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
- $self->{ProtoThisXSUB} = $self->{WantPrototypes};
- $self->{ScopeThisXSUB} = 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|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} }, "");
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} };
my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
my $static = 1 if $self->{ret_type} =~ s/^static\s+//;
my $func_header = shift(@{ $self->{line} });
- blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
+ $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);
# 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}++;
}
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 {
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->{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;
}
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")) {
+ $self->print_section();
}
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");
generate_output( {
type => $self->{var_types}->{$_},
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};
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";
}
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} };
}
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
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;
+ $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;
+ $_ = 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 INIT_handler {
+ my $self = shift;
+ $self->print_section();
+}
-sub GetAliases {
+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 PushXSStack {
+ my $self = shift;
my %args = @_;
# Save the current file context.
push(@{ $self->{XSStack} }, {
}
-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();
# open the new file
- open ($FH, "$_") or death("Cannot open '$_': $!");
+ open ($FH, "$_") or $self->death("Cannot open '$_': $!");
print Q(<<"EOF");
#
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();
# open the new file
open ($FH, "-|", "$_")
- or death("Cannot run command '$_' to include its output: $!");
+ or $self->death( $self, "Cannot run command '$_' to include its output: $!");
print Q(<<"EOF");
#
$self->{lastline_no} = $.;
}
-sub PopFile() {
+sub PopFile {
+ my $self = shift;
+
return 0 unless $self->{XSStack}->[-1]{type} eq 'file';
my $data = pop @{ $self->{XSStack} };
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;
# Read next xsub into @{ $self->{line} } from ($lastline, <$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*$/) {
while ($self->{lastline} = <$FH>) {
last if ($self->{lastline} =~ /^=cut\s*$/);
}
- death ("Error: Unterminated pod") unless $self->{lastline};
+ $self->death("Error: Unterminated pod") unless $self->{lastline};
$self->{lastline} = <$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} = <$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->CurrentLineNumber()+1,
+ fake_filename => $self->{filename},
+ );
+ $self->{typemap}->merge(typemap => $tmap, replace => 1);
+
+ last unless defined($self->{lastline} = <$FH>);
+ next;
+ }
+
if ($self->{lastline} !~ /^\s*#/ ||
# CPP directives:
# ANSI: if ifdef ifndef elif else endif define undef
$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;
-}
-
1;
# vim: ts=2 sw=2 et:
https://perl5.git.perl.org / perl5.git / blobdiff