05dc2a9ad7e486a1877ef91e536669bc48f96aa0
[perl.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.04_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 as_embedded_typemap
594
595 Generates and returns the string form of the typemap with the
596 appropriate prefix around it for verbatim inclusion into an
597 XS file as an embedded typemap. This will return a string like
598
599   TYPEMAP: <<END_OF_TYPEMAP
600   ... typemap here (see as_string) ...
601   END_OF_TYPEMAP
602
603 The method takes care not to use a HERE-doc end marker that
604 appears in the typemap string itself.
605
606 =cut
607
608 sub as_embedded_typemap {
609   my $self = shift;
610   my $string = $self->as_string;
611
612   my @ident_cand = qw(END_TYPEMAP END_OF_TYPEMAP END);
613   my $icand = 0;
614   my $cand_suffix = "";
615   while ($string =~ /^\Q$ident_cand[$icand]$cand_suffix\E\s*$/m) {
616     $icand++;
617     if ($icand == @ident_cand) {
618       $icand = 0;
619       ++$cand_suffix;
620     }
621   }
622
623   my $marker = "$ident_cand[$icand]$cand_suffix";
624   return "TYPEMAP: <<$marker;\n$string\n$marker\n";
625 }
626
627 =head2 merge
628
629 Merges a given typemap into the object. Note that a failed merge
630 operation leaves the object in an inconsistent state so clone it if necessary.
631
632 Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
633 or C<file =E<gt> $path_to_typemap_file> but not both.
634
635 Optional arguments: C<replace =E<gt> 1> to force replacement
636 of existing typemap entries without warning or C<skip =E<gt> 1>
637 to skip entries that exist already in the typemap.
638
639 =cut
640
641 sub merge {
642   my $self = shift;
643   my %args = @_;
644
645   if (exists $args{typemap} and exists $args{file}) {
646     die("Need {file} OR {typemap} argument. Not both!");
647   }
648   elsif (not exists $args{typemap} and not exists $args{file}) {
649     die("Need {file} or {typemap} argument!");
650   }
651
652   my @params;
653   push @params, 'replace' => $args{replace} if exists $args{replace};
654   push @params, 'skip' => $args{skip} if exists $args{skip};
655
656   my $typemap = $args{typemap};
657   if (not defined $typemap) {
658     $typemap = ref($self)->new(file => $args{file}, @params);
659   }
660
661   # FIXME breaking encapsulation. Add accessor code.
662   foreach my $entry (@{$typemap->{typemap_section}}) {
663     $self->add_typemap( $entry, @params );
664   }
665
666   foreach my $entry (@{$typemap->{input_section}}) {
667     $self->add_inputmap( $entry, @params );
668   }
669
670   foreach my $entry (@{$typemap->{output_section}}) {
671     $self->add_outputmap( $entry, @params );
672   }
673
674   return 1;
675 }
676
677 =head2 is_empty
678
679 Returns a bool indicating whether this typemap is entirely empty.
680
681 =cut
682
683 sub is_empty {
684   my $self = shift;
685
686   return @{ $self->{typemap_section} } == 0
687       && @{ $self->{input_section} } == 0
688       && @{ $self->{output_section} } == 0;
689 }
690
691 =head2 list_mapped_ctypes
692
693 Returns a list of the C types that are mappable by
694 this typemap object.
695
696 =cut
697
698 sub list_mapped_ctypes {
699   my $self = shift;
700   return sort keys %{ $self->{typemap_lookup} };
701 }
702
703 =head2 _get_typemap_hash
704
705 Returns a hash mapping the C types to the XS types:
706
707   {
708     'char **' => 'T_PACKEDARRAY',
709     'bool_t' => 'T_IV',
710     'AV *' => 'T_AVREF',
711     'InputStream' => 'T_IN',
712     'double' => 'T_DOUBLE',
713     # ...
714   }
715
716 This is documented because it is used by C<ExtUtils::ParseXS>,
717 but it's not intended for general consumption. May be removed
718 at any time.
719
720 =cut
721
722 sub _get_typemap_hash {
723   my $self = shift;
724   my $lookup  = $self->{typemap_lookup};
725   my $storage = $self->{typemap_section};
726
727   my %rv;
728   foreach my $ctype (keys %$lookup) {
729     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype;
730   }
731
732   return \%rv;
733 }
734
735 =head2 _get_inputmap_hash
736
737 Returns a hash mapping the XS types (identifiers) to the
738 corresponding INPUT code:
739
740   {
741     'T_CALLBACK' => '   $var = make_perl_cb_$type($arg)
742   ',
743     'T_OUT' => '    $var = IoOFP(sv_2io($arg))
744   ',
745     'T_REF_IV_PTR' => '   if (sv_isa($arg, \\"${ntype}\\")) {
746     # ...
747   }
748
749 This is documented because it is used by C<ExtUtils::ParseXS>,
750 but it's not intended for general consumption. May be removed
751 at any time.
752
753 =cut
754
755 sub _get_inputmap_hash {
756   my $self = shift;
757   my $lookup  = $self->{input_lookup};
758   my $storage = $self->{input_section};
759
760   my %rv;
761   foreach my $xstype (keys %$lookup) {
762     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
763
764     # Squash trailing whitespace to one line break
765     # This isn't strictly necessary, but makes the output more similar
766     # to the original ExtUtils::ParseXS.
767     $rv{$xstype} =~ s/\s*\z/\n/;
768   }
769
770   return \%rv;
771 }
772
773
774 =head2 _get_outputmap_hash
775
776 Returns a hash mapping the XS types (identifiers) to the
777 corresponding OUTPUT code:
778
779   {
780     'T_CALLBACK' => '   sv_setpvn($arg, $var.context.value().chp(),
781                 $var.context.value().size());
782   ',
783     'T_OUT' => '    {
784             GV *gv = newGVgen("$Package");
785             if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
786                 sv_setsv(
787                   $arg,
788                   sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))
789                 );
790             else
791                 $arg = &PL_sv_undef;
792          }
793   ',
794     # ...
795   }
796
797 This is documented because it is used by C<ExtUtils::ParseXS>,
798 but it's not intended for general consumption. May be removed
799 at any time.
800
801 =cut
802
803 sub _get_outputmap_hash {
804   my $self = shift;
805   my $lookup  = $self->{output_lookup};
806   my $storage = $self->{output_section};
807
808   my %rv;
809   foreach my $xstype (keys %$lookup) {
810     $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code;
811
812     # Squash trailing whitespace to one line break
813     # This isn't strictly necessary, but makes the output more similar
814     # to the original ExtUtils::ParseXS.
815     $rv{$xstype} =~ s/\s*\z/\n/;
816   }
817
818   return \%rv;
819 }
820
821 =head2 _get_prototype_hash
822
823 Returns a hash mapping the C types of the typemap to their
824 corresponding prototypes.
825
826   {
827     'char **' => '$',
828     'bool_t' => '$',
829     'AV *' => '$',
830     'InputStream' => '$',
831     'double' => '$',
832     # ...
833   }
834
835 This is documented because it is used by C<ExtUtils::ParseXS>,
836 but it's not intended for general consumption. May be removed
837 at any time.
838
839 =cut
840
841 sub _get_prototype_hash {
842   my $self = shift;
843   my $lookup  = $self->{typemap_lookup};
844   my $storage = $self->{typemap_section};
845
846   my %rv;
847   foreach my $ctype (keys %$lookup) {
848     $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$';
849   }
850
851   return \%rv;
852 }
853
854
855
856 # make sure that the provided types wouldn't collide with what's
857 # in the object already.
858 sub validate {
859   my $self = shift;
860   my %args = @_;
861
862   if ( exists $args{ctype}
863        and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
864   {
865     die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
866   }
867
868   if ( exists $args{inputmap_xstype}
869        and exists $self->{input_lookup}{$args{inputmap_xstype}} )
870   {
871     die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
872   }
873
874   if ( exists $args{outputmap_xstype}
875        and exists $self->{output_lookup}{$args{outputmap_xstype}} )
876   {
877     die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
878   }
879
880   return 1;
881 }
882
883 sub _parse {
884   my $self = shift;
885   my $stringref = shift;
886   my $lineno_offset = shift;
887   $lineno_offset = 0 if not defined $lineno_offset;
888   my $filename = shift;
889   $filename = '<string>' if not defined $filename;
890
891   my $replace = $self->{replace};
892   my $skip    = $self->{skip};
893   die "Can only replace OR skip" if $replace and $skip;
894   my @add_params;
895   push @add_params, replace => 1 if $replace;
896   push @add_params, skip    => 1 if $skip;
897
898   # TODO comments should round-trip, currently ignoring
899   # TODO order of sections, multiple sections of same type
900   # Heavily influenced by ExtUtils::ParseXS
901   my $section = 'typemap';
902   my $lineno = $lineno_offset;
903   my $junk = "";
904   my $current = \$junk;
905   my @input_expr;
906   my @output_expr;
907   while ($$stringref =~ /^(.*)$/gcm) {
908     local $_ = $1;
909     ++$lineno;
910     chomp;
911     next if /^\s*#/;
912     if (/^INPUT\s*$/) {
913       $section = 'input';
914       $current = \$junk;
915       next;
916     }
917     elsif (/^OUTPUT\s*$/) {
918       $section = 'output';
919       $current = \$junk;
920       next;
921     }
922     elsif (/^TYPEMAP\s*$/) {
923       $section = 'typemap';
924       $current = \$junk;
925       next;
926     }
927     
928     if ($section eq 'typemap') {
929       my $line = $_;
930       s/^\s+//; s/\s+$//;
931       next if $_ eq '' or /^#/;
932       my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
933         or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
934            next;
935       # prototype defaults to '$'
936       $proto = '$' unless $proto;
937       warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
938         unless _valid_proto_string($proto);
939       $self->add_typemap(
940         ExtUtils::Typemaps::Type->new(
941           xstype => $kind, proto => $proto, ctype => $type
942         ),
943         @add_params
944       );
945     } elsif (/^\s/) {
946       s/\s+$//;
947       $$current .= $$current eq '' ? $_ : "\n".$_;
948     } elsif ($_ eq '') {
949       next;
950     } elsif ($section eq 'input') {
951       s/\s+$//;
952       push @input_expr, {xstype => $_, code => ''};
953       $current = \$input_expr[-1]{code};
954     } else { # output section
955       s/\s+$//;
956       push @output_expr, {xstype => $_, code => ''};
957       $current = \$output_expr[-1]{code};
958     }
959
960   } # end while lines
961
962   foreach my $inexpr (@input_expr) {
963     $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params );
964   }
965   foreach my $outexpr (@output_expr) {
966     $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params );
967   }
968
969   return 1;
970 }
971
972 # taken from ExtUtils::ParseXS
973 sub _tidy_type {
974   local $_ = shift;
975
976   # rationalise any '*' by joining them into bunches and removing whitespace
977   s#\s*(\*+)\s*#$1#g;
978   s#(\*+)# $1 #g ;
979
980   # trim leading & trailing whitespace
981   s/^\s+//; s/\s+$//;
982
983   # change multiple whitespace into a single space
984   s/\s+/ /g;
985
986   $_;
987 }
988
989
990 # taken from ExtUtils::ParseXS
991 sub _valid_proto_string {
992   my $string = shift;
993   if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
994     return $string;
995   }
996
997   return 0 ;
998 }
999
1000 # taken from ExtUtils::ParseXS (C_string)
1001 sub _escape_backslashes {
1002   my $string = shift;
1003   $string =~ s[\\][\\\\]g;
1004   $string;
1005 }
1006
1007 =head1 CAVEATS
1008
1009 Inherits some evil code from C<ExtUtils::ParseXS>.
1010
1011 =head1 SEE ALSO
1012
1013 The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
1014
1015 For details on typemaps: L<perlxstut>, L<perlxs>.
1016
1017 =head1 AUTHOR
1018
1019 Steffen Mueller C<<smueller@cpan.org>>
1020
1021 =head1 COPYRIGHT & LICENSE
1022
1023 Copyright 2009, 2010, 2011, 2012 Steffen Mueller
1024
1025 This program is free software; you can redistribute it and/or
1026 modify it under the same terms as Perl itself.
1027
1028 =cut
1029
1030 1;
1031