This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Extract typemap-related code from ExtUtils::ParseXS
[perl5.git] / dist / ExtUtils-ParseXS / lib / ExtUtils / Typemap.pm
CommitLineData
297f4492
S
1package ExtUtils::Typemap;
2use 5.006001;
3use strict;
4use warnings;
5our $VERSION = '0.05';
6use Carp qw(croak);
7
8our $Proto_Regexp = "[" . quotemeta('\$%&*@;[]') . "]";
9
10require ExtUtils::Typemap::InputMap;
11require ExtUtils::Typemap::OutputMap;
12require ExtUtils::Typemap::Type;
13
14=head1 NAME
15
16ExtUtils::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
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 => [],
81 input_section => [],
82 output_section => [],
83 } => $class;
84
85 $self->_init();
86
87 return $self;
88}
89
90sub _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
108Get/set the file that the typemap is written to when the
109C<write> method is called.
110
111=cut
112
113sub file {
114 $_[0]->{file} = $_[1] if @_ > 1;
115 $_[0]->{file}
116}
117
118=head2 add_typemap
119
120Add a C<TYPEMAP> entry to the typemap.
121
122Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>)
123and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>).
124
125Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
126existing C<TYPEMAP> entries of the same C<ctype>.
127
128As an alternative to the named parameters usage, you may pass in
129an C<ExtUtils::Typemap::Type> object, a copy of which will be
130added to the typemap.
131
132=cut
133
134sub 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
168Add an C<INPUT> entry to the typemap.
169
170Required named arguments:
171The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
172and the C<code> to associate with it for input.
173
174Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
175existing C<INPUT> entries of the same C<xstype>.
176
177You may pass in a single C<ExtUtils::Typemap::InputMap> object instead,
178a copy of which will be added to the typemap.
179
180=cut
181
182sub 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
214Add an C<OUTPUT> entry to the typemap.
215Works exactly the same as C<add_inputmap>.
216
217=cut
218
219sub 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
251Parses a string as a typemap and merge it into the typemap object.
252
253Required named argument: C<string> to specify the string to parse.
254
255=cut
256
257sub 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
269Removes a C<TYPEMAP> entry from the typemap.
270
271Required named argument: C<ctype> to specify the entry to remove from the typemap.
272
273Alternatively, you may pass a single C<ExtUtils::Typemap::Type> object.
274
275=cut
276
277sub 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
295Removes an C<INPUT> entry from the typemap.
296
297Required named argument: C<xstype> to specify the entry to remove from the typemap.
298
299Alternatively, you may pass a single C<ExtUtils::Typemap::InputMap> object.
300
301=cut
302
303sub 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
320Removes an C<OUTPUT> entry from the typemap.
321
322Required named argument: C<xstype> to specify the entry to remove from the typemap.
323
324Alternatively, you may pass a single C<ExtUtils::Typemap::OutputMap> object.
325
326=cut
327
328sub 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
343sub _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
363Fetches an entry of the TYPEMAP section of the typemap.
364
365Mandatory named arguments: The C<ctype> of the entry.
366
367Returns the C<ExtUtils::Typemap::Type>
368object for the entry if found.
369
370=cut
371
372sub 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
387Fetches an entry of the INPUT section of the
388typemap.
389
390Mandatory named arguments: The C<xstype> of the
391entry.
392
393Returns the C<ExtUtils::Typemap::InputMap>
394object for the entry if found.
395
396=cut
397
398sub 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
412Fetches an entry of the OUTPUT section of the
413typemap.
414
415Mandatory named arguments: The C<xstype> of the
416entry.
417
418Returns the C<ExtUtils::Typemap::InputMap>
419object for the entry if found.
420
421=cut
422
423sub 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
437Write the typemap to a file. Optionally takes a C<file> argument. If given, the
438typemap will be written to the specified file. If not, the typemap is written
439to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
440it was read from if any).
441
442=cut
443
444sub 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
459Generates and returns the string form of the typemap.
460
461=cut
462
463sub 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
495Merges a given typemap into the object. Note that a failed merge
496operation leaves the object in an inconsistent state so clone if necessary.
497
498Mandatory named argument: C<typemap =E<gt> $another_typemap>
499
500Optional argument: C<replace =E<gt> 1> to force replacement
501of existing typemap entries without warning.
502
503=cut
504
505sub 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.
532sub 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
574sub _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
650sub _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
668sub _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)
678sub _escape_backslashes {
679 my $string = shift;
680 $string =~ s[\\][\\\\]g;
681 $string;
682}
683
684=head1 CAVEATS
685
686Not as well tested as I'd like it to be.
687
688Inherits some evil code from C<ExtUtils::ParseXS>.
689
690Adding more typemaps incurs an O(n) validation penalty
691that could be optimized with a hash.
692
693=head1 SEE ALSO
694
695The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
696
697For details on typemaps: L<perlxstut>, L<perlxs>.
698
699=head1 AUTHOR
700
701Steffen Mueller C<<smueller@cpan.org>>
702
703=head1 COPYRIGHT & LICENSE
704
705Copyright 2009-2010 Steffen Mueller
706
707This program is free software; you can redistribute it and/or
708modify it under the same terms as Perl itself.
709
710=cut
711
7121;
713