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}) { | |
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 | |
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 | ||
7534260c | 638 | |
99d2ef39 S |
639 | =head2 _get_typemap_hash |
640 | ||
641 | Returns a hash mapping the C types to the XS types: | |
642 | ||
643 | { | |
644 | 'char **' => 'T_PACKEDARRAY', | |
645 | 'bool_t' => 'T_IV', | |
646 | 'AV *' => 'T_AVREF', | |
647 | 'InputStream' => 'T_IN', | |
648 | 'double' => 'T_DOUBLE', | |
649 | # ... | |
650 | } | |
651 | ||
652 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
653 | but it's not intended for general consumption. May be removed | |
654 | at any time. | |
655 | ||
656 | =cut | |
657 | ||
658 | sub _get_typemap_hash { | |
659 | my $self = shift; | |
660 | my $lookup = $self->{typemap_lookup}; | |
661 | my $storage = $self->{typemap_section}; | |
662 | ||
663 | my %rv; | |
664 | foreach my $ctype (keys %$lookup) { | |
665 | $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype; | |
666 | } | |
667 | ||
668 | return \%rv; | |
669 | } | |
670 | ||
671 | =head2 _get_inputmap_hash | |
672 | ||
673 | Returns a hash mapping the XS types (identifiers) to the | |
674 | corresponding INPUT code: | |
675 | ||
676 | { | |
677 | 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg) | |
678 | ', | |
679 | 'T_OUT' => ' $var = IoOFP(sv_2io($arg)) | |
680 | ', | |
681 | 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) { | |
682 | # ... | |
683 | } | |
684 | ||
685 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
686 | but it's not intended for general consumption. May be removed | |
687 | at any time. | |
688 | ||
689 | =cut | |
690 | ||
691 | sub _get_inputmap_hash { | |
692 | my $self = shift; | |
693 | my $lookup = $self->{input_lookup}; | |
694 | my $storage = $self->{input_section}; | |
695 | ||
696 | my %rv; | |
697 | foreach my $xstype (keys %$lookup) { | |
698 | $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; | |
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 | ||
712 | Returns a hash mapping the XS types (identifiers) to the | |
713 | corresponding OUTPUT code: | |
714 | ||
715 | { | |
716 | 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), | |
717 | $var.context.value().size()); | |
718 | ', | |
719 | 'T_OUT' => ' { | |
720 | GV *gv = newGVgen("$Package"); | |
721 | if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) | |
722 | sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); | |
723 | else | |
724 | $arg = &PL_sv_undef; | |
725 | } | |
726 | ', | |
727 | # ... | |
728 | } | |
729 | ||
730 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
731 | but it's not intended for general consumption. May be removed | |
732 | at any time. | |
733 | ||
734 | =cut | |
735 | ||
736 | sub _get_outputmap_hash { | |
737 | my $self = shift; | |
738 | my $lookup = $self->{output_lookup}; | |
739 | my $storage = $self->{output_section}; | |
740 | ||
741 | my %rv; | |
742 | foreach my $xstype (keys %$lookup) { | |
743 | $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; | |
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 | ||
756 | Returns a hash mapping the C types of the typemap to their | |
757 | corresponding prototypes. | |
758 | ||
759 | { | |
760 | 'char **' => '$', | |
761 | 'bool_t' => '$', | |
762 | 'AV *' => '$', | |
763 | 'InputStream' => '$', | |
764 | 'double' => '$', | |
765 | # ... | |
766 | } | |
767 | ||
768 | This is documented because it is used by C<ExtUtils::ParseXS>, | |
769 | but it's not intended for general consumption. May be removed | |
770 | at any time. | |
771 | ||
772 | =cut | |
773 | ||
774 | sub _get_prototype_hash { | |
775 | my $self = shift; | |
776 | my $lookup = $self->{typemap_lookup}; | |
777 | my $storage = $self->{typemap_section}; | |
778 | ||
779 | my %rv; | |
780 | foreach my $ctype (keys %$lookup) { | |
781 | $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$'; | |
782 | } | |
783 | ||
784 | return \%rv; | |
785 | } | |
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 |
791 | sub 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 | ||
816 | sub _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 | |
904 | sub _tidy_type { | |
905 | local $_ = shift; | |
906 | ||
907 | # rationalise any '*' by joining them into bunches and removing whitespace | |
908 | s#\s*(\*+)\s*#$1#g; | |
909 | s#(\*+)# $1 #g ; | |
910 | ||
911 | # trim leading & trailing whitespace | |
912 | s/^\s+//; s/\s+$//; | |
913 | ||
914 | # change multiple whitespace into a single space | |
915 | s/\s+/ /g; | |
916 | ||
917 | $_; | |
918 | } | |
919 | ||
920 | ||
921 | # taken from ExtUtils::ParseXS | |
922 | sub _valid_proto_string { | |
923 | my $string = shift; | |
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) | |
932 | sub _escape_backslashes { | |
933 | my $string = shift; | |
934 | $string =~ s[\\][\\\\]g; | |
935 | $string; | |
936 | } | |
937 | ||
938 | =head1 CAVEATS | |
939 | ||
297f4492 S |
940 | Inherits some evil code from C<ExtUtils::ParseXS>. |
941 | ||
297f4492 S |
942 | =head1 SEE ALSO |
943 | ||
944 | The parser is heavily inspired from the one in L<ExtUtils::ParseXS>. | |
945 | ||
946 | For details on typemaps: L<perlxstut>, L<perlxs>. | |
947 | ||
948 | =head1 AUTHOR | |
949 | ||
950 | Steffen Mueller C<<smueller@cpan.org>> | |
951 | ||
952 | =head1 COPYRIGHT & LICENSE | |
953 | ||
0b19625b | 954 | Copyright 2009-2011 Steffen Mueller |
297f4492 S |
955 | |
956 | This program is free software; you can redistribute it and/or | |
957 | modify it under the same terms as Perl itself. | |
958 | ||
959 | =cut | |
960 | ||
961 | 1; | |
962 |