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