This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove the wistful comment about "use strict -- one of these days ..."
[perl5.git] / dist / ExtUtils-ParseXS / lib / ExtUtils / ParseXS.pm
CommitLineData
6b09c160 1package ExtUtils::ParseXS;
f0744969 2use strict;
6b09c160
YST
3
4use 5.006; # We use /??{}/ in regexes
5use Cwd;
6use Config;
505ef4a5 7use Exporter;
6b09c160
YST
8use File::Basename;
9use File::Spec;
907ce46c 10use Symbol;
547742ac 11use ExtUtils::ParseXS::Constants ();
9e831c8e 12use ExtUtils::ParseXS::CountLines;
a65c06db
S
13use ExtUtils::ParseXS::Utilities qw(
14 standard_typemap_locations
1d40e528 15 trim_whitespace
73e91d5a 16 tidy_type
c1e43162 17 C_string
547742ac 18 valid_proto_string
50b96cc2 19 process_typemaps
af4112ab 20 make_targetable
0ec7450c 21 map_type
a65c06db 22);
6b09c160 23
c74be726
JK
24our @ISA = qw(Exporter);
25our @EXPORT_OK = qw(
26 process_file
27 report_error_count
28);
29our $VERSION = '3';
a1c5c71f 30$VERSION = eval $VERSION if $VERSION =~ /_/;
6b09c160 31
37ddf986
JK
32our (
33 $ProtoUsed, @InitFileCode, $FH, $proto_re, $Overload, $errors, $Fallback,
34 $hiertype, $WantPrototypes, $WantVersionChk, $WantLineNumbers, $filepathname,
eb26ba82
JK
35 $dir, $filename, %IncludedFiles, %input_expr, %output_expr,
36 %type_kind, %proto_letter, $BLOCK_re, $lastline, $lastline_no, $Package,
cb069f63
JK
37 $Prefix, @line, %args_match, %defaults, %var_types, %arg_list, @proto_arg,
38 $processing_arg_with_types, %argtype_seen, %in_out, %lengthof,
39 $proto_in_this_xsub, $scope_in_this_xsub, $interface,
40 $interface_macro, $interface_macro_set, $ProtoThisXSUB, $ScopeThisXSUB,
91817d4e 41 @line_no, $ret_type, $func_name, $Full_func_name, $Packprefix, $Packid,
e8cc43a7 42 %XsubAliases, %XsubAliasValues, %Interfaces, @Attributes, %outargs, $pname,
9e831c8e 43 $thisdone, $retvaldone, $deferred, $gotRETVAL, $condnum, $cond,
68f166a7 44 $RETVAL_code, $printed_name, $func_args, @XSStack, $ALIAS,
a1c5c71f 45);
be5bcef7 46our ($DoSetMagic, $newXS, $proto, $Module_cname, $XsubAliases, $Interfaces, $var_num, );
6b09c160
YST
47
48sub process_file {
1efd22b7 49
6b09c160 50 # Allow for $package->process_file(%hash) in the future
c1e43162 51 my ($pkg, %options) = @_ % 2 ? @_ : (__PACKAGE__, @_);
1efd22b7 52
c1e43162 53 $ProtoUsed = exists $options{prototypes};
1efd22b7 54
6b09c160 55 # Set defaults.
c1e43162 56 my %args = (
37ddf986
JK
57 argtypes => 1,
58 csuffix => '.c',
59 except => 0,
60 hiertype => 0,
61 inout => 1,
62 linenumbers => 1,
63 optimize => 1,
64 output => \*STDOUT,
65 prototypes => 0,
66 typemap => [],
67 versioncheck => 1,
c1e43162 68 %options,
34fa6cb6 69 );
c1e43162 70 $args{except} = $args{except} ? ' TRY' : '';
6b09c160
YST
71
72 # Global Constants
1efd22b7 73
6b09c160
YST
74 my ($Is_VMS, $SymSet);
75 if ($^O eq 'VMS') {
76 $Is_VMS = 1;
77 # Establish set of global symbols with max length 28, since xsubpp
78 # will later add the 'XS_' prefix.
79 require ExtUtils::XSSymSet;
80 $SymSet = new ExtUtils::XSSymSet 28;
81 }
82 @XSStack = ({type => 'none'});
547742ac
JK
83 my $XSS_work_idx = 0;
84 my $cpp_next_tmp = 'XSubPPtmpAAAA';
85 @InitFileCode = @ExtUtils::ParseXS::Constants::InitFileCode;
86 $FH = $ExtUtils::ParseXS::Constants::FH;
87 $proto_re = $ExtUtils::ParseXS::Constants::proto_re;
88 $Overload = $ExtUtils::ParseXS::Constants::Overload;
89 $errors = $ExtUtils::ParseXS::Constants::errors;
90 $Fallback = $ExtUtils::ParseXS::Constants::Fallback;
6b09c160
YST
91
92 # Most of the 1500 lines below uses these globals. We'll have to
93 # clean this up sometime, probably. For now, we just pull them out
94 # of %args. -Ken
1efd22b7 95
6b09c160
YST
96 $hiertype = $args{hiertype};
97 $WantPrototypes = $args{prototypes};
98 $WantVersionChk = $args{versioncheck};
6b09c160 99 $WantLineNumbers = $args{linenumbers};
1efd22b7 100
c1e43162
JK
101 for my $f ($args{filename}) {
102 die "Missing required parameter 'filename'" unless $f;
103 $filepathname = $f;
104 ($dir, $filename) = (dirname($f), basename($f));
6b09c160 105 $filepathname =~ s/\\/\\\\/g;
c1e43162 106 $IncludedFiles{$f}++;
6b09c160 107 }
1efd22b7 108
6b09c160
YST
109 # Open the output file if given as a string. If they provide some
110 # other kind of reference, trust them that we can print to it.
111 if (not ref $args{output}) {
112 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
113 $args{outfile} = $args{output};
114 $args{output} = $fh;
115 }
116
117 # Really, we shouldn't have to chdir() or select() in the first
118 # place. For now, just save & restore.
119 my $orig_cwd = cwd();
120 my $orig_fh = select();
1efd22b7 121
6b09c160
YST
122 chdir($dir);
123 my $pwd = cwd();
008fb49c 124 my $csuffix = $args{csuffix};
1efd22b7 125
6b09c160
YST
126 if ($WantLineNumbers) {
127 my $cfile;
128 if ( $args{outfile} ) {
129 $cfile = $args{outfile};
34fa6cb6
JK
130 }
131 else {
6b09c160 132 $cfile = $args{filename};
008fb49c 133 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
6b09c160
YST
134 }
135 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
136 select PSEUDO_STDOUT;
34fa6cb6
JK
137 }
138 else {
6b09c160
YST
139 select $args{output};
140 }
141
50b96cc2
JK
142 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
143 process_typemaps( $args{typemap}, $pwd );
6b09c160 144
50b96cc2
JK
145 %type_kind = %{ $type_kind_ref };
146 %proto_letter = %{ $proto_letter_ref };
147 %input_expr = %{ $input_expr_ref };
148 %output_expr = %{ $output_expr_ref };
6b09c160 149
fa81e4d3
NC
150 foreach my $value (values %input_expr) {
151 $value =~ s/;*\s+\z//;
a396bf53
NC
152 # Move C pre-processor instructions to column 1 to be strictly ANSI
153 # conformant. Some pre-processors are fussy about this.
154 $value =~ s/^\s+#/#/mg;
155 }
156 foreach my $value (values %output_expr) {
157 # And again.
158 $value =~ s/^\s+#/#/mg;
6b09c160
YST
159 }
160
af4112ab 161 my %targetable = make_targetable(\%output_expr);
6b09c160 162
1efd22b7 163 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
6b09c160
YST
164
165 # Match an XS keyword
34fa6cb6
JK
166 $BLOCK_re = '\s*(' . join('|', qw(
167 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE
168 OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE
169 VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE
170 INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
171 )) . "|$END)\\s*:";
6b09c160 172
a8adbc99 173 our ($C_group_rex, $C_arg);
6b09c160
YST
174 # Group in C (no support for comments or literals)
175 $C_group_rex = qr/ [({\[]
1efd22b7 176 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
7c3505a2 177 [)}\]] /x;
6b09c160
YST
178 # Chunk in C without comma at toplevel (no comments):
179 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
1efd22b7
JK
180 | (??{ $C_group_rex })
181 | " (?: (?> [^\\"]+ )
182 | \\.
183 )* " # String literal
184 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
185 )* /xs;
186
6b09c160 187 # Identify the version of xsubpp used
7c3505a2 188 print <<EOM;
6b09c160 189/*
566395ef 190 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
6b09c160
YST
191 * contents of $filename. Do not edit this file, edit $filename instead.
192 *
1efd22b7 193 * ANY CHANGES MADE HERE WILL BE LOST!
6b09c160
YST
194 *
195 */
196
197EOM
198
199
200 print("#line 1 \"$filepathname\"\n")
201 if $WantLineNumbers;
202
af4112ab
JK
203 # Open the input file (using basename'd $args{filename} due to chdir above)
204 open($FH, $filename) or die "cannot open $filename: $!\n";
205
6b09c160
YST
206 firstmodule:
207 while (<$FH>) {
208 if (/^=/) {
209 my $podstartline = $.;
210 do {
34fa6cb6
JK
211 if (/^=cut\s*$/) {
212 # We can't just write out a /* */ comment, as our embedded
213 # POD might itself be in a comment. We can't put a /**/
214 # comment inside #if 0, as the C standard says that the source
215 # file is decomposed into preprocessing characters in the stage
216 # before preprocessing commands are executed.
217 # I don't want to leave the text as barewords, because the spec
218 # isn't clear whether macros are expanded before or after
219 # preprocessing commands are executed, and someone pathological
220 # may just have defined one of the 3 words as a macro that does
221 # something strange. Multiline strings are illegal in C, so
222 # the "" we write must be a string literal. And they aren't
223 # concatenated until 2 steps later, so we are safe.
224 # - Nicholas Clark
225 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
226 printf("#line %d \"$filepathname\"\n", $. + 1)
227 if $WantLineNumbers;
228 next firstmodule
229 }
1efd22b7 230
6b09c160
YST
231 } while (<$FH>);
232 # At this point $. is at end of file so die won't state the start
233 # of the problem, and as we haven't yet read any lines &death won't
234 # show the correct line in the message either.
235 die ("Error: Unterminated pod in $filename, line $podstartline\n")
34fa6cb6 236 unless $lastline;
6b09c160
YST
237 }
238 last if ($Package, $Prefix) =
239 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
1efd22b7 240
6b09c160
YST
241 print $_;
242 }
243 unless (defined $_) {
244 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
245 exit 0; # Not a fatal error for the caller process
246 }
247
708f9ca6
DG
248 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
249
250 print <<"EOF";
6b09c160
YST
251#ifndef PERL_UNUSED_VAR
252# define PERL_UNUSED_VAR(var) if (0) var = var
253#endif
254
255EOF
256
708f9ca6
DG
257 print <<"EOF";
258#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
259#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
260
261/* prototype to pass -Wmissing-prototypes */
262STATIC void
263S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
264
265STATIC void
266S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
267{
268 const GV *const gv = CvGV(cv);
269
270 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
271
272 if (gv) {
273 const char *const gvname = GvNAME(gv);
274 const HV *const stash = GvSTASH(gv);
275 const char *const hvname = stash ? HvNAME(stash) : NULL;
276
277 if (hvname)
278 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
279 else
280 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
281 } else {
282 /* Pants. I don't think that it should be possible to get here. */
283 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
284 }
285}
286#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
287
288#ifdef PERL_IMPLICIT_CONTEXT
1efd22b7 289#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
708f9ca6 290#else
1efd22b7 291#define croak_xs_usage S_croak_xs_usage
708f9ca6
DG
292#endif
293
294#endif
295
28892255
DG
296/* NOTE: the prototype of newXSproto() is different in versions of perls,
297 * so we define a portable version of newXSproto()
298 */
299#ifdef newXS_flags
300#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
301#else
302#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
303#endif /* !defined(newXS_flags) */
304
708f9ca6
DG
305EOF
306
6b09c160
YST
307 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
308
309 $lastline = $_;
310 $lastline_no = $.;
311
cb069f63 312 my (@BootCode, @outlist, $prepush_done, $xsreturn, $func_header, $orig_args, );
6b09c160
YST
313 PARAGRAPH:
314 while (fetch_para()) {
315 # Print initial preprocessor statements and blank lines
316 while (@line && $line[0] !~ /^[^\#]/) {
9e831c8e
JK
317 my $ln = shift(@line);
318 print $ln, "\n";
319 next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
6b09c160
YST
320 my $statement = $+;
321 if ($statement eq 'if') {
34fa6cb6
JK
322 $XSS_work_idx = @XSStack;
323 push(@XSStack, {type => 'if'});
324 }
325 else {
326 death ("Error: `$statement' with no matching `if'")
327 if $XSStack[-1]{type} ne 'if';
328 if ($XSStack[-1]{varname}) {
329 push(@InitFileCode, "#endif\n");
330 push(@BootCode, "#endif");
331 }
1efd22b7 332
34fa6cb6
JK
333 my(@fns) = keys %{$XSStack[-1]{functions}};
334 if ($statement ne 'endif') {
335 # Hide the functions defined in other #if branches, and reset.
336 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
337 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
338 }
339 else {
340 my($tmp) = pop(@XSStack);
341 0 while (--$XSS_work_idx
342 && $XSStack[$XSS_work_idx]{type} ne 'if');
343 # Keep all new defined functions
344 push(@fns, keys %{$tmp->{other_functions}});
345 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
346 }
6b09c160
YST
347 }
348 }
1efd22b7 349
6b09c160 350 next PARAGRAPH unless @line;
1efd22b7 351
6b09c160
YST
352 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
353 # We are inside an #if, but have not yet #defined its xsubpp variable.
354 print "#define $cpp_next_tmp 1\n\n";
355 push(@InitFileCode, "#if $cpp_next_tmp\n");
356 push(@BootCode, "#if $cpp_next_tmp");
357 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
358 }
359
360 death ("Code is not inside a function"
1efd22b7
JK
361 ." (maybe last function was ended by a blank line "
362 ." followed by a statement on column one?)")
6b09c160 363 if $line[0] =~ /^\s/;
1efd22b7 364
95b611b0 365 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
1efd22b7 366 my (@fake_INPUT_pre); # For length(s) generated variables
6b09c160 367 my (@fake_INPUT);
1efd22b7 368
6b09c160
YST
369 # initialize info arrays
370 undef(%args_match);
371 undef(%var_types);
372 undef(%defaults);
7c3505a2
JK
373 undef(%arg_list);
374 undef(@proto_arg);
375 undef($processing_arg_with_types);
376 undef(%argtype_seen);
377 undef(@outlist);
378 undef(%in_out);
379 undef(%lengthof);
380 undef($proto_in_this_xsub);
381 undef($scope_in_this_xsub);
6b09c160
YST
382 undef($interface);
383 undef($prepush_done);
7c3505a2
JK
384 $interface_macro = 'XSINTERFACE_FUNC';
385 $interface_macro_set = 'XSINTERFACE_FUNC_SET';
386 $ProtoThisXSUB = $WantPrototypes;
6b09c160
YST
387 $ScopeThisXSUB = 0;
388 $xsreturn = 0;
389
390 $_ = shift(@line);
387b6f8d 391 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
d710f389 392 no strict 'refs';
7c3505a2 393 &{"${kwd}_handler"}();
d710f389 394 use strict 'refs';
7c3505a2 395 next PARAGRAPH unless @line;
6b09c160
YST
396 $_ = shift(@line);
397 }
398
399 if (check_keyword("BOOT")) {
400 &check_cpp;
401 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
34fa6cb6 402 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
7c3505a2
JK
403 push (@BootCode, @line, "");
404 next PARAGRAPH;
6b09c160
YST
405 }
406
6b09c160 407 # extract return type, function name and arguments
73e91d5a 408 ($ret_type) = tidy_type($_);
6b09c160
YST
409 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
410
411 # Allow one-line ANSI-like declaration
412 unshift @line, $2
c1e43162 413 if $args{argtypes}
34fa6cb6 414 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
6b09c160
YST
415
416 # a function definition needs at least 2 lines
417 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
7c3505a2 418 unless @line;
6b09c160 419
008fb49c
JH
420 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
421 $static = 1 if $ret_type =~ s/^static\s+//;
6b09c160
YST
422
423 $func_header = shift(@line);
424 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
425 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
426
7c3505a2 427 ($class, $func_name, $orig_args) = ($1, $2, $3);
6b09c160
YST
428 $class = "$4 $class" if $4;
429 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
081eda6f 430 my $clean_func_name;
6b09c160
YST
431 ($clean_func_name = $func_name) =~ s/^$Prefix//;
432 $Full_func_name = "${Packid}_$clean_func_name";
433 if ($Is_VMS) {
434 $Full_func_name = $SymSet->addsym($Full_func_name);
435 }
436
437 # Check for duplicate function definition
438 for my $tmp (@XSStack) {
439 next unless defined $tmp->{functions}{$Full_func_name};
440 Warn("Warning: duplicate function definition '$clean_func_name' detected");
441 last;
442 }
9e831c8e 443 $XSStack[$XSS_work_idx]{functions}{$Full_func_name}++;
6b09c160
YST
444 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
445 $DoSetMagic = 1;
446
1efd22b7 447 $orig_args =~ s/\\\s*/ /g; # process line continuations
6b09c160
YST
448 my @args;
449
1efd22b7 450 my %only_C_inlist; # Not in the signature of Perl function
c1e43162 451 if ($args{argtypes} and $orig_args =~ /\S/) {
6b09c160
YST
452 my $args = "$orig_args ,";
453 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
34fa6cb6
JK
454 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
455 for ( @args ) {
456 s/^\s+//;
457 s/\s+$//;
e8cc43a7 458 my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x);
af4112ab 459 my ($pre, $len_name) = ($arg =~ /(.*?) \s*
34fa6cb6
JK
460 \b ( \w+ | length\( \s*\w+\s* \) )
461 \s* $ /x);
462 next unless defined($pre) && length($pre);
463 my $out_type = '';
464 my $inout_var;
c1e43162 465 if ($args{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
34fa6cb6
JK
466 my $type = $1;
467 $out_type = $type if $type ne 'IN';
468 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
469 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
470 }
471 my $islength;
af4112ab
JK
472 if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) {
473 $len_name = "XSauto_length_of_$1";
34fa6cb6
JK
474 $islength = 1;
475 die "Default value on length() argument: `$_'"
476 if length $default;
477 }
478 if (length $pre or $islength) { # Has a type
479 if ($islength) {
480 push @fake_INPUT_pre, $arg;
505ef4a5
JK
481 }
482 else {
34fa6cb6
JK
483 push @fake_INPUT, $arg;
484 }
485 # warn "pushing '$arg'\n";
af4112ab
JK
486 $argtype_seen{$len_name}++;
487 $_ = "$len_name$default"; # Assigns to @args
34fa6cb6
JK
488 }
489 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
af4112ab
JK
490 push @outlist, $len_name if $out_type =~ /OUTLIST$/;
491 $in_out{$len_name} = $out_type if $out_type;
1efd22b7 492 }
1efd22b7 493 }
34fa6cb6
JK
494 else {
495 @args = split(/\s*,\s*/, $orig_args);
496 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
6b09c160 497 }
34fa6cb6
JK
498 }
499 else {
6b09c160
YST
500 @args = split(/\s*,\s*/, $orig_args);
501 for (@args) {
c1e43162 502 if ($args{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
34fa6cb6
JK
503 my $out_type = $1;
504 next if $out_type eq 'IN';
505 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
e9bd0a47 506 if ($out_type =~ /OUTLIST$/) {
be5bcef7 507 push @outlist, undef;
e9bd0a47 508 }
34fa6cb6
JK
509 $in_out{$_} = $out_type;
510 }
6b09c160
YST
511 }
512 }
513 if (defined($class)) {
514 my $arg0 = ((defined($static) or $func_name eq 'new')
1efd22b7 515 ? "CLASS" : "THIS");
6b09c160 516 unshift(@args, $arg0);
6b09c160
YST
517 }
518 my $extra_args = 0;
a40ca62b
JK
519 my @args_num = ();
520 my $num_args = 0;
6b09c160
YST
521 my $report_args = '';
522 foreach my $i (0 .. $#args) {
523 if ($args[$i] =~ s/\.\.\.//) {
34fa6cb6
JK
524 $ellipsis = 1;
525 if ($args[$i] eq '' && $i == $#args) {
526 $report_args .= ", ...";
527 pop(@args);
528 last;
529 }
6b09c160
YST
530 }
531 if ($only_C_inlist{$args[$i]}) {
34fa6cb6
JK
532 push @args_num, undef;
533 }
534 else {
535 push @args_num, ++$num_args;
536 $report_args .= ", $args[$i]";
6b09c160
YST
537 }
538 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
34fa6cb6
JK
539 $extra_args++;
540 $args[$i] = $1;
541 $defaults{$args[$i]} = $2;
542 $defaults{$args[$i]} =~ s/"/\\"/g;
6b09c160 543 }
7c3505a2 544 $proto_arg[$i+1] = '$';
6b09c160 545 }
a40ca62b 546 my $min_args = $num_args - $extra_args;
6b09c160
YST
547 $report_args =~ s/"/\\"/g;
548 $report_args =~ s/^,\s+//;
549 my @func_args = @args;
550 shift @func_args if defined($class);
551
552 for (@func_args) {
553 s/^/&/ if $in_out{$_};
554 }
555 $func_args = join(", ", @func_args);
556 @args_match{@args} = @args_num;
557
9e831c8e
JK
558 my $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
559 my $CODE = grep(/^\s*CODE\s*:/, @line);
6b09c160
YST
560 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
561 # to set explicit return values.
9e831c8e 562 my $EXPLICIT_RETURN = ($CODE &&
1efd22b7 563 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
b9709a1c 564
50b96cc2
JK
565 # The $ALIAS which follows is only explicitly called within the scope of
566 # process_file(). In principle, it ought to be a lexical, i.e., 'my
b9709a1c
JK
567 # $ALIAS' like the other nearby variables. However, implementing that
568 # change produced a slight difference in the resulting .c output in at
569 # least two distributions: B/BD/BDFOY/Crypt-Rijndael and
570 # G/GF/GFUJI/Hash-FieldHash. The difference is, arguably, an improvement
571 # in the resulting C code. Example:
572 # 388c388
573 # < GvNAME(CvGV(cv)),
574 # ---
575 # > "Crypt::Rijndael::encrypt",
576 # But at this point we're committed to generating the *same* C code that
577 # the current version of ParseXS.pm does. So we're declaring it as 'our'.
578 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
579
9e831c8e 580 my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
6b09c160
YST
581
582 $xsreturn = 1 if $EXPLICIT_RETURN;
583
008fb49c
JH
584 $externC = $externC ? qq[extern "C"] : "";
585
6b09c160
YST
586 # print function header
587 print Q(<<"EOF");
008fb49c 588#$externC
6b09c160
YST
589#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
590#XS(XS_${Full_func_name})
591#[[
97aff369
JH
592##ifdef dVAR
593# dVAR; dXSARGS;
594##else
6b09c160 595# dXSARGS;
97aff369 596##endif
6b09c160 597EOF
7c3505a2 598 print Q(<<"EOF") if $ALIAS;
6b09c160
YST
599# dXSI32;
600EOF
7c3505a2 601 print Q(<<"EOF") if $INTERFACE;
6b09c160
YST
602# dXSFUNCTION($ret_type);
603EOF
95b611b0 604 if ($ellipsis) {
6b09c160 605 $cond = ($min_args ? qq(items < $min_args) : 0);
34fa6cb6
JK
606 }
607 elsif ($min_args == $num_args) {
6b09c160 608 $cond = qq(items != $min_args);
34fa6cb6
JK
609 }
610 else {
6b09c160
YST
611 $cond = qq(items < $min_args || items > $num_args);
612 }
613
c1e43162 614 print Q(<<"EOF") if $args{except};
6b09c160
YST
615# char errbuf[1024];
616# *errbuf = '\0';
617EOF
618
708f9ca6 619 if($cond) {
34fa6cb6 620 print Q(<<"EOF");
6b09c160 621# if ($cond)
708f9ca6 622# croak_xs_usage(cv, "$report_args");
6b09c160 623EOF
34fa6cb6
JK
624 }
625 else {
708f9ca6
DG
626 # cv likely to be unused
627 print Q(<<"EOF");
6b09c160
YST
628# PERL_UNUSED_VAR(cv); /* -W */
629EOF
708f9ca6 630 }
6b09c160
YST
631
632 #gcc -Wall: if an xsub has PPCODE is used
633 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
634 #hence `ax' (setup by dXSARGS) is unused
635 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
636 #but such a move could break third-party extensions
637 print Q(<<"EOF") if $PPCODE;
638# PERL_UNUSED_VAR(ax); /* -Wall */
639EOF
640
641 print Q(<<"EOF") if $PPCODE;
642# SP -= items;
643EOF
644
645 # Now do a block of some sort.
646
647 $condnum = 0;
1efd22b7 648 $cond = ''; # last CASE: condidional
6b09c160
YST
649 push(@line, "$END:");
650 push(@line_no, $line_no[-1]);
651 $_ = '';
652 &check_cpp;
653 while (@line) {
654 &CASE_handler if check_keyword("CASE");
655 print Q(<<"EOF");
c1e43162 656# $args{except} [[
6b09c160
YST
657EOF
658
659 # do initialization of input variables
660 $thisdone = 0;
661 $retvaldone = 0;
662 $deferred = "";
7c3505a2 663 %arg_list = ();
6b09c160 664 $gotRETVAL = 0;
1efd22b7 665
7c3505a2
JK
666 INPUT_handler();
667 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
6b09c160
YST
668
669 print Q(<<"EOF") if $ScopeThisXSUB;
670# ENTER;
671# [[
672EOF
1efd22b7 673
6b09c160 674 if (!$thisdone && defined($class)) {
34fa6cb6
JK
675 if (defined($static) or $func_name eq 'new') {
676 print "\tchar *";
677 $var_types{"CLASS"} = "char *";
879afb6d
JK
678 generate_init( {
679 type => "char *",
680 num => 1,
681 var => "CLASS",
682 printed_name => undef,
683 } );
34fa6cb6
JK
684 }
685 else {
686 print "\t$class *";
687 $var_types{"THIS"} = "$class *";
879afb6d
JK
688 generate_init( {
689 type => "$class *",
690 num => 1,
691 var => "THIS",
692 printed_name => undef,
693 } );
34fa6cb6 694 }
6b09c160 695 }
1efd22b7 696
6b09c160
YST
697 # do code
698 if (/^\s*NOT_IMPLEMENTED_YET/) {
34fa6cb6
JK
699 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
700 $_ = '';
701 }
702 else {
703 if ($ret_type ne "void") {
0ec7450c 704 print "\t" . &map_type($ret_type, 'RETVAL', $hiertype) . ";\n"
34fa6cb6
JK
705 if !$retvaldone;
706 $args_match{"RETVAL"} = 0;
707 $var_types{"RETVAL"} = $ret_type;
708 print "\tdXSTARG;\n"
c1e43162 709 if $args{optimize} and $targetable{$type_kind{$ret_type}};
34fa6cb6 710 }
1efd22b7 711
34fa6cb6
JK
712 if (@fake_INPUT or @fake_INPUT_pre) {
713 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
714 $_ = "";
715 $processing_arg_with_types = 1;
716 INPUT_handler();
717 }
718 print $deferred;
1efd22b7 719
7c3505a2 720 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
1efd22b7 721
34fa6cb6
JK
722 if (check_keyword("PPCODE")) {
723 print_section();
724 death ("PPCODE must be last thing") if @line;
725 print "\tLEAVE;\n" if $ScopeThisXSUB;
726 print "\tPUTBACK;\n\treturn;\n";
1efd22b7 727 }
34fa6cb6
JK
728 elsif (check_keyword("CODE")) {
729 print_section();
730 }
731 elsif (defined($class) and $func_name eq "DESTROY") {
732 print "\n\t";
733 print "delete THIS;\n";
734 }
735 else {
736 print "\n\t";
737 if ($ret_type ne "void") {
738 print "RETVAL = ";
739 $wantRETVAL = 1;
740 }
741 if (defined($static)) {
742 if ($func_name eq 'new') {
743 $func_name = "$class";
744 }
745 else {
746 print "${class}::";
747 }
748 }
749 elsif (defined($class)) {
750 if ($func_name eq 'new') {
751 $func_name .= " $class";
752 }
753 else {
754 print "THIS->";
755 }
756 }
757 $func_name =~ s/^\Q$args{'s'}//
758 if exists $args{'s'};
759 $func_name = 'XSFUNCTION' if $interface;
760 print "$func_name($func_args);\n";
1efd22b7 761 }
1efd22b7
JK
762 }
763
6b09c160 764 # do output variables
1efd22b7
JK
765 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
766 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
6b09c160
YST
767 # $wantRETVAL set if 'RETVAL =' autogenerated
768 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
7c3505a2 769 undef %outargs;
6b09c160 770 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
1efd22b7 771
879afb6d
JK
772 generate_output( {
773 type => $var_types{$_},
774 num => $args_match{$_},
775 var => $_,
776 do_setmagic => $DoSetMagic,
777 do_push => undef,
778 } ) for grep $in_out{$_} =~ /OUT$/, keys %in_out;
1efd22b7 779
6b09c160
YST
780 # all OUTPUT done, so now push the return value on the stack
781 if ($gotRETVAL && $RETVAL_code) {
34fa6cb6
JK
782 print "\t$RETVAL_code\n";
783 }
784 elsif ($gotRETVAL || $wantRETVAL) {
c1e43162 785 my $t = $args{optimize} && $targetable{$type_kind{$ret_type}};
fae3e113
JK
786 # Although the '$var' declared in the next line is never explicitly
787 # used within this 'elsif' block, commenting it out leads to
788 # disaster, starting with the first 'eval qq' inside the 'elsif' block
789 # below.
790 # It appears that this is related to the fact that at this point the
791 # value of $t is a reference to an array whose [2] element includes
792 # '$var' as a substring:
793 # <i> <> <(IV)$var>
34fa6cb6
JK
794 my $var = 'RETVAL';
795 my $type = $ret_type;
796
797 # 0: type, 1: with_size, 2: how, 3: how_size
798 if ($t and not $t->[1] and $t->[0] eq 'p') {
799 # PUSHp corresponds to setpvn. Treate setpv directly
800 my $what = eval qq("$t->[2]");
801 warn $@ if $@;
802
803 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
804 $prepush_done = 1;
805 }
806 elsif ($t) {
807 my $what = eval qq("$t->[2]");
808 warn $@ if $@;
809
af4112ab
JK
810 my $tsize = $t->[3];
811 $tsize = '' unless defined $tsize;
812 $tsize = eval qq("$tsize");
34fa6cb6 813 warn $@ if $@;
af4112ab 814 print "\tXSprePUSH; PUSH$t->[0]($what$tsize);\n";
34fa6cb6
JK
815 $prepush_done = 1;
816 }
817 else {
818 # RETVAL almost never needs SvSETMAGIC()
879afb6d
JK
819 generate_output( {
820 type => $ret_type,
821 num => 0,
822 var => 'RETVAL',
823 do_setmagic => 0,
824 do_push => undef,
825 } );
34fa6cb6 826 }
6b09c160 827 }
1efd22b7 828
6b09c160
YST
829 $xsreturn = 1 if $ret_type ne "void";
830 my $num = $xsreturn;
831 my $c = @outlist;
832 print "\tXSprePUSH;" if $c and not $prepush_done;
833 print "\tEXTEND(SP,$c);\n" if $c;
834 $xsreturn += $c;
879afb6d
JK
835 generate_output( {
836 type => $var_types{$_},
837 num => $num++,
838 var => $_,
839 do_setmagic => 0,
840 do_push => 1,
841 } ) for @outlist;
1efd22b7 842
6b09c160 843 # do cleanup
7c3505a2 844 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
1efd22b7 845
6b09c160
YST
846 print Q(<<"EOF") if $ScopeThisXSUB;
847# ]]
848EOF
849 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
850# LEAVE;
851EOF
1efd22b7 852
6b09c160
YST
853 # print function trailer
854 print Q(<<"EOF");
855# ]]
856EOF
c1e43162 857 print Q(<<"EOF") if $args{except};
6b09c160
YST
858# BEGHANDLERS
859# CATCHALL
1efd22b7 860# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
6b09c160
YST
861# ENDHANDLERS
862EOF
863 if (check_keyword("CASE")) {
34fa6cb6
JK
864 blurt ("Error: No `CASE:' at top of function")
865 unless $condnum;
866 $_ = "CASE: $_"; # Restore CASE: label
867 next;
6b09c160
YST
868 }
869 last if $_ eq "$END:";
28892255 870 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
6b09c160 871 }
1efd22b7 872
c1e43162 873 print Q(<<"EOF") if $args{except};
6b09c160 874# if (errbuf[0])
1efd22b7 875# Perl_croak(aTHX_ errbuf);
6b09c160 876EOF
1efd22b7 877
6b09c160
YST
878 if ($xsreturn) {
879 print Q(<<"EOF") unless $PPCODE;
880# XSRETURN($xsreturn);
881EOF
34fa6cb6
JK
882 }
883 else {
6b09c160
YST
884 print Q(<<"EOF") unless $PPCODE;
885# XSRETURN_EMPTY;
886EOF
887 }
888
889 print Q(<<"EOF");
890#]]
891#
892EOF
893
a40ca62b
JK
894 $newXS = "newXS";
895 $proto = "";
1efd22b7 896
6b09c160
YST
897 # Build the prototype string for the xsub
898 if ($ProtoThisXSUB) {
28892255 899 $newXS = "newXSproto_portable";
1efd22b7 900
6b09c160 901 if ($ProtoThisXSUB eq 2) {
34fa6cb6 902 # User has specified empty prototype
6b09c160
YST
903 }
904 elsif ($ProtoThisXSUB eq 1) {
34fa6cb6
JK
905 my $s = ';';
906 if ($min_args < $num_args) {
907 $s = '';
908 $proto_arg[$min_args] .= ";";
909 }
910 push @proto_arg, "$s\@"
911 if $ellipsis;
912
913 $proto = join ("", grep defined, @proto_arg);
6b09c160
YST
914 }
915 else {
34fa6cb6
JK
916 # User has specified a prototype
917 $proto = $ProtoThisXSUB;
6b09c160
YST
918 }
919 $proto = qq{, "$proto"};
920 }
28892255 921
6b09c160
YST
922 if (%XsubAliases) {
923 $XsubAliases{$pname} = 0
34fa6cb6 924 unless defined $XsubAliases{$pname};
534bb3f4 925 while ( my ($xname, $value) = each %XsubAliases) {
34fa6cb6 926 push(@InitFileCode, Q(<<"EOF"));
534bb3f4 927# cv = ${newXS}(\"$xname\", XS_$Full_func_name, file$proto);
7c3505a2 928# XSANY.any_i32 = $value;
6b09c160 929EOF
6b09c160
YST
930 }
931 }
932 elsif (@Attributes) {
933 push(@InitFileCode, Q(<<"EOF"));
28892255 934# cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);
6b09c160
YST
935# apply_attrs_string("$Package", cv, "@Attributes", 0);
936EOF
937 }
938 elsif ($interface) {
534bb3f4
JK
939 while ( my ($yname, $value) = each %Interfaces) {
940 $yname = "$Package\::$yname" unless $yname =~ /::/;
88577d04 941 push(@InitFileCode, Q(<<"EOF"));
534bb3f4 942# cv = ${newXS}(\"$yname\", XS_$Full_func_name, file$proto);
7c3505a2 943# $interface_macro_set(cv,$value);
6b09c160 944EOF
6b09c160
YST
945 }
946 }
387b6f8d
S
947 elsif($newXS eq 'newXS'){ # work around P5NCI's empty newXS macro
948 push(@InitFileCode,
1efd22b7 949 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
387b6f8d 950 }
6b09c160
YST
951 else {
952 push(@InitFileCode,
1efd22b7 953 " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
6b09c160 954 }
9e831c8e 955 } # END 'PARAGRAPH' 'while' loop
6b09c160 956
d710f389 957 if ($Overload) { # make it findable with fetchmethod
6b09c160
YST
958 print Q(<<"EOF");
959#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
960#XS(XS_${Packid}_nil)
961#{
68746769 962# dXSARGS;
6b09c160
YST
963# XSRETURN_EMPTY;
964#}
965#
966EOF
967 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
968 /* Making a sub named "${Package}::()" allows the package */
969 /* to be findable via fetchmethod(), and causes */
970 /* overload::Overloaded("${Package}") to return true. */
28892255 971 (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto);
6b09c160
YST
972MAKE_FETCHMETHOD_WORK
973 }
974
975 # print initialization routine
976
977 print Q(<<"EOF");
978##ifdef __cplusplus
979#extern "C"
980##endif
981EOF
982
983 print Q(<<"EOF");
984#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
985#XS(boot_$Module_cname)
986EOF
987
988 print Q(<<"EOF");
989#[[
97aff369
JH
990##ifdef dVAR
991# dVAR; dXSARGS;
992##else
6b09c160 993# dXSARGS;
97aff369 994##endif
6b09c160
YST
995EOF
996
1cb9da9d
DG
997 #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
998 #file name argument. If the wrong qualifier is used, it causes breakage with
999 #C++ compilers and warnings with recent gcc.
6b09c160
YST
1000 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
1001 #so `file' is unused
1002 print Q(<<"EOF") if $Full_func_name;
1cb9da9d 1003##if (PERL_REVISION == 5 && PERL_VERSION < 9)
28892255 1004# char* file = __FILE__;
1cb9da9d 1005##else
f05ddbb8 1006# const char* file = __FILE__;
1cb9da9d 1007##endif
6b09c160
YST
1008EOF
1009
1010 print Q("#\n");
1011
1012 print Q(<<"EOF");
1013# PERL_UNUSED_VAR(cv); /* -W */
1014# PERL_UNUSED_VAR(items); /* -W */
1015EOF
1efd22b7 1016
7c3505a2
JK
1017 print Q(<<"EOF") if $WantVersionChk;
1018# XS_VERSION_BOOTCHECK;
6b09c160
YST
1019#
1020EOF
1021
7c3505a2 1022 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
6b09c160 1023# {
7c3505a2 1024# CV * cv;
6b09c160
YST
1025#
1026EOF
1027
1028 print Q(<<"EOF") if ($Overload);
1029# /* register the overloading (type 'A') magic */
1030# PL_amagic_generation++;
1031# /* The magic for overload gets a GV* via gv_fetchmeth as */
1032# /* mentioned above, and looks in the SV* slot of it for */
1033# /* the "fallback" status. */
1034# sv_setsv(
1035# get_sv( "${Package}::()", TRUE ),
1036# $Fallback
1037# );
1038EOF
1039
1040 print @InitFileCode;
1041
7c3505a2 1042 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
6b09c160
YST
1043# }
1044EOF
1045
505ef4a5 1046 if (@BootCode) {
7c3505a2 1047 print "\n /* Initialisation Section */\n\n";
6b09c160
YST
1048 @line = @BootCode;
1049 print_section();
7c3505a2 1050 print "\n /* End of Initialisation Section */\n\n";
6b09c160
YST
1051 }
1052
1cb9da9d
DG
1053 print Q(<<'EOF');
1054##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
1055# if (PL_unitcheckav)
1056# call_list(PL_scopestack_ix, PL_unitcheckav);
1057##endif
0932863f 1058EOF
89345840 1059
6b09c160
YST
1060 print Q(<<"EOF");
1061# XSRETURN_YES;
1062#]]
1063#
1064EOF
1065
1066 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
7c3505a2 1067 unless $ProtoUsed;
6b09c160
YST
1068
1069 chdir($orig_cwd);
1070 select($orig_fh);
1071 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
907ce46c 1072 close $FH;
6b09c160
YST
1073
1074 return 1;
1075}
1076
c74be726
JK
1077#sub errors { $errors }
1078sub report_error_count { $errors }
6b09c160 1079
6b09c160
YST
1080# Input: ($_, @line) == unparsed input.
1081# Output: ($_, @line) == (rest of line, following lines).
1082# Return: the matched keyword if found, otherwise 0
1083sub check_keyword {
505ef4a5
JK
1084 $_ = shift(@line) while !/\S/ && @line;
1085 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
6b09c160
YST
1086}
1087
1088sub print_section {
505ef4a5
JK
1089 # the "do" is required for right semantics
1090 do { $_ = shift(@line) } while !/\S/ && @line;
6b09c160 1091
505ef4a5 1092 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1efd22b7 1093 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
505ef4a5 1094 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1efd22b7 1095 print "$_\n";
505ef4a5
JK
1096 }
1097 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
6b09c160
YST
1098}
1099
1100sub merge_section {
505ef4a5 1101 my $in = '';
6b09c160 1102
505ef4a5
JK
1103 while (!/\S/ && @line) {
1104 $_ = shift(@line);
1105 }
6b09c160 1106
505ef4a5
JK
1107 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1108 $in .= "$_\n";
6b09c160 1109 }
505ef4a5
JK
1110 chomp $in;
1111 return $in;
1112}
6b09c160 1113
505ef4a5
JK
1114sub process_keyword($) {
1115 my($pattern) = @_;
1116 my $kwd;
6b09c160 1117
d710f389 1118 no strict 'refs';
505ef4a5
JK
1119 &{"${kwd}_handler"}()
1120 while $kwd = check_keyword($pattern);
d710f389 1121 use strict 'refs';
505ef4a5 1122}
6b09c160
YST
1123
1124sub CASE_handler {
1125 blurt ("Error: `CASE:' after unconditional `CASE:'")
1126 if $condnum && $cond eq '';
1127 $cond = $_;
1d40e528 1128 trim_whitespace($cond);
6b09c160 1129 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
7c3505a2 1130 $_ = '';
6b09c160
YST
1131}
1132
1133sub INPUT_handler {
1134 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1135 last if /^\s*NOT_IMPLEMENTED_YET/;
1efd22b7 1136 next unless /\S/; # skip blank lines
6b09c160 1137
1d40e528 1138 trim_whitespace($_);
9e831c8e 1139 my $ln = $_;
6b09c160
YST
1140
1141 # remove trailing semicolon if no initialisation
7c3505a2 1142 s/\s*;$//g unless /[=;+].*\S/;
6b09c160
YST
1143
1144 # Process the length(foo) declarations
1145 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1146 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
be5bcef7 1147 $lengthof{$2} = undef;
1cb9da9d 1148 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
6b09c160
YST
1149 }
1150
1151 # check for optional initialisation code
7c3505a2
JK
1152 my $var_init = '';
1153 $var_init = $1 if s/\s*([=;+].*)$//s;
6b09c160
YST
1154 $var_init =~ s/"/\\"/g;
1155
1156 s/\s+/ /g;
1157 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
9e831c8e 1158 or blurt("Error: invalid argument declaration '$ln'"), next;
6b09c160
YST
1159
1160 # Check for duplicate definitions
1161 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1162 if $arg_list{$var_name}++
1efd22b7 1163 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
6b09c160
YST
1164
1165 $thisdone |= $var_name eq "THIS";
1166 $retvaldone |= $var_name eq "RETVAL";
1167 $var_types{$var_name} = $var_type;
1168 # XXXX This check is a safeguard against the unfinished conversion of
1169 # generate_init(). When generate_init() is fixed,
1170 # one can use 2-args map_type() unconditionally.
1171 if ($var_type =~ / \( \s* \* \s* \) /x) {
1172 # Function pointers are not yet supported with &output_init!
0ec7450c 1173 print "\t" . &map_type($var_type, $var_name, $hiertype);
68f166a7 1174 $printed_name = 1;
505ef4a5
JK
1175 }
1176 else {
0ec7450c 1177 print "\t" . &map_type($var_type, undef, $hiertype);
68f166a7 1178 $printed_name = 0;
6b09c160
YST
1179 }
1180 $var_num = $args_match{$var_name};
1181
1182 $proto_arg[$var_num] = ProtoString($var_type)
7c3505a2 1183 if $var_num;
6b09c160
YST
1184 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1185 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
505ef4a5
JK
1186 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1187 and $var_init !~ /\S/) {
68f166a7 1188 if ($printed_name) {
505ef4a5 1189 print ";\n";
6b09c160 1190 }
505ef4a5
JK
1191 else {
1192 print "\t$var_name;\n";
1193 }
1194 }
1195 elsif ($var_init =~ /\S/) {
87e6f370
JK
1196 output_init( {
1197 type => $var_type,
1198 num => $var_num,
1199 var => $var_name,
1200 init => $var_init,
1201 printed_name => $printed_name,
1202 } );
505ef4a5
JK
1203 }
1204 elsif ($var_num) {
879afb6d
JK
1205 generate_init( {
1206 type => $var_type,
1207 num => $var_num,
1208 var => $var_name,
1209 printed_name => $printed_name,
1210 } );
505ef4a5
JK
1211 }
1212 else {
6b09c160
YST
1213 print ";\n";
1214 }
1215 }
1216}
1217
1218sub OUTPUT_handler {
1219 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1220 next unless /\S/;
1221 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1222 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1223 next;
1224 }
7c3505a2 1225 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s;
6b09c160 1226 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
9e831c8e 1227 if $outargs{$outarg}++;
6b09c160
YST
1228 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1229 # deal with RETVAL last
7c3505a2
JK
1230 $RETVAL_code = $outcode;
1231 $gotRETVAL = 1;
1232 next;
6b09c160
YST
1233 }
1234 blurt ("Error: OUTPUT $outarg not an argument"), next
1235 unless defined($args_match{$outarg});
1236 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
7c3505a2 1237 unless defined $var_types{$outarg};
6b09c160
YST
1238 $var_num = $args_match{$outarg};
1239 if ($outcode) {
1240 print "\t$outcode\n";
1241 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
505ef4a5
JK
1242 }
1243 else {
879afb6d
JK
1244 generate_output( {
1245 type => $var_types{$outarg},
1246 num => $var_num,
1247 var => $outarg,
1248 do_setmagic => $DoSetMagic,
1249 do_push => undef,
1250 } );
6b09c160 1251 }
1efd22b7 1252 delete $in_out{$outarg} # No need to auto-OUTPUT
6b09c160
YST
1253 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1254 }
1255}
1256
1257sub C_ARGS_handler() {
1258 my $in = merge_section();
1259
1d40e528 1260 trim_whitespace($in);
6b09c160
YST
1261 $func_args = $in;
1262}
1263
1264sub INTERFACE_MACRO_handler() {
1265 my $in = merge_section();
1266
1d40e528 1267 trim_whitespace($in);
1efd22b7 1268 if ($in =~ /\s/) { # two
6b09c160 1269 ($interface_macro, $interface_macro_set) = split ' ', $in;
505ef4a5
JK
1270 }
1271 else {
6b09c160
YST
1272 $interface_macro = $in;
1273 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1274 }
1efd22b7
JK
1275 $interface = 1; # local
1276 $Interfaces = 1; # global
6b09c160
YST
1277}
1278
1279sub INTERFACE_handler() {
1280 my $in = merge_section();
1281
1d40e528 1282 trim_whitespace($in);
6b09c160
YST
1283
1284 foreach (split /[\s,]+/, $in) {
88577d04
JK
1285 my $iface_name = $_;
1286 $iface_name =~ s/^$Prefix//;
1287 $Interfaces{$iface_name} = $_;
6b09c160
YST
1288 }
1289 print Q(<<"EOF");
1efd22b7 1290# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
6b09c160 1291EOF
1efd22b7
JK
1292 $interface = 1; # local
1293 $Interfaces = 1; # global
6b09c160
YST
1294}
1295
1296sub CLEANUP_handler() { print_section() }
1297sub PREINIT_handler() { print_section() }
1298sub POSTCALL_handler() { print_section() }
1299sub INIT_handler() { print_section() }
1300
505ef4a5
JK
1301sub GetAliases {
1302 my ($line) = @_;
1303 my ($orig) = $line;
6b09c160 1304
505ef4a5
JK
1305 # Parse alias definitions
1306 # format is
1307 # alias = value alias = value ...
6b09c160 1308
505ef4a5 1309 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
9e831c8e
JK
1310 my ($alias, $value) = ($1, $2);
1311 my $orig_alias = $alias;
6b09c160 1312
505ef4a5
JK
1313 # check for optional package definition in the alias
1314 $alias = $Packprefix . $alias if $alias !~ /::/;
6b09c160 1315
505ef4a5
JK
1316 # check for duplicate alias name & duplicate value
1317 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1318 if defined $XsubAliases{$alias};
6b09c160 1319
505ef4a5
JK
1320 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1321 if $XsubAliasValues{$value};
6b09c160 1322
505ef4a5
JK
1323 $XsubAliases = 1;
1324 $XsubAliases{$alias} = $value;
1325 $XsubAliasValues{$value} = $orig_alias;
6b09c160
YST
1326 }
1327
505ef4a5
JK
1328 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1329 if $line;
1330}
1331
1332sub ATTRS_handler () {
1333 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1334 next unless /\S/;
1d40e528 1335 trim_whitespace($_);
505ef4a5 1336 push @Attributes, $_;
6b09c160 1337 }
505ef4a5 1338}
6b09c160 1339
505ef4a5
JK
1340sub ALIAS_handler () {
1341 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1342 next unless /\S/;
1d40e528 1343 trim_whitespace($_);
505ef4a5 1344 GetAliases($_) if $_;
6b09c160 1345 }
505ef4a5 1346}
6b09c160 1347
505ef4a5 1348sub OVERLOAD_handler() {
6b09c160
YST
1349 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1350 next unless /\S/;
1d40e528 1351 trim_whitespace($_);
6b09c160
YST
1352 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1353 $Overload = 1 unless $Overload;
7c3505a2 1354 my $overload = "$Package\::(".$1;
6b09c160 1355 push(@InitFileCode,
1efd22b7 1356 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
6b09c160 1357 }
1efd22b7 1358 }
6b09c160
YST
1359}
1360
505ef4a5 1361sub FALLBACK_handler() {
1efd22b7 1362 # the rest of the current line should contain either TRUE,
6b09c160 1363 # FALSE or UNDEF
1efd22b7 1364
1d40e528 1365 trim_whitespace($_);
6b09c160 1366 my %map = (
505ef4a5
JK
1367 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1368 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1369 UNDEF => "&PL_sv_undef",
1370 );
1efd22b7 1371
6b09c160 1372 # check for valid FALLBACK value
7c3505a2 1373 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
1efd22b7 1374
7c3505a2 1375 $Fallback = $map{uc $_};
6b09c160
YST
1376}
1377
1378
505ef4a5
JK
1379sub REQUIRE_handler () {
1380 # the rest of the current line should contain a version number
1381 my ($Ver) = $_;
6b09c160 1382
1d40e528 1383 trim_whitespace($Ver);
6b09c160 1384
505ef4a5
JK
1385 death ("Error: REQUIRE expects a version number")
1386 unless $Ver;
6b09c160 1387
505ef4a5
JK
1388 # check that the version number is of the form n.n
1389 death ("Error: REQUIRE: expected a number, got '$Ver'")
1390 unless $Ver =~ /^\d+(\.\d*)?/;
6b09c160 1391
505ef4a5
JK
1392 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1393 unless $VERSION >= $Ver;
1394}
6b09c160 1395
505ef4a5
JK
1396sub VERSIONCHECK_handler () {
1397 # the rest of the current line should contain either ENABLE or
1398 # DISABLE
6b09c160 1399
1d40e528 1400 trim_whitespace($_);
6b09c160 1401
505ef4a5
JK
1402 # check for ENABLE/DISABLE
1403 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1404 unless /^(ENABLE|DISABLE)/i;
6b09c160 1405
505ef4a5
JK
1406 $WantVersionChk = 1 if $1 eq 'ENABLE';
1407 $WantVersionChk = 0 if $1 eq 'DISABLE';
6b09c160 1408
505ef4a5 1409}
6b09c160 1410
505ef4a5
JK
1411sub PROTOTYPE_handler () {
1412 my $specified;
6b09c160 1413
505ef4a5 1414 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
9e831c8e 1415 if $proto_in_this_xsub++;
6b09c160 1416
505ef4a5
JK
1417 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1418 next unless /\S/;
1419 $specified = 1;
1d40e528 1420 trim_whitespace($_);
505ef4a5
JK
1421 if ($_ eq 'DISABLE') {
1422 $ProtoThisXSUB = 0;
1423 }
1424 elsif ($_ eq 'ENABLE') {
1425 $ProtoThisXSUB = 1;
1426 }
1427 else {
1428 # remove any whitespace
1429 s/\s+//g;
1430 death("Error: Invalid prototype '$_'")
547742ac 1431 unless valid_proto_string($_);
505ef4a5
JK
1432 $ProtoThisXSUB = C_string($_);
1433 }
6b09c160
YST
1434 }
1435
505ef4a5
JK
1436 # If no prototype specified, then assume empty prototype ""
1437 $ProtoThisXSUB = 2 unless $specified;
6b09c160 1438
505ef4a5
JK
1439 $ProtoUsed = 1;
1440}
6b09c160 1441
505ef4a5
JK
1442sub SCOPE_handler () {
1443 death("Error: Only 1 SCOPE declaration allowed per xsub")
9e831c8e 1444 if $scope_in_this_xsub++;
6b09c160 1445
1d40e528 1446 trim_whitespace($_);
505ef4a5
JK
1447 death ("Error: SCOPE: ENABLE/DISABLE")
1448 unless /^(ENABLE|DISABLE)\b/i;
1449 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
1450}
6b09c160 1451
505ef4a5
JK
1452sub PROTOTYPES_handler () {
1453 # the rest of the current line should contain either ENABLE or
1454 # DISABLE
6b09c160 1455
1d40e528 1456 trim_whitespace($_);
6b09c160 1457
505ef4a5
JK
1458 # check for ENABLE/DISABLE
1459 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1460 unless /^(ENABLE|DISABLE)/i;
6b09c160 1461
505ef4a5
JK
1462 $WantPrototypes = 1 if $1 eq 'ENABLE';
1463 $WantPrototypes = 0 if $1 eq 'DISABLE';
1464 $ProtoUsed = 1;
1465}
387b6f8d 1466
505ef4a5 1467sub PushXSStack {
f0744969 1468 my %args = @_;
505ef4a5
JK
1469 # Save the current file context.
1470 push(@XSStack, {
1471 type => 'file',
1472 LastLine => $lastline,
1473 LastLineNo => $lastline_no,
1474 Line => \@line,
1475 LineNo => \@line_no,
1476 Filename => $filename,
1477 Filepathname => $filepathname,
1478 Handle => $FH,
1479 IsPipe => scalar($filename =~ /\|\s*$/),
1480 %args,
1481 });
387b6f8d 1482
505ef4a5 1483}
6b09c160 1484
505ef4a5
JK
1485sub INCLUDE_handler () {
1486 # the rest of the current line should contain a valid filename
6b09c160 1487
1d40e528 1488 trim_whitespace($_);
6b09c160 1489
505ef4a5
JK
1490 death("INCLUDE: filename missing")
1491 unless $_;
6b09c160 1492
505ef4a5
JK
1493 death("INCLUDE: output pipe is illegal")
1494 if /^\s*\|/;
6b09c160 1495
505ef4a5
JK
1496 # simple minded recursion detector
1497 death("INCLUDE loop detected")
1498 if $IncludedFiles{$_};
6b09c160 1499
9e831c8e 1500 ++$IncludedFiles{$_} unless /\|\s*$/;
505ef4a5
JK
1501
1502 if (/\|\s*$/ && /^\s*perl\s/) {
1503 Warn("The INCLUDE directive with a command is discouraged." .
1504 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1505 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1506 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1507 " the use of \$^X as the currently running perl, see" .
1508 " 'perldoc perlxs' for details.");
1509 }
387b6f8d 1510
505ef4a5 1511 PushXSStack();
6b09c160 1512
505ef4a5 1513 $FH = Symbol::gensym();
6b09c160 1514
505ef4a5
JK
1515 # open the new file
1516 open ($FH, "$_") or death("Cannot open '$_': $!");
6b09c160 1517
505ef4a5 1518 print Q(<<"EOF");
6b09c160
YST
1519#
1520#/* INCLUDE: Including '$_' from '$filename' */
1521#
1522EOF
1523
505ef4a5
JK
1524 $filename = $_;
1525 $filepathname = File::Spec->catfile($dir, $filename);
6b09c160 1526
505ef4a5
JK
1527 # Prime the pump by reading the first
1528 # non-blank line
6b09c160 1529
505ef4a5
JK
1530 # skip leading blank lines
1531 while (<$FH>) {
1532 last unless /^\s*$/;
387b6f8d
S
1533 }
1534
505ef4a5
JK
1535 $lastline = $_;
1536 $lastline_no = $.;
1537}
1538
494e8c4c 1539sub QuoteArgs {
505ef4a5
JK
1540 my $cmd = shift;
1541 my @args = split /\s+/, $cmd;
1542 $cmd = shift @args;
1543 for (@args) {
1544 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
494e8c4c 1545 }
505ef4a5
JK
1546 return join (' ', ($cmd, @args));
1547}
494e8c4c 1548
505ef4a5
JK
1549sub INCLUDE_COMMAND_handler () {
1550 # the rest of the current line should contain a valid command
387b6f8d 1551
1d40e528 1552 trim_whitespace($_);
387b6f8d 1553
505ef4a5 1554 $_ = QuoteArgs($_) if $^O eq 'VMS';
494e8c4c 1555
505ef4a5
JK
1556 death("INCLUDE_COMMAND: command missing")
1557 unless $_;
387b6f8d 1558
505ef4a5
JK
1559 death("INCLUDE_COMMAND: pipes are illegal")
1560 if /^\s*\|/ or /\|\s*$/;
387b6f8d 1561
505ef4a5 1562 PushXSStack( IsPipe => 1 );
387b6f8d 1563
505ef4a5 1564 $FH = Symbol::gensym();
387b6f8d 1565
505ef4a5
JK
1566 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1567 # the same perl interpreter as we're currently running
1568 s/^\s*\$\^X/$^X/;
387b6f8d 1569
505ef4a5
JK
1570 # open the new file
1571 open ($FH, "-|", "$_")
1572 or death("Cannot run command '$_' to include its output: $!");
387b6f8d 1573
505ef4a5 1574 print Q(<<"EOF");
387b6f8d
S
1575#
1576#/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */
1577#
1578EOF
1579
505ef4a5
JK
1580 $filename = $_;
1581 $filepathname = $filename;
1582 $filepathname =~ s/\"/\\"/g;
387b6f8d 1583
505ef4a5
JK
1584 # Prime the pump by reading the first
1585 # non-blank line
6b09c160 1586
505ef4a5
JK
1587 # skip leading blank lines
1588 while (<$FH>) {
1589 last unless /^\s*$/;
6b09c160
YST
1590 }
1591
505ef4a5
JK
1592 $lastline = $_;
1593 $lastline_no = $.;
1594}
6b09c160 1595
505ef4a5
JK
1596sub PopFile() {
1597 return 0 unless $XSStack[-1]{type} eq 'file';
6b09c160 1598
505ef4a5
JK
1599 my $data = pop @XSStack;
1600 my $ThisFile = $filename;
1601 my $isPipe = $data->{IsPipe};
6b09c160 1602
9e831c8e 1603 --$IncludedFiles{$filename}
505ef4a5 1604 unless $isPipe;
6b09c160 1605
505ef4a5 1606 close $FH;
6b09c160 1607
505ef4a5
JK
1608 $FH = $data->{Handle};
1609 # $filename is the leafname, which for some reason isused for diagnostic
1610 # messages, whereas $filepathname is the full pathname, and is used for
1611 # #line directives.
1612 $filename = $data->{Filename};
1613 $filepathname = $data->{Filepathname};
1614 $lastline = $data->{LastLine};
1615 $lastline_no = $data->{LastLineNo};
1616 @line = @{ $data->{Line} };
1617 @line_no = @{ $data->{LineNo} };
1618
1619 if ($isPipe and $? ) {
9e831c8e 1620 --$lastline_no;
505ef4a5
JK
1621 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1622 exit 1;
1623 }
6b09c160 1624
505ef4a5 1625 print Q(<<"EOF");
6b09c160
YST
1626#
1627#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1628#
1629EOF
1630
505ef4a5
JK
1631 return 1;
1632}
6b09c160 1633
505ef4a5
JK
1634sub ProtoString ($) {
1635 my ($type) = @_;
1636
1637 $proto_letter{$type} or "\$";
1638}
6b09c160
YST
1639
1640sub check_cpp {
1641 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1642 if (@cpp) {
1643 my ($cpp, $cpplevel);
1644 for $cpp (@cpp) {
1645 if ($cpp =~ /^\#\s*if/) {
505ef4a5
JK
1646 $cpplevel++;
1647 }
1648 elsif (!$cpplevel) {
1649 Warn("Warning: #else/elif/endif without #if in this function");
1650 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1651 if $XSStack[-1]{type} eq 'if';
1652 return;
1653 }
1654 elsif ($cpp =~ /^\#\s*endif/) {
1655 $cpplevel--;
6b09c160
YST
1656 }
1657 }
1658 Warn("Warning: #if without #endif in this function") if $cpplevel;
1659 }
1660}
1661
1662
1663sub Q {
1664 my($text) = @_;
1665 $text =~ s/^#//gm;
1666 $text =~ s/\[\[/{/g;
1667 $text =~ s/\]\]/}/g;
1668 $text;
1669}
1670
1671# Read next xsub into @line from ($lastline, <$FH>).
1672sub fetch_para {
1673 # parse paragraph
1674 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1675 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1676 @line = ();
7c3505a2 1677 @line_no = ();
6b09c160
YST
1678 return PopFile() if !defined $lastline;
1679
1680 if ($lastline =~
1681 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
be5bcef7 1682 my $Module = $1;
6b09c160
YST
1683 $Package = defined($2) ? $2 : ''; # keep -w happy
1684 $Prefix = defined($3) ? $3 : ''; # keep -w happy
7c3505a2 1685 $Prefix = quotemeta $Prefix;
6b09c160
YST
1686 ($Module_cname = $Module) =~ s/\W/_/g;
1687 ($Packid = $Package) =~ tr/:/_/;
1688 $Packprefix = $Package;
1689 $Packprefix .= "::" if $Packprefix ne "";
1690 $lastline = "";
1691 }
1692
1693 for (;;) {
1694 # Skip embedded PODs
1695 while ($lastline =~ /^=/) {
1696 while ($lastline = <$FH>) {
505ef4a5 1697 last if ($lastline =~ /^=cut\s*$/);
6b09c160
YST
1698 }
1699 death ("Error: Unterminated pod") unless $lastline;
1700 $lastline = <$FH>;
1701 chomp $lastline;
1702 $lastline =~ s/^\s+$//;
1703 }
1704 if ($lastline !~ /^\s*#/ ||
1efd22b7
JK
1705 # CPP directives:
1706 # ANSI: if ifdef ifndef elif else endif define undef
1707 # line error pragma
1708 # gcc: warning include_next
1709 # obj-c: import
1710 # others: ident (gcc notes that some cpps have this one)
1711 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
6b09c160
YST
1712 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1713 push(@line, $lastline);
7c3505a2 1714 push(@line_no, $lastline_no);
6b09c160
YST
1715 }
1716
1717 # Read next line and continuation lines
1718 last unless defined($lastline = <$FH>);
1719 $lastline_no = $.;
1720 my $tmp_line;
1721 $lastline .= $tmp_line
1722 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1723
1724 chomp $lastline;
1725 $lastline =~ s/^\s+$//;
1726 }
1727 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1728 1;
1729}
1730
1731sub output_init {
87e6f370
JK
1732 my $argsref = shift;
1733 my ($type, $num, $var, $init, $printed_name) = (
1734 $argsref->{type},
1735 $argsref->{num},
1736 $argsref->{var},
1737 $argsref->{init},
1738 $argsref->{printed_name}
1739 );
f0744969 1740 my $arg = "ST(" . ($num - 1) . ")";
6b09c160
YST
1741
1742 if ( $init =~ /^=/ ) {
68f166a7 1743 if ($printed_name) {
6b09c160 1744 eval qq/print " $init\\n"/;
505ef4a5
JK
1745 }
1746 else {
6b09c160
YST
1747 eval qq/print "\\t$var $init\\n"/;
1748 }
9e831c8e 1749 warn $@ if $@;
505ef4a5
JK
1750 }
1751 else {
6b09c160 1752 if ( $init =~ s/^\+// && $num ) {
879afb6d
JK
1753 generate_init( {
1754 type => $type,
1755 num => $num,
1756 var => $var,
1757 printed_name => $printed_name,
1758 } );
505ef4a5 1759 }
68f166a7 1760 elsif ($printed_name) {
6b09c160
YST
1761 print ";\n";
1762 $init =~ s/^;//;
505ef4a5
JK
1763 }
1764 else {
6b09c160 1765 eval qq/print "\\t$var;\\n"/;
9e831c8e 1766 warn $@ if $@;
6b09c160
YST
1767 $init =~ s/^;//;
1768 }
1769 $deferred .= eval qq/"\\n\\t$init\\n"/;
505ef4a5 1770 warn $@ if $@;
6b09c160
YST
1771 }
1772}
1773
6b09c160 1774sub generate_init {
879afb6d
JK
1775 my $argsref = shift;
1776 my ($type, $num, $var, $printed_name) = (
1777 $argsref->{type},
1778 $argsref->{num},
1779 $argsref->{var},
1780 $argsref->{printed_name},
1781 );
be5bcef7 1782 my $arg = "ST(" . ($num - 1) . ")";
be5bcef7
JK
1783 my ($argoff, $ntype, $tk);
1784 $argoff = $num - 1;
6b09c160 1785
73e91d5a 1786 $type = tidy_type($type);
6b09c160
YST
1787 blurt("Error: '$type' not in typemap"), return
1788 unless defined($type_kind{$type});
1789
1790 ($ntype = $type) =~ s/\s*\*/Ptr/g;
be5bcef7 1791 my $subtype;
6b09c160
YST
1792 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1793 $tk = $type_kind{$type};
1794 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1795 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
68f166a7 1796 print "\t$var" unless $printed_name;
6b09c160
YST
1797 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1798 die "default value not supported with length(NAME) supplied"
1799 if defined $defaults{$var};
1800 return;
1801 }
1802 $type =~ tr/:/_/ unless $hiertype;
1803 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
7c3505a2 1804 unless defined $input_expr{$tk};
be5bcef7 1805 my $expr = $input_expr{$tk};
6b09c160
YST
1806 if ($expr =~ /DO_ARRAY_ELEM/) {
1807 blurt("Error: '$subtype' not in typemap"), return
1808 unless defined($type_kind{$subtype});
1809 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
7c3505a2 1810 unless defined $input_expr{$type_kind{$subtype}};
be5bcef7 1811 my $subexpr = $input_expr{$type_kind{$subtype}};
6b09c160
YST
1812 $subexpr =~ s/\$type/\$subtype/g;
1813 $subexpr =~ s/ntype/subtype/g;
1814 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1815 $subexpr =~ s/\n\t/\n\t\t/g;
1816 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1817 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1818 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1819 }
1820 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1821 $ScopeThisXSUB = 1;
1822 }
1823 if (defined($defaults{$var})) {
1824 $expr =~ s/(\t+)/$1 /g;
1825 $expr =~ s/ /\t/g;
68f166a7 1826 if ($printed_name) {
6b09c160 1827 print ";\n";
505ef4a5
JK
1828 }
1829 else {
6b09c160 1830 eval qq/print "\\t$var;\\n"/;
0bba9eb1 1831 warn $@ if $@;
6b09c160
YST
1832 }
1833 if ($defaults{$var} eq 'NO_INIT') {
1834 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
505ef4a5
JK
1835 }
1836 else {
6b09c160
YST
1837 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1838 }
0bba9eb1 1839 warn $@ if $@;
505ef4a5
JK
1840 }
1841 elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
68f166a7 1842 if ($printed_name) {
6b09c160 1843 print ";\n";
505ef4a5
JK
1844 }
1845 else {
6b09c160 1846 eval qq/print "\\t$var;\\n"/;
0bba9eb1 1847 warn $@ if $@;
6b09c160
YST
1848 }
1849 $deferred .= eval qq/"\\n$expr;\\n"/;
0bba9eb1 1850 warn $@ if $@;
505ef4a5
JK
1851 }
1852 else {
6b09c160 1853 die "panic: do not know how to handle this branch for function pointers"
68f166a7 1854 if $printed_name;
6b09c160 1855 eval qq/print "$expr;\\n"/;
0bba9eb1 1856 warn $@ if $@;
6b09c160
YST
1857 }
1858}
1859
1860sub generate_output {
879afb6d
JK
1861 my $argsref = shift;
1862 my ($type, $num, $var, $do_setmagic, $do_push) = (
1863 $argsref->{type},
1864 $argsref->{num},
1865 $argsref->{var},
1866 $argsref->{do_setmagic},
1867 $argsref->{do_push}
1868 );
be5bcef7 1869 my $arg = "ST(" . ($num - ($num != 0)) . ")";
be5bcef7 1870 my $ntype;
6b09c160 1871
73e91d5a 1872 $type = tidy_type($type);
6b09c160
YST
1873 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1874 print "\t$arg = sv_newmortal();\n";
1875 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1876 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
505ef4a5
JK
1877 }
1878 else {
6b09c160
YST
1879 blurt("Error: '$type' not in typemap"), return
1880 unless defined($type_kind{$type});
1881 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
7c3505a2 1882 unless defined $output_expr{$type_kind{$type}};
6b09c160
YST
1883 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1884 $ntype =~ s/\(\)//g;
be5bcef7 1885 my $subtype;
6b09c160 1886 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
be5bcef7 1887 my $expr = $output_expr{$type_kind{$type}};
6b09c160
YST
1888 if ($expr =~ /DO_ARRAY_ELEM/) {
1889 blurt("Error: '$subtype' not in typemap"), return
59863c7c 1890 unless defined($type_kind{$subtype});
6b09c160 1891 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
59863c7c 1892 unless defined $output_expr{$type_kind{$subtype}};
be5bcef7 1893 my $subexpr = $output_expr{$type_kind{$subtype}};
6b09c160
YST
1894 $subexpr =~ s/ntype/subtype/g;
1895 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1896 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1897 $subexpr =~ s/\n\t/\n\t\t/g;
1898 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1899 eval "print qq\a$expr\a";
0bba9eb1 1900 warn $@ if $@;
6b09c160 1901 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
505ef4a5
JK
1902 }
1903 elsif ($var eq 'RETVAL') {
6b09c160 1904 if ($expr =~ /^\t\$arg = new/) {
505ef4a5
JK
1905 # We expect that $arg has refcnt 1, so we need to
1906 # mortalize it.
1907 eval "print qq\a$expr\a";
0bba9eb1 1908 warn $@ if $@;
505ef4a5
JK
1909 print "\tsv_2mortal(ST($num));\n";
1910 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1911 }
1912 elsif ($expr =~ /^\s*\$arg\s*=/) {
1913 # We expect that $arg has refcnt >=1, so we need
1914 # to mortalize it!
1915 eval "print qq\a$expr\a";
0bba9eb1 1916 warn $@ if $@;
505ef4a5
JK
1917 print "\tsv_2mortal(ST(0));\n";
1918 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
6b09c160 1919 }
505ef4a5
JK
1920 else {
1921 # Just hope that the entry would safely write it
1922 # over an already mortalized value. By
1923 # coincidence, something like $arg = &sv_undef
1924 # works too.
1925 print "\tST(0) = sv_newmortal();\n";
1926 eval "print qq\a$expr\a";
0bba9eb1 1927 warn $@ if $@;
505ef4a5
JK
1928 # new mortals don't have set magic
1929 }
1930 }
1931 elsif ($do_push) {
6b09c160
YST
1932 print "\tPUSHs(sv_newmortal());\n";
1933 $arg = "ST($num)";
1934 eval "print qq\a$expr\a";
0bba9eb1 1935 warn $@ if $@;
6b09c160 1936 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
505ef4a5
JK
1937 }
1938 elsif ($arg =~ /^ST\(\d+\)$/) {
6b09c160 1939 eval "print qq\a$expr\a";
0bba9eb1 1940 warn $@ if $@;
6b09c160
YST
1941 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1942 }
1943 }
1944}
1945
87e6f370
JK
1946sub Warn {
1947 # work out the line number
1948 my $warn_line_number = $line_no[@line_no - @line -1];
1949
1950 print STDERR "@_ in $filename, line $warn_line_number\n";
1951}
1952
1953sub blurt {
1954 Warn @_;
1955 $errors++
1956}
1957
1958sub death {
1959 Warn @_;
1960 exit 1;
1961}
1962
6b09c160 19631;