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