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