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

   1 package ExtUtils::Typemaps;
   2 use 5.006001;
   3 use strict;
   4 use warnings;
   5 our $VERSION = '0.05';
   6 use Carp qw(croak);
   7
   8 our $Proto_Regexp = "[" . quotemeta('\$%&*@;[]') . "]";
   9
  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>.
 130
 131 As an alternative to the named parameters usage, you may pass in
 132 an C<ExtUtils::Typemaps::Type> object, a copy of which will be
 133 added to the typemap.
 134
 135 =cut
 136
 137 sub add_typemap {
 138   my $self = shift;
 139   my $type;
 140   my $replace = 0;
 141   if (@_ == 1) {
 142     my $orig = shift;
 143     $type = $orig->new(@_);
 144   }
 145   else {
 146     my %args = @_;
 147     my $ctype = $args{ctype};
 148     croak("Need ctype argument") if not defined $ctype;
 149     my $xstype = $args{xstype};
 150     croak("Need xstype argument") if not defined $xstype;
 151
 152     $type = ExtUtils::Typemaps::Type->new(
 153       xstype      => $xstype,
 154       'prototype' => $args{'prototype'},
 155       ctype       => $ctype,
 156     );
 157     $replace = $args{replace};
 158   }
 159
 160   if ($replace) {
 161     $self->remove_typemap(ctype => $type->ctype);
 162   } else {
 163     $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
 164   }
 165
 166   # store
 167   push @{$self->{typemap_section}}, $type;
 168   # remember type for lookup, too.
 169   $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}};
 170
 171   return 1;
 172 }
 173
 174 =head2 add_inputmap
 175
 176 Add an C<INPUT> entry to the typemap.
 177
 178 Required named arguments:
 179 The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
 180 and the C<code> to associate with it for input.
 181
 182 Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
 183 existing C<INPUT> entries of the same C<xstype>.
 184
 185 You may pass in a single C<ExtUtils::Typemaps::InputMap> object instead,
 186 a copy of which will be added to the typemap.
 187
 188 =cut
 189
 190 sub add_inputmap {
 191   my $self = shift;
 192   my $input;
 193   my $replace = 0;
 194   if (@_ == 1) {
 195     my $orig = shift;
 196     $input = $orig->new(@_);
 197   }
 198   else {
 199     my %args = @_;
 200     my $xstype = $args{xstype};
 201     croak("Need xstype argument") if not defined $xstype;
 202     my $code = $args{code};
 203     croak("Need code argument") if not defined $code;
 204
 205     $input = ExtUtils::Typemaps::InputMap->new(
 206       xstype => $xstype,
 207       code   => $code,
 208     );
 209     $replace = $args{replace};
 210   }
 211   if ($replace) {
 212     $self->remove_inputmap(xstype => $input->xstype);
 213   } else {
 214     $self->validate(inputmap_xstype => $input->xstype);
 215   }
 216
 217   # store
 218   push @{$self->{input_section}}, $input;
 219   # remember type for lookup, too.
 220   $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}};
 221
 222   return 1;
 223 }
 224
 225 =head2 add_outputmap
 226
 227 Add an C<OUTPUT> entry to the typemap.
 228 Works exactly the same as C<add_inputmap>.
 229
 230 =cut
 231
 232 sub add_outputmap {
 233   my $self = shift;
 234   my $output;
 235   my $replace = 0;
 236   if (@_ == 1) {
 237     my $orig = shift;
 238     $output = $orig->new(@_);
 239   }
 240   else {
 241     my %args = @_;
 242     my $xstype = $args{xstype};
 243     croak("Need xstype argument") if not defined $xstype;
 244     my $code = $args{code};
 245     croak("Need code argument") if not defined $code;
 246
 247     $output = ExtUtils::Typemaps::OutputMap->new(
 248       xstype => $xstype,
 249       code   => $code,
 250     );
 251     $replace = $args{replace};
 252   }
 253   if ($replace) {
 254     $self->remove_outputmap(xstype => $output->xstype);
 255   } else {
 256     $self->validate(outputmap_xstype => $output->xstype);
 257   }
 258
 259   # store
 260   push @{$self->{output_section}}, $output;
 261   # remember type for lookup, too.
 262   $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}};
 263
 264   return 1;
 265 }
 266
 267 =head2 add_string
 268
 269 Parses a string as a typemap and merge it into the typemap object.
 270
 271 Required named argument: C<string> to specify the string to parse.
 272
 273 =cut
 274
 275 sub add_string {
 276   my $self = shift;
 277   my %args = @_;
 278   croak("Need 'string' argument") if not defined $args{string};
 279
 280   # no, this is not elegant.
 281   my $other = ExtUtils::Typemaps->new(string => $args{string});
 282   $self->merge(typemap => $other);
 283 }
 284
 285 =head2 remove_typemap
 286
 287 Removes a C<TYPEMAP> entry from the typemap.
 288
 289 Required named argument: C<ctype> to specify the entry to remove from the typemap.
 290
 291 Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.
 292
 293 =cut
 294
 295 sub remove_typemap {
 296   my $self = shift;
 297   my $ctype;
 298   if (@_ > 1) {
 299     my %args = @_;
 300     $ctype = $args{ctype};
 301     croak("Need ctype argument") if not defined $ctype;
 302     $ctype = _tidy_type($ctype);
 303   }
 304   else {
 305     $ctype = $_[0]->tidy_ctype;
 306   }
 307
 308   return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup});
 309 }
 310
 311 =head2 remove_inputmap
 312
 313 Removes an C<INPUT> entry from the typemap.
 314
 315 Required named argument: C<xstype> to specify the entry to remove from the typemap.
 316
 317 Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.
 318
 319 =cut
 320
 321 sub remove_inputmap {
 322   my $self = shift;
 323   my $xstype;
 324   if (@_ > 1) {
 325     my %args = @_;
 326     $xstype = $args{xstype};
 327     croak("Need xstype argument") if not defined $xstype;
 328   }
 329   else {
 330     $xstype = $_[0]->xstype;
 331   }
 332
 333   return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
 334 }
 335
 336 =head2 remove_inputmap
 337
 338 Removes an C<OUTPUT> entry from the typemap.
 339
 340 Required named argument: C<xstype> to specify the entry to remove from the typemap.
 341
 342 Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.
 343
 344 =cut
 345
 346 sub remove_outputmap {
 347   my $self = shift;
 348   my $xstype;
 349   if (@_ > 1) {
 350     my %args = @_;
 351     $xstype = $args{xstype};
 352     croak("Need xstype argument") if not defined $xstype;
 353   }
 354   else {
 355     $xstype = $_[0]->xstype;
 356   }
 357
 358   return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup});
 359 }
 360
 361 sub _remove {
 362   my $self   = shift;
 363   my $rm     = shift;
 364   my $array  = shift;
 365   my $lookup = shift;
 366
 367   # Just fetch the index of the item from the lookup table
 368   my $index = $lookup->{$rm};
 369   return() if not defined $index;
 370
 371   # Nuke the item from storage
 372   splice(@$array, $index, 1);
 373
 374   # Decrement the storage position of all items thereafter
 375   foreach my $key (keys %$lookup) {
 376     if ($lookup->{$key} > $index) {
 377       $lookup->{$key}--;
 378     }
 379   }
 380   return();
 381 }
 382
 383 =head2 get_typemap
 384
 385 Fetches an entry of the TYPEMAP section of the typemap.
 386
 387 Mandatory named arguments: The C<ctype> of the entry.
 388
 389 Returns the C<ExtUtils::Typemaps::Type>
 390 object for the entry if found.
 391
 392 =cut
 393
 394 sub get_typemap {
 395   my $self = shift;
 396   my %args = @_;
 397   my $ctype = $args{ctype};
 398   croak("Need ctype argument") if not defined $ctype;
 399   $ctype = _tidy_type($ctype);
 400
 401   my $index = $self->{typemap_lookup}{$ctype};
 402   return() if not defined $index;
 403   return $self->{typemap_section}[$index];
 404 }
 405
 406 =head2 get_inputmap
 407
 408 Fetches an entry of the INPUT section of the
 409 typemap.
 410
 411 Mandatory named arguments: The C<xstype> of the
 412 entry.
 413
 414 Returns the C<ExtUtils::Typemaps::InputMap>
 415 object for the entry if found.
 416
 417 =cut
 418
 419 sub get_inputmap {
 420   my $self = shift;
 421   my %args = @_;
 422   my $xstype = $args{xstype};
 423   croak("Need xstype argument") if not defined $xstype;
 424
 425   my $index = $self->{input_lookup}{$xstype};
 426   return() if not defined $index;
 427   return $self->{input_section}[$index];
 428 }
 429
 430 =head2 get_outputmap
 431
 432 Fetches an entry of the OUTPUT section of the
 433 typemap.
 434
 435 Mandatory named arguments: The C<xstype> of the
 436 entry.
 437
 438 Returns the C<ExtUtils::Typemaps::InputMap>
 439 object for the entry if found.
 440
 441 =cut
 442
 443 sub get_outputmap {
 444   my $self = shift;
 445   my %args = @_;
 446   my $xstype = $args{xstype};
 447   croak("Need xstype argument") if not defined $xstype;
 448
 449   my $index = $self->{output_lookup}{$xstype};
 450   return() if not defined $index;
 451   return $self->{output_section}[$index];
 452 }
 453
 454 =head2 write
 455
 456 Write the typemap to a file. Optionally takes a C<file> argument. If given, the
 457 typemap will be written to the specified file. If not, the typemap is written
 458 to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
 459 it was read from if any).
 460
 461 =cut
 462
 463 sub write {
 464   my $self = shift;
 465   my %args = @_;
 466   my $file = defined $args{file} ? $args{file} : $self->file();
 467   croak("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
 468     if not defined $file;
 469
 470   open my $fh, '>', $file
 471     or die "Cannot open typemap file '$file' for writing: $!";
 472   print $fh $self->as_string();
 473   close $fh;
 474 }
 475
 476 =head2 as_string
 477
 478 Generates and returns the string form of the typemap.
 479
 480 =cut
 481
 482 sub as_string {
 483   my $self = shift;
 484   my $typemap = $self->{typemap_section};
 485   my @code;
 486   push @code, "TYPEMAP\n";
 487   foreach my $entry (@$typemap) {
 488     # type kind proto
 489     # /^(.*?\S)\s+(\S+)\s*($Proto_Regexp*)$/o
 490     push @code, $entry->ctype . "\t" . $entry->xstype
 491               . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
 492   }
 493
 494   my $input = $self->{input_section};
 495   if (@$input) {
 496     push @code, "\nINPUT\n";
 497     foreach my $entry (@$input) {
 498       push @code, $entry->xstype, "\n", $entry->code, "\n";
 499     }
 500   }
 501
 502   my $output = $self->{output_section};
 503   if (@$output) {
 504     push @code, "\nOUTPUT\n";
 505     foreach my $entry (@$output) {
 506       push @code, $entry->xstype, "\n", $entry->code, "\n";
 507     }
 508   }
 509   return join '', @code;
 510 }
 511
 512 =head2 merge
 513
 514 Merges a given typemap into the object. Note that a failed merge
 515 operation leaves the object in an inconsistent state so clone if necessary.
 516
 517 Mandatory named argument: C<typemap =E<gt> $another_typemap>
 518
 519 Optional argument: C<replace =E<gt> 1> to force replacement
 520 of existing typemap entries without warning.
 521
 522 =cut
 523
 524 sub merge {
 525   my $self = shift;
 526   my %args = @_;
 527   my $typemap = $args{typemap};
 528   croak("Need ExtUtils::Typemaps as argument")
 529     if not ref $typemap or not $typemap->isa('ExtUtils::Typemaps');
 530
 531   my $replace = $args{replace};
 532
 533   # FIXME breaking encapsulation. Add accessor code.
 534   #
 535   foreach my $entry (@{$typemap->{typemap_section}}) {
 536     $self->add_typemap( $entry );
 537   }
 538
 539   foreach my $entry (@{$typemap->{input_section}}) {
 540     $self->add_inputmap( $entry );
 541   }
 542
 543   foreach my $entry (@{$typemap->{output_section}}) {
 544     $self->add_outputmap( $entry );
 545   }
 546
 547   return 1;
 548 }
 549
 550
 551 # make sure that the provided types wouldn't collide with what's
 552 # in the object already.
 553 sub validate {
 554   my $self = shift;
 555   my %args = @_;
 556
 557   if ( exists $args{ctype}
 558        and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
 559   {
 560     croak("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
 561   }
 562
 563   if ( exists $args{inputmap_xstype}
 564        and exists $self->{input_lookup}{$args{inputmap_xstype}} )
 565   {
 566     croak("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
 567   }
 568
 569   if ( exists $args{outputmap_xstype}
 570        and exists $self->{output_lookup}{$args{outputmap_xstype}} )
 571   {
 572     croak("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
 573   }
 574
 575   return 1;
 576 }
 577
 578 sub _parse {
 579   my $self = shift;
 580   my $stringref = shift;
 581   my $filename = shift;
 582   $filename = '<string>' if not defined $filename;
 583
 584   # TODO comments should round-trip, currently ignoring
 585   # TODO order of sections, multiple sections of same type
 586   # Heavily influenced by ExtUtils::ParseXS
 587   my $section = 'typemap';
 588   my $lineno = 0;
 589   my $junk = "";
 590   my $current = \$junk;
 591   my @input_expr;
 592   my @output_expr;
 593   while ($$stringref =~ /^(.*)$/gcm) {
 594     local $_ = $1;
 595     ++$lineno;
 596     chomp;
 597     next if /^\s*#/;
 598     if (/^INPUT\s*$/) {
 599       $section = 'input';
 600       $current = \$junk;
 601       next;
 602     }
 603     elsif (/^OUTPUT\s*$/) {
 604       $section = 'output';
 605       $current = \$junk;
 606       next;
 607     }
 608     elsif (/^TYPEMAP\s*$/) {
 609       $section = 'typemap';
 610       $current = \$junk;
 611       next;
 612     }
 613
 614     if ($section eq 'typemap') {
 615       my $line = $_;
 616       s/^\s+//; s/\s+$//;
 617       next if /^#/ or /^$/;
 618       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($Proto_Regexp*)$/o
 619         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
 620            next;
 621       #$proto = '' if not $proto;
 622       # prototype defaults to '$'
 623       #$proto = '$' unless $proto;
 624       #warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
 625       #  unless _valid_proto_string($proto);
 626       $self->add_typemap(
 627         ExtUtils::Typemaps::Type->new(
 628           xstype => $kind, proto => $proto, ctype => $type
 629         )
 630       );
 631     } elsif (/^\s/) {
 632       $$current .= $$current eq '' ? $_ : "\n".$_;
 633     } elsif (/^$/) {
 634       next;
 635     } elsif ($section eq 'input') {
 636       s/\s+$//;
 637       push @input_expr, {xstype => $_, code => ''};
 638       $current = \$input_expr[-1]{code};
 639     } else { # output section
 640       s/\s+$//;
 641       push @output_expr, {xstype => $_, code => ''};
 642       $current = \$output_expr[-1]{code};
 643     }
 644
 645   } # end while lines
 646
 647   foreach my $inexpr (@input_expr) {
 648     $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr) );
 649   }
 650   foreach my $outexpr (@output_expr) {
 651     $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr) );
 652   }
 653
 654   return 1;
 655 }
 656
 657 # taken from ExtUtils::ParseXS
 658 sub _tidy_type {
 659   local $_ = shift;
 660
 661   # rationalise any '*' by joining them into bunches and removing whitespace
 662   s#\s*(\*+)\s*#$1#g;
 663   s#(\*+)# $1 #g ;
 664
 665   # trim leading & trailing whitespace
 666   s/^\s+//; s/\s+$//;
 667
 668   # change multiple whitespace into a single space
 669   s/\s+/ /g;
 670
 671   $_;
 672 }
 673
 674
 675 # taken from ExtUtils::ParseXS
 676 sub _valid_proto_string {
 677   my $string = shift;
 678   if ($string =~ /^$Proto_Regexp+$/o) {
 679     return $string;
 680   }
 681
 682   return 0 ;
 683 }
 684
 685 # taken from ExtUtils::ParseXS (C_string)
 686 sub _escape_backslashes {
 687   my $string = shift;
 688   $string =~ s[\\][\\\\]g;
 689   $string;
 690 }
 691
 692 =head1 CAVEATS
 693
 694 Inherits some evil code from C<ExtUtils::ParseXS>.
 695
 696 =head1 SEE ALSO
 697
 698 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
 699
 700 For details on typemaps: L<perlxstut>, L<perlxs>.
 701
 702 =head1 AUTHOR
 703
 704 Steffen Mueller C<<smueller@cpan.org>>
 705
 706 =head1 COPYRIGHT & LICENSE
 707
 708 Copyright 2009-2011 Steffen Mueller
 709
 710 This program is free software; you can redistribute it and/or
 711 modify it under the same terms as Perl itself.
 712
 713 =cut
 714
 715 1;
 716