Commit | Line | Data |
---|---|---|
7320491e | 1 | package ExtUtils::Typemaps; |
297f4492 S |
2 | use 5.006001; |
3 | use strict; | |
4 | use warnings; | |
120f2c87 | 5 | our $VERSION = '1.00'; |
a64e87a8 | 6 | #use Carp qw(croak); |
297f4492 | 7 | |
9c95e74b S |
8 | require ExtUtils::ParseXS; |
9 | require ExtUtils::ParseXS::Constants; | |
7320491e S |
10 | require ExtUtils::Typemaps::InputMap; |
11 | require ExtUtils::Typemaps::OutputMap; | |
12 | require ExtUtils::Typemaps::Type; | |
297f4492 S |
13 | |
14 | =head1 NAME | |
15 | ||
7320491e | 16 | ExtUtils::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 | ||
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}) { | |
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 | ||
93 | sub _init { | |
94 | my $self = shift; | |
95 | if (defined $self->{string}) { | |
7c981820 | 96 | $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename}); |
297f4492 S |
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>; | |
7c981820 | 105 | $self->_parse(\$string, $self->{lineno_offset}, $self->{file}); |
297f4492 S |
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 | |
8badd275 S |
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. | |
297f4492 S |
132 | |
133 | As an alternative to the named parameters usage, you may pass in | |
8226b442 | 134 | an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be |
8badd275 | 135 | added to the typemap. In that case, only the C<replace> or C<skip> named parameters |
8226b442 S |
136 | may be used after the object. Example: |
137 | ||
138 | $map->add_typemap($type_obj, replace => 1); | |
297f4492 S |
139 | |
140 | =cut | |
141 | ||
142 | sub 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 | ||
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 | |
8badd275 S |
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. | |
297f4492 | 200 | |
8226b442 S |
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 | |
8badd275 | 203 | added to the typemap. In that case, only the C<replace> or C<skip> named parameters |
8226b442 S |
204 | may be used after the object. Example: |
205 | ||
206 | $map->add_inputmap($type_obj, replace => 1); | |
297f4492 S |
207 | |
208 | =cut | |
209 | ||
210 | sub 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 | ||
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; | |
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 | ||
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 = @_; | |
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 | ||
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 | ||
7320491e | 331 | Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object. |
297f4492 S |
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}; | |
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 | ||
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 | ||
7320491e | 357 | Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object. |
297f4492 S |
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}; | |
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 | ||
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 | ||
7320491e | 382 | Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object. |
297f4492 S |
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}; | |
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 | ||
401 | sub _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 | ||
425 | Fetches an entry of the TYPEMAP section of the typemap. | |
426 | ||
427 | Mandatory named arguments: The C<ctype> of the entry. | |
428 | ||
7320491e | 429 | Returns the C<ExtUtils::Typemaps::Type> |
297f4492 S |
430 | object for the entry if found. |
431 | ||
432 | =cut | |
433 | ||
434 | sub 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 | ||
450 | Fetches an entry of the INPUT section of the | |
451 | typemap. | |
452 | ||
453 | Mandatory named arguments: The C<xstype> of the | |
1c4122e7 S |
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); | |
297f4492 | 462 | |
7320491e | 463 | Returns the C<ExtUtils::Typemaps::InputMap> |
297f4492 S |
464 | object for the entry if found. |
465 | ||
466 | =cut | |
467 | ||
468 | sub 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 | ||
494 | Fetches an entry of the OUTPUT section of the | |
495 | typemap. | |
496 | ||
497 | Mandatory named arguments: The C<xstype> of the | |
1c4122e7 S |
498 | entry or the C<ctype> of the typemap that can be used to |
499 | resolve the C<xstype>. (See above for an example.) | |
297f4492 | 500 | |
7320491e | 501 | Returns the C<ExtUtils::Typemaps::InputMap> |
297f4492 S |
502 | object for the entry if found. |
503 | ||
504 | =cut | |
505 | ||
506 | sub 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 | ||
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(); | |
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 | ||
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 | |
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 | ||
590 | Merges a given typemap into the object. Note that a failed merge | |
11cf72d4 | 591 | operation leaves the object in an inconsistent state so clone it if necessary. |
297f4492 | 592 | |
11cf72d4 S |
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. | |
297f4492 | 595 | |
8badd275 S |
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. | |
297f4492 S |
599 | |
600 | =cut | |
601 | ||
602 | sub 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 | ||
48150f65 S |
638 | =head2 is_empty |
639 | ||
640 | Returns a bool indicating whether this typemap is entirely empty. | |
641 | ||
642 | =cut | |
643 | ||
644 | sub is_empty { | |
645 | my $self = shift; | |
646 | ||
647 | return @{ $self->{typemap_section} } == 0 | |
648 | && @{ $self->{input_section} } == 0 | |
649 | && @{ $self->{output_section} } == 0; | |
650 | } | |
7534260c | 651 | |
99d2ef39 S |
652 | =head2 _get_typemap_hash |
653 | ||
654 | Returns a hash mapping the C types to the XS types: | |
655 | ||
656 | { | |
657 | 'char **' => 'T_PACKEDARRAY', | |
658 | 'bool_t' => 'T_IV', | |
659 | 'AV *' => 'T_AVREF', | |
660 | 'InputStream' => 'T_IN', | |
661 | 'double' => 'T_DOUBLE', | |
662 | # ... | |
663 | } | |
664 | ||
665 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
666 | but it's not intended for general consumption. May be removed | |
667 | at any time. | |
668 | ||
669 | =cut | |
670 | ||
671 | sub _get_typemap_hash { | |
672 | my $self = shift; | |
673 | my $lookup = $self->{typemap_lookup}; | |
674 | my $storage = $self->{typemap_section}; | |
675 | ||
676 | my %rv; | |
677 | foreach my $ctype (keys %$lookup) { | |
678 | $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype; | |
679 | } | |
680 | ||
681 | return \%rv; | |
682 | } | |
683 | ||
684 | =head2 _get_inputmap_hash | |
685 | ||
686 | Returns a hash mapping the XS types (identifiers) to the | |
687 | corresponding INPUT code: | |
688 | ||
689 | { | |
690 | 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg) | |
691 | ', | |
692 | 'T_OUT' => ' $var = IoOFP(sv_2io($arg)) | |
693 | ', | |
694 | 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) { | |
695 | # ... | |
696 | } | |
697 | ||
698 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
699 | but it's not intended for general consumption. May be removed | |
700 | at any time. | |
701 | ||
702 | =cut | |
703 | ||
704 | sub _get_inputmap_hash { | |
705 | my $self = shift; | |
706 | my $lookup = $self->{input_lookup}; | |
707 | my $storage = $self->{input_section}; | |
708 | ||
709 | my %rv; | |
710 | foreach my $xstype (keys %$lookup) { | |
711 | $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; | |
54a9f7b6 | 712 | |
737750de | 713 | # Squash trailing whitespace to one line break |
54a9f7b6 S |
714 | # This isn't strictly necessary, but makes the output more similar |
715 | # to the original ExtUtils::ParseXS. | |
737750de | 716 | $rv{$xstype} =~ s/\s*\z/\n/; |
99d2ef39 S |
717 | } |
718 | ||
719 | return \%rv; | |
720 | } | |
721 | ||
722 | ||
723 | =head2 _get_outputmap_hash | |
724 | ||
725 | Returns a hash mapping the XS types (identifiers) to the | |
726 | corresponding OUTPUT code: | |
727 | ||
728 | { | |
729 | 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), | |
730 | $var.context.value().size()); | |
731 | ', | |
732 | 'T_OUT' => ' { | |
733 | GV *gv = newGVgen("$Package"); | |
734 | if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) | |
735 | sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); | |
736 | else | |
737 | $arg = &PL_sv_undef; | |
738 | } | |
739 | ', | |
740 | # ... | |
741 | } | |
742 | ||
743 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
744 | but it's not intended for general consumption. May be removed | |
745 | at any time. | |
746 | ||
747 | =cut | |
748 | ||
749 | sub _get_outputmap_hash { | |
750 | my $self = shift; | |
751 | my $lookup = $self->{output_lookup}; | |
752 | my $storage = $self->{output_section}; | |
753 | ||
754 | my %rv; | |
755 | foreach my $xstype (keys %$lookup) { | |
756 | $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; | |
737750de S |
757 | |
758 | # Squash trailing whitespace to one line break | |
759 | # This isn't strictly necessary, but makes the output more similar | |
760 | # to the original ExtUtils::ParseXS. | |
761 | $rv{$xstype} =~ s/\s*\z/\n/; | |
99d2ef39 S |
762 | } |
763 | ||
764 | return \%rv; | |
765 | } | |
766 | ||
d505a9a6 S |
767 | =head2 _get_prototype_hash |
768 | ||
769 | Returns a hash mapping the C types of the typemap to their | |
770 | corresponding prototypes. | |
771 | ||
772 | { | |
773 | 'char **' => '$', | |
774 | 'bool_t' => '$', | |
775 | 'AV *' => '$', | |
776 | 'InputStream' => '$', | |
777 | 'double' => '$', | |
778 | # ... | |
779 | } | |
780 | ||
781 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
782 | but it's not intended for general consumption. May be removed | |
783 | at any time. | |
784 | ||
785 | =cut | |
786 | ||
787 | sub _get_prototype_hash { | |
788 | my $self = shift; | |
789 | my $lookup = $self->{typemap_lookup}; | |
790 | my $storage = $self->{typemap_section}; | |
791 | ||
792 | my %rv; | |
793 | foreach my $ctype (keys %$lookup) { | |
794 | $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$'; | |
795 | } | |
796 | ||
797 | return \%rv; | |
798 | } | |
99d2ef39 S |
799 | |
800 | ||
801 | ||
7534260c S |
802 | # make sure that the provided types wouldn't collide with what's |
803 | # in the object already. | |
297f4492 S |
804 | sub validate { |
805 | my $self = shift; | |
806 | my %args = @_; | |
807 | ||
256eb880 S |
808 | if ( exists $args{ctype} |
809 | and exists $self->{typemap_lookup}{_tidy_type($args{ctype})} ) | |
810 | { | |
a64e87a8 | 811 | die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section"); |
297f4492 S |
812 | } |
813 | ||
7534260c S |
814 | if ( exists $args{inputmap_xstype} |
815 | and exists $self->{input_lookup}{$args{inputmap_xstype}} ) | |
816 | { | |
a64e87a8 | 817 | die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section"); |
297f4492 S |
818 | } |
819 | ||
080872fe S |
820 | if ( exists $args{outputmap_xstype} |
821 | and exists $self->{output_lookup}{$args{outputmap_xstype}} ) | |
822 | { | |
a64e87a8 | 823 | die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section"); |
297f4492 S |
824 | } |
825 | ||
826 | return 1; | |
827 | } | |
828 | ||
829 | sub _parse { | |
830 | my $self = shift; | |
831 | my $stringref = shift; | |
7c981820 S |
832 | my $lineno_offset = shift; |
833 | $lineno_offset = 0 if not defined $lineno_offset; | |
297f4492 S |
834 | my $filename = shift; |
835 | $filename = '<string>' if not defined $filename; | |
836 | ||
a64e87a8 S |
837 | my $replace = $self->{replace}; |
838 | my $skip = $self->{skip}; | |
839 | die "Can only replace OR skip" if $replace and $skip; | |
840 | my @add_params; | |
841 | push @add_params, replace => 1 if $replace; | |
842 | push @add_params, skip => 1 if $skip; | |
843 | ||
297f4492 S |
844 | # TODO comments should round-trip, currently ignoring |
845 | # TODO order of sections, multiple sections of same type | |
846 | # Heavily influenced by ExtUtils::ParseXS | |
847 | my $section = 'typemap'; | |
7c981820 | 848 | my $lineno = $lineno_offset; |
297f4492 S |
849 | my $junk = ""; |
850 | my $current = \$junk; | |
297f4492 S |
851 | my @input_expr; |
852 | my @output_expr; | |
853 | while ($$stringref =~ /^(.*)$/gcm) { | |
854 | local $_ = $1; | |
855 | ++$lineno; | |
856 | chomp; | |
857 | next if /^\s*#/; | |
858 | if (/^INPUT\s*$/) { | |
859 | $section = 'input'; | |
860 | $current = \$junk; | |
861 | next; | |
862 | } | |
863 | elsif (/^OUTPUT\s*$/) { | |
864 | $section = 'output'; | |
865 | $current = \$junk; | |
866 | next; | |
867 | } | |
868 | elsif (/^TYPEMAP\s*$/) { | |
869 | $section = 'typemap'; | |
870 | $current = \$junk; | |
871 | next; | |
872 | } | |
873 | ||
874 | if ($section eq 'typemap') { | |
875 | my $line = $_; | |
876 | s/^\s+//; s/\s+$//; | |
737750de | 877 | next if $_ eq '' or /^#/; |
9c95e74b | 878 | my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o |
297f4492 S |
879 | or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"), |
880 | next; | |
297f4492 | 881 | # prototype defaults to '$' |
186329e0 S |
882 | $proto = '$' unless $proto; |
883 | warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n") | |
884 | unless _valid_proto_string($proto); | |
256eb880 S |
885 | $self->add_typemap( |
886 | ExtUtils::Typemaps::Type->new( | |
887 | xstype => $kind, proto => $proto, ctype => $type | |
a64e87a8 S |
888 | ), |
889 | @add_params | |
297f4492 S |
890 | ); |
891 | } elsif (/^\s/) { | |
737750de | 892 | s/\s+$//; |
297f4492 | 893 | $$current .= $$current eq '' ? $_ : "\n".$_; |
737750de | 894 | } elsif ($_ eq '') { |
297f4492 S |
895 | next; |
896 | } elsif ($section eq 'input') { | |
897 | s/\s+$//; | |
898 | push @input_expr, {xstype => $_, code => ''}; | |
899 | $current = \$input_expr[-1]{code}; | |
900 | } else { # output section | |
901 | s/\s+$//; | |
902 | push @output_expr, {xstype => $_, code => ''}; | |
903 | $current = \$output_expr[-1]{code}; | |
904 | } | |
905 | ||
906 | } # end while lines | |
907 | ||
7534260c | 908 | foreach my $inexpr (@input_expr) { |
a64e87a8 | 909 | $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params ); |
7534260c | 910 | } |
080872fe | 911 | foreach my $outexpr (@output_expr) { |
a64e87a8 | 912 | $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params ); |
080872fe | 913 | } |
7534260c | 914 | |
080872fe | 915 | return 1; |
297f4492 S |
916 | } |
917 | ||
918 | # taken from ExtUtils::ParseXS | |
919 | sub _tidy_type { | |
920 | local $_ = shift; | |
921 | ||
922 | # rationalise any '*' by joining them into bunches and removing whitespace | |
923 | s#\s*(\*+)\s*#$1#g; | |
924 | s#(\*+)# $1 #g ; | |
925 | ||
926 | # trim leading & trailing whitespace | |
927 | s/^\s+//; s/\s+$//; | |
928 | ||
929 | # change multiple whitespace into a single space | |
930 | s/\s+/ /g; | |
931 | ||
932 | $_; | |
933 | } | |
934 | ||
935 | ||
936 | # taken from ExtUtils::ParseXS | |
937 | sub _valid_proto_string { | |
938 | my $string = shift; | |
9c95e74b | 939 | if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) { |
297f4492 S |
940 | return $string; |
941 | } | |
942 | ||
943 | return 0 ; | |
944 | } | |
945 | ||
946 | # taken from ExtUtils::ParseXS (C_string) | |
947 | sub _escape_backslashes { | |
948 | my $string = shift; | |
949 | $string =~ s[\\][\\\\]g; | |
950 | $string; | |
951 | } | |
952 | ||
953 | =head1 CAVEATS | |
954 | ||
297f4492 S |
955 | Inherits some evil code from C<ExtUtils::ParseXS>. |
956 | ||
297f4492 S |
957 | =head1 SEE ALSO |
958 | ||
959 | The parser is heavily inspired from the one in L<ExtUtils::ParseXS>. | |
960 | ||
961 | For details on typemaps: L<perlxstut>, L<perlxs>. | |
962 | ||
963 | =head1 AUTHOR | |
964 | ||
965 | Steffen Mueller C<<smueller@cpan.org>> | |
966 | ||
967 | =head1 COPYRIGHT & LICENSE | |
968 | ||
0b19625b | 969 | Copyright 2009-2011 Steffen Mueller |
297f4492 S |
970 | |
971 | This program is free software; you can redistribute it and/or | |
972 | modify it under the same terms as Perl itself. | |
973 | ||
974 | =cut | |
975 | ||
976 | 1; | |
977 |