diff options
author | Steffen Mueller <smueller@cpan.org> | 2011-07-12 22:02:24 +0200 |
---|---|---|
committer | Steffen Mueller <smueller@cpan.org> | 2011-07-12 22:02:26 +0200 |
commit | bb17296d8de7c33dc13da5d17077dd5140a794b1 (patch) | |
tree | 97c258357dd2052c3c6f2aff9bde09339cb42130 | |
parent | 17616481cf4701b926ec5adcc5914f839cfa0c2e (diff) | |
parent | 96893281c6f796153cd1c238c56581fa7c8c802a (diff) | |
download | perl-bb17296d8de7c33dc13da5d17077dd5140a794b1.tar.gz |
Merge branch 'smueller/eu_typemap' into blead
Much of ExtUtils::ParseXS was rewritten and cleaned up.
It has been made somewhat more extensible and now finally
uses strictures.
The logic for parsing, merging, and dumping XS typemaps was extracted
from ExtUtils::ParseXS into a module of its own, ExtUtils::Typemaps.
ExtUtils::Typemaps offers an interface to typemap handling outside of
the scope of the XS compiler itself.
As a first use case of the improved API an extensibility, typemaps can now
be included inline into XS code with a HEREDOC-like syntax:
TYPEMAP: <<END_TYPEMAP
MyType T_IV
END_TYPEMAP
52 files changed, 5924 insertions, 1573 deletions
@@ -2971,20 +2971,59 @@ dist/ExtUtils-Install/t/Packlist.t See if Packlist works dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files dist/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP The default MANIFEST.SKIP dist/ExtUtils-Manifest/t/Manifest.t See if ExtUtils::Manifest works -dist/ExtUtils-ParseXS/Changes ExtUtils::ParseXS change log -dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm converts Perl XS code into C code -dist/ExtUtils-ParseXS/lib/ExtUtils/xsubpp External subroutine preprocessor -dist/ExtUtils-ParseXS/t/basic.t See if ExtUtils::ParseXS works -dist/ExtUtils-ParseXS/t/lib/IncludeTester.pm ExtUtils::ParseXS testing utility -dist/ExtUtils-ParseXS/t/more.t Extended ExtUtils::ParseXS testing -dist/ExtUtils-ParseXS/t/typemap Standard typemap for controlled testing -dist/ExtUtils-ParseXS/t/usage.t ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/XSInclude.xsh Test file for ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/XSMore.xs Test file for ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/XSTest.pm Test file for ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/XSTest.xs Test file for ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/XSUsage.pm ExtUtils::ParseXS tests -dist/ExtUtils-ParseXS/t/XSUsage.xs ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/Changes ExtUtils::ParseXS change log +dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm ExtUtils::ParseXS guts +dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm ExtUtils::ParseXS guts +dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm converts Perl XS code into C code +dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod ExtUtils::ParseXS documentation +dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm ExtUtils::ParseXS guts +dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm ExtUtils::Typemaps guts +dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm ExtUtils::Typemaps guts +dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm ExtUtils::Typemaps, a PXS helper +dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm ExtUtils::Typemaps guts +dist/ExtUtils-ParseXS/lib/ExtUtils/xsubpp External subroutine preprocessor +dist/ExtUtils-ParseXS/t/001-basic.t See if ExtUtils::ParseXS works +dist/ExtUtils-ParseXS/t/002-more.t Extended ExtUtils::ParseXS testing +dist/ExtUtils-ParseXS/t/003-usage.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/004-nolinenumbers.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/102-trim_whitespace.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/103-tidy_type.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/104-map_type.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/105-valid_proto_string.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/106-process_typemaps.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/107-make_targetable.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/108-map_type.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/110-assign_func_args.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/112-set_cond.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/501-t-compile.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/510-t-bare.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/511-t-whitespace.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/512-t-file.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/513-t-merge.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/600-t-compat.t ExtUtils::Typemaps tests +dist/ExtUtils-ParseXS/t/data/b.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/data/combined.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/data/conflicting.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/data/confl_repl.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/data/confl_skip.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/data/other.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/data/perl.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/data/simple.typemap ExtUtils::Typemaps test data +dist/ExtUtils-ParseXS/t/lib/IncludeTester.pm ExtUtils::ParseXS testing utility +dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm Primitive STDOUT/ERR capturing for tests +dist/ExtUtils-ParseXS/t/pseudotypemap1 A test-typemap +dist/ExtUtils-ParseXS/t/typemap Standard typemap for controlled testing +dist/ExtUtils-ParseXS/t/XSInclude.xsh Test file for ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/XSMore.xs Test file for ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/XSTest.pm Test file for ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/XSTest.xs Test file for ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/XSUsage.pm ExtUtils::ParseXS tests +dist/ExtUtils-ParseXS/t/XSUsage.xs ExtUtils::ParseXS tests dist/File-CheckTree/lib/File/CheckTree.pm Perl module supporting wholesale file mode validation dist/File-CheckTree/t/CheckTree.t See if File::CheckTree works dist/Filter-Simple/lib/Filter/Simple.pm Simple frontend to Filter::Util::Call diff --git a/Porting/checkAUTHORS.pl b/Porting/checkAUTHORS.pl index 9c6c71245a..44f82b567a 100755 --- a/Porting/checkAUTHORS.pl +++ b/Porting/checkAUTHORS.pl @@ -866,3 +866,5 @@ wolfgang.laun\100alcatel.at wolfgang.laun\100chello.at + wolfgang.laun\100thalesgroup.com + wolfgang.laun\100gmail.com yath\100yath.de yath-perlbug\100yath.de + +jkeen@verizon.net jkeenan@cpan.org diff --git a/dist/ExtUtils-ParseXS/Changes b/dist/ExtUtils-ParseXS/Changes index 8ebc900d4b..696705cd80 100644 --- a/dist/ExtUtils-ParseXS/Changes +++ b/dist/ExtUtils-ParseXS/Changes @@ -1,5 +1,28 @@ Revision history for Perl extension ExtUtils::ParseXS. +3.00_01 - Tue Jul 12 22:00:00 EDT 2011 + + - Major refactoring of the whole code base. + It finally runs under 'use strict' for the first time! + [James Keenan, Steffen Mueller] + + - Typemaps can now be embedded into XS code using a here-doc + like syntax and the new "TYPEMAP:" XS keyword. + [Steffen Mueller] + + - Move typemap handling code to ExtUtils::Typemaps + with full object-oriented goodness. [Steffen Mueller] + + - Check API compatibility when loading xs modules. + If on a new-enough perl, add the XS_APIVERSION_BOOTCHECK macro to + the _boot function of every XS module to compare it against the API + version the module has been compiled against. If the versions do + not match, an exception is thrown. [Florian Ragwitz] + + - Fixed compiler warnings in XS. [Zefram] + + - Spell-check [Peter J. Acklam] + 2.2206 - Sun Jul 4 15:43:21 EDT 2010 Bug fixes: diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index 79b3968849..3458ed429c 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -1,109 +1,109 @@ package ExtUtils::ParseXS; +use strict; use 5.006; # We use /??{}/ in regexes use Cwd; use Config; +use Exporter; use File::Basename; use File::Spec; use Symbol; - -require Exporter; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(process_file); - -# use strict; # One of these days... - -my(@XSStack); # Stack of conditionals and INCLUDEs -my($XSS_work_idx, $cpp_next_tmp); - -use vars qw($VERSION); -$VERSION = '2.2210'; +use ExtUtils::ParseXS::Constants (); +use ExtUtils::ParseXS::CountLines; +use ExtUtils::ParseXS::Utilities qw( + standard_typemap_locations + trim_whitespace + tidy_type + C_string + valid_proto_string + 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); +our @EXPORT_OK = qw( + process_file + report_error_count +); +our $VERSION = '3.00_01'; $VERSION = eval $VERSION if $VERSION =~ /_/; -use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback - $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers - $WantOptimize $process_inout $process_argtypes @tm - $dir $filename $filepathname %IncludedFiles - %type_kind %proto_letter - %targetable $BLOCK_re $lastline $lastline_no - $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg - $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof - $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set - $ProtoThisXSUB $ScopeThisXSUB $xsreturn - @line_no $ret_type $func_header $orig_args - ); # Add these just to get compilation to happen. +# 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 ( + $Package, $func_name, $Full_func_name, $pname, $ALIAS, +); +our $self = bless {} => __PACKAGE__; sub process_file { - + # Allow for $package->process_file(%hash) in the future - my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_); - - $ProtoUsed = exists $args{prototypes}; - + my ($pkg, %options) = @_ % 2 ? @_ : (__PACKAGE__, @_); + + $self->{ProtoUsed} = exists $options{prototypes}; + # Set defaults. - %args = ( - # 'C++' => 0, # Doesn't seem to *do* anything... - hiertype => 0, - except => 0, - prototypes => 0, - versioncheck => 1, - linenumbers => 1, - optimize => 1, - prototypes => 0, - inout => 1, - argtypes => 1, - typemap => [], - output => \*STDOUT, - csuffix => '.c', - %args, - ); + my %args = ( + argtypes => 1, + csuffix => '.c', + except => 0, + hiertype => 0, + inout => 1, + linenumbers => 1, + optimize => 1, + output => \*STDOUT, + prototypes => 0, + typemap => [], + versioncheck => 1, + FH => Symbol::gensym(), + %options, + ); + $args{except} = $args{except} ? ' TRY' : ''; # Global Constants - + my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { $Is_VMS = 1; # 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'}); - ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); - @InitFileCode = (); - $FH = Symbol::gensym(); - $proto_re = "[" . quotemeta('\$%&*@;[]_') . "]" ; - $Overload = 0; - $errors = 0; - $Fallback = '&PL_sv_undef'; + @{ $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 - - $cplusplus = $args{'C++'}; - $hiertype = $args{hiertype}; - $WantPrototypes = $args{prototypes}; - $WantVersionChk = $args{versioncheck}; - $except = $args{except} ? ' TRY' : ''; - $WantLineNumbers = $args{linenumbers}; - $WantOptimize = $args{optimize}; - $process_inout = $args{inout}; - $process_argtypes = $args{argtypes}; - @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap}); - - for ($args{filename}) { - die "Missing required parameter 'filename'" unless $_; - $filepathname = $_; - ($dir, $filename) = (dirname($_), basename($_)); - $filepathname =~ s/\\/\\\\/g; - $IncludedFiles{$_}++; - } - - # Open the input file - open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n"; + + $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. @@ -114,194 +114,121 @@ 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}; - } else { + } + else { $cfile = $args{filename}; $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; } tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output}); select PSEUDO_STDOUT; - } else { - select $args{output}; - } - - foreach my $typemap (@tm) { - die "Can't find $typemap in $pwd\n" unless -r $typemap; - } - - push @tm, standard_typemap_locations(); - - foreach my $typemap (@tm) { - next unless -f $typemap ; - # skip directories, binary files etc. - warn("Warning: ignoring non-text typemap file '$typemap'\n"), next - unless -T $typemap ; - open(TYPEMAP, $typemap) - or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; - my $mode = 'Typemap'; - my $junk = "" ; - my $current = \$junk; - while (<TYPEMAP>) { - next if /^\s* #/; - my $line_no = $. + 1; - if (/^INPUT\s*$/) { - $mode = 'Input'; $current = \$junk; next; - } - if (/^OUTPUT\s*$/) { - $mode = 'Output'; $current = \$junk; next; - } - if (/^TYPEMAP\s*$/) { - $mode = 'Typemap'; $current = \$junk; next; - } - if ($mode eq 'Typemap') { - chomp; - my $line = $_ ; - TrimWhitespace($_) ; - # skip blank lines and comment lines - next if /^$/ or /^#/ ; - my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or - warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; - $type = TidyType($type) ; - $type_kind{$type} = $kind ; - # prototype defaults to '$' - $proto = "\$" unless $proto ; - warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") - unless ValidProtoString($proto) ; - $proto_letter{$type} = C_string($proto) ; - } elsif (/^\s/) { - $$current .= $_; - } elsif ($mode eq 'Input') { - s/\s+$//; - $input_expr{$_} = ''; - $current = \$input_expr{$_}; - } else { - s/\s+$//; - $output_expr{$_} = ''; - $current = \$output_expr{$_}; - } - } - close(TYPEMAP); } - - 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; + else { + select $args{output}; } - my ($cast, $size); - our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced - $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast - $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) - - foreach my $key (keys %output_expr) { - # We can still bootstrap compile 're', because in code re.pm is - # available to miniperl, and does not attempt to load the XS code. - use re 'eval'; - - my ($t, $with_size, $arg, $sarg) = - ($output_expr{$key} =~ - m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn - \s* \( \s* $cast \$arg \s* , - \s* ( (??{ $bal }) ) # Set from - ( (??{ $size }) )? # Possible sizeof set-from - \) \s* ; \s* $ - ]x); - $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; - } + $self->{typemap} = process_typemaps( $args{typemap}, $pwd ); - my $END = "!End!\n\n"; # "impossible" keyword (multiple newline) + my $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Match an XS keyword - $BLOCK_re= '\s*(' . join('|', qw( - REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE - OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE - VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE - INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK - )) . "|$END)\\s*:"; - - + $self->{BLOCK_re} = '\s*(' . + join('|' => @ExtUtils::ParseXS::Constants::XSKeywords) . + "|$END)\\s*:"; + our ($C_group_rex, $C_arg); # Group in C (no support for comments or literals) $C_group_rex = qr/ [({\[] - (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* - [)}\]] /x ; + (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* + [)}\]] /x; # Chunk in C without comma at toplevel (no comments): $C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) - | (??{ $C_group_rex }) - | " (?: (?> [^\\"]+ ) - | \\. - )* " # String literal - | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal - )* /xs; - + | (??{ $C_group_rex }) + | " (?: (?> [^\\"]+ ) + | \\. + )* " # String literal + | ' (?: (?> [^\\']+ ) | \\. )* ' # 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 <<EOM ; + print <<EOM; /* * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the - * contents of $filename. Do not edit this file, edit $filename instead. + * contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead. * - * ANY CHANGES MADE HERE WILL BE LOST! + * ANY CHANGES MADE HERE WILL BE LOST! * */ EOM - print("#line 1 \"$filepathname\"\n") - if $WantLineNumbers; + print("#line 1 \"$self->{filepathname}\"\n") + if $self->{WantLineNumbers}; + + # 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 { - if (/^=cut\s*$/) { - # We can't just write out a /* */ comment, as our embedded - # POD might itself be in a comment. We can't put a /**/ - # comment inside #if 0, as the C standard says that the source - # file is decomposed into preprocessing characters in the stage - # before preprocessing commands are executed. - # I don't want to leave the text as barewords, because the spec - # isn't clear whether macros are expanded before or after - # preprocessing commands are executed, and someone pathological - # may just have defined one of the 3 words as a macro that does - # something strange. Multiline strings are illegal in C, so - # the "" we write must be a string literal. And they aren't - # 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; - next firstmodule - } - - } while (<$FH>); + if (/^=cut\s*$/) { + # We can't just write out a /* */ comment, as our embedded + # POD might itself be in a comment. We can't put a /**/ + # comment inside #if 0, as the C standard says that the source + # file is decomposed into preprocessing characters in the stage + # before preprocessing commands are executed. + # I don't want to leave the text as barewords, because the spec + # isn't clear whether macros are expanded before or after + # preprocessing commands are executed, and someone pathological + # may just have defined one of the 3 words as a macro that does + # something strange. Multiline strings are illegal in C, so + # the "" we write must be a string literal. And they aren't + # concatenated until 2 steps later, so we are safe. + # - Nicholas Clark + print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); + printf("#line %d \"$self->{filepathname}\"\n", $. + 1) + if $self->{WantLineNumbers}; + next firstmodule + } + + } 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 $_; } unless (defined $_) { @@ -309,313 +236,258 @@ EOM exit 0; # Not a fatal error for the caller process } - print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; - - print <<"EOF"; -#ifndef PERL_UNUSED_VAR -# define PERL_UNUSED_VAR(var) if (0) var = var -#endif - -EOF - - 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 + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; -/* 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 + standard_XS_defs(); - print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; - $lastline = $_; - $lastline_no = $.; + $self->{lastline} = $_; + $self->{lastline_no} = $.; + 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 $line = shift(@line); - print $line, "\n"; - next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; + 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; - - if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { + + next PARAGRAPH unless @{ $self->{line} }; + + 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")) { - &{"${kwd}_handler"}() ; - next PARAGRAPH unless @line ; - $_ = shift(@line); + foreach my $member (qw(args_match var_types defaults arg_list + argtype_seen in_out lengthof)) + { + $self->{$member} = {}; } - - 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, "") ; - next PARAGRAPH ; + $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 ($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) = TidyType($_); - $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 $process_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; - ($class, $func_name, $orig_args) = ($1, $2, $3) ; + my ($class, $orig_args); + ($class, $func_name, $orig_args) = ($1, $2, $3); $class = "$4 $class" if $4; - ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; - ($clean_func_name = $func_name) =~ s/^$Prefix//; - $Full_func_name = "${Packid}_$clean_func_name"; + ($pname = $func_name) =~ s/^($self->{Prefix})?/$self->{Packprefix}/; + my $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; - - $orig_args =~ s/\\\s*/ /g; # process line continuations + $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 ($process_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); - for ( @args ) { - s/^\s+//; - s/\s+$//; - my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; - my ($pre, $name) = ($arg =~ /(.*?) \s* - \b ( \w+ | length\( \s*\w+\s* \) ) - \s* $ /x); - next unless defined($pre) && length($pre); - my $out_type = ''; - my $inout_var; - if ($process_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*//; - $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; - } - my $islength; - if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { - $name = "XSauto_length_of_$1"; - $islength = 1; - die "Default value on length() argument: `$_'" - if length $default; - } - if (length $pre or $islength) { # Has a type - if ($islength) { - push @fake_INPUT_pre, $arg; - } else { - push @fake_INPUT, $arg; - } - # warn "pushing '$arg'\n"; - $argtype_seen{$name}++; - $_ = "$name$default"; # Assigns to @args - } - $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; - push @outlist, $name if $out_type =~ /OUTLIST$/; - $in_out{$name} = $out_type if $out_type; - } - } else { - @args = split(/\s*,\s*/, $orig_args); - Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); + @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); + for ( @args ) { + s/^\s+//; + s/\s+$//; + my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x); + my ($pre, $len_name) = ($arg =~ /(.*?) \s* + \b ( \w+ | length\( \s*\w+\s* \) ) + \s* $ /x); + next unless defined($pre) && length($pre); + my $out_type = ''; + my $inout_var; + 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*//; + $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; + } + my $islength; + if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) { + $len_name = "XSauto_length_of_$1"; + $islength = 1; + die "Default value on length() argument: `$_'" + if length $default; + } + if (length $pre or $islength) { # Has a type + if ($islength) { + push @fake_INPUT_pre, $arg; + } + else { + push @fake_INPUT, $arg; + } + # warn "pushing '$arg'\n"; + $self->{argtype_seen}->{$len_name}++; + $_ = "$len_name$default"; # Assigns to @args + } + $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( $self, "Warning: cannot parse argument list '$orig_args', fallback to split"); } - } else { + } + else { @args = split(/\s*,\s*/, $orig_args); for (@args) { - if ($process_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"; - push @outlist, $name if $out_type =~ /OUTLIST$/; - $in_out{$_} = $out_type; - } + 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_ref->{$_} = 1 if $out_type eq "OUTLIST"; + if ($out_type =~ /OUTLIST$/) { + push @{ $outlist_ref }, undef; + } + $self->{in_out}->{$_} = $out_type; + } } } if (defined($class)) { my $arg0 = ((defined($static) or $func_name eq 'new') - ? "CLASS" : "THIS"); + ? "CLASS" : "THIS"); unshift(@args, $arg0); } my $extra_args = 0; - @args_num = (); - $num_args = 0; + my @args_num = (); + my $num_args = 0; my $report_args = ''; + my $ellipsis; foreach my $i (0 .. $#args) { if ($args[$i] =~ s/\.\.\.//) { - $ellipsis = 1; - if ($args[$i] eq '' && $i == $#args) { - $report_args .= ", ..."; - pop(@args); - last; - } + $ellipsis = 1; + if ($args[$i] eq '' && $i == $#args) { + $report_args .= ", ..."; + pop(@args); + last; + } } - if ($only_C_inlist{$args[$i]}) { - push @args_num, undef; - } else { - push @args_num, ++$num_args; - $report_args .= ", $args[$i]"; + if ($only_C_inlist_ref->{$args[$i]}) { + push @args_num, undef; + } + else { + push @args_num, ++$num_args; + $report_args .= ", $args[$i]"; } if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { - $extra_args++; - $args[$i] = $1; - $defaults{$args[$i]} = $2; - $defaults{$args[$i]} =~ s/"/\\"/g; + $extra_args++; + $args[$i] = $1; + $self->{defaults}->{$args[$i]} = $2; + $self->{defaults}->{$args[$i]} =~ s/"/\\"/g; } - $proto_arg[$i+1] = '$' ; + $self->{proto_arg}->[$i+1] = '$'; } - $min_args = $num_args - $extra_args; + 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; - $PPCODE = grep(/^\s*PPCODE\s*:/, @line); - $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. - $EXPLICIT_RETURN = ($CODE && - ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); - $ALIAS = grep(/^\s*ALIAS\s*:/, @line); - $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); + # to set explicit return values. + my $EXPLICIT_RETURN = ($CODE && + ("@{ $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 + # $ALIAS' like the other nearby variables. However, implementing that + # change produced a slight difference in the resulting .c output in at + # least two distributions: B/BD/BDFOY/Crypt-Rijndael and + # G/GF/GFUJI/Hash-FieldHash. The difference is, arguably, an improvement + # in the resulting C code. Example: + # 388c388 + # < GvNAME(CvGV(cv)), + # --- + # > "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*:/, @{ $self->{line} }); + + my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} }); $xsreturn = 1 if $EXPLICIT_RETURN; @@ -633,31 +505,27 @@ EOF # dXSARGS; ##endif EOF - print Q(<<"EOF") if $ALIAS ; + print Q(<<"EOF") if $ALIAS; # dXSI32; EOF - print Q(<<"EOF") if $INTERFACE ; -# dXSFUNCTION($ret_type); + print Q(<<"EOF") if $INTERFACE; +# 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 $except; + $self->{cond} = set_cond($ellipsis, $min_args, $num_args); + + print Q(<<"EOF") if $self->{except}; # char errbuf[1024]; # *errbuf = '\0'; EOF - if($cond) { - print Q(<<"EOF"); -# if ($cond) + if($self->{cond}) { + print Q(<<"EOF"); +# if ($self->{cond}) # croak_xs_usage(cv, "$report_args"); EOF - } else { + } + else { # cv likely to be unused print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ @@ -679,199 +547,246 @@ EOF # Now do a block of some sort. - $condnum = 0; - $cond = ''; # last CASE: conditional - 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"); -# $except [[ +# $self->{except} [[ EOF # do initialization of input variables - $thisdone = 0; - $retvaldone = 0; - $deferred = ""; - %arg_list = () ; - $gotRETVAL = 0; - - INPUT_handler() ; - process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ; - - print Q(<<"EOF") if $ScopeThisXSUB; + $self->{thisdone} = 0; + $self->{retvaldone} = 0; + $self->{deferred} = ""; + %{ $self->{arg_list} } = (); + $self->{gotRETVAL} = 0; + + $self->INPUT_handler($_); + $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); + + print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ENTER; # [[ EOF - - if (!$thisdone && defined($class)) { - if (defined($static) or $func_name eq 'new') { - print "\tchar *"; - $var_types{"CLASS"} = "char *"; - &generate_init("char *", 1, "CLASS"); - } - else { - print "\t$class *"; - $var_types{"THIS"} = "$class *"; - &generate_init("$class *", 1, "THIS"); - } + + if (!$self->{thisdone} && defined($class)) { + if (defined($static) or $func_name eq 'new') { + print "\tchar *"; + $self->{var_types}->{"CLASS"} = "char *"; + generate_init( { + type => "char *", + num => 1, + var => "CLASS", + printed_name => undef, + } ); + } + else { + print "\t$class *"; + $self->{var_types}->{"THIS"} = "$class *"; + generate_init( { + type => "$class *", + num => 1, + var => "THIS", + printed_name => undef, + } ); + } } - + + 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') . ";\n" - if !$retvaldone; - $args_match{"RETVAL"} = 0; - $var_types{"RETVAL"} = $ret_type; - print "\tdXSTARG;\n" - if $WantOptimize and $targetable{$type_kind{$ret_type}}; - } - - if (@fake_INPUT or @fake_INPUT_pre) { - unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; - $_ = ""; - $processing_arg_with_types = 1; - INPUT_handler() ; - } - print $deferred; - - process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ; - - if (check_keyword("PPCODE")) { - print_section(); - death ("PPCODE must be last thing") if @line; - print "\tLEAVE;\n" if $ScopeThisXSUB; - print "\tPUTBACK;\n\treturn;\n"; - } elsif (check_keyword("CODE")) { - print_section() ; - } elsif (defined($class) and $func_name eq "DESTROY") { - print "\n\t"; - print "delete THIS;\n"; - } else { - print "\n\t"; - if ($ret_type ne "void") { - print "RETVAL = "; - $wantRETVAL = 1; - } - if (defined($static)) { - if ($func_name eq 'new') { - $func_name = "$class"; - } else { - print "${class}::"; - } - } elsif (defined($class)) { - if ($func_name eq 'new') { - $func_name .= " $class"; - } else { - print "THIS->"; - } - } - $func_name =~ s/^\Q$args{'s'}// - if exists $args{'s'}; - $func_name = 'XSFUNCTION' if $interface; - print "$func_name($func_args);\n"; - } + print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; + $_ = ''; } - + else { + 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 $self->{optimize} and $outputmap and $outputmap->targetable; + } + + if (@fake_INPUT or @fake_INPUT_pre) { + unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; + $_ = ""; + $self->{processing_arg_with_types} = 1; + $self->INPUT_handler($_); + } + print $self->{deferred}; + + $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); + + 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 ($self->check_keyword("CODE")) { + $self->print_section(); + } + elsif (defined($class) and $func_name eq "DESTROY") { + print "\n\t"; + print "delete THIS;\n"; + } + else { + print "\n\t"; + if ($self->{ret_type} ne "void") { + print "RETVAL = "; + $wantRETVAL = 1; + } + if (defined($static)) { + if ($func_name eq 'new') { + $func_name = "$class"; + } + else { + print "${class}::"; + } + } + elsif (defined($class)) { + if ($func_name eq 'new') { + $func_name .= " $class"; + } + else { + print "THIS->"; + } + } + $func_name =~ s/^\Q$args{'s'}// + if exists $args{'s'}; + $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"); - - &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) - for grep $in_out{$_} =~ /OUT$/, keys %in_out; - + ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; + undef %{ $self->{outargs} }; + $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); + + generate_output( { + type => $self->{var_types}->{$_}, + num => $self->{args_match}->{$_}, + var => $_, + do_setmagic => $self->{DoSetMagic}, + do_push => undef, + } ) 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"; - } elsif ($gotRETVAL || $wantRETVAL) { - my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; - 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. Treat setpv directly - my $what = eval qq("$t->[2]"); - warn $@ if $@; - - print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; - $prepush_done = 1; - } - elsif ($t) { - my $what = eval qq("$t->[2]"); - warn $@ if $@; - - my $size = $t->[3]; - $size = '' unless defined $size; - $size = eval qq("$size"); - warn $@ if $@; - print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; - $prepush_done = 1; - } - else { - # RETVAL almost never needs SvSETMAGIC() - &generate_output($ret_type, 0, 'RETVAL', 0); - } + if ($self->{gotRETVAL} && $self->{RETVAL_code}) { + print "\t$self->{RETVAL_code}\n"; } - - $xsreturn = 1 if $ret_type ne "void"; + 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 + # below. + # It appears that this is related to the fact that at this point the + # value of $t is a reference to an array whose [2] element includes + # '$var' as a substring: + # <i> <> <(IV)$var> + my $var = 'RETVAL'; + 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->{what}"); + warn $@ if $@; + + my $tsize = $t->{what_size}; + $tsize = '' unless defined $tsize; + $tsize = eval qq("$tsize"); + warn $@ if $@; + print "\tXSprePUSH; PUSH$t->{type}($what$tsize);\n"; + $prepush_done = 1; + } + else { + # RETVAL almost never needs SvSETMAGIC() + generate_output( { + type => $self->{ret_type}, + num => 0, + var => 'RETVAL', + do_setmagic => 0, + do_push => undef, + } ); + } + } + + $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($var_types{$_}, $num++, $_, 0, 1) for @outlist; - + generate_output( { + type => $self->{var_types}->{$_}, + num => $num++, + var => $_, + do_setmagic => 0, + do_push => 1, + } ) for @{ $outlist_ref }; + # do cleanup - process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ; - - print Q(<<"EOF") if $ScopeThisXSUB; + $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); + + 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 - + # print function trailer print Q(<<"EOF"); # ]] EOF - print Q(<<"EOF") if $except; + print Q(<<"EOF") if $self->{except}; # BEGHANDLERS # CATCHALL -# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); +# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); # ENDHANDLERS EOF - if (check_keyword("CASE")) { - blurt ("Error: No `CASE:' at top of function") - unless $condnum; - $_ = "CASE: $_"; # Restore CASE: label - next; + 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 $except; + + print Q(<<"EOF") if $self->{except}; # if (errbuf[0]) -# Perl_croak(aTHX_ errbuf); +# Perl_croak(aTHX_ errbuf); EOF - + if ($xsreturn) { print Q(<<"EOF") unless $PPCODE; # XSRETURN($xsreturn); EOF - } else { + } + else { print Q(<<"EOF") unless $PPCODE; # XSRETURN_EMPTY; EOF @@ -882,85 +797,84 @@ EOF # EOF - our $newXS = "newXS" ; - our $proto = "" ; - + $self->{newXS} = "newXS"; + $self->{proto} = ""; + # Build the prototype string for the xsub - if ($ProtoThisXSUB) { - $newXS = "newXSproto_portable"; - - if ($ProtoThisXSUB eq 2) { - # User has specified empty prototype + if ($self->{ProtoThisXSUB}) { + $self->{newXS} = "newXSproto_portable"; + + if ($self->{ProtoThisXSUB} eq 2) { + # User has specified empty prototype } - elsif ($ProtoThisXSUB eq 1) { - my $s = ';'; - if ($min_args < $num_args) { - $s = ''; - $proto_arg[$min_args] .= ";" ; - } - push @proto_arg, "$s\@" - if $ellipsis ; - - $proto = join ("", grep defined, @proto_arg); + elsif ($self->{ProtoThisXSUB} eq 1) { + my $s = ';'; + if ($min_args < $num_args) { + $s = ''; + $self->{proto_arg}->[$min_args] .= ";"; + } + push @{ $self->{proto_arg} }, "$s\@" + if $ellipsis; + + $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); } else { - # User has specified a prototype - $proto = $ProtoThisXSUB; + # User has specified a prototype + $self->{proto} = $self->{ProtoThisXSUB}; } - $proto = qq{, "$proto"}; + $self->{proto} = qq{, "$self->{proto}"}; } - if (%XsubAliases) { - $XsubAliases{$pname} = 0 - unless defined $XsubAliases{$pname} ; - while ( ($name, $value) = each %XsubAliases) { - push(@InitFileCode, Q(<<"EOF")); -# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto); -# XSANY.any_i32 = $value ; + 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 ( ($name, $value) = each %Interfaces) { - $name = "$Package\::$name" unless $name =~ /::/; - push(@InitFileCode, Q(<<"EOF")); -# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto); -# $interface_macro_set(cv,$value) ; + elsif ($self->{interface}) { + while ( my ($yname, $value) = each %{ $self->{Interfaces} }) { + $yname = "$Package\::$yname" unless $yname =~ /::/; + 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 } @@ -973,8 +887,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,18 +923,18 @@ EOF ##endif EOF - print Q(<<"EOF") if $WantVersionChk ; -# XS_VERSION_BOOTCHECK ; + 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 ; +# 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 */ @@ -1028,22 +942,21 @@ 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) - { - print "\n /* Initialisation Section */\n\n" ; - @line = @BootCode; - print_section(); - print "\n /* End of Initialisation Section */\n\n" ; + if (@{ $BootCode_ref }) { + print "\n /* Initialisation Section */\n\n"; + @{ $self->{line} } = @{ $BootCode_ref }; + $self->print_section(); + print "\n /* End of Initialisation Section */\n\n"; } print Q(<<'EOF'); @@ -1059,654 +972,641 @@ 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 standard_typemap_locations { - # Add all the default typemap locations to the search path - my @tm = qw(typemap); - - my $updir = File::Spec->updir; - foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2), - File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) { - - unshift @tm, File::Spec->catfile($dir, 'typemap'); - unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); - } - foreach my $dir (@INC) { - my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); - unshift @tm, $file if -e $file; - } - return @tm; -} - -sub TrimWhitespace -{ - $_[0] =~ s/^\s+|\s+$//go ; -} - -sub TidyType - { - local ($_) = @_ ; - - # rationalise any '*' by joining them into bunches and removing whitespace - s#\s*(\*+)\s*#$1#g; - s#(\*+)# $1 #g ; - - # change multiple whitespace into a single space - s/\s+/ /g ; - - # trim leading & trailing whitespace - TrimWhitespace($_) ; - - $_ ; -} +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; - s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; + my $self = shift; + $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; + s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; } sub print_section { - # the "do" is required for right semantics - do { $_ = shift(@line) } while !/\S/ && @line; + my $self = shift; - 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)) { - print "$_\n"; - } - print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers; + # the "do" is required for right semantics + do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; + + 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"; + } + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; } sub merge_section { - my $in = ''; + my $self = shift; + my $in = ''; - while (!/\S/ && @line) { - $_ = shift(@line); - } + while (!/\S/ && @{ $self->{line} }) { + $_ = shift(@{ $self->{line} }); + } - for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { - $in .= "$_\n"; - } - chomp $in; - return $in; + 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) = @_; - &{"${kwd}_handler"}() - while $kwd = check_keyword($pattern) ; + 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 = $_; - TrimWhitespace($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 + next unless /\S/; # skip blank lines - TrimWhitespace($_) ; - my $line = $_ ; + trim_whitespace($_); + my $ln = $_; # remove trailing semicolon if no initialisation - s/\s*;$//g unless /[=;+].*\S/ ; + s/\s*;$//g unless /[=;+].*\S/; # Process the length(foo) declarations if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; - $lengthof{$2} = $name; - # $islengthof{$name} = $1; - $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; + $self->{lengthof}->{$2} = undef; + $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; } # check for optional initialisation code - my $var_init = '' ; - $var_init = $1 if s/\s*([=;+].*)$//s ; + my $var_init = ''; + $var_init = $1 if s/\s*([=;+].*)$//s; $var_init =~ s/"/\\"/g; s/\s+/ /g; my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s - or blurt("Error: invalid argument declaration '$line'"), 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); - $name_printed = 1; - } else { - print "\t" . &map_type($var_type); - $name_printed = 0; + # 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($self, $var_type, undef); + $printed_name = 0; } - $var_num = $args_match{$var_name}; + $self->{var_num} = $self->{args_match}->{$var_name}; - $proto_arg[$var_num] = ProtoString($var_type) - if $var_num ; - $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; + 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) || "\$"; + } + $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/ - and $var_init !~ /\S/) { - if ($name_printed) { - print ";\n"; - } else { - print "\t$var_name;\n"; + or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ + and $var_init !~ /\S/) { + if ($printed_name) { + print ";\n"; } - } elsif ($var_init =~ /\S/) { - &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); - } elsif ($var_num) { - # generate initialization code - &generate_init($var_type, $var_num, $var_name, $name_printed); - } else { + else { + print "\t$var_name;\n"; + } + } + elsif ($var_init =~ /\S/) { + output_init( { + type => $var_type, + num => $self->{var_num}, + var => $var_name, + init => $var_init, + printed_name => $printed_name, + } ); + } + elsif ($self->{var_num}) { + generate_init( { + type => $var_type, + num => $self->{var_num}, + var => $var_name, + printed_name => $printed_name, + } ); + } + else { print ";\n"; } } } sub OUTPUT_handler { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + my $self = shift; + $_ = 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') { + my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; + $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 ; - next ; + $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; - } else { - &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); + print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; + } + else { + generate_output( { + type => $self->{var_types}->{$outarg}, + num => $self->{var_num}, + var => $outarg, + 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(); - TrimWhitespace($in); - $func_args = $in; + trim_whitespace($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(); - TrimWhitespace($in); - if ($in =~ /\s/) { # two - ($interface_macro, $interface_macro_set) = split ' ', $in; - } else { - $interface_macro = $in; - $interface_macro_set = 'UNKNOWN_CVT'; # catch later + trim_whitespace($in); + if ($in =~ /\s/) { # two + ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; } - $interface = 1; # local - $Interfaces = 1; # global + else { + $self->{interface_macro} = $in; + $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later + } + $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(); - TrimWhitespace($in); + trim_whitespace($in); foreach (split /[\s,]+/, $in) { - my $name = $_; - $name =~ s/^$Prefix//; - $Interfaces{$name} = $_; + my $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() { print_section() } -sub PREINIT_handler() { print_section() } -sub POSTCALL_handler() { print_section() } -sub INIT_handler() { print_section() } +sub CLEANUP_handler { + my $self = shift; + $self->print_section(); +} -sub GetAliases - { - my ($line) = @_ ; - my ($orig) = $line ; - my ($alias) ; - my ($value) ; +sub PREINIT_handler { + my $self = shift; + $self->print_section(); +} - # Parse alias definitions - # format is - # alias = value alias = value ... +sub POSTCALL_handler { + my $self = shift; + $self->print_section(); +} - while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { - $alias = $1 ; - $orig_alias = $alias ; - $value = $2 ; +sub INIT_handler { + my $self = shift; + $self->print_section(); +} - # check for optional package definition in the alias - $alias = $Packprefix . $alias if $alias !~ /::/ ; +sub get_aliases { + my $self = shift; + my ($line) = @_; + my ($orig) = $line; - # check for duplicate alias name & duplicate value - Warn("Warning: Ignoring duplicate alias '$orig_alias'") - if defined $XsubAliases{$alias} ; + # Parse alias definitions + # format is + # alias = value alias = value ... - Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") - if $XsubAliasValues{$value} ; + while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { + my ($alias, $value) = ($1, $2); + my $orig_alias = $alias; - $XsubAliases = 1; - $XsubAliases{$alias} = $value ; - $XsubAliasValues{$value} = $orig_alias ; - } + # check for optional package definition in the alias + $alias = $self->{Packprefix} . $alias if $alias !~ /::/; + + # check for duplicate alias name & duplicate value + Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") + if defined $self->{XsubAliases}->{$alias}; + + Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") + if $self->{XsubAliasValues}->{$value}; - blurt("Error: Cannot parse ALIAS definitions from '$orig'") - if $line ; + $self->{xsubaliases} = 1; + $self->{XsubAliases}->{$alias} = $value; + $self->{XsubAliasValues}->{$value} = $orig_alias; } -sub ATTRS_handler () - { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - TrimWhitespace($_) ; - push @Attributes, $_; - } + blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") + if $line; +} + +sub ATTRS_handler { + my $self = shift; + $_ = shift; + + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + trim_whitespace($_); + push @{ $self->{Attributes} }, $_; } +} -sub ALIAS_handler () - { - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - TrimWhitespace($_) ; - GetAliases($_) if $_ ; - } +sub ALIAS_handler { + my $self = shift; + $_ = shift; + + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + trim_whitespace($_); + $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/; - TrimWhitespace($_) ; + trim_whitespace($_); while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { - $Overload = 1 unless $Overload; - my $overload = "$Package\::(".$1 ; - push(@InitFileCode, - " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n"); + $self->{Overload} = 1 unless $self->{Overload}; + my $overload = "$Package\::(".$1; + push(@{ $self->{InitFileCode} }, + " (void)$self->{newXS}(\"$overload\", XS_$Full_func_name, file$self->{proto});\n"); } - } + } } -sub FALLBACK_handler() -{ - # the rest of the current line should contain either TRUE, +sub FALLBACK_handler { + my $self = shift; + $_ = shift; + + # the rest of the current line should contain either TRUE, # FALSE or UNDEF - - TrimWhitespace($_) ; + + trim_whitespace($_); my %map = ( - TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes", - FALSE => "&PL_sv_no", 0 => "&PL_sv_no", - UNDEF => "&PL_sv_undef", - ) ; - + TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes", + FALSE => "&PL_sv_no", 0 => "&PL_sv_no", + UNDEF => "&PL_sv_undef", + ); + # check for valid FALLBACK value - death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ; - - $Fallback = $map{uc $_} ; + $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_}; + + $self->{Fallback} = $map{uc $_}; } -sub REQUIRE_handler () - { - # the rest of the current line should contain a version number - my ($Ver) = $_ ; +sub REQUIRE_handler { + my $self = shift; + # the rest of the current line should contain a version number + my $Ver = shift; - TrimWhitespace($Ver) ; + trim_whitespace($Ver); - death ("Error: REQUIRE expects a version number") - unless $Ver ; + $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'") - unless $Ver =~ /^\d+(\.\d*)?/ ; + # check that the version number is of the form n.n + $self->death("Error: REQUIRE: expected a number, got '$Ver'") + unless $Ver =~ /^\d+(\.\d*)?/; - death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.") - unless $VERSION >= $Ver ; - } + $self->death("Error: xsubpp $Ver (or better) required--this is only $VERSION.") + unless $VERSION >= $Ver; +} -sub VERSIONCHECK_handler () - { - # the rest of the current line should contain either ENABLE or - # DISABLE +sub VERSIONCHECK_handler { + my $self = shift; + $_ = shift; - TrimWhitespace($_) ; + # the rest of the current line should contain either ENABLE or + # DISABLE - # check for ENABLE/DISABLE - death ("Error: VERSIONCHECK: ENABLE/DISABLE") - unless /^(ENABLE|DISABLE)/i ; + trim_whitespace($_); - $WantVersionChk = 1 if $1 eq 'ENABLE' ; - $WantVersionChk = 0 if $1 eq 'DISABLE' ; + # check for ENABLE/DISABLE + $self->death("Error: VERSIONCHECK: ENABLE/DISABLE") + unless /^(ENABLE|DISABLE)/i; - } + $self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; + $self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; -sub PROTOTYPE_handler () - { - my $specified ; - - death("Error: Only 1 PROTOTYPE definition allowed per xsub") - if $proto_in_this_xsub ++ ; - - for (; !/^$BLOCK_re/o; $_ = shift(@line)) { - next unless /\S/; - $specified = 1 ; - TrimWhitespace($_) ; - if ($_ eq 'DISABLE') { - $ProtoThisXSUB = 0 - } elsif ($_ eq 'ENABLE') { - $ProtoThisXSUB = 1 - } else { - # remove any whitespace - s/\s+//g ; - death("Error: Invalid prototype '$_'") - unless ValidProtoString($_) ; - $ProtoThisXSUB = C_string($_) ; - } - } +} + +sub PROTOTYPE_handler { + my $self = shift; + $_ = shift; - # If no prototype specified, then assume empty prototype "" - $ProtoThisXSUB = 2 unless $specified ; + my $specified; - $ProtoUsed = 1 ; + $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") + if $self->{proto_in_this_xsub}++; + for (; !/^$self->{BLOCK_re}/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + $specified = 1; + trim_whitespace($_); + if ($_ eq 'DISABLE') { + $self->{ProtoThisXSUB} = 0; + } + elsif ($_ eq 'ENABLE') { + $self->{ProtoThisXSUB} = 1; + } + else { + # remove any whitespace + s/\s+//g; + $self->death("Error: Invalid prototype '$_'") + unless valid_proto_string($_); + $self->{ProtoThisXSUB} = C_string($_); + } } -sub SCOPE_handler () - { - death("Error: Only 1 SCOPE declaration allowed per xsub") - if $scope_in_this_xsub ++ ; + # If no prototype specified, then assume empty prototype "" + $self->{ProtoThisXSUB} = 2 unless $specified; - TrimWhitespace($_); - death ("Error: SCOPE: ENABLE/DISABLE") - unless /^(ENABLE|DISABLE)\b/i; - $ScopeThisXSUB = ( uc($1) eq 'ENABLE' ); - } + $self->{ProtoUsed} = 1; +} -sub PROTOTYPES_handler () - { - # the rest of the current line should contain either ENABLE or - # DISABLE +sub SCOPE_handler { + my $self = shift; + $_ = shift; - TrimWhitespace($_) ; + $self->death("Error: Only 1 SCOPE declaration allowed per xsub") + if $self->{scope_in_this_xsub}++; - # check for ENABLE/DISABLE - death ("Error: PROTOTYPES: ENABLE/DISABLE") - unless /^(ENABLE|DISABLE)/i ; + trim_whitespace($_); + $self->death("Error: SCOPE: ENABLE/DISABLE") + unless /^(ENABLE|DISABLE)\b/i; + $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); +} - $WantPrototypes = 1 if $1 eq 'ENABLE' ; - $WantPrototypes = 0 if $1 eq 'DISABLE' ; - $ProtoUsed = 1 ; +sub PROTOTYPES_handler { + my $self = shift; + $_ = shift; - } + # the rest of the current line should contain either ENABLE or + # DISABLE -sub PushXSStack - { - my %args = @_; - # Save the current file context. - push(@XSStack, { - type => 'file', - LastLine => $lastline, - LastLineNo => $lastline_no, - Line => \@line, - LineNo => \@line_no, - Filename => $filename, - Filepathname => $filepathname, - Handle => $FH, - IsPipe => scalar($filename =~ /\|\s*$/), - %args, - }) ; + trim_whitespace($_); - } + # check for ENABLE/DISABLE + $self->death("Error: PROTOTYPES: ENABLE/DISABLE") + unless /^(ENABLE|DISABLE)/i; + + $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(@{ $self->{XSStack} }, { + type => 'file', + 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 () - { - # the rest of the current line should contain a valid filename +} - TrimWhitespace($_) ; +sub INCLUDE_handler { + my $self = shift; + $_ = shift; + # the rest of the current line should contain a valid filename - death("INCLUDE: filename missing") - unless $_ ; + trim_whitespace($_); - death("INCLUDE: output pipe is illegal") - if /^\s*\|/ ; + $self->death("INCLUDE: filename missing") + unless $_; - # simple minded recursion detector - death("INCLUDE loop detected") - if $IncludedFiles{$_} ; + $self->death("INCLUDE: output pipe is illegal") + if /^\s*\|/; - ++ $IncludedFiles{$_} unless /\|\s*$/ ; + # simple minded recursion detector + $self->death("INCLUDE loop detected") + if $self->{IncludedFiles}->{$_}; - 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."); - } + ++$self->{IncludedFiles}->{$_} unless /\|\s*$/; - PushXSStack(); + if (/\|\s*$/ && /^\s*perl\s/) { + 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."); + } - $FH = Symbol::gensym(); + $self->PushXSStack(); - # open the new file - open ($FH, "$_") or death("Cannot open '$_': $!") ; + $self->{FH} = Symbol::gensym(); - print Q(<<"EOF"); + # open the new file + 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} = File::Spec->catfile($self->{dir}, $self->{filename}); - # Prime the pump by reading the first - # non-blank line + # Prime the pump by reading the first + # non-blank line - # skip leading blank lines - while (<$FH>) { - last unless /^\s*$/ ; - } - - $lastline = $_ ; - $lastline_no = $. ; + # skip leading blank lines + while (readline($self->{FH})) { + last unless /^\s*$/; } + $self->{lastline} = $_; + $self->{lastline_no} = $.; +} + sub QuoteArgs { - my $cmd = shift; - my @args = split /\s+/, $cmd; - $cmd = shift @args; - for (@args) { - $_ = q(").$_.q(") if !/^\"/ && length($_) > 0; - } - return join (' ', ($cmd, @args)); + my $cmd = shift; + my @args = split /\s+/, $cmd; + $cmd = shift @args; + for (@args) { + $_ = q(").$_.q(") if !/^\"/ && length($_) > 0; } + return join (' ', ($cmd, @args)); +} -sub INCLUDE_COMMAND_handler () - { - # the rest of the current line should contain a valid command +sub INCLUDE_COMMAND_handler { + my $self = shift; + $_ = shift; + # the rest of the current line should contain a valid command - TrimWhitespace($_) ; + trim_whitespace($_); - $_ = QuoteArgs($_) if $^O eq 'VMS'; + $_ = QuoteArgs($_) if $^O eq 'VMS'; - death("INCLUDE_COMMAND: command missing") - unless $_ ; + $self->death("INCLUDE_COMMAND: command missing") + unless $_; - death("INCLUDE_COMMAND: pipes are illegal") - if /^\s*\|/ or /\|\s*$/ ; + $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/; + # 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 the new file + open ($self->{FH}, "-|", $_) + or $self->death( $self, "Cannot run command '$_' to include its output: $!"); - print Q(<<"EOF"); + 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; - # Prime the pump by reading the first - # non-blank line + # Prime the pump by reading the first + # non-blank line - # skip leading blank lines - while (<$FH>) { - last unless /^\s*$/ ; - } - - $lastline = $_ ; - $lastline_no = $. ; + # skip leading blank lines + while (readline($self->{FH})) { + last unless /^\s*$/; } -sub PopFile() - { - return 0 unless $XSStack[-1]{type} eq 'file' ; - - my $data = pop @XSStack ; - my $ThisFile = $filename ; - my $isPipe = $data->{IsPipe}; - - -- $IncludedFiles{$filename} - unless $isPipe ; - - close $FH ; - - $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} } ; - - if ($isPipe and $? ) { - -- $lastline_no ; - print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; - exit 1 ; - } + $self->{lastline} = $_; + $self->{lastline_no} = $.; +} - print Q(<<"EOF"); -# -#/* INCLUDE: Returning to '$filename' from '$ThisFile' */ -# -EOF +sub PopFile { + my $self = shift; - return 1 ; - } + return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; -sub ValidProtoString ($) - { - my($string) = @_ ; + my $data = pop @{ $self->{XSStack} }; + my $ThisFile = $self->{filename}; + my $isPipe = $data->{IsPipe}; - if ( $string =~ /^$proto_re+$/ ) { - return $string ; - } + --$self->{IncludedFiles}->{$self->{filename}} + unless $isPipe; - return 0 ; - } + close $self->{FH}; -sub C_string ($) - { - my($string) = @_ ; + $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. + $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} }; - $string =~ s[\\][\\\\]g ; - $string ; + if ($isPipe and $? ) { + --$self->{lastline_no}; + print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; + exit 1; } -sub ProtoString ($) - { - my ($type) = @_ ; - - $proto_letter{$type} or "\$" ; - } + print Q(<<"EOF"); +# +#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ +# +EOF -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; - } + return 1; } - sub Q { my($text) = @_; $text =~ s/^#//gm; @@ -1715,145 +1615,185 @@ 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*$/) { - $Module = $1; + 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*$/); + } + $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}; } - death ("Error: Unterminated pod") unless $lastline; - $lastline = <$FH>; - chomp $lastline; - $lastline =~ s/^\s+$//; + + 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 ($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) ; + + 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*["<].*[>"])/) { + 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; } sub output_init { - local($type, $num, $var, $init, $name_printed) = @_; - local($arg) = "ST(" . ($num - 1) . ")"; + my $argsref = shift; + my ($type, $num, $var, $init, $printed_name) = ( + $argsref->{type}, + $argsref->{num}, + $argsref->{var}, + $argsref->{init}, + $argsref->{printed_name} + ); + my $arg = "ST(" . ($num - 1) . ")"; if ( $init =~ /^=/ ) { - if ($name_printed) { + if ($printed_name) { eval qq/print " $init\\n"/; - } else { + } + else { eval qq/print "\\t$var $init\\n"/; } - warn $@ if $@; - } else { + warn $@ if $@; + } + else { if ( $init =~ s/^\+// && $num ) { - &generate_init($type, $num, $var, $name_printed); - } elsif ($name_printed) { + generate_init( { + type => $type, + num => $num, + var => $var, + printed_name => $printed_name, + } ); + } + elsif ($printed_name) { print ";\n"; $init =~ s/^;//; - } else { + } + else { eval qq/print "\\t$var;\\n"/; - warn $@ if $@; + warn $@ if $@; $init =~ s/^;//; } - $deferred .= eval qq/"\\n\\t$init\\n"/; - warn $@ if $@; + $self->{deferred} .= eval qq/"\\n\\t$init\\n"/; + warn $@ if $@; } } -sub Warn - { - # work out the line number - my $line_no = $line_no[@line_no - @line -1] ; - - print STDERR "@_ in $filename, line $line_no\n" ; - } - -sub blurt - { - Warn @_ ; - $errors ++ - } - -sub death - { - Warn @_ ; - exit 1 ; - } - sub generate_init { - local($type, $num, $var) = @_; - local($arg) = "ST(" . ($num - 1) . ")"; - local($argoff) = $num - 1; - local($ntype); - local($tk); - - $type = TidyType($type) ; - blurt("Error: '$type' not in typemap"), return - unless defined($type_kind{$type}); + my $argsref = shift; + my ($type, $num, $var, $printed_name) = ( + $argsref->{type}, + $argsref->{num}, + $argsref->{var}, + $argsref->{printed_name}, + ); + my $arg = "ST(" . ($num - 1) . ")"; + my ($argoff, $ntype); + $argoff = $num - 1; + + my $typemaps = $self->{typemap}; + + $type = tidy_type($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}) { - print "\t$var" unless $name_printed; + 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} ; - $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}} ; - $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; @@ -1863,332 +1803,138 @@ 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 ($name_printed) { + if ($printed_name) { print ";\n"; - } else { + } + else { eval qq/print "\\t$var;\\n"/; - warn $@ if $@; + warn $@ if $@; + } + if ($self->{defaults}->{$var} eq 'NO_INIT') { + $self->{deferred} .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/; } - if ($defaults{$var} eq 'NO_INIT') { - $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"/; + else { + $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 =/) { - if ($name_printed) { + warn $@ if $@; + } + elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { + if ($printed_name) { print ";\n"; - } else { + } + else { eval qq/print "\\t$var;\\n"/; - warn $@ if $@; + warn $@ if $@; } - $deferred .= eval qq/"\\n$expr;\\n"/; - warn $@ if $@; - } else { + $self->{deferred} .= eval qq/"\\n$expr;\\n"/; + warn $@ if $@; + } + else { die "panic: do not know how to handle this branch for function pointers" - if $name_printed; + if $printed_name; eval qq/print "$expr;\\n"/; - warn $@ if $@; + warn $@ if $@; } } sub generate_output { - local($type, $num, $var, $do_setmagic, $do_push) = @_; - local($arg) = "ST(" . ($num - ($num != 0)) . ")"; - local($argoff) = $num - 1; - local($ntype); - - $type = TidyType($type) ; + my $argsref = shift; + my ($type, $num, $var, $do_setmagic, $do_push) = ( + $argsref->{type}, + $argsref->{num}, + $argsref->{var}, + $argsref->{do_setmagic}, + $argsref->{do_push} + ); + 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"; print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; 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}} ; + } + else { + 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)?$//; - $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}} ; - $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; $subexpr =~ s/\n\t/\n\t\t/g; $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; eval "print qq\a$expr\a"; - warn $@ if $@; + warn $@ if $@; print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; - } elsif ($var eq 'RETVAL') { + } + elsif ($var eq 'RETVAL') { if ($expr =~ /^\t\$arg = new/) { - # We expect that $arg has refcnt 1, so we need to - # mortalize it. - eval "print qq\a$expr\a"; - warn $@ if $@; - print "\tsv_2mortal(ST($num));\n"; - print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; - } elsif ($expr =~ /^\s*\$arg\s*=/) { - # We expect that $arg has refcnt >=1, so we need - # to mortalize it! - eval "print qq\a$expr\a"; - warn $@ if $@; - print "\tsv_2mortal(ST(0));\n"; - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; - } else { - # Just hope that the entry would safely write it - # over an already mortalized value. By - # coincidence, something like $arg = &sv_undef - # works too. - print "\tST(0) = sv_newmortal();\n"; - eval "print qq\a$expr\a"; - warn $@ if $@; - # new mortals don't have set magic + # We expect that $arg has refcnt 1, so we need to + # mortalize it. + eval "print qq\a$expr\a"; + warn $@ if $@; + print "\tsv_2mortal(ST($num));\n"; + print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; + } + elsif ($expr =~ /^\s*\$arg\s*=/) { + # We expect that $arg has refcnt >=1, so we need + # to mortalize it! + eval "print qq\a$expr\a"; + warn $@ if $@; + print "\tsv_2mortal(ST(0));\n"; + print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; + } + else { + # Just hope that the entry would safely write it + # over an already mortalized value. By + # coincidence, something like $arg = &sv_undef + # works too. + print "\tST(0) = sv_newmortal();\n"; + eval "print qq\a$expr\a"; + warn $@ if $@; + # new mortals don't have set magic } - } elsif ($do_push) { + } + elsif ($do_push) { print "\tPUSHs(sv_newmortal());\n"; $arg = "ST($num)"; eval "print qq\a$expr\a"; - warn $@ if $@; + warn $@ if $@; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; - } elsif ($arg =~ /^ST\(\d+\)$/) { + } + elsif ($arg =~ /^ST\(\d+\)$/) { eval "print qq\a$expr\a"; - warn $@ if $@; + warn $@ if $@; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } } } -sub map_type { - my($type, $varname) = @_; - - # C++ has :: in types too so skip this - $type =~ tr/:/_/ unless $hiertype; - $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; - if ($varname) { - if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { - (substr $type, pos $type, 0) = " $varname "; - } else { - $type .= "\t$varname"; - } - } - $type; -} - - -######################################################### -package - ExtUtils::ParseXS::CountLines; -use strict; -use vars qw($SECTION_END_MARKER); - -sub TIEHANDLE { - my ($class, $cfile, $fh) = @_; - $cfile =~ s/\\/\\\\/g; - $SECTION_END_MARKER = qq{#line --- "$cfile"}; - - return bless {buffer => '', - fh => $fh, - line_no => 1, - }, $class; -} - -sub PRINT { - my $self = shift; - for (@_) { - $self->{buffer} .= $_; - while ($self->{buffer} =~ s/^([^\n]*\n)//) { - my $line = $1; - ++ $self->{line_no}; - $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|; - print {$self->{fh}} $line; - } - } -} - -sub PRINTF { - my $self = shift; - my $fmt = shift; - $self->PRINT(sprintf($fmt, @_)); -} - -sub DESTROY { - # Not necessary if we're careful to end with a "\n" - my $self = shift; - print {$self->{fh}} $self->{buffer}; -} - -sub UNTIE { - # This sub does nothing, but is necessary for references to be released. -} - -sub end_marker { - return $SECTION_END_MARKER; -} - - 1; -__END__ - -=head1 NAME - -ExtUtils::ParseXS - converts Perl XS code into C code - -=head1 SYNOPSIS - - use ExtUtils::ParseXS qw(process_file); - - process_file( filename => 'foo.xs' ); - - process_file( filename => 'foo.xs', - output => 'bar.c', - 'C++' => 1, - typemap => 'path/to/typemap', - hiertype => 1, - except => 1, - prototypes => 1, - versioncheck => 1, - linenumbers => 1, - optimize => 1, - prototypes => 1, - ); -=head1 DESCRIPTION - -C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs -necessary to let C functions manipulate Perl values and creates the glue -necessary to let Perl access those functions. The compiler uses typemaps to -determine how to map C function parameters and variables to Perl values. - -The compiler will search for typemap files called I<typemap>. It will use -the following search path to find default typemaps, with the rightmost -typemap taking precedence. - - ../../../typemap:../../typemap:../typemap:typemap - -=head1 EXPORT - -None by default. C<process_file()> may be exported upon request. - - -=head1 FUNCTIONS - -=over 4 - -=item process_xs() - -This function processes an XS file and sends output to a C file. -Named parameters control how the processing is done. The following -parameters are accepted: - -=over 4 - -=item B<C++> - -Adds C<extern "C"> to the C code. Default is false. - -=item B<hiertype> - -Retains C<::> in type names so that C++ hierarchical types can be -mapped. Default is false. - -=item B<except> - -Adds exception handling stubs to the C code. Default is false. - -=item B<typemap> - -Indicates that a user-supplied typemap should take precedence over the -default typemaps. A single typemap may be specified as a string, or -multiple typemaps can be specified in an array reference, with the -last typemap having the highest precedence. - -=item B<prototypes> - -Generates prototype code for all xsubs. Default is false. - -=item B<versioncheck> - -Makes sure at run time that the object file (derived from the C<.xs> -file) and the C<.pm> files have the same version number. Default is -true. - -=item B<linenumbers> - -Adds C<#line> directives to the C output so error messages will look -like they came from the original XS file. Default is true. - -=item B<optimize> - -Enables certain optimizations. The only optimization that is currently -affected is the use of I<target>s by the output C code (see L<perlguts>). -Not optimizing may significantly slow down the generated code, but this is the way -B<xsubpp> of 5.005 and earlier operated. Default is to optimize. - -=item B<inout> - -Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> -declarations. Default is true. - -=item B<argtypes> - -Enable recognition of ANSI-like descriptions of function signature. -Default is true. - -=item B<s> - -I have no clue what this does. Strips function prefixes? - -=back - -=item errors() - -This function returns the number of [a certain kind of] errors -encountered during processing of the XS file. - -=back - -=head1 AUTHOR - -Based on xsubpp code, written by Larry Wall. - -Maintained by: - -=over 4 - -=item * - -Ken Williams, <ken@mathforum.org> - -=item * - -David Golden, <dagolden@cpan.org> - -=back - -=head1 COPYRIGHT - -Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All -rights reserved. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5 -Porters, which was released under the same license terms. - -=head1 SEE ALSO - -L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>. -=cut +# vim: ts=2 sw=2 et: diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod new file mode 100644 index 0000000000..7b6895d625 --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pod @@ -0,0 +1,161 @@ +=head1 NAME + +ExtUtils::ParseXS - converts Perl XS code into C code + +=head1 SYNOPSIS + + use ExtUtils::ParseXS qw(process_file); + + process_file( filename => 'foo.xs' ); + + process_file( filename => 'foo.xs', + output => 'bar.c', + 'C++' => 1, + typemap => 'path/to/typemap', + hiertype => 1, + except => 1, + prototypes => 1, + versioncheck => 1, + linenumbers => 1, + optimize => 1, + prototypes => 1, + ); + +=head1 DESCRIPTION + +C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs +necessary to let C functions manipulate Perl values and creates the glue +necessary to let Perl access those functions. The compiler uses typemaps to +determine how to map C function parameters and variables to Perl values. + +The compiler will search for typemap files called I<typemap>. It will use +the following search path to find default typemaps, with the rightmost +typemap taking precedence. + + ../../../typemap:../../typemap:../typemap:typemap + +=head1 EXPORT + +None by default. C<process_file()> may be exported upon request. + +=head1 FUNCTIONS + +=over 4 + +=item process_file() + +This function processes an XS file and sends output to a C file. +Named parameters control how the processing is done. The following +parameters are accepted: + +=over 4 + +=item B<C++> + +Adds C<extern "C"> to the C code. Default is false. + +=item B<hiertype> + +Retains C<::> in type names so that C++ hierarchical types can be +mapped. Default is false. + +=item B<except> + +Adds exception handling stubs to the C code. Default is false. + +=item B<typemap> + +Indicates that a user-supplied typemap should take precedence over the +default typemaps. A single typemap may be specified as a string, or +multiple typemaps can be specified in an array reference, with the +last typemap having the highest precedence. + +=item B<prototypes> + +Generates prototype code for all xsubs. Default is false. + +=item B<versioncheck> + +Makes sure at run time that the object file (derived from the C<.xs> +file) and the C<.pm> files have the same version number. Default is +true. + +=item B<linenumbers> + +Adds C<#line> directives to the C output so error messages will look +like they came from the original XS file. Default is true. + +=item B<optimize> + +Enables certain optimizations. The only optimization that is currently +affected is the use of I<target>s by the output C code (see L<perlguts>). +Not optimizing may significantly slow down the generated code, but this is the way +B<xsubpp> of 5.005 and earlier operated. Default is to optimize. + +=item B<inout> + +Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> +declarations. Default is true. + +=item B<argtypes> + +Enable recognition of ANSI-like descriptions of function signature. +Default is true. + +=item B<s> + +I<Maintainer note:> I have no clue what this does. Strips function prefixes? + +=back + +=item errors() + +This function returns the number of [a certain kind of] errors +encountered during processing of the XS file. + +=back + +=head1 AUTHOR + +Based on xsubpp code, written by Larry Wall. + +Maintained by: + +=over 4 + +=item * + +Ken Williams, <ken@mathforum.org> + +=item * + +David Golden, <dagolden@cpan.org> + +=item * + +James Keenan, <jkeenan@cpan.org> + +=item * + +Steffen Mueller, <smueller@cpan.org> + +=back + +=head1 COPYRIGHT + +Copyright 2002-2011 by Ken Williams, David Golden and other contributors. All +rights reserved. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Based on the C<ExtUtils::xsubpp> code by Larry Wall and the Perl 5 +Porters, which was released under the same license terms. + +=head1 SEE ALSO + +L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>. + +=cut + + diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm new file mode 100644 index 0000000000..69eba9d578 --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm @@ -0,0 +1,39 @@ +package ExtUtils::ParseXS::Constants; +use strict; +use warnings; +use Symbol; + +=head1 NAME + +ExtUtils::ParseXS::Constants - Initialization values for some globals + +=head1 SYNOPSIS + + use ExtUtils::ParseXS::Constants (); + + $PrototypeRegexp = $ExtUtils::ParseXS::Constants::PrototypeRegexp; + +=head1 DESCRIPTION + +Initialization of certain non-subroutine variables in ExtUtils::ParseXS and some of its +supporting packages has been moved into this package so that those values can +be defined exactly once and then re-used in any package. + +Nothing is exported. Use fully qualified variable names. + +=cut + +# FIXME: THESE ARE NOT CONSTANTS! +our @InitFileCode; + +# Note that to reduce maintenance, $PrototypeRegexp is used +# by ExtUtils::Typemaps, too! +our $PrototypeRegexp = "[" . quotemeta('\$%&*@;[]_') . "]"; +our @XSKeywords = qw( + REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE + OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE + VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE + INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK +); + +1; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm new file mode 100644 index 0000000000..d576c09637 --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm @@ -0,0 +1,50 @@ +package ExtUtils::ParseXS::CountLines; +use strict; +our $SECTION_END_MARKER; + +sub TIEHANDLE { + my ($class, $cfile, $fh) = @_; + $cfile =~ s/\\/\\\\/g; + $SECTION_END_MARKER = qq{#line --- "$cfile"}; + + return bless { + buffer => '', + fh => $fh, + line_no => 1, + }, $class; +} + +sub PRINT { + my $self = shift; + for (@_) { + $self->{buffer} .= $_; + while ($self->{buffer} =~ s/^([^\n]*\n)//) { + my $line = $1; + ++$self->{line_no}; + $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|; + print {$self->{fh}} $line; + } + } +} + +sub PRINTF { + my $self = shift; + my $fmt = shift; + $self->PRINT(sprintf($fmt, @_)); +} + +sub DESTROY { + # Not necessary if we're careful to end with a "\n" + my $self = shift; + print {$self->{fh}} $self->{buffer}; +} + +sub UNTIE { + # This sub does nothing, but is necessary for references to be released. +} + +sub end_marker { + return $SECTION_END_MARKER; +} + +1; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm new file mode 100644 index 0000000000..1616b0dc52 --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -0,0 +1,757 @@ +package ExtUtils::ParseXS::Utilities; +use strict; +use warnings; +use Exporter; +use File::Spec; +use lib qw( lib ); +use ExtUtils::ParseXS::Constants (); + +our (@ISA, @EXPORT_OK); +@ISA = qw(Exporter); +@EXPORT_OK = qw( + standard_typemap_locations + trim_whitespace + tidy_type + C_string + valid_proto_string + 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 +); + +=head1 NAME + +ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS + +=head1 SYNOPSIS + + use ExtUtils::ParseXS::Utilities qw( + standard_typemap_locations + trim_whitespace + tidy_type + C_string + valid_proto_string + process_typemaps + make_targetable + map_type + standard_XS_defs + assign_func_args + analyze_preprocessor_statements + set_cond + Warn + blurt + death + check_conditional_preprocessor_statements + ); + +=head1 SUBROUTINES + +The following functions are not considered to be part of the public interface. +They are documented here for the benefit of future maintainers of this module. + +=head2 C<standard_typemap_locations()> + +=over 4 + +=item * Purpose + +Provide a list of filepaths where F<typemap> files may be found. The +filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority. + +The highest priority is to look in the current directory. + + 'typemap' + +The second and third highest priorities are to look in the parent of the +current directory and a directory called F<lib/ExtUtils> underneath the parent +directory. + + '../typemap', + '../lib/ExtUtils/typemap', + +The fourth through ninth highest priorities are to look in the corresponding +grandparent, great-grandparent and great-great-grandparent directories. + + '../../typemap', + '../../lib/ExtUtils/typemap', + '../../../typemap', + '../../../lib/ExtUtils/typemap', + '../../../../typemap', + '../../../../lib/ExtUtils/typemap', + +The tenth and subsequent priorities are to look in directories named +F<ExtUtils> which are subdirectories of directories found in C<@INC> -- +I<provided> a file named F<typemap> actually exists in such a directory. +Example: + + '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', + +However, these filepaths appear in the list returned by +C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest. + + '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', + '../../../../lib/ExtUtils/typemap', + '../../../../typemap', + '../../../lib/ExtUtils/typemap', + '../../../typemap', + '../../lib/ExtUtils/typemap', + '../../typemap', + '../lib/ExtUtils/typemap', + '../typemap', + 'typemap' + +=item * Arguments + + my @stl = standard_typemap_locations( \@INC ); + +Reference to C<@INC>. + +=item * Return Value + +Array holding list of directories to be searched for F<typemap> files. + +=back + +=cut + +sub standard_typemap_locations { + my $include_ref = shift; + my @tm = qw(typemap); + + my $updir = File::Spec->updir(); + foreach my $dir ( + File::Spec->catdir(($updir) x 1), + File::Spec->catdir(($updir) x 2), + File::Spec->catdir(($updir) x 3), + File::Spec->catdir(($updir) x 4), + ) { + unshift @tm, File::Spec->catfile($dir, 'typemap'); + unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); + } + foreach my $dir (@{ $include_ref}) { + my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); + unshift @tm, $file if -e $file; + } + return @tm; +} + +=head2 C<trim_whitespace()> + +=over 4 + +=item * Purpose + +Perform an in-place trimming of leading and trailing whitespace from the +first argument provided to the function. + +=item * Argument + + trim_whitespace($arg); + +=item * Return Value + +None. Remember: this is an I<in-place> modification of the argument. + +=back + +=cut + +sub trim_whitespace { + $_[0] =~ s/^\s+|\s+$//go; +} + +=head2 C<tidy_type()> + +=over 4 + +=item * Purpose + +Rationalize any asterisks (C<*>) by joining them into bunches, removing +interior whitespace, then trimming leading and trailing whitespace. + +=item * Arguments + + ($ret_type) = tidy_type($_); + +String to be cleaned up. + +=item * Return Value + +String cleaned up. + +=back + +=cut + +sub tidy_type { + local ($_) = @_; + + # rationalise any '*' by joining them into bunches and removing whitespace + s#\s*(\*+)\s*#$1#g; + s#(\*+)# $1 #g; + + # change multiple whitespace into a single space + s/\s+/ /g; + + # trim leading & trailing whitespace + trim_whitespace($_); + + $_; +} + +=head2 C<C_string()> + +=over 4 + +=item * Purpose + +Escape backslashes (C<\>) in prototype strings. + +=item * Arguments + + $ProtoThisXSUB = C_string($_); + +String needing escaping. + +=item * Return Value + +Properly escaped string. + +=back + +=cut + +sub C_string { + my($string) = @_; + + $string =~ s[\\][\\\\]g; + $string; +} + +=head2 C<valid_proto_string()> + +=over 4 + +=item * Purpose + +Validate prototype string. + +=item * Arguments + +String needing checking. + +=item * Return Value + +Upon success, returns the same string passed as argument. + +Upon failure, returns C<0>. + +=back + +=cut + +sub valid_proto_string { + my($string) = @_; + + if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) { + return $string; + } + + return 0; +} + +=head2 C<process_typemaps()> + +=over 4 + +=item * Purpose + +Process all typemap files. + +=item * Arguments + + my $typemaps_object = process_typemaps( $args{typemap}, $pwd ); + +List of two elements: C<typemap> element from C<%args>; current working +directory. + +=item * Return Value + +Upon success, returns an L<ExtUtils::Typemaps> object. + +=back + +=cut + +sub process_typemaps { + my ($tmap, $pwd) = @_; + + my @tm = ref $tmap ? @{$tmap} : ($tmap); + + foreach my $typemap (@tm) { + die "Can't find $typemap in $pwd\n" unless -r $typemap; + } + + push @tm, standard_typemap_locations( \@INC ); + + require ExtUtils::Typemaps; + my $typemap = ExtUtils::Typemaps->new; + foreach my $typemap_loc (@tm) { + next unless -f $typemap_loc; + # skip directories, binary files etc. + warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next + unless -T $typemap_loc; + + $typemap->merge(file => $typemap_loc, replace => 1); + } + + return $typemap; +} + +=head2 C<make_targetable()> + +=over 4 + +=item * Purpose + +Populate C<%targetable>. This constitutes a refinement of the output of +C<process_typemaps()> with respect to its fourth output, C<$output_expr_ref>. + +=item * Arguments + + %targetable = make_targetable($output_expr_ref); + +Single hash reference: the fourth such ref returned by C<process_typemaps()>. + +=item * Return Value + +Hash. + +=back + +=cut + +sub make_targetable { + my $output_expr_ref = shift; + + our $bal; # ()-balanced + $bal = qr[ + (?: + (?>[^()]+) + | + \( (??{ $bal }) \) + )* + ]x; + + # matches variations on (SV*) + my $sv_cast = qr[ + (?: + \( \s* SV \s* \* \s* \) \s* + )? + ]x; + + my $size = qr[ # Third arg (to setpvn) + , \s* (??{ $bal }) + ]x; + + my %targetable; + foreach my $key (keys %{ $output_expr_ref }) { + # We can still bootstrap compile 're', because in code re.pm is + # available to miniperl, and does not attempt to load the XS code. + use re 'eval'; + + my ($type, $with_size, $arg, $sarg) = + ($output_expr_ref->{$key} =~ + m[^ + \s+ + sv_set([iunp])v(n)? # Type, is_setpvn + \s* + \( \s* + $sv_cast \$arg \s* , \s* + ( (??{ $bal }) ) # Set from + ( (??{ $size }) )? # Possible sizeof set-from + \) \s* ; \s* $ + ]x + ); + $targetable{$key} = [$type, $with_size, $arg, $sarg] if $type; + } + return %targetable; +} + +=head2 C<map_type()> + +=over 4 + +=item * Purpose + +Performs a mapping at several places inside C<PARAGRAPH> loop. + +=item * Arguments + + $type = map_type($self, $type, $varname); + +List of three arguments. + +=item * Return Value + +String holding augmented version of second argument. + +=back + +=cut + +sub map_type { + my ($self, $type, $varname) = @_; + + # C++ has :: in types too so skip this + $type =~ tr/:/_/ unless $self->{hiertype}; + $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; + if ($varname) { + if ($type =~ / \( \s* \* (?= \s* \) ) /xg) { + (substr $type, pos $type, 0) = " $varname "; + } + else { + $type .= "\t$varname"; + } + } + return $type; +} + +=head2 C<standard_XS_defs()> + +=over 4 + +=item * Purpose + +Writes to the C<.c> output file certain preprocessor directives and function +headers needed in all such files. + +=item * Arguments + +None. + +=item * Return Value + +Returns true. + +=back + +=cut + +sub standard_XS_defs { + print <<"EOF"; +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(var) if (0) var = var +#endif + +EOF + + 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 + return 1; +} + +=head2 C<assign_func_args()> + +=over 4 + +=item * Purpose + +Perform assignment to the C<func_args> attribute. + +=item * Arguments + + $string = assign_func_args($self, $argsref, $class); + +List of three elements. Second is an array reference; third is a string. + +=item * Return Value + +String. + +=back + +=cut + +sub assign_func_args { + my ($self, $argsref, $class) = @_; + my @func_args = @{$argsref}; + shift @func_args if defined($class); + + for my $arg (@func_args) { + $arg =~ s/^/&/ if $self->{in_out}->{$arg}; + } + return join(", ", @func_args); +} + +=head2 C<analyze_preprocessor_statements()> + +=over 4 + +=item * Purpose + +Within each function inside each Xsub, print to the F<.c> output file certain +preprocessor statements. + +=item * Arguments + + ( $self, $XSS_work_idx, $BootCode_ref ) = + analyze_preprocessor_statements( + $self, $statement, $XSS_work_idx, $BootCode_ref + ); + +List of four elements. + +=item * Return Value + +Modifed values of three of the arguments passed to the function. In +particular, the C<XSStack> and C<InitFileCode> attributes are modified. + +=back + +=cut + +sub analyze_preprocessor_statements { + my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_; + + if ($statement eq 'if') { + $XSS_work_idx = @{ $self->{XSStack} }; + push(@{ $self->{XSStack} }, {type => 'if'}); + } + else { + $self->death("Error: `$statement' with no matching `if'") + if $self->{XSStack}->[-1]{type} ne 'if'; + if ($self->{XSStack}->[-1]{varname}) { + push(@{ $self->{InitFileCode} }, "#endif\n"); + push(@{ $BootCode_ref }, "#endif"); + } + + my(@fns) = keys %{$self->{XSStack}->[-1]{functions}}; + if ($statement ne 'endif') { + # Hide the functions defined in other #if branches, and reset. + @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns; + @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {}); + } + else { + my($tmp) = pop(@{ $self->{XSStack} }); + 0 while (--$XSS_work_idx + && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if'); + # Keep all new defined functions + push(@fns, keys %{$tmp->{other_functions}}); + @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; + } + } + return ($self, $XSS_work_idx, $BootCode_ref); +} + +=head2 C<set_cond()> + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + +sub set_cond { + my ($ellipsis, $min_args, $num_args) = @_; + my $cond; + 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); + } + return $cond; +} + +=head2 C<current_line_number()> + +=over 4 + +=item * Purpose + +Figures out the current line number in the XS file. + +=item * Arguments + +C<$self> + +=item * Return Value + +The current line number. + +=back + +=cut + +sub current_line_number { + my $self = shift; + my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1]; + return $line_number; +} + +=head2 C<Warn()> + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + +sub Warn { + my $self = shift; + my $warn_line_number = $self->current_line_number(); + print STDERR "@_ in $self->{filename}, line $warn_line_number\n"; +} + +=head2 C<blurt()> + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + +sub blurt { + my $self = shift; + $self->Warn(@_); + $self->{errors}++ +} + +=head2 C<death()> + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + +sub death { + my $self = shift; + $self->Warn(@_); + exit 1; +} + +=head2 C<check_conditional_preprocessor_statements()> + +=over 4 + +=item * Purpose + +=item * Arguments + +=item * Return Value + +=back + +=cut + +sub check_conditional_preprocessor_statements { + my ($self) = @_; + my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} }); + if (@cpp) { + my $cpplevel; + for my $cpp (@cpp) { + if ($cpp =~ /^\#\s*if/) { + $cpplevel++; + } + elsif (!$cpplevel) { + $self->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 $self->{XSStack}->[-1]{type} eq 'if'; + return; + } + elsif ($cpp =~ /^\#\s*endif/) { + $cpplevel--; + } + } + $self->Warn("Warning: #if without #endif in this function") if $cpplevel; + } +} + +1; + +# vim: ts=2 sw=2 et: diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm new file mode 100644 index 0000000000..0f5d12c840 --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm @@ -0,0 +1,977 @@ +package ExtUtils::Typemaps; +use 5.006001; +use strict; +use warnings; +our $VERSION = '1.00'; +#use Carp qw(croak); + +require ExtUtils::ParseXS; +require ExtUtils::ParseXS::Constants; +require ExtUtils::Typemaps::InputMap; +require ExtUtils::Typemaps::OutputMap; +require ExtUtils::Typemaps::Type; + +=head1 NAME + +ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files + +=head1 SYNOPSIS + + # read/create file + my $typemap = ExtUtils::Typemaps->new(file => 'typemap'); + # alternatively create an in-memory typemap + # $typemap = ExtUtils::Typemaps->new(); + # alternatively create an in-memory typemap by parsing a string + # $typemap = ExtUtils::Typemaps->new(string => $sometypemap); + + # add a mapping + $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV'); + $typemap->add_inputmap (xstype => 'T_NV', code => '$var = ($type)SvNV($arg);'); + $typemap->add_outputmap(xstype => 'T_NV', code => 'sv_setnv($arg, (NV)$var);'); + $typemap->add_string(string => $typemapstring); # will be parsed and merged + + # remove a mapping (same for remove_typemap and remove_outputmap...) + $typemap->remove_inputmap(xstype => 'SomeType'); + + # save a typemap to a file + $typemap->write(file => 'anotherfile.map'); + + # merge the other typemap into this one + $typemap->merge(typemap => $another_typemap); + +=head1 DESCRIPTION + +This module can read, modify, create and write Perl XS typemap files. If you don't know +what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals. + +The module is not entirely round-trip safe: For example it currently simply strips all comments. +The order of entries in the maps is, however, preserved. + +We check for duplicate entries in the typemap, but do not check for missing +C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden +in a different typemap. + +=head1 METHODS + +=cut + +=head2 new + +Returns a new typemap object. Takes an optional C<file> parameter. +If set, the given file will be read. If the file doesn't exist, an empty typemap +is returned. + +Alternatively, if the C<string> parameter is given, the supplied +string will be parsed instead of a file. + +=cut + +sub new { + my $class = shift; + my %args = @_; + + if (defined $args{file} and defined $args{string}) { + die("Cannot handle both 'file' and 'string' arguments to constructor"); + } + + my $self = bless { + file => undef, + %args, + typemap_section => [], + typemap_lookup => {}, + input_section => [], + input_lookup => {}, + output_section => [], + output_lookup => {}, + } => $class; + + $self->_init(); + + return $self; +} + +sub _init { + my $self = shift; + if (defined $self->{string}) { + $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename}); + delete $self->{string}; + } + elsif (defined $self->{file} and -e $self->{file}) { + open my $fh, '<', $self->{file} + or die "Cannot open typemap file '" + . $self->{file} . "' for reading: $!"; + local $/ = undef; + my $string = <$fh>; + $self->_parse(\$string, $self->{lineno_offset}, $self->{file}); + } +} + +=head2 file + +Get/set the file that the typemap is written to when the +C<write> method is called. + +=cut + +sub file { + $_[0]->{file} = $_[1] if @_ > 1; + $_[0]->{file} +} + +=head2 add_typemap + +Add a C<TYPEMAP> entry to the typemap. + +Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>) +and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>). + +Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of +existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1> +triggers a I<"first come first serve"> logic by which new entries that conflict +with existing entries are silently ignored. + +As an alternative to the named parameters usage, you may pass in +an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be +added to the typemap. In that case, only the C<replace> or C<skip> named parameters +may be used after the object. Example: + + $map->add_typemap($type_obj, replace => 1); + +=cut + +sub add_typemap { + my $self = shift; + my $type; + my %args; + + if ((@_ % 2) == 1) { + my $orig = shift; + $type = $orig->new(); + %args = @_; + } + else { + %args = @_; + my $ctype = $args{ctype}; + die("Need ctype argument") if not defined $ctype; + my $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + + $type = ExtUtils::Typemaps::Type->new( + xstype => $xstype, + 'prototype' => $args{'prototype'}, + ctype => $ctype, + ); + } + + if ($args{skip} and $args{replace}) { + die("Cannot use both 'skip' and 'replace'"); + } + + if ($args{replace}) { + $self->remove_typemap(ctype => $type->ctype); + } + elsif ($args{skip}) { + return() if exists $self->{typemap_lookup}{$type->ctype}; + } + else { + $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype); + } + + # store + push @{$self->{typemap_section}}, $type; + # remember type for lookup, too. + $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}}; + + return 1; +} + +=head2 add_inputmap + +Add an C<INPUT> entry to the typemap. + +Required named arguments: +The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>) +and the C<code> to associate with it for input. + +Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of +existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1> +triggers a I<"first come first serve"> logic by which new entries that conflict +with existing entries are silently ignored. + +As an alternative to the named parameters usage, you may pass in +an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be +added to the typemap. In that case, only the C<replace> or C<skip> named parameters +may be used after the object. Example: + + $map->add_inputmap($type_obj, replace => 1); + +=cut + +sub add_inputmap { + my $self = shift; + my $input; + my %args; + + if ((@_ % 2) == 1) { + my $orig = shift; + $input = $orig->new(); + %args = @_; + } + else { + %args = @_; + my $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + my $code = $args{code}; + die("Need code argument") if not defined $code; + + $input = ExtUtils::Typemaps::InputMap->new( + xstype => $xstype, + code => $code, + ); + } + + if ($args{skip} and $args{replace}) { + die("Cannot use both 'skip' and 'replace'"); + } + + if ($args{replace}) { + $self->remove_inputmap(xstype => $input->xstype); + } + elsif ($args{skip}) { + return() if exists $self->{input_lookup}{$input->xstype}; + } + else { + $self->validate(inputmap_xstype => $input->xstype); + } + + # store + push @{$self->{input_section}}, $input; + # remember type for lookup, too. + $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}}; + + return 1; +} + +=head2 add_outputmap + +Add an C<OUTPUT> entry to the typemap. +Works exactly the same as C<add_inputmap>. + +=cut + +sub add_outputmap { + my $self = shift; + my $output; + my %args; + + if ((@_ % 2) == 1) { + my $orig = shift; + $output = $orig->new(); + %args = @_; + } + else { + %args = @_; + my $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + my $code = $args{code}; + die("Need code argument") if not defined $code; + + $output = ExtUtils::Typemaps::OutputMap->new( + xstype => $xstype, + code => $code, + ); + } + + if ($args{skip} and $args{replace}) { + die("Cannot use both 'skip' and 'replace'"); + } + + if ($args{replace}) { + $self->remove_outputmap(xstype => $output->xstype); + } + elsif ($args{skip}) { + return() if exists $self->{output_lookup}{$output->xstype}; + } + else { + $self->validate(outputmap_xstype => $output->xstype); + } + + # store + push @{$self->{output_section}}, $output; + # remember type for lookup, too. + $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}}; + + return 1; +} + +=head2 add_string + +Parses a string as a typemap and merge it into the typemap object. + +Required named argument: C<string> to specify the string to parse. + +=cut + +sub add_string { + my $self = shift; + my %args = @_; + die("Need 'string' argument") if not defined $args{string}; + + # no, this is not elegant. + my $other = ExtUtils::Typemaps->new(string => $args{string}); + $self->merge(typemap => $other); +} + +=head2 remove_typemap + +Removes a C<TYPEMAP> entry from the typemap. + +Required named argument: C<ctype> to specify the entry to remove from the typemap. + +Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object. + +=cut + +sub remove_typemap { + my $self = shift; + my $ctype; + if (@_ > 1) { + my %args = @_; + $ctype = $args{ctype}; + die("Need ctype argument") if not defined $ctype; + $ctype = _tidy_type($ctype); + } + else { + $ctype = $_[0]->tidy_ctype; + } + + return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup}); +} + +=head2 remove_inputmap + +Removes an C<INPUT> entry from the typemap. + +Required named argument: C<xstype> to specify the entry to remove from the typemap. + +Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object. + +=cut + +sub remove_inputmap { + my $self = shift; + my $xstype; + if (@_ > 1) { + my %args = @_; + $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + } + else { + $xstype = $_[0]->xstype; + } + + return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup}); +} + +=head2 remove_inputmap + +Removes an C<OUTPUT> entry from the typemap. + +Required named argument: C<xstype> to specify the entry to remove from the typemap. + +Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object. + +=cut + +sub remove_outputmap { + my $self = shift; + my $xstype; + if (@_ > 1) { + my %args = @_; + $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + } + else { + $xstype = $_[0]->xstype; + } + + return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup}); +} + +sub _remove { + my $self = shift; + my $rm = shift; + my $array = shift; + my $lookup = shift; + + # Just fetch the index of the item from the lookup table + my $index = $lookup->{$rm}; + return() if not defined $index; + + # Nuke the item from storage + splice(@$array, $index, 1); + + # Decrement the storage position of all items thereafter + foreach my $key (keys %$lookup) { + if ($lookup->{$key} > $index) { + $lookup->{$key}--; + } + } + return(); +} + +=head2 get_typemap + +Fetches an entry of the TYPEMAP section of the typemap. + +Mandatory named arguments: The C<ctype> of the entry. + +Returns the C<ExtUtils::Typemaps::Type> +object for the entry if found. + +=cut + +sub get_typemap { + my $self = shift; + die("Need named parameters, got uneven number") if @_ % 2; + + my %args = @_; + my $ctype = $args{ctype}; + die("Need ctype argument") if not defined $ctype; + $ctype = _tidy_type($ctype); + + my $index = $self->{typemap_lookup}{$ctype}; + return() if not defined $index; + return $self->{typemap_section}[$index]; +} + +=head2 get_inputmap + +Fetches an entry of the INPUT section of the +typemap. + +Mandatory named arguments: The C<xstype> of the +entry or the C<ctype> of the typemap that can be used to find +the C<xstype>. To wit, the following pieces of code +are equivalent: + + my $type = $typemap->get_typemap(ctype => $ctype) + my $input_map = $typemap->get_inputmap(xstype => $type->xstype); + + my $input_map = $typemap->get_inputmap(ctype => $ctype); + +Returns the C<ExtUtils::Typemaps::InputMap> +object for the entry if found. + +=cut + +sub get_inputmap { + my $self = shift; + die("Need named parameters, got uneven number") if @_ % 2; + + my %args = @_; + my $xstype = $args{xstype}; + my $ctype = $args{ctype}; + die("Need xstype or ctype argument") + if not defined $xstype + and not defined $ctype; + die("Need xstype OR ctype arguments, not both") + if defined $xstype and defined $ctype; + + if (defined $ctype) { + my $tm = $self->get_typemap(ctype => $ctype); + $xstype = $tm && $tm->xstype; + return() if not defined $xstype; + } + + my $index = $self->{input_lookup}{$xstype}; + return() if not defined $index; + return $self->{input_section}[$index]; +} + +=head2 get_outputmap + +Fetches an entry of the OUTPUT section of the +typemap. + +Mandatory named arguments: The C<xstype> of the +entry or the C<ctype> of the typemap that can be used to +resolve the C<xstype>. (See above for an example.) + +Returns the C<ExtUtils::Typemaps::InputMap> +object for the entry if found. + +=cut + +sub get_outputmap { + my $self = shift; + die("Need named parameters, got uneven number") if @_ % 2; + + my %args = @_; + my $xstype = $args{xstype}; + my $ctype = $args{ctype}; + die("Need xstype or ctype argument") + if not defined $xstype + and not defined $ctype; + die("Need xstype OR ctype arguments, not both") + if defined $xstype and defined $ctype; + + if (defined $ctype) { + my $tm = $self->get_typemap(ctype => $ctype); + $xstype = $tm && $tm->xstype; + return() if not defined $xstype; + } + + my $index = $self->{output_lookup}{$xstype}; + return() if not defined $index; + return $self->{output_section}[$index]; +} + +=head2 write + +Write the typemap to a file. Optionally takes a C<file> argument. If given, the +typemap will be written to the specified file. If not, the typemap is written +to the currently stored file name (see C<-E<gt>file> above, this defaults to the file +it was read from if any). + +=cut + +sub write { + my $self = shift; + my %args = @_; + my $file = defined $args{file} ? $args{file} : $self->file(); + die("write() needs a file argument (or set the file name of the typemap using the 'file' method)") + if not defined $file; + + open my $fh, '>', $file + or die "Cannot open typemap file '$file' for writing: $!"; + print $fh $self->as_string(); + close $fh; +} + +=head2 as_string + +Generates and returns the string form of the typemap. + +=cut + +sub as_string { + my $self = shift; + my $typemap = $self->{typemap_section}; + my @code; + push @code, "TYPEMAP\n"; + foreach my $entry (@$typemap) { + # type kind proto + # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o + push @code, $entry->ctype . "\t" . $entry->xstype + . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n"; + } + + my $input = $self->{input_section}; + if (@$input) { + push @code, "\nINPUT\n"; + foreach my $entry (@$input) { + push @code, $entry->xstype, "\n", $entry->code, "\n"; + } + } + + my $output = $self->{output_section}; + if (@$output) { + push @code, "\nOUTPUT\n"; + foreach my $entry (@$output) { + push @code, $entry->xstype, "\n", $entry->code, "\n"; + } + } + return join '', @code; +} + +=head2 merge + +Merges a given typemap into the object. Note that a failed merge +operation leaves the object in an inconsistent state so clone it if necessary. + +Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj> +or C<file =E<gt> $path_to_typemap_file> but not both. + +Optional arguments: C<replace =E<gt> 1> to force replacement +of existing typemap entries without warning or C<skip =E<gt> 1> +to skip entries that exist already in the typemap. + +=cut + +sub merge { + my $self = shift; + my %args = @_; + + if (exists $args{typemap} and exists $args{file}) { + die("Need {file} OR {typemap} argument. Not both!"); + } + elsif (not exists $args{typemap} and not exists $args{file}) { + die("Need {file} or {typemap} argument!"); + } + + my @params; + push @params, 'replace' => $args{replace} if exists $args{replace}; + push @params, 'skip' => $args{skip} if exists $args{skip}; + + my $typemap = $args{typemap}; + if (not defined $typemap) { + $typemap = ref($self)->new(file => $args{file}, @params); + } + + # FIXME breaking encapsulation. Add accessor code. + foreach my $entry (@{$typemap->{typemap_section}}) { + $self->add_typemap( $entry, @params ); + } + + foreach my $entry (@{$typemap->{input_section}}) { + $self->add_inputmap( $entry, @params ); + } + + foreach my $entry (@{$typemap->{output_section}}) { + $self->add_outputmap( $entry, @params ); + } + + return 1; +} + +=head2 is_empty + +Returns a bool indicating whether this typemap is entirely empty. + +=cut + +sub is_empty { + my $self = shift; + + return @{ $self->{typemap_section} } == 0 + && @{ $self->{input_section} } == 0 + && @{ $self->{output_section} } == 0; +} + +=head2 _get_typemap_hash + +Returns a hash mapping the C types to the XS types: + + { + 'char **' => 'T_PACKEDARRAY', + 'bool_t' => 'T_IV', + 'AV *' => 'T_AVREF', + 'InputStream' => 'T_IN', + 'double' => 'T_DOUBLE', + # ... + } + +This is documented because it is used by C<ExtUtils::ParseXS>, +but it's not intended for general consumption. May be removed +at any time. + +=cut + +sub _get_typemap_hash { + my $self = shift; + my $lookup = $self->{typemap_lookup}; + my $storage = $self->{typemap_section}; + + my %rv; + foreach my $ctype (keys %$lookup) { + $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype; + } + + return \%rv; +} + +=head2 _get_inputmap_hash + +Returns a hash mapping the XS types (identifiers) to the +corresponding INPUT code: + + { + 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg) + ', + 'T_OUT' => ' $var = IoOFP(sv_2io($arg)) + ', + 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) { + # ... + } + +This is documented because it is used by C<ExtUtils::ParseXS>, +but it's not intended for general consumption. May be removed +at any time. + +=cut + +sub _get_inputmap_hash { + my $self = shift; + my $lookup = $self->{input_lookup}; + my $storage = $self->{input_section}; + + my %rv; + foreach my $xstype (keys %$lookup) { + $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; + + # Squash trailing whitespace to one line break + # This isn't strictly necessary, but makes the output more similar + # to the original ExtUtils::ParseXS. + $rv{$xstype} =~ s/\s*\z/\n/; + } + + return \%rv; +} + + +=head2 _get_outputmap_hash + +Returns a hash mapping the XS types (identifiers) to the +corresponding OUTPUT code: + + { + 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), + $var.context.value().size()); + ', + 'T_OUT' => ' { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } + ', + # ... + } + +This is documented because it is used by C<ExtUtils::ParseXS>, +but it's not intended for general consumption. May be removed +at any time. + +=cut + +sub _get_outputmap_hash { + my $self = shift; + my $lookup = $self->{output_lookup}; + my $storage = $self->{output_section}; + + my %rv; + foreach my $xstype (keys %$lookup) { + $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; + + # Squash trailing whitespace to one line break + # This isn't strictly necessary, but makes the output more similar + # to the original ExtUtils::ParseXS. + $rv{$xstype} =~ s/\s*\z/\n/; + } + + return \%rv; +} + +=head2 _get_prototype_hash + +Returns a hash mapping the C types of the typemap to their +corresponding prototypes. + + { + 'char **' => '$', + 'bool_t' => '$', + 'AV *' => '$', + 'InputStream' => '$', + 'double' => '$', + # ... + } + +This is documented because it is used by C<ExtUtils::ParseXS>, +but it's not intended for general consumption. May be removed +at any time. + +=cut + +sub _get_prototype_hash { + my $self = shift; + my $lookup = $self->{typemap_lookup}; + my $storage = $self->{typemap_section}; + + my %rv; + foreach my $ctype (keys %$lookup) { + $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$'; + } + + return \%rv; +} + + + +# make sure that the provided types wouldn't collide with what's +# in the object already. +sub validate { + my $self = shift; + my %args = @_; + + if ( exists $args{ctype} + and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} ) + { + die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section"); + } + + if ( exists $args{inputmap_xstype} + and exists $self->{input_lookup}{$args{inputmap_xstype}} ) + { + die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section"); + } + + if ( exists $args{outputmap_xstype} + and exists $self->{output_lookup}{$args{outputmap_xstype}} ) + { + die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section"); + } + + return 1; +} + +sub _parse { + my $self = shift; + my $stringref = shift; + my $lineno_offset = shift; + $lineno_offset = 0 if not defined $lineno_offset; + my $filename = shift; + $filename = '<string>' if not defined $filename; + + my $replace = $self->{replace}; + my $skip = $self->{skip}; + die "Can only replace OR skip" if $replace and $skip; + my @add_params; + push @add_params, replace => 1 if $replace; + push @add_params, skip => 1 if $skip; + + # TODO comments should round-trip, currently ignoring + # TODO order of sections, multiple sections of same type + # Heavily influenced by ExtUtils::ParseXS + my $section = 'typemap'; + my $lineno = $lineno_offset; + my $junk = ""; + my $current = \$junk; + my @input_expr; + my @output_expr; + while ($$stringref =~ /^(.*)$/gcm) { + local $_ = $1; + ++$lineno; + chomp; + next if /^\s*#/; + if (/^INPUT\s*$/) { + $section = 'input'; + $current = \$junk; + next; + } + elsif (/^OUTPUT\s*$/) { + $section = 'output'; + $current = \$junk; + next; + } + elsif (/^TYPEMAP\s*$/) { + $section = 'typemap'; + $current = \$junk; + next; + } + + if ($section eq 'typemap') { + my $line = $_; + s/^\s+//; s/\s+$//; + next if $_ eq '' or /^#/; + my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o + or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"), + next; + # prototype defaults to '$' + $proto = '$' unless $proto; + warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n") + unless _valid_proto_string($proto); + $self->add_typemap( + ExtUtils::Typemaps::Type->new( + xstype => $kind, proto => $proto, ctype => $type + ), + @add_params + ); + } elsif (/^\s/) { + s/\s+$//; + $$current .= $$current eq '' ? $_ : "\n".$_; + } elsif ($_ eq '') { + next; + } elsif ($section eq 'input') { + s/\s+$//; + push @input_expr, {xstype => $_, code => ''}; + $current = \$input_expr[-1]{code}; + } else { # output section + s/\s+$//; + push @output_expr, {xstype => $_, code => ''}; + $current = \$output_expr[-1]{code}; + } + + } # end while lines + + foreach my $inexpr (@input_expr) { + $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params ); + } + foreach my $outexpr (@output_expr) { + $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params ); + } + + return 1; +} + +# taken from ExtUtils::ParseXS +sub _tidy_type { + local $_ = shift; + + # rationalise any '*' by joining them into bunches and removing whitespace + s#\s*(\*+)\s*#$1#g; + s#(\*+)# $1 #g ; + + # trim leading & trailing whitespace + s/^\s+//; s/\s+$//; + + # change multiple whitespace into a single space + s/\s+/ /g; + + $_; +} + + +# taken from ExtUtils::ParseXS +sub _valid_proto_string { + my $string = shift; + if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) { + return $string; + } + + return 0 ; +} + +# taken from ExtUtils::ParseXS (C_string) +sub _escape_backslashes { + my $string = shift; + $string =~ s[\\][\\\\]g; + $string; +} + +=head1 CAVEATS + +Inherits some evil code from C<ExtUtils::ParseXS>. + +=head1 SEE ALSO + +The parser is heavily inspired from the one in L<ExtUtils::ParseXS>. + +For details on typemaps: L<perlxstut>, L<perlxs>. + +=head1 AUTHOR + +Steffen Mueller C<<smueller@cpan.org>> + +=head1 COPYRIGHT & LICENSE + +Copyright 2009-2011 Steffen Mueller + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; + diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm new file mode 100644 index 0000000000..163353eca9 --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm @@ -0,0 +1,116 @@ +package ExtUtils::Typemaps::InputMap; +use 5.006001; +use strict; +use warnings; +#use Carp qw(croak); + +=head1 NAME + +ExtUtils::Typemaps::InputMap - Entry in the INPUT section of a typemap + +=head1 SYNOPSIS + + use ExtUtils::Typemaps; + ... + my $input = $typemap->get_input_map('T_NV'); + my $code = $input->code(); + $input->code("..."); + +=head1 DESCRIPTION + +Refer to L<ExtUtils::Typemaps> for details. + +=head1 METHODS + +=cut + +=head2 new + +Requires C<xstype> and C<code> parameters. + +=cut + +sub new { + my $prot = shift; + my $class = ref($prot)||$prot; + my %args = @_; + + if (!ref($prot)) { + if (not defined $args{xstype} or not defined $args{code}) { + die("Need xstype and code parameters"); + } + } + + my $self = bless( + (ref($prot) ? {%$prot} : {}) + => $class + ); + + $self->{xstype} = $args{xstype} if defined $args{xstype}; + $self->{code} = $args{code} if defined $args{code}; + $self->{code} =~ s/^(?=\S)/\t/mg; + + return $self; +} + +=head2 code + +Returns or sets the INPUT mapping code for this entry. + +=cut + +sub code { + $_[0]->{code} = $_[1] if @_ > 1; + return $_[0]->{code}; +} + +=head2 xstype + +Returns the name of the XS type of the INPUT map. + +=cut + +sub xstype { + return $_[0]->{xstype}; +} + +=head2 cleaned_code + +Returns a cleaned-up copy of the code to which certain transformations +have been applied to make it more ANSI compliant. + +=cut + +sub cleaned_code { + my $self = shift; + my $code = $self->code; + + $code =~ s/;*\s+\z//; + + # Move C pre-processor instructions to column 1 to be strictly ANSI + # conformant. Some pre-processors are fussy about this. + $code =~ s/^\s+#/#/mg; + $code =~ s/\s*\z/\n/; + + return $code; +} + +=head1 SEE ALSO + +L<ExtUtils::Typemaps> + +=head1 AUTHOR + +Steffen Mueller C<<smueller@cpan.org>> + +=head1 COPYRIGHT & LICENSE + +Copyright 2009-2011 Steffen Mueller + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; + diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm new file mode 100644 index 0000000000..d29cae4e82 --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm @@ -0,0 +1,194 @@ +package ExtUtils::Typemaps::OutputMap; +use 5.006001; +use strict; +use warnings; +#use Carp qw(croak); + +=head1 NAME + +ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap + +=head1 SYNOPSIS + + use ExtUtils::Typemaps; + ... + my $output = $typemap->get_output_map('T_NV'); + my $code = $output->code(); + $output->code("..."); + +=head1 DESCRIPTION + +Refer to L<ExtUtils::Typemaps> for details. + +=head1 METHODS + +=cut + +=head2 new + +Requires C<xstype> and C<code> parameters. + +=cut + +sub new { + my $prot = shift; + my $class = ref($prot)||$prot; + my %args = @_; + + if (!ref($prot)) { + if (not defined $args{xstype} or not defined $args{code}) { + die("Need xstype and code parameters"); + } + } + + my $self = bless( + (ref($prot) ? {%$prot} : {}) + => $class + ); + + $self->{xstype} = $args{xstype} if defined $args{xstype}; + $self->{code} = $args{code} if defined $args{code}; + $self->{code} =~ s/^(?=\S)/\t/mg; + + return $self; +} + +=head2 code + +Returns or sets the OUTPUT mapping code for this entry. + +=cut + +sub code { + $_[0]->{code} = $_[1] if @_ > 1; + return $_[0]->{code}; +} + +=head2 xstype + +Returns the name of the XS type of the OUTPUT map. + +=cut + +sub xstype { + return $_[0]->{xstype}; +} + +=head2 cleaned_code + +Returns a cleaned-up copy of the code to which certain transformations +have been applied to make it more ANSI compliant. + +=cut + +sub cleaned_code { + my $self = shift; + my $code = $self->code; + + # Move C pre-processor instructions to column 1 to be strictly ANSI + # conformant. Some pre-processors are fussy about this. + $code =~ s/^\s+#/#/mg; + $code =~ s/\s*\z/\n/; + + return $code; +} + +=head2 targetable + +This is an obscure optimization that used to live in C<ExtUtils::ParseXS> +directly. + +In a nutshell, this will check whether the output code +involves calling C<set_iv>, C<set_uv>, C<set_nv>, C<set_pv> or C<set_pvn> +to set the special C<$arg> placeholder to a new value +B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is +eligible for using the C<TARG>-related macros to optimize this. +Thus the name of the method: C<targetable>. + +If the optimization can not be applied, this returns undef. +If it can be applied, this method returns a hash reference containing +the following information: + + type: Any of the characters i, u, n, p + with_size: Bool indicating whether this is the sv_setpvn variant + what: The code that actually evaluates to the output scalar + what_size: If "with_size", this has the string length (as code, not constant) + +=cut + +sub targetable { + my $self = shift; + return $self->{targetable} if exists $self->{targetable}; + + our $bal; # ()-balanced + $bal = qr[ + (?: + (?>[^()]+) + | + \( (??{ $bal }) \) + )* + ]x; + + # matches variations on (SV*) + my $sv_cast = qr[ + (?: + \( \s* SV \s* \* \s* \) \s* + )? + ]x; + + my $size = qr[ # Third arg (to setpvn) + , \s* (??{ $bal }) + ]x; + + my $code = $self->code; + + # We can still bootstrap compile 're', because in code re.pm is + # available to miniperl, and does not attempt to load the XS code. + use re 'eval'; + + my ($type, $with_size, $arg, $sarg) = + ($code =~ + m[^ + \s+ + sv_set([iunp])v(n)? # Type, is_setpvn + \s* + \( \s* + $sv_cast \$arg \s* , \s* + ( (??{ $bal }) ) # Set from + ( (??{ $size }) )? # Possible sizeof set-from + \) \s* ; \s* $ + ]x + ); + + my $rv = undef; + if ($type) { + $rv = { + type => $type, + with_size => $with_size, + what => $arg, + what_size => $sarg, + }; + } + $self->{targetable} = $rv; + return $rv; +} + +=head1 SEE ALSO + +L<ExtUtils::Typemaps> + +=head1 AUTHOR + +Steffen Mueller C<<smueller@cpan.org>> + +=head1 COPYRIGHT & LICENSE + +Copyright 2009-2011 Steffen Mueller + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; + diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm new file mode 100644 index 0000000000..ad57b3a7bb --- /dev/null +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm @@ -0,0 +1,121 @@ +package ExtUtils::Typemaps::Type; +use 5.006001; +use strict; +use warnings; +our $VERSION = '0.05'; +#use Carp qw(croak); +require ExtUtils::Typemaps; + +=head1 NAME + +ExtUtils::Typemaps::Type - Entry in the TYPEMAP section of a typemap + +=head1 SYNOPSIS + + use ExtUtils::Typemaps; + ... + my $type = $typemap->get_type_map('char*'); + my $input = $typemap->get_input_map($type->xstype); + +=head1 DESCRIPTION + +Refer to L<ExtUtils::Typemaps> for details. +Object associates C<ctype> with C<xstype>, which is the index +into the in- and output mapping tables. + +=head1 METHODS + +=cut + +=head2 new + +Requires C<xstype> and C<ctype> parameters. + +Optionally takes C<prototype> parameter. + +=cut + +sub new { + my $prot = shift; + my $class = ref($prot)||$prot; + my %args = @_; + + if (!ref($prot)) { + if (not defined $args{xstype} or not defined $args{ctype}) { + die("Need xstype and ctype parameters"); + } + } + + my $self = bless( + (ref($prot) ? {%$prot} : {proto => ''}) + => $class + ); + + $self->{xstype} = $args{xstype} if defined $args{xstype}; + $self->{ctype} = $args{ctype} if defined $args{ctype}; + $self->{tidy_ctype} = ExtUtils::Typemaps::_tidy_type($self->{ctype}); + $self->{proto} = $args{'prototype'} if defined $args{'prototype'}; + + return $self; +} + +=head2 proto + +Returns or sets the prototype. + +=cut + +sub proto { + $_[0]->{proto} = $_[1] if @_ > 1; + return $_[0]->{proto}; +} + +=head2 xstype + +Returns the name of the XS type that this C type is associated to. + +=cut + +sub xstype { + return $_[0]->{xstype}; +} + +=head2 ctype + +Returns the name of the C type as it was set on construction. + +=cut + +sub ctype { + return defined($_[0]->{ctype}) ? $_[0]->{ctype} : $_[0]->{tidy_ctype}; +} + +=head2 tidy_ctype + +Returns the canonicalized name of the C type. + +=cut + +sub tidy_ctype { + return $_[0]->{tidy_ctype}; +} + +=head1 SEE ALSO + +L<ExtUtils::Typemaps> + +=head1 AUTHOR + +Steffen Mueller C<<smueller@cpan.org>> + +=head1 COPYRIGHT & LICENSE + +Copyright 2009-2011 Steffen Mueller + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + +1; + diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/xsubpp b/dist/ExtUtils-ParseXS/lib/ExtUtils/xsubpp index e4e5b774d8..2dfe278105 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/xsubpp +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/xsubpp @@ -1,7 +1,10 @@ #!./miniperl require 5.002; -use ExtUtils::ParseXS qw(process_file); +use ExtUtils::ParseXS qw( + process_file + report_error_count +); use Getopt::Long; my %args = (); @@ -38,7 +41,7 @@ if ($args{v}) { $args{filename} = shift @ARGV; process_file(%args); -exit( ExtUtils::ParseXS::errors() ? 1 : 0 ); +exit( report_error_count() ? 1 : 0 ); __END__ diff --git a/dist/ExtUtils-ParseXS/t/basic.t b/dist/ExtUtils-ParseXS/t/001-basic.t index 39e1ca912c..f94876890b 100644 --- a/dist/ExtUtils-ParseXS/t/basic.t +++ b/dist/ExtUtils-ParseXS/t/001-basic.t @@ -1,13 +1,11 @@ #!/usr/bin/perl use strict; -use Test::More; +use Test::More tests => 11; use Config; use DynaLoader; use ExtUtils::CBuilder; -plan tests => 10; - my ($source_file, $obj_file, $lib_file); require_ok( 'ExtUtils::ParseXS' ); @@ -37,7 +35,7 @@ SKIP: { skip "no compiler available", 2 if ! $b->have_compiler; $obj_file = $b->compile( source => $source_file ); - ok $obj_file; + ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; ok -e $obj_file, "Make sure $obj_file exists"; } @@ -46,13 +44,15 @@ SKIP: { if !$b->have_compiler || !$Config{usedl}; my $module = 'XSTest'; $lib_file = $b->link( objects => $obj_file, module_name => $module ); - ok $lib_file; + ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; ok -e $lib_file, "Make sure $lib_file exists"; eval {require XSTest}; - is $@, ''; - ok XSTest::is_even(8); - ok !XSTest::is_even(9); + is $@, '', "No error message recorded, as expected"; + ok XSTest::is_even(8), + "Function created thru XS returned expected true value"; + ok !XSTest::is_even(9), + "Function created thru XS returned expected false value"; # Win32 needs to close the DLL before it can unlink it, but unfortunately # dl_unload_file was missing on Win32 prior to perl change #24679! @@ -66,6 +66,15 @@ SKIP: { } } +my $seen = 0; +open my $IN, '<', $source_file + or die "Unable to open $source_file: $!"; +while (my $l = <$IN>) { + $seen++ if $l =~ m/#line\s1\s/; +} +close $IN or die "Unable to close $source_file: $!"; +is( $seen, 1, "Linenumbers created in output file, as intended" ); + unless ($ENV{PERL_NO_CLEANUP}) { for ( $obj_file, $lib_file, $source_file) { next unless defined $_; diff --git a/dist/ExtUtils-ParseXS/t/more.t b/dist/ExtUtils-ParseXS/t/002-more.t index 4c2a39ae88..04bd296fc9 100644 --- a/dist/ExtUtils-ParseXS/t/more.t +++ b/dist/ExtUtils-ParseXS/t/002-more.t @@ -1,6 +1,7 @@ #!/usr/bin/perl use strict; +use warnings; use Test::More; use Config; use DynaLoader; @@ -8,7 +9,7 @@ use ExtUtils::CBuilder; use attributes; use overload; -plan tests => 25; +plan tests => 28; my ($source_file, $obj_file, $lib_file); @@ -37,16 +38,16 @@ SKIP: { skip "no compiler available", 2 if ! $b->have_compiler; $obj_file = $b->compile( source => $source_file ); - ok $obj_file; + ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; ok -e $obj_file, "Make sure $obj_file exists"; } SKIP: { - skip "no dynamic loading", 21 + skip "no dynamic loading", 24 if !$b->have_compiler || !$Config{usedl}; my $module = 'XSMore'; $lib_file = $b->link( objects => $obj_file, module_name => $module ); - ok $lib_file; + ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; ok -e $lib_file, "Make sure $lib_file exists"; eval{ @@ -57,8 +58,8 @@ SKIP: { sub new{ bless {}, shift } }; - is $@, ''; - is ExtUtils::ParseXS::errors(), 0, 'ExtUtils::ParseXS::errors()'; + is $@, '', "No error message recorded, as expected"; + is ExtUtils::ParseXS::report_error_count(), 0, 'ExtUtils::ParseXS::errors()'; is $XSMore::boot_ok, 100, 'the BOOT keyword'; @@ -90,6 +91,11 @@ SKIP: { is XSMore::sum(5, 9), 14, 'the INCLUDE_COMMAND directive'; + # Tests for embedded typemaps + is XSMore::typemaptest1(), 42, 'Simple embedded typemap works'; + is XSMore::typemaptest2(), 42, 'Simple embedded typemap works with funny end marker'; + is XSMore::typemaptest3(12), 12, 'Simple embedded typemap works for input, too'; + # Win32 needs to close the DLL before it can unlink it, but unfortunately # dl_unload_file was missing on Win32 prior to perl change #24679! if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) { diff --git a/dist/ExtUtils-ParseXS/t/usage.t b/dist/ExtUtils-ParseXS/t/003-usage.t index 3d6ed791b4..3d6ed791b4 100644 --- a/dist/ExtUtils-ParseXS/t/usage.t +++ b/dist/ExtUtils-ParseXS/t/003-usage.t diff --git a/dist/ExtUtils-ParseXS/t/004-nolinenumbers.t b/dist/ExtUtils-ParseXS/t/004-nolinenumbers.t new file mode 100644 index 0000000000..4a1565a5e5 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/004-nolinenumbers.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl + +use strict; +use Test::More tests => 11; +use Config; +use DynaLoader; +use ExtUtils::CBuilder; + +my ($source_file, $obj_file, $lib_file); + +require_ok( 'ExtUtils::ParseXS' ); +ExtUtils::ParseXS->import('process_file'); + +chdir 't' or die "Can't chdir to t/, $!"; + +use Carp; $SIG{__WARN__} = \&Carp::cluck; + +######################### + +# Try sending to filehandle +tie *FH, 'Foo'; +process_file( + filename => 'XSTest.xs', + output => \*FH, + prototypes => 1, + linenumbers => 0, +); +like tied(*FH)->content, '/is_even/', "Test that output contains some text"; + +$source_file = 'XSTest.c'; + +# Try sending to file +process_file( + filename => 'XSTest.xs', + output => $source_file, + prototypes => 0, + linenumbers => 0, +); +ok -e $source_file, "Create an output file"; + +my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; +my $b = ExtUtils::CBuilder->new(quiet => $quiet); + +SKIP: { + skip "no compiler available", 2 + if ! $b->have_compiler; + $obj_file = $b->compile( source => $source_file ); + ok $obj_file, "ExtUtils::CBuilder::compile() returned true value"; + ok -e $obj_file, "Make sure $obj_file exists"; +} + +SKIP: { + skip "no dynamic loading", 5 + if !$b->have_compiler || !$Config{usedl}; + my $module = 'XSTest'; + $lib_file = $b->link( objects => $obj_file, module_name => $module ); + ok $lib_file, "ExtUtils::CBuilder::link() returned true value"; + ok -e $lib_file, "Make sure $lib_file exists"; + + eval {require XSTest}; + is $@, '', "No error message recorded, as expected"; + ok XSTest::is_even(8), + "Function created thru XS returned expected true value"; + ok !XSTest::is_even(9), + "Function created thru XS returned expected false value"; + + # Win32 needs to close the DLL before it can unlink it, but unfortunately + # dl_unload_file was missing on Win32 prior to perl change #24679! + if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) { + for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { + if ($DynaLoader::dl_modules[$i] eq $module) { + DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); + last; + } + } + } +} + +my $seen = 0; +open my $IN, '<', $source_file + or die "Unable to open $source_file: $!"; +while (my $l = <$IN>) { + $seen++ if $l =~ m/#line\s1\s/; +} +close $IN or die "Unable to close $source_file: $!"; +is( $seen, 0, "No linenumbers created in output file, as intended" ); + + +unless ($ENV{PERL_NO_CLEANUP}) { + for ( $obj_file, $lib_file, $source_file) { + next unless defined $_; + 1 while unlink $_; + } +} + +##################################################################### + +sub Foo::TIEHANDLE { bless {}, 'Foo' } +sub Foo::PRINT { shift->{buf} .= join '', @_ } +sub Foo::content { shift->{buf} } diff --git a/dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t b/dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t new file mode 100644 index 0000000000..e9e7e59650 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/101-standard_typemap_locations.t @@ -0,0 +1,25 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + standard_typemap_locations +); + +{ + local @INC = @INC; + my @stl = standard_typemap_locations( \@INC ); + ok( @stl >= 9, "At least 9 entries in typemap locations list" ); + is( $stl[$#stl], 'typemap', + "Last element is typemap in current directory"); + SKIP: { + skip "No lib/ExtUtils/ directories under directories in \@INC", + 1 + unless @stl > 9; + ok( -f $stl[-10], + "At least one typemap file exists underneath \@INC directories" + ); + } +} + diff --git a/dist/ExtUtils-ParseXS/t/102-trim_whitespace.t b/dist/ExtUtils-ParseXS/t/102-trim_whitespace.t new file mode 100644 index 0000000000..65f70328f6 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/102-trim_whitespace.t @@ -0,0 +1,30 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 5; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + trim_whitespace +); + +my $str; + +$str = 'overworked'; +trim_whitespace($str); +is( $str, 'overworked', "Got expected value" ); + +$str = ' overworked'; +trim_whitespace($str); +is( $str, 'overworked', "Got expected value" ); + +$str = 'overworked '; +trim_whitespace($str); +is( $str, 'overworked', "Got expected value" ); + +$str = ' overworked '; +trim_whitespace($str); +is( $str, 'overworked', "Got expected value" ); + +$str = "\toverworked"; +trim_whitespace($str); +is( $str, 'overworked', "Got expected value" ); diff --git a/dist/ExtUtils-ParseXS/t/103-tidy_type.t b/dist/ExtUtils-ParseXS/t/103-tidy_type.t new file mode 100644 index 0000000000..a043383637 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/103-tidy_type.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 3; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + tidy_type +); + +my $input; + +$input = ' * ** '; +is( tidy_type($input), '***', + "Got expected value for '$input'" ); + +$input = ' * ** '; +is( tidy_type($input), '***', + "Got expected value for '$input'" ); + +$input = ' * ** foobar * '; +is( tidy_type($input), '*** foobar *', + "Got expected value for '$input'" ); + diff --git a/dist/ExtUtils-ParseXS/t/104-map_type.t b/dist/ExtUtils-ParseXS/t/104-map_type.t new file mode 100644 index 0000000000..01e784e37c --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/104-map_type.t @@ -0,0 +1,67 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 7; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + map_type +); + +my ($self, $type, $varname); +my ($result, $expected); + +$type = 'struct DATA *'; +$varname = 'RETVAL'; +$self->{hiertype} = 0; +$expected = "$type\t$varname"; +$result = map_type($self, $type, $varname); +is( $result, $expected, + "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" ); + +$type = 'Crypt::Shark'; +$varname = undef; +$self->{hiertype} = 0; +$expected = 'Crypt__Shark'; +$result = map_type($self, $type, $varname); +is( $result, $expected, + "Got expected map_type for <$type>, undef, <$self->{hiertype}>" ); + +$type = 'Crypt::Shark'; +$varname = undef; +$self->{hiertype} = 1; +$expected = 'Crypt::Shark'; +$result = map_type($self, $type, $varname); +is( $result, $expected, + "Got expected map_type for <$type>, undef, <$self->{hiertype}>" ); + +$type = 'Crypt::TC18'; +$varname = 'RETVAL'; +$self->{hiertype} = 0; +$expected = "Crypt__TC18\t$varname"; +$result = map_type($self, $type, $varname); +is( $result, $expected, + "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" ); + +$type = 'Crypt::TC18'; +$varname = 'RETVAL'; +$self->{hiertype} = 1; +$expected = "Crypt::TC18\t$varname"; +$result = map_type($self, $type, $varname); +is( $result, $expected, + "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" ); + +$type = 'array(alpha,beta) gamma'; +$varname = 'RETVAL'; +$self->{hiertype} = 0; +$expected = "alpha *\t$varname"; +$result = map_type($self, $type, $varname); +is( $result, $expected, + "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" ); + +$type = '(*)'; +$varname = 'RETVAL'; +$self->{hiertype} = 0; +$expected = "(* $varname )"; +$result = map_type($self, $type, $varname); +is( $result, $expected, + "Got expected map_type for <$type>, <$varname>, <$self->{hiertype}>" ); diff --git a/dist/ExtUtils-ParseXS/t/105-valid_proto_string.t b/dist/ExtUtils-ParseXS/t/105-valid_proto_string.t new file mode 100644 index 0000000000..926ebe6154 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/105-valid_proto_string.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 6; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + valid_proto_string +); + +my ($input, $output); + +$input = '[\$]'; +$output = valid_proto_string($input); +is( $output, $input, "Got expected value for <$input>" ); + +$input = '[$]'; +$output = valid_proto_string($input); +is( $output, $input, "Got expected value for <$input>" ); + +$input = '[\$\@]'; +$output = valid_proto_string($input); +is( $output, $input, "Got expected value for <$input>" ); + +$input = '[\$alpha]'; +$output = valid_proto_string($input); +is( $output, 0, "Got expected value for <$input>" ); + +$input = '[alpha]'; +$output = valid_proto_string($input); +is( $output, 0, "Got expected value for <$input>" ); + +$input = '[_]'; +$output = valid_proto_string($input); +is( $output, $input, "Got expected value for <$input>" ); + diff --git a/dist/ExtUtils-ParseXS/t/106-process_typemaps.t b/dist/ExtUtils-ParseXS/t/106-process_typemaps.t new file mode 100644 index 0000000000..0f28510e12 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/106-process_typemaps.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More tests => 2; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + process_typemaps +); + +my $startdir = cwd(); +{ + my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); + my $typemap = 'typemap'; + my $tdir = tempdir( CLEANUP => 1 ); + chdir $tdir or croak "Unable to change to tempdir for testing"; + eval { + ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) + = process_typemaps( $typemap, $tdir ); + }; + like( $@, qr/Can't find \Q$typemap\E in \Q$tdir\E/, #' + "Got expected result for no typemap in current directory" ); + chdir $startdir; +} + +{ + my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); + my $typemap = [ qw( pseudo typemap ) ]; + my $tdir = tempdir( CLEANUP => 1 ); + chdir $tdir or croak "Unable to change to tempdir for testing"; + open my $IN, '>', 'typemap' or croak "Cannot open for writing"; + print $IN "\n"; + close $IN or croak "Cannot close after writing"; + eval { + ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) + = process_typemaps( $typemap, $tdir ); + }; + like( $@, qr/Can't find pseudo in \Q$tdir\E/, #' + "Got expected result for no typemap in current directory" ); + chdir $startdir; +} + diff --git a/dist/ExtUtils-ParseXS/t/107-make_targetable.t b/dist/ExtUtils-ParseXS/t/107-make_targetable.t new file mode 100644 index 0000000000..fde608f4e0 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/107-make_targetable.t @@ -0,0 +1,146 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More qw(no_plan); # tests => 7; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + make_targetable +); + +my $output_expr_ref = { + 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), + $var.context.value().size()); +', + 'T_OUT' => ' { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_REF_IV_PTR' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var); +', + 'T_U_LONG' => ' sv_setuv($arg, (UV)$var); +', + 'T_U_CHAR' => ' sv_setuv($arg, (UV)$var); +', + 'T_U_INT' => ' sv_setuv($arg, (UV)$var); +', + 'T_ARRAY' => ' { + U32 ix_$var; + EXTEND(SP,size_$var); + for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { + ST(ix_$var) = sv_newmortal(); + DO_ARRAY_ELEM + } + } +', + 'T_NV' => ' sv_setnv($arg, (NV)$var); +', + 'T_SHORT' => ' sv_setiv($arg, (IV)$var); +', + 'T_OPAQUE' => ' sv_setpvn($arg, (char *)&$var, sizeof($var)); +', + 'T_PTROBJ' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)$var); +', + 'T_HVREF' => ' $arg = newRV((SV*)$var); +', + 'T_PACKEDARRAY' => ' XS_pack_$ntype($arg, $var, count_$ntype); +', + 'T_INT' => ' sv_setiv($arg, (IV)$var); +', + 'T_OPAQUEPTR' => ' sv_setpvn($arg, (char *)$var, sizeof(*$var)); +', + 'T_BOOL' => ' $arg = boolSV($var); +', + 'T_REFREF' => ' NOT_IMPLEMENTED +', + 'T_REF_IV_REF' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new $ntype($var)); +', + 'T_STDIO' => ' { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_FLOAT' => ' sv_setnv($arg, (double)$var); +', + 'T_IN' => ' { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_PV' => ' sv_setpv((SV*)$arg, $var); +', + 'T_INOUT' => ' { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +', + 'T_CHAR' => ' sv_setpvn($arg, (char *)&$var, 1); +', + 'T_LONG' => ' sv_setiv($arg, (IV)$var); +', + 'T_DOUBLE' => ' sv_setnv($arg, (double)$var); +', + 'T_PTR' => ' sv_setiv($arg, PTR2IV($var)); +', + 'T_AVREF' => ' $arg = newRV((SV*)$var); +', + 'T_SV' => ' $arg = $var; +', + 'T_ENUM' => ' sv_setiv($arg, (IV)$var); +', + 'T_REFOBJ' => ' NOT IMPLEMENTED +', + 'T_CVREF' => ' $arg = newRV((SV*)$var); +', + 'T_UV' => ' sv_setuv($arg, (UV)$var); +', + 'T_PACKED' => ' XS_pack_$ntype($arg, $var); +', + 'T_SYSRET' => ' if ($var != -1) { + if ($var == 0) + sv_setpvn($arg, "0 but true", 10); + else + sv_setiv($arg, (IV)$var); + } +', + 'T_IV' => ' sv_setiv($arg, (IV)$var); +', + 'T_PTRDESC' => ' sv_setref_pv($arg, \\"${ntype}\\", (void*)new\\U${type}_DESC\\E($var)); +', + 'T_DATAUNIT' => ' sv_setpvn($arg, $var.chp(), $var.size()); +', + 'T_U_SHORT' => ' sv_setuv($arg, (UV)$var); +', + 'T_SVREF' => ' $arg = newRV((SV*)$var); +', + 'T_PTRREF' => ' sv_setref_pv($arg, Nullch, (void*)$var); +', +}; + +my %targetable; +%targetable = make_targetable($output_expr_ref); + +ok(! exists $targetable{'T_AVREF'}, + "Element found in 'output_expr' not found in \%targetable: not an 'sv_set'" ); + +ok(exists $targetable{'T_CALLBACK'}, + "Element found in 'output_expr' found in \%targetable as expected" ); + +pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/108-map_type.t b/dist/ExtUtils-ParseXS/t/108-map_type.t new file mode 100644 index 0000000000..ba08f6cb04 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/108-map_type.t @@ -0,0 +1,18 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More qw(no_plan); # tests => 7; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + map_type +); + +#print "\t" . map_type($self->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n" +#print "\t" . map_type($var_type, $var_name, $self->{hiertype}); +#print "\t" . map_type($var_type, undef, $self->{hiertype}); + +pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t b/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t new file mode 100644 index 0000000000..0cb7493f9d --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/109-standard_XS_defs.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl +use strict; +use warnings; +$| = 1; +use Test::More tests => 5; +use lib qw( lib t/lib ); +use ExtUtils::ParseXS::Utilities qw( + standard_XS_defs +); +use PrimitiveCapture; + +my @statements = ( + '#ifndef PERL_UNUSED_VAR', + '#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE', + '#ifdef PERL_IMPLICIT_CONTEXT', + '#ifdef newXS_flags', +); + +my $stdout = PrimitiveCapture::capture_stdout(sub { + standard_XS_defs(); +}); + +foreach my $s (@statements) { + like( $stdout, qr/$s/s, "Printed <$s>" ); +} + +pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/110-assign_func_args.t b/dist/ExtUtils-ParseXS/t/110-assign_func_args.t new file mode 100644 index 0000000000..63d978417b --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/110-assign_func_args.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More qw(no_plan); # tests => 7; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + assign_func_args +); + +#sub assign_func_args { +# my ($self, $argsref, $class) = @_; +# return join(", ", @func_args); + +my ($self, @args, $class); +my ($func_args, $expected); + +@args = qw( alpha beta gamma ); +$self->{in_out}->{alpha} = 'OUT'; +$expected = q|&alpha, beta, gamma|; +$func_args = assign_func_args($self, \@args, $class); +is( $func_args, $expected, + "Got expected func_args: in_out true; class undefined" ); + +@args = ( 'My::Class', qw( beta gamma ) ); +$self->{in_out}->{beta} = 'OUT'; +$class = 'My::Class'; +$expected = q|&beta, gamma|; +$func_args = assign_func_args($self, \@args, $class); +is( $func_args, $expected, + "Got expected func_args: in_out true; class defined" ); + +@args = ( 'My::Class', qw( beta gamma ) ); +$self->{in_out}->{beta} = ''; +$class = 'My::Class'; +$expected = q|beta, gamma|; +$func_args = assign_func_args($self, \@args, $class); +is( $func_args, $expected, + "Got expected func_args: in_out false; class defined" ); + +@args = qw( alpha beta gamma ); +$self->{in_out}->{alpha} = ''; +$class = undef; +$expected = q|alpha, beta, gamma|; +$func_args = assign_func_args($self, \@args, $class); +is( $func_args, $expected, + "Got expected func_args: in_out false; class undefined" ); + +pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t b/dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t new file mode 100644 index 0000000000..b9d6d73b41 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl +use strict; +use warnings; +$| = 1; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More qw(no_plan); # tests => 7; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + analyze_preprocessor_statements +); + +# ( $self, $XSS_work_idx, $BootCode_ref ) = +# analyze_preprocessor_statements( +# $self, $statement, $XSS_work_idx, $BootCode_ref +# ); + +pass("Passed all tests in $0"); + + diff --git a/dist/ExtUtils-ParseXS/t/112-set_cond.t b/dist/ExtUtils-ParseXS/t/112-set_cond.t new file mode 100644 index 0000000000..d6578776fd --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/112-set_cond.t @@ -0,0 +1,14 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More qw(no_plan); # tests => 7; +use lib qw( lib ); +use ExtUtils::ParseXS::Utilities qw( + set_cond +); + +pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t b/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t new file mode 100644 index 0000000000..55e3d4ba61 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/113-check_cond_preproc_statements.t @@ -0,0 +1,149 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More tests => 13; +use lib qw( lib t/lib ); +use ExtUtils::ParseXS; +use ExtUtils::ParseXS::Utilities qw( + check_conditional_preprocessor_statements +); +use PrimitiveCapture; + +my $self = bless({} => 'ExtUtils::ParseXS'); +$self->{line} = []; +$self->{XSStack} = []; +$self->{XSStack}->[0] = {}; + +{ + $self->{line} = [ + "#if this_is_an_if_statement", + "Alpha this is not an if/elif/elsif/endif", + "#elif this_is_an_elif_statement", + "Beta this is not an if/elif/elsif/endif", + "#else this_is_an_else_statement", + "Gamma this is not an if/elif/elsif/endif", + "#endif this_is_an_endif_statement", + ]; + $self->{line_no} = [ 17 .. 23 ]; + $self->{XSStack}->[-1]{type} = 'if'; + $self->{filename} = 'myfile1'; + + my $rv; + my $stderr = PrimitiveCapture::capture_stderr(sub { + $rv = check_conditional_preprocessor_statements($self); + }); + + is( $rv, 0, "Basic case: returned 0: all ifs resolved" ); + ok( ! $stderr, "No warnings captured, as expected" ); +} + +{ + $self->{line} = [ + "#if this_is_an_if_statement", + "Alpha this is not an if/elif/elsif/endif", + "#if this_is_a_different_if_statement", + "Beta this is not an if/elif/elsif/endif", + "#endif this_is_a_different_endif_statement", + "Gamma this is not an if/elif/elsif/endif", + "#endif this_is_an_endif_statement", + ]; + $self->{line_no} = [ 17 .. 23 ]; + $self->{XSStack}->[-1]{type} = 'if'; + $self->{filename} = 'myfile1'; + + my $rv; + my $stderr = PrimitiveCapture::capture_stderr(sub { + $rv = check_conditional_preprocessor_statements($self); + }); + is( $rv, 0, "One nested if case: returned 0: all ifs resolved" ); + ok( ! $stderr, "No warnings captured, as expected" ); +} + +{ + $self->{line} = [ + "Alpha this is not an if/elif/elsif/endif", + "#elif this_is_an_elif_statement", + "Beta this is not an if/elif/elsif/endif", + "#else this_is_an_else_statement", + "Gamma this is not an if/elif/elsif/endif", + "#endif this_is_an_endif_statement", + ]; + $self->{line_no} = [ 17 .. 22 ]; + $self->{XSStack}->[-1]{type} = 'if'; + $self->{filename} = 'myfile1'; + + my $rv; + my $stderr = PrimitiveCapture::capture_stderr(sub { + $rv = check_conditional_preprocessor_statements($self); + }); + is( $rv, undef, + "Missing 'if' case: returned undef: all ifs resolved" ); + like( $stderr, + qr/Warning: #else\/elif\/endif without #if in this function/, + "Got expected warning: lack of #if" + ); + like( $stderr, + qr/precede it with a blank line/s, + "Got expected warning: advice re blank line" + ); +} + +{ + $self->{line} = [ + "Alpha this is not an if/elif/elsif/endif", + "#elif this_is_an_elif_statement", + "Beta this is not an if/elif/elsif/endif", + "#else this_is_an_else_statement", + "Gamma this is not an if/elif/elsif/endif", + "#endif this_is_an_endif_statement", + ]; + $self->{line_no} = [ 17 .. 22 ]; + $self->{XSStack}->[-1]{type} = 'file'; + $self->{filename} = 'myfile1'; + + my $rv; + my $stderr = PrimitiveCapture::capture_stderr(sub { + $rv = check_conditional_preprocessor_statements($self); + }); + is( $rv, undef, + "Missing 'if' case: returned undef: all ifs resolved" ); + like( $stderr, + qr/Warning: #else\/elif\/endif without #if in this function/, + "Got expected warning: lack of #if" + ); + unlike( $stderr, + qr/precede it with a blank line/s, + "Did not get unexpected stderr" + ); +} + +{ + $self->{line} = [ + "#if this_is_an_if_statement", + "Alpha this is not an if/elif/elsif/endif", + "#elif this_is_an_elif_statement", + "Beta this is not an if/elif/elsif/endif", + "#else this_is_an_else_statement", + "Gamma this is not an if/elif/elsif/endif", + ]; + $self->{line_no} = [ 17 .. 22 ]; + $self->{XSStack}->[-1]{type} = 'if'; + $self->{filename} = 'myfile1'; + + my $rv; + my $stderr = PrimitiveCapture::capture_stderr(sub { + $rv = check_conditional_preprocessor_statements($self); + }); + isnt( $rv, 0, + "Missing 'endif' case: returned non-zero as expected" ); + like( $stderr, + qr/Warning: #if without #endif in this function/s, + "Got expected warning: lack of #endif" + ); +} + +pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t b/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t new file mode 100644 index 0000000000..955b29b65b --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/114-blurt_death_Warn.t @@ -0,0 +1,132 @@ +#!/usr/bin/perl +use strict; +use warnings; +$| = 1; +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw( tempdir ); +use Test::More tests => 7; +use lib qw( lib t/lib ); +use ExtUtils::ParseXS; +use ExtUtils::ParseXS::Utilities qw( + Warn + blurt + death +); +use PrimitiveCapture; + +my $self = bless({} => 'ExtUtils::ParseXS'); +$self->{line} = []; +$self->{line_no} = []; + +{ + $self->{line} = [ + 'Alpha', + 'Beta', + 'Gamma', + 'Delta', + ]; + $self->{line_no} = [ 17 .. 20 ]; + $self->{filename} = 'myfile1'; + + my $message = 'Warning: Ignoring duplicate alias'; + + my $stderr = PrimitiveCapture::capture_stderr(sub { + Warn( $self, $message); + }); + like( $stderr, + qr/$message in $self->{filename}, line 20/, + "Got expected Warn output", + ); +} + +{ + $self->{line} = [ + 'Alpha', + 'Beta', + 'Gamma', + 'Delta', + 'Epsilon', + ]; + $self->{line_no} = [ 17 .. 20 ]; + $self->{filename} = 'myfile2'; + + my $message = 'Warning: Ignoring duplicate alias'; + my $stderr = PrimitiveCapture::capture_stderr(sub { + Warn( $self, $message); + }); + like( $stderr, + qr/$message in $self->{filename}, line 19/, + "Got expected Warn output", + ); +} + +{ + $self->{line} = [ + 'Alpha', + 'Beta', + 'Gamma', + 'Delta', + ]; + $self->{line_no} = [ 17 .. 21 ]; + $self->{filename} = 'myfile1'; + + my $message = 'Warning: Ignoring duplicate alias'; + my $stderr = PrimitiveCapture::capture_stderr(sub { + Warn( $self, $message); + }); + like( $stderr, + qr/$message in $self->{filename}, line 17/, + "Got expected Warn output", + ); +} + +{ + $self->{line} = [ + 'Alpha', + 'Beta', + 'Gamma', + 'Delta', + ]; + $self->{line_no} = [ 17 .. 20 ]; + $self->{filename} = 'myfile1'; + $self->{errors} = 0; + + + my $message = 'Error: Cannot parse function definition'; + my $stderr = PrimitiveCapture::capture_stderr(sub { + blurt( $self, $message); + }); + like( $stderr, + qr/$message in $self->{filename}, line 20/, + "Got expected blurt output", + ); + is( $self->{errors}, 1, "Error count incremented correctly" ); +} + +SKIP: { + skip "death() not testable as long as it contains hard-coded 'exit'", 1; + + $self->{line} = [ + 'Alpha', + 'Beta', + 'Gamma', + 'Delta', + ]; + $self->{line_no} = [ 17 .. 20 ]; + $self->{filename} = 'myfile1'; + + my $message = "Code is not inside a function"; + eval { + my $stderr = PrimitiveCapture::capture_stderr(sub { + death( $self, $message); + }); + like( $stderr, + qr/$message in $self->{filename}, line 20/, + "Got expected death output", + ); + }; +} + +pass("Passed all tests in $0"); diff --git a/dist/ExtUtils-ParseXS/t/501-t-compile.t b/dist/ExtUtils-ParseXS/t/501-t-compile.t new file mode 100644 index 0000000000..5681cd2e22 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/501-t-compile.t @@ -0,0 +1,14 @@ +#!/usr/bin/perl +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +use Test::More tests => 2; + +# Check their perl version +ok( $] >= 5.006001, "Your perl is new enough" ); + +# Does the module load +use_ok( 'ExtUtils::Typemaps' ); diff --git a/dist/ExtUtils-ParseXS/t/510-t-bare.t b/dist/ExtUtils-ParseXS/t/510-t-bare.t new file mode 100644 index 0000000000..033c0aea5a --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/510-t-bare.t @@ -0,0 +1,160 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 43; +use ExtUtils::Typemaps; + +# empty typemap +SCOPE: { + ok(ExtUtils::Typemaps->new()->is_empty(), "This is an empty typemap"); +} + +# typemap only +SCOPE: { + my $map = ExtUtils::Typemaps->new(); + $map->add_typemap(ctype => 'unsigned int', xstype => 'T_IV'); + ok(!$map->is_empty(), "This is not an empty typemap"); + + is($map->as_string(), <<'HERE', "Simple typemap matches expectations"); +TYPEMAP +unsigned int T_IV +HERE + + my $type = $map->get_typemap(ctype => 'unsigned int'); + isa_ok($type, 'ExtUtils::Typemaps::Type'); + is($type->ctype, 'unsigned int'); + is($type->xstype, 'T_IV'); + is($type->tidy_ctype, 'unsigned int'); + + + # test failure + ok(!$map->get_typemap(ctype => 'foo'), "Access to nonexistent typemap doesn't die"); + ok(!$map->get_inputmap(ctype => 'foo'), "Access to nonexistent inputmap via ctype doesn't die"); + ok(!$map->get_outputmap(ctype => 'foo'), "Access to nonexistent outputmap via ctype doesn't die"); + ok(!$map->get_inputmap(xstype => 'foo'), "Access to nonexistent inputmap via xstype doesn't die"); + ok(!$map->get_outputmap(xstype => 'foo'), "Access to nonexistent outputmap via xstype doesn't die"); + ok(!eval{$map->get_typemap('foo')} && $@, "Access to typemap with positional params dies"); + ok(!eval{$map->get_inputmap('foo')} && $@, "Access to inputmap with positional params dies"); + ok(!eval{$map->get_outputmap('foo')} && $@, "Access to outputmap with positional params dies"); +} + +# typemap & input +SCOPE: { + my $map = ExtUtils::Typemaps->new(); + $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); + ok(!$map->is_empty(), "This is not an empty typemap"); + $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); + is($map->as_string(), <<'HERE', "Simple typemap (with input) matches expectations"); +TYPEMAP +unsigned int T_UV + +INPUT +T_UV + $var = ($type)SvUV($arg); +HERE + + my $type = $map->get_typemap(ctype => 'unsigned int'); + isa_ok($type, 'ExtUtils::Typemaps::Type'); + is($type->ctype, 'unsigned int'); + is($type->xstype, 'T_UV'); + is($type->tidy_ctype, 'unsigned int'); + + my $in = $map->get_inputmap(xstype => 'T_UV'); + isa_ok($in, 'ExtUtils::Typemaps::InputMap'); + is($in->xstype, 'T_UV'); + + # test fetching inputmap by ctype + my $in2 = $map->get_inputmap(ctype => 'unsigned int'); + is_deeply($in2, $in, "get_inputmap returns the same typemap for ctype and xstype"); +} + + +# typemap & output +SCOPE: { + my $map = ExtUtils::Typemaps->new(); + $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); + ok(!$map->is_empty(), "This is not an empty typemap"); + $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); + is($map->as_string(), <<'HERE', "Simple typemap (with output) matches expectations"); +TYPEMAP +unsigned int T_UV + +OUTPUT +T_UV + sv_setuv($arg, (UV)$var); +HERE + + my $type = $map->get_typemap(ctype => 'unsigned int'); + isa_ok($type, 'ExtUtils::Typemaps::Type'); + is($type->ctype, 'unsigned int'); + is($type->xstype, 'T_UV'); + is($type->tidy_ctype, 'unsigned int'); + + my $in = $map->get_outputmap(xstype => 'T_UV'); + isa_ok($in, 'ExtUtils::Typemaps::OutputMap'); + is($in->xstype, 'T_UV'); +} + +# typemap & input & output +SCOPE: { + my $map = ExtUtils::Typemaps->new(); + $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); + $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); + $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); + ok(!$map->is_empty(), "This is not an empty typemap"); + is($map->as_string(), <<'HERE', "Simple typemap (with in- & output) matches expectations"); +TYPEMAP +unsigned int T_UV + +INPUT +T_UV + $var = ($type)SvUV($arg); + +OUTPUT +T_UV + sv_setuv($arg, (UV)$var); +HERE +} + +# two typemaps & input & output +SCOPE: { + my $map = ExtUtils::Typemaps->new(); + $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); + $map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); + $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); + + $map->add_typemap(ctype => 'int', xstype => 'T_IV'); + $map->add_inputmap(xstype => 'T_IV', code => '$var = ($type)SvIV($arg);'); + $map->add_outputmap(xstype => 'T_IV', code => 'sv_setiv($arg, (IV)$var);'); + is($map->as_string(), <<'HERE', "Simple typemap (with in- & output) matches expectations"); +TYPEMAP +unsigned int T_UV +int T_IV + +INPUT +T_UV + $var = ($type)SvUV($arg); +T_IV + $var = ($type)SvIV($arg); + +OUTPUT +T_UV + sv_setuv($arg, (UV)$var); +T_IV + sv_setiv($arg, (IV)$var); +HERE + my $type = $map->get_typemap(ctype => 'unsigned int'); + isa_ok($type, 'ExtUtils::Typemaps::Type'); + is($type->ctype, 'unsigned int'); + is($type->xstype, 'T_UV'); + is($type->tidy_ctype, 'unsigned int'); + + my $in = $map->get_outputmap(xstype => 'T_UV'); + isa_ok($in, 'ExtUtils::Typemaps::OutputMap'); + is($in->xstype, 'T_UV'); + $in = $map->get_outputmap(xstype => 'T_IV'); + isa_ok($in, 'ExtUtils::Typemaps::OutputMap'); + is($in->xstype, 'T_IV'); +} + diff --git a/dist/ExtUtils-ParseXS/t/511-t-whitespace.t b/dist/ExtUtils-ParseXS/t/511-t-whitespace.t new file mode 100644 index 0000000000..003d7e5378 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/511-t-whitespace.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 2; +use ExtUtils::Typemaps; + +SCOPE: { + my $map = ExtUtils::Typemaps->new(); + $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); + $map->add_inputmap(xstype => 'T_UV', code => ' $var = ($type)SvUV($arg);'); + is($map->as_string(), <<'HERE', "Simple typemap (with input and code including leading whitespace) matches expectations"); +TYPEMAP +unsigned int T_UV + +INPUT +T_UV + $var = ($type)SvUV($arg); +HERE +} + + +SCOPE: { + my $map = ExtUtils::Typemaps->new(); + $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); + $map->add_inputmap(xstype => 'T_UV', code => " \$var =\n(\$type)\n SvUV(\$arg);"); + is($map->as_string(), <<'HERE', "Simple typemap (with input and multi-line code) matches expectations"); +TYPEMAP +unsigned int T_UV + +INPUT +T_UV + $var = + ($type) + SvUV($arg); +HERE +} + diff --git a/dist/ExtUtils-ParseXS/t/512-t-file.t b/dist/ExtUtils-ParseXS/t/512-t-file.t new file mode 100644 index 0000000000..3bf1addf26 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/512-t-file.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 6; +use ExtUtils::Typemaps; +use File::Spec; +use File::Temp; + +my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; + +sub slurp { + my $file = shift; + open my $fh, '<', $file + or die "Cannot open file '$file' for reading: $!"; + local $/ = undef; + return <$fh>; +} + +my $cmp_typemap_file = File::Spec->catfile($datadir, 'simple.typemap'); +my $cmp_typemap_str = slurp($cmp_typemap_file); + +my $map = ExtUtils::Typemaps->new(); +$map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV'); +$map->add_inputmap(xstype => 'T_UV', code => '$var = ($type)SvUV($arg);'); +$map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);'); +$map->add_typemap(ctype => 'int', xstype => 'T_IV'); +$map->add_inputmap(xstype => 'T_IV', code => '$var = ($type)SvIV($arg);'); +$map->add_outputmap(xstype => 'T_IV', code => 'sv_setiv($arg, (IV)$var);'); + +is($map->as_string(), $cmp_typemap_str, "Simple typemap matches reference file"); + +my $tmpdir = File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1); +my $tmpfile = File::Spec->catdir($tmpdir, 'simple.typemap'); + +$map->write(file => $tmpfile); +is($map->as_string(), slurp($tmpfile), "Simple typemap write matches as_string"); +is(ExtUtils::Typemaps->new(file => $cmp_typemap_file)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips"); +is(ExtUtils::Typemaps->new(file => $tmpfile)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips (2)"); + +SCOPE: { + local $map->{file} = $cmp_typemap_file; + is_deeply(ExtUtils::Typemaps->new(file => $cmp_typemap_file), $map, "Simple typemap roundtrips (in memory)"); +} + +# test that we can also create them from a string +my $map_from_str = ExtUtils::Typemaps->new(string => $map->as_string()); +is_deeply($map_from_str, $map); + diff --git a/dist/ExtUtils-ParseXS/t/513-t-merge.t b/dist/ExtUtils-ParseXS/t/513-t-merge.t new file mode 100644 index 0000000000..72d948fce2 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/513-t-merge.t @@ -0,0 +1,116 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More tests => 19; +use ExtUtils::Typemaps; +use File::Spec; +use File::Temp; + +my $datadir = -d 't' ? File::Spec->catdir(qw/t data/) : 'data'; + +sub slurp { + my $file = shift; + open my $fh, '<', $file + or die "Cannot open file '$file' for reading: $!"; + local $/ = undef; + return <$fh>; +} + +my $first_typemap_file = File::Spec->catfile($datadir, 'simple.typemap'); +my $second_typemap_file = File::Spec->catfile($datadir, 'other.typemap'); +my $combined_typemap_file = File::Spec->catfile($datadir, 'combined.typemap'); +my $conflicting_typemap_file = File::Spec->catfile($datadir, 'conflicting.typemap'); +my $confl_replace_typemap_file = File::Spec->catfile($datadir, 'confl_repl.typemap'); +my $confl_skip_typemap_file = File::Spec->catfile($datadir, 'confl_skip.typemap'); + +# test merging two typemaps +SCOPE: { + my $first = ExtUtils::Typemaps->new(file => $first_typemap_file); + isa_ok($first, 'ExtUtils::Typemaps'); + my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); + isa_ok($second, 'ExtUtils::Typemaps'); + + $first->merge(typemap => $second); + + is($first->as_string(), slurp($combined_typemap_file), "merging produces expected output"); +} + +# test merging a typemap from file +SCOPE: { + my $first = ExtUtils::Typemaps->new(file => $first_typemap_file); + isa_ok($first, 'ExtUtils::Typemaps'); + + $first->merge(file => $second_typemap_file); + + is($first->as_string(), slurp($combined_typemap_file), "merging produces expected output"); +} + + +# test merging a typemap as string +SCOPE: { + my $first = ExtUtils::Typemaps->new(file => $first_typemap_file); + isa_ok($first, 'ExtUtils::Typemaps'); + my $second_str = slurp($second_typemap_file); + + $first->add_string(string => $second_str); + + is($first->as_string(), slurp($combined_typemap_file), "merging (string) produces expected output"); +} + +# test merging a conflicting typemap without "replace" +SCOPE: { + my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); + isa_ok($second, 'ExtUtils::Typemaps'); + my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file); + isa_ok($conflict, 'ExtUtils::Typemaps'); + + ok( + !eval { + $second->merge(typemap => $conflict); + 1; + }, + "Merging conflicting typemap croaks" + ); + ok( + $@ =~ /Multiple definition/, + "Conflicting typemap error as expected" + ); +} + +# test merging a conflicting typemap with "replace" +SCOPE: { + my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); + isa_ok($second, 'ExtUtils::Typemaps'); + my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file); + isa_ok($conflict, 'ExtUtils::Typemaps'); + + ok( + eval { + $second->merge(typemap => $conflict, replace => 1); + 1; + }, + "Conflicting typemap merge with 'replace' doesn't croak" + ); + + is($second->as_string(), slurp($confl_replace_typemap_file), "merging (string) produces expected output"); +} + +# test merging a conflicting typemap file with "skip" +SCOPE: { + my $second = ExtUtils::Typemaps->new(file => $second_typemap_file); + isa_ok($second, 'ExtUtils::Typemaps'); + my $conflict = ExtUtils::Typemaps->new(file => $conflicting_typemap_file); + isa_ok($conflict, 'ExtUtils::Typemaps'); + + ok( + eval { + $second->merge(typemap => $conflict, skip => 1); + 1; + }, + "Conflicting typemap merge with 'skip' doesn't croak" + ); + + is($second->as_string(), slurp($confl_skip_typemap_file), "merging (string) produces expected output"); +} + diff --git a/dist/ExtUtils-ParseXS/t/600-t-compat.t b/dist/ExtUtils-ParseXS/t/600-t-compat.t new file mode 100644 index 0000000000..abb99f8fd9 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/600-t-compat.t @@ -0,0 +1,182 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Test::More; + +# This test is for making sure that the new EU::Typemaps +# based typemap merging produces the same result as the old +# EU::ParseXS code. + +use ExtUtils::Typemaps; +use ExtUtils::ParseXS::Utilities qw( + C_string + tidy_type + trim_whitespace + process_typemaps +); +use ExtUtils::ParseXS::Constants; +use File::Spec; + +my $path_prefix = File::Spec->catdir(-d 't' ? qw(t data) : qw(data)); + +my @tests = ( + { + name => 'Simple conflict', + local_maps => [ + File::Spec->catdir($path_prefix, "conflicting.typemap"), + ], + std_maps => [ + File::Spec->catdir($path_prefix, "other.typemap"), + ], + }, + { + name => 'B', + local_maps => [ + File::Spec->catdir($path_prefix, "b.typemap"), + ], + std_maps => [], + }, + { + name => 'B and perl', + local_maps => [ + File::Spec->catdir($path_prefix, "b.typemap"), + ], + std_maps => [ + File::Spec->catdir($path_prefix, "perl.typemap"), + ], + }, + { + name => 'B and perl and B again', + local_maps => [ + File::Spec->catdir($path_prefix, "b.typemap"), + ], + std_maps => [ + File::Spec->catdir($path_prefix, "perl.typemap"), + File::Spec->catdir($path_prefix, "b.typemap"), + ], + }, +); +plan tests => scalar(@tests); + +my @local_tmaps; +my @standard_typemap_locations; +SCOPE: { + no warnings 'redefine'; + sub ExtUtils::ParseXS::Utilities::standard_typemap_locations { + @standard_typemap_locations; + } + sub standard_typemap_locations { + @standard_typemap_locations; + } +} + +foreach my $test (@tests) { + @local_tmaps = @{ $test->{local_maps} }; + @standard_typemap_locations = @{ $test->{std_maps} }; + + my $res = [_process_typemaps([@local_tmaps], '.')]; + my $tm = process_typemaps([@local_tmaps], '.'); + my $res_new = [map $tm->$_(), qw(_get_typemap_hash _get_prototype_hash _get_inputmap_hash _get_outputmap_hash) ]; + + # Normalize trailing whitespace. Let's be that lenient, mkay? + for ($res, $res_new) { + for ($_->[2], $_->[3]) { + for (values %$_) { + s/\s+\z//; + } + } + } + #use Data::Dumper; warn Dumper $res; + #use Data::Dumper; warn Dumper $res_new; + + is_deeply($res_new, $res, "typemap equivalency for '$test->{name}'"); +} + + +# The code below is a reproduction of what the pre-ExtUtils::Typemap +# typemap-parsing/handling code in ExtUtils::ParseXS looked like. For +# bug-compatibility, we want to produce the same data structures as that +# code as much as possible. +sub _process_typemaps { + my ($tmap, $pwd) = @_; + + my @tm = ref $tmap ? @{$tmap} : ($tmap); + + foreach my $typemap (@tm) { + die "Can't find $typemap in $pwd\n" unless -r $typemap; + } + + push @tm, standard_typemap_locations( \@INC ); + + my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) + = ( {}, {}, {}, {} ); + + foreach my $typemap (@tm) { + next unless -f $typemap; + # skip directories, binary files etc. + warn("Warning: ignoring non-text typemap file '$typemap'\n"), next + unless -T $typemap; + ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = + _process_single_typemap( $typemap, + $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); + } + return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); +} + +sub _process_single_typemap { + my ($typemap, + $type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) = @_; + open my $TYPEMAP, '<', $typemap + or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; + my $mode = 'Typemap'; + my $junk = ""; + my $current = \$junk; + while (<$TYPEMAP>) { + # skip comments + next if /^\s*#/; + if (/^INPUT\s*$/) { + $mode = 'Input'; $current = \$junk; next; + } + if (/^OUTPUT\s*$/) { + $mode = 'Output'; $current = \$junk; next; + } + if (/^TYPEMAP\s*$/) { + $mode = 'Typemap'; $current = \$junk; next; + } + if ($mode eq 'Typemap') { + chomp; + my $logged_line = $_; + trim_whitespace($_); + # skip blank lines + next if /^$/; + my($type,$kind, $proto) = + m/^\s*(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)\s*$/ + or warn( + "Warning: File '$typemap' Line $. '$logged_line' " . + "TYPEMAP entry needs 2 or 3 columns\n" + ), + next; + $type = tidy_type($type); + $type_kind_ref->{$type} = $kind; + # prototype defaults to '$' + $proto = "\$" unless $proto; + $proto_letter_ref->{$type} = C_string($proto); + } + elsif (/^\s/) { + $$current .= $_; + } + elsif ($mode eq 'Input') { + s/\s+$//; + $input_expr_ref->{$_} = ''; + $current = \$input_expr_ref->{$_}; + } + else { + s/\s+$//; + $output_expr_ref->{$_} = ''; + $current = \$output_expr_ref->{$_}; + } + } + close $TYPEMAP; + return ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref); +} diff --git a/dist/ExtUtils-ParseXS/t/XSMore.xs b/dist/ExtUtils-ParseXS/t/XSMore.xs index 0777f89eac..d0a1f3cabe 100644 --- a/dist/ExtUtils-ParseXS/t/XSMore.xs +++ b/dist/ExtUtils-ParseXS/t/XSMore.xs @@ -2,6 +2,12 @@ #include "perl.h" #include "XSUB.h" +typedef IV MyType; +typedef IV MyType2; +typedef IV MyType3; +typedef IV MyType4; + + =for testing This parts are ignored. @@ -42,6 +48,53 @@ BOOT: sv_setiv(get_sv("XSMore::boot_ok", TRUE), 100); +TYPEMAP: <<END +MyType T_IV +END + +TYPEMAP: <<" FOO BAR BAZ"; +MyType2 T_FOOOO + +OUTPUT +T_FOOOO + sv_setiv($arg, (IV)$var); + FOO BAR BAZ + +TYPEMAP: <<'END' +MyType3 T_BAAR +MyType4 T_BAAR + +OUTPUT +T_BAAR + sv_setiv($arg, (IV)$var); + +INPUT +T_BAAR + $var = ($type)SvIV($arg) +END + + +MyType +typemaptest1() + CODE: + RETVAL = 42; + OUTPUT: + RETVAL + +MyType2 +typemaptest2() + CODE: + RETVAL = 42; + OUTPUT: + RETVAL + +MyType3 +typemaptest3(MyType4 foo) + CODE: + RETVAL = foo; + OUTPUT: + RETVAL + void prototype_ssa() PROTOTYPE: $$@ diff --git a/dist/ExtUtils-ParseXS/t/data/b.typemap b/dist/ExtUtils-ParseXS/t/data/b.typemap new file mode 100644 index 0000000000..5e342749d2 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/b.typemap @@ -0,0 +1,88 @@ +TYPEMAP + +B::OP T_OP_OBJ +B::UNOP T_OP_OBJ +B::BINOP T_OP_OBJ +B::LOGOP T_OP_OBJ +B::LISTOP T_OP_OBJ +B::PMOP T_OP_OBJ +B::SVOP T_OP_OBJ +B::PADOP T_OP_OBJ +B::PVOP T_OP_OBJ +B::LOOP T_OP_OBJ +B::COP T_OP_OBJ + +B::SV T_SV_OBJ +B::PV T_SV_OBJ +B::IV T_SV_OBJ +B::NV T_SV_OBJ +B::PVMG T_SV_OBJ +B::REGEXP T_SV_OBJ +B::PVLV T_SV_OBJ +B::BM T_SV_OBJ +B::RV T_SV_OBJ +B::GV T_SV_OBJ +B::CV T_SV_OBJ +B::HV T_SV_OBJ +B::AV T_SV_OBJ +B::IO T_SV_OBJ +B::FM T_SV_OBJ + +B::MAGIC T_MG_OBJ +SSize_t T_IV +STRLEN T_UV +PADOFFSET T_UV + +B::HE T_HE_OBJ +B::RHE T_RHE_OBJ + +INPUT +T_OP_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + +T_SV_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + +T_MG_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + +T_HE_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + +T_RHE_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + +OUTPUT +T_MG_OBJ + sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); + +T_HE_OBJ + sv_setiv(newSVrv($arg, "B::HE"), PTR2IV($var)); + +T_RHE_OBJ + sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var)); diff --git a/dist/ExtUtils-ParseXS/t/data/combined.typemap b/dist/ExtUtils-ParseXS/t/data/combined.typemap new file mode 100644 index 0000000000..6a1d776450 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/combined.typemap @@ -0,0 +1,20 @@ +TYPEMAP +unsigned int T_UV +int T_IV +double T_NV + +INPUT +T_UV + $var = ($type)SvUV($arg); +T_IV + $var = ($type)SvIV($arg); +T_NV + $var = ($type)SvNV($arg); + +OUTPUT +T_UV + sv_setuv($arg, (UV)$var); +T_IV + sv_setiv($arg, (IV)$var); +T_NV + sv_setnv($arg, (NV)$var); diff --git a/dist/ExtUtils-ParseXS/t/data/confl_repl.typemap b/dist/ExtUtils-ParseXS/t/data/confl_repl.typemap new file mode 100644 index 0000000000..4aecbe8e1b --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/confl_repl.typemap @@ -0,0 +1,12 @@ +TYPEMAP +double T_DIFFERENT + +INPUT +T_NV + $var = ($type)SvNV($arg); +T_DIFFERENT + $var = ($type)SvNV($arg); + +OUTPUT +T_NV + sv_setnv($arg, (NV)$var); diff --git a/dist/ExtUtils-ParseXS/t/data/confl_skip.typemap b/dist/ExtUtils-ParseXS/t/data/confl_skip.typemap new file mode 100644 index 0000000000..f56dc7057a --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/confl_skip.typemap @@ -0,0 +1,12 @@ +TYPEMAP +double T_NV + +INPUT +T_NV + $var = ($type)SvNV($arg); +T_DIFFERENT + $var = ($type)SvNV($arg); + +OUTPUT +T_NV + sv_setnv($arg, (NV)$var); diff --git a/dist/ExtUtils-ParseXS/t/data/conflicting.typemap b/dist/ExtUtils-ParseXS/t/data/conflicting.typemap new file mode 100644 index 0000000000..3edee2d1a1 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/conflicting.typemap @@ -0,0 +1,6 @@ +TYPEMAP +double T_DIFFERENT + +INPUT +T_DIFFERENT + $var = ($type)SvNV($arg); diff --git a/dist/ExtUtils-ParseXS/t/data/other.typemap b/dist/ExtUtils-ParseXS/t/data/other.typemap new file mode 100644 index 0000000000..c7e306bf9f --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/other.typemap @@ -0,0 +1,10 @@ +TYPEMAP +double T_NV + +INPUT +T_NV + $var = ($type)SvNV($arg); + +OUTPUT +T_NV + sv_setnv($arg, (NV)$var); diff --git a/dist/ExtUtils-ParseXS/t/data/perl.typemap b/dist/ExtUtils-ParseXS/t/data/perl.typemap new file mode 100644 index 0000000000..c88238a48d --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/perl.typemap @@ -0,0 +1,360 @@ +# basic C types +int T_IV +unsigned T_UV +unsigned int T_UV +long T_IV +unsigned long T_UV +short T_IV +unsigned short T_UV +char T_CHAR +unsigned char T_U_CHAR +char * T_PV +unsigned char * T_PV +const char * T_PV +caddr_t T_PV +wchar_t * T_PV +wchar_t T_IV +# bool_t is defined in <rpc/rpc.h> +bool_t T_IV +size_t T_UV +ssize_t T_IV +time_t T_NV +unsigned long * T_OPAQUEPTR +char ** T_PACKEDARRAY +void * T_PTR +Time_t * T_PV +SV * T_SV +SVREF T_SVREF +AV * T_AVREF +HV * T_HVREF +CV * T_CVREF + +IV T_IV +UV T_UV +NV T_NV +I32 T_IV +I16 T_IV +I8 T_IV +STRLEN T_UV +U32 T_U_LONG +U16 T_U_SHORT +U8 T_UV +Result T_U_CHAR +Boolean T_BOOL +float T_FLOAT +double T_DOUBLE +SysRet T_SYSRET +SysRetLong T_SYSRET +FILE * T_STDIO +PerlIO * T_INOUT +FileHandle T_PTROBJ +InputStream T_IN +InOutStream T_INOUT +OutputStream T_OUT +bool T_BOOL + +############################################################################# +INPUT +T_SV + $var = $arg +T_SVREF + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv)){ + $var = SvRV(xsub_tmp_sv); + } + else{ + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_AVREF + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){ + $var = (AV*)SvRV(xsub_tmp_sv); + } + else{ + Perl_croak(aTHX_ \"%s: %s is not an ARRAY reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_HVREF + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){ + $var = (HV*)SvRV(xsub_tmp_sv); + } + else{ + Perl_croak(aTHX_ \"%s: %s is not a HASH reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_CVREF + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVCV){ + $var = (CV*)SvRV(xsub_tmp_sv); + } + else{ + Perl_croak(aTHX_ \"%s: %s is not a CODE reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_SYSRET + $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) +T_IV + $var = ($type)SvIV($arg) +T_INT + $var = (int)SvIV($arg) +T_ENUM + $var = ($type)SvIV($arg) +T_BOOL + $var = (bool)SvTRUE($arg) +T_U_INT + $var = (unsigned int)SvUV($arg) +T_SHORT + $var = (short)SvIV($arg) +T_U_SHORT + $var = (unsigned short)SvUV($arg) +T_LONG + $var = (long)SvIV($arg) +T_U_LONG + $var = (unsigned long)SvUV($arg) +T_CHAR + $var = (char)*SvPV_nolen($arg) +T_U_CHAR + $var = (unsigned char)SvUV($arg) +T_FLOAT + $var = (float)SvNV($arg) +T_NV + $var = ($type)SvNV($arg) +T_DOUBLE + $var = (double)SvNV($arg) +T_PV + $var = ($type)SvPV_nolen($arg) +T_PTR + $var = INT2PTR($type,SvIV($arg)) +T_PTRREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_REF_IV_REF + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type *, tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_REF_IV_PTR + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_PTROBJ + if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_PTRDESC + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + ${type}_desc = (\U${type}_DESC\E*) tmp; + $var = ${type}_desc->ptr; + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_REFREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_REFOBJ + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_OPAQUE + $var = *($type *)SvPV_nolen($arg) +T_OPAQUEPTR + $var = ($type)SvPV_nolen($arg) +T_PACKED + $var = XS_unpack_$ntype($arg) +T_PACKEDARRAY + $var = XS_unpack_$ntype($arg) +T_CALLBACK + $var = make_perl_cb_$type($arg) +T_ARRAY + U32 ix_$var = $argoff; + $var = $ntype(items -= $argoff); + while (items--) { + DO_ARRAY_ELEM; + ix_$var++; + } + /* this is the number of elements in the array */ + ix_$var -= $argoff +T_STDIO + $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) +T_IN + $var = IoIFP(sv_2io($arg)) +T_INOUT + $var = IoIFP(sv_2io($arg)) +T_OUT + $var = IoOFP(sv_2io($arg)) +############################################################################# +OUTPUT +T_SV + $arg = $var; +T_SVREF + $arg = newRV((SV*)$var); +T_AVREF + $arg = newRV((SV*)$var); +T_HVREF + $arg = newRV((SV*)$var); +T_CVREF + $arg = newRV((SV*)$var); +T_IV + sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); +T_INT + sv_setiv($arg, (IV)$var); +T_SYSRET + if ($var != -1) { + if ($var == 0) + sv_setpvn($arg, "0 but true", 10); + else + sv_setiv($arg, (IV)$var); + } +T_ENUM + sv_setiv($arg, (IV)$var); +T_BOOL + $arg = boolSV($var); +T_U_INT + sv_setuv($arg, (UV)$var); +T_SHORT + sv_setiv($arg, (IV)$var); +T_U_SHORT + sv_setuv($arg, (UV)$var); +T_LONG + sv_setiv($arg, (IV)$var); +T_U_LONG + sv_setuv($arg, (UV)$var); +T_CHAR + sv_setpvn($arg, (char *)&$var, 1); +T_U_CHAR + sv_setuv($arg, (UV)$var); +T_FLOAT + sv_setnv($arg, (double)$var); +T_NV + sv_setnv($arg, (NV)$var); +T_DOUBLE + sv_setnv($arg, (double)$var); +T_PV + sv_setpv((SV*)$arg, $var); +T_PTR + sv_setiv($arg, PTR2IV($var)); +T_PTRREF + sv_setref_pv($arg, Nullch, (void*)$var); +T_REF_IV_REF + sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); +T_REF_IV_PTR + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTROBJ + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTRDESC + sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); +T_REFREF + NOT_IMPLEMENTED +T_REFOBJ + NOT IMPLEMENTED +T_OPAQUE + sv_setpvn($arg, (char *)&$var, sizeof($var)); +T_OPAQUEPTR + sv_setpvn($arg, (char *)$var, sizeof(*$var)); +T_PACKED + XS_pack_$ntype($arg, $var); +T_PACKEDARRAY + XS_pack_$ntype($arg, $var, count_$ntype); +T_DATAUNIT + sv_setpvn($arg, $var.chp(), $var.size()); +T_CALLBACK + sv_setpvn($arg, $var.context.value().chp(), + $var.context.value().size()); +T_ARRAY + { + U32 ix_$var; + EXTEND(SP,size_$var); + for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { + ST(ix_$var) = sv_newmortal(); + DO_ARRAY_ELEM + } + } +T_STDIO + { + GV *gv = newGVgen("$Package"); + PerlIO *fp = PerlIO_importFILE($var,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_IN + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_INOUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } +T_OUT + { + GV *gv = newGVgen("$Package"); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + else + $arg = &PL_sv_undef; + } diff --git a/dist/ExtUtils-ParseXS/t/data/simple.typemap b/dist/ExtUtils-ParseXS/t/data/simple.typemap new file mode 100644 index 0000000000..1c4556876e --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/data/simple.typemap @@ -0,0 +1,15 @@ +TYPEMAP +unsigned int T_UV +int T_IV + +INPUT +T_UV + $var = ($type)SvUV($arg); +T_IV + $var = ($type)SvIV($arg); + +OUTPUT +T_UV + sv_setuv($arg, (UV)$var); +T_IV + sv_setiv($arg, (IV)$var); diff --git a/dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm b/dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm new file mode 100644 index 0000000000..aa873d4d4f --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/lib/PrimitiveCapture.pm @@ -0,0 +1,33 @@ +package PrimitiveCapture; +use strict; +use warnings; + +sub capture_stdout { + my $sub = shift; + my $stdout; + open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; + close STDOUT; + open STDOUT, '>', \$stdout or die "Can't open STDOUT: $!"; + + $sub->(); + + close STDOUT; + open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!"; + return $stdout; +} + +sub capture_stderr { + my $sub = shift; + my $stderr; + open my $olderr, ">&STDERR" or die "Can't dup STDERR: $!"; + close STDERR; + open STDERR, '>', \$stderr or die "Can't open STDERR: $!"; + + $sub->(); + + close STDERR; + open STDERR, ">&", $olderr or die "Can't dup \$olderr: $!"; + return $stderr; +} + +1; diff --git a/dist/ExtUtils-ParseXS/t/pseudotypemap1 b/dist/ExtUtils-ParseXS/t/pseudotypemap1 new file mode 100644 index 0000000000..de771bd279 --- /dev/null +++ b/dist/ExtUtils-ParseXS/t/pseudotypemap1 @@ -0,0 +1,5 @@ + # pseudotypemap1: comment with leading whitespace +TYPEMAP + +line_to_generate_insufficient_columns_warning +unsigned long T_UV diff --git a/ext/I18N-Langinfo/Langinfo.pm b/ext/I18N-Langinfo/Langinfo.pm index a3bf3b58e5..db303592ef 100644 --- a/ext/I18N-Langinfo/Langinfo.pm +++ b/ext/I18N-Langinfo/Langinfo.pm @@ -72,7 +72,7 @@ our @EXPORT_OK = qw( YESSTR ); -our $VERSION = '0.08'; +our $VERSION = '0.08_02'; XSLoader::load(); diff --git a/lib/.gitignore b/lib/.gitignore index 43939bc963..75022003f5 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -171,6 +171,10 @@ /ExtUtils/Mksymlists.pm /ExtUtils/Packlist.pm /ExtUtils/ParseXS.pm +/ExtUtils/ParseXS.pod +/ExtUtils/ParseXS/ +/ExtUtils/Typemaps.pm +/ExtUtils/Typemaps/ /ExtUtils/testlib.pm /ExtUtils/xsubpp /Fatal.pm diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 723914cd06..69677bb19e 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -145,6 +145,26 @@ XXX =item * +L<ExtUtils::ParseXS> has been upgraded from version XXX to version XXX. + +Much of L<ExtUtils::ParseXS>, the module behind the XS compiler C<xsubpp>, +was rewritten and cleaned up. It has been made somewhat more extensible +and now finally uses strictures. + +The logic for parsing, merging, and dumping XS typemaps was extracted +from C<ExtUtils::ParseXS> into a module of its own, L<ExtUtils::Typemaps>. +C<ExtUtils::Typemaps> offers an interface to typemap handling outside of +the scope of the XS compiler itself. + +As a first use case of the improved API an extensibility, typemaps can now +be included inline into XS code with a HEREDOC-like syntax: + + TYPEMAP: <<END_TYPEMAP + MyType T_IV + END_TYPEMAP + +=item * + L<CGI> has been upgraded from version 3.54 to version 3.55 [THINGS THAT MAY BREAK YOUR CODE] @@ -305,6 +325,10 @@ section. XXX Description of the change here +=item * + +L<perlxs> was extended with documentation on inline typemaps. + =back =head1 Diagnostics diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 1eccb49efc..e5077a8240 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -540,6 +540,25 @@ not care about its initial contents. OUTPUT: timep +=head2 The TYPEMAP: Keyword + +Starting with Perl 5.16, you can embed typemaps into your XS code +instead of or in addition to typemaps in a separate file. Multiple +such embedded typemaps will be processed in order of appearance in +the XS code and like local typemap files take precendence over the +default typemap, the embedded typemaps may overwrite previous +definitions of TYPEMAP, INPUT, and OUTPUT stanzas. The syntax for +embedded typemaps is + + TYPEMAP: <<HERE + ... your typemap code here ... + HERE + +where the C<TYPEMAP> keyword must appear in the first column of a +new line. + +Refer to the section on L<The Typemap> for details on writing typemaps. + =head2 Initializing Function Parameters C function parameters are normally initialized with their values from @@ -1823,7 +1842,10 @@ contains many useful types which can be used by Perl extensions. Some extensions define additional typemaps which they keep in their own directory. These additional typemaps may reference INPUT and OUTPUT maps in the main typemap. The B<xsubpp> compiler will allow the extension's own typemap to -override any mappings which are in the default typemap. +override any mappings which are in the default typemap. Instead of using +an additional F<typemap> file, typemaps may be embedded verbatim in XS +with a heredoc-like syntax. See the documentation on the C<TYPEMAP:> XS +keyword. Most extensions which require a custom typemap will need only the TYPEMAP section of the typemap file. The custom typemap used in the |