X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e15ca23a92d880854f025fe87b3b773259728d6f..b33c3c199a4d1a7f93b3afad435f77c0ff4988ba:/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index 8ac143e..106883a 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -11,12 +11,12 @@ use Symbol; our $VERSION; BEGIN { - $VERSION = '3.22'; + $VERSION = '3.41'; + require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION); + require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION); + require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION); + require ExtUtils::ParseXS::Eval; ExtUtils::ParseXS::Eval->VERSION($VERSION); } -use ExtUtils::ParseXS::Constants $VERSION; -use ExtUtils::ParseXS::CountLines $VERSION; -use ExtUtils::ParseXS::Utilities $VERSION; -use ExtUtils::ParseXS::Eval $VERSION; $VERSION = eval $VERSION if $VERSION =~ /_/; use ExtUtils::ParseXS::Utilities qw( @@ -42,6 +42,7 @@ use ExtUtils::ParseXS::Utilities qw( our @EXPORT_OK = qw( process_file report_error_count + errors ); ############################## @@ -79,12 +80,7 @@ sub process_file { # Allow for $package->process_file(%hash), $obj->process_file, and process_file() if (@_ % 2) { my $invocant = shift; - if (ref($invocant)) { - $self = $invocant; - } - else { - $self = $invocant->new; - } + $self = ref($invocant) ? $invocant : $invocant->new; } else { $self = $Singleton; @@ -123,15 +119,15 @@ sub process_file { } @{ $self->{XSStack} } = ({type => 'none'}); $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ]; - $self->{Overload} = 0; - $self->{errors} = 0; + $self->{Overload} = 0; # bool + $self->{errors} = 0; # count $self->{Fallback} = '&PL_sv_undef'; # Most of the 1500 lines below uses these globals. We'll have to # clean this up sometime, probably. For now, we just pull them out # of %args. -Ken - $self->{hiertype} = $args{hiertype}; + $self->{RetainCplusplusHierarchicalTypes} = $args{hiertype}; $self->{WantPrototypes} = $args{prototypes}; $self->{WantVersionChk} = $args{versioncheck}; $self->{WantLineNumbers} = $args{linenumbers}; @@ -205,7 +201,7 @@ EOM # is a basename'd $args{filename} due to chdir above) open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n"; - firstmodule: + FIRSTMODULE: while (readline($self->{FH})) { if (/^=/) { my $podstartline = $.; @@ -227,7 +223,7 @@ EOM print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname})) if $self->{WantLineNumbers}; - next firstmodule + next FIRSTMODULE; } } while (readline($self->{FH})); @@ -297,14 +293,14 @@ EOM $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->{processing_arg_with_types} = 0; # bool + $self->{proto_in_this_xsub} = 0; # counter & bool + $self->{scope_in_this_xsub} = 0; # counter & bool + $self->{interface} = 0; # bool $self->{interface_macro} = 'XSINTERFACE_FUNC'; $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET'; - $self->{ProtoThisXSUB} = $self->{WantPrototypes}; - $self->{ScopeThisXSUB} = 0; + $self->{ProtoThisXSUB} = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype) + $self->{ScopeThisXSUB} = 0; # bool my $xsreturn = 0; @@ -363,8 +359,8 @@ EOM last; } $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++; - %{ $self->{XsubAliases} } = (); - %{ $self->{XsubAliasValues} } = (); + delete $self->{XsubAliases}; + delete $self->{XsubAliasValues}; %{ $self->{Interfaces} } = (); @{ $self->{Attributes} } = (); $self->{DoSetMagic} = 1; @@ -472,7 +468,7 @@ EOM $self->{defaults}->{$args[$i]} = $2; $self->{defaults}->{$args[$i]} =~ s/"/\\"/g; } - $self->{proto_arg}->[$i+1] = '$'; + $self->{proto_arg}->[$i+1] = '$' unless $only_C_inlist_ref->{$args[$i]}; } my $min_args = $num_args - $extra_args; $report_args =~ s/"/\\"/g; @@ -524,9 +520,10 @@ EOF EOF } else { - # cv likely to be unused + # cv and items likely to be unused print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ +# PERL_UNUSED_VAR(items); /* -W */ EOF } @@ -584,7 +581,7 @@ EOF } ); } else { - print "\t$class *"; + print "\t" . map_type($self, "$class *"); $self->{var_types}->{"THIS"} = "$class *"; $self->generate_init( { type => "$class *", @@ -691,7 +688,7 @@ EOF var => $_, do_setmagic => $self->{DoSetMagic}, do_push => undef, - } ) for grep $self->{in_out}->{$_} =~ /OUT$/, keys %{ $self->{in_out} }; + } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; my $prepush_done; # all OUTPUT done, so now push the return value on the stack @@ -802,12 +799,15 @@ EOF # EOF - $self->{newXS} = "newXS"; $self->{proto} = ""; - + unless($self->{ProtoThisXSUB}) { + $self->{newXS} = "newXS_deffile"; + $self->{file} = ""; + } + else { # Build the prototype string for the xsub - if ($self->{ProtoThisXSUB}) { $self->{newXS} = "newXSproto_portable"; + $self->{file} = ", file"; if ($self->{ProtoThisXSUB} eq 2) { # User has specified empty prototype @@ -830,20 +830,20 @@ EOF $self->{proto} = qq{, "$self->{proto}"}; } - if (%{ $self->{XsubAliases} }) { + if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) { $self->{XsubAliases}->{ $self->{pname} } = 0 unless defined $self->{XsubAliases}->{ $self->{pname} }; foreach my $xname (sort keys %{ $self->{XsubAliases} }) { my $value = $self->{XsubAliases}{$xname}; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); -# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}, file$self->{proto}); +# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # XSANY.any_i32 = $value; EOF } } elsif (@{ $self->{Attributes} }) { push(@{ $self->{InitFileCode} }, Q(<<"EOF")); -# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto}); +# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); EOF } @@ -852,18 +852,18 @@ EOF my $value = $self->{Interfaces}{$yname}; $yname = "$self->{Package}\::$yname" unless $yname =~ /::/; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); -# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}, file$self->{proto}); +# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # $self->{interface_macro_set}(cv,$value); EOF } } - elsif($self->{newXS} eq 'newXS'){ # work around P5NCI's empty newXS macro + elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro push(@{ $self->{InitFileCode} }, - " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n"); + " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } else { push(@{ $self->{InitFileCode} }, - " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n"); + " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } # END 'PARAGRAPH' 'while' loop @@ -873,6 +873,7 @@ EOF #XS_EUPXS(XS_$self->{Packid}_nil) #{ # dXSARGS; +# PERL_UNUSED_VAR(items); # XSRETURN_EMPTY; #} # @@ -881,7 +882,7 @@ EOF /* Making a sub named "$self->{Package}::()" allows the package */ /* to be findable via fetchmethod(), and causes */ /* overload::Overloaded("$self->{Package}") to return true. */ - (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil, file$self->{proto}); + (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); MAKE_FETCHMETHOD_WORK } @@ -896,11 +897,13 @@ EOF print Q(<<"EOF"); #XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ #XS_EXTERNAL(boot_$self->{Module_cname}) -EOF - - print Q(<<"EOF"); #[[ +##if PERL_VERSION_LE(5, 21, 5) # dVAR; dXSARGS; +##else +# dVAR; ${\($self->{WantVersionChk} ? + 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} +##endif EOF #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const @@ -909,11 +912,13 @@ EOF #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs #so 'file' is unused print Q(<<"EOF") if $self->{Full_func_name}; -##if (PERL_REVISION == 5 && PERL_VERSION < 9) +##if PERL_VERSION_LT(5, 9, 0) # char* file = __FILE__; ##else # const char* file = __FILE__; ##endif +# +# PERL_UNUSED_VAR(file); EOF print Q("#\n"); @@ -921,17 +926,28 @@ EOF print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ # PERL_UNUSED_VAR(items); /* -W */ -##ifdef XS_APIVERSION_BOOTCHECK +EOF + + if( $self->{WantVersionChk}){ + print Q(<<"EOF") ; +##if PERL_VERSION_LE(5, 21, 5) +# XS_VERSION_BOOTCHECK; +## ifdef XS_APIVERSION_BOOTCHECK # XS_APIVERSION_BOOTCHECK; +## endif ##endif + EOF + } else { + print Q(<<"EOF") ; +##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) +# XS_APIVERSION_BOOTCHECK; +##endif - print Q(<<"EOF") if $self->{WantVersionChk}; -# XS_VERSION_BOOTCHECK; -# EOF + } - print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces}; + print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # { # CV * cv; # @@ -939,7 +955,7 @@ EOF print Q(<<"EOF") if ($self->{Overload}); # /* register the overloading (type 'A') magic */ -##if (PERL_REVISION == 5 && PERL_VERSION < 9) +##if PERL_VERSION_LT(5, 9, 0) # PL_amagic_generation++; ##endif # /* The magic for overload gets a GV* via gv_fetchmeth as */ @@ -953,7 +969,7 @@ EOF print @{ $self->{InitFileCode} }; - print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces}; + print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # } EOF @@ -965,14 +981,15 @@ EOF } print Q(<<'EOF'); -##if (PERL_REVISION == 5 && PERL_VERSION >= 9) -# if (PL_unitcheckav) -# call_list(PL_scopestack_ix, PL_unitcheckav); -##endif -EOF - - print Q(<<"EOF"); +##if PERL_VERSION_LE(5, 21, 5) +## if PERL_VERSION_GE(5, 9, 0) +# if (PL_unitcheckav) +# call_list(PL_scopestack_ix, PL_unitcheckav); +## endif # XSRETURN_YES; +##else +# Perl_xs_boot_epilog(aTHX_ ax); +##endif #]] # EOF @@ -996,6 +1013,7 @@ sub report_error_count { return $Singleton->{errors}||0; } } +*errors = \&report_error_count; # Input: ($self, $_, @{ $self->{line} }) == unparsed input. # Output: ($_, @{ $self->{line} }) == (rest of line, following lines). @@ -1286,7 +1304,6 @@ sub get_aliases { Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") if $self->{XsubAliasValues}->{$value}; - $self->{xsubaliases} = 1; $self->{XsubAliases}->{$alias} = $value; $self->{XsubAliasValues}->{$value} = $orig_alias; } @@ -1328,7 +1345,7 @@ sub OVERLOAD_handler { $self->{Overload} = 1 unless $self->{Overload}; my $overload = "$self->{Package}\::(".$1; push(@{ $self->{InitFileCode} }, - " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}, file$self->{proto});\n"); + " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } } @@ -1564,6 +1581,25 @@ sub QuoteArgs { return join (' ', ($cmd, @args)); } +# code copied from CPAN::HandleConfig::safe_quote +# - that has doc saying leave if start/finish with same quote, but no code +# given text, will conditionally quote it to protect from shell +{ + my ($quote, $use_quote) = $^O eq 'MSWin32' + ? (q{"}, q{"}) + : (q{"'}, q{'}); + sub _safe_quote { + my ($self, $command) = @_; + # Set up quote/default quote + if (defined($command) + and $command =~ /\s/ + and $command !~ /[$quote]/) { + return qq{$use_quote$command$use_quote} + } + return $command; + } +} + sub INCLUDE_COMMAND_handler { my $self = shift; $_ = shift; @@ -1585,7 +1621,8 @@ sub INCLUDE_COMMAND_handler { # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be # the same perl interpreter as we're currently running - s/^\s*\$\^X/$^X/; + my $X = $self->_safe_quote($^X); # quotes if has spaces + s/^\s*\$\^X/$X/; # open the new file open ($self->{FH}, "-|", $_) @@ -1662,6 +1699,69 @@ sub Q { $text; } +# Process "MODULE = Foo ..." lines and update global state accordingly +sub _process_module_xs_line { + my ($self, $module, $pkg, $prefix) = @_; + + ($self->{Module_cname} = $module) =~ s/\W/_/g; + + $self->{Package} = defined($pkg) ? $pkg : ''; + $self->{Prefix} = quotemeta( defined($prefix) ? $prefix : '' ); + + ($self->{Packid} = $self->{Package}) =~ tr/:/_/; + + $self->{Packprefix} = $self->{Package}; + $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; + + $self->{lastline} = ""; +} + +# Skip any embedded POD sections +sub _maybe_skip_pod { + my ($self) = @_; + + while ($self->{lastline} =~ /^=/) { + while ($self->{lastline} = readline($self->{FH})) { + last if ($self->{lastline} =~ /^=cut\s*$/); + } + $self->death("Error: Unterminated pod") unless defined $self->{lastline}; + $self->{lastline} = readline($self->{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. +sub _maybe_parse_typemap_block { + my ($self) = @_; + + # 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); + + # Scan until we find $end_marker alone on a line. + my @tmaplines; + while (1) { + $self->{lastline} = readline($self->{FH}); + $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline}; + last if $self->{lastline} =~ /^$end_marker\s*$/; + push @tmaplines, $self->{lastline}; + } + + my $tmap = ExtUtils::Typemaps->new( + string => join("", @tmaplines), + lineno_offset => 1 + ($self->current_line_number() || 0), + fake_filename => $self->{filename}, + ); + $self->{typemap}->merge(typemap => $tmap, replace => 1); + + $self->{lastline} = ""; + } +} + # Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). sub fetch_para { my $self = shift; @@ -1671,66 +1771,38 @@ sub fetch_para { if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; @{ $self->{line} } = (); @{ $self->{line_no} } = (); - return $self->PopFile() if !defined $self->{lastline}; + return $self->PopFile() if not defined $self->{lastline}; # EOF if ($self->{lastline} =~ - /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { - my $Module = $1; - $self->{Package} = defined($2) ? $2 : ''; # keep -w happy - $self->{Prefix} = defined($3) ? $3 : ''; # keep -w happy - $self->{Prefix} = quotemeta $self->{Prefix}; - ($self->{Module_cname} = $Module) =~ s/\W/_/g; - ($self->{Packid} = $self->{Package}) =~ tr/:/_/; - $self->{Packprefix} = $self->{Package}; - $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; - $self->{lastline} = ""; + /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) + { + $self->_process_module_xs_line($1, $2, $3); } for (;;) { - # Skip embedded PODs - while ($self->{lastline} =~ /^=/) { - while ($self->{lastline} = readline($self->{FH})) { - last if ($self->{lastline} =~ /^=cut\s*$/); - } - $self->death("Error: Unterminated pod") unless $self->{lastline}; - $self->{lastline} = readline($self->{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} = readline($self->{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->current_line_number()||0)+1, - fake_filename => $self->{filename}, - ); - $self->{typemap}->merge(typemap => $tmap, replace => 1); - - $self->{lastline} = ""; - } - - if ($self->{lastline} !~ /^\s*#/ || - # CPP directives: - # ANSI: if ifdef ifndef elif else endif define undef - # line error pragma - # gcc: warning include_next - # obj-c: import - # others: ident (gcc notes that some cpps have this one) - $self->{lastline} =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { + $self->_maybe_skip_pod; + + $self->_maybe_parse_typemap_block; + + if ($self->{lastline} !~ /^\s*#/ # not a CPP directive + # CPP directives: + # ANSI: if ifdef ifndef elif else endif define undef + # line error pragma + # gcc: warning include_next + # obj-c: import + # others: ident (gcc notes that some cpps have this one) + || $self->{lastline} =~ /^\#[ \t]* + (?: + (?:if|ifn?def|elif|else|endif| + define|undef|pragma|error| + warning|line\s+\d+|ident) + \b + | (?:include(?:_next)?|import) + \s* ["<] .* [>"] + ) + /x + ) + { last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; push(@{ $self->{line} }, $self->{lastline}); push(@{ $self->{line_no} }, $self->{lastline_no}); @@ -1746,27 +1818,27 @@ sub fetch_para { chomp $self->{lastline}; $self->{lastline} =~ s/^\s+$//; } - pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) while @{ $self->{line} } && $self->{line}->[-1] eq ""; - 1; + + # Nuke trailing "line" entries until there's one that's not empty + pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) + while @{ $self->{line} } && $self->{line}->[-1] eq ""; + + return 1; } sub output_init { my $self = shift; my $argsref = shift; - my ($type, $num, $var, $init, $printed_name) = ( - $argsref->{type}, - $argsref->{num}, - $argsref->{var}, - $argsref->{init}, - $argsref->{printed_name} - ); + my ($type, $num, $var, $init, $printed_name) + = @{$argsref}{qw(type num var init printed_name)}; + # local assign for efficiently passing in to eval_input_typemap_code local $argsref->{arg} = $num ? "ST(" . ($num-1) . ")" : "/* not a parameter */"; - if ( $init =~ /^=/ ) { + if ( $init =~ /^=/ ) { if ($printed_name) { $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref); } @@ -1800,28 +1872,29 @@ sub generate_init { my $self = shift; my $argsref = shift; - my ($type, $num, $var, $printed_name) = ( - $argsref->{type}, - $argsref->{num}, - $argsref->{var}, - $argsref->{printed_name}, - ); + my ($type, $num, $var, $printed_name) + = @{$argsref}{qw(type num var printed_name)}; - my $arg = "ST(" . ($num - 1) . ")"; my $argoff = $num - 1; + my $arg = "ST($argoff)"; my $typemaps = $self->{typemap}; $type = ExtUtils::Typemaps::tidy_type($type); - $self->report_typemap_failure($typemaps, $type), return - unless $typemaps->get_typemap(ctype => $type); + if (not $typemaps->get_typemap(ctype => $type)) { + $self->report_typemap_failure($typemaps, $type); + return; + } (my $ntype = $type) =~ s/\s*\*/Ptr/g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; my $typem = $typemaps->get_typemap(ctype => $type); my $xstype = $typem->xstype; - $xstype =~ s/OBJ$/REF/ if $self->{func_name} =~ /DESTROY$/; + #this is an optimization from perl 5.0 alpha 6, class check is skipped + #T_REF_IV_REF is missing since it has no untyped analog at the moment + $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ + if $self->{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"; @@ -1829,21 +1902,29 @@ sub generate_init { if defined $self->{defaults}->{$var}; return; } - $type =~ tr/:/_/ unless $self->{hiertype}; + $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; my $inputmap = $typemaps->get_inputmap(xstype => $xstype); - $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"), return - unless defined $inputmap; + if (not defined $inputmap) { + $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"); + return; + } 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/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); - $self->report_typemap_failure($typemaps, $subtype), return - if not $subtypemap; + if (not $subtypemap) { + $self->report_typemap_failure($typemaps, $subtype); + return; + } + my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); - $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return - unless $subinputmap; + if (not $subinputmap) { + $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); + return; + } + my $subexpr = $subinputmap->cleaned_code; $subexpr =~ s/\$type/\$subtype/g; $subexpr =~ s/ntype/subtype/g; @@ -1910,13 +1991,9 @@ sub generate_init { sub generate_output { my $self = shift; my $argsref = shift; - my ($type, $num, $var, $do_setmagic, $do_push) = ( - $argsref->{type}, - $argsref->{num}, - $argsref->{var}, - $argsref->{do_setmagic}, - $argsref->{do_push} - ); + my ($type, $num, $var, $do_setmagic, $do_push) + = @{$argsref}{qw(type num var do_setmagic do_push)}; + my $arg = "ST(" . ($num - ($num != 0)) . ")"; my $typemaps = $self->{typemap}; @@ -1931,11 +2008,17 @@ sub generate_output { } else { my $typemap = $typemaps->get_typemap(ctype => $type); - $self->report_typemap_failure($typemaps, $type), return - if not $typemap; + if (not $typemap) { + $self->report_typemap_failure($typemaps, $type); + return; + } + my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); - $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"), return - unless $outputmap; + if (not $outputmap) { + $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"); + return; + } + (my $ntype = $type) =~ s/\s*\*/Ptr/g; $ntype =~ s/\(\)//g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; @@ -1944,11 +2027,17 @@ sub generate_output { my $expr = $outputmap->cleaned_code; if ($expr =~ /DO_ARRAY_ELEM/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); - $self->report_typemap_failure($typemaps, $subtype), return - if not $subtypemap; + if (not $subtypemap) { + $self->report_typemap_failure($typemaps, $subtype); + return; + } + my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); - $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return - unless $suboutputmap; + if (not $suboutputmap) { + $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); + return; + } + my $subexpr = $suboutputmap->cleaned_code; $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; @@ -1959,36 +2048,78 @@ sub generate_output { print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } elsif ($var eq 'RETVAL') { + my $orig_arg = $arg; + my $indent; + my $use_RETVALSV = 1; + my $do_mortal = 0; + my $do_copy_tmp = 1; + my $pre_expr; + local $eval_vars->{arg} = $arg = 'RETVALSV'; my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars); + if ($expr =~ /^\t\Q$arg\E = new/) { # We expect that $arg has refcnt 1, so we need to # mortalize it. - print $evalexpr; - print "\tsv_2mortal(ST($num));\n"; - print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; + $do_mortal = 1; } # If RETVAL is immortal, don't mortalize it. This code is not perfect: # It won't detect a func or expression that only returns immortals, for # example, this RE must be tried before next elsif. elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) { - print $evalexpr; + $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV + $use_RETVALSV = 0; } elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) { # We expect that $arg has refcnt >=1, so we need # to mortalize it! - print $evalexpr; - print "\tsv_2mortal(ST(0));\n"; - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; + $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block + $do_mortal = 1; } else { # Just hope that the entry would safely write it # over an already mortalized value. By - # coincidence, something like $arg = &sv_undef + # coincidence, something like $arg = &PL_sv_undef # works too, but should be caught above. - print "\tST(0) = sv_newmortal();\n"; - print $evalexpr; + $pre_expr = "RETVALSV = sv_newmortal();\n"; # new mortals don't have set magic + $do_setmagic = 0; + } + if($use_RETVALSV) { + print "\t{\n\t SV * RETVALSV;\n"; + $indent = "\t "; + } else { + $indent = "\t"; + } + print $indent.$pre_expr if $pre_expr; + + if($use_RETVALSV) { + #take control of 1 layer of indent, may or may not indent more + $evalexpr =~ s/^(\t| )/$indent/gm; + #"\t \t" doesn't draw right in some IDEs + #break down all \t into spaces + $evalexpr =~ s/\t/ /g; + #rebuild back into \t'es, \t==8 spaces, indent==4 spaces + $evalexpr =~ s/ /\t/g; + } + else { + if($do_mortal || $do_setmagic) { + #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace + $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code + } + else { #if no extra boilerplate (no mortal, no set magic) is needed + #after $evalexport, get rid of RETVALSV's visual cluter and change + $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X) + } } + #stop " RETVAL = RETVAL;" for SVPtr type + print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/; + print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'') + .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal; + print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic; + #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter + print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" + if $do_mortal || $do_setmagic || $do_copy_tmp; + print "\t}\n" if $use_RETVALSV; } elsif ($do_push) { print "\tPUSHs(sv_newmortal());\n";