Adds ``extern "C"'' to the C code.
+=item B<-hiertype>
+
+Retains '::' in type names so that C++ hierachical types can be mapped.
+
=item B<-except>
Adds exception handling stubs to the C code.
This may significantly slow down the generated code, but this is the way
B<xsubpp> of 5.005 and earlier operated.
+=item B<-noinout>
+
+Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.
+
+=item B<-noargtypes>
+
+Disable recognition of ANSI-like descriptions of function signature.
+
=back
=head1 ENVIRONMENT
require 5.002;
use Cwd;
-use vars '$cplusplus';
+use vars qw($cplusplus $hiertype);
use vars '%v';
use Config;
# Global Constants
-$XSUBPP_version = "1.9507";
+$XSUBPP_version = "1.9508";
my ($Is_VMS, $SymSet);
if ($^O eq 'VMS') {
$FH = 'File0000' ;
-$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-s pattern] [-typemap typemap]... file.xs\n";
+$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n";
-$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
-# mjn
-$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+$proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
$except = "";
$WantPrototypes = -1 ;
$ProtoUsed = 0 ;
$WantLineNumbers = 1 ;
$WantOptimize = 1 ;
+$Overload = 0;
+$Fallback = 'PL_sv_undef';
+
+my $process_inout = 1;
+my $process_argtypes = 1;
+
SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
$flag = shift @ARGV;
$flag =~ s/^-// ;
$spat = quotemeta shift, next SWITCH if $flag eq 's';
$cplusplus = 1, next SWITCH if $flag eq 'C++';
+ $hiertype = 1, next SWITCH if $flag eq 'hiertype';
$WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes';
$WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
$WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck';
$WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck';
# XXX left this in for compat
- $WantCAPI = 1, next SWITCH if $flag eq 'object_capi';
+ next SWITCH if $flag eq 'object_capi';
$except = " TRY", next SWITCH if $flag eq 'except';
push(@tm,shift), next SWITCH if $flag eq 'typemap';
$WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers';
$WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers';
$WantOptimize = 0, next SWITCH if $flag eq 'nooptimize';
$WantOptimize = 1, next SWITCH if $flag eq 'optimize';
+ $process_inout = 0, next SWITCH if $flag eq 'noinout';
+ $process_inout = 1, next SWITCH if $flag eq 'inout';
+ $process_argtypes = 0, next SWITCH if $flag eq 'noargtypes';
+ $process_argtypes = 1, next SWITCH if $flag eq 'argtypes';
(print "xsubpp version $XSUBPP_version\n"), exit
if $flag eq 'v';
die $usage;
# change multiple whitespace into a single space
s/\s+/ /g ;
-
+
# trim leading & trailing whitespace
TrimWhitespace($_) ;
../../lib/ExtUtils/typemap ../../../typemap ../../typemap
../typemap typemap);
foreach $typemap (@tm) {
- next unless -e $typemap ;
+ next unless -f $typemap ;
# skip directories, binary files etc.
- warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
+ warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
unless -T $typemap ;
- open(TYPEMAP, $typemap)
+ open(TYPEMAP, $typemap)
or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
$mode = 'Typemap';
$junk = "" ;
$current = \$junk;
while (<TYPEMAP>) {
next if /^\s*#/;
- my $line_no = $. + 1;
+ my $line_no = $. + 1;
if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
$type_kind{$type} = $kind ;
# prototype defaults to '$'
$proto = "\$" unless $proto ;
- warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
+ warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$type} = C_string($proto) ;
}
}
foreach $key (keys %input_expr) {
- $input_expr{$key} =~ s/\n+$//;
+ $input_expr{$key} =~ s/;*\s+\z//;
}
-$bal = qr[(?:(?>[^()]+)|\((?p{ $bal })\))*]; # ()-balanced
+$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
$cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
-$size = qr[,\s* (?p{ $bal }) ]x; # Third arg (to setpvn)
+$size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
foreach $key (keys %output_expr) {
use re 'eval';
($output_expr{$key} =~
m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
\s* \( \s* $cast \$arg \s* ,
- \s* ( (?p{ $bal }) ) # Set from
- ( (?p{ $size }) )? # Possible sizeof set-from
+ \s* ( (??{ $bal }) ) # Set from
+ ( (??{ $size }) )? # Possible sizeof set-from
\) \s* ; \s* $
]x);
$targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
# Match an XS keyword
$BLOCK_re= '\s*(' . join('|', qw(
- REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
- CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
- SCOPE INTERFACE INTERFACE_MACRO C_ARGS POST_CALL
+ REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
+ CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+ SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
)) . "|$END)\\s*:";
# Input: ($_, @line) == unparsed input.
my ($C_group_rex, $C_arg);
# Group in C (no support for comments or literals)
$C_group_rex = qr/ [({\[]
- (?: (?> [^()\[\]{}]+ ) | (?p{ $C_group_rex }) )*
+ (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
[)}\]] /x ;
# Chunk in C without comma at toplevel (no comments):
$C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
- | (?p{ $C_group_rex })
+ | (??{ $C_group_rex })
| " (?: (?> [^\\"]+ )
| \\.
)* " # String literal
sub print_section {
# the "do" is required for right semantics
do { $_ = shift(@line) } while !/\S/ && @line;
-
+
print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
sub merge_section {
my $in = '';
-
+
while (!/\S/ && @line) {
$_ = shift(@line);
}
-
+
for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
$in .= "$_\n";
}
my($pattern) = @_ ;
my $kwd ;
- &{"${kwd}_handler"}()
+ &{"${kwd}_handler"}()
while $kwd = check_keyword($pattern) ;
}
$_ = '' ;
}
-my $process_inout = 1;
-my $process_argtypes = 1;
-
sub INPUT_handler {
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
last if /^\s*NOT_IMPLEMENTED_YET/;
- next unless /\S/; # skip blank lines
+ next unless /\S/; # skip blank lines
TrimWhitespace($_) ;
my $line = $_ ;
# remove trailing semicolon if no initialisation
s/\s*;$//g unless /[=;+].*\S/ ;
+ # 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;
+ $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
+ }
+
# check for optional initialisation code
my $var_init = '' ;
$var_init = $1 if s/\s*([=;+].*)$//s ;
$var_init =~ s/"/\\"/g;
s/\s+/ /g;
- my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
+ my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
or blurt("Error: invalid argument declaration '$line'"), next;
# Check for duplicate definitions
blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
- if $arg_list{$var_name}++
- or defined $arg_types{$var_name} and not $processing_arg_with_types;
+ if $arg_list{$var_name}++
+ or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
$thisdone |= $var_name eq "THIS";
$retvaldone |= $var_name eq "RETVAL";
}
$var_num = $args_match{$var_name};
- $proto_arg[$var_num] = ProtoString($var_type)
+ $proto_arg[$var_num] = ProtoString($var_type)
if $var_num ;
- if ($var_addr) {
- $var_addr{$var_name} = 1;
- $func_args =~ s/\b($var_name)\b/&$1/;
- }
+ $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
- or $in_out{$var_name} and $in_out{$var_name} eq 'outlist'
+ or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
and $var_init !~ /\S/) {
if ($name_printed) {
print ";\n";
} else {
&generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
}
+ delete $in_out{$outarg} # No need to auto-OUTPUT
+ if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
}
}
sub C_ARGS_handler() {
my $in = merge_section();
-
+
TrimWhitespace($in);
$func_args = $in;
-}
+}
sub INTERFACE_MACRO_handler() {
my $in = merge_section();
-
+
TrimWhitespace($in);
if ($in =~ /\s/) { # two
($interface_macro, $interface_macro_set) = split ' ', $in;
sub INTERFACE_handler() {
my $in = merge_section();
-
+
TrimWhitespace($in);
-
+
foreach (split /[\s,]+/, $in) {
$Interfaces{$_} = $_;
}
$Interfaces = 1; # global
}
-sub CLEANUP_handler() { print_section() }
-sub PREINIT_handler() { print_section() }
-sub POST_CALL_handler() { print_section() }
-sub INIT_handler() { print_section() }
+sub CLEANUP_handler() { print_section() }
+sub PREINIT_handler() { print_section() }
+sub POSTCALL_handler() { print_section() }
+sub INIT_handler() { print_section() }
sub GetAliases
{
# check for optional package definition in the alias
$alias = $Packprefix . $alias if $alias !~ /::/ ;
-
+
# check for duplicate alias name & duplicate value
Warn("Warning: Ignoring duplicate alias '$orig_alias'")
if defined $XsubAliases{$alias} ;
if $line ;
}
+sub ATTRS_handler ()
+{
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ push @Attributes, $_;
+ }
+}
+
sub ALIAS_handler ()
{
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
}
}
+sub OVERLOAD_handler()
+{
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
+ $Overload = 1 unless $Overload;
+ my $overload = "$Package\::(".$1 ;
+ push(@InitFileCode,
+ " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
+ }
+ }
+
+}
+
+sub FALLBACK_handler()
+{
+ # the rest of the current line should contain either TRUE,
+ # FALSE or UNDEF
+
+ TrimWhitespace($_) ;
+ my %map = (
+ TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
+ FALSE => "PL_sv_no", 0 => "PL_sv_no",
+ UNDEF => "PL_sv_undef",
+ ) ;
+
+ # check for valid FALLBACK value
+ death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
+
+ $Fallback = $map{uc $_} ;
+}
+
sub REQUIRE_handler ()
{
# the rest of the current line should contain a version number
unless $Ver =~ /^\d+(\.\d*)?/ ;
death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
- unless $XSUBPP_version >= $Ver ;
+ unless $XSUBPP_version >= $Ver ;
}
sub VERSIONCHECK_handler ()
{
# the rest of the current line should contain either ENABLE or
# DISABLE
-
+
TrimWhitespace($_) ;
-
+
# check for ENABLE/DISABLE
death ("Error: VERSIONCHECK: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)/i ;
-
+
$WantVersionChk = 1 if $1 eq 'ENABLE' ;
$WantVersionChk = 0 if $1 eq 'DISABLE' ;
-
+
}
sub PROTOTYPE_handler ()
{
my $specified ;
- death("Error: Only 1 PROTOTYPE definition allowed per xsub")
+ death("Error: Only 1 PROTOTYPE definition allowed per xsub")
if $proto_in_this_xsub ++ ;
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
$specified = 1 ;
TrimWhitespace($_) ;
if ($_ eq 'DISABLE') {
- $ProtoThisXSUB = 0
+ $ProtoThisXSUB = 0
}
elsif ($_ eq 'ENABLE') {
- $ProtoThisXSUB = 1
+ $ProtoThisXSUB = 1
}
else {
# remove any whitespace
sub SCOPE_handler ()
{
- death("Error: Only 1 SCOPE declaration allowed per xsub")
+ death("Error: Only 1 SCOPE declaration allowed per xsub")
if $scope_in_this_xsub ++ ;
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
next unless /\S/;
TrimWhitespace($_) ;
if ($_ =~ /^DISABLE/i) {
- $ScopeThisXSUB = 0
+ $ScopeThisXSUB = 0
}
elsif ($_ =~ /^ENABLE/i) {
- $ScopeThisXSUB = 1
+ $ScopeThisXSUB = 1
}
}
sub PROTOTYPES_handler ()
{
# the rest of the current line should contain either ENABLE or
- # DISABLE
+ # DISABLE
TrimWhitespace($_) ;
sub INCLUDE_handler ()
{
# the rest of the current line should contain a valid filename
-
+
TrimWhitespace($_) ;
-
+
death("INCLUDE: filename missing")
unless $_ ;
Filename => $filename,
Handle => $FH,
}) ;
-
+
++ $FH ;
# open the new file
open ($FH, "$_") or death("Cannot open '$_': $!") ;
-
+
print Q<<"EOF" ;
#
#/* INCLUDE: Including '$_' from '$filename' */
$filename = $_ ;
- # Prime the pump by reading the first
+ # Prime the pump by reading the first
# non-blank line
# skip leading blank lines
$lastline = $_ ;
$lastline_no = $. ;
-
+
}
-
+
sub PopFile()
{
return 0 unless $XSStack[-1]{type} eq 'file' ;
my $data = pop @XSStack ;
my $ThisFile = $filename ;
my $isPipe = ($filename =~ /\|\s*$/) ;
-
+
-- $IncludedFiles{$filename}
unless $isPipe ;
# Identify the version of xsubpp used
print <<EOM ;
/*
- * This file was generated automatically by xsubpp version $XSUBPP_version from the
+ * This file was generated automatically by xsubpp version $XSUBPP_version from the
* contents of $filename. Do not edit this file, edit $filename instead.
*
- * ANY CHANGES MADE HERE WILL BE LOST!
+ * ANY CHANGES MADE HERE WILL BE LOST!
*
*/
EOM
-
+
print("#line 1 \"$filename\"\n")
if $WantLineNumbers;
+firstmodule:
while (<$FH>) {
+ if (/^=/) {
+ my $podstartline = $.;
+ do {
+ if (/^=cut\s*$/) {
+ # We can't just write out a /* */ comment, as our embedded
+ # POD might itself be in a comment. We can't put a /**/
+ # comment inside #if 0, as the C standard says that the source
+ # file is decomposed into preprocessing characters in the stage
+ # before preprocessing commands are executed.
+ # I don't want to leave the text as barewords, because the spec
+ # isn't clear whether macros are expanded before or after
+ # preprocessing commands are executed, and someone pathological
+ # may just have defined one of the 3 words as a macro that does
+ # something strange. Multiline strings are illegal in C, so
+ # the "" we write must be a string literal. And they aren't
+ # concatenated until 2 steps later, so we are safe.
+ print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
+ printf("#line %d \"$filename\"\n", $. + 1)
+ if $WantLineNumbers;
+ next firstmodule
+ }
+
+ } while (<$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.
+ die ("Error: Unterminated pod in $filename, line $podstartline\n")
+ unless $lastline;
+ }
last if ($Module, $Package, $Prefix) =
/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
- if ($OBJ) {
- s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
- }
print $_;
}
&Exit unless defined $_;
}
for(;;) {
+ # Skip embedded PODs
+ while ($lastline =~ /^=/) {
+ while ($lastline = <$FH>) {
+ last if ($lastline =~ /^=cut\s*$/);
+ }
+ death ("Error: Unterminated pod") unless $lastline;
+ $lastline = <$FH>;
+ chomp $lastline;
+ $lastline =~ s/^\s+$//;
+ }
if ($lastline !~ /^\s*#/ ||
# CPP directives:
# ANSI: if ifdef ifndef elif else endif define undef
death ("Code is not inside a function"
." (maybe last function was ended by a blank line "
- ." followed by a a statement on column one?)")
+ ." followed by a statement on column one?)")
if $line[0] =~ /^\s/;
# initialize info arrays
undef(%args_match);
undef(%var_types);
- undef(%var_addr);
undef(%defaults);
undef($class);
undef($static);
undef($RETVAL_no_return) ;
undef(%arg_list) ;
undef(@proto_arg) ;
- undef(@arg_with_types) ;
+ undef(@fake_INPUT_pre) ; # For length(s) generated variables
+ undef(@fake_INPUT) ;
undef($processing_arg_with_types) ;
- undef(%arg_types) ;
- undef(@in_out) ;
+ undef(%argtype_seen) ;
+ undef(@outlist) ;
undef(%in_out) ;
+ undef(%lengthof) ;
+ # undef(%islengthof) ;
undef($proto_in_this_xsub) ;
undef($scope_in_this_xsub) ;
undef($interface);
$xsreturn = 0;
$_ = shift(@line);
- while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
+ while ($kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
&{"${kwd}_handler"}() ;
next PARAGRAPH unless @line ;
$_ = shift(@line);
($ret_type) = TidyType($_);
$RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
+ # Allow one-line ANSI-like declaration
+ unshift @line, $2
+ if $process_argtypes
+ and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
+
# a function definition needs at least 2 lines
blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
unless @line ;
last;
}
$XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
- %XsubAliases = %XsubAliasValues = %Interfaces = ();
+ %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
$DoSetMagic = 1;
$orig_args =~ s/\\\s*/ /g; # process line continuations
- my %out_vars;
+ my %only_C_inlist; # Not in the signature of Perl function
if ($process_argtypes and $orig_args =~ /\S/) {
my $args = "$orig_args ,";
- if ($args =~ /^( (?p{ $C_arg }) , )* $ /x) {
- @args = ($args =~ /\G ( (?p{ $C_arg }) ) , /xg);
+ if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
+ @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
for ( @args ) {
s/^\s+//;
s/\s+$//;
- my $arg = $_;
- my $default;
- ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
- my ($pre, $name) = ($arg =~ /(.*?) \s* \b(\w+) \s* $ /x);
+ my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
+ my ($pre, $name) = ($arg =~ /(.*?) \s*
+ \b ( \w+ | length\( \s*\w+\s* \) )
+ \s* $ /x);
next unless length $pre;
my $out_type;
my $inout_var;
- if ($process_inout and s/^(in|in_outlist|outlist)\s+//) {
+ if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
my $type = $1;
- $out_type = $type if $type ne 'in';
- $arg =~ s/^(in|in_outlist|outlist)\s+//;
+ $out_type = $type if $type ne 'IN';
+ $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
+ $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
}
- if (/\W/) { # Has a type
- push @arg_with_types, $arg;
+ my $islength;
+ if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
+ $name = "XSauto_length_of_$1";
+ $islength = 1;
+ die "Default value on length() argument: `$_'"
+ if length $default;
+ }
+ if (length $pre or $islength) { # Has a type
+ if ($islength) {
+ push @fake_INPUT_pre, $arg;
+ } else {
+ push @fake_INPUT, $arg;
+ }
# warn "pushing '$arg'\n";
- $arg_types{$name} = $arg;
- $_ = "$name$default";
+ $argtype_seen{$name}++;
+ $_ = "$name$default"; # Assigns to @args
}
- $out_vars{$_} = 1 if $out_type eq 'outlist';
- push @in_out, $name if $out_type;
+ $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;
}
} else {
} else {
@args = split(/\s*,\s*/, $orig_args);
for (@args) {
- if ($process_inout and s/^(in|in_outlist|outlist)\s+//) {
+ if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
my $out_type = $1;
- next if $out_type eq 'in';
- $out_vars{$_} = 1 if $out_type eq 'outlist';
- push @in_out, $name;
+ next if $out_type eq 'IN';
+ $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
+ push @outlist, $name if $out_type =~ /OUTLIST$/;
$in_out{$_} = $out_type;
}
}
last;
}
}
- if ($out_vars{$args[$i]}) {
+ if ($only_C_inlist{$args[$i]}) {
push @args_num, undef;
} else {
push @args_num, ++$num_args;
# print function header
print Q<<"EOF";
+#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS(XS_${Full_func_name})
#[[
# dXSARGS;
# *errbuf = '\0';
EOF
- if ($ALIAS)
+ if ($ALIAS)
{ print Q<<"EOF" if $cond }
# if ($cond)
# Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv)));
EOF
- else
+ else
{ print Q<<"EOF" if $cond }
# if ($cond)
# Perl_croak(aTHX_ "Usage: $pname($report_args)");
EOF
+ #gcc -Wall: if an xsub has no arguments and PPCODE is used
+ #it is likely none of ST, XSRETURN or XSprePUSH macros are used
+ #hence `ax' (setup by dXSARGS) is unused
+ #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
+ #but such a move could break third-party extensions
+ print Q<<"EOF" if $PPCODE and $num_args == 0;
+# PERL_UNUSED_VAR(ax); /* -Wall */
+EOF
+
print Q<<"EOF" if $PPCODE;
# SP -= items;
EOF
$gotRETVAL = 0;
INPUT_handler() ;
- process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ;
+ process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
print Q<<"EOF" if $ScopeThisXSUB;
# ENTER;
if $WantOptimize and $targetable{$type_kind{$ret_type}};
}
- if (@arg_with_types) {
- unshift @line, @arg_with_types, $_;
+ if (@fake_INPUT or @fake_INPUT_pre) {
+ unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
$_ = "";
$processing_arg_with_types = 1;
INPUT_handler() ;
}
print $deferred;
- process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
+ process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
if (check_keyword("PPCODE")) {
print_section();
# $wantRETVAL set if 'RETVAL =' autogenerated
($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
undef %outargs ;
- process_keyword("POST_CALL|OUTPUT|ALIAS|PROTOTYPE");
+ process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
+
+ &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
+ for grep $in_out{$_} =~ /OUT$/, keys %in_out;
# all OUTPUT done, so now push the return value on the stack
if ($gotRETVAL && $RETVAL_code) {
$xsreturn = 1 if $ret_type ne "void";
my $num = $xsreturn;
- my $c = @in_out;
+ my $c = @outlist;
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 @in_out;
+ generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
# do cleanup
- process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
+ process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
print Q<<"EOF" if $ScopeThisXSUB;
# ]]
else {
my $s = ';';
if ($min_args < $num_args) {
- $s = '';
+ $s = '';
$proto_arg[$min_args] .= ";" ;
}
- push @proto_arg, "$s\@"
+ push @proto_arg, "$s\@"
if $elipsis ;
-
+
$proto = ', "' . join ("", @proto_arg) . '"';
}
}
if (%XsubAliases) {
- $XsubAliases{$pname} = 0
+ $XsubAliases{$pname} = 0
unless defined $XsubAliases{$pname} ;
while ( ($name, $value) = each %XsubAliases) {
push(@InitFileCode, Q<<"EOF");
# sv_setpv((SV*)cv$proto) ;
EOF
}
- }
+ }
+ elsif (@Attributes) {
+ push(@InitFileCode, Q<<"EOF");
+# cv = newXS(\"$pname\", XS_$Full_func_name, file);
+# apply_attrs_string("$Package", cv, "@Attributes", 0);
+EOF
+ }
elsif ($interface) {
while ( ($name, $value) = each %Interfaces) {
$name = "$Package\::$name" unless $name =~ /::/;
}
}
+if ($Overload) # make it findable with fetchmethod
+{
+
+ print Q<<"EOF";
+#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
+#XS(XS_${Packid}_nil)
+#{
+# XSRETURN_EMPTY;
+#}
+#
+EOF
+ unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
+ /* Making a sub named "${Package}::()" allows the package */
+ /* to be findable via fetchmethod(), and causes */
+ /* overload::Overloaded("${Package}") to return true. */
+ newXS("${Package}::()", XS_${Packid}_nil, file$proto);
+MAKE_FETCHMETHOD_WORK
+}
+
# print initialization routine
print Q<<"EOF";
EOF
print Q<<"EOF";
+#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
#XS(boot_$Module_cname)
EOF
print Q<<"EOF";
#[[
# dXSARGS;
+EOF
+
+#-Wall: if there is no $Full_func_name there are no xsubs in this .xs
+#so `file' is unused
+print Q<<"EOF" if $Full_func_name;
# char* file = __FILE__;
-#
EOF
+print Q "#\n";
+
print Q<<"EOF" if $WantVersionChk ;
# XS_VERSION_BOOTCHECK ;
#
#
EOF
+print Q<<"EOF" if ($Overload);
+# /* register the overloading (type 'A') magic */
+# PL_amagic_generation++;
+# /* The magic for overload gets a GV* via gv_fetchmeth as */
+# /* mentioned above, and looks in the SV* slot of it for */
+# /* the "fallback" status. */
+# sv_setsv(
+# get_sv( "${Package}::()", TRUE ),
+# $Fallback
+# );
+EOF
+
print @InitFileCode;
print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
#
EOF
-warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
+warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
unless $ProtoUsed ;
&Exit;
{
# work out the line number
my $line_no = $line_no[@line_no - @line -1] ;
-
+
print STDERR "@_ in $filename, line $line_no\n" ;
}
-sub blurt
-{
+sub blurt
+{
Warn @_ ;
- $errors ++
+ $errors ++
}
sub death
local($tk);
$type = TidyType($type) ;
- blurt("Error: '$type' not in typemap"), return
+ blurt("Error: '$type' not in typemap"), return
unless defined($type_kind{$type});
($ntype = $type) =~ s/\s*\*/Ptr/g;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
$tk = $type_kind{$type};
$tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
- $type =~ tr/:/_/;
- blurt("Error: No INPUT definition for type '$type' found"), return
+ if ($tk eq 'T_PV' and exists $lengthof{$var}) {
+ print "\t$var" unless $name_printed;
+ print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
+ die "default value not supported with length(NAME) supplied"
+ if defined $defaults{$var};
+ return;
+ }
+ $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};
if ($expr =~ /DO_ARRAY_ELEM/) {
- blurt("Error: '$subtype' not in typemap"), return
+ blurt("Error: '$subtype' not in typemap"), return
unless defined($type_kind{$subtype});
- blurt("Error: No INPUT definition for type '$subtype' found"), return
+ 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}};
+ $subexpr =~ s/\$type/\$subtype/g;
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
$subexpr =~ s/\n\t/\n\t\t/g;
eval qq/print "\\t$var;\\n"/;
warn $@ if $@;
}
- $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
+ 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 $@;
- } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
+ } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
if ($name_printed) {
print ";\n";
} else {
$type = TidyType($type) ;
if ($type =~ /^array\(([^,]*),(.*)\)/) {
+ print "\t$arg = sv_newmortal();\n";
print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
} else {
blurt("Error: '$type' not in typemap"), return
unless defined($type_kind{$type});
- blurt("Error: No OUTPUT definition for type '$type' found"), return
+ blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
unless defined $output_expr{$type_kind{$type}} ;
($ntype = $type) =~ s/\s*\*/Ptr/g;
$ntype =~ s/\(\)//g;
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' found"), return
+ 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}};
$subexpr =~ s/ntype/subtype/g;
sub map_type {
my($type, $varname) = @_;
- $type =~ tr/:/_/;
+ # 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) {