From: Nick Ing-Simmons Date: Wed, 3 Apr 2002 06:41:58 +0000 (+0000) Subject: Add -hiertype option to xsubpp for easier mapping C++ with namespaces. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0ab125c1e00cef4eab6989366621d77be6d38567;p=p5sagit%2Fp5-mst-13.2.git Add -hiertype option to xsubpp for easier mapping C++ with namespaces. p4raw-id: //depot/perlio@15696 --- diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 284279a..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; @@ -142,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'; @@ -197,7 +202,7 @@ sub TidyType # change multiple whitespace into a single space s/\s+/ /g ; - + # trim leading & trailing whitespace TrimWhitespace($_) ; @@ -214,16 +219,16 @@ unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap foreach $typemap (@tm) { 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; } @@ -239,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) ; } @@ -286,7 +291,7 @@ $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 OVERLOAD )) . "|$END)\\s*:"; @@ -359,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)) { @@ -370,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"; } @@ -387,7 +392,7 @@ sub process_keyword($) my($pattern) = @_ ; my $kwd ; - &{"${kwd}_handler"}() + &{"${kwd}_handler"}() while $kwd = check_keyword($pattern) ; } @@ -403,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 = $_ ; @@ -430,7 +435,7 @@ sub INPUT_handler { # Check for duplicate definitions blurt ("Error: duplicate definition of argument '$var_name' ignored"), next - if $arg_list{$var_name}++ + if $arg_list{$var_name}++ or defined $argtype_seen{$var_name} and not $processing_arg_with_types; $thisdone |= $var_name eq "THIS"; @@ -449,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*$/ @@ -498,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; @@ -526,9 +531,9 @@ sub INTERFACE_MACRO_handler() { sub INTERFACE_handler() { my $in = merge_section(); - + TrimWhitespace($in); - + foreach (split /[\s,]+/, $in) { $Interfaces{$_} = $_; } @@ -539,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 { @@ -562,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} ; @@ -627,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)) { @@ -658,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 @@ -681,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 } } @@ -700,7 +705,7 @@ sub SCOPE_handler () sub PROTOTYPES_handler () { # the rest of the current line should contain either ENABLE or - # DISABLE + # DISABLE TrimWhitespace($_) ; @@ -717,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 $_ ; @@ -742,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' */ @@ -756,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 @@ -766,9 +771,9 @@ EOF $lastline = $_ ; $lastline_no = $. ; - + } - + sub PopFile() { return 0 unless $XSStack[-1]{type} eq 'file' ; @@ -776,7 +781,7 @@ sub PopFile() my $data = pop @XSStack ; my $ThisFile = $filename ; my $isPipe = ($filename =~ /\|\s*$/) ; - + -- $IncludedFiles{$filename} unless $isPipe ; @@ -864,15 +869,15 @@ open($FH, $filename) or die "cannot open $filename: $!\n"; # Identify the version of xsubpp used print <) { last if ($lastline =~ /^=cut\s*$/); @@ -1243,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)"); @@ -1490,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"); @@ -1512,7 +1517,7 @@ EOF # sv_setpv((SV*)cv$proto) ; EOF } - } + } elsif (@Attributes) { push(@InitFileCode, Q<<"EOF"); # cv = newXS(\"$pname\", XS_$Full_func_name, file); @@ -1606,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; @@ -1641,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 @@ -1665,7 +1670,7 @@ 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; @@ -1679,12 +1684,12 @@ sub generate_init { if defined $defaults{$var}; return; } - $type =~ tr/:/_/; + $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}} ; @@ -1813,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) {