This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ceea1e3786c9c286718dc5bb6500e1d3167edabc
[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, '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