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, 'tidy_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, '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, 'xstype', $self->{output_section}, $self->{output_lookup});
 359 }
 360
 361 sub _remove {
 362   my $self   = shift;
 363   my $rm     = shift;
 364   my $method = shift;
 365   my $array  = shift;
 366   my $lookup = shift;
 367
 368   if ($lookup) {
 369     my $index = $lookup->{$rm};
 370     return() if not defined $index;
 371     splice(@$array, $index, 1);
 372     foreach my $key (keys %$lookup) {
 373       if ($lookup->{$key} > $index) {
 374         $lookup->{$key}--;
 375       }
 376     }
 377   }
 378   else {
 379     my $index = 0;
 380     foreach my $map (@$array) {
 381       last if $map->$method() eq $rm;
 382       $index++;
 383     }
 384     if ($index < @$array) {
 385       splice(@$array, $index, 1);
 386       return 1;
 387     }
 388   }
 389   return();
 390 }
 391
 392 =head2 get_typemap
 393
 394 Fetches an entry of the TYPEMAP section of the typemap.
 395
 396 Mandatory named arguments: The C<ctype> of the entry.
 397
 398 Returns the C<ExtUtils::Typemaps::Type>
 399 object for the entry if found.
 400
 401 =cut
 402
 403 sub get_typemap {
 404   my $self = shift;
 405   my %args = @_;
 406   my $ctype = $args{ctype};
 407   croak("Need ctype argument") if not defined $ctype;
 408   $ctype = _tidy_type($ctype);
 409
 410   my $index = $self->{typemap_lookup}{$ctype};
 411   return() if not defined $index;
 412   return $self->{typemap_section}[$index];
 413 }
 414
 415 =head2 get_inputmap
 416
 417 Fetches an entry of the INPUT section of the
 418 typemap.
 419
 420 Mandatory named arguments: The C<xstype> of the
 421 entry.
 422
 423 Returns the C<ExtUtils::Typemaps::InputMap>
 424 object for the entry if found.
 425
 426 =cut
 427
 428 sub get_inputmap {
 429   my $self = shift;
 430   my %args = @_;
 431   my $xstype = $args{xstype};
 432   croak("Need xstype argument") if not defined $xstype;
 433
 434   my $index = $self->{input_lookup}{$xstype};
 435   return() if not defined $index;
 436   return $self->{input_section}[$index];
 437 }
 438
 439 =head2 get_outputmap
 440
 441 Fetches an entry of the OUTPUT section of the
 442 typemap.
 443
 444 Mandatory named arguments: The C<xstype> of the
 445 entry.
 446
 447 Returns the C<ExtUtils::Typemaps::InputMap>
 448 object for the entry if found.
 449
 450 =cut
 451
 452 sub get_outputmap {
 453   my $self = shift;
 454   my %args = @_;
 455   my $xstype = $args{xstype};
 456   croak("Need xstype argument") if not defined $xstype;
 457
 458   my $index = $self->{output_lookup}{$xstype};
 459   return() if not defined $index;
 460   return $self->{output_section}[$index];
 461 }
 462
 463 =head2 write
 464
 465 Write the typemap to a file. Optionally takes a C<file> argument. If given, the
 466 typemap will be written to the specified file. If not, the typemap is written
 467 to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
 468 it was read from if any).
 469
 470 =cut
 471
 472 sub write {
 473   my $self = shift;
 474   my %args = @_;
 475   my $file = defined $args{file} ? $args{file} : $self->file();
 476   croak("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
 477     if not defined $file;
 478
 479   open my $fh, '>', $file
 480     or die "Cannot open typemap file '$file' for writing: $!";
 481   print $fh $self->as_string();
 482   close $fh;
 483 }
 484
 485 =head2 as_string
 486
 487 Generates and returns the string form of the typemap.
 488
 489 =cut
 490
 491 sub as_string {
 492   my $self = shift;
 493   my $typemap = $self->{typemap_section};
 494   my @code;
 495   push @code, "TYPEMAP\n";
 496   foreach my $entry (@$typemap) {
 497     # type kind proto
 498     # /^(.*?\S)\s+(\S+)\s*($Proto_Regexp*)$/o
 499     push @code, $entry->ctype . "\t" . $entry->xstype
 500               . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
 501   }
 502
 503   my $input = $self->{input_section};
 504   if (@$input) {
 505     push @code, "\nINPUT\n";
 506     foreach my $entry (@$input) {
 507       push @code, $entry->xstype, "\n", $entry->code, "\n";
 508     }
 509   }
 510
 511   my $output = $self->{output_section};
 512   if (@$output) {
 513     push @code, "\nOUTPUT\n";
 514     foreach my $entry (@$output) {
 515       push @code, $entry->xstype, "\n", $entry->code, "\n";
 516     }
 517   }
 518   return join '', @code;
 519 }
 520
 521 =head2 merge
 522
 523 Merges a given typemap into the object. Note that a failed merge
 524 operation leaves the object in an inconsistent state so clone if necessary.
 525
 526 Mandatory named argument: C<typemap =E<gt> $another_typemap>
 527
 528 Optional argument: C<replace =E<gt> 1> to force replacement
 529 of existing typemap entries without warning.
 530
 531 =cut
 532
 533 sub merge {
 534   my $self = shift;
 535   my %args = @_;
 536   my $typemap = $args{typemap};
 537   croak("Need ExtUtils::Typemaps as argument")
 538     if not ref $typemap or not $typemap->isa('ExtUtils::Typemaps');
 539
 540   my $replace = $args{replace};
 541
 542   # FIXME breaking encapsulation. Add accessor code.
 543   #
 544   foreach my $entry (@{$typemap->{typemap_section}}) {
 545     $self->add_typemap( $entry );
 546   }
 547
 548   foreach my $entry (@{$typemap->{input_section}}) {
 549     $self->add_inputmap( $entry );
 550   }
 551
 552   foreach my $entry (@{$typemap->{output_section}}) {
 553     $self->add_outputmap( $entry );
 554   }
 555
 556   return 1;
 557 }
 558
 559
 560 # make sure that the provided types wouldn't collide with what's
 561 # in the object already.
 562 sub validate {
 563   my $self = shift;
 564   my %args = @_;
 565
 566   if ( exists $args{ctype}
 567        and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
 568   {
 569     croak("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
 570   }
 571
 572   if ( exists $args{inputmap_xstype}
 573        and exists $self->{input_lookup}{$args{inputmap_xstype}} )
 574   {
 575     croak("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
 576   }
 577
 578   if ( exists $args{outputmap_xstype}
 579        and exists $self->{output_lookup}{$args{outputmap_xstype}} )
 580   {
 581     croak("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
 582   }
 583
 584   return 1;
 585 }
 586
 587 sub _parse {
 588   my $self = shift;
 589   my $stringref = shift;
 590   my $filename = shift;
 591   $filename = '<string>' if not defined $filename;
 592
 593   # TODO comments should round-trip, currently ignoring
 594   # TODO order of sections, multiple sections of same type
 595   # Heavily influenced by ExtUtils::ParseXS
 596   my $section = 'typemap';
 597   my $lineno = 0;
 598   my $junk = "";
 599   my $current = \$junk;
 600   my @input_expr;
 601   my @output_expr;
 602   while ($$stringref =~ /^(.*)$/gcm) {
 603     local $_ = $1;
 604     ++$lineno;
 605     chomp;
 606     next if /^\s*#/;
 607     if (/^INPUT\s*$/) {
 608       $section = 'input';
 609       $current = \$junk;
 610       next;
 611     }
 612     elsif (/^OUTPUT\s*$/) {
 613       $section = 'output';
 614       $current = \$junk;
 615       next;
 616     }
 617     elsif (/^TYPEMAP\s*$/) {
 618       $section = 'typemap';
 619       $current = \$junk;
 620       next;
 621     }
 622
 623     if ($section eq 'typemap') {
 624       my $line = $_;
 625       s/^\s+//; s/\s+$//;
 626       next if /^#/ or /^$/;
 627       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($Proto_Regexp*)$/o
 628         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
 629            next;
 630       #$proto = '' if not $proto;
 631       # prototype defaults to '$'
 632       #$proto = '$' unless $proto;
 633       #warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
 634       #  unless _valid_proto_string($proto);
 635       $self->add_typemap(
 636         ExtUtils::Typemaps::Type->new(
 637           xstype => $kind, proto => $proto, ctype => $type
 638         )
 639       );
 640     } elsif (/^\s/) {
 641       $$current .= $$current eq '' ? $_ : "\n".$_;
 642     } elsif (/^$/) {
 643       next;
 644     } elsif ($section eq 'input') {
 645       s/\s+$//;
 646       push @input_expr, {xstype => $_, code => ''};
 647       $current = \$input_expr[-1]{code};
 648     } else { # output section
 649       s/\s+$//;
 650       push @output_expr, {xstype => $_, code => ''};
 651       $current = \$output_expr[-1]{code};
 652     }
 653
 654   } # end while lines
 655
 656   foreach my $inexpr (@input_expr) {
 657     $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr) );
 658   }
 659   foreach my $outexpr (@output_expr) {
 660     $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr) );
 661   }
 662
 663   return 1;
 664 }
 665
 666 # taken from ExtUtils::ParseXS
 667 sub _tidy_type {
 668   local $_ = shift;
 669
 670   # rationalise any '*' by joining them into bunches and removing whitespace
 671   s#\s*(\*+)\s*#$1#g;
 672   s#(\*+)# $1 #g ;
 673
 674   # trim leading & trailing whitespace
 675   s/^\s+//; s/\s+$//;
 676
 677   # change multiple whitespace into a single space
 678   s/\s+/ /g;
 679
 680   $_;
 681 }
 682
 683
 684 # taken from ExtUtils::ParseXS
 685 sub _valid_proto_string {
 686   my $string = shift;
 687   if ($string =~ /^$Proto_Regexp+$/o) {
 688     return $string;
 689   }
 690
 691   return 0 ;
 692 }
 693
 694 # taken from ExtUtils::ParseXS (C_string)
 695 sub _escape_backslashes {
 696   my $string = shift;
 697   $string =~ s[\\][\\\\]g;
 698   $string;
 699 }
 700
 701 =head1 CAVEATS
 702
 703 Inherits some evil code from C<ExtUtils::ParseXS>.
 704
 705 =head1 SEE ALSO
 706
 707 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
 708
 709 For details on typemaps: L<perlxstut>, L<perlxs>.
 710
 711 =head1 AUTHOR
 712
 713 Steffen Mueller C<<smueller@cpan.org>>
 714
 715 =head1 COPYRIGHT & LICENSE
 716
 717 Copyright 2009-2011 Steffen Mueller
 718
 719 This program is free software; you can redistribute it and/or
 720 modify it under the same terms as Perl itself.
 721
 722 =cut
 723
 724 1;
 725