Commit | Line | Data |
2304df62 |
1 | #!./miniperl |
75f92628 |
2 | |
3 | =head1 NAME |
4 | |
5 | xsubpp - compiler to convert Perl XS code into C code |
6 | |
7 | =head1 SYNOPSIS |
8 | |
8fc38fda |
9 | B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs |
75f92628 |
10 | |
11 | =head1 DESCRIPTION |
12 | |
13 | I<xsubpp> will compile XS code into C code by embedding the constructs |
14 | necessary to let C functions manipulate Perl values and creates the glue |
15 | necessary to let Perl access those functions. The compiler uses typemaps to |
16 | determine how to map C function parameters and variables to Perl values. |
17 | |
18 | The compiler will search for typemap files called I<typemap>. It will use |
19 | the following search path to find default typemaps, with the rightmost |
20 | typemap taking precedence. |
21 | |
22 | ../../../typemap:../../typemap:../typemap:typemap |
23 | |
24 | =head1 OPTIONS |
25 | |
26 | =over 5 |
27 | |
28 | =item B<-C++> |
29 | |
30 | Adds ``extern "C"'' to the C code. |
31 | |
32 | |
33 | =item B<-except> |
34 | |
35 | Adds exception handling stubs to the C code. |
36 | |
37 | =item B<-typemap typemap> |
38 | |
39 | Indicates that a user-supplied typemap should take precedence over the |
40 | default typemaps. This option may be used multiple times, with the last |
41 | typemap having the highest precedence. |
42 | |
8e07c86e |
43 | =item B<-v> |
44 | |
45 | Prints the I<xsubpp> version number to standard output, then exits. |
46 | |
8fc38fda |
47 | =item B<-prototypes> |
382b8d97 |
48 | |
8fc38fda |
49 | By default I<xsubpp> will not automatically generate prototype code for |
50 | all xsubs. This flag will enable prototypes. |
51 | |
52 | =item B<-noversioncheck> |
53 | |
54 | Disables the run time test that determines if the object file (derived |
55 | from the C<.xs> file) and the C<.pm> files have the same version |
56 | number. |
382b8d97 |
57 | |
75f92628 |
58 | =back |
59 | |
60 | =head1 ENVIRONMENT |
61 | |
62 | No environment variables are used. |
63 | |
64 | =head1 AUTHOR |
65 | |
66 | Larry Wall |
67 | |
f06db76b |
68 | =head1 MODIFICATION HISTORY |
69 | |
8e07c86e |
70 | See the file F<changes.pod>. |
e50aee73 |
71 | |
75f92628 |
72 | =head1 SEE ALSO |
73 | |
8fc38fda |
74 | perl(1), perlxs(1), perlxstut(1), perlapi(1) |
75f92628 |
75 | |
76 | =cut |
93a17b20 |
77 | |
f06db76b |
78 | # Global Constants |
c07a80fd |
79 | $XSUBPP_version = "1.932"; |
382b8d97 |
80 | require 5.002; |
81 | |
8fc38fda |
82 | sub Q ; |
83 | |
c07a80fd |
84 | $FH = 'File0000' ; |
8fc38fda |
85 | |
86 | $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n"; |
f06db76b |
87 | |
382b8d97 |
88 | $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; |
93a17b20 |
89 | |
8e07c86e |
90 | $except = ""; |
8fc38fda |
91 | $WantPrototypes = -1 ; |
92 | $WantVersionChk = 1 ; |
93 | $ProtoUsed = 0 ; |
8e07c86e |
94 | SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { |
93a17b20 |
95 | $flag = shift @ARGV; |
e50aee73 |
96 | $flag =~ s/^-// ; |
8990e307 |
97 | $spat = shift, next SWITCH if $flag eq 's'; |
98 | $cplusplus = 1, next SWITCH if $flag eq 'C++'; |
382b8d97 |
99 | $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; |
100 | $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; |
8fc38fda |
101 | $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; |
102 | $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; |
8e07c86e |
103 | $except = " TRY", next SWITCH if $flag eq 'except'; |
8990e307 |
104 | push(@tm,shift), next SWITCH if $flag eq 'typemap'; |
8e07c86e |
105 | (print "xsubpp version $XSUBPP_version\n"), exit |
106 | if $flag eq 'v'; |
93a17b20 |
107 | die $usage; |
108 | } |
8fc38fda |
109 | if ($WantPrototypes == -1) |
110 | { $WantPrototypes = 0} |
111 | else |
112 | { $ProtoUsed = 1 } |
113 | |
114 | |
8990e307 |
115 | @ARGV == 1 or die $usage; |
c2960299 |
116 | ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# |
117 | or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# |
8990e307 |
118 | or ($dir, $filename) = ('.', $ARGV[0]); |
119 | chdir($dir); |
8fc38fda |
120 | # Check for VMS; Config.pm may not be installed yet, but this routine |
121 | # is built into VMS perl |
122 | if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; } |
123 | else { $Is_VMS = 0; chomp($pwd = `pwd`); } |
124 | |
125 | ++ $IncludedFiles{$ARGV[0]} ; |
93a17b20 |
126 | |
f06db76b |
127 | sub TrimWhitespace |
128 | { |
129 | $_[0] =~ s/^\s+|\s+$//go ; |
130 | } |
131 | |
132 | sub TidyType |
133 | { |
134 | local ($_) = @_ ; |
135 | |
136 | # rationalise any '*' by joining them into bunches and removing whitespace |
137 | s#\s*(\*+)\s*#$1#g; |
e50aee73 |
138 | s#(\*+)# $1 #g ; |
f06db76b |
139 | |
140 | # change multiple whitespace into a single space |
141 | s/\s+/ /g ; |
142 | |
143 | # trim leading & trailing whitespace |
144 | TrimWhitespace($_) ; |
145 | |
146 | $_ ; |
147 | } |
148 | |
93a17b20 |
149 | $typemap = shift @ARGV; |
8990e307 |
150 | foreach $typemap (@tm) { |
151 | die "Can't find $typemap in $pwd\n" unless -r $typemap; |
93a17b20 |
152 | } |
748a9306 |
153 | unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap |
154 | ../../lib/ExtUtils/typemap ../../../typemap ../../typemap |
155 | ../typemap typemap); |
8990e307 |
156 | foreach $typemap (@tm) { |
f06db76b |
157 | next unless -e $typemap ; |
158 | # skip directories, binary files etc. |
159 | warn("Warning: ignoring non-text typemap file '$typemap'\n"), next |
160 | unless -T $typemap ; |
161 | open(TYPEMAP, $typemap) |
162 | or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; |
e50aee73 |
163 | $mode = 'Typemap'; |
c2960299 |
164 | $junk = "" ; |
8990e307 |
165 | $current = \$junk; |
166 | while (<TYPEMAP>) { |
e50aee73 |
167 | next if /^\s*#/; |
8e07c86e |
168 | if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } |
169 | if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } |
170 | if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } |
e50aee73 |
171 | if ($mode eq 'Typemap') { |
172 | chomp; |
f06db76b |
173 | my $line = $_ ; |
174 | TrimWhitespace($_) ; |
175 | # skip blank lines and comment lines |
176 | next if /^$/ or /^#/ ; |
382b8d97 |
177 | my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or |
178 | warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; |
179 | $type = TidyType($type) ; |
180 | $type_kind{$type} = $kind ; |
181 | # prototype defaults to '$' |
182 | $proto = '$' unless $proto ; |
183 | warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") |
184 | unless ValidProtoString($proto) ; |
185 | $proto_letter{$type} = C_string($proto) ; |
8e07c86e |
186 | } |
187 | elsif (/^\s/) { |
188 | $$current .= $_; |
463ee0b2 |
189 | } |
e50aee73 |
190 | elsif ($mode eq 'Input') { |
8e07c86e |
191 | s/\s+$//; |
192 | $input_expr{$_} = ''; |
193 | $current = \$input_expr{$_}; |
93a17b20 |
194 | } |
8990e307 |
195 | else { |
8e07c86e |
196 | s/\s+$//; |
197 | $output_expr{$_} = ''; |
198 | $current = \$output_expr{$_}; |
93a17b20 |
199 | } |
8990e307 |
200 | } |
201 | close(TYPEMAP); |
202 | } |
93a17b20 |
203 | |
8990e307 |
204 | foreach $key (keys %input_expr) { |
205 | $input_expr{$key} =~ s/\n+$//; |
206 | } |
93a17b20 |
207 | |
8e07c86e |
208 | $END = "!End!\n\n"; # "impossible" keyword (multiple newline) |
209 | |
210 | # Match an XS keyword |
382b8d97 |
211 | $BLOCK_re= '\s*(' . join('|', qw( |
212 | REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT |
8fc38fda |
213 | CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE |
382b8d97 |
214 | )) . "|$END)\\s*:"; |
8e07c86e |
215 | |
216 | # Input: ($_, @line) == unparsed input. |
217 | # Output: ($_, @line) == (rest of line, following lines). |
218 | # Return: the matched keyword if found, otherwise 0 |
219 | sub check_keyword { |
220 | $_ = shift(@line) while !/\S/ && @line; |
221 | s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; |
222 | } |
223 | |
224 | |
225 | sub print_section { |
226 | $_ = shift(@line) while !/\S/ && @line; |
227 | for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { |
228 | print "$_\n"; |
229 | } |
230 | } |
231 | |
8fc38fda |
232 | sub process_keyword($) |
233 | { |
234 | my($pattern) = @_ ; |
235 | my $kwd ; |
236 | |
237 | &{"${kwd}_handler"}() |
238 | while $kwd = check_keyword($pattern) ; |
239 | } |
240 | |
8e07c86e |
241 | sub CASE_handler { |
242 | blurt ("Error: `CASE:' after unconditional `CASE:'") |
243 | if $condnum && $cond eq ''; |
244 | $cond = $_; |
245 | TrimWhitespace($cond); |
246 | print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); |
247 | $_ = '' ; |
248 | } |
249 | |
250 | sub INPUT_handler { |
251 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
252 | last if /^\s*NOT_IMPLEMENTED_YET/; |
253 | next unless /\S/; # skip blank lines |
254 | |
255 | TrimWhitespace($_) ; |
256 | my $line = $_ ; |
257 | |
258 | # remove trailing semicolon if no initialisation |
259 | s/\s*;$//g unless /=/ ; |
260 | |
261 | # check for optional initialisation code |
262 | my $var_init = '' ; |
263 | $var_init = $1 if s/\s*(=.*)$//s ; |
264 | $var_init =~ s/"/\\"/g; |
265 | |
266 | s/\s+/ /g; |
267 | my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s |
268 | or blurt("Error: invalid argument declaration '$line'"), next; |
269 | |
270 | # Check for duplicate definitions |
271 | blurt ("Error: duplicate definition of argument '$var_name' ignored"), next |
272 | if $arg_list{$var_name} ++ ; |
273 | |
274 | $thisdone |= $var_name eq "THIS"; |
275 | $retvaldone |= $var_name eq "RETVAL"; |
276 | $var_types{$var_name} = $var_type; |
277 | print "\t" . &map_type($var_type); |
278 | $var_num = $args_match{$var_name}; |
382b8d97 |
279 | |
8fc38fda |
280 | $proto_arg[$var_num] = ProtoString($var_type) |
281 | if $var_num ; |
8e07c86e |
282 | if ($var_addr) { |
283 | $var_addr{$var_name} = 1; |
284 | $func_args =~ s/\b($var_name)\b/&$1/; |
285 | } |
286 | if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) { |
287 | print "\t$var_name;\n"; |
288 | } elsif ($var_init =~ /\S/) { |
289 | &output_init($var_type, $var_num, "$var_name $var_init"); |
290 | } elsif ($var_num) { |
291 | # generate initialization code |
292 | &generate_init($var_type, $var_num, $var_name); |
293 | } else { |
294 | print ";\n"; |
295 | } |
296 | } |
297 | } |
298 | |
299 | sub OUTPUT_handler { |
300 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
301 | next unless /\S/; |
302 | my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; |
303 | blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next |
304 | if $outargs{$outarg} ++ ; |
305 | if (!$gotRETVAL and $outarg eq 'RETVAL') { |
306 | # deal with RETVAL last |
307 | $RETVAL_code = $outcode ; |
308 | $gotRETVAL = 1 ; |
309 | next ; |
310 | } |
311 | blurt ("Error: OUTPUT $outarg not an argument"), next |
312 | unless defined($args_match{$outarg}); |
313 | blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next |
314 | unless defined $var_types{$outarg} ; |
315 | if ($outcode) { |
316 | print "\t$outcode\n"; |
317 | } else { |
318 | $var_num = $args_match{$outarg}; |
319 | &generate_output($var_types{$outarg}, $var_num, $outarg); |
320 | } |
321 | } |
322 | } |
323 | |
8fc38fda |
324 | sub CLEANUP_handler() { print_section() } |
325 | sub PREINIT_handler() { print_section() } |
326 | sub INIT_handler() { print_section() } |
327 | |
8e07c86e |
328 | sub GetAliases |
329 | { |
330 | my ($line) = @_ ; |
331 | my ($orig) = $line ; |
332 | my ($alias) ; |
333 | my ($value) ; |
334 | |
335 | # Parse alias definitions |
336 | # format is |
337 | # alias = value alias = value ... |
338 | |
339 | while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { |
340 | $alias = $1 ; |
341 | $orig_alias = $alias ; |
342 | $value = $2 ; |
343 | |
344 | # check for optional package definition in the alias |
345 | $alias = $Packprefix . $alias if $alias !~ /::/ ; |
346 | |
347 | # check for duplicate alias name & duplicate value |
348 | Warn("Warning: Ignoring duplicate alias '$orig_alias'") |
349 | if defined $XsubAliases{$pname}{$alias} ; |
350 | |
351 | Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values") |
352 | if $XsubAliasValues{$pname}{$value} ; |
353 | |
354 | $XsubAliases{$pname}{$alias} = $value ; |
355 | $XsubAliasValues{$pname}{$value} = $orig_alias ; |
356 | } |
357 | |
358 | blurt("Error: Cannot parse ALIAS definitions from '$orig'") |
359 | if $line ; |
360 | } |
361 | |
382b8d97 |
362 | sub ALIAS_handler () |
8e07c86e |
363 | { |
364 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
365 | next unless /\S/; |
366 | TrimWhitespace($_) ; |
367 | GetAliases($_) if $_ ; |
368 | } |
369 | } |
370 | |
382b8d97 |
371 | sub REQUIRE_handler () |
8e07c86e |
372 | { |
373 | # the rest of the current line should contain a version number |
374 | my ($Ver) = $_ ; |
375 | |
376 | TrimWhitespace($Ver) ; |
377 | |
378 | death ("Error: REQUIRE expects a version number") |
379 | unless $Ver ; |
380 | |
381 | # check that the version number is of the form n.n |
382 | death ("Error: REQUIRE: expected a number, got '$Ver'") |
383 | unless $Ver =~ /^\d+(\.\d*)?/ ; |
384 | |
385 | death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") |
386 | unless $XSUBPP_version >= $Ver ; |
387 | } |
388 | |
8fc38fda |
389 | sub VERSIONCHECK_handler () |
390 | { |
391 | # the rest of the current line should contain either ENABLE or |
392 | # DISABLE |
393 | |
394 | TrimWhitespace($_) ; |
395 | |
396 | # check for ENABLE/DISABLE |
397 | death ("Error: VERSIONCHECK: ENABLE/DISABLE") |
398 | unless /^(ENABLE|DISABLE)/i ; |
399 | |
400 | $WantVersionChk = 1 if $1 eq 'ENABLE' ; |
401 | $WantVersionChk = 0 if $1 eq 'DISABLE' ; |
402 | |
403 | } |
404 | |
382b8d97 |
405 | sub PROTOTYPE_handler () |
406 | { |
c07a80fd |
407 | death("Error: Only 1 PROTOTYPE definition allowed per xsub") |
408 | if $proto_in_this_xsub ++ ; |
409 | |
382b8d97 |
410 | for (; !/^$BLOCK_re/o; $_ = shift(@line)) { |
411 | next unless /\S/; |
412 | TrimWhitespace($_) ; |
413 | if ($_ eq 'DISABLE') { |
414 | $ProtoThisXSUB = 0 |
415 | } |
416 | elsif ($_ eq 'ENABLE') { |
417 | $ProtoThisXSUB = 1 |
418 | } |
419 | else { |
420 | # remove any whitespace |
421 | s/\s+//g ; |
422 | death("Error: Invalid prototype '$_'") |
423 | unless ValidProtoString($_) ; |
424 | $ProtoThisXSUB = C_string($_) ; |
425 | } |
426 | } |
c07a80fd |
427 | |
8fc38fda |
428 | $ProtoUsed = 1 ; |
c07a80fd |
429 | |
382b8d97 |
430 | } |
431 | |
432 | sub PROTOTYPES_handler () |
433 | { |
434 | # the rest of the current line should contain either ENABLE or |
435 | # DISABLE |
436 | |
437 | TrimWhitespace($_) ; |
438 | |
439 | # check for ENABLE/DISABLE |
440 | death ("Error: PROTOTYPES: ENABLE/DISABLE") |
441 | unless /^(ENABLE|DISABLE)/i ; |
442 | |
443 | $WantPrototypes = 1 if $1 eq 'ENABLE' ; |
444 | $WantPrototypes = 0 if $1 eq 'DISABLE' ; |
8fc38fda |
445 | $ProtoUsed = 1 ; |
382b8d97 |
446 | |
447 | } |
448 | |
8fc38fda |
449 | sub INCLUDE_handler () |
450 | { |
451 | # the rest of the current line should contain a valid filename |
452 | |
453 | TrimWhitespace($_) ; |
454 | |
8fc38fda |
455 | death("INCLUDE: filename missing") |
456 | unless $_ ; |
457 | |
458 | death("INCLUDE: output pipe is illegal") |
459 | if /^\s*\|/ ; |
460 | |
461 | # simple minded recursion detector |
462 | death("INCLUDE loop detected") |
463 | if $IncludedFiles{$_} ; |
464 | |
465 | ++ $IncludedFiles{$_} unless /\|\s*$/ ; |
466 | |
467 | # Save the current file context. |
468 | push(@FileStack, { |
469 | LastLine => $lastline, |
470 | LastLineNo => $lastline_no, |
471 | Line => \@line, |
472 | LineNo => \@line_no, |
473 | Filename => $filename, |
c07a80fd |
474 | Handle => $FH, |
8fc38fda |
475 | }) ; |
476 | |
c07a80fd |
477 | ++ $FH ; |
8fc38fda |
478 | |
479 | # open the new file |
c07a80fd |
480 | open ($FH, "$_") or death("Cannot open '$_': $!") ; |
8fc38fda |
481 | |
482 | print Q<<"EOF" ; |
483 | # |
484 | #/* INCLUDE: Including '$_' from '$filename' */ |
485 | # |
486 | EOF |
487 | |
8fc38fda |
488 | $filename = $_ ; |
489 | |
c07a80fd |
490 | # Prime the pump by reading the first |
491 | # non-blank line |
492 | |
493 | # skip leading blank lines |
494 | while (<$FH>) { |
495 | last unless /^\s*$/ ; |
496 | } |
497 | |
498 | $lastline = $_ ; |
8fc38fda |
499 | $lastline_no = $. ; |
500 | |
501 | } |
502 | |
503 | sub PopFile() |
504 | { |
505 | return 0 unless @FileStack ; |
506 | |
507 | my $data = pop @FileStack ; |
508 | my $ThisFile = $filename ; |
509 | my $isPipe = ($filename =~ /\|\s*$/) ; |
510 | |
511 | -- $IncludedFiles{$filename} |
512 | unless $isPipe ; |
513 | |
c07a80fd |
514 | close $FH ; |
8fc38fda |
515 | |
c07a80fd |
516 | $FH = $data->{Handle} ; |
8fc38fda |
517 | $filename = $data->{Filename} ; |
518 | $lastline = $data->{LastLine} ; |
519 | $lastline_no = $data->{LastLineNo} ; |
520 | @line = @{ $data->{Line} } ; |
521 | @line_no = @{ $data->{LineNo} } ; |
522 | |
523 | if ($isPipe and $? ) { |
524 | -- $lastline_no ; |
525 | print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; |
526 | exit 1 ; |
527 | } |
528 | |
529 | print Q<<"EOF" ; |
530 | # |
531 | #/* INCLUDE: Returning to '$filename' from '$ThisFile' */ |
532 | # |
533 | EOF |
534 | |
535 | return 1 ; |
536 | } |
537 | |
382b8d97 |
538 | sub ValidProtoString ($) |
539 | { |
540 | my($string) = @_ ; |
541 | |
542 | if ( $string =~ /^$proto_re+$/ ) { |
543 | return $string ; |
544 | } |
545 | |
546 | return 0 ; |
547 | } |
548 | |
549 | sub C_string ($) |
550 | { |
551 | my($string) = @_ ; |
552 | |
553 | $string =~ s[\\][\\\\]g ; |
554 | $string ; |
555 | } |
556 | |
557 | sub ProtoString ($) |
558 | { |
559 | my ($type) = @_ ; |
560 | |
561 | $proto_letter{$type} or '$' ; |
562 | } |
563 | |
8e07c86e |
564 | sub check_cpp { |
565 | my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); |
566 | if (@cpp) { |
567 | my ($cpp, $cpplevel); |
568 | for $cpp (@cpp) { |
569 | if ($cpp =~ /^\#\s*if/) { |
570 | $cpplevel++; |
571 | } elsif (!$cpplevel) { |
572 | Warn("Warning: #else/elif/endif without #if in this function"); |
573 | return; |
574 | } elsif ($cpp =~ /^\#\s*endif/) { |
575 | $cpplevel--; |
576 | } |
577 | } |
578 | Warn("Warning: #if without #endif in this function") if $cpplevel; |
579 | } |
580 | } |
581 | |
582 | |
8990e307 |
583 | sub Q { |
e50aee73 |
584 | my($text) = @_; |
4633a7c4 |
585 | $text =~ s/^#//gm; |
2304df62 |
586 | $text =~ s/\[\[/{/g; |
587 | $text =~ s/\]\]/}/g; |
8990e307 |
588 | $text; |
93a17b20 |
589 | } |
590 | |
c07a80fd |
591 | open($FH, $filename) or die "cannot open $filename: $!\n"; |
c2960299 |
592 | |
f06db76b |
593 | # Identify the version of xsubpp used |
f06db76b |
594 | print <<EOM ; |
e50aee73 |
595 | /* |
596 | * This file was generated automatically by xsubpp version $XSUBPP_version from the |
597 | * contents of $filename. Don't edit this file, edit $filename instead. |
598 | * |
599 | * ANY CHANGES MADE HERE WILL BE LOST! |
f06db76b |
600 | * |
601 | */ |
e50aee73 |
602 | |
f06db76b |
603 | EOM |
604 | |
605 | |
c07a80fd |
606 | while (<$FH>) { |
e50aee73 |
607 | last if ($Module, $Package, $Prefix) = |
608 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; |
a0d0e21e |
609 | print $_; |
93a17b20 |
610 | } |
e50aee73 |
611 | &Exit unless defined $_; |
612 | |
8fc38fda |
613 | $lastline = $_; |
614 | $lastline_no = $.; |
93a17b20 |
615 | |
e50aee73 |
616 | |
c07a80fd |
617 | # Read next xsub into @line from ($lastline, <$FH>). |
2304df62 |
618 | sub fetch_para { |
619 | # parse paragraph |
620 | @line = (); |
c2960299 |
621 | @line_no = () ; |
8fc38fda |
622 | if (! defined $lastline) { |
623 | return 1 if PopFile() ; |
c07a80fd |
624 | return 0 ; |
8fc38fda |
625 | } |
e50aee73 |
626 | |
627 | if ($lastline =~ |
628 | /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { |
629 | $Module = $1; |
8e07c86e |
630 | $Package = defined($2) ? $2 : ''; # keep -w happy |
631 | $Prefix = defined($3) ? $3 : ''; # keep -w happy |
e50aee73 |
632 | ($Module_cname = $Module) =~ s/\W/_/g; |
8e07c86e |
633 | ($Packid = $Package) =~ tr/:/_/; |
e50aee73 |
634 | $Packprefix = $Package; |
8e07c86e |
635 | $Packprefix .= "::" if $Packprefix ne ""; |
2304df62 |
636 | $lastline = ""; |
e50aee73 |
637 | } |
638 | |
639 | for(;;) { |
640 | if ($lastline !~ /^\s*#/ || |
8e07c86e |
641 | $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) { |
e50aee73 |
642 | last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; |
643 | push(@line, $lastline); |
644 | push(@line_no, $lastline_no) ; |
93a17b20 |
645 | } |
e50aee73 |
646 | |
647 | # Read next line and continuation lines |
c07a80fd |
648 | last unless defined($lastline = <$FH>); |
e50aee73 |
649 | $lastline_no = $.; |
650 | my $tmp_line; |
651 | $lastline .= $tmp_line |
c07a80fd |
652 | while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); |
e50aee73 |
653 | |
8e07c86e |
654 | chomp $lastline; |
e50aee73 |
655 | $lastline =~ s/^\s+$//; |
2304df62 |
656 | } |
e50aee73 |
657 | pop(@line), pop(@line_no) while @line && $line[-1] eq ""; |
e50aee73 |
658 | 1; |
2304df62 |
659 | } |
93a17b20 |
660 | |
c2960299 |
661 | PARAGRAPH: |
8e07c86e |
662 | while (fetch_para()) { |
e50aee73 |
663 | # Print initial preprocessor statements and blank lines |
664 | print shift(@line), "\n" |
665 | while @line && $line[0] !~ /^[^\#]/; |
666 | |
667 | next PARAGRAPH unless @line; |
668 | |
669 | death ("Code is not inside a function") |
670 | if $line[0] =~ /^\s/; |
671 | |
2304df62 |
672 | # initialize info arrays |
673 | undef(%args_match); |
674 | undef(%var_types); |
675 | undef(%var_addr); |
676 | undef(%defaults); |
677 | undef($class); |
678 | undef($static); |
679 | undef($elipsis); |
f06db76b |
680 | undef($wantRETVAL) ; |
681 | undef(%arg_list) ; |
382b8d97 |
682 | undef(@proto_arg) ; |
c07a80fd |
683 | undef($proto_in_this_xsub) ; |
382b8d97 |
684 | $ProtoThisXSUB = $WantPrototypes ; |
2304df62 |
685 | |
8e07c86e |
686 | $_ = shift(@line); |
8fc38fda |
687 | while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) { |
688 | &{"${kwd}_handler"}() ; |
8e07c86e |
689 | next PARAGRAPH unless @line ; |
690 | $_ = shift(@line); |
691 | } |
c2960299 |
692 | |
8e07c86e |
693 | if (check_keyword("BOOT")) { |
694 | &check_cpp; |
695 | push (@BootCode, $_, @line, "") ; |
c2960299 |
696 | next PARAGRAPH ; |
a0d0e21e |
697 | } |
c2960299 |
698 | |
8e07c86e |
699 | |
700 | # extract return type, function name and arguments |
701 | my($ret_type) = TidyType($_); |
702 | |
c2960299 |
703 | # a function definition needs at least 2 lines |
704 | blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH |
705 | unless @line ; |
706 | |
8e07c86e |
707 | $static = 1 if $ret_type =~ s/^static\s+//; |
708 | |
2304df62 |
709 | $func_header = shift(@line); |
c2960299 |
710 | blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH |
8e07c86e |
711 | unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s; |
c2960299 |
712 | |
8e07c86e |
713 | ($class, $func_name, $orig_args) = ($1, $2, $3) ; |
2304df62 |
714 | ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; |
c2960299 |
715 | |
716 | # Check for duplicate function definition |
8e07c86e |
717 | if (defined $Func_name{"${Packid}_$func_name"} ) { |
718 | Warn("Warning: duplicate function definition '$func_name' detected") |
719 | } |
720 | else { |
721 | push(@Func_name, "${Packid}_$func_name"); |
722 | push(@Func_pname, $pname); |
723 | } |
c2960299 |
724 | $Func_name{"${Packid}_$func_name"} ++ ; |
725 | |
2304df62 |
726 | @args = split(/\s*,\s*/, $orig_args); |
a0d0e21e |
727 | if (defined($class)) { |
8fc38fda |
728 | my $arg0 = ((defined($static) or $func_name =~ /^new/) ? "CLASS" : "THIS"); |
8e07c86e |
729 | unshift(@args, $arg0); |
730 | ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/; |
2304df62 |
731 | } |
732 | $orig_args =~ s/"/\\"/g; |
733 | $min_args = $num_args = @args; |
734 | foreach $i (0..$num_args-1) { |
735 | if ($args[$i] =~ s/\.\.\.//) { |
736 | $elipsis = 1; |
737 | $min_args--; |
c2960299 |
738 | if ($args[$i] eq '' && $i == $num_args - 1) { |
2304df62 |
739 | pop(@args); |
740 | last; |
741 | } |
742 | } |
8e07c86e |
743 | if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { |
2304df62 |
744 | $min_args--; |
745 | $args[$i] = $1; |
746 | $defaults{$args[$i]} = $2; |
747 | $defaults{$args[$i]} =~ s/"/\\"/g; |
748 | } |
382b8d97 |
749 | $proto_arg[$i+1] = '$' ; |
2304df62 |
750 | } |
a0d0e21e |
751 | if (defined($class)) { |
2304df62 |
752 | $func_args = join(", ", @args[1..$#args]); |
753 | } else { |
754 | $func_args = join(", ", @args); |
755 | } |
756 | @args_match{@args} = 1..@args; |
757 | |
8e07c86e |
758 | $PPCODE = grep(/^\s*PPCODE\s*:/, @line); |
759 | $ALIAS = grep(/^\s*ALIAS\s*:/, @line); |
760 | |
2304df62 |
761 | # print function header |
a0d0e21e |
762 | print Q<<"EOF"; |
763 | #XS(XS_${Packid}_$func_name) |
2304df62 |
764 | #[[ |
a0d0e21e |
765 | # dXSARGS; |
93a17b20 |
766 | EOF |
8e07c86e |
767 | print Q<<"EOF" if $ALIAS ; |
768 | # dXSI32; |
769 | EOF |
2304df62 |
770 | if ($elipsis) { |
8e07c86e |
771 | $cond = ($min_args ? qq(items < $min_args) : 0); |
2304df62 |
772 | } |
773 | elsif ($min_args == $num_args) { |
774 | $cond = qq(items != $min_args); |
775 | } |
776 | else { |
777 | $cond = qq(items < $min_args || items > $num_args); |
778 | } |
8990e307 |
779 | |
2304df62 |
780 | print Q<<"EOF" if $except; |
781 | # char errbuf[1024]; |
782 | # *errbuf = '\0'; |
783 | EOF |
784 | |
8e07c86e |
785 | if ($ALIAS) |
786 | { print Q<<"EOF" if $cond } |
787 | # if ($cond) |
788 | # croak("Usage: %s($orig_args)", GvNAME(CvGV(cv))); |
789 | EOF |
790 | else |
791 | { print Q<<"EOF" if $cond } |
792 | # if ($cond) |
8990e307 |
793 | # croak("Usage: $pname($orig_args)"); |
93a17b20 |
794 | EOF |
795 | |
a0d0e21e |
796 | print Q<<"EOF" if $PPCODE; |
797 | # SP -= items; |
798 | EOF |
799 | |
2304df62 |
800 | # Now do a block of some sort. |
93a17b20 |
801 | |
2304df62 |
802 | $condnum = 0; |
8e07c86e |
803 | $cond = ''; # last CASE: condidional |
804 | push(@line, "$END:"); |
805 | push(@line_no, $line_no[-1]); |
806 | $_ = ''; |
807 | &check_cpp; |
2304df62 |
808 | while (@line) { |
8e07c86e |
809 | &CASE_handler if check_keyword("CASE"); |
810 | print Q<<"EOF"; |
811 | # $except [[ |
93a17b20 |
812 | EOF |
813 | |
814 | # do initialization of input variables |
815 | $thisdone = 0; |
816 | $retvaldone = 0; |
463ee0b2 |
817 | $deferred = ""; |
c2960299 |
818 | %arg_list = () ; |
819 | $gotRETVAL = 0; |
f06db76b |
820 | |
8fc38fda |
821 | INPUT_handler() ; |
822 | process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE") ; |
823 | |
a0d0e21e |
824 | if (!$thisdone && defined($class)) { |
8fc38fda |
825 | if (defined($static) or $func_name =~ /^new/) { |
a0d0e21e |
826 | print "\tchar *"; |
827 | $var_types{"CLASS"} = "char *"; |
828 | &generate_init("char *", 1, "CLASS"); |
829 | } |
830 | else { |
93a17b20 |
831 | print "\t$class *"; |
832 | $var_types{"THIS"} = "$class *"; |
833 | &generate_init("$class *", 1, "THIS"); |
a0d0e21e |
834 | } |
93a17b20 |
835 | } |
836 | |
837 | # do code |
838 | if (/^\s*NOT_IMPLEMENTED_YET/) { |
4633a7c4 |
839 | print "\n\tcroak(\"$pname: not implemented yet\");\n"; |
840 | $_ = '' ; |
93a17b20 |
841 | } else { |
842 | if ($ret_type ne "void") { |
843 | print "\t" . &map_type($ret_type) . "\tRETVAL;\n" |
844 | if !$retvaldone; |
845 | $args_match{"RETVAL"} = 0; |
846 | $var_types{"RETVAL"} = $ret_type; |
847 | } |
8e07c86e |
848 | print $deferred; |
8fc38fda |
849 | process_keyword("INIT|ALIAS|PROTOTYPE") ; |
8e07c86e |
850 | |
851 | if (check_keyword("PPCODE")) { |
8fc38fda |
852 | print_section(); |
8e07c86e |
853 | death ("PPCODE must be last thing") if @line; |
a0d0e21e |
854 | print "\tPUTBACK;\n\treturn;\n"; |
8e07c86e |
855 | } elsif (check_keyword("CODE")) { |
8fc38fda |
856 | print_section() ; |
857 | } elsif (defined($class) and $func_name eq "DESTROY") { |
a0d0e21e |
858 | print "\n\t"; |
8e07c86e |
859 | print "delete THIS;\n"; |
93a17b20 |
860 | } else { |
861 | print "\n\t"; |
862 | if ($ret_type ne "void") { |
463ee0b2 |
863 | print "RETVAL = "; |
e50aee73 |
864 | $wantRETVAL = 1; |
93a17b20 |
865 | } |
866 | if (defined($static)) { |
a0d0e21e |
867 | if ($func_name =~ /^new/) { |
8fc38fda |
868 | $func_name = "$class"; |
8e07c86e |
869 | } else { |
870 | print "${class}::"; |
a0d0e21e |
871 | } |
93a17b20 |
872 | } elsif (defined($class)) { |
8fc38fda |
873 | if ($func_name =~ /^new/) { |
874 | $func_name .= " $class"; |
875 | } else { |
93a17b20 |
876 | print "THIS->"; |
8fc38fda |
877 | } |
93a17b20 |
878 | } |
e50aee73 |
879 | $func_name =~ s/^($spat)// |
880 | if defined($spat); |
93a17b20 |
881 | print "$func_name($func_args);\n"; |
93a17b20 |
882 | } |
883 | } |
884 | |
885 | # do output variables |
8e07c86e |
886 | $gotRETVAL = 0; |
887 | undef $RETVAL_code ; |
888 | undef %outargs ; |
8fc38fda |
889 | process_keyword("OUTPUT|ALIAS|PROTOTYPE"); |
f06db76b |
890 | |
891 | # all OUTPUT done, so now push the return value on the stack |
8e07c86e |
892 | if ($gotRETVAL && $RETVAL_code) { |
893 | print "\t$RETVAL_code\n"; |
894 | } elsif ($gotRETVAL || $wantRETVAL) { |
895 | &generate_output($ret_type, 0, 'RETVAL'); |
896 | } |
f06db76b |
897 | |
93a17b20 |
898 | # do cleanup |
8fc38fda |
899 | process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; |
8e07c86e |
900 | |
93a17b20 |
901 | # print function trailer |
8e07c86e |
902 | print Q<<EOF; |
2304df62 |
903 | # ]] |
8e07c86e |
904 | EOF |
905 | print Q<<EOF if $except; |
8990e307 |
906 | # BEGHANDLERS |
907 | # CATCHALL |
908 | # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); |
909 | # ENDHANDLERS |
93a17b20 |
910 | EOF |
8e07c86e |
911 | if (check_keyword("CASE")) { |
912 | blurt ("Error: No `CASE:' at top of function") |
913 | unless $condnum; |
914 | $_ = "CASE: $_"; # Restore CASE: label |
915 | next; |
8990e307 |
916 | } |
8e07c86e |
917 | last if $_ eq "$END:"; |
918 | death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); |
2304df62 |
919 | } |
a0d0e21e |
920 | |
2304df62 |
921 | print Q<<EOF if $except; |
922 | # if (errbuf[0]) |
923 | # croak(errbuf); |
924 | EOF |
a0d0e21e |
925 | |
926 | print Q<<EOF unless $PPCODE; |
927 | # XSRETURN(1); |
928 | EOF |
929 | |
2304df62 |
930 | print Q<<EOF; |
2304df62 |
931 | #]] |
8990e307 |
932 | # |
93a17b20 |
933 | EOF |
382b8d97 |
934 | |
935 | # Build the prototype string for the xsub |
936 | if ($ProtoThisXSUB) { |
937 | if ($ProtoThisXSUB != 1) { |
938 | $ProtoXSUB{$pname} = '"' . $ProtoThisXSUB . '"' |
939 | } |
940 | else { |
941 | my $s = ';'; |
942 | if ($min_args < $num_args) { |
943 | $s = ''; |
944 | $proto_arg[$min_args] .= ";" ; |
945 | } |
946 | push @proto_arg, "${s}@" |
947 | if $elipsis ; |
948 | |
949 | $ProtoXSUB{$pname} = '"' . join ("", @proto_arg) . '"' |
950 | } |
951 | } |
952 | |
93a17b20 |
953 | } |
954 | |
955 | # print initialization routine |
8990e307 |
956 | print Q<<"EOF"; |
4633a7c4 |
957 | ##ifdef __cplusplus |
958 | #extern "C" |
959 | ##endif |
a0d0e21e |
960 | #XS(boot_$Module_cname) |
2304df62 |
961 | #[[ |
a0d0e21e |
962 | # dXSARGS; |
8990e307 |
963 | # char* file = __FILE__; |
964 | # |
93a17b20 |
965 | EOF |
966 | |
8fc38fda |
967 | print Q<<"EOF" if $WantVersionChk ; |
968 | # XS_VERSION_BOOTCHECK ; |
969 | # |
970 | EOF |
971 | |
8e07c86e |
972 | print Q<<"EOF" if defined %XsubAliases ; |
973 | # { |
974 | # CV * cv ; |
975 | # |
976 | EOF |
977 | |
93a17b20 |
978 | for (@Func_name) { |
2304df62 |
979 | $pname = shift(@Func_pname); |
382b8d97 |
980 | my $newXS = "newXS" ; |
981 | my $proto = "" ; |
982 | |
983 | if ($ProtoXSUB{$pname}) { |
984 | $newXS = "newXSproto" ; |
985 | $proto = ", $ProtoXSUB{$pname}" ; |
986 | } |
8e07c86e |
987 | |
988 | if ($XsubAliases{$pname}) { |
989 | $XsubAliases{$pname}{$pname} = 0 |
990 | unless defined $XsubAliases{$pname}{$pname} ; |
991 | while ( ($name, $value) = each %{$XsubAliases{$pname}}) { |
992 | print Q<<"EOF" ; |
993 | # cv = newXS(\"$name\", XS_$_, file); |
994 | # XSANY.any_i32 = $value ; |
995 | EOF |
382b8d97 |
996 | print Q<<"EOF" if $proto ; |
c07a80fd |
997 | # sv_setpv((SV*)cv, $ProtoXSUB{$pname}) ; |
382b8d97 |
998 | EOF |
8e07c86e |
999 | } |
1000 | } |
1001 | else { |
382b8d97 |
1002 | print " ${newXS}(\"$pname\", XS_$_, file$proto);\n"; |
8e07c86e |
1003 | } |
a0d0e21e |
1004 | } |
1005 | |
8e07c86e |
1006 | print Q<<"EOF" if defined %XsubAliases ; |
1007 | # } |
1008 | EOF |
1009 | |
a0d0e21e |
1010 | if (@BootCode) |
1011 | { |
8e07c86e |
1012 | print "\n /* Initialisation Section */\n" ; |
a0d0e21e |
1013 | print grep (s/$/\n/, @BootCode) ; |
8e07c86e |
1014 | print "\n /* End of Initialisation Section */\n\n" ; |
93a17b20 |
1015 | } |
a0d0e21e |
1016 | |
e50aee73 |
1017 | print Q<<"EOF";; |
1018 | # ST(0) = &sv_yes; |
1019 | # XSRETURN(1); |
1020 | #]] |
1021 | EOF |
1022 | |
8fc38fda |
1023 | warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") |
1024 | unless $ProtoUsed ; |
e50aee73 |
1025 | &Exit; |
1026 | |
93a17b20 |
1027 | |
1028 | sub output_init { |
2304df62 |
1029 | local($type, $num, $init) = @_; |
a0d0e21e |
1030 | local($arg) = "ST(" . ($num - 1) . ")"; |
93a17b20 |
1031 | |
2304df62 |
1032 | eval qq/print " $init\\\n"/; |
93a17b20 |
1033 | } |
1034 | |
c2960299 |
1035 | sub Warn |
1036 | { |
1037 | # work out the line number |
1038 | my $line_no = $line_no[@line_no - @line -1] ; |
1039 | |
1040 | print STDERR "@_ in $filename, line $line_no\n" ; |
1041 | } |
1042 | |
1043 | sub blurt |
1044 | { |
1045 | Warn @_ ; |
1046 | $errors ++ |
1047 | } |
1048 | |
1049 | sub death |
1050 | { |
1051 | Warn @_ ; |
1052 | exit 1 ; |
1053 | } |
8990e307 |
1054 | |
93a17b20 |
1055 | sub generate_init { |
2304df62 |
1056 | local($type, $num, $var) = @_; |
a0d0e21e |
1057 | local($arg) = "ST(" . ($num - 1) . ")"; |
2304df62 |
1058 | local($argoff) = $num - 1; |
1059 | local($ntype); |
1060 | local($tk); |
93a17b20 |
1061 | |
f06db76b |
1062 | $type = TidyType($type) ; |
c2960299 |
1063 | blurt("Error: '$type' not in typemap"), return |
1064 | unless defined($type_kind{$type}); |
1065 | |
2304df62 |
1066 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
8e07c86e |
1067 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 |
1068 | $tk = $type_kind{$type}; |
1069 | $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; |
8e07c86e |
1070 | $type =~ tr/:/_/; |
c2960299 |
1071 | blurt("Error: No INPUT definition for type '$type' found"), return |
1072 | unless defined $input_expr{$tk} ; |
2304df62 |
1073 | $expr = $input_expr{$tk}; |
1074 | if ($expr =~ /DO_ARRAY_ELEM/) { |
c2960299 |
1075 | blurt("Error: '$subtype' not in typemap"), return |
1076 | unless defined($type_kind{$subtype}); |
1077 | blurt("Error: No INPUT definition for type '$subtype' found"), return |
1078 | unless defined $input_expr{$type_kind{$subtype}} ; |
2304df62 |
1079 | $subexpr = $input_expr{$type_kind{$subtype}}; |
1080 | $subexpr =~ s/ntype/subtype/g; |
1081 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
1082 | $subexpr =~ s/\n\t/\n\t\t/g; |
1083 | $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g; |
a0d0e21e |
1084 | $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; |
2304df62 |
1085 | $expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
1086 | } |
1087 | if (defined($defaults{$var})) { |
1088 | $expr =~ s/(\t+)/$1 /g; |
1089 | $expr =~ s/ /\t/g; |
1090 | eval qq/print "\\t$var;\\n"/; |
1091 | $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; |
1092 | } elsif ($expr !~ /^\t\$var =/) { |
1093 | eval qq/print "\\t$var;\\n"/; |
1094 | $deferred .= eval qq/"\\n$expr;\\n"/; |
1095 | } else { |
1096 | eval qq/print "$expr;\\n"/; |
1097 | } |
93a17b20 |
1098 | } |
1099 | |
1100 | sub generate_output { |
2304df62 |
1101 | local($type, $num, $var) = @_; |
a0d0e21e |
1102 | local($arg) = "ST(" . ($num - ($num != 0)) . ")"; |
2304df62 |
1103 | local($argoff) = $num - 1; |
1104 | local($ntype); |
93a17b20 |
1105 | |
f06db76b |
1106 | $type = TidyType($type) ; |
2304df62 |
1107 | if ($type =~ /^array\(([^,]*),(.*)\)/) { |
1108 | print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; |
1109 | } else { |
f06db76b |
1110 | blurt("Error: '$type' not in typemap"), return |
2304df62 |
1111 | unless defined($type_kind{$type}); |
c2960299 |
1112 | blurt("Error: No OUTPUT definition for type '$type' found"), return |
1113 | unless defined $output_expr{$type_kind{$type}} ; |
2304df62 |
1114 | ($ntype = $type) =~ s/\s*\*/Ptr/g; |
1115 | $ntype =~ s/\(\)//g; |
8e07c86e |
1116 | ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2304df62 |
1117 | $expr = $output_expr{$type_kind{$type}}; |
1118 | if ($expr =~ /DO_ARRAY_ELEM/) { |
c2960299 |
1119 | blurt("Error: '$subtype' not in typemap"), return |
1120 | unless defined($type_kind{$subtype}); |
1121 | blurt("Error: No OUTPUT definition for type '$subtype' found"), return |
1122 | unless defined $output_expr{$type_kind{$subtype}} ; |
2304df62 |
1123 | $subexpr = $output_expr{$type_kind{$subtype}}; |
1124 | $subexpr =~ s/ntype/subtype/g; |
1125 | $subexpr =~ s/\$arg/ST(ix_$var)/g; |
1126 | $subexpr =~ s/\$var/${var}[ix_$var]/g; |
1127 | $subexpr =~ s/\n\t/\n\t\t/g; |
1128 | $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; |
a0d0e21e |
1129 | eval "print qq\a$expr\a"; |
2304df62 |
1130 | } |
a0d0e21e |
1131 | elsif ($var eq 'RETVAL') { |
2304df62 |
1132 | if ($expr =~ /^\t\$arg = /) { |
a0d0e21e |
1133 | eval "print qq\a$expr\a"; |
2304df62 |
1134 | print "\tsv_2mortal(ST(0));\n"; |
93a17b20 |
1135 | } |
2304df62 |
1136 | else { |
8990e307 |
1137 | print "\tST(0) = sv_newmortal();\n"; |
a0d0e21e |
1138 | eval "print qq\a$expr\a"; |
463ee0b2 |
1139 | } |
2304df62 |
1140 | } |
a0d0e21e |
1141 | elsif ($arg =~ /^ST\(\d+\)$/) { |
1142 | eval "print qq\a$expr\a"; |
1143 | } |
2304df62 |
1144 | } |
93a17b20 |
1145 | } |
1146 | |
1147 | sub map_type { |
e50aee73 |
1148 | my($type) = @_; |
93a17b20 |
1149 | |
8e07c86e |
1150 | $type =~ tr/:/_/; |
1151 | $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; |
1152 | $type; |
93a17b20 |
1153 | } |
8990e307 |
1154 | |
e50aee73 |
1155 | |
1156 | sub Exit { |
748a9306 |
1157 | # If this is VMS, the exit status has meaning to the shell, so we |
8fc38fda |
1158 | # use a predictable value (SS$_Normal or SS$_Abort) rather than an |
1159 | # arbitrary number. |
1160 | exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; |
e50aee73 |
1161 | } |