X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=b5dfa610c02097eda4d8c52ab683013ca56bd13d;hb=80a5d8e74b5512d4ab704d0e83466ae41247ce55;hp=5a71e896362fc12a296f91cc9129b2fb95a274a4;hpb=ee8c7f5465f003860e2347a2946abacac39bd9b9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 5a71e89..b5dfa61 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -34,6 +34,10 @@ any makefiles generated by MakeMaker. 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. @@ -100,7 +104,7 @@ perl(1), perlxs(1), perlxstut(1) require 5.002; use Cwd; -use vars '$cplusplus'; +use vars qw($cplusplus $hiertype); use vars '%v'; use Config; @@ -109,7 +113,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9507"; +$XSUBPP_version = "1.9508"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -124,9 +128,7 @@ $FH = 'File0000' ; $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 ; @@ -134,6 +136,7 @@ $WantVersionChk = 1 ; $ProtoUsed = 0 ; $WantLineNumbers = 1 ; $WantOptimize = 1 ; +$Overload = 0; my $process_inout = 1; my $process_argtypes = 1; @@ -143,12 +146,13 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $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'; @@ -198,7 +202,7 @@ sub TidyType # change multiple whitespace into a single space s/\s+/ /g ; - + # trim leading & trailing whitespace TrimWhitespace($_) ; @@ -213,18 +217,18 @@ unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap ../../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 () { 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; } @@ -240,7 +244,7 @@ foreach $typemap (@tm) { $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) ; } @@ -262,7 +266,7 @@ foreach $typemap (@tm) { } foreach $key (keys %input_expr) { - $input_expr{$key} =~ s/\n+$//; + $input_expr{$key} =~ s/;*\s+\z//; } $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced @@ -287,9 +291,9 @@ $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # 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 POSTCALL + REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT + CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE + SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD )) . "|$END)\\s*:"; # Input: ($_, @line) == unparsed input. @@ -360,7 +364,7 @@ if ($WantLineNumbers) { 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)) { @@ -371,11 +375,11 @@ sub print_section { sub merge_section { my $in = ''; - + while (!/\S/ && @line) { $_ = shift(@line); } - + for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { $in .= "$_\n"; } @@ -388,7 +392,7 @@ sub process_keyword($) my($pattern) = @_ ; my $kwd ; - &{"${kwd}_handler"}() + &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; } @@ -404,7 +408,7 @@ sub CASE_handler { 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 = $_ ; @@ -412,19 +416,27 @@ sub INPUT_handler { # 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"; @@ -442,14 +454,11 @@ sub INPUT_handler { } $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"; @@ -494,19 +503,21 @@ sub OUTPUT_handler { } 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; @@ -520,9 +531,9 @@ sub INTERFACE_MACRO_handler() { sub INTERFACE_handler() { my $in = merge_section(); - + TrimWhitespace($in); - + foreach (split /[\s,]+/, $in) { $Interfaces{$_} = $_; } @@ -533,10 +544,10 @@ EOF $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() { print_section() } +sub PREINIT_handler() { print_section() } +sub POSTCALL_handler() { print_section() } +sub INIT_handler() { print_section() } sub GetAliases { @@ -556,7 +567,7 @@ 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} ; @@ -573,6 +584,15 @@ sub GetAliases 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)) { @@ -582,6 +602,21 @@ sub ALIAS_handler () } } +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 REQUIRE_handler () { # the rest of the current line should contain a version number @@ -597,30 +632,30 @@ sub REQUIRE_handler () 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)) { @@ -628,10 +663,10 @@ sub PROTOTYPE_handler () $specified = 1 ; TrimWhitespace($_) ; if ($_ eq 'DISABLE') { - $ProtoThisXSUB = 0 + $ProtoThisXSUB = 0 } elsif ($_ eq 'ENABLE') { - $ProtoThisXSUB = 1 + $ProtoThisXSUB = 1 } else { # remove any whitespace @@ -651,17 +686,17 @@ sub PROTOTYPE_handler () 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 } } @@ -670,7 +705,7 @@ sub SCOPE_handler () sub PROTOTYPES_handler () { # the rest of the current line should contain either ENABLE or - # DISABLE + # DISABLE TrimWhitespace($_) ; @@ -687,9 +722,9 @@ sub PROTOTYPES_handler () sub INCLUDE_handler () { # the rest of the current line should contain a valid filename - + TrimWhitespace($_) ; - + death("INCLUDE: filename missing") unless $_ ; @@ -712,12 +747,12 @@ sub INCLUDE_handler () Filename => $filename, Handle => $FH, }) ; - + ++ $FH ; # open the new file open ($FH, "$_") or death("Cannot open '$_': $!") ; - + print Q<<"EOF" ; # #/* INCLUDE: Including '$_' from '$filename' */ @@ -726,7 +761,7 @@ EOF $filename = $_ ; - # Prime the pump by reading the first + # Prime the pump by reading the first # non-blank line # skip leading blank lines @@ -736,9 +771,9 @@ EOF $lastline = $_ ; $lastline_no = $. ; - + } - + sub PopFile() { return 0 unless $XSStack[-1]{type} eq 'file' ; @@ -746,7 +781,7 @@ sub PopFile() my $data = pop @XSStack ; my $ThisFile = $filename ; my $isPipe = ($filename =~ /\|\s*$/) ; - + -- $IncludedFiles{$filename} unless $isPipe ; @@ -834,26 +869,41 @@ open($FH, $filename) or die "cannot open $filename: $!\n"; # Identify the version of xsubpp used print <) { + if (/^=/) { + my $podstartline = $.; + do { + if (/^=cut\s*$/) { + print("/* Skipped embedded POD. */\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 $_; @@ -886,6 +936,16 @@ sub fetch_para { } 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 @@ -960,13 +1020,12 @@ while (fetch_para()) { 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); @@ -975,11 +1034,14 @@ while (fetch_para()) { 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); @@ -1039,12 +1101,12 @@ while (fetch_para()) { 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 =~ /^( (??{ $C_arg }) , )* $ /x) { @@ -1052,26 +1114,38 @@ while (fetch_para()) { 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+//; + $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 { @@ -1081,11 +1155,11 @@ while (fetch_para()) { } 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; + $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; + push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$_} = $out_type; } } @@ -1109,7 +1183,7 @@ while (fetch_para()) { last; } } - if ($out_vars{$args[$i]}) { + if ($only_C_inlist{$args[$i]}) { push @args_num, undef; } else { push @args_num, ++$num_args; @@ -1148,6 +1222,7 @@ while (fetch_para()) { # print function header print Q<<"EOF"; +#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS(XS_${Full_func_name}) #[[ # dXSARGS; @@ -1173,17 +1248,26 @@ EOF # *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 @@ -1210,7 +1294,7 @@ 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; @@ -1244,15 +1328,15 @@ EOF 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(); @@ -1296,7 +1380,10 @@ EOF # $wantRETVAL set if 'RETVAL =' autogenerated ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; undef %outargs ; - process_keyword("POSTCALL|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) { @@ -1334,14 +1421,14 @@ EOF $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; # ]] @@ -1408,18 +1495,18 @@ EOF 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"); @@ -1430,7 +1517,13 @@ 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 =~ /::/; @@ -1458,16 +1551,23 @@ 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 ; # @@ -1479,6 +1579,18 @@ print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; # EOF +print Q<<"EOF" if ($Overload); +# { +# /* create the package stash */ +# HV *hv = get_hv(\"$Package\::OVERLOAD\",TRUE); +# SV *sv = *hv_fetch(hv,"register",8,1); +# sv_inc(sv); +# SvSETMAGIC(sv); +# /* Make it findable via fetchmethod */ +# newXS(\"$Package\::()\", NULL, file); +# } +EOF + print @InitFileCode; print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; @@ -1499,7 +1611,7 @@ print Q<<"EOF";; # 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; @@ -1534,14 +1646,14 @@ sub Warn { # 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 @@ -1558,23 +1670,31 @@ sub generate_init { 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/:/_/; + 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', 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; @@ -1600,7 +1720,7 @@ sub generate_init { $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 { @@ -1625,6 +1745,7 @@ sub generate_output { $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 { @@ -1697,7 +1818,8 @@ sub generate_output { 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) {