dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm

   1 package ExtUtils::Typemaps;
   2 use 5.006001;
   3 use strict;
   4 use warnings;
   5 our $VERSION = '0.05';
   6 use Carp qw(croak);
   7
   8 our $Proto_Regexp = "[" . quotemeta('\$%&*@;[]') . "]";
   9
  10 require ExtUtils::Typemaps::InputMap;
  11 require ExtUtils::Typemaps::OutputMap;
  12 require ExtUtils::Typemaps::Type;
  13
  14 =head1 NAME
  15
  16 ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files
  17
  18 =head1 SYNOPSIS
  19
  20   # read/create file
  21   my $typemap = ExtUtils::Typemaps->new(file => 'typemap');
  22   # alternatively create an in-memory typemap
  23   # $typemap = ExtUtils::Typemaps->new();
  24   # alternatively create an in-memory typemap by parsing a string
  25   # $typemap = ExtUtils::Typemaps->new(string => $sometypemap);
  26
  27   # add a mapping
  28   $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV');
  29   $typemap->add_inputmap (xstype => 'T_NV', code => '$var = ($type)SvNV($arg);');
  30   $typemap->add_outputmap(xstype => 'T_NV', code => 'sv_setnv($arg, (NV)$var);');
  31   $typemap->add_string(string => $typemapstring); # will be parsed and merged
  32
  33   # remove a mapping (same for remove_typemap and remove_outputmap...)
  34   $typemap->remove_inputmap(xstype => 'SomeType');
  35
  36   # save a typemap to a file
  37   $typemap->write(file => 'anotherfile.map');
  38
  39   # merge the other typemap into this one
  40   $typemap->merge(typemap => $another_typemap);
  41
  42 =head1 DESCRIPTION
  43
  44 This module can read, modify, create and write Perl XS typemap files. If you don't know
  45 what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals.
  46
  47 The module is not entirely round-trip safe: For example it currently simply strips all comments.
  48 The order of entries in the maps is, however, preserved.
  49
  50 We check for duplicate entries in the typemap, but do not check for missing
  51 C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden
  52 in a different typemap.
  53
  54 =head1 METHODS
  55
  56 =cut
  57
  58 =head2 new
  59
  60 Returns a new typemap object. Takes an optional C<file> parameter.
  61 If set, the given file will be read. If the file doesn't exist, an empty typemap
  62 is returned.
  63
  64 Alternatively, if the C<string> parameter is given, the supplied
  65 string will be parsed instead of a file.
  66
  67 =cut
  68
  69 sub new {
  70   my $class = shift;
  71   my %args = @_;
  72
  73   if (defined $args{file} and defined $args{string}) {
  74     croak("Cannot handle both 'file' and 'string' arguments to constructor");
  75   }
  76
  77   my $self = bless {
  78     file            => undef,
  79     %args,
  80     typemap_section => [],
  81     input_section   => [],
  82     output_section  => [],
  83   } => $class;
  84
  85   $self->_init();
  86
  87   return $self;
  88 }
  89
  90 sub _init {
  91   my $self = shift;
  92   if (defined $self->{string}) {
  93     $self->_parse(\($self->{string}));
  94     delete $self->{string};
  95   }
  96   elsif (defined $self->{file} and -e $self->{file}) {
  97     open my $fh, '<', $self->{file}
  98       or die "Cannot open typemap file '"
  99              . $self->{file} . "' for reading: $!";
 100     local $/ = undef;
 101     my $string = <$fh>;
 102     $self->_parse(\$string, $self->{file});
 103   }
 104 }
 105
 106 =head2 file
 107
 108 Get/set the file that the typemap is written to when the
 109 C<write> method is called.
 110
 111 =cut
 112
 113 sub file {
 114   $_[0]->{file} = $_[1] if @_ > 1;
 115   $_[0]->{file}
 116 }
 117
 118 =head2 add_typemap
 119
 120 Add a C<TYPEMAP> entry to the typemap.
 121
 122 Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>)
 123 and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>).
 124
 125 Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
 126 existing C<TYPEMAP> entries of the same C<ctype>.
 127
 128 As an alternative to the named parameters usage, you may pass in
 129 an C<ExtUtils::Typemaps::Type> object, a copy of which will be
 130 added to the typemap.
 131
 132 =cut
 133
 134 sub add_typemap {
 135   my $self = shift;
 136   my $type;
 137   my $replace = 0;
 138   if (@_ == 1) {
 139     my $orig = shift;
 140     $type = $orig->new(@_);
 141   }
 142   else {
 143     my %args = @_;
 144     my $ctype = $args{ctype};
 145     croak("Need ctype argument") if not defined $ctype;
 146     my $xstype = $args{xstype};
 147     croak("Need xstype argument") if not defined $xstype;
 148
 149     $type = ExtUtils::Typemaps::Type->new(
 150       xstype      => $xstype,
 151       'prototype' => $args{'prototype'},
 152       ctype       => $ctype,
 153     );
 154     $replace = $args{replace};
 155   }
 156
 157   if ($replace) {
 158     $self->remove_typemap(ctype => $type->ctype);
 159   } else {
 160     $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
 161   }
 162   push @{$self->{typemap_section}}, $type;
 163   return 1;
 164 }
 165
 166 =head2 add_inputmap
 167
 168 Add an C<INPUT> entry to the typemap.
 169
 170 Required named arguments:
 171 The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
 172 and the C<code> to associate with it for input.
 173
 174 Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
 175 existing C<INPUT> entries of the same C<xstype>.
 176
 177 You may pass in a single C<ExtUtils::Typemaps::InputMap> object instead,
 178 a copy of which will be added to the typemap.
 179
 180 =cut
 181
 182 sub add_inputmap {
 183   my $self = shift;
 184   my $input;
 185   my $replace = 0;
 186   if (@_ == 1) {
 187     my $orig = shift;
 188     $input = $orig->new(@_);
 189   }
 190   else {
 191     my %args = @_;
 192     my $xstype = $args{xstype};
 193     croak("Need xstype argument") if not defined $xstype;
 194     my $code = $args{code};
 195     croak("Need code argument") if not defined $code;
 196
 197     $input = ExtUtils::Typemaps::InputMap->new(
 198       xstype => $xstype,
 199       code   => $code,
 200     );
 201     $replace = $args{replace};
 202   }
 203   if ($replace) {
 204     $self->remove_inputmap(xstype => $input->xstype);
 205   } else {
 206     $self->validate(inputmap_xstype => $input->xstype);
 207   }
 208   push @{$self->{input_section}}, $input;
 209   return 1;
 210 }
 211
 212 =head2 add_outputmap
 213
 214 Add an C<OUTPUT> entry to the typemap.
 215 Works exactly the same as C<add_inputmap>.
 216
 217 =cut
 218
 219 sub add_outputmap {
 220   my $self = shift;
 221   my $output;
 222   my $replace = 0;
 223   if (@_ == 1) {
 224     my $orig = shift;
 225     $output = $orig->new(@_);
 226   }
 227   else {
 228     my %args = @_;
 229     my $xstype = $args{xstype};
 230     croak("Need xstype argument") if not defined $xstype;
 231     my $code = $args{code};
 232     croak("Need code argument") if not defined $code;
 233
 234     $output = ExtUtils::Typemaps::OutputMap->new(
 235       xstype => $xstype,
 236       code   => $code,
 237     );
 238     $replace = $args{replace};
 239   }
 240   if ($replace) {
 241     $self->remove_outputmap(xstype => $output->xstype);
 242   } else {
 243     $self->validate(outputmap_xstype => $output->xstype);
 244   }
 245   push @{$self->{output_section}}, $output;
 246   return 1;
 247 }
 248
 249 =head2 add_string
 250
 251 Parses a string as a typemap and merge it into the typemap object.
 252
 253 Required named argument: C<string> to specify the string to parse.
 254
 255 =cut
 256
 257 sub add_string {
 258   my $self = shift;
 259   my %args = @_;
 260   croak("Need 'string' argument") if not defined $args{string};
 261
 262   # no, this is not elegant.
 263   my $other = ExtUtils::Typemaps->new(string => $args{string});
 264   $self->merge(typemap => $other);
 265 }
 266
 267 =head2 remove_typemap
 268
 269 Removes a C<TYPEMAP> entry from the typemap.
 270
 271 Required named argument: C<ctype> to specify the entry to remove from the typemap.
 272
 273 Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.
 274
 275 =cut
 276
 277 sub remove_typemap {
 278   my $self = shift;
 279   my $ctype;
 280   if (@_ > 1) {
 281     my %args = @_;
 282     $ctype = $args{ctype};
 283     croak("Need ctype argument") if not defined $ctype;
 284     $ctype = _tidy_type($ctype);
 285   }
 286   else {
 287     $ctype = $_[0]->tidy_ctype;
 288   }
 289
 290   return $self->_remove($ctype, 'tidy_ctype', $self->{typemap_section});
 291 }
 292
 293 =head2 remove_inputmap
 294
 295 Removes an C<INPUT> entry from the typemap.
 296
 297 Required named argument: C<xstype> to specify the entry to remove from the typemap.
 298
 299 Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.
 300
 301 =cut
 302
 303 sub remove_inputmap {
 304   my $self = shift;
 305   my $xstype;
 306   if (@_ > 1) {
 307     my %args = @_;
 308     $xstype = $args{xstype};
 309     croak("Need xstype argument") if not defined $xstype;
 310   }
 311   else {
 312     $xstype = $_[0]->xstype;
 313   }
 314
 315   return $self->_remove($xstype, 'xstype', $self->{input_section});
 316 }
 317
 318 =head2 remove_inputmap
 319
 320 Removes an C<OUTPUT> entry from the typemap.
 321
 322 Required named argument: C<xstype> to specify the entry to remove from the typemap.
 323
 324 Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.
 325
 326 =cut
 327
 328 sub remove_outputmap {
 329   my $self = shift;
 330   my $xstype;
 331   if (@_ > 1) {
 332     my %args = @_;
 333     $xstype = $args{xstype};
 334     croak("Need xstype argument") if not defined $xstype;
 335   }
 336   else {
 337     $xstype = $_[0]->xstype;
 338   }
 339
 340   return $self->_remove($xstype, 'xstype', $self->{output_section});
 341 }
 342
 343 sub _remove {
 344   my $self   = shift;
 345   my $rm     = shift;
 346   my $method = shift;
 347   my $array  = shift;
 348
 349   my $index = 0;
 350   foreach my $map (@$array) {
 351     last if $map->$method() eq $rm;
 352     $index++;
 353   }
 354   if ($index < @$array) {
 355     splice(@$array, $index, 1);
 356     return 1;
 357   }
 358   return();
 359 }
 360
 361 =head2 get_typemap
 362
 363 Fetches an entry of the TYPEMAP section of the typemap.
 364
 365 Mandatory named arguments: The C<ctype> of the entry.
 366
 367 Returns the C<ExtUtils::Typemaps::Type>
 368 object for the entry if found.
 369
 370 =cut
 371
 372 sub get_typemap {
 373   my $self = shift;
 374   my %args = @_;
 375   my $ctype = $args{ctype};
 376   croak("Need ctype argument") if not defined $ctype;
 377   $ctype = _tidy_type($ctype);
 378
 379   foreach my $map (@{$self->{typemap_section}}) {
 380     return $map if $map->tidy_ctype eq $ctype;
 381   }
 382   return();
 383 }
 384
 385 =head2 get_inputmap
 386
 387 Fetches an entry of the INPUT section of the
 388 typemap.
 389
 390 Mandatory named arguments: The C<xstype> of the
 391 entry.
 392
 393 Returns the C<ExtUtils::Typemaps::InputMap>
 394 object for the entry if found.
 395
 396 =cut
 397
 398 sub get_inputmap {
 399   my $self = shift;
 400   my %args = @_;
 401   my $xstype = $args{xstype};
 402   croak("Need xstype argument") if not defined $xstype;
 403
 404   foreach my $map (@{$self->{input_section}}) {
 405     return $map if $map->xstype eq $xstype;
 406   }
 407   return();
 408 }
 409
 410 =head2 get_outputmap
 411
 412 Fetches an entry of the OUTPUT section of the
 413 typemap.
 414
 415 Mandatory named arguments: The C<xstype> of the
 416 entry.
 417
 418 Returns the C<ExtUtils::Typemaps::InputMap>
 419 object for the entry if found.
 420
 421 =cut
 422
 423 sub get_outputmap {
 424   my $self = shift;
 425   my %args = @_;
 426   my $xstype = $args{xstype};
 427   croak("Need xstype argument") if not defined $xstype;
 428
 429   foreach my $map (@{$self->{output_section}}) {
 430     return $map if $map->xstype eq $xstype;
 431   }
 432   return();
 433 }
 434
 435 =head2 write
 436
 437 Write the typemap to a file. Optionally takes a C<file> argument. If given, the
 438 typemap will be written to the specified file. If not, the typemap is written
 439 to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
 440 it was read from if any).
 441
 442 =cut
 443
 444 sub write {
 445   my $self = shift;
 446   my %args = @_;
 447   my $file = defined $args{file} ? $args{file} : $self->file();
 448   croak("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
 449     if not defined $file;
 450
 451   open my $fh, '>', $file
 452     or die "Cannot open typemap file '$file' for writing: $!";
 453   print $fh $self->as_string();
 454   close $fh;
 455 }
 456
 457 =head2 as_string
 458
 459 Generates and returns the string form of the typemap.
 460
 461 =cut
 462
 463 sub as_string {
 464   my $self = shift;
 465   my $typemap = $self->{typemap_section};
 466   my @code;
 467   push @code, "TYPEMAP\n";
 468   foreach my $entry (@$typemap) {
 469     # type kind proto
 470     # /^(.*?\S)\s+(\S+)\s*($Proto_Regexp*)$/o
 471     push @code, $entry->ctype . "\t" . $entry->xstype
 472               . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
 473   }
 474
 475   my $input = $self->{input_section};
 476   if (@$input) {
 477     push @code, "\nINPUT\n";
 478     foreach my $entry (@$input) {
 479       push @code, $entry->xstype, "\n", $entry->code, "\n";
 480     }
 481   }
 482
 483   my $output = $self->{output_section};
 484   if (@$output) {
 485     push @code, "\nOUTPUT\n";
 486     foreach my $entry (@$output) {
 487       push @code, $entry->xstype, "\n", $entry->code, "\n";
 488     }
 489   }
 490   return join '', @code;
 491 }
 492
 493 =head2 merge
 494
 495 Merges a given typemap into the object. Note that a failed merge
 496 operation leaves the object in an inconsistent state so clone if necessary.
 497
 498 Mandatory named argument: C<typemap =E<gt> $another_typemap>
 499
 500 Optional argument: C<replace =E<gt> 1> to force replacement
 501 of existing typemap entries without warning.
 502
 503 =cut
 504
 505 sub merge {
 506   my $self = shift;
 507   my %args = @_;
 508   my $typemap = $args{typemap};
 509   croak("Need ExtUtils::Typemaps as argument")
 510     if not ref $typemap or not $typemap->isa('ExtUtils::Typemaps');
 511
 512   my $replace = $args{replace};
 513
 514   # FIXME breaking encapsulation. Add accessor code.
 515   #
 516   foreach my $entry (@{$typemap->{typemap_section}}) {
 517     $self->add_typemap( $entry );
 518   }
 519
 520   foreach my $entry (@{$typemap->{input_section}}) {
 521     $self->add_inputmap( $entry );
 522   }
 523
 524   foreach my $entry (@{$typemap->{output_section}}) {
 525     $self->add_outputmap( $entry );
 526   }
 527
 528   return 1;
 529 }
 530
 531 # Note: This is really inefficient. One could keep a hash to start with.
 532 sub validate {
 533   my $self = shift;
 534   my %args = @_;
 535
 536   my %xstypes;
 537   my %ctypes;
 538   $xstypes{$args{typemap_xstype}}++ if defined $args{typemap_xstype};
 539   $ctypes{$args{ctype}}++ if defined $args{ctype};
 540
 541   foreach my $map (@{$self->{typemap_section}}) {
 542     my $ctype = $map->tidy_ctype;
 543     croak("Multiple definition of ctype '$ctype' in TYPEMAP section")
 544       if exists $ctypes{$ctype};
 545     my $xstype = $map->xstype;
 546     # TODO check this: We shouldn't complain about reusing XS types in TYPEMAP.
 547     #croak("Multiple definition of xstype '$xstype' in TYPEMAP section")
 548     #  if exists $xstypes{$xstype};
 549     $xstypes{$xstype}++;
 550     $ctypes{$ctype}++;
 551   }
 552
 553   %xstypes = ();
 554   $xstypes{$args{inputmap_xstype}}++ if defined $args{inputmap_xstype};
 555   foreach my $map (@{$self->{input_section}}) {
 556     my $xstype = $map->xstype;
 557     croak("Multiple definition of xstype '$xstype' in INPUTMAP section")
 558       if exists $xstypes{$xstype};
 559     $xstypes{$xstype}++;
 560   }
 561
 562   %xstypes = ();
 563   $xstypes{$args{outputmap_xstype}}++ if defined $args{outputmap_xstype};
 564   foreach my $map (@{$self->{output_section}}) {
 565     my $xstype = $map->xstype;
 566     croak("Multiple definition of xstype '$xstype' in OUTPUTMAP section")
 567       if exists $xstypes{$xstype};
 568     $xstypes{$xstype}++;
 569   }
 570
 571   return 1;
 572 }
 573
 574 sub _parse {
 575   my $self = shift;
 576   my $stringref = shift;
 577   my $filename = shift;
 578   $filename = '<string>' if not defined $filename;
 579
 580   # TODO comments should round-trip, currently ignoring
 581   # TODO order of sections, multiple sections of same type
 582   # Heavily influenced by ExtUtils::ParseXS
 583   my $section = 'typemap';
 584   my $lineno = 0;
 585   my $junk = "";
 586   my $current = \$junk;
 587   my @typemap_expr;
 588   my @input_expr;
 589   my @output_expr;
 590   while ($$stringref =~ /^(.*)$/gcm) {
 591     local $_ = $1;
 592     ++$lineno;
 593     chomp;
 594     next if /^\s*#/;
 595     if (/^INPUT\s*$/) {
 596       $section = 'input';
 597       $current = \$junk;
 598       next;
 599     }
 600     elsif (/^OUTPUT\s*$/) {
 601       $section = 'output';
 602       $current = \$junk;
 603       next;
 604     }
 605     elsif (/^TYPEMAP\s*$/) {
 606       $section = 'typemap';
 607       $current = \$junk;
 608       next;
 609     }
 610
 611     if ($section eq 'typemap') {
 612       my $line = $_;
 613       s/^\s+//; s/\s+$//;
 614       next if /^#/ or /^$/;
 615       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($Proto_Regexp*)$/o
 616         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
 617            next;
 618       #$proto = '' if not $proto;
 619       # prototype defaults to '$'
 620       #$proto = '$' unless $proto;
 621       #warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
 622       #  unless _valid_proto_string($proto);
 623       push @typemap_expr, ExtUtils::Typemaps::Type->new(
 624         xstype => $kind, proto => $proto, ctype => $type
 625       );
 626     } elsif (/^\s/) {
 627       $$current .= $$current eq '' ? $_ : "\n".$_;
 628     } elsif (/^$/) {
 629       next;
 630     } elsif ($section eq 'input') {
 631       s/\s+$//;
 632       push @input_expr, {xstype => $_, code => ''};
 633       $current = \$input_expr[-1]{code};
 634     } else { # output section
 635       s/\s+$//;
 636       push @output_expr, {xstype => $_, code => ''};
 637       $current = \$output_expr[-1]{code};
 638     }
 639
 640   } # end while lines
 641
 642   $self->{typemap_section} = \@typemap_expr;
 643   $self->{input_section}   = [ map {ExtUtils::Typemaps::InputMap->new(%$_) } @input_expr ];
 644   $self->{output_section}  = [ map {ExtUtils::Typemaps::OutputMap->new(%$_) } @output_expr ];
 645
 646   return $self->validate();
 647 }
 648
 649 # taken from ExtUtils::ParseXS
 650 sub _tidy_type {
 651   local $_ = shift;
 652
 653   # rationalise any '*' by joining them into bunches and removing whitespace
 654   s#\s*(\*+)\s*#$1#g;
 655   s#(\*+)# $1 #g ;
 656
 657   # trim leading & trailing whitespace
 658   s/^\s+//; s/\s+$//;
 659
 660   # change multiple whitespace into a single space
 661   s/\s+/ /g;
 662
 663   $_;
 664 }
 665
 666
 667 # taken from ExtUtils::ParseXS
 668 sub _valid_proto_string {
 669   my $string = shift;
 670   if ($string =~ /^$Proto_Regexp+$/o) {
 671     return $string;
 672   }
 673
 674   return 0 ;
 675 }
 676
 677 # taken from ExtUtils::ParseXS (C_string)
 678 sub _escape_backslashes {
 679   my $string = shift;
 680   $string =~ s[\\][\\\\]g;
 681   $string;
 682 }
 683
 684 =head1 CAVEATS
 685
 686 Not as well tested as I'd like it to be.
 687
 688 Inherits some evil code from C<ExtUtils::ParseXS>.
 689
 690 Adding more typemaps incurs an O(n) validation penalty
 691 that could be optimized with a hash.
 692
 693 =head1 SEE ALSO
 694
 695 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
 696
 697 For details on typemaps: L<perlxstut>, L<perlxs>.
 698
 699 =head1 AUTHOR
 700
 701 Steffen Mueller C<<smueller@cpan.org>>
 702
 703 =head1 COPYRIGHT & LICENSE
 704
 705 Copyright 2009-2010 Steffen Mueller
 706
 707 This program is free software; you can redistribute it and/or
 708 modify it under the same terms as Perl itself.
 709
 710 =cut
 711
 712 1;
 713