This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
remove prehistoric XFree() gunk
[perl5.git] / lib / ExtUtils / xsubpp
CommitLineData
2304df62 1#!./miniperl
75f92628
AD
2
3=head1 NAME
4
5xsubpp - compiler to convert Perl XS code into C code
6
7=head1 SYNOPSIS
8
c5be433b 9B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] ... file.xs
75f92628
AD
10
11=head1 DESCRIPTION
12
13I<xsubpp> will compile XS code into C code by embedding the constructs
14necessary to let C functions manipulate Perl values and creates the glue
15necessary to let Perl access those functions. The compiler uses typemaps to
16determine how to map C function parameters and variables to Perl values.
17
18The compiler will search for typemap files called I<typemap>. It will use
19the following search path to find default typemaps, with the rightmost
20typemap taking precedence.
21
22 ../../../typemap:../../typemap:../typemap:typemap
23
24=head1 OPTIONS
25
26=over 5
27
28=item B<-C++>
29
30Adds ``extern "C"'' to the C code.
31
32
33=item B<-except>
34
35Adds exception handling stubs to the C code.
36
37=item B<-typemap typemap>
38
39Indicates that a user-supplied typemap should take precedence over the
40default typemaps. This option may be used multiple times, with the last
41typemap having the highest precedence.
42
8e07c86e
AD
43=item B<-v>
44
45Prints the I<xsubpp> version number to standard output, then exits.
46
8fc38fda 47=item B<-prototypes>
382b8d97 48
8fc38fda
PP
49By default I<xsubpp> will not automatically generate prototype code for
50all xsubs. This flag will enable prototypes.
51
52=item B<-noversioncheck>
53
54Disables the run time test that determines if the object file (derived
55from the C<.xs> file) and the C<.pm> files have the same version
56number.
382b8d97 57
6f1abe2b
JT
58=item B<-nolinenumbers>
59
60Prevents the inclusion of `#line' directives in the output.
61
c5be433b 62=back
75f92628
AD
63
64=head1 ENVIRONMENT
65
66No environment variables are used.
67
68=head1 AUTHOR
69
70Larry Wall
71
f06db76b
AD
72=head1 MODIFICATION HISTORY
73
8e07c86e 74See the file F<changes.pod>.
e50aee73 75
75f92628
AD
76=head1 SEE ALSO
77
55a00e51 78perl(1), perlxs(1), perlxstut(1)
75f92628
AD
79
80=cut
93a17b20 81
382b8d97 82require 5.002;
774d564b 83use Cwd;
4230ab3f 84use vars '$cplusplus';
7ad6fb0b 85use vars '%v';
382b8d97 86
01f988be
GS
87use Config;
88
aa689395
PP
89sub Q ;
90
774d564b 91# Global Constants
774d564b 92
cfc02341 93$XSUBPP_version = "1.9507";
aa689395
PP
94
95my ($Is_VMS, $SymSet);
96if ($^O eq 'VMS') {
97 $Is_VMS = 1;
98 # Establish set of global symbols with max length 28, since xsubpp
99 # will later add the 'XS_' prefix.
100 require ExtUtils::XSSymSet;
101 $SymSet = new ExtUtils::XSSymSet 28;
102}
8fc38fda 103
c07a80fd 104$FH = 'File0000' ;
8fc38fda 105
6f1abe2b 106$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n";
f06db76b 107
382b8d97 108$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
01f988be
GS
109# mjn
110$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
93a17b20 111
8e07c86e 112$except = "";
8fc38fda
PP
113$WantPrototypes = -1 ;
114$WantVersionChk = 1 ;
115$ProtoUsed = 0 ;
6f1abe2b 116$WantLineNumbers = 1 ;
8e07c86e 117SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
93a17b20 118 $flag = shift @ARGV;
e50aee73 119 $flag =~ s/^-// ;
ff68c719 120 $spat = quotemeta shift, next SWITCH if $flag eq 's';
8990e307 121 $cplusplus = 1, next SWITCH if $flag eq 'C++';
382b8d97
PM
122 $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes';
123 $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
8fc38fda
PP
124 $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck';
125 $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck';
c5be433b 126 # XXX left this in for compat
b207eff1 127 $WantCAPI = 1, next SWITCH if $flag eq 'object_capi';
8e07c86e 128 $except = " TRY", next SWITCH if $flag eq 'except';
8990e307 129 push(@tm,shift), next SWITCH if $flag eq 'typemap';
6f1abe2b
JT
130 $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers';
131 $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers';
8e07c86e
AD
132 (print "xsubpp version $XSUBPP_version\n"), exit
133 if $flag eq 'v';
93a17b20
LW
134 die $usage;
135}
8fc38fda
PP
136if ($WantPrototypes == -1)
137 { $WantPrototypes = 0}
138else
139 { $ProtoUsed = 1 }
140
141
8990e307 142@ARGV == 1 or die $usage;
c2960299 143($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
57497940 144 or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
c2960299 145 or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
8990e307
LW
146 or ($dir, $filename) = ('.', $ARGV[0]);
147chdir($dir);
774d564b 148$pwd = cwd();
8fc38fda
PP
149
150++ $IncludedFiles{$ARGV[0]} ;
93a17b20 151
4230ab3f
PP
152my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs
153my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
aa689395 154
4230ab3f 155
f06db76b
AD
156sub TrimWhitespace
157{
158 $_[0] =~ s/^\s+|\s+$//go ;
159}
160
161sub TidyType
162{
163 local ($_) = @_ ;
164
165 # rationalise any '*' by joining them into bunches and removing whitespace
166 s#\s*(\*+)\s*#$1#g;
e50aee73 167 s#(\*+)# $1 #g ;
f06db76b
AD
168
169 # change multiple whitespace into a single space
170 s/\s+/ /g ;
171
172 # trim leading & trailing whitespace
173 TrimWhitespace($_) ;
174
175 $_ ;
176}
177
93a17b20 178$typemap = shift @ARGV;
8990e307
LW
179foreach $typemap (@tm) {
180 die "Can't find $typemap in $pwd\n" unless -r $typemap;
93a17b20 181}
748a9306
LW
182unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
183 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
184 ../typemap typemap);
8990e307 185foreach $typemap (@tm) {
f06db76b
AD
186 next unless -e $typemap ;
187 # skip directories, binary files etc.
188 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
189 unless -T $typemap ;
190 open(TYPEMAP, $typemap)
191 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
e50aee73 192 $mode = 'Typemap';
c2960299 193 $junk = "" ;
8990e307
LW
194 $current = \$junk;
195 while (<TYPEMAP>) {
e50aee73 196 next if /^\s*#/;
e1f0c0aa 197 my $line_no = $. + 1;
8e07c86e
AD
198 if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
199 if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
200 if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
e50aee73
AD
201 if ($mode eq 'Typemap') {
202 chomp;
f06db76b
AD
203 my $line = $_ ;
204 TrimWhitespace($_) ;
205 # skip blank lines and comment lines
206 next if /^$/ or /^#/ ;
382b8d97
PM
207 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
208 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
209 $type = TidyType($type) ;
210 $type_kind{$type} = $kind ;
211 # prototype defaults to '$'
93d3b392 212 $proto = "\$" unless $proto ;
382b8d97
PM
213 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
214 unless ValidProtoString($proto) ;
215 $proto_letter{$type} = C_string($proto) ;
8e07c86e
AD
216 }
217 elsif (/^\s/) {
218 $$current .= $_;
463ee0b2 219 }
e50aee73 220 elsif ($mode eq 'Input') {
8e07c86e
AD
221 s/\s+$//;
222 $input_expr{$_} = '';
223 $current = \$input_expr{$_};
93a17b20 224 }
8990e307 225 else {
8e07c86e
AD
226 s/\s+$//;
227 $output_expr{$_} = '';
228 $current = \$output_expr{$_};
93a17b20 229 }
8990e307
LW
230 }
231 close(TYPEMAP);
232}
93a17b20 233
8990e307
LW
234foreach $key (keys %input_expr) {
235 $input_expr{$key} =~ s/\n+$//;
236}
93a17b20 237
8e07c86e
AD
238$END = "!End!\n\n"; # "impossible" keyword (multiple newline)
239
240# Match an XS keyword
382b8d97
PM
241$BLOCK_re= '\s*(' . join('|', qw(
242 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
8fc38fda 243 CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
cfc02341 244 SCOPE INTERFACE INTERFACE_MACRO C_ARGS
382b8d97 245 )) . "|$END)\\s*:";
8e07c86e
AD
246
247# Input: ($_, @line) == unparsed input.
248# Output: ($_, @line) == (rest of line, following lines).
249# Return: the matched keyword if found, otherwise 0
250sub check_keyword {
251 $_ = shift(@line) while !/\S/ && @line;
252 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
253}
254
255
6f1abe2b
JT
256if ($WantLineNumbers) {
257 {
258 package xsubpp::counter;
259 sub TIEHANDLE {
260 my ($class, $cfile) = @_;
261 my $buf = "";
262 $SECTION_END_MARKER = "#line --- \"$cfile\"";
263 $line_no = 1;
264 bless \$buf;
265 }
266
267 sub PRINT {
268 my $self = shift;
269 for (@_) {
270 $$self .= $_;
271 while ($$self =~ s/^([^\n]*\n)//) {
272 my $line = $1;
273 ++ $line_no;
274 $line =~ s|^\#line\s+---(?=\s)|#line $line_no|;
275 print STDOUT $line;
276 }
277 }
278 }
279
280 sub PRINTF {
281 my $self = shift;
282 my $fmt = shift;
283 $self->PRINT(sprintf($fmt, @_));
284 }
285
286 sub DESTROY {
287 # Not necessary if we're careful to end with a "\n"
288 my $self = shift;
289 print STDOUT $$self;
290 }
291 }
292
293 my $cfile = $filename;
294 $cfile =~ s/\.xs$/.c/i or $cfile .= ".c";
295 tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile);
296 select PSEUDO_STDOUT;
297}
298
8e07c86e 299sub print_section {
6f1abe2b
JT
300 # the "do" is required for right semantics
301 do { $_ = shift(@line) } while !/\S/ && @line;
302
303 print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
d3308daf 304 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
8e07c86e
AD
305 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
306 print "$_\n";
307 }
6f1abe2b 308 print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
8e07c86e
AD
309}
310
cfc02341
IZ
311sub merge_section {
312 my $in = '';
313
314 while (!/\S/ && @line) {
315 $_ = shift(@line);
316 }
317
318 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
319 $in .= "$_\n";
320 }
321 chomp $in;
322 return $in;
323}
324
8fc38fda
PP
325sub process_keyword($)
326{
327 my($pattern) = @_ ;
328 my $kwd ;
329
330 &{"${kwd}_handler"}()
331 while $kwd = check_keyword($pattern) ;
332}
333
8e07c86e
AD
334sub CASE_handler {
335 blurt ("Error: `CASE:' after unconditional `CASE:'")
336 if $condnum && $cond eq '';
337 $cond = $_;
338 TrimWhitespace($cond);
339 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
340 $_ = '' ;
341}
342
343sub INPUT_handler {
344 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
345 last if /^\s*NOT_IMPLEMENTED_YET/;
346 next unless /\S/; # skip blank lines
347
348 TrimWhitespace($_) ;
349 my $line = $_ ;
350
351 # remove trailing semicolon if no initialisation
7ad6fb0b 352 s/\s*;$//g unless /[=;+].*\S/ ;
8e07c86e
AD
353
354 # check for optional initialisation code
355 my $var_init = '' ;
7ad6fb0b 356 $var_init = $1 if s/\s*([=;+].*)$//s ;
8e07c86e
AD
357 $var_init =~ s/"/\\"/g;
358
359 s/\s+/ /g;
360 my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
361 or blurt("Error: invalid argument declaration '$line'"), next;
362
363 # Check for duplicate definitions
364 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
365 if $arg_list{$var_name} ++ ;
366
367 $thisdone |= $var_name eq "THIS";
368 $retvaldone |= $var_name eq "RETVAL";
369 $var_types{$var_name} = $var_type;
370 print "\t" . &map_type($var_type);
371 $var_num = $args_match{$var_name};
382b8d97 372
8fc38fda
PP
373 $proto_arg[$var_num] = ProtoString($var_type)
374 if $var_num ;
8e07c86e
AD
375 if ($var_addr) {
376 $var_addr{$var_name} = 1;
377 $func_args =~ s/\b($var_name)\b/&$1/;
378 }
7ad6fb0b 379 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) {
8e07c86e
AD
380 print "\t$var_name;\n";
381 } elsif ($var_init =~ /\S/) {
7ad6fb0b 382 &output_init($var_type, $var_num, $var_name, $var_init);
8e07c86e
AD
383 } elsif ($var_num) {
384 # generate initialization code
385 &generate_init($var_type, $var_num, $var_name);
386 } else {
387 print ";\n";
388 }
389 }
390}
391
392sub OUTPUT_handler {
393 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
394 next unless /\S/;
ef50df4b
GS
395 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
396 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
397 next;
398 }
8e07c86e
AD
399 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
400 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
401 if $outargs{$outarg} ++ ;
402 if (!$gotRETVAL and $outarg eq 'RETVAL') {
403 # deal with RETVAL last
404 $RETVAL_code = $outcode ;
405 $gotRETVAL = 1 ;
406 next ;
407 }
408 blurt ("Error: OUTPUT $outarg not an argument"), next
409 unless defined($args_match{$outarg});
410 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
411 unless defined $var_types{$outarg} ;
f78230ad 412 $var_num = $args_match{$outarg};
8e07c86e
AD
413 if ($outcode) {
414 print "\t$outcode\n";
f78230ad 415 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
8e07c86e 416 } else {
ef50df4b 417 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
8e07c86e
AD
418 }
419 }
420}
421
cfc02341
IZ
422sub C_ARGS_handler() {
423 my $in = merge_section();
424
425 TrimWhitespace($in);
426 $func_args = $in;
427}
428
429sub INTERFACE_MACRO_handler() {
430 my $in = merge_section();
431
432 TrimWhitespace($in);
433 if ($in =~ /\s/) { # two
434 ($interface_macro, $interface_macro_set) = split ' ', $in;
435 } else {
436 $interface_macro = $in;
437 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
438 }
439 $interface = 1; # local
440 $Interfaces = 1; # global
441}
442
443sub INTERFACE_handler() {
444 my $in = merge_section();
445
446 TrimWhitespace($in);
447
448 foreach (split /[\s,]+/, $in) {
449 $Interfaces{$_} = $_;
450 }
451 print Q<<"EOF";
452# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
453EOF
454 $interface = 1; # local
455 $Interfaces = 1; # global
456}
457
8fc38fda
PP
458sub CLEANUP_handler() { print_section() }
459sub PREINIT_handler() { print_section() }
460sub INIT_handler() { print_section() }
461
8e07c86e
AD
462sub GetAliases
463{
464 my ($line) = @_ ;
465 my ($orig) = $line ;
466 my ($alias) ;
467 my ($value) ;
468
469 # Parse alias definitions
470 # format is
471 # alias = value alias = value ...
472
473 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
474 $alias = $1 ;
475 $orig_alias = $alias ;
476 $value = $2 ;
477
478 # check for optional package definition in the alias
479 $alias = $Packprefix . $alias if $alias !~ /::/ ;
480
481 # check for duplicate alias name & duplicate value
482 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
4230ab3f 483 if defined $XsubAliases{$alias} ;
8e07c86e 484
4230ab3f
PP
485 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
486 if $XsubAliasValues{$value} ;
8e07c86e 487
4230ab3f
PP
488 $XsubAliases = 1;
489 $XsubAliases{$alias} = $value ;
490 $XsubAliasValues{$value} = $orig_alias ;
8e07c86e
AD
491 }
492
493 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
494 if $line ;
495}
496
382b8d97 497sub ALIAS_handler ()
8e07c86e
AD
498{
499 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
500 next unless /\S/;
501 TrimWhitespace($_) ;
502 GetAliases($_) if $_ ;
503 }
504}
505
382b8d97 506sub REQUIRE_handler ()
8e07c86e
AD
507{
508 # the rest of the current line should contain a version number
509 my ($Ver) = $_ ;
510
511 TrimWhitespace($Ver) ;
512
513 death ("Error: REQUIRE expects a version number")
514 unless $Ver ;
515
516 # check that the version number is of the form n.n
517 death ("Error: REQUIRE: expected a number, got '$Ver'")
518 unless $Ver =~ /^\d+(\.\d*)?/ ;
519
520 death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
521 unless $XSUBPP_version >= $Ver ;
522}
523
8fc38fda
PP
524sub VERSIONCHECK_handler ()
525{
526 # the rest of the current line should contain either ENABLE or
527 # DISABLE
528
529 TrimWhitespace($_) ;
530
531 # check for ENABLE/DISABLE
532 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
533 unless /^(ENABLE|DISABLE)/i ;
534
535 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
536 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
537
538}
539
382b8d97
PM
540sub PROTOTYPE_handler ()
541{
7d41bd0a
PM
542 my $specified ;
543
c07a80fd
PP
544 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
545 if $proto_in_this_xsub ++ ;
546
382b8d97
PM
547 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
548 next unless /\S/;
7d41bd0a 549 $specified = 1 ;
382b8d97
PM
550 TrimWhitespace($_) ;
551 if ($_ eq 'DISABLE') {
552 $ProtoThisXSUB = 0
553 }
554 elsif ($_ eq 'ENABLE') {
555 $ProtoThisXSUB = 1
556 }
557 else {
558 # remove any whitespace
559 s/\s+//g ;
560 death("Error: Invalid prototype '$_'")
561 unless ValidProtoString($_) ;
562 $ProtoThisXSUB = C_string($_) ;
563 }
564 }
c07a80fd 565
7d41bd0a
PM
566 # If no prototype specified, then assume empty prototype ""
567 $ProtoThisXSUB = 2 unless $specified ;
568
8fc38fda 569 $ProtoUsed = 1 ;
c07a80fd 570
382b8d97
PM
571}
572
db3b9414
PP
573sub SCOPE_handler ()
574{
575 death("Error: Only 1 SCOPE declaration allowed per xsub")
576 if $scope_in_this_xsub ++ ;
577
578 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
579 next unless /\S/;
580 TrimWhitespace($_) ;
581 if ($_ =~ /^DISABLE/i) {
582 $ScopeThisXSUB = 0
583 }
584 elsif ($_ =~ /^ENABLE/i) {
585 $ScopeThisXSUB = 1
586 }
587 }
588
589}
590
382b8d97
PM
591sub PROTOTYPES_handler ()
592{
593 # the rest of the current line should contain either ENABLE or
594 # DISABLE
595
596 TrimWhitespace($_) ;
597
598 # check for ENABLE/DISABLE
599 death ("Error: PROTOTYPES: ENABLE/DISABLE")
600 unless /^(ENABLE|DISABLE)/i ;
601
602 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
603 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
8fc38fda 604 $ProtoUsed = 1 ;
382b8d97
PM
605
606}
607
8fc38fda
PP
608sub INCLUDE_handler ()
609{
610 # the rest of the current line should contain a valid filename
611
612 TrimWhitespace($_) ;
613
8fc38fda
PP
614 death("INCLUDE: filename missing")
615 unless $_ ;
616
617 death("INCLUDE: output pipe is illegal")
618 if /^\s*\|/ ;
619
620 # simple minded recursion detector
621 death("INCLUDE loop detected")
622 if $IncludedFiles{$_} ;
623
624 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
625
626 # Save the current file context.
4230ab3f
PP
627 push(@XSStack, {
628 type => 'file',
8fc38fda
PP
629 LastLine => $lastline,
630 LastLineNo => $lastline_no,
631 Line => \@line,
632 LineNo => \@line_no,
633 Filename => $filename,
c07a80fd 634 Handle => $FH,
8fc38fda
PP
635 }) ;
636
c07a80fd 637 ++ $FH ;
8fc38fda
PP
638
639 # open the new file
c07a80fd 640 open ($FH, "$_") or death("Cannot open '$_': $!") ;
8fc38fda
PP
641
642 print Q<<"EOF" ;
643#
644#/* INCLUDE: Including '$_' from '$filename' */
645#
646EOF
647
8fc38fda
PP
648 $filename = $_ ;
649
c07a80fd
PP
650 # Prime the pump by reading the first
651 # non-blank line
652
653 # skip leading blank lines
654 while (<$FH>) {
655 last unless /^\s*$/ ;
656 }
657
658 $lastline = $_ ;
8fc38fda
PP
659 $lastline_no = $. ;
660
661}
662
663sub PopFile()
664{
4230ab3f
PP
665 return 0 unless $XSStack[-1]{type} eq 'file' ;
666
667 my $data = pop @XSStack ;
8fc38fda
PP
668 my $ThisFile = $filename ;
669 my $isPipe = ($filename =~ /\|\s*$/) ;
670
671 -- $IncludedFiles{$filename}
672 unless $isPipe ;
673
c07a80fd 674 close $FH ;
8fc38fda 675
c07a80fd 676 $FH = $data->{Handle} ;
8fc38fda
PP
677 $filename = $data->{Filename} ;
678 $lastline = $data->{LastLine} ;
679 $lastline_no = $data->{LastLineNo} ;
680 @line = @{ $data->{Line} } ;
681 @line_no = @{ $data->{LineNo} } ;
4230ab3f 682
8fc38fda
PP
683 if ($isPipe and $? ) {
684 -- $lastline_no ;
685 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
686 exit 1 ;
687 }
688
689 print Q<<"EOF" ;
690#
691#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
692#
693EOF
694
695 return 1 ;
696}
697
382b8d97
PM
698sub ValidProtoString ($)
699{
700 my($string) = @_ ;
701
702 if ( $string =~ /^$proto_re+$/ ) {
703 return $string ;
704 }
705
706 return 0 ;
707}
708
709sub C_string ($)
710{
711 my($string) = @_ ;
712
713 $string =~ s[\\][\\\\]g ;
714 $string ;
715}
716
717sub ProtoString ($)
718{
719 my ($type) = @_ ;
720
93d3b392 721 $proto_letter{$type} or "\$" ;
382b8d97
PM
722}
723
8e07c86e
AD
724sub check_cpp {
725 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
726 if (@cpp) {
727 my ($cpp, $cpplevel);
728 for $cpp (@cpp) {
729 if ($cpp =~ /^\#\s*if/) {
730 $cpplevel++;
731 } elsif (!$cpplevel) {
732 Warn("Warning: #else/elif/endif without #if in this function");
4230ab3f
PP
733 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
734 if $XSStack[-1]{type} eq 'if';
8e07c86e
AD
735 return;
736 } elsif ($cpp =~ /^\#\s*endif/) {
737 $cpplevel--;
738 }
739 }
740 Warn("Warning: #if without #endif in this function") if $cpplevel;
741 }
742}
743
744
8990e307 745sub Q {
e50aee73 746 my($text) = @_;
4633a7c4 747 $text =~ s/^#//gm;
2304df62
AD
748 $text =~ s/\[\[/{/g;
749 $text =~ s/\]\]/}/g;
8990e307 750 $text;
93a17b20
LW
751}
752
c07a80fd 753open($FH, $filename) or die "cannot open $filename: $!\n";
c2960299 754
f06db76b 755# Identify the version of xsubpp used
f06db76b 756print <<EOM ;
e50aee73
AD
757/*
758 * This file was generated automatically by xsubpp version $XSUBPP_version from the
93d3b392 759 * contents of $filename. Do not edit this file, edit $filename instead.
e50aee73
AD
760 *
761 * ANY CHANGES MADE HERE WILL BE LOST!
f06db76b
AD
762 *
763 */
e50aee73 764
f06db76b 765EOM
6f1abe2b
JT
766
767
768print("#line 1 \"$filename\"\n")
769 if $WantLineNumbers;
f06db76b 770
c07a80fd 771while (<$FH>) {
e50aee73
AD
772 last if ($Module, $Package, $Prefix) =
773 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
01f988be
GS
774
775 if ($OBJ) {
b85ee828 776 s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
01f988be 777 }
a0d0e21e 778 print $_;
93a17b20 779}
e50aee73
AD
780&Exit unless defined $_;
781
cfc02341
IZ
782print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
783
8fc38fda
PP
784$lastline = $_;
785$lastline_no = $.;
93a17b20 786
c07a80fd 787# Read next xsub into @line from ($lastline, <$FH>).
2304df62
AD
788sub fetch_para {
789 # parse paragraph
4230ab3f
PP
790 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
791 if !defined $lastline && $XSStack[-1]{type} eq 'if';
2304df62 792 @line = ();
c2960299 793 @line_no = () ;
4230ab3f 794 return PopFile() if !defined $lastline;
e50aee73
AD
795
796 if ($lastline =~
797 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
798 $Module = $1;
8e07c86e
AD
799 $Package = defined($2) ? $2 : ''; # keep -w happy
800 $Prefix = defined($3) ? $3 : ''; # keep -w happy
ff68c719 801 $Prefix = quotemeta $Prefix ;
e50aee73 802 ($Module_cname = $Module) =~ s/\W/_/g;
8e07c86e 803 ($Packid = $Package) =~ tr/:/_/;
e50aee73 804 $Packprefix = $Package;
8e07c86e 805 $Packprefix .= "::" if $Packprefix ne "";
2304df62 806 $lastline = "";
e50aee73
AD
807 }
808
809 for(;;) {
810 if ($lastline !~ /^\s*#/ ||
4230ab3f
PP
811 # CPP directives:
812 # ANSI: if ifdef ifndef elif else endif define undef
813 # line error pragma
814 # gcc: warning include_next
815 # obj-c: import
816 # others: ident (gcc notes that some cpps have this one)
817 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
e50aee73
AD
818 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
819 push(@line, $lastline);
820 push(@line_no, $lastline_no) ;
93a17b20 821 }
e50aee73
AD
822
823 # Read next line and continuation lines
c07a80fd 824 last unless defined($lastline = <$FH>);
e50aee73
AD
825 $lastline_no = $.;
826 my $tmp_line;
827 $lastline .= $tmp_line
c07a80fd 828 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
e50aee73 829
8e07c86e 830 chomp $lastline;
e50aee73 831 $lastline =~ s/^\s+$//;
2304df62 832 }
e50aee73 833 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
e50aee73 834 1;
2304df62 835}
93a17b20 836
c2960299 837PARAGRAPH:
8e07c86e 838while (fetch_para()) {
e50aee73 839 # Print initial preprocessor statements and blank lines
4230ab3f
PP
840 while (@line && $line[0] !~ /^[^\#]/) {
841 my $line = shift(@line);
842 print $line, "\n";
843 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
844 my $statement = $+;
845 if ($statement eq 'if') {
846 $XSS_work_idx = @XSStack;
847 push(@XSStack, {type => 'if'});
848 } else {
849 death ("Error: `$statement' with no matching `if'")
850 if $XSStack[-1]{type} ne 'if';
851 if ($XSStack[-1]{varname}) {
852 push(@InitFileCode, "#endif\n");
853 push(@BootCode, "#endif");
854 }
855
856 my(@fns) = keys %{$XSStack[-1]{functions}};
857 if ($statement ne 'endif') {
858 # Hide the functions defined in other #if branches, and reset.
859 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
860 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
861 } else {
862 my($tmp) = pop(@XSStack);
863 0 while (--$XSS_work_idx
864 && $XSStack[$XSS_work_idx]{type} ne 'if');
865 # Keep all new defined functions
866 push(@fns, keys %{$tmp->{other_functions}});
867 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
868 }
869 }
870 }
e50aee73
AD
871
872 next PARAGRAPH unless @line;
873
4230ab3f
PP
874 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
875 # We are inside an #if, but have not yet #defined its xsubpp variable.
876 print "#define $cpp_next_tmp 1\n\n";
877 push(@InitFileCode, "#if $cpp_next_tmp\n");
878 push(@BootCode, "#if $cpp_next_tmp");
879 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
880 }
881
55497cff
PP
882 death ("Code is not inside a function"
883 ." (maybe last function was ended by a blank line "
884 ." followed by a a statement on column one?)")
e50aee73
AD
885 if $line[0] =~ /^\s/;
886
2304df62
AD
887 # initialize info arrays
888 undef(%args_match);
889 undef(%var_types);
890 undef(%var_addr);
891 undef(%defaults);
892 undef($class);
893 undef($static);
894 undef($elipsis);
f06db76b
AD
895 undef($wantRETVAL) ;
896 undef(%arg_list) ;
382b8d97 897 undef(@proto_arg) ;
c07a80fd 898 undef($proto_in_this_xsub) ;
db3b9414 899 undef($scope_in_this_xsub) ;
cfc02341
IZ
900 undef($interface);
901 $interface_macro = 'XSINTERFACE_FUNC' ;
902 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
382b8d97 903 $ProtoThisXSUB = $WantPrototypes ;
db3b9414 904 $ScopeThisXSUB = 0;
2304df62 905
8e07c86e 906 $_ = shift(@line);
8fc38fda
PP
907 while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
908 &{"${kwd}_handler"}() ;
8e07c86e
AD
909 next PARAGRAPH unless @line ;
910 $_ = shift(@line);
911 }
c2960299 912
8e07c86e
AD
913 if (check_keyword("BOOT")) {
914 &check_cpp;
6f1abe2b
JT
915 push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
916 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
917 push (@BootCode, @line, "") ;
c2960299 918 next PARAGRAPH ;
a0d0e21e 919 }
c2960299 920
8e07c86e
AD
921
922 # extract return type, function name and arguments
cfc02341 923 ($ret_type) = TidyType($_);
8e07c86e 924
c2960299
AD
925 # a function definition needs at least 2 lines
926 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
927 unless @line ;
928
8e07c86e
AD
929 $static = 1 if $ret_type =~ s/^static\s+//;
930
2304df62 931 $func_header = shift(@line);
c2960299 932 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
f480b56a 933 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*$/s;
c2960299 934
8e07c86e 935 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
f480b56a 936 $class = "$4 $class" if $4;
2304df62 937 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
ff68c719
PP
938 ($clean_func_name = $func_name) =~ s/^$Prefix//;
939 $Full_func_name = "${Packid}_$clean_func_name";
ff0cee69 940 if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }
c2960299
AD
941
942 # Check for duplicate function definition
4230ab3f
PP
943 for $tmp (@XSStack) {
944 next unless defined $tmp->{functions}{$Full_func_name};
ff68c719 945 Warn("Warning: duplicate function definition '$clean_func_name' detected");
4230ab3f 946 last;
8e07c86e 947 }
4230ab3f 948 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
cfc02341 949 %XsubAliases = %XsubAliasValues = %Interfaces = ();
ef50df4b 950 $DoSetMagic = 1;
c2960299 951
2304df62 952 @args = split(/\s*,\s*/, $orig_args);
a0d0e21e 953 if (defined($class)) {
683d4eee
JL
954 my $arg0 = ((defined($static) or $func_name eq 'new')
955 ? "CLASS" : "THIS");
8e07c86e
AD
956 unshift(@args, $arg0);
957 ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
2304df62
AD
958 }
959 $orig_args =~ s/"/\\"/g;
960 $min_args = $num_args = @args;
961 foreach $i (0..$num_args-1) {
962 if ($args[$i] =~ s/\.\.\.//) {
963 $elipsis = 1;
964 $min_args--;
c2960299 965 if ($args[$i] eq '' && $i == $num_args - 1) {
2304df62
AD
966 pop(@args);
967 last;
968 }
969 }
8e07c86e 970 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
2304df62
AD
971 $min_args--;
972 $args[$i] = $1;
973 $defaults{$args[$i]} = $2;
974 $defaults{$args[$i]} =~ s/"/\\"/g;
975 }
93d3b392 976 $proto_arg[$i+1] = "\$" ;
2304df62 977 }
a0d0e21e 978 if (defined($class)) {
2304df62
AD
979 $func_args = join(", ", @args[1..$#args]);
980 } else {
981 $func_args = join(", ", @args);
982 }
983 @args_match{@args} = 1..@args;
984
8e07c86e 985 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
93d3b392 986 $CODE = grep(/^\s*CODE\s*:/, @line);
6c5fb52b
TB
987 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
988 # to set explicit return values.
989 $EXPLICIT_RETURN = ($CODE &&
990 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
8e07c86e 991 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
cfc02341 992 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
8e07c86e 993
2304df62 994 # print function header
a0d0e21e 995 print Q<<"EOF";
ff68c719 996#XS(XS_${Full_func_name})
2304df62 997#[[
a0d0e21e 998# dXSARGS;
93a17b20 999EOF
8e07c86e
AD
1000 print Q<<"EOF" if $ALIAS ;
1001# dXSI32;
1002EOF
cfc02341
IZ
1003 print Q<<"EOF" if $INTERFACE ;
1004# dXSFUNCTION($ret_type);
1005EOF
2304df62 1006 if ($elipsis) {
8e07c86e 1007 $cond = ($min_args ? qq(items < $min_args) : 0);
2304df62
AD
1008 }
1009 elsif ($min_args == $num_args) {
1010 $cond = qq(items != $min_args);
1011 }
1012 else {
1013 $cond = qq(items < $min_args || items > $num_args);
1014 }
8990e307 1015
2304df62
AD
1016 print Q<<"EOF" if $except;
1017# char errbuf[1024];
1018# *errbuf = '\0';
1019EOF
1020
8e07c86e
AD
1021 if ($ALIAS)
1022 { print Q<<"EOF" if $cond }
1023# if ($cond)
cea2e8a9 1024# Perl_croak(aTHX_ "Usage: %s($orig_args)", GvNAME(CvGV(cv)));
8e07c86e
AD
1025EOF
1026 else
1027 { print Q<<"EOF" if $cond }
1028# if ($cond)
cea2e8a9 1029# Perl_croak(aTHX_ "Usage: $pname($orig_args)");
93a17b20
LW
1030EOF
1031
a0d0e21e
LW
1032 print Q<<"EOF" if $PPCODE;
1033# SP -= items;
1034EOF
1035
2304df62 1036 # Now do a block of some sort.
93a17b20 1037
2304df62 1038 $condnum = 0;
8e07c86e
AD
1039 $cond = ''; # last CASE: condidional
1040 push(@line, "$END:");
1041 push(@line_no, $line_no[-1]);
1042 $_ = '';
1043 &check_cpp;
2304df62 1044 while (@line) {
8e07c86e
AD
1045 &CASE_handler if check_keyword("CASE");
1046 print Q<<"EOF";
1047# $except [[
93a17b20
LW
1048EOF
1049
1050 # do initialization of input variables
1051 $thisdone = 0;
1052 $retvaldone = 0;
463ee0b2 1053 $deferred = "";
c2960299
AD
1054 %arg_list = () ;
1055 $gotRETVAL = 0;
f06db76b 1056
8fc38fda 1057 INPUT_handler() ;
cfc02341 1058 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ;
8fc38fda 1059
db3b9414
PP
1060 print Q<<"EOF" if $ScopeThisXSUB;
1061# ENTER;
1062# [[
1063EOF
1064
a0d0e21e 1065 if (!$thisdone && defined($class)) {
683d4eee 1066 if (defined($static) or $func_name eq 'new') {
a0d0e21e
LW
1067 print "\tchar *";
1068 $var_types{"CLASS"} = "char *";
1069 &generate_init("char *", 1, "CLASS");
1070 }
1071 else {
93a17b20
LW
1072 print "\t$class *";
1073 $var_types{"THIS"} = "$class *";
1074 &generate_init("$class *", 1, "THIS");
a0d0e21e 1075 }
93a17b20
LW
1076 }
1077
1078 # do code
1079 if (/^\s*NOT_IMPLEMENTED_YET/) {
cea2e8a9 1080 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
4633a7c4 1081 $_ = '' ;
93a17b20
LW
1082 } else {
1083 if ($ret_type ne "void") {
1084 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
1085 if !$retvaldone;
1086 $args_match{"RETVAL"} = 0;
1087 $var_types{"RETVAL"} = $ret_type;
1088 }
db3b9414 1089
8e07c86e 1090 print $deferred;
db3b9414 1091
cfc02341 1092 process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
8e07c86e
AD
1093
1094 if (check_keyword("PPCODE")) {
8fc38fda 1095 print_section();
8e07c86e 1096 death ("PPCODE must be last thing") if @line;
db3b9414 1097 print "\tLEAVE;\n" if $ScopeThisXSUB;
a0d0e21e 1098 print "\tPUTBACK;\n\treturn;\n";
8e07c86e 1099 } elsif (check_keyword("CODE")) {
8fc38fda
PP
1100 print_section() ;
1101 } elsif (defined($class) and $func_name eq "DESTROY") {
a0d0e21e 1102 print "\n\t";
8e07c86e 1103 print "delete THIS;\n";
93a17b20
LW
1104 } else {
1105 print "\n\t";
1106 if ($ret_type ne "void") {
463ee0b2 1107 print "RETVAL = ";
e50aee73 1108 $wantRETVAL = 1;
93a17b20
LW
1109 }
1110 if (defined($static)) {
683d4eee 1111 if ($func_name eq 'new') {
8fc38fda 1112 $func_name = "$class";
8e07c86e
AD
1113 } else {
1114 print "${class}::";
a0d0e21e 1115 }
93a17b20 1116 } elsif (defined($class)) {
683d4eee 1117 if ($func_name eq 'new') {
8fc38fda
PP
1118 $func_name .= " $class";
1119 } else {
93a17b20 1120 print "THIS->";
8fc38fda 1121 }
93a17b20 1122 }
e50aee73
AD
1123 $func_name =~ s/^($spat)//
1124 if defined($spat);
cfc02341 1125 $func_name = 'XSFUNCTION' if $interface;
93a17b20 1126 print "$func_name($func_args);\n";
93a17b20
LW
1127 }
1128 }
1129
1130 # do output variables
8e07c86e
AD
1131 $gotRETVAL = 0;
1132 undef $RETVAL_code ;
1133 undef %outargs ;
8fc38fda 1134 process_keyword("OUTPUT|ALIAS|PROTOTYPE");
f06db76b
AD
1135
1136 # all OUTPUT done, so now push the return value on the stack
8e07c86e
AD
1137 if ($gotRETVAL && $RETVAL_code) {
1138 print "\t$RETVAL_code\n";
1139 } elsif ($gotRETVAL || $wantRETVAL) {
ef50df4b
GS
1140 # RETVAL almost never needs SvSETMAGIC()
1141 &generate_output($ret_type, 0, 'RETVAL', 0);
8e07c86e 1142 }
f06db76b 1143
93a17b20 1144 # do cleanup
8fc38fda 1145 process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
8e07c86e 1146
db3b9414
PP
1147 print Q<<"EOF" if $ScopeThisXSUB;
1148# ]]
1149EOF
1150 print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE;
1151# LEAVE;
1152EOF
1153
93a17b20 1154 # print function trailer
8e07c86e 1155 print Q<<EOF;
2304df62 1156# ]]
8e07c86e
AD
1157EOF
1158 print Q<<EOF if $except;
8990e307
LW
1159# BEGHANDLERS
1160# CATCHALL
1161# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
1162# ENDHANDLERS
93a17b20 1163EOF
8e07c86e
AD
1164 if (check_keyword("CASE")) {
1165 blurt ("Error: No `CASE:' at top of function")
1166 unless $condnum;
1167 $_ = "CASE: $_"; # Restore CASE: label
1168 next;
8990e307 1169 }
8e07c86e
AD
1170 last if $_ eq "$END:";
1171 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
2304df62 1172 }
a0d0e21e 1173
2304df62
AD
1174 print Q<<EOF if $except;
1175# if (errbuf[0])
cea2e8a9 1176# Perl_croak(aTHX_ errbuf);
2304df62 1177EOF
a0d0e21e 1178
7c5b83de 1179 if ($ret_type ne "void" or $EXPLICIT_RETURN) {
93d3b392 1180 print Q<<EOF unless $PPCODE;
a0d0e21e
LW
1181# XSRETURN(1);
1182EOF
93d3b392
PP
1183 } else {
1184 print Q<<EOF unless $PPCODE;
1185# XSRETURN_EMPTY;
1186EOF
1187 }
a0d0e21e 1188
2304df62 1189 print Q<<EOF;
2304df62 1190#]]
8990e307 1191#
93a17b20 1192EOF
382b8d97 1193
4230ab3f
PP
1194 my $newXS = "newXS" ;
1195 my $proto = "" ;
1196
382b8d97
PM
1197 # Build the prototype string for the xsub
1198 if ($ProtoThisXSUB) {
4230ab3f
PP
1199 $newXS = "newXSproto";
1200
6f1abe2b 1201 if ($ProtoThisXSUB eq 2) {
4230ab3f
PP
1202 # User has specified empty prototype
1203 $proto = ', ""' ;
1204 }
6f1abe2b 1205 elsif ($ProtoThisXSUB ne 1) {
7d41bd0a 1206 # User has specified a prototype
4230ab3f 1207 $proto = ', "' . $ProtoThisXSUB . '"';
382b8d97
PM
1208 }
1209 else {
1210 my $s = ';';
1211 if ($min_args < $num_args) {
1212 $s = '';
1213 $proto_arg[$min_args] .= ";" ;
1214 }
4230ab3f 1215 push @proto_arg, "$s\@"
382b8d97
PM
1216 if $elipsis ;
1217
4230ab3f 1218 $proto = ', "' . join ("", @proto_arg) . '"';
382b8d97
PM
1219 }
1220 }
1221
4230ab3f
PP
1222 if (%XsubAliases) {
1223 $XsubAliases{$pname} = 0
1224 unless defined $XsubAliases{$pname} ;
1225 while ( ($name, $value) = each %XsubAliases) {
1226 push(@InitFileCode, Q<<"EOF");
1227# cv = newXS(\"$name\", XS_$Full_func_name, file);
1228# XSANY.any_i32 = $value ;
1229EOF
1230 push(@InitFileCode, Q<<"EOF") if $proto;
1231# sv_setpv((SV*)cv$proto) ;
1232EOF
1233 }
cfc02341
IZ
1234 }
1235 elsif ($interface) {
1236 while ( ($name, $value) = each %Interfaces) {
1237 $name = "$Package\::$name" unless $name =~ /::/;
1238 push(@InitFileCode, Q<<"EOF");
1239# cv = newXS(\"$name\", XS_$Full_func_name, file);
1240# $interface_macro_set(cv,$value) ;
1241EOF
1242 push(@InitFileCode, Q<<"EOF") if $proto;
1243# sv_setpv((SV*)cv$proto) ;
1244EOF
1245 }
4230ab3f
PP
1246 }
1247 else {
1248 push(@InitFileCode,
1249 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
1250 }
93a17b20
LW
1251}
1252
1253# print initialization routine
7ee8c957 1254
e3b8966e 1255print Q<<"EOF";
e3b8966e
GS
1256##ifdef __cplusplus
1257#extern "C"
1258##endif
7ee8c957
GS
1259EOF
1260
8990e307 1261print Q<<"EOF";
a0d0e21e 1262#XS(boot_$Module_cname)
7ee8c957
GS
1263EOF
1264
7ee8c957 1265print Q<<"EOF";
2304df62 1266#[[
a0d0e21e 1267# dXSARGS;
8990e307
LW
1268# char* file = __FILE__;
1269#
93a17b20
LW
1270EOF
1271
8fc38fda
PP
1272print Q<<"EOF" if $WantVersionChk ;
1273# XS_VERSION_BOOTCHECK ;
1274#
1275EOF
1276
cfc02341 1277print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
8e07c86e
AD
1278# {
1279# CV * cv ;
1280#
1281EOF
1282
4230ab3f 1283print @InitFileCode;
a0d0e21e 1284
cfc02341 1285print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
8e07c86e
AD
1286# }
1287EOF
1288
a0d0e21e
LW
1289if (@BootCode)
1290{
6f1abe2b
JT
1291 print "\n /* Initialisation Section */\n\n" ;
1292 @line = @BootCode;
1293 print_section();
8e07c86e 1294 print "\n /* End of Initialisation Section */\n\n" ;
93a17b20 1295}
a0d0e21e 1296
e50aee73 1297print Q<<"EOF";;
3280af22 1298# XSRETURN_YES;
e50aee73 1299#]]
e3b8966e
GS
1300#
1301EOF
1302
8fc38fda
PP
1303warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1304 unless $ProtoUsed ;
e50aee73
AD
1305&Exit;
1306
93a17b20 1307sub output_init {
7ad6fb0b 1308 local($type, $num, $var, $init) = @_;
a0d0e21e 1309 local($arg) = "ST(" . ($num - 1) . ")";
93a17b20 1310
7ad6fb0b
TM
1311 if( $init =~ /^=/ ) {
1312 eval qq/print "\\t$var $init\\n"/;
1313 warn $@ if $@;
1314 } else {
1315 if( $init =~ s/^\+// && $num ) {
1316 &generate_init($type, $num, $var);
1317 } else {
1318 eval qq/print "\\t$var;\\n"/;
1319 warn $@ if $@;
1320 $init =~ s/^;//;
1321 }
1322 $deferred .= eval qq/"\\n\\t$init\\n"/;
1323 warn $@ if $@;
1324 }
93a17b20
LW
1325}
1326
c2960299
AD
1327sub Warn
1328{
1329 # work out the line number
1330 my $line_no = $line_no[@line_no - @line -1] ;
1331
1332 print STDERR "@_ in $filename, line $line_no\n" ;
1333}
1334
1335sub blurt
1336{
1337 Warn @_ ;
1338 $errors ++
1339}
1340
1341sub death
1342{
1343 Warn @_ ;
1344 exit 1 ;
1345}
8990e307 1346
93a17b20 1347sub generate_init {
2304df62 1348 local($type, $num, $var) = @_;
a0d0e21e 1349 local($arg) = "ST(" . ($num - 1) . ")";
2304df62
AD
1350 local($argoff) = $num - 1;
1351 local($ntype);
1352 local($tk);
93a17b20 1353
f06db76b 1354 $type = TidyType($type) ;
c2960299
AD
1355 blurt("Error: '$type' not in typemap"), return
1356 unless defined($type_kind{$type});
1357
2304df62 1358 ($ntype = $type) =~ s/\s*\*/Ptr/g;
8e07c86e 1359 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
2304df62
AD
1360 $tk = $type_kind{$type};
1361 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
8e07c86e 1362 $type =~ tr/:/_/;
c2960299
AD
1363 blurt("Error: No INPUT definition for type '$type' found"), return
1364 unless defined $input_expr{$tk} ;
2304df62
AD
1365 $expr = $input_expr{$tk};
1366 if ($expr =~ /DO_ARRAY_ELEM/) {
c2960299
AD
1367 blurt("Error: '$subtype' not in typemap"), return
1368 unless defined($type_kind{$subtype});
1369 blurt("Error: No INPUT definition for type '$subtype' found"), return
1370 unless defined $input_expr{$type_kind{$subtype}} ;
2304df62
AD
1371 $subexpr = $input_expr{$type_kind{$subtype}};
1372 $subexpr =~ s/ntype/subtype/g;
1373 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1374 $subexpr =~ s/\n\t/\n\t\t/g;
93d3b392 1375 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
a0d0e21e 1376 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
2304df62
AD
1377 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1378 }
db3b9414
PP
1379 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1380 $ScopeThisXSUB = 1;
1381 }
2304df62
AD
1382 if (defined($defaults{$var})) {
1383 $expr =~ s/(\t+)/$1 /g;
1384 $expr =~ s/ /\t/g;
1385 eval qq/print "\\t$var;\\n"/;
7ad6fb0b 1386 warn $@ if $@;
2304df62 1387 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
7ad6fb0b 1388 warn $@ if $@;
db3b9414 1389 } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
2304df62 1390 eval qq/print "\\t$var;\\n"/;
7ad6fb0b 1391 warn $@ if $@;
2304df62 1392 $deferred .= eval qq/"\\n$expr;\\n"/;
7ad6fb0b 1393 warn $@ if $@;
2304df62
AD
1394 } else {
1395 eval qq/print "$expr;\\n"/;
7ad6fb0b 1396 warn $@ if $@;
2304df62 1397 }
93a17b20
LW
1398}
1399
1400sub generate_output {
ef50df4b 1401 local($type, $num, $var, $do_setmagic) = @_;
a0d0e21e 1402 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
2304df62
AD
1403 local($argoff) = $num - 1;
1404 local($ntype);
93a17b20 1405
f06db76b 1406 $type = TidyType($type) ;
2304df62 1407 if ($type =~ /^array\(([^,]*),(.*)\)/) {
4bd3d083 1408 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
ef50df4b 1409 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
2304df62 1410 } else {
f06db76b 1411 blurt("Error: '$type' not in typemap"), return
2304df62 1412 unless defined($type_kind{$type});
c2960299
AD
1413 blurt("Error: No OUTPUT definition for type '$type' found"), return
1414 unless defined $output_expr{$type_kind{$type}} ;
2304df62
AD
1415 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1416 $ntype =~ s/\(\)//g;
8e07c86e 1417 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
2304df62
AD
1418 $expr = $output_expr{$type_kind{$type}};
1419 if ($expr =~ /DO_ARRAY_ELEM/) {
c2960299
AD
1420 blurt("Error: '$subtype' not in typemap"), return
1421 unless defined($type_kind{$subtype});
1422 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
1423 unless defined $output_expr{$type_kind{$subtype}} ;
2304df62
AD
1424 $subexpr = $output_expr{$type_kind{$subtype}};
1425 $subexpr =~ s/ntype/subtype/g;
1426 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1427 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1428 $subexpr =~ s/\n\t/\n\t\t/g;
1429 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
a0d0e21e 1430 eval "print qq\a$expr\a";
7ad6fb0b 1431 warn $@ if $@;
ef50df4b 1432 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
2304df62 1433 }
a0d0e21e 1434 elsif ($var eq 'RETVAL') {
a2baab1c
IZ
1435 if ($expr =~ /^\t\$arg = new/) {
1436 # We expect that $arg has refcnt 1, so we need to
1437 # mortalize it.
a0d0e21e 1438 eval "print qq\a$expr\a";
7ad6fb0b 1439 warn $@ if $@;
2304df62 1440 print "\tsv_2mortal(ST(0));\n";
ef50df4b 1441 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
93a17b20 1442 }
a2baab1c
IZ
1443 elsif ($expr =~ /^\s*\$arg\s*=/) {
1444 # We expect that $arg has refcnt >=1, so we need
d689ffdd 1445 # to mortalize it!
a2baab1c 1446 eval "print qq\a$expr\a";
7ad6fb0b 1447 warn $@ if $@;
d689ffdd 1448 print "\tsv_2mortal(ST(0));\n";
ef50df4b 1449 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
a2baab1c 1450 }
2304df62 1451 else {
a2baab1c
IZ
1452 # Just hope that the entry would safely write it
1453 # over an already mortalized value. By
1454 # coincidence, something like $arg = &sv_undef
1455 # works too.
8990e307 1456 print "\tST(0) = sv_newmortal();\n";
a0d0e21e 1457 eval "print qq\a$expr\a";
7ad6fb0b 1458 warn $@ if $@;
ef50df4b 1459 # new mortals don't have set magic
463ee0b2 1460 }
2304df62 1461 }
a0d0e21e
LW
1462 elsif ($arg =~ /^ST\(\d+\)$/) {
1463 eval "print qq\a$expr\a";
7ad6fb0b 1464 warn $@ if $@;
ef50df4b 1465 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
a0d0e21e 1466 }
2304df62 1467 }
93a17b20
LW
1468}
1469
1470sub map_type {
e50aee73 1471 my($type) = @_;
93a17b20 1472
8e07c86e
AD
1473 $type =~ tr/:/_/;
1474 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1475 $type;
93a17b20 1476}
8990e307 1477
e50aee73
AD
1478
1479sub Exit {
ff0cee69
PP
1480# If this is VMS, the exit status has meaning to the shell, so we
1481# use a predictable value (SS$_Normal or SS$_Abort) rather than an
1482# arbitrary number.
1483# exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
1484 exit ($errors ? 1 : 0);
e50aee73 1485}