This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Reduce code duplication by using the same prototype regexp
[perl5.git] / dist / ExtUtils-ParseXS / lib / ExtUtils / Typemaps.pm
CommitLineData
7320491e 1package ExtUtils::Typemaps;
297f4492
S
2use 5.006001;
3use strict;
4use warnings;
120f2c87 5our $VERSION = '1.00';
297f4492
S
6use Carp qw(croak);
7
9c95e74b
S
8require ExtUtils::ParseXS;
9require ExtUtils::ParseXS::Constants;
7320491e
S
10require ExtUtils::Typemaps::InputMap;
11require ExtUtils::Typemaps::OutputMap;
12require ExtUtils::Typemaps::Type;
297f4492
S
13
14=head1 NAME
15
7320491e 16ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files
297f4492
S
17
18=head1 SYNOPSIS
19
20 # read/create file
7320491e 21 my $typemap = ExtUtils::Typemaps->new(file => 'typemap');
297f4492 22 # alternatively create an in-memory typemap
7320491e 23 # $typemap = ExtUtils::Typemaps->new();
297f4492 24 # alternatively create an in-memory typemap by parsing a string
7320491e 25 # $typemap = ExtUtils::Typemaps->new(string => $sometypemap);
297f4492
S
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
44This module can read, modify, create and write Perl XS typemap files. If you don't know
45what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals.
46
47The module is not entirely round-trip safe: For example it currently simply strips all comments.
48The order of entries in the maps is, however, preserved.
49
50We check for duplicate entries in the typemap, but do not check for missing
51C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden
52in a different typemap.
53
54=head1 METHODS
55
56=cut
57
58=head2 new
59
60Returns a new typemap object. Takes an optional C<file> parameter.
61If set, the given file will be read. If the file doesn't exist, an empty typemap
62is returned.
63
64Alternatively, if the C<string> parameter is given, the supplied
65string will be parsed instead of a file.
66
67=cut
68
69sub 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 => [],
256eb880 81 typemap_lookup => {},
297f4492 82 input_section => [],
7534260c 83 input_lookup => {},
297f4492 84 output_section => [],
080872fe 85 output_lookup => {},
297f4492
S
86 } => $class;
87
88 $self->_init();
89
90 return $self;
91}
92
93sub _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
111Get/set the file that the typemap is written to when the
112C<write> method is called.
113
114=cut
115
116sub file {
117 $_[0]->{file} = $_[1] if @_ > 1;
118 $_[0]->{file}
119}
120
121=head2 add_typemap
122
123Add a C<TYPEMAP> entry to the typemap.
124
125Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>)
126and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>).
127
128Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
129existing C<TYPEMAP> entries of the same C<ctype>.
130
131As an alternative to the named parameters usage, you may pass in
7320491e 132an C<ExtUtils::Typemaps::Type> object, a copy of which will be
297f4492
S
133added to the typemap.
134
135=cut
136
137sub 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
7320491e 152 $type = ExtUtils::Typemaps::Type->new(
297f4492
S
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 }
256eb880
S
165
166 # store
297f4492 167 push @{$self->{typemap_section}}, $type;
256eb880
S
168 # remember type for lookup, too.
169 $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}};
7534260c 170
297f4492
S
171 return 1;
172}
173
174=head2 add_inputmap
175
176Add an C<INPUT> entry to the typemap.
177
178Required named arguments:
179The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
180and the C<code> to associate with it for input.
181
182Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
183existing C<INPUT> entries of the same C<xstype>.
184
7320491e 185You may pass in a single C<ExtUtils::Typemaps::InputMap> object instead,
297f4492
S
186a copy of which will be added to the typemap.
187
188=cut
189
190sub 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
7320491e 205 $input = ExtUtils::Typemaps::InputMap->new(
297f4492
S
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 }
7534260c
S
216
217 # store
297f4492 218 push @{$self->{input_section}}, $input;
7534260c
S
219 # remember type for lookup, too.
220 $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}};
221
297f4492
S
222 return 1;
223}
224
225=head2 add_outputmap
226
227Add an C<OUTPUT> entry to the typemap.
228Works exactly the same as C<add_inputmap>.
229
230=cut
231
232sub 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
7320491e 247 $output = ExtUtils::Typemaps::OutputMap->new(
297f4492
S
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 }
080872fe
S
258
259 # store
297f4492 260 push @{$self->{output_section}}, $output;
080872fe
S
261 # remember type for lookup, too.
262 $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}};
263
297f4492
S
264 return 1;
265}
266
267=head2 add_string
268
269Parses a string as a typemap and merge it into the typemap object.
270
271Required named argument: C<string> to specify the string to parse.
272
273=cut
274
275sub 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.
7320491e 281 my $other = ExtUtils::Typemaps->new(string => $args{string});
297f4492
S
282 $self->merge(typemap => $other);
283}
284
285=head2 remove_typemap
286
287Removes a C<TYPEMAP> entry from the typemap.
288
289Required named argument: C<ctype> to specify the entry to remove from the typemap.
290
7320491e 291Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.
297f4492
S
292
293=cut
294
295sub 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 }
256eb880 307
4433194b 308 return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup});
297f4492
S
309}
310
311=head2 remove_inputmap
312
313Removes an C<INPUT> entry from the typemap.
314
315Required named argument: C<xstype> to specify the entry to remove from the typemap.
316
7320491e 317Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.
297f4492
S
318
319=cut
320
321sub 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
4433194b 333 return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
297f4492
S
334}
335
336=head2 remove_inputmap
337
338Removes an C<OUTPUT> entry from the typemap.
339
340Required named argument: C<xstype> to specify the entry to remove from the typemap.
341
7320491e 342Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.
297f4492
S
343
344=cut
345
346sub 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
4433194b 358 return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup});
297f4492
S
359}
360
361sub _remove {
362 my $self = shift;
363 my $rm = shift;
297f4492 364 my $array = shift;
256eb880 365 my $lookup = shift;
297f4492 366
4433194b
S
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}--;
256eb880 378 }
297f4492
S
379 }
380 return();
381}
382
383=head2 get_typemap
384
385Fetches an entry of the TYPEMAP section of the typemap.
386
387Mandatory named arguments: The C<ctype> of the entry.
388
7320491e 389Returns the C<ExtUtils::Typemaps::Type>
297f4492
S
390object for the entry if found.
391
392=cut
393
394sub 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
256eb880
S
401 my $index = $self->{typemap_lookup}{$ctype};
402 return() if not defined $index;
403 return $self->{typemap_section}[$index];
297f4492
S
404}
405
406=head2 get_inputmap
407
408Fetches an entry of the INPUT section of the
409typemap.
410
411Mandatory named arguments: The C<xstype> of the
412entry.
413
7320491e 414Returns the C<ExtUtils::Typemaps::InputMap>
297f4492
S
415object for the entry if found.
416
417=cut
418
419sub get_inputmap {
420 my $self = shift;
421 my %args = @_;
422 my $xstype = $args{xstype};
423 croak("Need xstype argument") if not defined $xstype;
424
7534260c
S
425 my $index = $self->{input_lookup}{$xstype};
426 return() if not defined $index;
427 return $self->{input_section}[$index];
297f4492
S
428}
429
430=head2 get_outputmap
431
432Fetches an entry of the OUTPUT section of the
433typemap.
434
435Mandatory named arguments: The C<xstype> of the
436entry.
437
7320491e 438Returns the C<ExtUtils::Typemaps::InputMap>
297f4492
S
439object for the entry if found.
440
441=cut
442
443sub get_outputmap {
444 my $self = shift;
445 my %args = @_;
446 my $xstype = $args{xstype};
447 croak("Need xstype argument") if not defined $xstype;
448
080872fe
S
449 my $index = $self->{output_lookup}{$xstype};
450 return() if not defined $index;
451 return $self->{output_section}[$index];
297f4492
S
452}
453
454=head2 write
455
456Write the typemap to a file. Optionally takes a C<file> argument. If given, the
457typemap will be written to the specified file. If not, the typemap is written
458to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
459it was read from if any).
460
461=cut
462
463sub 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
478Generates and returns the string form of the typemap.
479
480=cut
481
482sub 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
9c95e74b 489 # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
297f4492
S
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
514Merges a given typemap into the object. Note that a failed merge
515operation leaves the object in an inconsistent state so clone if necessary.
516
517Mandatory named argument: C<typemap =E<gt> $another_typemap>
518
519Optional argument: C<replace =E<gt> 1> to force replacement
520of existing typemap entries without warning.
521
522=cut
523
524sub merge {
525 my $self = shift;
526 my %args = @_;
527 my $typemap = $args{typemap};
7320491e
S
528 croak("Need ExtUtils::Typemaps as argument")
529 if not ref $typemap or not $typemap->isa('ExtUtils::Typemaps');
297f4492
S
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
7534260c
S
550
551# make sure that the provided types wouldn't collide with what's
552# in the object already.
297f4492
S
553sub validate {
554 my $self = shift;
555 my %args = @_;
556
256eb880
S
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");
297f4492
S
561 }
562
7534260c
S
563 if ( exists $args{inputmap_xstype}
564 and exists $self->{input_lookup}{$args{inputmap_xstype}} )
565 {
080872fe 566 croak("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
297f4492
S
567 }
568
080872fe
S
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");
297f4492
S
573 }
574
575 return 1;
576}
577
578sub _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;
297f4492
S
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 /^$/;
9c95e74b 618 my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
297f4492
S
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);
256eb880
S
626 $self->add_typemap(
627 ExtUtils::Typemaps::Type->new(
628 xstype => $kind, proto => $proto, ctype => $type
629 )
297f4492
S
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
7534260c
S
647 foreach my $inexpr (@input_expr) {
648 $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr) );
649 }
080872fe
S
650 foreach my $outexpr (@output_expr) {
651 $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr) );
652 }
7534260c 653
080872fe 654 return 1;
297f4492
S
655}
656
657# taken from ExtUtils::ParseXS
658sub _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
676sub _valid_proto_string {
677 my $string = shift;
9c95e74b 678 if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
297f4492
S
679 return $string;
680 }
681
682 return 0 ;
683}
684
685# taken from ExtUtils::ParseXS (C_string)
686sub _escape_backslashes {
687 my $string = shift;
688 $string =~ s[\\][\\\\]g;
689 $string;
690}
691
692=head1 CAVEATS
693
297f4492
S
694Inherits some evil code from C<ExtUtils::ParseXS>.
695
297f4492
S
696=head1 SEE ALSO
697
698The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
699
700For details on typemaps: L<perlxstut>, L<perlxs>.
701
702=head1 AUTHOR
703
704Steffen Mueller C<<smueller@cpan.org>>
705
706=head1 COPYRIGHT & LICENSE
707
0b19625b 708Copyright 2009-2011 Steffen Mueller
297f4492
S
709
710This program is free software; you can redistribute it and/or
711modify it under the same terms as Perl itself.
712
713=cut
714
7151;
716