X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2Fxsubpp;h=b5dfa610c02097eda4d8c52ab683013ca56bd13d;hb=80a5d8e74b5512d4ab704d0e83466ae41247ce55;hp=3fbb3654d89cec81d104dd5b65d0fbffd4dd5a88;hpb=c2452817bba58a2cb577b1ed636309441032e9cf;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 3fbb365..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. @@ -98,9 +102,9 @@ perl(1), perlxs(1), perlxstut(1) =cut -require 5.0; +require 5.002; use Cwd; -use vars '$cplusplus'; +use vars qw($cplusplus $hiertype); use vars '%v'; use Config; @@ -132,6 +136,7 @@ $WantVersionChk = 1 ; $ProtoUsed = 0 ; $WantLineNumbers = 1 ; $WantOptimize = 1 ; +$Overload = 0; my $process_inout = 1; my $process_argtypes = 1; @@ -141,6 +146,7 @@ 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'; @@ -196,7 +202,7 @@ sub TidyType # change multiple whitespace into a single space s/\s+/ /g ; - + # trim leading & trailing whitespace TrimWhitespace($_) ; @@ -211,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; } @@ -238,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) ; } @@ -260,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 @@ -285,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 + REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE - SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL + SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD )) . "|$END)\\s*:"; # Input: ($_, @line) == unparsed input. @@ -358,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)) { @@ -369,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"; } @@ -386,7 +392,7 @@ sub process_keyword($) my($pattern) = @_ ; my $kwd ; - &{"${kwd}_handler"}() + &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; } @@ -402,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 = $_ ; @@ -410,6 +416,14 @@ 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 ; @@ -421,8 +435,8 @@ sub INPUT_handler { # 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"; @@ -440,7 +454,7 @@ 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 ; $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ @@ -489,21 +503,21 @@ sub OUTPUT_handler { } else { &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); } - delete $in_out{$outarg} # No need to auto-OUTPUT + 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; @@ -517,9 +531,9 @@ sub INTERFACE_MACRO_handler() { sub INTERFACE_handler() { my $in = merge_section(); - + TrimWhitespace($in); - + foreach (split /[\s,]+/, $in) { $Interfaces{$_} = $_; } @@ -530,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 { @@ -553,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} ; @@ -588,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 @@ -603,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)) { @@ -634,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 @@ -657,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 } } @@ -676,7 +705,7 @@ sub SCOPE_handler () sub PROTOTYPES_handler () { # the rest of the current line should contain either ENABLE or - # DISABLE + # DISABLE TrimWhitespace($_) ; @@ -693,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 $_ ; @@ -718,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' */ @@ -732,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 @@ -742,9 +771,9 @@ EOF $lastline = $_ ; $lastline_no = $. ; - + } - + sub PopFile() { return 0 unless $XSStack[-1]{type} eq 'file' ; @@ -752,7 +781,7 @@ sub PopFile() my $data = pop @XSStack ; my $ThisFile = $filename ; my $isPipe = ($filename =~ /\|\s*$/) ; - + -- $IncludedFiles{$filename} unless $isPipe ; @@ -840,15 +869,15 @@ open($FH, $filename) or die "cannot open $filename: $!\n"; # Identify the version of xsubpp used print <) { last if ($lastline =~ /^=cut\s*$/); @@ -1005,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(%argtype_seen) ; undef(@outlist) ; undef(%in_out) ; + undef(%lengthof) ; + # undef(%islengthof) ; undef($proto_in_this_xsub) ; undef($scope_in_this_xsub) ; undef($interface); @@ -1074,7 +1106,7 @@ while (fetch_para()) { $orig_args =~ s/\\\s*/ /g; # process line continuations - my %only_outlist; + 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) { @@ -1082,10 +1114,10 @@ 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; @@ -1093,14 +1125,26 @@ while (fetch_para()) { my $type = $1; $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 } - $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + $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; } @@ -1114,7 +1158,7 @@ while (fetch_para()) { if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { my $out_type = $1; next if $out_type eq 'IN'; - $only_outlist{$_} = 1 if $out_type eq "OUTLIST"; + $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; push @outlist, $name if $out_type =~ /OUTLIST$/; $in_out{$_} = $out_type; } @@ -1139,7 +1183,7 @@ while (fetch_para()) { last; } } - if ($only_outlist{$args[$i]}) { + if ($only_C_inlist{$args[$i]}) { push @args_num, undef; } else { push @args_num, ++$num_args; @@ -1204,12 +1248,12 @@ 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)"); @@ -1250,7 +1294,7 @@ EOF $gotRETVAL = 0; INPUT_handler() ; - process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ; + process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ; print Q<<"EOF" if $ScopeThisXSUB; # ENTER; @@ -1284,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|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; + process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ; if (check_keyword("PPCODE")) { print_section(); @@ -1336,7 +1380,7 @@ EOF # $wantRETVAL set if 'RETVAL =' autogenerated ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; undef %outargs ; - process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); + process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) for grep $in_out{$_} =~ /OUT$/, keys %in_out; @@ -1384,7 +1428,7 @@ EOF generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; # do cleanup - process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ; + process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ; print Q<<"EOF" if $ScopeThisXSUB; # ]] @@ -1451,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"); @@ -1473,7 +1517,7 @@ EOF # sv_setpv((SV*)cv$proto) ; EOF } - } + } elsif (@Attributes) { push(@InitFileCode, Q<<"EOF"); # cv = newXS(\"$pname\", XS_$Full_func_name, file); @@ -1535,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 ; @@ -1555,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; @@ -1590,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 @@ -1614,19 +1670,26 @@ 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}} ; @@ -1657,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 { @@ -1755,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) {