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
 665   return \%rv;
 666 }
 667
 668
 669 =head2 _get_outputmap_hash
 670
 671 Returns a hash mapping the XS types (identifiers) to the
 672 corresponding OUTPUT code:
 673
 674   {
 675     'T_CALLBACK' => '   sv_setpvn($arg, $var.context.value().chp(),
 676                 $var.context.value().size());
 677   ',
 678     'T_OUT' => '    {
 679             GV *gv = newGVgen("$Package");
 680             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
 681                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
 682             else
 683                 $arg = &PL_sv_undef;
 684          }
 685   ',
 686     # ...
 687   }
 688
 689 This is documented because it is used by C<ExtUtils::ParseXS>,
 690 but it's not intended for general consumption. May be removed
 691 at any time.
 692
 693 =cut
 694
 695 sub _get_outputmap_hash {
 696   my $self = shift;
 697   my $lookup  = $self->{output_lookup};
 698   my $storage = $self->{output_section};
 699
 700   my %rv;
 701   foreach my $xstype (keys %$lookup) {
 702     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
 703   }
 704
 705   return \%rv;
 706 }
 707
 708 =head2 _get_prototype_hash
 709
 710 Returns a hash mapping the C types of the typemap to their
 711 corresponding prototypes.
 712
 713   {
 714     'char **' => '$',
 715     'bool_t' => '$',
 716     'AV *' => '$',
 717     'InputStream' => '$',
 718     'double' => '$',
 719     # ...
 720   }
 721
 722 This is documented because it is used by C<ExtUtils::ParseXS>,
 723 but it's not intended for general consumption. May be removed
 724 at any time.
 725
 726 =cut
 727
 728 sub _get_prototype_hash {
 729   my $self = shift;
 730   my $lookup  = $self->{typemap_lookup};
 731   my $storage = $self->{typemap_section};
 732
 733   my %rv;
 734   foreach my $ctype (keys %$lookup) {
 735     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
 736   }
 737
 738   return \%rv;
 739 }
 740
 741
 742
 743 # make sure that the provided types wouldn't collide with what's
 744 # in the object already.
 745 sub validate {
 746   my $self = shift;
 747   my %args = @_;
 748
 749   if ( exists $args{ctype}
 750        and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
 751   {
 752     croak("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
 753   }
 754
 755   if ( exists $args{inputmap_xstype}
 756        and exists $self->{input_lookup}{$args{inputmap_xstype}} )
 757   {
 758     croak("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
 759   }
 760
 761   if ( exists $args{outputmap_xstype}
 762        and exists $self->{output_lookup}{$args{outputmap_xstype}} )
 763   {
 764     croak("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
 765   }
 766
 767   return 1;
 768 }
 769
 770 sub _parse {
 771   my $self = shift;
 772   my $stringref = shift;
 773   my $filename = shift;
 774   $filename = '<string>' if not defined $filename;
 775
 776   # TODO comments should round-trip, currently ignoring
 777   # TODO order of sections, multiple sections of same type
 778   # Heavily influenced by ExtUtils::ParseXS
 779   my $section = 'typemap';
 780   my $lineno = 0;
 781   my $junk = "";
 782   my $current = \$junk;
 783   my @input_expr;
 784   my @output_expr;
 785   while ($$stringref =~ /^(.*)$/gcm) {
 786     local $_ = $1;
 787     ++$lineno;
 788     chomp;
 789     next if /^\s*#/;
 790     if (/^INPUT\s*$/) {
 791       $section = 'input';
 792       $current = \$junk;
 793       next;
 794     }
 795     elsif (/^OUTPUT\s*$/) {
 796       $section = 'output';
 797       $current = \$junk;
 798       next;
 799     }
 800     elsif (/^TYPEMAP\s*$/) {
 801       $section = 'typemap';
 802       $current = \$junk;
 803       next;
 804     }
 805
 806     if ($section eq 'typemap') {
 807       my $line = $_;
 808       s/^\s+//; s/\s+$//;
 809       next if /^#/ or /^$/;
 810       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
 811         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
 812            next;
 813       #$proto = '' if not $proto;
 814       # prototype defaults to '$'
 815       #$proto = '$' unless $proto;
 816       #warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
 817       #  unless _valid_proto_string($proto);
 818       $self->add_typemap(
 819         ExtUtils::Typemaps::Type->new(
 820           xstype => $kind, proto => $proto, ctype => $type
 821         )
 822       );
 823     } elsif (/^\s/) {
 824       $$current .= $$current eq '' ? $_ : "\n".$_;
 825     } elsif (/^$/) {
 826       next;
 827     } elsif ($section eq 'input') {
 828       s/\s+$//;
 829       push @input_expr, {xstype => $_, code => ''};
 830       $current = \$input_expr[-1]{code};
 831     } else { # output section
 832       s/\s+$//;
 833       push @output_expr, {xstype => $_, code => ''};
 834       $current = \$output_expr[-1]{code};
 835     }
 836
 837   } # end while lines
 838
 839   foreach my $inexpr (@input_expr) {
 840     $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr) );
 841   }
 842   foreach my $outexpr (@output_expr) {
 843     $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr) );
 844   }
 845
 846   return 1;
 847 }
 848
 849 # taken from ExtUtils::ParseXS
 850 sub _tidy_type {
 851   local $_ = shift;
 852
 853   # rationalise any '*' by joining them into bunches and removing whitespace
 854   s#\s*(\*+)\s*#$1#g;
 855   s#(\*+)# $1 #g ;
 856
 857   # trim leading & trailing whitespace
 858   s/^\s+//; s/\s+$//;
 859
 860   # change multiple whitespace into a single space
 861   s/\s+/ /g;
 862
 863   $_;
 864 }
 865
 866
 867 # taken from ExtUtils::ParseXS
 868 sub _valid_proto_string {
 869   my $string = shift;
 870   if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
 871     return $string;
 872   }
 873
 874   return 0 ;
 875 }
 876
 877 # taken from ExtUtils::ParseXS (C_string)
 878 sub _escape_backslashes {
 879   my $string = shift;
 880   $string =~ s[\\][\\\\]g;
 881   $string;
 882 }
 883
 884 =head1 CAVEATS
 885
 886 Inherits some evil code from C<ExtUtils::ParseXS>.
 887
 888 =head1 SEE ALSO
 889
 890 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
 891
 892 For details on typemaps: L<perlxstut>, L<perlxs>.
 893
 894 =head1 AUTHOR
 895
 896 Steffen Mueller C<<smueller@cpan.org>>
 897
 898 =head1 COPYRIGHT & LICENSE
 899
 900 Copyright 2009-2011 Steffen Mueller
 901
 902 This program is free software; you can redistribute it and/or
 903 modify it under the same terms as Perl itself.
 904
 905 =cut
 906
 907 1;
 908