This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Simplify "remove" logic after previous refactoring
[perl5.git] / 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