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