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