Extract typemap-related code from ExtUtils::ParseXS
authorSteffen Mueller <smueller@cpan.org>
Thu, 10 Feb 2011 12:51:54 +0000 (13:51 +0100)
committerSteffen Mueller <smueller@cpan.org>
Tue, 12 Jul 2011 18:54:47 +0000 (20:54 +0200)
This was available from CPAN a while ago. The plan is to use it to make
the typemap parsing and manipulation saner and rip the parser from
ExtUtils::ParseXS' dead claws.

13 files changed:
MANIFEST
dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap.pm [new file with mode: 0644]
dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/InputMap.pm [new file with mode: 0644]
dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/OutputMap.pm [new file with mode: 0644]
dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/Type.pm [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/501-t-compile.t [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/510-t-bare.t [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/511-t-whitespace.t [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/512-t-file.t [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/513-t-merge.t [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/data/combined.typemap [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/data/other.typemap [new file with mode: 0644]
dist/ExtUtils-ParseXS/t/data/simple.typemap [new file with mode: 0644]

index a6defc7..9572c7d 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2977,6 +2977,10 @@ 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/Typemap/InputMap.pm         ExtUtils::Typemap guts
+dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/OutputMap.pm                ExtUtils::Typemap guts
+dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap.pm                  ExtUtils::Typemap, a PXS helper
+dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/Type.pm             ExtUtils::Typemap 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
@@ -2996,6 +3000,14 @@ dist/ExtUtils-ParseXS/t/111-analyze_preprocessor_statements.t    ExtUtils::ParseXS
 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::Typemap tests
+dist/ExtUtils-ParseXS/t/510-t-bare.t                           ExtUtils::Typemap tests
+dist/ExtUtils-ParseXS/t/511-t-whitespace.t                     ExtUtils::Typemap tests
+dist/ExtUtils-ParseXS/t/512-t-file.t                           ExtUtils::Typemap tests
+dist/ExtUtils-ParseXS/t/513-t-merge.t                          ExtUtils::Typemap tests
+dist/ExtUtils-ParseXS/t/data/combined.typemap                  ExtUtils::Typemap test data
+dist/ExtUtils-ParseXS/t/data/other.typemap                     ExtUtils::Typemap test data
+dist/ExtUtils-ParseXS/t/data/simple.typemap                    ExtUtils::Typemap 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
diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap.pm
new file mode 100644 (file)
index 0000000..c190682
--- /dev/null
@@ -0,0 +1,713 @@
+package ExtUtils::Typemap;
+use 5.006001;
+use strict;
+use warnings;
+our $VERSION = '0.05';
+use Carp qw(croak);
+
+our $Proto_Regexp = "[" . quotemeta('\$%&*@;[]') . "]";
+
+require ExtUtils::Typemap::InputMap;
+require ExtUtils::Typemap::OutputMap;
+require ExtUtils::Typemap::Type;
+
+=head1 NAME
+
+ExtUtils::Typemap - Read/Write/Modify Perl/XS typemap files
+
+=head1 SYNOPSIS
+
+  # read/create file
+  my $typemap = ExtUtils::Typemap->new(file => 'typemap');
+  # alternatively create an in-memory typemap
+  # $typemap = ExtUtils::Typemap->new();
+  # alternatively create an in-memory typemap by parsing a string
+  # $typemap = ExtUtils::Typemap->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}) {
+    croak("Cannot handle both 'file' and 'string' arguments to constructor");
+  }
+
+  my $self = bless {
+    file            => undef,
+    %args,
+    typemap_section => [],
+    input_section   => [],
+    output_section  => [],
+  } => $class;
+
+  $self->_init();
+
+  return $self;
+}
+
+sub _init {
+  my $self = shift;
+  if (defined $self->{string}) {
+    $self->_parse(\($self->{string}));
+    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->{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>.
+
+As an alternative to the named parameters usage, you may pass in
+an C<ExtUtils::Typemap::Type> object, a copy of which will be
+added to the typemap.
+
+=cut
+
+sub add_typemap {
+  my $self = shift;
+  my $type;
+  my $replace = 0;
+  if (@_ == 1) {
+    my $orig = shift;
+    $type = $orig->new(@_);
+  }
+  else {
+    my %args = @_;
+    my $ctype = $args{ctype};
+    croak("Need ctype argument") if not defined $ctype;
+    my $xstype = $args{xstype};
+    croak("Need xstype argument") if not defined $xstype;
+
+    $type = ExtUtils::Typemap::Type->new(
+      xstype      => $xstype,
+      'prototype' => $args{'prototype'},
+      ctype       => $ctype,
+    );
+    $replace = $args{replace};
+  }
+
+  if ($replace) {
+    $self->remove_typemap(ctype => $type->ctype);
+  } else {
+    $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
+  }
+  push @{$self->{typemap_section}}, $type;
+  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>.
+
+You may pass in a single C<ExtUtils::Typemap::InputMap> object instead,
+a copy of which will be added to the typemap.
+
+=cut
+
+sub add_inputmap {
+  my $self = shift;
+  my $input;
+  my $replace = 0;
+  if (@_ == 1) {
+    my $orig = shift;
+    $input = $orig->new(@_);
+  }
+  else {
+    my %args = @_;
+    my $xstype = $args{xstype};
+    croak("Need xstype argument") if not defined $xstype;
+    my $code = $args{code};
+    croak("Need code argument") if not defined $code;
+
+    $input = ExtUtils::Typemap::InputMap->new(
+      xstype => $xstype,
+      code   => $code,
+    );
+    $replace = $args{replace};
+  }
+  if ($replace) {
+    $self->remove_inputmap(xstype => $input->xstype);
+  } else {
+    $self->validate(inputmap_xstype => $input->xstype);
+  }
+  push @{$self->{input_section}}, $input;
+  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 $replace = 0;
+  if (@_ == 1) {
+    my $orig = shift;
+    $output = $orig->new(@_);
+  }
+  else {
+    my %args = @_;
+    my $xstype = $args{xstype};
+    croak("Need xstype argument") if not defined $xstype;
+    my $code = $args{code};
+    croak("Need code argument") if not defined $code;
+
+    $output = ExtUtils::Typemap::OutputMap->new(
+      xstype => $xstype,
+      code   => $code,
+    );
+    $replace = $args{replace};
+  }
+  if ($replace) {
+    $self->remove_outputmap(xstype => $output->xstype);
+  } else {
+    $self->validate(outputmap_xstype => $output->xstype);
+  }
+  push @{$self->{output_section}}, $output;
+  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 = @_;
+  croak("Need 'string' argument") if not defined $args{string};
+
+  # no, this is not elegant.
+  my $other = ExtUtils::Typemap->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::Typemap::Type> object.
+
+=cut
+
+sub remove_typemap {
+  my $self = shift;
+  my $ctype;
+  if (@_ > 1) {
+    my %args = @_;
+    $ctype = $args{ctype};
+    croak("Need ctype argument") if not defined $ctype;
+    $ctype = _tidy_type($ctype);
+  }
+  else {
+    $ctype = $_[0]->tidy_ctype;
+  }
+  
+  return $self->_remove($ctype, 'tidy_ctype', $self->{typemap_section});
+}
+
+=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::Typemap::InputMap> object.
+
+=cut
+
+sub remove_inputmap {
+  my $self = shift;
+  my $xstype;
+  if (@_ > 1) {
+    my %args = @_;
+    $xstype = $args{xstype};
+    croak("Need xstype argument") if not defined $xstype;
+  }
+  else {
+    $xstype = $_[0]->xstype;
+  }
+  
+  return $self->_remove($xstype, 'xstype', $self->{input_section});
+}
+
+=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::Typemap::OutputMap> object.
+
+=cut
+
+sub remove_outputmap {
+  my $self = shift;
+  my $xstype;
+  if (@_ > 1) {
+    my %args = @_;
+    $xstype = $args{xstype};
+    croak("Need xstype argument") if not defined $xstype;
+  }
+  else {
+    $xstype = $_[0]->xstype;
+  }
+  
+  return $self->_remove($xstype, 'xstype', $self->{output_section});
+}
+
+sub _remove {
+  my $self   = shift;
+  my $rm     = shift;
+  my $method = shift;
+  my $array  = shift;
+
+  my $index = 0;
+  foreach my $map (@$array) {
+    last if $map->$method() eq $rm;
+    $index++;
+  }
+  if ($index < @$array) {
+    splice(@$array, $index, 1);
+    return 1;
+  }
+  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::Typemap::Type>
+object for the entry if found.
+
+=cut
+
+sub get_typemap {
+  my $self = shift;
+  my %args = @_;
+  my $ctype = $args{ctype};
+  croak("Need ctype argument") if not defined $ctype;
+  $ctype = _tidy_type($ctype);
+
+  foreach my $map (@{$self->{typemap_section}}) {
+    return $map if $map->tidy_ctype eq $ctype;
+  }
+  return();
+}
+
+=head2 get_inputmap
+
+Fetches an entry of the INPUT section of the
+typemap.
+
+Mandatory named arguments: The C<xstype> of the
+entry.
+
+Returns the C<ExtUtils::Typemap::InputMap>
+object for the entry if found.
+
+=cut
+
+sub get_inputmap {
+  my $self = shift;
+  my %args = @_;
+  my $xstype = $args{xstype};
+  croak("Need xstype argument") if not defined $xstype;
+
+  foreach my $map (@{$self->{input_section}}) {
+    return $map if $map->xstype eq $xstype;
+  }
+  return();
+}
+
+=head2 get_outputmap
+
+Fetches an entry of the OUTPUT section of the
+typemap.
+
+Mandatory named arguments: The C<xstype> of the
+entry.
+
+Returns the C<ExtUtils::Typemap::InputMap>
+object for the entry if found.
+
+=cut
+
+sub get_outputmap {
+  my $self = shift;
+  my %args = @_;
+  my $xstype = $args{xstype};
+  croak("Need xstype argument") if not defined $xstype;
+
+  foreach my $map (@{$self->{output_section}}) {
+    return $map if $map->xstype eq $xstype;
+  }
+  return();
+}
+
+=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();
+  croak("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*($Proto_Regexp*)$/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 if necessary.
+
+Mandatory named argument: C<typemap =E<gt> $another_typemap>
+
+Optional argument: C<replace =E<gt> 1> to force replacement
+of existing typemap entries without warning.
+
+=cut
+
+sub merge {
+  my $self = shift;
+  my %args = @_;
+  my $typemap = $args{typemap};
+  croak("Need ExtUtils::Typemap as argument")
+    if not ref $typemap or not $typemap->isa('ExtUtils::Typemap');
+
+  my $replace = $args{replace};
+
+  # FIXME breaking encapsulation. Add accessor code.
+  #
+  foreach my $entry (@{$typemap->{typemap_section}}) {
+    $self->add_typemap( $entry );
+  }
+
+  foreach my $entry (@{$typemap->{input_section}}) {
+    $self->add_inputmap( $entry );
+  }
+
+  foreach my $entry (@{$typemap->{output_section}}) {
+    $self->add_outputmap( $entry );
+  }
+
+  return 1;
+}
+
+# Note: This is really inefficient. One could keep a hash to start with.
+sub validate {
+  my $self = shift;
+  my %args = @_;
+
+  my %xstypes;
+  my %ctypes;
+  $xstypes{$args{typemap_xstype}}++ if defined $args{typemap_xstype};
+  $ctypes{$args{ctype}}++ if defined $args{ctype};
+
+  foreach my $map (@{$self->{typemap_section}}) {
+    my $ctype = $map->tidy_ctype;
+    croak("Multiple definition of ctype '$ctype' in TYPEMAP section")
+      if exists $ctypes{$ctype};
+    my $xstype = $map->xstype;
+    # TODO check this: We shouldn't complain about reusing XS types in TYPEMAP.
+    #croak("Multiple definition of xstype '$xstype' in TYPEMAP section")
+    #  if exists $xstypes{$xstype};
+    $xstypes{$xstype}++;
+    $ctypes{$ctype}++;
+  }
+
+  %xstypes = ();
+  $xstypes{$args{inputmap_xstype}}++ if defined $args{inputmap_xstype};
+  foreach my $map (@{$self->{input_section}}) {
+    my $xstype = $map->xstype;
+    croak("Multiple definition of xstype '$xstype' in INPUTMAP section")
+      if exists $xstypes{$xstype};
+    $xstypes{$xstype}++;
+  }
+
+  %xstypes = ();
+  $xstypes{$args{outputmap_xstype}}++ if defined $args{outputmap_xstype};
+  foreach my $map (@{$self->{output_section}}) {
+    my $xstype = $map->xstype;
+    croak("Multiple definition of xstype '$xstype' in OUTPUTMAP section")
+      if exists $xstypes{$xstype};
+    $xstypes{$xstype}++;
+  }
+
+  return 1;
+}
+
+sub _parse {
+  my $self = shift;
+  my $stringref = shift;
+  my $filename = shift;
+  $filename = '<string>' if not defined $filename;
+
+  # 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 = 0;
+  my $junk = "";
+  my $current = \$junk;
+  my @typemap_expr;
+  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 /^#/ or /^$/;
+      my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($Proto_Regexp*)$/o
+        or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
+           next;
+      #$proto = '' if not $proto;
+      # prototype defaults to '$'
+      #$proto = '$' unless $proto;
+      #warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
+      #  unless _valid_proto_string($proto);
+      push @typemap_expr, ExtUtils::Typemap::Type->new(
+        xstype => $kind, proto => $proto, ctype => $type
+      );
+    } elsif (/^\s/) {
+      $$current .= $$current eq '' ? $_ : "\n".$_;
+    } elsif (/^$/) {
+      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
+
+  $self->{typemap_section} = \@typemap_expr;
+  $self->{input_section}   = [ map {ExtUtils::Typemap::InputMap->new(%$_) } @input_expr ];
+  $self->{output_section}  = [ map {ExtUtils::Typemap::OutputMap->new(%$_) } @output_expr ];
+  
+  return $self->validate();
+}
+
+# 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 =~ /^$Proto_Regexp+$/o) {
+    return $string;
+  }
+
+  return 0 ;
+}
+
+# taken from ExtUtils::ParseXS (C_string)
+sub _escape_backslashes {
+  my $string = shift;
+  $string =~ s[\\][\\\\]g;
+  $string;
+}
+
+=head1 CAVEATS
+
+Not as well tested as I'd like it to be.
+
+Inherits some evil code from C<ExtUtils::ParseXS>.
+
+Adding more typemaps incurs an O(n) validation penalty
+that could be optimized with a hash.
+
+=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-2010 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/Typemap/InputMap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/InputMap.pm
new file mode 100644 (file)
index 0000000..08c54cb
--- /dev/null
@@ -0,0 +1,96 @@
+package ExtUtils::Typemap::InputMap;
+use 5.006001;
+use strict;
+use warnings;
+our $VERSION = '0.05';
+use Carp qw(croak);
+
+=head1 NAME
+
+ExtUtils::Typemap::InputMap - Entry in the INPUT section of a typemap
+
+=head1 SYNOPSIS
+
+  use ExtUtils::Typemap;
+  ...
+  my $input = $typemap->get_input_map('T_NV');
+  my $code = $input->code();
+  $input->code("...");
+
+=head1 DESCRIPTION
+
+Refer to L<ExtUtils::Typemap> 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}) {
+      croak("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};
+}
+
+=head1 SEE ALSO
+
+L<ExtUtils::Typemap>
+
+=head1 AUTHOR
+
+Steffen Mueller C<<smueller@cpan.org>>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2009-2010 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/Typemap/OutputMap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/OutputMap.pm
new file mode 100644 (file)
index 0000000..c543386
--- /dev/null
@@ -0,0 +1,96 @@
+package ExtUtils::Typemap::OutputMap;
+use 5.006001;
+use strict;
+use warnings;
+our $VERSION = '0.05';
+use Carp qw(croak);
+
+=head1 NAME
+
+ExtUtils::Typemap::OutputMap - Entry in the OUTPUT section of a typemap
+
+=head1 SYNOPSIS
+
+  use ExtUtils::Typemap;
+  ...
+  my $output = $typemap->get_output_map('T_NV');
+  my $code = $output->code();
+  $output->code("...");
+
+=head1 DESCRIPTION
+
+Refer to L<ExtUtils::Typemap> 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}) {
+      croak("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};
+}
+
+=head1 SEE ALSO
+
+L<ExtUtils::Typemap>
+
+=head1 AUTHOR
+
+Steffen Mueller C<<smueller@cpan.org>>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2009-2010 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/Typemap/Type.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemap/Type.pm
new file mode 100644 (file)
index 0000000..9be7a94
--- /dev/null
@@ -0,0 +1,121 @@
+package ExtUtils::Typemap::Type;
+use 5.006001;
+use strict;
+use warnings;
+our $VERSION = '0.05';
+use Carp qw(croak);
+use ExtUtils::Typemap;
+
+=head1 NAME
+
+ExtUtils::Typemap::Type - Entry in the TYPEMAP section of a typemap
+
+=head1 SYNOPSIS
+
+  use ExtUtils::Typemap;
+  ...
+  my $type = $typemap->get_type_map('char*');
+  my $input = $typemap->get_input_map($type->xstype);
+
+=head1 DESCRIPTION
+
+Refer to L<ExtUtils::Typemap> 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}) {
+      croak("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::Typemap::_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::Typemap>
+
+=head1 AUTHOR
+
+Steffen Mueller C<<smueller@cpan.org>>
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2009-2010 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/t/501-t-compile.t b/dist/ExtUtils-ParseXS/t/501-t-compile.t
new file mode 100644 (file)
index 0000000..b782ec2
--- /dev/null
@@ -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::Typemap'   );
diff --git a/dist/ExtUtils-ParseXS/t/510-t-bare.t b/dist/ExtUtils-ParseXS/t/510-t-bare.t
new file mode 100644 (file)
index 0000000..ae373e6
--- /dev/null
@@ -0,0 +1,135 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use ExtUtils::Typemap;
+
+# typemap only
+SCOPE: {
+  my $map = ExtUtils::Typemap->new();
+  $map->add_typemap(ctype => 'unsigned int', xstype => 'T_IV');
+  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::Typemap::Type');
+  is($type->ctype, 'unsigned int');
+  is($type->xstype, 'T_IV');
+  is($type->tidy_ctype, 'unsigned int');
+}
+
+# typemap & input
+SCOPE: {
+  my $map = ExtUtils::Typemap->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) 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::Typemap::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::Typemap::InputMap');
+  is($in->xstype, 'T_UV');
+}
+
+
+# typemap & output
+SCOPE: {
+  my $map = ExtUtils::Typemap->new();
+  $map->add_typemap(ctype => 'unsigned int', xstype => 'T_UV');
+  $map->add_outputmap(xstype => 'T_UV', code => 'sv_setuv($arg, (UV)$var);');
+  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::Typemap::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::Typemap::OutputMap');
+  is($in->xstype, 'T_UV');
+}
+
+# typemap & input & output
+SCOPE: {
+  my $map = ExtUtils::Typemap->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);');
+  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::Typemap->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::Typemap::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::Typemap::OutputMap');
+  is($in->xstype, 'T_UV');
+  $in = $map->get_outputmap(xstype => 'T_IV');
+  isa_ok($in, 'ExtUtils::Typemap::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 (file)
index 0000000..3d2ceeb
--- /dev/null
@@ -0,0 +1,38 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use ExtUtils::Typemap;
+
+SCOPE: {
+  my $map = ExtUtils::Typemap->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::Typemap->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 (file)
index 0000000..e13bf5b
--- /dev/null
@@ -0,0 +1,49 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+use ExtUtils::Typemap;
+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::Typemap->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::Typemap->new(file => $cmp_typemap_file)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips");
+is(ExtUtils::Typemap->new(file => $tmpfile)->as_string(), $cmp_typemap_str, "Simple typemap roundtrips (2)");
+
+SCOPE: {
+  local $map->{file} = $cmp_typemap_file;
+  is_deeply(ExtUtils::Typemap->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::Typemap->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 (file)
index 0000000..34ae064
--- /dev/null
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use ExtUtils::Typemap;
+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');
+
+
+SCOPE: {
+  my $first = ExtUtils::Typemap->new(file => $first_typemap_file);
+  isa_ok($first, 'ExtUtils::Typemap');
+  my $second = ExtUtils::Typemap->new(file => $second_typemap_file);
+  isa_ok($second, 'ExtUtils::Typemap');
+
+  $first->merge(typemap => $second);
+
+  is($first->as_string(), slurp($combined_typemap_file), "merging produces expected output");
+}
+
+SCOPE: {
+  my $first = ExtUtils::Typemap->new(file => $first_typemap_file);
+  isa_ok($first, 'ExtUtils::Typemap');
+  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");
+}
diff --git a/dist/ExtUtils-ParseXS/t/data/combined.typemap b/dist/ExtUtils-ParseXS/t/data/combined.typemap
new file mode 100644 (file)
index 0000000..6a1d776
--- /dev/null
@@ -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/other.typemap b/dist/ExtUtils-ParseXS/t/data/other.typemap
new file mode 100644 (file)
index 0000000..c7e306b
--- /dev/null
@@ -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/simple.typemap b/dist/ExtUtils-ParseXS/t/data/simple.typemap
new file mode 100644 (file)
index 0000000..1c45568
--- /dev/null
@@ -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);