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
CommitLineData
7320491e 1package ExtUtils::Typemaps;
297f4492
S
2use 5.006001;
3use strict;
4use warnings;
120f2c87 5our $VERSION = '1.00';
a64e87a8 6#use Carp qw(croak);
297f4492 7
9c95e74b
S
8require ExtUtils::ParseXS;
9require ExtUtils::ParseXS::Constants;
7320491e
S
10require ExtUtils::Typemaps::InputMap;
11require ExtUtils::Typemaps::OutputMap;
12require ExtUtils::Typemaps::Type;
297f4492
S
13
14=head1 NAME
15
7320491e 16ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files
297f4492
S
17
18=head1 SYNOPSIS
19
20 # read/create file
7320491e 21 my $typemap = ExtUtils::Typemaps->new(file => 'typemap');
297f4492 22 # alternatively create an in-memory typemap
7320491e 23 # $typemap = ExtUtils::Typemaps->new();
297f4492 24 # alternatively create an in-memory typemap by parsing a string
7320491e 25 # $typemap = ExtUtils::Typemaps->new(string => $sometypemap);
297f4492
S
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
44This module can read, modify, create and write Perl XS typemap files. If you don't know
45what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals.
46
47The module is not entirely round-trip safe: For example it currently simply strips all comments.
48The order of entries in the maps is, however, preserved.
49
50We check for duplicate entries in the typemap, but do not check for missing
51C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden
52in a different typemap.
53
54=head1 METHODS
55
56=cut
57
58=head2 new
59
60Returns a new typemap object. Takes an optional C<file> parameter.
61If set, the given file will be read. If the file doesn't exist, an empty typemap
62is returned.
63
64Alternatively, if the C<string> parameter is given, the supplied
65string will be parsed instead of a file.
66
67=cut
68
69sub new {
70 my $class = shift;
71 my %args = @_;
72
73 if (defined $args{file} and defined $args{string}) {
a64e87a8 74 die("Cannot handle both 'file' and 'string' arguments to constructor");
297f4492
S
75 }
76
77 my $self = bless {
78 file => undef,
79 %args,
80 typemap_section => [],
256eb880 81 typemap_lookup => {},
297f4492 82 input_section => [],
7534260c 83 input_lookup => {},
297f4492 84 output_section => [],
080872fe 85 output_lookup => {},
297f4492
S
86 } => $class;
87
88 $self->_init();
89
90 return $self;
91}
92
93sub _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
111Get/set the file that the typemap is written to when the
112C<write> method is called.
113
114=cut
115
116sub file {
117 $_[0]->{file} = $_[1] if @_ > 1;
118 $_[0]->{file}
119}
120
121=head2 add_typemap
122
123Add a C<TYPEMAP> entry to the typemap.
124
125Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>)
126and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>).
127
128Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
8badd275
S
129existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1>
130triggers a I<"first come first serve"> logic by which new entries that conflict
131with existing entries are silently ignored.
297f4492
S
132
133As an alternative to the named parameters usage, you may pass in
8226b442 134an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be
8badd275 135added to the typemap. In that case, only the C<replace> or C<skip> named parameters
8226b442
S
136may be used after the object. Example:
137
138 $map->add_typemap($type_obj, replace => 1);
297f4492
S
139
140=cut
141
142sub add_typemap {
143 my $self = shift;
144 my $type;
8226b442
S
145 my %args;
146
147 if ((@_ % 2) == 1) {
297f4492 148 my $orig = shift;
8226b442
S
149 $type = $orig->new();
150 %args = @_;
297f4492
S
151 }
152 else {
8226b442 153 %args = @_;
297f4492 154 my $ctype = $args{ctype};
a64e87a8 155 die("Need ctype argument") if not defined $ctype;
297f4492 156 my $xstype = $args{xstype};
a64e87a8 157 die("Need xstype argument") if not defined $xstype;
297f4492 158
7320491e 159 $type = ExtUtils::Typemaps::Type->new(
297f4492
S
160 xstype => $xstype,
161 'prototype' => $args{'prototype'},
162 ctype => $ctype,
163 );
297f4492
S
164 }
165
8badd275 166 if ($args{skip} and $args{replace}) {
a64e87a8 167 die("Cannot use both 'skip' and 'replace'");
8badd275
S
168 }
169
8226b442 170 if ($args{replace}) {
297f4492 171 $self->remove_typemap(ctype => $type->ctype);
8badd275
S
172 }
173 elsif ($args{skip}) {
174 return() if exists $self->{typemap_lookup}{$type->ctype};
175 }
176 else {
297f4492
S
177 $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype);
178 }
256eb880
S
179
180 # store
297f4492 181 push @{$self->{typemap_section}}, $type;
256eb880
S
182 # remember type for lookup, too.
183 $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}};
7534260c 184
297f4492
S
185 return 1;
186}
187
188=head2 add_inputmap
189
190Add an C<INPUT> entry to the typemap.
191
192Required named arguments:
193The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>)
194and the C<code> to associate with it for input.
195
196Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of
8badd275
S
197existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1>
198triggers a I<"first come first serve"> logic by which new entries that conflict
199with existing entries are silently ignored.
297f4492 200
8226b442
S
201As an alternative to the named parameters usage, you may pass in
202an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be
8badd275 203added to the typemap. In that case, only the C<replace> or C<skip> named parameters
8226b442
S
204may be used after the object. Example:
205
206 $map->add_inputmap($type_obj, replace => 1);
297f4492
S
207
208=cut
209
210sub add_inputmap {
211 my $self = shift;
212 my $input;
8226b442
S
213 my %args;
214
215 if ((@_ % 2) == 1) {
297f4492 216 my $orig = shift;
8226b442
S
217 $input = $orig->new();
218 %args = @_;
297f4492
S
219 }
220 else {
8226b442 221 %args = @_;
297f4492 222 my $xstype = $args{xstype};
a64e87a8 223 die("Need xstype argument") if not defined $xstype;
297f4492 224 my $code = $args{code};
a64e87a8 225 die("Need code argument") if not defined $code;
297f4492 226
7320491e 227 $input = ExtUtils::Typemaps::InputMap->new(
297f4492
S
228 xstype => $xstype,
229 code => $code,
230 );
297f4492 231 }
8226b442 232
8badd275 233 if ($args{skip} and $args{replace}) {
a64e87a8 234 die("Cannot use both 'skip' and 'replace'");
8badd275
S
235 }
236
8226b442 237 if ($args{replace}) {
297f4492 238 $self->remove_inputmap(xstype => $input->xstype);
8badd275
S
239 }
240 elsif ($args{skip}) {
241 return() if exists $self->{input_lookup}{$input->xstype};
242 }
243 else {
297f4492
S
244 $self->validate(inputmap_xstype => $input->xstype);
245 }
7534260c
S
246
247 # store
297f4492 248 push @{$self->{input_section}}, $input;
7534260c
S
249 # remember type for lookup, too.
250 $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}};
251
297f4492
S
252 return 1;
253}
254
255=head2 add_outputmap
256
257Add an C<OUTPUT> entry to the typemap.
258Works exactly the same as C<add_inputmap>.
259
260=cut
261
262sub add_outputmap {
263 my $self = shift;
264 my $output;
8226b442
S
265 my %args;
266
267 if ((@_ % 2) == 1) {
297f4492 268 my $orig = shift;
8226b442
S
269 $output = $orig->new();
270 %args = @_;
297f4492
S
271 }
272 else {
8226b442 273 %args = @_;
297f4492 274 my $xstype = $args{xstype};
a64e87a8 275 die("Need xstype argument") if not defined $xstype;
297f4492 276 my $code = $args{code};
a64e87a8 277 die("Need code argument") if not defined $code;
297f4492 278
7320491e 279 $output = ExtUtils::Typemaps::OutputMap->new(
297f4492
S
280 xstype => $xstype,
281 code => $code,
282 );
297f4492 283 }
8226b442 284
8badd275 285 if ($args{skip} and $args{replace}) {
a64e87a8 286 die("Cannot use both 'skip' and 'replace'");
8badd275
S
287 }
288
8226b442 289 if ($args{replace}) {
297f4492 290 $self->remove_outputmap(xstype => $output->xstype);
8badd275
S
291 }
292 elsif ($args{skip}) {
293 return() if exists $self->{output_lookup}{$output->xstype};
294 }
295 else {
297f4492
S
296 $self->validate(outputmap_xstype => $output->xstype);
297 }
080872fe
S
298
299 # store
297f4492 300 push @{$self->{output_section}}, $output;
080872fe
S
301 # remember type for lookup, too.
302 $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}};
303
297f4492
S
304 return 1;
305}
306
307=head2 add_string
308
309Parses a string as a typemap and merge it into the typemap object.
310
311Required named argument: C<string> to specify the string to parse.
312
313=cut
314
315sub add_string {
316 my $self = shift;
317 my %args = @_;
a64e87a8 318 die("Need 'string' argument") if not defined $args{string};
297f4492
S
319
320 # no, this is not elegant.
7320491e 321 my $other = ExtUtils::Typemaps->new(string => $args{string});
297f4492
S
322 $self->merge(typemap => $other);
323}
324
325=head2 remove_typemap
326
327Removes a C<TYPEMAP> entry from the typemap.
328
329Required named argument: C<ctype> to specify the entry to remove from the typemap.
330
7320491e 331Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object.
297f4492
S
332
333=cut
334
335sub remove_typemap {
336 my $self = shift;
337 my $ctype;
338 if (@_ > 1) {
339 my %args = @_;
340 $ctype = $args{ctype};
a64e87a8 341 die("Need ctype argument") if not defined $ctype;
297f4492
S
342 $ctype = _tidy_type($ctype);
343 }
344 else {
345 $ctype = $_[0]->tidy_ctype;
346 }
256eb880 347
4433194b 348 return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup});
297f4492
S
349}
350
351=head2 remove_inputmap
352
353Removes an C<INPUT> entry from the typemap.
354
355Required named argument: C<xstype> to specify the entry to remove from the typemap.
356
7320491e 357Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object.
297f4492
S
358
359=cut
360
361sub remove_inputmap {
362 my $self = shift;
363 my $xstype;
364 if (@_ > 1) {
365 my %args = @_;
366 $xstype = $args{xstype};
a64e87a8 367 die("Need xstype argument") if not defined $xstype;
297f4492
S
368 }
369 else {
370 $xstype = $_[0]->xstype;
371 }
372
4433194b 373 return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup});
297f4492
S
374}
375
376=head2 remove_inputmap
377
378Removes an C<OUTPUT> entry from the typemap.
379
380Required named argument: C<xstype> to specify the entry to remove from the typemap.
381
7320491e 382Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object.
297f4492
S
383
384=cut
385
386sub remove_outputmap {
387 my $self = shift;
388 my $xstype;
389 if (@_ > 1) {
390 my %args = @_;
391 $xstype = $args{xstype};
a64e87a8 392 die("Need xstype argument") if not defined $xstype;
297f4492
S
393 }
394 else {
395 $xstype = $_[0]->xstype;
396 }
397
4433194b 398 return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup});
297f4492
S
399}
400
401sub _remove {
402 my $self = shift;
403 my $rm = shift;
297f4492 404 my $array = shift;
256eb880 405 my $lookup = shift;
297f4492 406
4433194b
S
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}--;
256eb880 418 }
297f4492
S
419 }
420 return();
421}
422
423=head2 get_typemap
424
425Fetches an entry of the TYPEMAP section of the typemap.
426
427Mandatory named arguments: The C<ctype> of the entry.
428
7320491e 429Returns the C<ExtUtils::Typemaps::Type>
297f4492
S
430object for the entry if found.
431
432=cut
433
434sub get_typemap {
435 my $self = shift;
ab018b01
S
436 die("Need named parameters, got uneven number") if @_ % 2;
437
297f4492
S
438 my %args = @_;
439 my $ctype = $args{ctype};
a64e87a8 440 die("Need ctype argument") if not defined $ctype;
297f4492
S
441 $ctype = _tidy_type($ctype);
442
256eb880
S
443 my $index = $self->{typemap_lookup}{$ctype};
444 return() if not defined $index;
445 return $self->{typemap_section}[$index];
297f4492
S
446}
447
448=head2 get_inputmap
449
450Fetches an entry of the INPUT section of the
451typemap.
452
453Mandatory named arguments: The C<xstype> of the
1c4122e7
S
454entry or the C<ctype> of the typemap that can be used to find
455the C<xstype>. To wit, the following pieces of code
456are 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);
297f4492 462
7320491e 463Returns the C<ExtUtils::Typemaps::InputMap>
297f4492
S
464object for the entry if found.
465
466=cut
467
468sub get_inputmap {
469 my $self = shift;
ab018b01
S
470 die("Need named parameters, got uneven number") if @_ % 2;
471
297f4492
S
472 my %args = @_;
473 my $xstype = $args{xstype};
1c4122e7
S
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) {
ab018b01
S
482 my $tm = $self->get_typemap(ctype => $ctype);
483 $xstype = $tm && $tm->xstype;
484 return() if not defined $xstype;
1c4122e7 485 }
297f4492 486
7534260c
S
487 my $index = $self->{input_lookup}{$xstype};
488 return() if not defined $index;
489 return $self->{input_section}[$index];
297f4492
S
490}
491
492=head2 get_outputmap
493
494Fetches an entry of the OUTPUT section of the
495typemap.
496
497Mandatory named arguments: The C<xstype> of the
1c4122e7
S
498entry or the C<ctype> of the typemap that can be used to
499resolve the C<xstype>. (See above for an example.)
297f4492 500
7320491e 501Returns the C<ExtUtils::Typemaps::InputMap>
297f4492
S
502object for the entry if found.
503
504=cut
505
506sub get_outputmap {
507 my $self = shift;
ab018b01
S
508 die("Need named parameters, got uneven number") if @_ % 2;
509
297f4492
S
510 my %args = @_;
511 my $xstype = $args{xstype};
1c4122e7
S
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) {
ab018b01
S
520 my $tm = $self->get_typemap(ctype => $ctype);
521 $xstype = $tm && $tm->xstype;
522 return() if not defined $xstype;
1c4122e7 523 }
297f4492 524
080872fe
S
525 my $index = $self->{output_lookup}{$xstype};
526 return() if not defined $index;
527 return $self->{output_section}[$index];
297f4492
S
528}
529
530=head2 write
531
532Write the typemap to a file. Optionally takes a C<file> argument. If given, the
533typemap will be written to the specified file. If not, the typemap is written
534to the currently stored file name (see C<-E<gt>file> above, this defaults to the file
535it was read from if any).
536
537=cut
538
539sub write {
540 my $self = shift;
541 my %args = @_;
542 my $file = defined $args{file} ? $args{file} : $self->file();
a64e87a8 543 die("write() needs a file argument (or set the file name of the typemap using the 'file' method)")
297f4492
S
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
554Generates and returns the string form of the typemap.
555
556=cut
557
558sub 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
9c95e74b 565 # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
297f4492
S
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
590Merges a given typemap into the object. Note that a failed merge
11cf72d4 591operation leaves the object in an inconsistent state so clone it if necessary.
297f4492 592
11cf72d4
S
593Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj>
594or C<file =E<gt> $path_to_typemap_file> but not both.
297f4492 595
8badd275
S
596Optional arguments: C<replace =E<gt> 1> to force replacement
597of existing typemap entries without warning or C<skip =E<gt> 1>
598to skip entries that exist already in the typemap.
297f4492
S
599
600=cut
601
602sub merge {
603 my $self = shift;
604 my %args = @_;
11cf72d4
S
605
606 if (exists $args{typemap} and exists $args{file}) {
a64e87a8 607 die("Need {file} OR {typemap} argument. Not both!");
11cf72d4
S
608 }
609 elsif (not exists $args{typemap} and not exists $args{file}) {
a64e87a8 610 die("Need {file} or {typemap} argument!");
11cf72d4 611 }
297f4492 612
8badd275
S
613 my @params;
614 push @params, 'replace' => $args{replace} if exists $args{replace};
615 push @params, 'skip' => $args{skip} if exists $args{skip};
297f4492 616
a64e87a8
S
617 my $typemap = $args{typemap};
618 if (not defined $typemap) {
619 $typemap = ref($self)->new(file => $args{file}, @params);
620 }
621
297f4492 622 # FIXME breaking encapsulation. Add accessor code.
297f4492 623 foreach my $entry (@{$typemap->{typemap_section}}) {
8badd275 624 $self->add_typemap( $entry, @params );
297f4492
S
625 }
626
627 foreach my $entry (@{$typemap->{input_section}}) {
8badd275 628 $self->add_inputmap( $entry, @params );
297f4492
S
629 }
630
631 foreach my $entry (@{$typemap->{output_section}}) {
8badd275 632 $self->add_outputmap( $entry, @params );
297f4492
S
633 }
634
635 return 1;
636}
637
7534260c 638
99d2ef39
S
639=head2 _get_typemap_hash
640
641Returns 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
652This is documented because it is used by C<ExtUtils::ParseXS>,
653but it's not intended for general consumption. May be removed
654at any time.
655
656=cut
657
658sub _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
673Returns a hash mapping the XS types (identifiers) to the
674corresponding 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
685This is documented because it is used by C<ExtUtils::ParseXS>,
686but it's not intended for general consumption. May be removed
687at any time.
688
689=cut
690
691sub _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;
54a9f7b6 699
737750de 700 # Squash trailing whitespace to one line break
54a9f7b6
S
701 # This isn't strictly necessary, but makes the output more similar
702 # to the original ExtUtils::ParseXS.
737750de 703 $rv{$xstype} =~ s/\s*\z/\n/;
99d2ef39
S
704 }
705
706 return \%rv;
707}
708
709
710=head2 _get_outputmap_hash
711
712Returns a hash mapping the XS types (identifiers) to the
713corresponding 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
730This is documented because it is used by C<ExtUtils::ParseXS>,
731but it's not intended for general consumption. May be removed
732at any time.
733
734=cut
735
736sub _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;
737750de
S
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/;
99d2ef39
S
749 }
750
751 return \%rv;
752}
753
d505a9a6
S
754=head2 _get_prototype_hash
755
756Returns a hash mapping the C types of the typemap to their
757corresponding prototypes.
758
759 {
760 'char **' => '$',
761 'bool_t' => '$',
762 'AV *' => '$',
763 'InputStream' => '$',
764 'double' => '$',
765 # ...
766 }
767
768This is documented because it is used by C<ExtUtils::ParseXS>,
769but it's not intended for general consumption. May be removed
770at any time.
771
772=cut
773
774sub _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}
99d2ef39
S
786
787
788
7534260c
S
789# make sure that the provided types wouldn't collide with what's
790# in the object already.
297f4492
S
791sub validate {
792 my $self = shift;
793 my %args = @_;
794
256eb880
S
795 if ( exists $args{ctype}
796 and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} )
797 {
a64e87a8 798 die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section");
297f4492
S
799 }
800
7534260c
S
801 if ( exists $args{inputmap_xstype}
802 and exists $self->{input_lookup}{$args{inputmap_xstype}} )
803 {
a64e87a8 804 die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section");
297f4492
S
805 }
806
080872fe
S
807 if ( exists $args{outputmap_xstype}
808 and exists $self->{output_lookup}{$args{outputmap_xstype}} )
809 {
a64e87a8 810 die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section");
297f4492
S
811 }
812
813 return 1;
814}
815
816sub _parse {
817 my $self = shift;
818 my $stringref = shift;
819 my $filename = shift;
820 $filename = '<string>' if not defined $filename;
821
a64e87a8
S
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
297f4492
S
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;
297f4492
S
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+$//;
737750de 862 next if $_ eq '' or /^#/;
9c95e74b 863 my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o
297f4492
S
864 or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"),
865 next;
297f4492 866 # prototype defaults to '$'
186329e0
S
867 $proto = '$' unless $proto;
868 warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n")
869 unless _valid_proto_string($proto);
256eb880
S
870 $self->add_typemap(
871 ExtUtils::Typemaps::Type->new(
872 xstype => $kind, proto => $proto, ctype => $type
a64e87a8
S
873 ),
874 @add_params
297f4492
S
875 );
876 } elsif (/^\s/) {
737750de 877 s/\s+$//;
297f4492 878 $$current .= $$current eq '' ? $_ : "\n".$_;
737750de 879 } elsif ($_ eq '') {
297f4492
S
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
7534260c 893 foreach my $inexpr (@input_expr) {
a64e87a8 894 $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params );
7534260c 895 }
080872fe 896 foreach my $outexpr (@output_expr) {
a64e87a8 897 $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params );
080872fe 898 }
7534260c 899
080872fe 900 return 1;
297f4492
S
901}
902
903# taken from ExtUtils::ParseXS
904sub _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
922sub _valid_proto_string {
923 my $string = shift;
9c95e74b 924 if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) {
297f4492
S
925 return $string;
926 }
927
928 return 0 ;
929}
930
931# taken from ExtUtils::ParseXS (C_string)
932sub _escape_backslashes {
933 my $string = shift;
934 $string =~ s[\\][\\\\]g;
935 $string;
936}
937
938=head1 CAVEATS
939
297f4492
S
940Inherits some evil code from C<ExtUtils::ParseXS>.
941
297f4492
S
942=head1 SEE ALSO
943
944The parser is heavily inspired from the one in L<ExtUtils::ParseXS>.
945
946For details on typemaps: L<perlxstut>, L<perlxs>.
947
948=head1 AUTHOR
949
950Steffen Mueller C<<smueller@cpan.org>>
951
952=head1 COPYRIGHT & LICENSE
953
0b19625b 954Copyright 2009-2011 Steffen Mueller
297f4492
S
955
956This program is free software; you can redistribute it and/or
957modify it under the same terms as Perl itself.
958
959=cut
960
9611;
962