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     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     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}));
  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->{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     croak("Need ctype argument") if not defined $ctype;
 156     my $xstype = $args{xstype};
 157     croak("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     croak("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     croak("Need xstype argument") if not defined $xstype;
 224     my $code = $args{code};
 225     croak("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     croak("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     croak("Need xstype argument") if not defined $xstype;
 276     my $code = $args{code};
 277     croak("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     croak("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   croak("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     croak("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     croak("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     croak("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   my %args = @_;
 437   my $ctype = $args{ctype};
 438   croak("Need ctype argument") if not defined $ctype;
 439   $ctype = _tidy_type($ctype);
 440
 441   my $index = $self->{typemap_lookup}{$ctype};
 442   return() if not defined $index;
 443   return $self->{typemap_section}[$index];
 444 }
 445
 446 =head2 get_inputmap
 447
 448 Fetches an entry of the INPUT section of the
 449 typemap.
 450
 451 Mandatory named arguments: The C<xstype> of the
 452 entry.
 453
 454 Returns the C<ExtUtils::Typemaps::InputMap>
 455 object for the entry if found.
 456
 457 =cut
 458
 459 sub get_inputmap {
 460   my $self = shift;
 461   my %args = @_;
 462   my $xstype = $args{xstype};
 463   croak("Need xstype argument") if not defined $xstype;
 464
 465   my $index = $self->{input_lookup}{$xstype};
 466   return() if not defined $index;
 467   return $self->{input_section}[$index];
 468 }
 469
 470 =head2 get_outputmap
 471
 472 Fetches an entry of the OUTPUT section of the
 473 typemap.
 474
 475 Mandatory named arguments: The C<xstype> of the
 476 entry.
 477
 478 Returns the C<ExtUtils::Typemaps::InputMap>
 479 object for the entry if found.
 480
 481 =cut
 482
 483 sub get_outputmap {
 484   my $self = shift;
 485   my %args = @_;
 486   my $xstype = $args{xstype};
 487   croak("Need xstype argument") if not defined $xstype;
 488
 489   my $index = $self->{output_lookup}{$xstype};
 490   return() if not defined $index;
 491   return $self->{output_section}[$index];
 492 }
 493
 494 =head2 write
 495
 496 Write the typemap to a file. Optionally takes a C<file> argument. If given, the
 497 typemap will be written to the specified file. If not, the typemap is written
 498 to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
 499 it was read from if any).
 500
 501 =cut
 502
 503 sub write {
 504   my $self = shift;
 505   my %args = @_;
 506   my $file = defined $args{file} ? $args{file} : $self->file();
 507   croak("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
 508     if not defined $file;
 509
 510   open my $fh, '>', $file
 511     or die "Cannot open typemap file '$file' for writing: $!";
 512   print $fh $self->as_string();
 513   close $fh;
 514 }
 515
 516 =head2 as_string
 517
 518 Generates and returns the string form of the typemap.
 519
 520 =cut
 521
 522 sub as_string {
 523   my $self = shift;
 524   my $typemap = $self->{typemap_section};
 525   my @code;
 526   push @code, "TYPEMAP\n";
 527   foreach my $entry (@$typemap) {
 528     # type kind proto
 529     # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
 530     push @code, $entry->ctype . "\t" . $entry->xstype
 531               . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
 532   }
 533
 534   my $input = $self->{input_section};
 535   if (@$input) {
 536     push @code, "\nINPUT\n";
 537     foreach my $entry (@$input) {
 538       push @code, $entry->xstype, "\n", $entry->code, "\n";
 539     }
 540   }
 541
 542   my $output = $self->{output_section};
 543   if (@$output) {
 544     push @code, "\nOUTPUT\n";
 545     foreach my $entry (@$output) {
 546       push @code, $entry->xstype, "\n", $entry->code, "\n";
 547     }
 548   }
 549   return join '', @code;
 550 }
 551
 552 =head2 merge
 553
 554 Merges a given typemap into the object. Note that a failed merge
 555 operation leaves the object in an inconsistent state so clone it if necessary.
 556
 557 Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
 558 or C<file =E<gt> $path_to_typemap_file> but not both.
 559
 560 Optional arguments: C<replace =E<gt> 1> to force replacement
 561 of existing typemap entries without warning or C<skip =E<gt> 1>
 562 to skip entries that exist already in the typemap.
 563
 564 =cut
 565
 566 sub merge {
 567   my $self = shift;
 568   my %args = @_;
 569
 570   if (exists $args{typemap} and exists $args{file}) {
 571     croak("Need {file} OR {typemap} argument. Not both!");
 572   }
 573   elsif (not exists $args{typemap} and not exists $args{file}) {
 574     croak("Need {file} or {typemap} argument!");
 575   }
 576
 577   my $typemap = $args{typemap};
 578   if (not defined $typemap) {
 579     $typemap = ref($self)->new(file => $args{file});
 580   }
 581
 582   my @params;
 583   push @params, 'replace' => $args{replace} if exists $args{replace};
 584   push @params, 'skip' => $args{skip} if exists $args{skip};
 585
 586   # FIXME breaking encapsulation. Add accessor code.
 587   foreach my $entry (@{$typemap->{typemap_section}}) {
 588     $self->add_typemap( $entry, @params );
 589   }
 590
 591   foreach my $entry (@{$typemap->{input_section}}) {
 592     $self->add_inputmap( $entry, @params );
 593   }
 594
 595   foreach my $entry (@{$typemap->{output_section}}) {
 596     $self->add_outputmap( $entry, @params );
 597   }
 598
 599   return 1;
 600 }
 601
 602
 603 =head2 _get_typemap_hash
 604
 605 Returns a hash mapping the C types to the XS types:
 606
 607   {
 608     'char **' => 'T_PACKEDARRAY',
 609     'bool_t' => 'T_IV',
 610     'AV *' => 'T_AVREF',
 611     'InputStream' => 'T_IN',
 612     'double' => 'T_DOUBLE',
 613     # ...
 614   }
 615
 616 This is documented because it is used by C<ExtUtils::ParseXS>,
 617 but it's not intended for general consumption. May be removed
 618 at any time.
 619
 620 =cut
 621
 622 sub _get_typemap_hash {
 623   my $self = shift;
 624   my $lookup  = $self->{typemap_lookup};
 625   my $storage = $self->{typemap_section};
 626
 627   my %rv;
 628   foreach my $ctype (keys %$lookup) {
 629     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype;
 630   }
 631
 632   return \%rv;
 633 }
 634
 635 =head2 _get_inputmap_hash
 636
 637 Returns a hash mapping the XS types (identifiers) to the
 638 corresponding INPUT code:
 639
 640   {
 641     'T_CALLBACK' => '   $var = make_perl_cb_$type($arg)
 642   ',
 643     'T_OUT' => '    $var = IoOFP(sv_2io($arg))
 644   ',
 645     'T_REF_IV_PTR' => '   if (sv_isa($arg, \\"${ntype}\\")) {
 646     # ...
 647   }
 648
 649 This is documented because it is used by C<ExtUtils::ParseXS>,
 650 but it's not intended for general consumption. May be removed
 651 at any time.
 652
 653 =cut
 654
 655 sub _get_inputmap_hash {
 656   my $self = shift;
 657   my $lookup  = $self->{input_lookup};
 658   my $storage = $self->{input_section};
 659
 660   my %rv;
 661   foreach my $xstype (keys %$lookup) {
 662     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
 663
 664     # Squash trailing whitespace to one line break
 665     # This isn't strictly necessary, but makes the output more similar
 666     # to the original ExtUtils::ParseXS.
 667     $rv{$xstype} =~ s/\s*\z/\n/;
 668   }
 669
 670   return \%rv;
 671 }
 672
 673
 674 =head2 _get_outputmap_hash
 675
 676 Returns a hash mapping the XS types (identifiers) to the
 677 corresponding OUTPUT code:
 678
 679   {
 680     'T_CALLBACK' => '   sv_setpvn($arg, $var.context.value().chp(),
 681                 $var.context.value().size());
 682   ',
 683     'T_OUT' => '    {
 684             GV *gv = newGVgen("$Package");
 685             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
 686                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
 687             else
 688                 $arg = &PL_sv_undef;
 689          }
 690   ',
 691     # ...
 692   }
 693
 694 This is documented because it is used by C<ExtUtils::ParseXS>,
 695 but it's not intended for general consumption. May be removed
 696 at any time.
 697
 698 =cut
 699
 700 sub _get_outputmap_hash {
 701   my $self = shift;
 702   my $lookup  = $self->{output_lookup};
 703   my $storage = $self->{output_section};
 704
 705   my %rv;
 706   foreach my $xstype (keys %$lookup) {
 707     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
 708
 709     # Squash trailing whitespace to one line break
 710     # This isn't strictly necessary, but makes the output more similar
 711     # to the original ExtUtils::ParseXS.
 712     $rv{$xstype} =~ s/\s*\z/\n/;
 713   }
 714
 715   return \%rv;
 716 }
 717
 718 =head2 _get_prototype_hash
 719
 720 Returns a hash mapping the C types of the typemap to their
 721 corresponding prototypes.
 722
 723   {
 724     'char **' => '$',
 725     'bool_t' => '$',
 726     'AV *' => '$',
 727     'InputStream' => '$',
 728     'double' => '$',
 729     # ...
 730   }
 731
 732 This is documented because it is used by C<ExtUtils::ParseXS>,
 733 but it's not intended for general consumption. May be removed
 734 at any time.
 735
 736 =cut
 737
 738 sub _get_prototype_hash {
 739   my $self = shift;
 740   my $lookup  = $self->{typemap_lookup};
 741   my $storage = $self->{typemap_section};
 742
 743   my %rv;
 744   foreach my $ctype (keys %$lookup) {
 745     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
 746   }
 747
 748   return \%rv;
 749 }
 750
 751
 752
 753 # make sure that the provided types wouldn't collide with what's
 754 # in the object already.
 755 sub validate {
 756   my $self = shift;
 757   my %args = @_;
 758
 759   if ( exists $args{ctype}
 760        and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
 761   {
 762     croak("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
 763   }
 764
 765   if ( exists $args{inputmap_xstype}
 766        and exists $self->{input_lookup}{$args{inputmap_xstype}} )
 767   {
 768     croak("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
 769   }
 770
 771   if ( exists $args{outputmap_xstype}
 772        and exists $self->{output_lookup}{$args{outputmap_xstype}} )
 773   {
 774     croak("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
 775   }
 776
 777   return 1;
 778 }
 779
 780 sub _parse {
 781   my $self = shift;
 782   my $stringref = shift;
 783   my $filename = shift;
 784   $filename = '<string>' if not defined $filename;
 785
 786   # TODO comments should round-trip, currently ignoring
 787   # TODO order of sections, multiple sections of same type
 788   # Heavily influenced by ExtUtils::ParseXS
 789   my $section = 'typemap';
 790   my $lineno = 0;
 791   my $junk = "";
 792   my $current = \$junk;
 793   my @input_expr;
 794   my @output_expr;
 795   while ($$stringref =~ /^(.*)$/gcm) {
 796     local $_ = $1;
 797     ++$lineno;
 798     chomp;
 799     next if /^\s*#/;
 800     if (/^INPUT\s*$/) {
 801       $section = 'input';
 802       $current = \$junk;
 803       next;
 804     }
 805     elsif (/^OUTPUT\s*$/) {
 806       $section = 'output';
 807       $current = \$junk;
 808       next;
 809     }
 810     elsif (/^TYPEMAP\s*$/) {
 811       $section = 'typemap';
 812       $current = \$junk;
 813       next;
 814     }
 815
 816     if ($section eq 'typemap') {
 817       my $line = $_;
 818       s/^\s+//; s/\s+$//;
 819       next if $_ eq '' or /^#/;
 820       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
 821         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
 822            next;
 823       # prototype defaults to '$'
 824       $proto = '$' unless $proto;
 825       warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
 826         unless _valid_proto_string($proto);
 827       $self->add_typemap(
 828         ExtUtils::Typemaps::Type->new(
 829           xstype => $kind, proto => $proto, ctype => $type
 830         )
 831       );
 832     } elsif (/^\s/) {
 833       s/\s+$//;
 834       $$current .= $$current eq '' ? $_ : "\n".$_;
 835     } elsif ($_ eq '') {
 836       next;
 837     } elsif ($section eq 'input') {
 838       s/\s+$//;
 839       push @input_expr, {xstype => $_, code => ''};
 840       $current = \$input_expr[-1]{code};
 841     } else { # output section
 842       s/\s+$//;
 843       push @output_expr, {xstype => $_, code => ''};
 844       $current = \$output_expr[-1]{code};
 845     }
 846
 847   } # end while lines
 848
 849   foreach my $inexpr (@input_expr) {
 850     $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr) );
 851   }
 852   foreach my $outexpr (@output_expr) {
 853     $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr) );
 854   }
 855
 856   return 1;
 857 }
 858
 859 # taken from ExtUtils::ParseXS
 860 sub _tidy_type {
 861   local $_ = shift;
 862
 863   # rationalise any '*' by joining them into bunches and removing whitespace
 864   s#\s*(\*+)\s*#$1#g;
 865   s#(\*+)# $1 #g ;
 866
 867   # trim leading & trailing whitespace
 868   s/^\s+//; s/\s+$//;
 869
 870   # change multiple whitespace into a single space
 871   s/\s+/ /g;
 872
 873   $_;
 874 }
 875
 876
 877 # taken from ExtUtils::ParseXS
 878 sub _valid_proto_string {
 879   my $string = shift;
 880   if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
 881     return $string;
 882   }
 883
 884   return 0 ;
 885 }
 886
 887 # taken from ExtUtils::ParseXS (C_string)
 888 sub _escape_backslashes {
 889   my $string = shift;
 890   $string =~ s[\\][\\\\]g;
 891   $string;
 892 }
 893
 894 =head1 CAVEATS
 895
 896 Inherits some evil code from C<ExtUtils::ParseXS>.
 897
 898 =head1 SEE ALSO
 899
 900 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
 901
 902 For details on typemaps: L<perlxstut>, L<perlxs>.
 903
 904 =head1 AUTHOR
 905
 906 Steffen Mueller C<<smueller@cpan.org>>
 907
 908 =head1 COPYRIGHT & LICENSE
 909
 910 Copyright 2009-2011 Steffen Mueller
 911
 912 This program is free software; you can redistribute it and/or
 913 modify it under the same terms as Perl itself.
 914
 915 =cut
 916
 917 1;
 918