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

   1 package ExtUtils::Typemaps;
   2 use 5.006001;
   3 use strict;
   4 use warnings;
   5 our $VERSION = '1.00';
   6 #use Carp qw(croak);
   7
   8 require ExtUtils::ParseXS;
   9 require ExtUtils::ParseXS::Constants;
  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     die("Cannot handle both 'file' and 'string' arguments to constructor");
  75   }
  76
  77   my $self = bless {
  78     file            => undef,
  79     %args,
  80     typemap_section => [],
  81     typemap_lookup  => {},
  82     input_section   => [],
  83     input_lookup    => {},
  84     output_section  => [],
  85     output_lookup   => {},
  86   } => $class;
  87
  88   $self->_init();
  89
  90   return $self;
  91 }
  92
  93 sub _init {
  94   my $self = shift;
  95   if (defined $self->{string}) {
  96     $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename});
  97     delete $self->{string};
  98   }
  99   elsif (defined $self->{file} and -e $self->{file}) {
 100     open my $fh, '<', $self->{file}
 101       or die "Cannot open typemap file '"
 102              . $self->{file} . "' for reading: $!";
 103     local $/ = undef;
 104     my $string = <$fh>;
 105     $self->_parse(\$string, $self->{lineno_offset}, $self->{file});
 106   }
 107 }
 108
 109 =head2 file
 110
 111 Get/set the file that the typemap is written to when the
 112 C<write> method is called.
 113
 114 =cut
 115
 116 sub file {
 117   $_[0]->{file} = $_[1] if @_ > 1;
 118   $_[0]->{file}
 119 }
 120
 121 =head2 add_typemap
 122
 123 Add a C<TYPEMAP> entry to the typemap.
 124
 125 Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>)
 126 and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>).
 127
 128 Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
 129 existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1>
 130 triggers a I<"first come first serve"> logic by which new entries that conflict
 131 with existing entries are silently ignored.
 132
 133 As an alternative to the named parameters usage, you may pass in
 134 an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be
 135 added to the typemap. In that case, only the C<replace> or C<skip> named parameters
 136 may be used after the object. Example:
 137
 138   $map->add_typemap($type_obj, replace => 1);
 139
 140 =cut
 141
 142 sub add_typemap {
 143   my $self = shift;
 144   my $type;
 145   my %args;
 146
 147   if ((@_ % 2) == 1) {
 148     my $orig = shift;
 149     $type = $orig->new();
 150     %args = @_;
 151   }
 152   else {
 153     %args = @_;
 154     my $ctype = $args{ctype};
 155     die("Need ctype argument") if not defined $ctype;
 156     my $xstype = $args{xstype};
 157     die("Need xstype argument") if not defined $xstype;
 158
 159     $type = ExtUtils::Typemaps::Type->new(
 160       xstype      => $xstype,
 161       'prototype' => $args{'prototype'},
 162       ctype       => $ctype,
 163     );
 164   }
 165
 166   if ($args{skip} and $args{replace}) {
 167     die("Cannot use both 'skip' and 'replace'");
 168   }
 169
 170   if ($args{replace}) {
 171     $self->remove_typemap(ctype => $type->ctype);
 172   }
 173   elsif ($args{skip}) {
 174     return() if exists $self->{typemap_lookup}{$type->ctype};
 175   }
 176   else {
 177     $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
 178   }
 179
 180   # store
 181   push @{$self->{typemap_section}}, $type;
 182   # remember type for lookup, too.
 183   $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}};
 184
 185   return 1;
 186 }
 187
 188 =head2 add_inputmap
 189
 190 Add an C<INPUT> entry to the typemap.
 191
 192 Required named arguments:
 193 The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
 194 and the C<code> to associate with it for input.
 195
 196 Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
 197 existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1>
 198 triggers a I<"first come first serve"> logic by which new entries that conflict
 199 with existing entries are silently ignored.
 200
 201 As an alternative to the named parameters usage, you may pass in
 202 an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be
 203 added to the typemap. In that case, only the C<replace> or C<skip> named parameters
 204 may be used after the object. Example:
 205
 206   $map->add_inputmap($type_obj, replace => 1);
 207
 208 =cut
 209
 210 sub add_inputmap {
 211   my $self = shift;
 212   my $input;
 213   my %args;
 214
 215   if ((@_ % 2) == 1) {
 216     my $orig = shift;
 217     $input = $orig->new();
 218     %args = @_;
 219   }
 220   else {
 221     %args = @_;
 222     my $xstype = $args{xstype};
 223     die("Need xstype argument") if not defined $xstype;
 224     my $code = $args{code};
 225     die("Need code argument") if not defined $code;
 226
 227     $input = ExtUtils::Typemaps::InputMap->new(
 228       xstype => $xstype,
 229       code   => $code,
 230     );
 231   }
 232
 233   if ($args{skip} and $args{replace}) {
 234     die("Cannot use both 'skip' and 'replace'");
 235   }
 236
 237   if ($args{replace}) {
 238     $self->remove_inputmap(xstype => $input->xstype);
 239   }
 240   elsif ($args{skip}) {
 241     return() if exists $self->{input_lookup}{$input->xstype};
 242   }
 243   else {
 244     $self->validate(inputmap_xstype => $input->xstype);
 245   }
 246
 247   # store
 248   push @{$self->{input_section}}, $input;
 249   # remember type for lookup, too.
 250   $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}};
 251
 252   return 1;
 253 }
 254
 255 =head2 add_outputmap
 256
 257 Add an C<OUTPUT> entry to the typemap.
 258 Works exactly the same as C<add_inputmap>.
 259
 260 =cut
 261
 262 sub add_outputmap {
 263   my $self = shift;
 264   my $output;
 265   my %args;
 266
 267   if ((@_ % 2) == 1) {
 268     my $orig = shift;
 269     $output = $orig->new();
 270     %args = @_;
 271   }
 272   else {
 273     %args = @_;
 274     my $xstype = $args{xstype};
 275     die("Need xstype argument") if not defined $xstype;
 276     my $code = $args{code};
 277     die("Need code argument") if not defined $code;
 278
 279     $output = ExtUtils::Typemaps::OutputMap->new(
 280       xstype => $xstype,
 281       code   => $code,
 282     );
 283   }
 284
 285   if ($args{skip} and $args{replace}) {
 286     die("Cannot use both 'skip' and 'replace'");
 287   }
 288
 289   if ($args{replace}) {
 290     $self->remove_outputmap(xstype => $output->xstype);
 291   }
 292   elsif ($args{skip}) {
 293     return() if exists $self->{output_lookup}{$output->xstype};
 294   }
 295   else {
 296     $self->validate(outputmap_xstype => $output->xstype);
 297   }
 298
 299   # store
 300   push @{$self->{output_section}}, $output;
 301   # remember type for lookup, too.
 302   $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}};
 303
 304   return 1;
 305 }
 306
 307 =head2 add_string
 308
 309 Parses a string as a typemap and merge it into the typemap object.
 310
 311 Required named argument: C<string> to specify the string to parse.
 312
 313 =cut
 314
 315 sub add_string {
 316   my $self = shift;
 317   my %args = @_;
 318   die("Need 'string' argument") if not defined $args{string};
 319
 320   # no, this is not elegant.
 321   my $other = ExtUtils::Typemaps->new(string => $args{string});
 322   $self->merge(typemap => $other);
 323 }
 324
 325 =head2 remove_typemap
 326
 327 Removes a C<TYPEMAP> entry from the typemap.
 328
 329 Required named argument: C<ctype> to specify the entry to remove from the typemap.
 330
 331 Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.
 332
 333 =cut
 334
 335 sub remove_typemap {
 336   my $self = shift;
 337   my $ctype;
 338   if (@_ > 1) {
 339     my %args = @_;
 340     $ctype = $args{ctype};
 341     die("Need ctype argument") if not defined $ctype;
 342     $ctype = _tidy_type($ctype);
 343   }
 344   else {
 345     $ctype = $_[0]->tidy_ctype;
 346   }
 347
 348   return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup});
 349 }
 350
 351 =head2 remove_inputmap
 352
 353 Removes an C<INPUT> entry from the typemap.
 354
 355 Required named argument: C<xstype> to specify the entry to remove from the typemap.
 356
 357 Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.
 358
 359 =cut
 360
 361 sub remove_inputmap {
 362   my $self = shift;
 363   my $xstype;
 364   if (@_ > 1) {
 365     my %args = @_;
 366     $xstype = $args{xstype};
 367     die("Need xstype argument") if not defined $xstype;
 368   }
 369   else {
 370     $xstype = $_[0]->xstype;
 371   }
 372
 373   return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
 374 }
 375
 376 =head2 remove_inputmap
 377
 378 Removes an C<OUTPUT> entry from the typemap.
 379
 380 Required named argument: C<xstype> to specify the entry to remove from the typemap.
 381
 382 Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.
 383
 384 =cut
 385
 386 sub remove_outputmap {
 387   my $self = shift;
 388   my $xstype;
 389   if (@_ > 1) {
 390     my %args = @_;
 391     $xstype = $args{xstype};
 392     die("Need xstype argument") if not defined $xstype;
 393   }
 394   else {
 395     $xstype = $_[0]->xstype;
 396   }
 397
 398   return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup});
 399 }
 400
 401 sub _remove {
 402   my $self   = shift;
 403   my $rm     = shift;
 404   my $array  = shift;
 405   my $lookup = shift;
 406
 407   # Just fetch the index of the item from the lookup table
 408   my $index = $lookup->{$rm};
 409   return() if not defined $index;
 410
 411   # Nuke the item from storage
 412   splice(@$array, $index, 1);
 413
 414   # Decrement the storage position of all items thereafter
 415   foreach my $key (keys %$lookup) {
 416     if ($lookup->{$key} > $index) {
 417       $lookup->{$key}--;
 418     }
 419   }
 420   return();
 421 }
 422
 423 =head2 get_typemap
 424
 425 Fetches an entry of the TYPEMAP section of the typemap.
 426
 427 Mandatory named arguments: The C<ctype> of the entry.
 428
 429 Returns the C<ExtUtils::Typemaps::Type>
 430 object for the entry if found.
 431
 432 =cut
 433
 434 sub get_typemap {
 435   my $self = shift;
 436   die("Need named parameters, got uneven number") if @_ % 2;
 437
 438   my %args = @_;
 439   my $ctype = $args{ctype};
 440   die("Need ctype argument") if not defined $ctype;
 441   $ctype = _tidy_type($ctype);
 442
 443   my $index = $self->{typemap_lookup}{$ctype};
 444   return() if not defined $index;
 445   return $self->{typemap_section}[$index];
 446 }
 447
 448 =head2 get_inputmap
 449
 450 Fetches an entry of the INPUT section of the
 451 typemap.
 452
 453 Mandatory named arguments: The C<xstype> of the
 454 entry or the C<ctype> of the typemap that can be used to find
 455 the C<xstype>. To wit, the following pieces of code
 456 are equivalent:
 457
 458   my $type = $typemap->get_typemap(ctype => $ctype)
 459   my $input_map = $typemap->get_inputmap(xstype => $type->xstype);
 460
 461   my $input_map = $typemap->get_inputmap(ctype => $ctype);
 462
 463 Returns the C<ExtUtils::Typemaps::InputMap>
 464 object for the entry if found.
 465
 466 =cut
 467
 468 sub get_inputmap {
 469   my $self = shift;
 470   die("Need named parameters, got uneven number") if @_ % 2;
 471
 472   my %args = @_;
 473   my $xstype = $args{xstype};
 474   my $ctype  = $args{ctype};
 475   die("Need xstype or ctype argument")
 476     if not defined $xstype
 477     and not defined $ctype;
 478   die("Need xstype OR ctype arguments, not both")
 479     if defined $xstype and defined $ctype;
 480
 481   if (defined $ctype) {
 482     my $tm = $self->get_typemap(ctype => $ctype);
 483     $xstype = $tm && $tm->xstype;
 484     return() if not defined $xstype;
 485   }
 486
 487   my $index = $self->{input_lookup}{$xstype};
 488   return() if not defined $index;
 489   return $self->{input_section}[$index];
 490 }
 491
 492 =head2 get_outputmap
 493
 494 Fetches an entry of the OUTPUT section of the
 495 typemap.
 496
 497 Mandatory named arguments: The C<xstype> of the
 498 entry or the C<ctype> of the typemap that can be used to
 499 resolve the C<xstype>. (See above for an example.)
 500
 501 Returns the C<ExtUtils::Typemaps::InputMap>
 502 object for the entry if found.
 503
 504 =cut
 505
 506 sub get_outputmap {
 507   my $self = shift;
 508   die("Need named parameters, got uneven number") if @_ % 2;
 509
 510   my %args = @_;
 511   my $xstype = $args{xstype};
 512   my $ctype  = $args{ctype};
 513   die("Need xstype or ctype argument")
 514     if not defined $xstype
 515     and not defined $ctype;
 516   die("Need xstype OR ctype arguments, not both")
 517     if defined $xstype and defined $ctype;
 518
 519   if (defined $ctype) {
 520     my $tm = $self->get_typemap(ctype => $ctype);
 521     $xstype = $tm && $tm->xstype;
 522     return() if not defined $xstype;
 523   }
 524
 525   my $index = $self->{output_lookup}{$xstype};
 526   return() if not defined $index;
 527   return $self->{output_section}[$index];
 528 }
 529
 530 =head2 write
 531
 532 Write the typemap to a file. Optionally takes a C<file> argument. If given, the
 533 typemap will be written to the specified file. If not, the typemap is written
 534 to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
 535 it was read from if any).
 536
 537 =cut
 538
 539 sub write {
 540   my $self = shift;
 541   my %args = @_;
 542   my $file = defined $args{file} ? $args{file} : $self->file();
 543   die("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
 544     if not defined $file;
 545
 546   open my $fh, '>', $file
 547     or die "Cannot open typemap file '$file' for writing: $!";
 548   print $fh $self->as_string();
 549   close $fh;
 550 }
 551
 552 =head2 as_string
 553
 554 Generates and returns the string form of the typemap.
 555
 556 =cut
 557
 558 sub as_string {
 559   my $self = shift;
 560   my $typemap = $self->{typemap_section};
 561   my @code;
 562   push @code, "TYPEMAP\n";
 563   foreach my $entry (@$typemap) {
 564     # type kind proto
 565     # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
 566     push @code, $entry->ctype . "\t" . $entry->xstype
 567               . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
 568   }
 569
 570   my $input = $self->{input_section};
 571   if (@$input) {
 572     push @code, "\nINPUT\n";
 573     foreach my $entry (@$input) {
 574       push @code, $entry->xstype, "\n", $entry->code, "\n";
 575     }
 576   }
 577
 578   my $output = $self->{output_section};
 579   if (@$output) {
 580     push @code, "\nOUTPUT\n";
 581     foreach my $entry (@$output) {
 582       push @code, $entry->xstype, "\n", $entry->code, "\n";
 583     }
 584   }
 585   return join '', @code;
 586 }
 587
 588 =head2 merge
 589
 590 Merges a given typemap into the object. Note that a failed merge
 591 operation leaves the object in an inconsistent state so clone it if necessary.
 592
 593 Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
 594 or C<file =E<gt> $path_to_typemap_file> but not both.
 595
 596 Optional arguments: C<replace =E<gt> 1> to force replacement
 597 of existing typemap entries without warning or C<skip =E<gt> 1>
 598 to skip entries that exist already in the typemap.
 599
 600 =cut
 601
 602 sub merge {
 603   my $self = shift;
 604   my %args = @_;
 605
 606   if (exists $args{typemap} and exists $args{file}) {
 607     die("Need {file} OR {typemap} argument. Not both!");
 608   }
 609   elsif (not exists $args{typemap} and not exists $args{file}) {
 610     die("Need {file} or {typemap} argument!");
 611   }
 612
 613   my @params;
 614   push @params, 'replace' => $args{replace} if exists $args{replace};
 615   push @params, 'skip' => $args{skip} if exists $args{skip};
 616
 617   my $typemap = $args{typemap};
 618   if (not defined $typemap) {
 619     $typemap = ref($self)->new(file => $args{file}, @params);
 620   }
 621
 622   # FIXME breaking encapsulation. Add accessor code.
 623   foreach my $entry (@{$typemap->{typemap_section}}) {
 624     $self->add_typemap( $entry, @params );
 625   }
 626
 627   foreach my $entry (@{$typemap->{input_section}}) {
 628     $self->add_inputmap( $entry, @params );
 629   }
 630
 631   foreach my $entry (@{$typemap->{output_section}}) {
 632     $self->add_outputmap( $entry, @params );
 633   }
 634
 635   return 1;
 636 }
 637
 638 =head2 is_empty
 639
 640 Returns a bool indicating whether this typemap is entirely empty.
 641
 642 =cut
 643
 644 sub is_empty {
 645   my $self = shift;
 646
 647   return @{ $self->{typemap_section} } == 0
 648       && @{ $self->{input_section} } == 0
 649       && @{ $self->{output_section} } == 0;
 650 }
 651
 652 =head2 _get_typemap_hash
 653
 654 Returns a hash mapping the C types to the XS types:
 655
 656   {
 657     'char **' => 'T_PACKEDARRAY',
 658     'bool_t' => 'T_IV',
 659     'AV *' => 'T_AVREF',
 660     'InputStream' => 'T_IN',
 661     'double' => 'T_DOUBLE',
 662     # ...
 663   }
 664
 665 This is documented because it is used by C<ExtUtils::ParseXS>,
 666 but it's not intended for general consumption. May be removed
 667 at any time.
 668
 669 =cut
 670
 671 sub _get_typemap_hash {
 672   my $self = shift;
 673   my $lookup  = $self->{typemap_lookup};
 674   my $storage = $self->{typemap_section};
 675
 676   my %rv;
 677   foreach my $ctype (keys %$lookup) {
 678     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype;
 679   }
 680
 681   return \%rv;
 682 }
 683
 684 =head2 _get_inputmap_hash
 685
 686 Returns a hash mapping the XS types (identifiers) to the
 687 corresponding INPUT code:
 688
 689   {
 690     'T_CALLBACK' => '   $var = make_perl_cb_$type($arg)
 691   ',
 692     'T_OUT' => '    $var = IoOFP(sv_2io($arg))
 693   ',
 694     'T_REF_IV_PTR' => '   if (sv_isa($arg, \\"${ntype}\\")) {
 695     # ...
 696   }
 697
 698 This is documented because it is used by C<ExtUtils::ParseXS>,
 699 but it's not intended for general consumption. May be removed
 700 at any time.
 701
 702 =cut
 703
 704 sub _get_inputmap_hash {
 705   my $self = shift;
 706   my $lookup  = $self->{input_lookup};
 707   my $storage = $self->{input_section};
 708
 709   my %rv;
 710   foreach my $xstype (keys %$lookup) {
 711     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
 712
 713     # Squash trailing whitespace to one line break
 714     # This isn't strictly necessary, but makes the output more similar
 715     # to the original ExtUtils::ParseXS.
 716     $rv{$xstype} =~ s/\s*\z/\n/;
 717   }
 718
 719   return \%rv;
 720 }
 721
 722
 723 =head2 _get_outputmap_hash
 724
 725 Returns a hash mapping the XS types (identifiers) to the
 726 corresponding OUTPUT code:
 727
 728   {
 729     'T_CALLBACK' => '   sv_setpvn($arg, $var.context.value().chp(),
 730                 $var.context.value().size());
 731   ',
 732     'T_OUT' => '    {
 733             GV *gv = newGVgen("$Package");
 734             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
 735                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
 736             else
 737                 $arg = &PL_sv_undef;
 738          }
 739   ',
 740     # ...
 741   }
 742
 743 This is documented because it is used by C<ExtUtils::ParseXS>,
 744 but it's not intended for general consumption. May be removed
 745 at any time.
 746
 747 =cut
 748
 749 sub _get_outputmap_hash {
 750   my $self = shift;
 751   my $lookup  = $self->{output_lookup};
 752   my $storage = $self->{output_section};
 753
 754   my %rv;
 755   foreach my $xstype (keys %$lookup) {
 756     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
 757
 758     # Squash trailing whitespace to one line break
 759     # This isn't strictly necessary, but makes the output more similar
 760     # to the original ExtUtils::ParseXS.
 761     $rv{$xstype} =~ s/\s*\z/\n/;
 762   }
 763
 764   return \%rv;
 765 }
 766
 767 =head2 _get_prototype_hash
 768
 769 Returns a hash mapping the C types of the typemap to their
 770 corresponding prototypes.
 771
 772   {
 773     'char **' => '$',
 774     'bool_t' => '$',
 775     'AV *' => '$',
 776     'InputStream' => '$',
 777     'double' => '$',
 778     # ...
 779   }
 780
 781 This is documented because it is used by C<ExtUtils::ParseXS>,
 782 but it's not intended for general consumption. May be removed
 783 at any time.
 784
 785 =cut
 786
 787 sub _get_prototype_hash {
 788   my $self = shift;
 789   my $lookup  = $self->{typemap_lookup};
 790   my $storage = $self->{typemap_section};
 791
 792   my %rv;
 793   foreach my $ctype (keys %$lookup) {
 794     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
 795   }
 796
 797   return \%rv;
 798 }
 799
 800
 801
 802 # make sure that the provided types wouldn't collide with what's
 803 # in the object already.
 804 sub validate {
 805   my $self = shift;
 806   my %args = @_;
 807
 808   if ( exists $args{ctype}
 809        and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
 810   {
 811     die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
 812   }
 813
 814   if ( exists $args{inputmap_xstype}
 815        and exists $self->{input_lookup}{$args{inputmap_xstype}} )
 816   {
 817     die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
 818   }
 819
 820   if ( exists $args{outputmap_xstype}
 821        and exists $self->{output_lookup}{$args{outputmap_xstype}} )
 822   {
 823     die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
 824   }
 825
 826   return 1;
 827 }
 828
 829 sub _parse {
 830   my $self = shift;
 831   my $stringref = shift;
 832   my $lineno_offset = shift;
 833   $lineno_offset = 0 if not defined $lineno_offset;
 834   my $filename = shift;
 835   $filename = '<string>' if not defined $filename;
 836
 837   my $replace = $self->{replace};
 838   my $skip    = $self->{skip};
 839   die "Can only replace OR skip" if $replace and $skip;
 840   my @add_params;
 841   push @add_params, replace => 1 if $replace;
 842   push @add_params, skip    => 1 if $skip;
 843
 844   # TODO comments should round-trip, currently ignoring
 845   # TODO order of sections, multiple sections of same type
 846   # Heavily influenced by ExtUtils::ParseXS
 847   my $section = 'typemap';
 848   my $lineno = $lineno_offset;
 849   my $junk = "";
 850   my $current = \$junk;
 851   my @input_expr;
 852   my @output_expr;
 853   while ($$stringref =~ /^(.*)$/gcm) {
 854     local $_ = $1;
 855     ++$lineno;
 856     chomp;
 857     next if /^\s*#/;
 858     if (/^INPUT\s*$/) {
 859       $section = 'input';
 860       $current = \$junk;
 861       next;
 862     }
 863     elsif (/^OUTPUT\s*$/) {
 864       $section = 'output';
 865       $current = \$junk;
 866       next;
 867     }
 868     elsif (/^TYPEMAP\s*$/) {
 869       $section = 'typemap';
 870       $current = \$junk;
 871       next;
 872     }
 873
 874     if ($section eq 'typemap') {
 875       my $line = $_;
 876       s/^\s+//; s/\s+$//;
 877       next if $_ eq '' or /^#/;
 878       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
 879         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
 880            next;
 881       # prototype defaults to '$'
 882       $proto = '$' unless $proto;
 883       warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
 884         unless _valid_proto_string($proto);
 885       $self->add_typemap(
 886         ExtUtils::Typemaps::Type->new(
 887           xstype => $kind, proto => $proto, ctype => $type
 888         ),
 889         @add_params
 890       );
 891     } elsif (/^\s/) {
 892       s/\s+$//;
 893       $$current .= $$current eq '' ? $_ : "\n".$_;
 894     } elsif ($_ eq '') {
 895       next;
 896     } elsif ($section eq 'input') {
 897       s/\s+$//;
 898       push @input_expr, {xstype => $_, code => ''};
 899       $current = \$input_expr[-1]{code};
 900     } else { # output section
 901       s/\s+$//;
 902       push @output_expr, {xstype => $_, code => ''};
 903       $current = \$output_expr[-1]{code};
 904     }
 905
 906   } # end while lines
 907
 908   foreach my $inexpr (@input_expr) {
 909     $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params );
 910   }
 911   foreach my $outexpr (@output_expr) {
 912     $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params );
 913   }
 914
 915   return 1;
 916 }
 917
 918 # taken from ExtUtils::ParseXS
 919 sub _tidy_type {
 920   local $_ = shift;
 921
 922   # rationalise any '*' by joining them into bunches and removing whitespace
 923   s#\s*(\*+)\s*#$1#g;
 924   s#(\*+)# $1 #g ;
 925
 926   # trim leading & trailing whitespace
 927   s/^\s+//; s/\s+$//;
 928
 929   # change multiple whitespace into a single space
 930   s/\s+/ /g;
 931
 932   $_;
 933 }
 934
 935
 936 # taken from ExtUtils::ParseXS
 937 sub _valid_proto_string {
 938   my $string = shift;
 939   if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
 940     return $string;
 941   }
 942
 943   return 0 ;
 944 }
 945
 946 # taken from ExtUtils::ParseXS (C_string)
 947 sub _escape_backslashes {
 948   my $string = shift;
 949   $string =~ s[\\][\\\\]g;
 950   $string;
 951 }
 952
 953 =head1 CAVEATS
 954
 955 Inherits some evil code from C<ExtUtils::ParseXS>.
 956
 957 =head1 SEE ALSO
 958
 959 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
 960
 961 For details on typemaps: L<perlxstut>, L<perlxs>.
 962
 963 =head1 AUTHOR
 964
 965 Steffen Mueller C<<smueller@cpan.org>>
 966
 967 =head1 COPYRIGHT & LICENSE
 968
 969 Copyright 2009-2011 Steffen Mueller
 970
 971 This program is free software; you can redistribute it and/or
 972 modify it under the same terms as Perl itself.
 973
 974 =cut
 975
 976 1;
 977