This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement 'skip' option for merging typemaps
[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
8badd275
S
129existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1>
130triggers a I<"first come first serve"> logic by which new entries that conflict
131with existing entries are silently ignored.
297f4492
S
132
133As an alternative to the named parameters usage, you may pass in
8226b442 134an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be
8badd275 135added to the typemap. In that case, only the C<replace> or C<skip> named parameters
8226b442
S
136may be used after the object. Example:
137
138 $map->add_typemap($type_obj, replace => 1);
297f4492
S
139
140=cut
141
142sub add_typemap {
143 my $self = shift;
144 my $type;
8226b442
S
145 my %args;
146
147 if ((@_ % 2) == 1) {
297f4492 148 my $orig = shift;
8226b442
S
149 $type = $orig->new();
150 %args = @_;
297f4492
S
151 }
152 else {
8226b442 153 %args = @_;
297f4492
S
154 my $ctype = $args{ctype};
155 croak("Need ctype argument") if not defined $ctype;
156 my $xstype = $args{xstype};
157 croak("Need xstype argument") if not defined $xstype;
158
7320491e 159 $type = ExtUtils::Typemaps::Type->new(
297f4492
S
160 xstype => $xstype,
161 'prototype' => $args{'prototype'},
162 ctype => $ctype,
163 );
297f4492
S
164 }
165
8badd275
S
166 if ($args{skip} and $args{replace}) {
167 croak("Cannot use both 'skip' and 'replace'");
168 }
169
8226b442 170 if ($args{replace}) {
297f4492 171 $self->remove_typemap(ctype => $type->ctype);
8badd275
S
172 }
173 elsif ($args{skip}) {
174 return() if exists $self->{typemap_lookup}{$type->ctype};
175 }
176 else {
297f4492
S
177 $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
178 }
256eb880
S
179
180 # store
297f4492 181 push @{$self->{typemap_section}}, $type;
256eb880
S
182 # remember type for lookup, too.
183 $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}};
7534260c 184
297f4492
S
185 return 1;
186}
187
188=head2 add_inputmap
189
190Add an C<INPUT> entry to the typemap.
191
192Required named arguments:
193The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
194and the C<code> to associate with it for input.
195
196Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
8badd275
S
197existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1>
198triggers a I<"first come first serve"> logic by which new entries that conflict
199with existing entries are silently ignored.
297f4492 200
8226b442
S
201As an alternative to the named parameters usage, you may pass in
202an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be
8badd275 203added to the typemap. In that case, only the C<replace> or C<skip> named parameters
8226b442
S
204may be used after the object. Example:
205
206 $map->add_inputmap($type_obj, replace => 1);
297f4492
S
207
208=cut
209
210sub add_inputmap {
211 my $self = shift;
212 my $input;
8226b442
S
213 my %args;
214
215 if ((@_ % 2) == 1) {
297f4492 216 my $orig = shift;
8226b442
S
217 $input = $orig->new();
218 %args = @_;
297f4492
S
219 }
220 else {
8226b442 221 %args = @_;
297f4492
S
222 my $xstype = $args{xstype};
223 croak("Need xstype argument") if not defined $xstype;
224 my $code = $args{code};
225 croak("Need code argument") if not defined $code;
226
7320491e 227 $input = ExtUtils::Typemaps::InputMap->new(
297f4492
S
228 xstype => $xstype,
229 code => $code,
230 );
297f4492 231 }
8226b442 232
8badd275
S
233 if ($args{skip} and $args{replace}) {
234 croak("Cannot use both 'skip' and 'replace'");
235 }
236
8226b442 237 if ($args{replace}) {
297f4492 238 $self->remove_inputmap(xstype => $input->xstype);
8badd275
S
239 }
240 elsif ($args{skip}) {
241 return() if exists $self->{input_lookup}{$input->xstype};
242 }
243 else {
297f4492
S
244 $self->validate(inputmap_xstype => $input->xstype);
245 }
7534260c
S
246
247 # store
297f4492 248 push @{$self->{input_section}}, $input;
7534260c
S
249 # remember type for lookup, too.
250 $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}};
251
297f4492
S
252 return 1;
253}
254
255=head2 add_outputmap
256
257Add an C<OUTPUT> entry to the typemap.
258Works exactly the same as C<add_inputmap>.
259
260=cut
261
262sub add_outputmap {
263 my $self = shift;
264 my $output;
8226b442
S
265 my %args;
266
267 if ((@_ % 2) == 1) {
297f4492 268 my $orig = shift;
8226b442
S
269 $output = $orig->new();
270 %args = @_;
297f4492
S
271 }
272 else {
8226b442 273 %args = @_;
297f4492
S
274 my $xstype = $args{xstype};
275 croak("Need xstype argument") if not defined $xstype;
276 my $code = $args{code};
277 croak("Need code argument") if not defined $code;
278
7320491e 279 $output = ExtUtils::Typemaps::OutputMap->new(
297f4492
S
280 xstype => $xstype,
281 code => $code,
282 );
297f4492 283 }
8226b442 284
8badd275
S
285 if ($args{skip} and $args{replace}) {
286 croak("Cannot use both 'skip' and 'replace'");
287 }
288
8226b442 289 if ($args{replace}) {
297f4492 290 $self->remove_outputmap(xstype => $output->xstype);
8badd275
S
291 }
292 elsif ($args{skip}) {
293 return() if exists $self->{output_lookup}{$output->xstype};
294 }
295 else {
297f4492
S
296 $self->validate(outputmap_xstype => $output->xstype);
297 }
080872fe
S
298
299 # store
297f4492 300 push @{$self->{output_section}}, $output;
080872fe
S
301 # remember type for lookup, too.
302 $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}};
303
297f4492
S
304 return 1;
305}
306
307=head2 add_string
308
309Parses a string as a typemap and merge it into the typemap object.
310
311Required named argument: C<string> to specify the string to parse.
312
313=cut
314
315sub add_string {
316 my $self = shift;
317 my %args = @_;
318 croak("Need 'string' argument") if not defined $args{string};
319
320 # no, this is not elegant.
7320491e 321 my $other = ExtUtils::Typemaps->new(string => $args{string});
297f4492
S
322 $self->merge(typemap => $other);
323}
324
325=head2 remove_typemap
326
327Removes a C<TYPEMAP> entry from the typemap.
328
329Required named argument: C<ctype> to specify the entry to remove from the typemap.
330
7320491e 331Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.
297f4492
S
332
333=cut
334
335sub remove_typemap {
336 my $self = shift;
337 my $ctype;
338 if (@_ > 1) {
339 my %args = @_;
340 $ctype = $args{ctype};
341 croak("Need ctype argument") if not defined $ctype;
342 $ctype = _tidy_type($ctype);
343 }
344 else {
345 $ctype = $_[0]->tidy_ctype;
346 }
256eb880 347
4433194b 348 return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup});
297f4492
S
349}
350
351=head2 remove_inputmap
352
353Removes an C<INPUT> entry from the typemap.
354
355Required named argument: C<xstype> to specify the entry to remove from the typemap.
356
7320491e 357Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.
297f4492
S
358
359=cut
360
361sub remove_inputmap {
362 my $self = shift;
363 my $xstype;
364 if (@_ > 1) {
365 my %args = @_;
366 $xstype = $args{xstype};
367 croak("Need xstype argument") if not defined $xstype;
368 }
369 else {
370 $xstype = $_[0]->xstype;
371 }
372
4433194b 373 return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
297f4492
S
374}
375
376=head2 remove_inputmap
377
378Removes an C<OUTPUT> entry from the typemap.
379
380Required named argument: C<xstype> to specify the entry to remove from the typemap.
381
7320491e 382Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.
297f4492
S
383
384=cut
385
386sub remove_outputmap {
387 my $self = shift;
388 my $xstype;
389 if (@_ > 1) {
390 my %args = @_;
391 $xstype = $args{xstype};
392 croak("Need xstype argument") if not defined $xstype;
393 }
394 else {
395 $xstype = $_[0]->xstype;
396 }
397
4433194b 398 return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup});
297f4492
S
399}
400
401sub _remove {
402 my $self = shift;
403 my $rm = shift;
297f4492 404 my $array = shift;
256eb880 405 my $lookup = shift;
297f4492 406
4433194b
S
407 # Just fetch the index of the item from the lookup table
408 my $index = $lookup->{$rm};
409 return() if not defined $index;
410
411 # Nuke the item from storage
412 splice(@$array, $index, 1);
413
414 # Decrement the storage position of all items thereafter
415 foreach my $key (keys %$lookup) {
416 if ($lookup->{$key} > $index) {
417 $lookup->{$key}--;
256eb880 418 }
297f4492
S
419 }
420 return();
421}
422
423=head2 get_typemap
424
425Fetches an entry of the TYPEMAP section of the typemap.
426
427Mandatory named arguments: The C<ctype> of the entry.
428
7320491e 429Returns the C<ExtUtils::Typemaps::Type>
297f4492
S
430object for the entry if found.
431
432=cut
433
434sub get_typemap {
435 my $self = shift;
436 my %args = @_;
437 my $ctype = $args{ctype};
438 croak("Need ctype argument") if not defined $ctype;
439 $ctype = _tidy_type($ctype);
440
256eb880
S
441 my $index = $self->{typemap_lookup}{$ctype};
442 return() if not defined $index;
443 return $self->{typemap_section}[$index];
297f4492
S
444}
445
446=head2 get_inputmap
447
448Fetches an entry of the INPUT section of the
449typemap.
450
451Mandatory named arguments: The C<xstype> of the
452entry.
453
7320491e 454Returns the C<ExtUtils::Typemaps::InputMap>
297f4492
S
455object for the entry if found.
456
457=cut
458
459sub get_inputmap {
460 my $self = shift;
461 my %args = @_;
462 my $xstype = $args{xstype};
463 croak("Need xstype argument") if not defined $xstype;
464
7534260c
S
465 my $index = $self->{input_lookup}{$xstype};
466 return() if not defined $index;
467 return $self->{input_section}[$index];
297f4492
S
468}
469
470=head2 get_outputmap
471
472Fetches an entry of the OUTPUT section of the
473typemap.
474
475Mandatory named arguments: The C<xstype> of the
476entry.
477
7320491e 478Returns the C<ExtUtils::Typemaps::InputMap>
297f4492
S
479object for the entry if found.
480
481=cut
482
483sub get_outputmap {
484 my $self = shift;
485 my %args = @_;
486 my $xstype = $args{xstype};
487 croak("Need xstype argument") if not defined $xstype;
488
080872fe
S
489 my $index = $self->{output_lookup}{$xstype};
490 return() if not defined $index;
491 return $self->{output_section}[$index];
297f4492
S
492}
493
494=head2 write
495
496Write the typemap to a file. Optionally takes a C<file> argument. If given, the
497typemap will be written to the specified file. If not, the typemap is written
498to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
499it was read from if any).
500
501=cut
502
503sub write {
504 my $self = shift;
505 my %args = @_;
506 my $file = defined $args{file} ? $args{file} : $self->file();
507 croak("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
508 if not defined $file;
509
510 open my $fh, '>', $file
511 or die "Cannot open typemap file '$file' for writing: $!";
512 print $fh $self->as_string();
513 close $fh;
514}
515
516=head2 as_string
517
518Generates and returns the string form of the typemap.
519
520=cut
521
522sub as_string {
523 my $self = shift;
524 my $typemap = $self->{typemap_section};
525 my @code;
526 push @code, "TYPEMAP\n";
527 foreach my $entry (@$typemap) {
528 # type kind proto
9c95e74b 529 # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
297f4492
S
530 push @code, $entry->ctype . "\t" . $entry->xstype
531 . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
532 }
533
534 my $input = $self->{input_section};
535 if (@$input) {
536 push @code, "\nINPUT\n";
537 foreach my $entry (@$input) {
538 push @code, $entry->xstype, "\n", $entry->code, "\n";
539 }
540 }
541
542 my $output = $self->{output_section};
543 if (@$output) {
544 push @code, "\nOUTPUT\n";
545 foreach my $entry (@$output) {
546 push @code, $entry->xstype, "\n", $entry->code, "\n";
547 }
548 }
549 return join '', @code;
550}
551
552=head2 merge
553
554Merges a given typemap into the object. Note that a failed merge
11cf72d4 555operation leaves the object in an inconsistent state so clone it if necessary.
297f4492 556
11cf72d4
S
557Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
558or C<file =E<gt> $path_to_typemap_file> but not both.
297f4492 559
8badd275
S
560Optional arguments: C<replace =E<gt> 1> to force replacement
561of existing typemap entries without warning or C<skip =E<gt> 1>
562to skip entries that exist already in the typemap.
297f4492
S
563
564=cut
565
566sub merge {
567 my $self = shift;
568 my %args = @_;
11cf72d4
S
569
570 if (exists $args{typemap} and exists $args{file}) {
571 croak("Need {file} OR {typemap} argument. Not both!");
572 }
573 elsif (not exists $args{typemap} and not exists $args{file}) {
574 croak("Need {file} or {typemap} argument!");
575 }
576
297f4492 577 my $typemap = $args{typemap};
11cf72d4
S
578 if (not defined $typemap) {
579 $typemap = ref($self)->new(file => $args{file});
580 }
297f4492 581
8badd275
S
582 my @params;
583 push @params, 'replace' => $args{replace} if exists $args{replace};
584 push @params, 'skip' => $args{skip} if exists $args{skip};
297f4492
S
585
586 # FIXME breaking encapsulation. Add accessor code.
297f4492 587 foreach my $entry (@{$typemap->{typemap_section}}) {
8badd275 588 $self->add_typemap( $entry, @params );
297f4492
S
589 }
590
591 foreach my $entry (@{$typemap->{input_section}}) {
8badd275 592 $self->add_inputmap( $entry, @params );
297f4492
S
593 }
594
595 foreach my $entry (@{$typemap->{output_section}}) {
8badd275 596 $self->add_outputmap( $entry, @params );
297f4492
S
597 }
598
599 return 1;
600}
601
7534260c 602
99d2ef39
S
603=head2 _get_typemap_hash
604
605Returns a hash mapping the C types to the XS types:
606
607 {
608 'char **' => 'T_PACKEDARRAY',
609 'bool_t' => 'T_IV',
610 'AV *' => 'T_AVREF',
611 'InputStream' => 'T_IN',
612 'double' => 'T_DOUBLE',
613 # ...
614 }
615
616This is documented because it is used by C<ExtUtils::ParseXS>,
617but it's not intended for general consumption. May be removed
618at any time.
619
620=cut
621
622sub _get_typemap_hash {
623 my $self = shift;
624 my $lookup = $self->{typemap_lookup};
625 my $storage = $self->{typemap_section};
626
627 my %rv;
628 foreach my $ctype (keys %$lookup) {
629 $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype;
630 }
631
632 return \%rv;
633}
634
635=head2 _get_inputmap_hash
636
637Returns a hash mapping the XS types (identifiers) to the
638corresponding INPUT code:
639
640 {
641 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg)
642 ',
643 'T_OUT' => ' $var = IoOFP(sv_2io($arg))
644 ',
645 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) {
646 # ...
647 }
648
649This is documented because it is used by C<ExtUtils::ParseXS>,
650but it's not intended for general consumption. May be removed
651at any time.
652
653=cut
654
655sub _get_inputmap_hash {
656 my $self = shift;
657 my $lookup = $self->{input_lookup};
658 my $storage = $self->{input_section};
659
660 my %rv;
661 foreach my $xstype (keys %$lookup) {
662 $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
663 }
664
665 return \%rv;
666}
667
668
669=head2 _get_outputmap_hash
670
671Returns a hash mapping the XS types (identifiers) to the
672corresponding OUTPUT code:
673
674 {
675 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(),
676 $var.context.value().size());
677 ',
678 'T_OUT' => ' {
679 GV *gv = newGVgen("$Package");
680 if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
681 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
682 else
683 $arg = &PL_sv_undef;
684 }
685 ',
686 # ...
687 }
688
689This is documented because it is used by C<ExtUtils::ParseXS>,
690but it's not intended for general consumption. May be removed
691at any time.
692
693=cut
694
695sub _get_outputmap_hash {
696 my $self = shift;
697 my $lookup = $self->{output_lookup};
698 my $storage = $self->{output_section};
699
700 my %rv;
701 foreach my $xstype (keys %$lookup) {
702 $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
703 }
704
705 return \%rv;
706}
707
d505a9a6
S
708=head2 _get_prototype_hash
709
710Returns a hash mapping the C types of the typemap to their
711corresponding prototypes.
712
713 {
714 'char **' => '$',
715 'bool_t' => '$',
716 'AV *' => '$',
717 'InputStream' => '$',
718 'double' => '$',
719 # ...
720 }
721
722This is documented because it is used by C<ExtUtils::ParseXS>,
723but it's not intended for general consumption. May be removed
724at any time.
725
726=cut
727
728sub _get_prototype_hash {
729 my $self = shift;
730 my $lookup = $self->{typemap_lookup};
731 my $storage = $self->{typemap_section};
732
733 my %rv;
734 foreach my $ctype (keys %$lookup) {
735 $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
736 }
737
738 return \%rv;
739}
99d2ef39
S
740
741
742
7534260c
S
743# make sure that the provided types wouldn't collide with what's
744# in the object already.
297f4492
S
745sub validate {
746 my $self = shift;
747 my %args = @_;
748
256eb880
S
749 if ( exists $args{ctype}
750 and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
751 {
752 croak("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
297f4492
S
753 }
754
7534260c
S
755 if ( exists $args{inputmap_xstype}
756 and exists $self->{input_lookup}{$args{inputmap_xstype}} )
757 {
080872fe 758 croak("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
297f4492
S
759 }
760
080872fe
S
761 if ( exists $args{outputmap_xstype}
762 and exists $self->{output_lookup}{$args{outputmap_xstype}} )
763 {
764 croak("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
297f4492
S
765 }
766
767 return 1;
768}
769
770sub _parse {
771 my $self = shift;
772 my $stringref = shift;
773 my $filename = shift;
774 $filename = '<string>' if not defined $filename;
775
776 # TODO comments should round-trip, currently ignoring
777 # TODO order of sections, multiple sections of same type
778 # Heavily influenced by ExtUtils::ParseXS
779 my $section = 'typemap';
780 my $lineno = 0;
781 my $junk = "";
782 my $current = \$junk;
297f4492
S
783 my @input_expr;
784 my @output_expr;
785 while ($$stringref =~ /^(.*)$/gcm) {
786 local $_ = $1;
787 ++$lineno;
788 chomp;
789 next if /^\s*#/;
790 if (/^INPUT\s*$/) {
791 $section = 'input';
792 $current = \$junk;
793 next;
794 }
795 elsif (/^OUTPUT\s*$/) {
796 $section = 'output';
797 $current = \$junk;
798 next;
799 }
800 elsif (/^TYPEMAP\s*$/) {
801 $section = 'typemap';
802 $current = \$junk;
803 next;
804 }
805
806 if ($section eq 'typemap') {
807 my $line = $_;
808 s/^\s+//; s/\s+$//;
809 next if /^#/ or /^$/;
9c95e74b 810 my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
297f4492
S
811 or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
812 next;
813 #$proto = '' if not $proto;
814 # prototype defaults to '$'
815 #$proto = '$' unless $proto;
816 #warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
817 # unless _valid_proto_string($proto);
256eb880
S
818 $self->add_typemap(
819 ExtUtils::Typemaps::Type->new(
820 xstype => $kind, proto => $proto, ctype => $type
821 )
297f4492
S
822 );
823 } elsif (/^\s/) {
824 $$current .= $$current eq '' ? $_ : "\n".$_;
825 } elsif (/^$/) {
826 next;
827 } elsif ($section eq 'input') {
828 s/\s+$//;
829 push @input_expr, {xstype => $_, code => ''};
830 $current = \$input_expr[-1]{code};
831 } else { # output section
832 s/\s+$//;
833 push @output_expr, {xstype => $_, code => ''};
834 $current = \$output_expr[-1]{code};
835 }
836
837 } # end while lines
838
7534260c
S
839 foreach my $inexpr (@input_expr) {
840 $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr) );
841 }
080872fe
S
842 foreach my $outexpr (@output_expr) {
843 $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr) );
844 }
7534260c 845
080872fe 846 return 1;
297f4492
S
847}
848
849# taken from ExtUtils::ParseXS
850sub _tidy_type {
851 local $_ = shift;
852
853 # rationalise any '*' by joining them into bunches and removing whitespace
854 s#\s*(\*+)\s*#$1#g;
855 s#(\*+)# $1 #g ;
856
857 # trim leading & trailing whitespace
858 s/^\s+//; s/\s+$//;
859
860 # change multiple whitespace into a single space
861 s/\s+/ /g;
862
863 $_;
864}
865
866
867# taken from ExtUtils::ParseXS
868sub _valid_proto_string {
869 my $string = shift;
9c95e74b 870 if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
297f4492
S
871 return $string;
872 }
873
874 return 0 ;
875}
876
877# taken from ExtUtils::ParseXS (C_string)
878sub _escape_backslashes {
879 my $string = shift;
880 $string =~ s[\\][\\\\]g;
881 $string;
882}
883
884=head1 CAVEATS
885
297f4492
S
886Inherits some evil code from C<ExtUtils::ParseXS>.
887
297f4492
S
888=head1 SEE ALSO
889
890The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
891
892For details on typemaps: L<perlxstut>, L<perlxs>.
893
894=head1 AUTHOR
895
896Steffen Mueller C<<smueller@cpan.org>>
897
898=head1 COPYRIGHT & LICENSE
899
0b19625b 900Copyright 2009-2011 Steffen Mueller
297f4492
S
901
902This program is free software; you can redistribute it and/or
903modify it under the same terms as Perl itself.
904
905=cut
906
9071;
908