This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Better error checking/handling
[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   die("Need named parameters, got uneven number") if @_ % 2;
437
438   my %args = @_;
439   my $ctype = $args{ctype};
440   die("Need ctype argument") if not defined $ctype;
441   $ctype = _tidy_type($ctype);
442
443   my $index = $self->{typemap_lookup}{$ctype};
444   return() if not defined $index;
445   return $self->{typemap_section}[$index];
446 }
447
448 =head2 get_inputmap
449
450 Fetches an entry of the INPUT section of the
451 typemap.
452
453 Mandatory named arguments: The C<xstype> of the
454 entry or the C<ctype> of the typemap that can be used to find
455 the C<xstype>. To wit, the following pieces of code
456 are equivalent:
457
458   my $type = $typemap->get_typemap(ctype => $ctype)
459   my $input_map = $typemap->get_inputmap(xstype => $type->xstype);
460
461   my $input_map = $typemap->get_inputmap(ctype => $ctype);
462
463 Returns the C<ExtUtils::Typemaps::InputMap>
464 object for the entry if found.
465
466 =cut
467
468 sub get_inputmap {
469   my $self = shift;
470   die("Need named parameters, got uneven number") if @_ % 2;
471
472   my %args = @_;
473   my $xstype = $args{xstype};
474   my $ctype  = $args{ctype};
475   die("Need xstype or ctype argument")
476     if not defined $xstype
477     and not defined $ctype;
478   die("Need xstype OR ctype arguments, not both")
479     if defined $xstype and defined $ctype;
480
481   if (defined $ctype) {
482     my $tm = $self->get_typemap(ctype => $ctype);
483     $xstype = $tm && $tm->xstype;
484     return() if not defined $xstype;
485   }
486
487   my $index = $self->{input_lookup}{$xstype};
488   return() if not defined $index;
489   return $self->{input_section}[$index];
490 }
491
492 =head2 get_outputmap
493
494 Fetches an entry of the OUTPUT section of the
495 typemap.
496
497 Mandatory named arguments: The C<xstype> of the
498 entry or the C<ctype> of the typemap that can be used to
499 resolve the C<xstype>. (See above for an example.)
500
501 Returns the C<ExtUtils::Typemaps::InputMap>
502 object for the entry if found.
503
504 =cut
505
506 sub get_outputmap {
507   my $self = shift;
508   die("Need named parameters, got uneven number") if @_ % 2;
509
510   my %args = @_;
511   my $xstype = $args{xstype};
512   my $ctype  = $args{ctype};
513   die("Need xstype or ctype argument")
514     if not defined $xstype
515     and not defined $ctype;
516   die("Need xstype OR ctype arguments, not both")
517     if defined $xstype and defined $ctype;
518
519   if (defined $ctype) {
520     my $tm = $self->get_typemap(ctype => $ctype);
521     $xstype = $tm && $tm->xstype;
522     return() if not defined $xstype;
523   }
524
525   my $index = $self->{output_lookup}{$xstype};
526   return() if not defined $index;
527   return $self->{output_section}[$index];
528 }
529
530 =head2 write
531
532 Write the typemap to a file. Optionally takes a C<file> argument. If given, the
533 typemap will be written to the specified file. If not, the typemap is written
534 to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
535 it was read from if any).
536
537 =cut
538
539 sub write {
540   my $self = shift;
541   my %args = @_;
542   my $file = defined $args{file} ? $args{file} : $self->file();
543   die("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
544     if not defined $file;
545
546   open my $fh, '>', $file
547     or die "Cannot open typemap file '$file' for writing: $!";
548   print $fh $self->as_string();
549   close $fh;
550 }
551
552 =head2 as_string
553
554 Generates and returns the string form of the typemap.
555
556 =cut
557
558 sub as_string {
559   my $self = shift;
560   my $typemap = $self->{typemap_section};
561   my @code;
562   push @code, "TYPEMAP\n";
563   foreach my $entry (@$typemap) {
564     # type kind proto
565     # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
566     push @code, $entry->ctype . "\t" . $entry->xstype
567               . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n";
568   }
569
570   my $input = $self->{input_section};
571   if (@$input) {
572     push @code, "\nINPUT\n";
573     foreach my $entry (@$input) {
574       push @code, $entry->xstype, "\n", $entry->code, "\n";
575     }
576   }
577
578   my $output = $self->{output_section};
579   if (@$output) {
580     push @code, "\nOUTPUT\n";
581     foreach my $entry (@$output) {
582       push @code, $entry->xstype, "\n", $entry->code, "\n";
583     }
584   }
585   return join '', @code;
586 }
587
588 =head2 merge
589
590 Merges a given typemap into the object. Note that a failed merge
591 operation leaves the object in an inconsistent state so clone it if necessary.
592
593 Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
594 or C<file =E<gt> $path_to_typemap_file> but not both.
595
596 Optional arguments: C<replace =E<gt> 1> to force replacement
597 of existing typemap entries without warning or C<skip =E<gt> 1>
598 to skip entries that exist already in the typemap.
599
600 =cut
601
602 sub merge {
603   my $self = shift;
604   my %args = @_;
605
606   if (exists $args{typemap} and exists $args{file}) {
607     die("Need {file} OR {typemap} argument. Not both!");
608   }
609   elsif (not exists $args{typemap} and not exists $args{file}) {
610     die("Need {file} or {typemap} argument!");
611   }
612
613   my @params;
614   push @params, 'replace' => $args{replace} if exists $args{replace};
615   push @params, 'skip' => $args{skip} if exists $args{skip};
616
617   my $typemap = $args{typemap};
618   if (not defined $typemap) {
619     $typemap = ref($self)->new(file => $args{file}, @params);
620   }
621
622   # FIXME breaking encapsulation. Add accessor code.
623   foreach my $entry (@{$typemap->{typemap_section}}) {
624     $self->add_typemap( $entry, @params );
625   }
626
627   foreach my $entry (@{$typemap->{input_section}}) {
628     $self->add_inputmap( $entry, @params );
629   }
630
631   foreach my $entry (@{$typemap->{output_section}}) {
632     $self->add_outputmap( $entry, @params );
633   }
634
635   return 1;
636 }
637
638
639 =head2 _get_typemap_hash
640
641 Returns a hash mapping the C types to the XS types:
642
643   {
644     'char **' => 'T_PACKEDARRAY',
645     'bool_t' => 'T_IV',
646     'AV *' => 'T_AVREF',
647     'InputStream' => 'T_IN',
648     'double' => 'T_DOUBLE',
649     # ...
650   }
651
652 This is documented because it is used by C<ExtUtils::ParseXS>,
653 but it's not intended for general consumption. May be removed
654 at any time.
655
656 =cut
657
658 sub _get_typemap_hash {
659   my $self = shift;
660   my $lookup  = $self->{typemap_lookup};
661   my $storage = $self->{typemap_section};
662
663   my %rv;
664   foreach my $ctype (keys %$lookup) {
665     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype;
666   }
667
668   return \%rv;
669 }
670
671 =head2 _get_inputmap_hash
672
673 Returns a hash mapping the XS types (identifiers) to the
674 corresponding INPUT code:
675
676   {
677     'T_CALLBACK' => '   $var = make_perl_cb_$type($arg)
678   ',
679     'T_OUT' => '    $var = IoOFP(sv_2io($arg))
680   ',
681     'T_REF_IV_PTR' => '   if (sv_isa($arg, \\"${ntype}\\")) {
682     # ...
683   }
684
685 This is documented because it is used by C<ExtUtils::ParseXS>,
686 but it's not intended for general consumption. May be removed
687 at any time.
688
689 =cut
690
691 sub _get_inputmap_hash {
692   my $self = shift;
693   my $lookup  = $self->{input_lookup};
694   my $storage = $self->{input_section};
695
696   my %rv;
697   foreach my $xstype (keys %$lookup) {
698     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
699
700     # Squash trailing whitespace to one line break
701     # This isn't strictly necessary, but makes the output more similar
702     # to the original ExtUtils::ParseXS.
703     $rv{$xstype} =~ s/\s*\z/\n/;
704   }
705
706   return \%rv;
707 }
708
709
710 =head2 _get_outputmap_hash
711
712 Returns a hash mapping the XS types (identifiers) to the
713 corresponding OUTPUT code:
714
715   {
716     'T_CALLBACK' => '   sv_setpvn($arg, $var.context.value().chp(),
717                 $var.context.value().size());
718   ',
719     'T_OUT' => '    {
720             GV *gv = newGVgen("$Package");
721             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
722                 sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
723             else
724                 $arg = &PL_sv_undef;
725          }
726   ',
727     # ...
728   }
729
730 This is documented because it is used by C<ExtUtils::ParseXS>,
731 but it's not intended for general consumption. May be removed
732 at any time.
733
734 =cut
735
736 sub _get_outputmap_hash {
737   my $self = shift;
738   my $lookup  = $self->{output_lookup};
739   my $storage = $self->{output_section};
740
741   my %rv;
742   foreach my $xstype (keys %$lookup) {
743     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
744
745     # Squash trailing whitespace to one line break
746     # This isn't strictly necessary, but makes the output more similar
747     # to the original ExtUtils::ParseXS.
748     $rv{$xstype} =~ s/\s*\z/\n/;
749   }
750
751   return \%rv;
752 }
753
754 =head2 _get_prototype_hash
755
756 Returns a hash mapping the C types of the typemap to their
757 corresponding prototypes.
758
759   {
760     'char **' => '$',
761     'bool_t' => '$',
762     'AV *' => '$',
763     'InputStream' => '$',
764     'double' => '$',
765     # ...
766   }
767
768 This is documented because it is used by C<ExtUtils::ParseXS>,
769 but it's not intended for general consumption. May be removed
770 at any time.
771
772 =cut
773
774 sub _get_prototype_hash {
775   my $self = shift;
776   my $lookup  = $self->{typemap_lookup};
777   my $storage = $self->{typemap_section};
778
779   my %rv;
780   foreach my $ctype (keys %$lookup) {
781     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
782   }
783
784   return \%rv;
785 }
786
787
788
789 # make sure that the provided types wouldn't collide with what's
790 # in the object already.
791 sub validate {
792   my $self = shift;
793   my %args = @_;
794
795   if ( exists $args{ctype}
796        and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
797   {
798     die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
799   }
800
801   if ( exists $args{inputmap_xstype}
802        and exists $self->{input_lookup}{$args{inputmap_xstype}} )
803   {
804     die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
805   }
806
807   if ( exists $args{outputmap_xstype}
808        and exists $self->{output_lookup}{$args{outputmap_xstype}} )
809   {
810     die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
811   }
812
813   return 1;
814 }
815
816 sub _parse {
817   my $self = shift;
818   my $stringref = shift;
819   my $filename = shift;
820   $filename = '<string>' if not defined $filename;
821
822   my $replace = $self->{replace};
823   my $skip    = $self->{skip};
824   die "Can only replace OR skip" if $replace and $skip;
825   my @add_params;
826   push @add_params, replace => 1 if $replace;
827   push @add_params, skip    => 1 if $skip;
828
829   # TODO comments should round-trip, currently ignoring
830   # TODO order of sections, multiple sections of same type
831   # Heavily influenced by ExtUtils::ParseXS
832   my $section = 'typemap';
833   my $lineno = 0;
834   my $junk = "";
835   my $current = \$junk;
836   my @input_expr;
837   my @output_expr;
838   while ($$stringref =~ /^(.*)$/gcm) {
839     local $_ = $1;
840     ++$lineno;
841     chomp;
842     next if /^\s*#/;
843     if (/^INPUT\s*$/) {
844       $section = 'input';
845       $current = \$junk;
846       next;
847     }
848     elsif (/^OUTPUT\s*$/) {
849       $section = 'output';
850       $current = \$junk;
851       next;
852     }
853     elsif (/^TYPEMAP\s*$/) {
854       $section = 'typemap';
855       $current = \$junk;
856       next;
857     }
858     
859     if ($section eq 'typemap') {
860       my $line = $_;
861       s/^\s+//; s/\s+$//;
862       next if $_ eq '' or /^#/;
863       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
864         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
865            next;
866       # prototype defaults to '$'
867       $proto = '$' unless $proto;
868       warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
869         unless _valid_proto_string($proto);
870       $self->add_typemap(
871         ExtUtils::Typemaps::Type->new(
872           xstype => $kind, proto => $proto, ctype => $type
873         ),
874         @add_params
875       );
876     } elsif (/^\s/) {
877       s/\s+$//;
878       $$current .= $$current eq '' ? $_ : "\n".$_;
879     } elsif ($_ eq '') {
880       next;
881     } elsif ($section eq 'input') {
882       s/\s+$//;
883       push @input_expr, {xstype => $_, code => ''};
884       $current = \$input_expr[-1]{code};
885     } else { # output section
886       s/\s+$//;
887       push @output_expr, {xstype => $_, code => ''};
888       $current = \$output_expr[-1]{code};
889     }
890
891   } # end while lines
892
893   foreach my $inexpr (@input_expr) {
894     $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params );
895   }
896   foreach my $outexpr (@output_expr) {
897     $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params );
898   }
899
900   return 1;
901 }
902
903 # taken from ExtUtils::ParseXS
904 sub _tidy_type {
905   local $_ = shift;
906
907   # rationalise any '*' by joining them into bunches and removing whitespace
908   s#\s*(\*+)\s*#$1#g;
909   s#(\*+)# $1 #g ;
910
911   # trim leading & trailing whitespace
912   s/^\s+//; s/\s+$//;
913
914   # change multiple whitespace into a single space
915   s/\s+/ /g;
916
917   $_;
918 }
919
920
921 # taken from ExtUtils::ParseXS
922 sub _valid_proto_string {
923   my $string = shift;
924   if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
925     return $string;
926   }
927
928   return 0 ;
929 }
930
931 # taken from ExtUtils::ParseXS (C_string)
932 sub _escape_backslashes {
933   my $string = shift;
934   $string =~ s[\\][\\\\]g;
935   $string;
936 }
937
938 =head1 CAVEATS
939
940 Inherits some evil code from C<ExtUtils::ParseXS>.
941
942 =head1 SEE ALSO
943
944 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
945
946 For details on typemaps: L<perlxstut>, L<perlxs>.
947
948 =head1 AUTHOR
949
950 Steffen Mueller C<<smueller@cpan.org>>
951
952 =head1 COPYRIGHT & LICENSE
953
954 Copyright 2009-2011 Steffen Mueller
955
956 This program is free software; you can redistribute it and/or
957 modify it under the same terms as Perl itself.
958
959 =cut
960
961 1;
962