ExtUtils::Typemap - Read/Write/Modify Perl/XS typemap files

  # 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);

package ExtUtils::Typemap;
use 5.006001;
use strict;
use warnings;
our $VERSION = '0.05';
use Carp qw(croak);

our $Proto_Regexp = "[" . quotemeta('\$%&*@;[]') . "]";

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});
  }
}

sub file {
  $_[0]->{file} = $_[1] if @_ > 1;
  $_[0]->{file}
}

sub add_typemap {
  my $self = shift;
  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;
  if ($args{replace}) {
    $self->remove_typemap(ctype => $ctype);
  } else {
    $self->validate(typemap_xstype => $xstype, ctype => $ctype);
  }
  my $proto = $args{"prototype"} || '';
  push @{$self->{typemap_section}}, {
    tidy_ctype => _tidy_type($ctype),
    xstype     => $xstype,
    proto      => $proto,
    ctype      => $ctype,
  };
  return 1;
}

sub add_inputmap {
  my $self = shift;
  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;
  if ($args{replace}) {
    $self->remove_inputmap(xstype => $xstype);
  } else {
    $self->validate(inputmap_xstype => $xstype);
  }
  $code =~ s/^(?=\S)/\t/mg;
  push @{$self->{input_section}},
    {xstype => $xstype, code => $code};
  return 1;
}

sub add_outputmap {
  my $self = shift;
  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;
  if ($args{replace}) {
    $self->remove_outputmap(xstype => $xstype);
  } else {
    $self->validate(outputmap_xstype => $xstype);
  }
  $code =~ s/^(?=\S)/\t/mg;
  push @{$self->{output_section}},
    {xstype => $xstype, code => $code};
  return 1;
}

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);
}

sub remove_typemap {
  my $self = shift;
  my %args = @_;
  my $ctype = $args{ctype};
  croak("Need ctype argument") if not defined $ctype;
  $ctype = _tidy_type($ctype);
  
  return $self->_remove($ctype, 'tidy_ctype', $self->{typemap_section});
}

sub remove_inputmap {
  my $self = shift;
  my %args = @_;
  my $xstype = $args{xstype};
  croak("Need xstype argument") if not defined $xstype;
  
  return $self->_remove($xstype, 'xstype', $self->{input_section});
}

sub remove_outputmap {
  my $self = shift;
  my %args = @_;
  my $xstype = $args{xstype};
  croak("Need xstype argument") if not defined $xstype;
  
  return $self->_remove($xstype, 'xstype', $self->{output_section});
}

sub _remove {
  my $self  = shift;
  my $rm    = shift;
  my $key   = shift;
  my $array = shift;

  my $index = 0;
  foreach my $map (@$array) {
    last if $map->{$key} eq $rm;
    $index++;
  }
  if ($index < @$array) {
    splice(@$array, $index, 1);
    return 1;
  }
  return();
}

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;
}

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
    my $ctype = defined($entry->{ctype}) ? $entry->{ctype} : $entry->{tidy_ctype};
    push @code, "$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;
}

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}}) {
    my $ctype = defined($entry->{ctype}) ? $entry->{ctype} : $entry->{tidy_ctype};
    $self->add_typemap(
      ctype       => $ctype,
      xstype      => $entry->{xstype},
      "prototype" => $entry->{proto},
      replace     => $replace,
    );
  }

  foreach my $entry (@{$typemap->{input_section}}) {
    $self->add_inputmap(
      code        => $entry->{code},
      xstype      => $entry->{xstype},
      replace     => $replace,
    );
  }

  foreach my $entry (@{$typemap->{output_section}}) {
    $self->add_outputmap(
      code        => $entry->{code},
      xstype      => $entry->{xstype},
      replace     => $replace,
    );
  }

  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{ $map->{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{ $map->{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;
      my $tidytype = _tidy_type($type);
      $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,
        {tidy_ctype => $tidytype, 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}   = \@input_expr;
  $self->{output_section}  = \@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;
}

1;