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