X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a1d55b8fd9d06a3960ba69eee30de1180602714a..5179f97822e5dcfebaf2a3fb412a1523d4009429:/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 1c07c3a..e63b133 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -1,7 +1,7 @@ package ExtUtils::ParseXS; use strict; -use 5.006; # We use /??{}/ in regexes +use 5.008001; # We use /??{}/ in regexes use Cwd; use Config; use Exporter; @@ -19,6 +19,15 @@ use ExtUtils::ParseXS::Utilities qw( process_typemaps make_targetable map_type + standard_XS_defs + assign_func_args + analyze_preprocessor_statements + set_cond + Warn + current_line_number + blurt + death + check_conditional_preprocessor_statements ); our @ISA = qw(Exporter); @@ -26,31 +35,24 @@ our @EXPORT_OK = qw( process_file report_error_count ); -our $VERSION = '3'; +our $VERSION = '3.03_01'; $VERSION = eval $VERSION if $VERSION =~ /_/; +# The scalars in the line below remain as 'our' variables because pulling +# them into $self led to build problems. In most cases, strings being +# 'eval'-ed contain the variables' names hard-coded. our ( - $ProtoUsed, @InitFileCode, $FH, $proto_re, $Overload, $errors, $Fallback, - $hiertype, $WantPrototypes, $WantVersionChk, $WantLineNumbers, $filepathname, - $dir, $filename, %IncludedFiles, %input_expr, %output_expr, - %type_kind, %proto_letter, $BLOCK_re, $lastline, $lastline_no, $Package, - $Prefix, @line, %args_match, %defaults, %var_types, %arg_list, @proto_arg, - $processing_arg_with_types, %argtype_seen, %in_out, %lengthof, - $proto_in_this_xsub, $scope_in_this_xsub, $interface, - $interface_macro, $interface_macro_set, $ProtoThisXSUB, $ScopeThisXSUB, - @line_no, $ret_type, $func_name, $Full_func_name, $Packprefix, $Packid, - %XsubAliases, %XsubAliasValues, %Interfaces, @Attributes, %outargs, $pname, - $thisdone, $retvaldone, $deferred, $gotRETVAL, $condnum, $cond, - $RETVAL_code, $printed_name, $func_args, @XSStack, $ALIAS, + $Package, $func_name, $Full_func_name, $pname, $ALIAS, ); -our ($DoSetMagic, $newXS, $proto, $Module_cname, $XsubAliases, $Interfaces, $var_num, ); + +our $self = bless {} => __PACKAGE__; sub process_file { # Allow for $package->process_file(%hash) in the future my ($pkg, %options) = @_ % 2 ? @_ : (__PACKAGE__, @_); - $ProtoUsed = exists $options{prototypes}; + $self->{ProtoUsed} = exists $options{prototypes}; # Set defaults. my %args = ( @@ -65,6 +67,7 @@ sub process_file { prototypes => 0, typemap => [], versioncheck => 1, + FH => Symbol::gensym(), %options, ); $args{except} = $args{except} ? ' TRY' : ''; @@ -77,34 +80,30 @@ sub process_file { # Establish set of global symbols with max length 28, since xsubpp # will later add the 'XS_' prefix. require ExtUtils::XSSymSet; - $SymSet = new ExtUtils::XSSymSet 28; + $SymSet = ExtUtils::XSSymSet->new(28); } - @XSStack = ({type => 'none'}); - my $XSS_work_idx = 0; - my $cpp_next_tmp = 'XSubPPtmpAAAA'; - @InitFileCode = @ExtUtils::ParseXS::Constants::InitFileCode; - $FH = $ExtUtils::ParseXS::Constants::FH; - $proto_re = $ExtUtils::ParseXS::Constants::proto_re; - $Overload = $ExtUtils::ParseXS::Constants::Overload; - $errors = $ExtUtils::ParseXS::Constants::errors; - $Fallback = $ExtUtils::ParseXS::Constants::Fallback; + @{ $self->{XSStack} } = ({type => 'none'}); + $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ]; + $self->{Overload} = 0; + $self->{errors} = 0; + $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 - $hiertype = $args{hiertype}; - $WantPrototypes = $args{prototypes}; - $WantVersionChk = $args{versioncheck}; - $WantLineNumbers = $args{linenumbers}; - - for my $f ($args{filename}) { - die "Missing required parameter 'filename'" unless $f; - $filepathname = $f; - ($dir, $filename) = (dirname($f), basename($f)); - $filepathname =~ s/\\/\\\\/g; - $IncludedFiles{$f}++; - } + $self->{hiertype} = $args{hiertype}; + $self->{WantPrototypes} = $args{prototypes}; + $self->{WantVersionChk} = $args{versioncheck}; + $self->{WantLineNumbers} = $args{linenumbers}; + $self->{IncludedFiles} = {}; + + die "Missing required parameter 'filename'" unless $args{filename}; + $self->{filepathname} = $args{filename}; + ($self->{dir}, $self->{filename}) = + (dirname($args{filename}), basename($args{filename})); + $self->{filepathname} =~ s/\\/\\\\/g; + $self->{IncludedFiles}->{$args{filename}}++; # Open the output file if given as a string. If they provide some # other kind of reference, trust them that we can print to it. @@ -115,15 +114,15 @@ sub process_file { } # Really, we shouldn't have to chdir() or select() in the first - # place. For now, just save & restore. + # place. For now, just save and restore. my $orig_cwd = cwd(); my $orig_fh = select(); - chdir($dir); + chdir($self->{dir}); my $pwd = cwd(); my $csuffix = $args{csuffix}; - if ($WantLineNumbers) { + if ($self->{WantLineNumbers}) { my $cfile; if ( $args{outfile} ) { $cfile = $args{outfile}; @@ -139,32 +138,13 @@ sub process_file { select $args{output}; } - my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = - process_typemaps( $args{typemap}, $pwd ); - - %type_kind = %{ $type_kind_ref }; - %proto_letter = %{ $proto_letter_ref }; - %input_expr = %{ $input_expr_ref }; - %output_expr = %{ $output_expr_ref }; - - foreach my $value (values %input_expr) { - $value =~ s/;*\s+\z//; - # Move C pre-processor instructions to column 1 to be strictly ANSI - # conformant. Some pre-processors are fussy about this. - $value =~ s/^\s+#/#/mg; - } - foreach my $value (values %output_expr) { - # And again. - $value =~ s/^\s+#/#/mg; - } - - my %targetable = make_targetable(\%output_expr); + $self->{typemap} = process_typemaps( $args{typemap}, $pwd ); my $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Match an XS keyword - $BLOCK_re = '\s*(' . - join('|' => @ExtUtils::ParseXS::Constants::keywords) . + $self->{BLOCK_re} = '\s*(' . + join('|' => @ExtUtils::ParseXS::Constants::XSKeywords) . "|$END)\\s*:"; our ($C_group_rex, $C_arg); @@ -181,11 +161,24 @@ sub process_file { | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal )* /xs; + # Since at this point we're ready to begin printing to the output file and + # reading from the input file, I want to get as much data as possible into + # the proto-object $self. That means assigning to $self and elements of + # %args referenced below this point. + # HOWEVER: This resulted in an error when I tried: + # $args{'s'} ---> $self->{s}. + # Use of uninitialized value in quotemeta at + # .../blib/lib/ExtUtils/ParseXS.pm line 733 + + foreach my $datum ( qw| argtypes except inout optimize | ) { + $self->{$datum} = $args{$datum}; + } + # Identify the version of xsubpp used print <{filename}. Do not edit this file, edit $self->{filename} instead. * * ANY CHANGES MADE HERE WILL BE LOST! * @@ -194,14 +187,15 @@ sub process_file { EOM - print("#line 1 \"$filepathname\"\n") - if $WantLineNumbers; + print("#line 1 \"$self->{filepathname}\"\n") + if $self->{WantLineNumbers}; - # Open the input file (using basename'd $args{filename} due to chdir above) - open($FH, $filename) or die "cannot open $filename: $!\n"; + # Open the input file (using $self->{filename} which + # is a basename'd $args{filename} due to chdir above) + open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n"; firstmodule: - while (<$FH>) { + while (readline($self->{FH})) { if (/^=/) { my $podstartline = $.; do { @@ -220,19 +214,19 @@ EOM # concatenated until 2 steps later, so we are safe. # - Nicholas Clark print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); - printf("#line %d \"$filepathname\"\n", $. + 1) - if $WantLineNumbers; + printf("#line %d \"$self->{filepathname}\"\n", $. + 1) + if $self->{WantLineNumbers}; next firstmodule } - } while (<$FH>); + } while (readline($self->{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; + die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n") + unless $self->{lastline}; } - last if ($Package, $Prefix) = + last if ($Package, $self->{Prefix}) = /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; print $_; @@ -242,210 +236,134 @@ EOM exit 0; # Not a fatal error for the caller process } - print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; - print <<"EOF"; -#ifndef PERL_UNUSED_VAR -# define PERL_UNUSED_VAR(var) if (0) var = var -#endif + standard_XS_defs(); -EOF + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; - print <<"EOF"; -#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE -#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) - -/* prototype to pass -Wmissing-prototypes */ -STATIC void -S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); - -STATIC void -S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) -{ - const GV *const gv = CvGV(cv); - - PERL_ARGS_ASSERT_CROAK_XS_USAGE; - - if (gv) { - const char *const gvname = GvNAME(gv); - const HV *const stash = GvSTASH(gv); - const char *const hvname = stash ? HvNAME(stash) : NULL; - - if (hvname) - Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); - else - Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); - } else { - /* Pants. I don't think that it should be possible to get here. */ - Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); - } -} -#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE - -#ifdef PERL_IMPLICIT_CONTEXT -#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) -#else -#define croak_xs_usage S_croak_xs_usage -#endif - -#endif - -/* NOTE: the prototype of newXSproto() is different in versions of perls, - * so we define a portable version of newXSproto() - */ -#ifdef newXS_flags -#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) -#else -#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) -#endif /* !defined(newXS_flags) */ - -EOF + $self->{lastline} = $_; + $self->{lastline_no} = $.; - print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; - - $lastline = $_; - $lastline_no = $.; - - my (@BootCode, @outlist, $prepush_done, $xsreturn, $func_header, $orig_args, ); + my $BootCode_ref = []; + my $XSS_work_idx = 0; + my $cpp_next_tmp = 'XSubPPtmpAAAA'; PARAGRAPH: - while (fetch_para()) { + while ($self->fetch_para()) { + my $outlist_ref = []; # Print initial preprocessor statements and blank lines - while (@line && $line[0] !~ /^[^\#]/) { - my $ln = shift(@line); + while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) { + my $ln = shift(@{ $self->{line} }); print $ln, "\n"; next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; my $statement = $+; - if ($statement eq 'if') { - $XSS_work_idx = @XSStack; - push(@XSStack, {type => 'if'}); - } - else { - death ("Error: `$statement' with no matching `if'") - if $XSStack[-1]{type} ne 'if'; - if ($XSStack[-1]{varname}) { - push(@InitFileCode, "#endif\n"); - push(@BootCode, "#endif"); - } - - my(@fns) = keys %{$XSStack[-1]{functions}}; - if ($statement ne 'endif') { - # Hide the functions defined in other #if branches, and reset. - @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns; - @{$XSStack[-1]}{qw(varname functions)} = ('', {}); - } - else { - my($tmp) = pop(@XSStack); - 0 while (--$XSS_work_idx - && $XSStack[$XSS_work_idx]{type} ne 'if'); - # Keep all new defined functions - push(@fns, keys %{$tmp->{other_functions}}); - @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; - } - } + ( $self, $XSS_work_idx, $BootCode_ref ) = + analyze_preprocessor_statements( + $self, $statement, $XSS_work_idx, $BootCode_ref + ); } - next PARAGRAPH unless @line; + next PARAGRAPH unless @{ $self->{line} }; - if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { + if ($XSS_work_idx && !$self->{XSStack}->[$XSS_work_idx]{varname}) { # We are inside an #if, but have not yet #defined its xsubpp variable. print "#define $cpp_next_tmp 1\n\n"; - push(@InitFileCode, "#if $cpp_next_tmp\n"); - push(@BootCode, "#if $cpp_next_tmp"); - $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; + push(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n"); + push(@{ $BootCode_ref }, "#if $cpp_next_tmp"); + $self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++; } - death ("Code is not inside a function" - ." (maybe last function was ended by a blank line " - ." followed by a statement on column one?)") - if $line[0] =~ /^\s/; - - my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return); - my (@fake_INPUT_pre); # For length(s) generated variables - my (@fake_INPUT); + $self->death( + "Code is not inside a function" + ." (maybe last function was ended by a blank line " + ." followed by a statement on column one?)") + if $self->{line}->[0] =~ /^\s/; # initialize info arrays - undef(%args_match); - undef(%var_types); - undef(%defaults); - undef(%arg_list); - undef(@proto_arg); - undef($processing_arg_with_types); - undef(%argtype_seen); - undef(@outlist); - undef(%in_out); - undef(%lengthof); - undef($proto_in_this_xsub); - undef($scope_in_this_xsub); - undef($interface); - undef($prepush_done); - $interface_macro = 'XSINTERFACE_FUNC'; - $interface_macro_set = 'XSINTERFACE_FUNC_SET'; - $ProtoThisXSUB = $WantPrototypes; - $ScopeThisXSUB = 0; - $xsreturn = 0; - - $_ = shift(@line); - while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) { - no strict 'refs'; - &{"${kwd}_handler"}(); - use strict 'refs'; - next PARAGRAPH unless @line; - $_ = shift(@line); + foreach my $member (qw(args_match var_types defaults arg_list + argtype_seen in_out lengthof)) + { + $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->{interface_macro} = 'XSINTERFACE_FUNC'; + $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET'; + $self->{ProtoThisXSUB} = $self->{WantPrototypes}; + $self->{ScopeThisXSUB} = 0; + + my $xsreturn = 0; + + $_ = shift(@{ $self->{line} }); + while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) { + my $method = $kwd . "_handler"; + $self->$method($_); + next PARAGRAPH unless @{ $self->{line} }; + $_ = shift(@{ $self->{line} }); } - if (check_keyword("BOOT")) { - &check_cpp; - push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"") - if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; - push (@BootCode, @line, ""); + if ($self->check_keyword("BOOT")) { + check_conditional_preprocessor_statements($self); + push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"$self->{filepathname}\"") + if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/; + push (@{ $BootCode_ref }, @{ $self->{line} }, ""); next PARAGRAPH; } # extract return type, function name and arguments - ($ret_type) = tidy_type($_); - $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; + ($self->{ret_type}) = tidy_type($_); + my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//; # Allow one-line ANSI-like declaration - unshift @line, $2 - if $args{argtypes} - and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; + unshift @{ $self->{line} }, $2 + if $self->{argtypes} + and $self->{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; + $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH + unless @{ $self->{line} }; - $externC = 1 if $ret_type =~ s/^extern "C"\s+//; - $static = 1 if $ret_type =~ s/^static\s+//; + my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//; + my $static = 1 if $self->{ret_type} =~ s/^static\s+//; - $func_header = shift(@line); - blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH + my $func_header = shift(@{ $self->{line} }); + $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; + my ($class, $orig_args); ($class, $func_name, $orig_args) = ($1, $2, $3); $class = "$4 $class" if $4; - ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; + ($pname = $func_name) =~ s/^($self->{Prefix})?/$self->{Packprefix}/; my $clean_func_name; - ($clean_func_name = $func_name) =~ s/^$Prefix//; - $Full_func_name = "${Packid}_$clean_func_name"; + ($clean_func_name = $func_name) =~ s/^$self->{Prefix}//; + $Full_func_name = "$self->{Packid}_$clean_func_name"; if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } # Check for duplicate function definition - for my $tmp (@XSStack) { + for my $tmp (@{ $self->{XSStack} }) { next unless defined $tmp->{functions}{$Full_func_name}; - Warn("Warning: duplicate function definition '$clean_func_name' detected"); + Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected"); last; } - $XSStack[$XSS_work_idx]{functions}{$Full_func_name}++; - %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); - $DoSetMagic = 1; + $self->{XSStack}->[$XSS_work_idx]{functions}{$Full_func_name}++; + %{ $self->{XsubAliases} } = (); + %{ $self->{XsubAliasValues} } = (); + %{ $self->{Interfaces} } = (); + @{ $self->{Attributes} } = (); + $self->{DoSetMagic} = 1; $orig_args =~ s/\\\s*/ /g; # process line continuations my @args; - my %only_C_inlist; # Not in the signature of Perl function - if ($args{argtypes} and $orig_args =~ /\S/) { + my (@fake_INPUT_pre); # For length(s) generated variables + my (@fake_INPUT); + my $only_C_inlist_ref = {}; # Not in the signature of Perl function + if ($self->{argtypes} and $orig_args =~ /\S/) { my $args = "$orig_args ,"; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); @@ -459,7 +377,7 @@ EOF next unless defined($pre) && length($pre); my $out_type = ''; my $inout_var; - if ($args{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) { + if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) { my $type = $1; $out_type = $type if $type ne 'IN'; $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; @@ -480,30 +398,30 @@ EOF push @fake_INPUT, $arg; } # warn "pushing '$arg'\n"; - $argtype_seen{$len_name}++; + $self->{argtype_seen}->{$len_name}++; $_ = "$len_name$default"; # Assigns to @args } - $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; - push @outlist, $len_name if $out_type =~ /OUTLIST$/; - $in_out{$len_name} = $out_type if $out_type; + $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength; + push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/; + $self->{in_out}->{$len_name} = $out_type if $out_type; } } else { @args = split(/\s*,\s*/, $orig_args); - Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); + Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split"); } } else { @args = split(/\s*,\s*/, $orig_args); for (@args) { - if ($args{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) { + if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) { my $out_type = $1; next if $out_type eq 'IN'; - $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; + $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST"; if ($out_type =~ /OUTLIST$/) { - push @outlist, undef; + push @{ $outlist_ref }, undef; } - $in_out{$_} = $out_type; + $self->{in_out}->{$_} = $out_type; } } } @@ -516,6 +434,7 @@ EOF my @args_num = (); my $num_args = 0; my $report_args = ''; + my $ellipsis; foreach my $i (0 .. $#args) { if ($args[$i] =~ s/\.\.\.//) { $ellipsis = 1; @@ -525,7 +444,7 @@ EOF last; } } - if ($only_C_inlist{$args[$i]}) { + if ($only_C_inlist_ref->{$args[$i]}) { push @args_num, undef; } else { @@ -535,29 +454,23 @@ EOF if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { $extra_args++; $args[$i] = $1; - $defaults{$args[$i]} = $2; - $defaults{$args[$i]} =~ s/"/\\"/g; + $self->{defaults}->{$args[$i]} = $2; + $self->{defaults}->{$args[$i]} =~ s/"/\\"/g; } - $proto_arg[$i+1] = '$'; + $self->{proto_arg}->[$i+1] = '$'; } my $min_args = $num_args - $extra_args; $report_args =~ s/"/\\"/g; $report_args =~ s/^,\s+//; - my @func_args = @args; - shift @func_args if defined($class); - - for (@func_args) { - s/^/&/ if $in_out{$_}; - } - $func_args = join(", ", @func_args); - @args_match{@args} = @args_num; + $self->{func_args} = assign_func_args($self, \@args, $class); + @{ $self->{args_match} }{@args} = @args_num; - my $PPCODE = grep(/^\s*PPCODE\s*:/, @line); - my $CODE = grep(/^\s*CODE\s*:/, @line); + my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} }); + my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} }); # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) - # to set explicit return values. + # to set explicit return values. my $EXPLICIT_RETURN = ($CODE && - ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); + ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); # The $ALIAS which follows is only explicitly called within the scope of # process_file(). In principle, it ought to be a lexical, i.e., 'my @@ -572,9 +485,9 @@ EOF # > "Crypt::Rijndael::encrypt", # But at this point we're committed to generating the *same* C code that # the current version of ParseXS.pm does. So we're declaring it as 'our'. - $ALIAS = grep(/^\s*ALIAS\s*:/, @line); + $ALIAS = grep(/^\s*ALIAS\s*:/, @{ $self->{line} }); - my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); + my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} }); $xsreturn = 1 if $EXPLICIT_RETURN; @@ -596,26 +509,19 @@ EOF # dXSI32; EOF print Q(<<"EOF") if $INTERFACE; -# dXSFUNCTION($ret_type); +# dXSFUNCTION($self->{ret_type}); EOF - if ($ellipsis) { - $cond = ($min_args ? qq(items < $min_args) : 0); - } - elsif ($min_args == $num_args) { - $cond = qq(items != $min_args); - } - else { - $cond = qq(items < $min_args || items > $num_args); - } - print Q(<<"EOF") if $args{except}; + $self->{cond} = set_cond($ellipsis, $min_args, $num_args); + + print Q(<<"EOF") if $self->{except}; # char errbuf[1024]; # *errbuf = '\0'; EOF - if($cond) { + if($self->{cond}) { print Q(<<"EOF"); -# if ($cond) +# if ($self->{cond}) # croak_xs_usage(cv, "$report_args"); EOF } @@ -641,37 +547,37 @@ EOF # Now do a block of some sort. - $condnum = 0; - $cond = ''; # last CASE: condidional - push(@line, "$END:"); - push(@line_no, $line_no[-1]); + $self->{condnum} = 0; + $self->{cond} = ''; # last CASE: conditional + push(@{ $self->{line} }, "$END:"); + push(@{ $self->{line_no} }, $self->{line_no}->[-1]); $_ = ''; - &check_cpp; - while (@line) { - &CASE_handler if check_keyword("CASE"); + check_conditional_preprocessor_statements(); + while (@{ $self->{line} }) { + $self->CASE_handler($_) if $self->check_keyword("CASE"); print Q(<<"EOF"); -# $args{except} [[ +# $self->{except} [[ EOF # do initialization of input variables - $thisdone = 0; - $retvaldone = 0; - $deferred = ""; - %arg_list = (); - $gotRETVAL = 0; + $self->{thisdone} = 0; + $self->{retvaldone} = 0; + $self->{deferred} = ""; + %{ $self->{arg_list} } = (); + $self->{gotRETVAL} = 0; - INPUT_handler(); - process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); + $self->INPUT_handler($_); + $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); - print Q(<<"EOF") if $ScopeThisXSUB; + print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ENTER; # [[ EOF - if (!$thisdone && defined($class)) { + if (!$self->{thisdone} && defined($class)) { if (defined($static) or $func_name eq 'new') { print "\tchar *"; - $var_types{"CLASS"} = "char *"; + $self->{var_types}->{"CLASS"} = "char *"; generate_init( { type => "char *", num => 1, @@ -681,7 +587,7 @@ EOF } else { print "\t$class *"; - $var_types{"THIS"} = "$class *"; + $self->{var_types}->{"THIS"} = "$class *"; generate_init( { type => "$class *", num => 1, @@ -691,39 +597,47 @@ EOF } } + # These are set if OUTPUT is found and/or CODE using RETVAL + $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0; + + my ($wantRETVAL); # do code if (/^\s*NOT_IMPLEMENTED_YET/) { print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; $_ = ''; } else { - if ($ret_type ne "void") { - print "\t" . &map_type($ret_type, 'RETVAL', $hiertype) . ";\n" - if !$retvaldone; - $args_match{"RETVAL"} = 0; - $var_types{"RETVAL"} = $ret_type; + if ($self->{ret_type} ne "void") { + print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n" + if !$self->{retvaldone}; + $self->{args_match}->{"RETVAL"} = 0; + $self->{var_types}->{"RETVAL"} = $self->{ret_type}; + my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); print "\tdXSTARG;\n" - if $args{optimize} and $targetable{$type_kind{$ret_type}}; + if $self->{optimize} and $outputmap and $outputmap->targetable; } if (@fake_INPUT or @fake_INPUT_pre) { - unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; + unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; $_ = ""; - $processing_arg_with_types = 1; - INPUT_handler(); + $self->{processing_arg_with_types} = 1; + $self->INPUT_handler($_); } - print $deferred; + print $self->{deferred}; - process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); + $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); - if (check_keyword("PPCODE")) { - print_section(); - death ("PPCODE must be last thing") if @line; - print "\tLEAVE;\n" if $ScopeThisXSUB; + if ($self->check_keyword("PPCODE")) { + $self->print_section(); + $self->death("PPCODE must be last thing") if @{ $self->{line} }; + print "\tLEAVE;\n" if $self->{ScopeThisXSUB}; print "\tPUTBACK;\n\treturn;\n"; } - elsif (check_keyword("CODE")) { - print_section(); + elsif ($self->check_keyword("CODE")) { + my $consumed_code = $self->print_section(); + if ($consumed_code =~ /\bRETVAL\b/) { + $self->{have_CODE_with_RETVAL} = 1; + } } elsif (defined($class) and $func_name eq "DESTROY") { print "\n\t"; @@ -731,7 +645,7 @@ EOF } else { print "\n\t"; - if ($ret_type ne "void") { + if ($self->{ret_type} ne "void") { print "RETVAL = "; $wantRETVAL = 1; } @@ -753,33 +667,41 @@ EOF } $func_name =~ s/^\Q$args{'s'}// if exists $args{'s'}; - $func_name = 'XSFUNCTION' if $interface; - print "$func_name($func_args);\n"; + $func_name = 'XSFUNCTION' if $self->{interface}; + print "$func_name($self->{func_args});\n"; } } # do output variables - $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section; - undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section); + $self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section; + undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section); # $wantRETVAL set if 'RETVAL =' autogenerated - ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; - undef %outargs; - process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); + ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; + undef %{ $self->{outargs} }; + + $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); + + # A CODE section with RETVAL, but no OUTPUT? FAIL! + if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') { + $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section."); + } generate_output( { - type => $var_types{$_}, - num => $args_match{$_}, + type => $self->{var_types}->{$_}, + num => $self->{args_match}->{$_}, var => $_, - do_setmagic => $DoSetMagic, + do_setmagic => $self->{DoSetMagic}, do_push => undef, - } ) for grep $in_out{$_} =~ /OUT$/, keys %in_out; + } ) for grep $self->{in_out}->{$_} =~ /OUT$/, keys %{ $self->{in_out} }; + my $prepush_done; # all OUTPUT done, so now push the return value on the stack - if ($gotRETVAL && $RETVAL_code) { - print "\t$RETVAL_code\n"; + if ($self->{gotRETVAL} && $self->{RETVAL_code}) { + print "\t$self->{RETVAL_code}\n"; } - elsif ($gotRETVAL || $wantRETVAL) { - my $t = $args{optimize} && $targetable{$type_kind{$ret_type}}; + elsif ($self->{gotRETVAL} || $wantRETVAL) { + my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); + my $t = $self->{optimize} && $outputmap && $outputmap->targetable; # Although the '$var' declared in the next line is never explicitly # used within this 'elsif' block, commenting it out leads to # disaster, starting with the first 'eval qq' inside the 'elsif' block @@ -789,32 +711,31 @@ EOF # '$var' as a substring: # <> <(IV)$var> my $var = 'RETVAL'; - my $type = $ret_type; - - # 0: type, 1: with_size, 2: how, 3: how_size - if ($t and not $t->[1] and $t->[0] eq 'p') { - # PUSHp corresponds to setpvn. Treate setpv directly - my $what = eval qq("$t->[2]"); + my $type = $self->{ret_type}; + + if ($t and not $t->{with_size} and $t->{type} eq 'p') { + # PUSHp corresponds to setpvn. Treat setpv directly + my $what = eval qq("$t->{what}"); warn $@ if $@; - + print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; $prepush_done = 1; } elsif ($t) { - my $what = eval qq("$t->[2]"); + my $what = eval qq("$t->{what}"); warn $@ if $@; - - my $tsize = $t->[3]; + + my $tsize = $t->{what_size}; $tsize = '' unless defined $tsize; $tsize = eval qq("$tsize"); warn $@ if $@; - print "\tXSprePUSH; PUSH$t->[0]($what$tsize);\n"; + print "\tXSprePUSH; PUSH$t->{type}($what$tsize);\n"; $prepush_done = 1; } else { # RETVAL almost never needs SvSETMAGIC() generate_output( { - type => $ret_type, + type => $self->{ret_type}, num => 0, var => 'RETVAL', do_setmagic => 0, @@ -823,27 +744,27 @@ EOF } } - $xsreturn = 1 if $ret_type ne "void"; + $xsreturn = 1 if $self->{ret_type} ne "void"; my $num = $xsreturn; - my $c = @outlist; + my $c = @{ $outlist_ref }; print "\tXSprePUSH;" if $c and not $prepush_done; print "\tEXTEND(SP,$c);\n" if $c; $xsreturn += $c; generate_output( { - type => $var_types{$_}, + type => $self->{var_types}->{$_}, num => $num++, var => $_, do_setmagic => 0, do_push => 1, - } ) for @outlist; + } ) for @{ $outlist_ref }; # do cleanup - process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); + $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); - print Q(<<"EOF") if $ScopeThisXSUB; + print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ]] EOF - print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE; + print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE; # LEAVE; EOF @@ -851,23 +772,23 @@ EOF print Q(<<"EOF"); # ]] EOF - print Q(<<"EOF") if $args{except}; + print Q(<<"EOF") if $self->{except}; # BEGHANDLERS # CATCHALL # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); # ENDHANDLERS EOF - if (check_keyword("CASE")) { - blurt ("Error: No `CASE:' at top of function") - unless $condnum; + if ($self->check_keyword("CASE")) { + $self->blurt("Error: No `CASE:' at top of function") + unless $self->{condnum}; $_ = "CASE: $_"; # Restore CASE: label next; } last if $_ eq "$END:"; - death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)"); + $self->death(/^$self->{BLOCK_re}/o ? "Misplaced `$1:'" : "Junk at end of function ($_)"); } - print Q(<<"EOF") if $args{except}; + print Q(<<"EOF") if $self->{except}; # if (errbuf[0]) # Perl_croak(aTHX_ errbuf); EOF @@ -888,84 +809,84 @@ EOF # EOF - $newXS = "newXS"; - $proto = ""; + $self->{newXS} = "newXS"; + $self->{proto} = ""; # Build the prototype string for the xsub - if ($ProtoThisXSUB) { - $newXS = "newXSproto_portable"; + if ($self->{ProtoThisXSUB}) { + $self->{newXS} = "newXSproto_portable"; - if ($ProtoThisXSUB eq 2) { + if ($self->{ProtoThisXSUB} eq 2) { # User has specified empty prototype } - elsif ($ProtoThisXSUB eq 1) { + elsif ($self->{ProtoThisXSUB} eq 1) { my $s = ';'; if ($min_args < $num_args) { $s = ''; - $proto_arg[$min_args] .= ";"; + $self->{proto_arg}->[$min_args] .= ";"; } - push @proto_arg, "$s\@" + push @{ $self->{proto_arg} }, "$s\@" if $ellipsis; - - $proto = join ("", grep defined, @proto_arg); + + $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); } else { # User has specified a prototype - $proto = $ProtoThisXSUB; + $self->{proto} = $self->{ProtoThisXSUB}; } - $proto = qq{, "$proto"}; + $self->{proto} = qq{, "$self->{proto}"}; } - if (%XsubAliases) { - $XsubAliases{$pname} = 0 - unless defined $XsubAliases{$pname}; - while ( my ($xname, $value) = each %XsubAliases) { - push(@InitFileCode, Q(<<"EOF")); -# cv = ${newXS}(\"$xname\", XS_$Full_func_name, file$proto); + if (%{ $self->{XsubAliases} }) { + $self->{XsubAliases}->{$pname} = 0 + unless defined $self->{XsubAliases}->{$pname}; + while ( my ($xname, $value) = each %{ $self->{XsubAliases} }) { + push(@{ $self->{InitFileCode} }, Q(<<"EOF")); +# cv = $self->{newXS}(\"$xname\", XS_$Full_func_name, file$self->{proto}); # XSANY.any_i32 = $value; EOF } } - elsif (@Attributes) { - push(@InitFileCode, Q(<<"EOF")); -# cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto); -# apply_attrs_string("$Package", cv, "@Attributes", 0); + elsif (@{ $self->{Attributes} }) { + push(@{ $self->{InitFileCode} }, Q(<<"EOF")); +# cv = $self->{newXS}(\"$pname\", XS_$Full_func_name, file$self->{proto}); +# apply_attrs_string("$Package", cv, "@{ $self->{Attributes} }", 0); EOF } - elsif ($interface) { - while ( my ($yname, $value) = each %Interfaces) { + elsif ($self->{interface}) { + while ( my ($yname, $value) = each %{ $self->{Interfaces} }) { $yname = "$Package\::$yname" unless $yname =~ /::/; - push(@InitFileCode, Q(<<"EOF")); -# cv = ${newXS}(\"$yname\", XS_$Full_func_name, file$proto); -# $interface_macro_set(cv,$value); + push(@{ $self->{InitFileCode} }, Q(<<"EOF")); +# cv = $self->{newXS}(\"$yname\", XS_$Full_func_name, file$self->{proto}); +# $self->{interface_macro_set}(cv,$value); EOF } } - elsif($newXS eq 'newXS'){ # work around P5NCI's empty newXS macro - push(@InitFileCode, - " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); + elsif($self->{newXS} eq 'newXS'){ # work around P5NCI's empty newXS macro + push(@{ $self->{InitFileCode} }, + " $self->{newXS}(\"$pname\", XS_$Full_func_name, file$self->{proto});\n"); } else { - push(@InitFileCode, - " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); + push(@{ $self->{InitFileCode} }, + " (void)$self->{newXS}(\"$pname\", XS_$Full_func_name, file$self->{proto});\n"); } } # END 'PARAGRAPH' 'while' loop - if ($Overload) { # make it findable with fetchmethod + if ($self->{Overload}) { # make it findable with fetchmethod print Q(<<"EOF"); -#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */ -#XS(XS_${Packid}_nil) +#XS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */ +#XS(XS_$self->{Packid}_nil) #{ # dXSARGS; # XSRETURN_EMPTY; #} # EOF - unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK"); + unshift(@{ $self->{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. */ - (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto); + (void)$self->{newXS}("${Package}::()", XS_$self->{Packid}_nil, file$self->{proto}); MAKE_FETCHMETHOD_WORK } @@ -978,8 +899,8 @@ MAKE_FETCHMETHOD_WORK EOF print Q(<<"EOF"); -#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ -#XS(boot_$Module_cname) +#XS(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ +#XS(boot_$self->{Module_cname}) EOF print Q(<<"EOF"); @@ -1009,20 +930,23 @@ EOF print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ # PERL_UNUSED_VAR(items); /* -W */ +##ifdef XS_APIVERSION_BOOTCHECK +# XS_APIVERSION_BOOTCHECK; +##endif EOF - print Q(<<"EOF") if $WantVersionChk; + print Q(<<"EOF") if $self->{WantVersionChk}; # XS_VERSION_BOOTCHECK; # EOF - print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces; + print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces}; # { # CV * cv; # EOF - print Q(<<"EOF") if ($Overload); + print Q(<<"EOF") if ($self->{Overload}); # /* register the overloading (type 'A') magic */ # PL_amagic_generation++; # /* The magic for overload gets a GV* via gv_fetchmeth as */ @@ -1030,20 +954,20 @@ EOF # /* the "fallback" status. */ # sv_setsv( # get_sv( "${Package}::()", TRUE ), -# $Fallback +# $self->{Fallback} # ); EOF - print @InitFileCode; + print @{ $self->{InitFileCode} }; - print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces; + print Q(<<"EOF") if defined $self->{xsubaliases} or defined $self->{interfaces}; # } EOF - if (@BootCode) { + if (@{ $BootCode_ref }) { print "\n /* Initialisation Section */\n\n"; - @line = @BootCode; - print_section(); + @{ $self->{line} } = @{ $BootCode_ref }; + $self->print_section(); print "\n /* End of Initialisation Section */\n\n"; } @@ -1060,75 +984,86 @@ EOF # EOF - warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") - unless $ProtoUsed; + warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") + unless $self->{ProtoUsed}; chdir($orig_cwd); select($orig_fh); untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; - close $FH; + close $self->{FH}; return 1; } -#sub errors { $errors } -sub report_error_count { $errors } +sub report_error_count { $self->{errors} } -# Input: ($_, @line) == unparsed input. -# Output: ($_, @line) == (rest of line, following lines). +# Input: ($self, $_, @{ $self->{line} }) == unparsed input. +# Output: ($_, @{ $self->{line} }) == (rest of line, following lines). # Return: the matched keyword if found, otherwise 0 sub check_keyword { - $_ = shift(@line) while !/\S/ && @line; + my $self = shift; + $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; } sub print_section { + my $self = shift; + # the "do" is required for right semantics - do { $_ = shift(@line) } while !/\S/ && @line; + do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; - print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n") - if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; - for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { + my $consumed_code = ''; + + print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"$self->{filepathname}\"\n") + if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; + for (; defined($_) && !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { print "$_\n"; + $consumed_code .= "$_\n"; } - print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; + + return $consumed_code; } sub merge_section { + my $self = shift; my $in = ''; - while (!/\S/ && @line) { - $_ = shift(@line); + while (!/\S/ && @{ $self->{line} }) { + $_ = shift(@{ $self->{line} }); } - for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { + for (; defined($_) && !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { $in .= "$_\n"; } chomp $in; return $in; } -sub process_keyword($) { - my($pattern) = @_; - my $kwd; +sub process_keyword { + my($self, $pattern) = @_; - no strict 'refs'; - &{"${kwd}_handler"}() - while $kwd = check_keyword($pattern); - use strict 'refs'; + while (my $kwd = $self->check_keyword($pattern)) { + my $method = $kwd . "_handler"; + $self->$method($_); + } } sub CASE_handler { - blurt ("Error: `CASE:' after unconditional `CASE:'") - if $condnum && $cond eq ''; - $cond = $_; - trim_whitespace($cond); - print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); + my $self = shift; + $_ = shift; + $self->blurt("Error: `CASE:' after unconditional `CASE:'") + if $self->{condnum} && $self->{cond} eq ''; + $self->{cond} = $_; + trim_whitespace($self->{cond}); + print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n"); $_ = ''; } sub INPUT_handler { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + my $self = shift; + $_ = shift; + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { last if /^\s*NOT_IMPLEMENTED_YET/; next unless /\S/; # skip blank lines @@ -1141,8 +1076,8 @@ sub INPUT_handler { # 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} = undef; - $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; + $self->{lengthof}->{$2} = undef; + $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; } # check for optional initialisation code @@ -1152,36 +1087,40 @@ sub INPUT_handler { s/\s+/ /g; my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s - or blurt("Error: invalid argument declaration '$ln'"), next; + or $self->blurt("Error: invalid argument declaration '$ln'"), next; # Check for duplicate definitions - blurt ("Error: duplicate definition of argument '$var_name' ignored"), next - if $arg_list{$var_name}++ - or defined $argtype_seen{$var_name} and not $processing_arg_with_types; + $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next + if $self->{arg_list}->{$var_name}++ + or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types}; - $thisdone |= $var_name eq "THIS"; - $retvaldone |= $var_name eq "RETVAL"; - $var_types{$var_name} = $var_type; + $self->{thisdone} |= $var_name eq "THIS"; + $self->{retvaldone} |= $var_name eq "RETVAL"; + $self->{var_types}->{$var_name} = $var_type; # XXXX This check is a safeguard against the unfinished conversion of # generate_init(). When generate_init() is fixed, # one can use 2-args map_type() unconditionally. + my $printed_name; if ($var_type =~ / \( \s* \* \s* \) /x) { - # Function pointers are not yet supported with &output_init! - print "\t" . &map_type($var_type, $var_name, $hiertype); + # Function pointers are not yet supported with output_init()! + print "\t" . map_type($self, $var_type, $var_name); $printed_name = 1; } else { - print "\t" . &map_type($var_type, undef, $hiertype); + print "\t" . map_type($self, $var_type, undef); $printed_name = 0; } - $var_num = $args_match{$var_name}; + $self->{var_num} = $self->{args_match}->{$var_name}; - if ($var_num) { - $proto_arg[$var_num] = $proto_letter{$var_type} || "\$"; + if ($self->{var_num}) { + my $typemap = $self->{typemap}->get_typemap(ctype => $var_type); + $self->death("Could not find a typemap for C type '$var_type'") + if not $typemap; + $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$"; } - $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; + $self->{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} =~ /^OUT/ + or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ and $var_init !~ /\S/) { if ($printed_name) { print ";\n"; @@ -1193,16 +1132,16 @@ sub INPUT_handler { elsif ($var_init =~ /\S/) { output_init( { type => $var_type, - num => $var_num, + num => $self->{var_num}, var => $var_name, init => $var_init, printed_name => $printed_name, } ); } - elsif ($var_num) { + elsif ($self->{var_num}) { generate_init( { type => $var_type, - num => $var_num, + num => $self->{var_num}, var => $var_name, printed_name => $printed_name, } ); @@ -1214,89 +1153,115 @@ sub INPUT_handler { } sub OUTPUT_handler { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + my $self = shift; + $self->{have_OUTPUT} = 1; + + $_ = shift; + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { - $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); + $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0); next; } my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; - blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next - if $outargs{$outarg}++; - if (!$gotRETVAL and $outarg eq 'RETVAL') { + $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next + if $self->{outargs}->{$outarg}++; + if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') { # deal with RETVAL last - $RETVAL_code = $outcode; - $gotRETVAL = 1; + $self->{RETVAL_code} = $outcode; + $self->{gotRETVAL} = 1; next; } - blurt ("Error: OUTPUT $outarg not an argument"), next - unless defined($args_match{$outarg}); - blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next - unless defined $var_types{$outarg}; - $var_num = $args_match{$outarg}; + $self->blurt("Error: OUTPUT $outarg not an argument"), next + unless defined($self->{args_match}->{$outarg}); + $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next + unless defined $self->{var_types}->{$outarg}; + $self->{var_num} = $self->{args_match}->{$outarg}; if ($outcode) { print "\t$outcode\n"; - print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic; + print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; } else { generate_output( { - type => $var_types{$outarg}, - num => $var_num, + type => $self->{var_types}->{$outarg}, + num => $self->{var_num}, var => $outarg, - do_setmagic => $DoSetMagic, + do_setmagic => $self->{DoSetMagic}, do_push => undef, } ); } - delete $in_out{$outarg} # No need to auto-OUTPUT - if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; + delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT + if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/; } } -sub C_ARGS_handler() { - my $in = merge_section(); +sub C_ARGS_handler { + my $self = shift; + $_ = shift; + my $in = $self->merge_section(); trim_whitespace($in); - $func_args = $in; + $self->{func_args} = $in; } -sub INTERFACE_MACRO_handler() { - my $in = merge_section(); +sub INTERFACE_MACRO_handler { + my $self = shift; + $_ = shift; + my $in = $self->merge_section(); trim_whitespace($in); if ($in =~ /\s/) { # two - ($interface_macro, $interface_macro_set) = split ' ', $in; + ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; } else { - $interface_macro = $in; - $interface_macro_set = 'UNKNOWN_CVT'; # catch later + $self->{interface_macro} = $in; + $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later } - $interface = 1; # local - $Interfaces = 1; # global + $self->{interface} = 1; # local + $self->{interfaces} = 1; # global } -sub INTERFACE_handler() { - my $in = merge_section(); +sub INTERFACE_handler { + my $self = shift; + $_ = shift; + my $in = $self->merge_section(); trim_whitespace($in); foreach (split /[\s,]+/, $in) { my $iface_name = $_; - $iface_name =~ s/^$Prefix//; - $Interfaces{$iface_name} = $_; + $iface_name =~ s/^$self->{Prefix}//; + $self->{Interfaces}->{$iface_name} = $_; } print Q(<<"EOF"); -# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr); +# XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr); EOF - $interface = 1; # local - $Interfaces = 1; # global + $self->{interface} = 1; # local + $self->{interfaces} = 1; # global +} + +sub CLEANUP_handler { + my $self = shift; + $self->print_section(); } -sub CLEANUP_handler() { print_section() } -sub PREINIT_handler() { print_section() } -sub POSTCALL_handler() { print_section() } -sub INIT_handler() { print_section() } +sub PREINIT_handler { + my $self = shift; + $self->print_section(); +} -sub GetAliases { +sub POSTCALL_handler { + my $self = shift; + $self->print_section(); +} + +sub INIT_handler { + my $self = shift; + $self->print_section(); +} + +sub get_aliases { + my $self = shift; my ($line) = @_; my ($orig) = $line; @@ -1309,54 +1274,66 @@ sub GetAliases { my $orig_alias = $alias; # check for optional package definition in the alias - $alias = $Packprefix . $alias if $alias !~ /::/; + $alias = $self->{Packprefix} . $alias if $alias !~ /::/; # check for duplicate alias name & duplicate value - Warn("Warning: Ignoring duplicate alias '$orig_alias'") - if defined $XsubAliases{$alias}; + Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") + if defined $self->{XsubAliases}->{$alias}; - Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") - if $XsubAliasValues{$value}; + Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") + if $self->{XsubAliasValues}->{$value}; - $XsubAliases = 1; - $XsubAliases{$alias} = $value; - $XsubAliasValues{$value} = $orig_alias; + $self->{xsubaliases} = 1; + $self->{XsubAliases}->{$alias} = $value; + $self->{XsubAliasValues}->{$value} = $orig_alias; } - blurt("Error: Cannot parse ALIAS definitions from '$orig'") + blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") if $line; } -sub ATTRS_handler () { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { +sub ATTRS_handler { + my $self = shift; + $_ = shift; + + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); - push @Attributes, $_; + push @{ $self->{Attributes} }, $_; } } -sub ALIAS_handler () { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { +sub ALIAS_handler { + my $self = shift; + $_ = shift; + + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); - GetAliases($_) if $_; + $self->get_aliases($_) if $_; } } -sub OVERLOAD_handler() { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { +sub OVERLOAD_handler { + my $self = shift; + $_ = shift; + + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { - $Overload = 1 unless $Overload; + $self->{Overload} = 1 unless $self->{Overload}; my $overload = "$Package\::(".$1; - push(@InitFileCode, - " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n"); + push(@{ $self->{InitFileCode} }, + " (void)$self->{newXS}(\"$overload\", XS_$Full_func_name, file$self->{proto});\n"); } } } -sub FALLBACK_handler() { +sub FALLBACK_handler { + my $self = shift; + $_ = shift; + # the rest of the current line should contain either TRUE, # FALSE or UNDEF @@ -1368,170 +1345,188 @@ sub FALLBACK_handler() { ); # check for valid FALLBACK value - death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_}; + $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_}; - $Fallback = $map{uc $_}; + $self->{Fallback} = $map{uc $_}; } -sub REQUIRE_handler () { +sub REQUIRE_handler { + my $self = shift; # the rest of the current line should contain a version number - my ($Ver) = $_; + my $Ver = shift; trim_whitespace($Ver); - death ("Error: REQUIRE expects a version number") + $self->death("Error: REQUIRE expects a version number") unless $Ver; # check that the version number is of the form n.n - death ("Error: REQUIRE: expected a number, got '$Ver'") + $self->death("Error: REQUIRE: expected a number, got '$Ver'") unless $Ver =~ /^\d+(\.\d*)?/; - death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.") + $self->death("Error: xsubpp $Ver (or better) required--this is only $VERSION.") unless $VERSION >= $Ver; } -sub VERSIONCHECK_handler () { +sub VERSIONCHECK_handler { + my $self = shift; + $_ = shift; + # the rest of the current line should contain either ENABLE or # DISABLE trim_whitespace($_); # check for ENABLE/DISABLE - death ("Error: VERSIONCHECK: ENABLE/DISABLE") + $self->death("Error: VERSIONCHECK: ENABLE/DISABLE") unless /^(ENABLE|DISABLE)/i; - $WantVersionChk = 1 if $1 eq 'ENABLE'; - $WantVersionChk = 0 if $1 eq 'DISABLE'; + $self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; + $self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; } -sub PROTOTYPE_handler () { +sub PROTOTYPE_handler { + my $self = shift; + $_ = shift; + my $specified; - death("Error: Only 1 PROTOTYPE definition allowed per xsub") - if $proto_in_this_xsub++; + $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") + if $self->{proto_in_this_xsub}++; - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; $specified = 1; trim_whitespace($_); if ($_ eq 'DISABLE') { - $ProtoThisXSUB = 0; + $self->{ProtoThisXSUB} = 0; } elsif ($_ eq 'ENABLE') { - $ProtoThisXSUB = 1; + $self->{ProtoThisXSUB} = 1; } else { # remove any whitespace s/\s+//g; - death("Error: Invalid prototype '$_'") + $self->death("Error: Invalid prototype '$_'") unless valid_proto_string($_); - $ProtoThisXSUB = C_string($_); + $self->{ProtoThisXSUB} = C_string($_); } } # If no prototype specified, then assume empty prototype "" - $ProtoThisXSUB = 2 unless $specified; + $self->{ProtoThisXSUB} = 2 unless $specified; - $ProtoUsed = 1; + $self->{ProtoUsed} = 1; } -sub SCOPE_handler () { - death("Error: Only 1 SCOPE declaration allowed per xsub") - if $scope_in_this_xsub++; +sub SCOPE_handler { + my $self = shift; + $_ = shift; + + $self->death("Error: Only 1 SCOPE declaration allowed per xsub") + if $self->{scope_in_this_xsub}++; trim_whitespace($_); - death ("Error: SCOPE: ENABLE/DISABLE") + $self->death("Error: SCOPE: ENABLE/DISABLE") unless /^(ENABLE|DISABLE)\b/i; - $ScopeThisXSUB = ( uc($1) eq 'ENABLE' ); + $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); } -sub PROTOTYPES_handler () { +sub PROTOTYPES_handler { + my $self = shift; + $_ = shift; + # the rest of the current line should contain either ENABLE or # DISABLE trim_whitespace($_); # check for ENABLE/DISABLE - death ("Error: PROTOTYPES: ENABLE/DISABLE") + $self->death("Error: PROTOTYPES: ENABLE/DISABLE") unless /^(ENABLE|DISABLE)/i; - $WantPrototypes = 1 if $1 eq 'ENABLE'; - $WantPrototypes = 0 if $1 eq 'DISABLE'; - $ProtoUsed = 1; + $self->{WantPrototypes} = 1 if $1 eq 'ENABLE'; + $self->{WantPrototypes} = 0 if $1 eq 'DISABLE'; + $self->{ProtoUsed} = 1; } sub PushXSStack { + my $self = shift; my %args = @_; # Save the current file context. - push(@XSStack, { + push(@{ $self->{XSStack} }, { type => 'file', - LastLine => $lastline, - LastLineNo => $lastline_no, - Line => \@line, - LineNo => \@line_no, - Filename => $filename, - Filepathname => $filepathname, - Handle => $FH, - IsPipe => scalar($filename =~ /\|\s*$/), + LastLine => $self->{lastline}, + LastLineNo => $self->{lastline_no}, + Line => $self->{line}, + LineNo => $self->{line_no}, + Filename => $self->{filename}, + Filepathname => $self->{filepathname}, + Handle => $self->{FH}, + IsPipe => scalar($self->{filename} =~ /\|\s*$/), %args, }); } -sub INCLUDE_handler () { +sub INCLUDE_handler { + my $self = shift; + $_ = shift; # the rest of the current line should contain a valid filename trim_whitespace($_); - death("INCLUDE: filename missing") + $self->death("INCLUDE: filename missing") unless $_; - death("INCLUDE: output pipe is illegal") + $self->death("INCLUDE: output pipe is illegal") if /^\s*\|/; # simple minded recursion detector - death("INCLUDE loop detected") - if $IncludedFiles{$_}; + $self->death("INCLUDE loop detected") + if $self->{IncludedFiles}->{$_}; - ++$IncludedFiles{$_} unless /\|\s*$/; + ++$self->{IncludedFiles}->{$_} unless /\|\s*$/; if (/\|\s*$/ && /^\s*perl\s/) { - Warn("The INCLUDE directive with a command is discouraged." . - " Use INCLUDE_COMMAND instead! In particular using 'perl'" . - " in an 'INCLUDE: ... |' directive is not guaranteed to pick" . - " up the correct perl. The INCLUDE_COMMAND directive allows" . - " the use of \$^X as the currently running perl, see" . - " 'perldoc perlxs' for details."); + Warn( $self, "The INCLUDE directive with a command is discouraged." . + " Use INCLUDE_COMMAND instead! In particular using 'perl'" . + " in an 'INCLUDE: ... |' directive is not guaranteed to pick" . + " up the correct perl. The INCLUDE_COMMAND directive allows" . + " the use of \$^X as the currently running perl, see" . + " 'perldoc perlxs' for details."); } - PushXSStack(); + $self->PushXSStack(); - $FH = Symbol::gensym(); + $self->{FH} = Symbol::gensym(); # open the new file - open ($FH, "$_") or death("Cannot open '$_': $!"); + open ($self->{FH}, '<', $_) or $self->death("Cannot open '$_': $!"); print Q(<<"EOF"); # -#/* INCLUDE: Including '$_' from '$filename' */ +#/* INCLUDE: Including '$_' from '$self->{filename}' */ # EOF - $filename = $_; - $filepathname = File::Spec->catfile($dir, $filename); + $self->{filename} = $_; + $self->{filepathname} = ( $^O =~ /^mswin/i ) + ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32? + : File::Spec->catfile($self->{dir}, $self->{filename}); # Prime the pump by reading the first # non-blank line # skip leading blank lines - while (<$FH>) { + while (readline($self->{FH})) { last unless /^\s*$/; } - $lastline = $_; - $lastline_no = $.; + $self->{lastline} = $_; + $self->{lastline_no} = $.; } sub QuoteArgs { @@ -1544,114 +1539,96 @@ sub QuoteArgs { return join (' ', ($cmd, @args)); } -sub INCLUDE_COMMAND_handler () { +sub INCLUDE_COMMAND_handler { + my $self = shift; + $_ = shift; # the rest of the current line should contain a valid command trim_whitespace($_); $_ = QuoteArgs($_) if $^O eq 'VMS'; - death("INCLUDE_COMMAND: command missing") + $self->death("INCLUDE_COMMAND: command missing") unless $_; - death("INCLUDE_COMMAND: pipes are illegal") + $self->death("INCLUDE_COMMAND: pipes are illegal") if /^\s*\|/ or /\|\s*$/; - PushXSStack( IsPipe => 1 ); + $self->PushXSStack( IsPipe => 1 ); - $FH = Symbol::gensym(); + $self->{FH} = Symbol::gensym(); # 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/; # open the new file - open ($FH, "-|", "$_") - or death("Cannot run command '$_' to include its output: $!"); + open ($self->{FH}, "-|", $_) + or $self->death( $self, "Cannot run command '$_' to include its output: $!"); print Q(<<"EOF"); # -#/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */ +#/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */ # EOF - $filename = $_; - $filepathname = $filename; - $filepathname =~ s/\"/\\"/g; + $self->{filename} = $_; + $self->{filepathname} = $self->{filename}; + #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21 + $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938 # Prime the pump by reading the first # non-blank line # skip leading blank lines - while (<$FH>) { + while (readline($self->{FH})) { last unless /^\s*$/; } - $lastline = $_; - $lastline_no = $.; + $self->{lastline} = $_; + $self->{lastline_no} = $.; } -sub PopFile() { - return 0 unless $XSStack[-1]{type} eq 'file'; +sub PopFile { + my $self = shift; + + return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; - my $data = pop @XSStack; - my $ThisFile = $filename; + my $data = pop @{ $self->{XSStack} }; + my $ThisFile = $self->{filename}; my $isPipe = $data->{IsPipe}; - --$IncludedFiles{$filename} + --$self->{IncludedFiles}->{$self->{filename}} unless $isPipe; - close $FH; + close $self->{FH}; - $FH = $data->{Handle}; + $self->{FH} = $data->{Handle}; # $filename is the leafname, which for some reason isused for diagnostic # messages, whereas $filepathname is the full pathname, and is used for # #line directives. - $filename = $data->{Filename}; - $filepathname = $data->{Filepathname}; - $lastline = $data->{LastLine}; - $lastline_no = $data->{LastLineNo}; - @line = @{ $data->{Line} }; - @line_no = @{ $data->{LineNo} }; + $self->{filename} = $data->{Filename}; + $self->{filepathname} = $data->{Filepathname}; + $self->{lastline} = $data->{LastLine}; + $self->{lastline_no} = $data->{LastLineNo}; + @{ $self->{line} } = @{ $data->{Line} }; + @{ $self->{line_no} } = @{ $data->{LineNo} }; if ($isPipe and $? ) { - --$lastline_no; - print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; + --$self->{lastline_no}; + print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; exit 1; } print Q(<<"EOF"); # -#/* INCLUDE: Returning to '$filename' from '$ThisFile' */ +#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ # EOF return 1; } -sub check_cpp { - my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); - if (@cpp) { - my ($cpp, $cpplevel); - for $cpp (@cpp) { - if ($cpp =~ /^\#\s*if/) { - $cpplevel++; - } - elsif (!$cpplevel) { - Warn("Warning: #else/elif/endif without #if in this function"); - print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" - if $XSStack[-1]{type} eq 'if'; - return; - } - elsif ($cpp =~ /^\#\s*endif/) { - $cpplevel--; - } - } - Warn("Warning: #if without #endif in this function") if $cpplevel; - } -} - - sub Q { my($text) = @_; $text =~ s/^#//gm; @@ -1660,63 +1637,92 @@ sub Q { $text; } -# Read next xsub into @line from ($lastline, <$FH>). +# Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). sub fetch_para { + my $self = shift; + # parse paragraph - death ("Error: Unterminated `#if/#ifdef/#ifndef'") - if !defined $lastline && $XSStack[-1]{type} eq 'if'; - @line = (); - @line_no = (); - return PopFile() if !defined $lastline; + $self->death("Error: Unterminated `#if/#ifdef/#ifndef'") + if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; + @{ $self->{line} } = (); + @{ $self->{line_no} } = (); + return $self->PopFile() if !defined $self->{lastline}; - if ($lastline =~ + if ($self->{lastline} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { my $Module = $1; $Package = defined($2) ? $2 : ''; # keep -w happy - $Prefix = defined($3) ? $3 : ''; # keep -w happy - $Prefix = quotemeta $Prefix; - ($Module_cname = $Module) =~ s/\W/_/g; - ($Packid = $Package) =~ tr/:/_/; - $Packprefix = $Package; - $Packprefix .= "::" if $Packprefix ne ""; - $lastline = ""; + $self->{Prefix} = defined($3) ? $3 : ''; # keep -w happy + $self->{Prefix} = quotemeta $self->{Prefix}; + ($self->{Module_cname} = $Module) =~ s/\W/_/g; + ($self->{Packid} = $Package) =~ tr/:/_/; + $self->{Packprefix} = $Package; + $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; + $self->{lastline} = ""; } for (;;) { # Skip embedded PODs - while ($lastline =~ /^=/) { - while ($lastline = <$FH>) { - last if ($lastline =~ /^=cut\s*$/); + while ($self->{lastline} =~ /^=/) { + while ($self->{lastline} = readline($self->{FH})) { + last if ($self->{lastline} =~ /^=cut\s*$/); } - death ("Error: Unterminated pod") unless $lastline; - $lastline = <$FH>; - chomp $lastline; - $lastline =~ s/^\s+$//; + $self->death("Error: Unterminated pod") unless $self->{lastline}; + $self->{lastline} = readline($self->{FH}); + chomp $self->{lastline}; + $self->{lastline} =~ s/^\s+$//; } - if ($lastline !~ /^\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()+1, + fake_filename => $self->{filename}, + ); + $self->{typemap}->merge(typemap => $tmap, replace => 1); + + last unless defined($self->{lastline} = readline($self->{FH})); + next; + } + + 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) - $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { - last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; - push(@line, $lastline); - push(@line_no, $lastline_no); + $self->{lastline} =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { + last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; + push(@{ $self->{line} }, $self->{lastline}); + push(@{ $self->{line_no} }, $self->{lastline_no}); } # Read next line and continuation lines - last unless defined($lastline = <$FH>); - $lastline_no = $.; + last unless defined($self->{lastline} = readline($self->{FH})); + $self->{lastline_no} = $.; my $tmp_line; - $lastline .= $tmp_line - while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); + $self->{lastline} .= $tmp_line + while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH}))); - chomp $lastline; - $lastline =~ s/^\s+$//; + chomp $self->{lastline}; + $self->{lastline} =~ s/^\s+$//; } - pop(@line), pop(@line_no) while @line && $line[-1] eq ""; + pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) while @{ $self->{line} } && $self->{line}->[-1] eq ""; 1; } @@ -1758,7 +1764,7 @@ sub output_init { warn $@ if $@; $init =~ s/^;//; } - $deferred .= eval qq/"\\n\\t$init\\n"/; + $self->{deferred} .= eval qq/"\\n\\t$init\\n"/; warn $@ if $@; } } @@ -1772,35 +1778,44 @@ sub generate_init { $argsref->{printed_name}, ); my $arg = "ST(" . ($num - 1) . ")"; - my ($argoff, $ntype, $tk); + my ($argoff, $ntype); $argoff = $num - 1; + my $typemaps = $self->{typemap}; + $type = tidy_type($type); - blurt("Error: '$type' not in typemap"), return - unless defined($type_kind{$type}); + $self->blurt("Error: '$type' not in typemap"), return + unless $typemaps->get_typemap(ctype => $type); ($ntype = $type) =~ s/\s*\*/Ptr/g; my $subtype; ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; - $tk = $type_kind{$type}; - $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; - if ($tk eq 'T_PV' and exists $lengthof{$var}) { + my $typem = $typemaps->get_typemap(ctype => $type); + my $xstype = $typem->xstype; + $xstype =~ s/OBJ$/REF/ if $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"; die "default value not supported with length(NAME) supplied" - if defined $defaults{$var}; + if defined $self->{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}; - my $expr = $input_expr{$tk}; + $type =~ tr/:/_/ unless $self->{hiertype}; + + my $inputmap = $typemaps->get_inputmap(xstype => $xstype); + $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"), return + unless defined $inputmap; + + 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/) { - 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}}; - my $subexpr = $input_expr{$type_kind{$subtype}}; + my $subtypemap = $typemaps->get_typemap(ctype => $subtype); + $self->blurt("Error: C type '$subtype' not in typemap"), return + if not $subtypemap; + my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); + $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return + unless $subinputmap; + my $subexpr = $subinputmap->cleaned_code; $subexpr =~ s/\$type/\$subtype/g; $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; @@ -1810,9 +1825,9 @@ sub generate_init { $expr =~ s/DO_ARRAY_ELEM/$subexpr/; } if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments - $ScopeThisXSUB = 1; + $self->{ScopeThisXSUB} = 1; } - if (defined($defaults{$var})) { + if (defined($self->{defaults}->{$var})) { $expr =~ s/(\t+)/$1 /g; $expr =~ s/ /\t/g; if ($printed_name) { @@ -1822,15 +1837,15 @@ sub generate_init { eval qq/print "\\t$var;\\n"/; warn $@ if $@; } - if ($defaults{$var} eq 'NO_INIT') { - $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/; + if ($self->{defaults}->{$var} eq 'NO_INIT') { + $self->{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"/; + $self->{deferred} .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; } warn $@ if $@; } - elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { + elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { if ($printed_name) { print ";\n"; } @@ -1838,7 +1853,7 @@ sub generate_init { eval qq/print "\\t$var;\\n"/; warn $@ if $@; } - $deferred .= eval qq/"\\n$expr;\\n"/; + $self->{deferred} .= eval qq/"\\n$expr;\\n"/; warn $@ if $@; } else { @@ -1861,6 +1876,8 @@ sub generate_output { my $arg = "ST(" . ($num - ($num != 0)) . ")"; my $ntype; + my $typemaps = $self->{typemap}; + $type = tidy_type($type); if ($type =~ /^array\(([^,]*),(.*)\)/) { print "\t$arg = sv_newmortal();\n"; @@ -1868,21 +1885,26 @@ sub generate_output { 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', typekind '$type_kind{$type}' found"), return - unless defined $output_expr{$type_kind{$type}}; + my $typemap = $typemaps->get_typemap(ctype => $type); + $self->blurt("Could not find a typemap for C type '$type'"), return + if not $typemap; + my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); + $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"), return + unless $outputmap; ($ntype = $type) =~ s/\s*\*/Ptr/g; $ntype =~ s/\(\)//g; my $subtype; ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; - my $expr = $output_expr{$type_kind{$type}}; + + my $expr = $outputmap->cleaned_code; 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', typekind '$type_kind{$subtype}' found"), return - unless defined $output_expr{$type_kind{$subtype}}; - my $subexpr = $output_expr{$type_kind{$subtype}}; + my $subtypemap = $typemaps->get_typemap(ctype => $subtype); + $self->blurt("Could not find a typemap for C type '$subtype'"), return + if not $subtypemap; + my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); + $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"), return + unless $suboutputmap; + my $subexpr = $suboutputmap->cleaned_code; $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\$var/${var}[ix_$var]/g; @@ -1935,21 +1957,6 @@ sub generate_output { } } -sub Warn { - # work out the line number - my $warn_line_number = $line_no[@line_no - @line -1]; - - print STDERR "@_ in $filename, line $warn_line_number\n"; -} - -sub blurt { - Warn @_; - $errors++ -} - -sub death { - Warn @_; - exit 1; -} - 1; + +# vim: ts=2 sw=2 et: