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