This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change arguments to generate_init() to single hashref.
[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
a1c5c71f 24our (@ISA, @EXPORT_OK, $VERSION);
6b09c160
YST
25@ISA = qw(Exporter);
26@EXPORT_OK = qw(process_file);
566395ef 27$VERSION = '3';
a1c5c71f 28$VERSION = eval $VERSION if $VERSION =~ /_/;
6b09c160 29
566395ef 30# use strict; # One of these days ...
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("char *", 1, "CLASS", undef);
679 generate_init( {
680 type => "char *",
681 num => 1,
682 var => "CLASS",
683 printed_name => undef,
684 } );
34fa6cb6
JK
685 }
686 else {
687 print "\t$class *";
688 $var_types{"THIS"} = "$class *";
879afb6d
JK
689# &generate_init("$class *", 1, "THIS", undef);
690 generate_init( {
691 type => "$class *",
692 num => 1,
693 var => "THIS",
694 printed_name => undef,
695 } );
34fa6cb6 696 }
6b09c160 697 }
1efd22b7 698
6b09c160
YST
699 # do code
700 if (/^\s*NOT_IMPLEMENTED_YET/) {
34fa6cb6
JK
701 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
702 $_ = '';
703 }
704 else {
705 if ($ret_type ne "void") {
0ec7450c 706 print "\t" . &map_type($ret_type, 'RETVAL', $hiertype) . ";\n"
34fa6cb6
JK
707 if !$retvaldone;
708 $args_match{"RETVAL"} = 0;
709 $var_types{"RETVAL"} = $ret_type;
710 print "\tdXSTARG;\n"
c1e43162 711 if $args{optimize} and $targetable{$type_kind{$ret_type}};
34fa6cb6 712 }
1efd22b7 713
34fa6cb6
JK
714 if (@fake_INPUT or @fake_INPUT_pre) {
715 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
716 $_ = "";
717 $processing_arg_with_types = 1;
718 INPUT_handler();
719 }
720 print $deferred;
1efd22b7 721
7c3505a2 722 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
1efd22b7 723
34fa6cb6
JK
724 if (check_keyword("PPCODE")) {
725 print_section();
726 death ("PPCODE must be last thing") if @line;
727 print "\tLEAVE;\n" if $ScopeThisXSUB;
728 print "\tPUTBACK;\n\treturn;\n";
1efd22b7 729 }
34fa6cb6
JK
730 elsif (check_keyword("CODE")) {
731 print_section();
732 }
733 elsif (defined($class) and $func_name eq "DESTROY") {
734 print "\n\t";
735 print "delete THIS;\n";
736 }
737 else {
738 print "\n\t";
739 if ($ret_type ne "void") {
740 print "RETVAL = ";
741 $wantRETVAL = 1;
742 }
743 if (defined($static)) {
744 if ($func_name eq 'new') {
745 $func_name = "$class";
746 }
747 else {
748 print "${class}::";
749 }
750 }
751 elsif (defined($class)) {
752 if ($func_name eq 'new') {
753 $func_name .= " $class";
754 }
755 else {
756 print "THIS->";
757 }
758 }
759 $func_name =~ s/^\Q$args{'s'}//
760 if exists $args{'s'};
761 $func_name = 'XSFUNCTION' if $interface;
762 print "$func_name($func_args);\n";
1efd22b7 763 }
1efd22b7
JK
764 }
765
6b09c160 766 # do output variables
1efd22b7
JK
767 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
768 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
6b09c160
YST
769 # $wantRETVAL set if 'RETVAL =' autogenerated
770 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
7c3505a2 771 undef %outargs;
6b09c160 772 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
1efd22b7 773
879afb6d
JK
774# &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
775 generate_output( {
776 type => $var_types{$_},
777 num => $args_match{$_},
778 var => $_,
779 do_setmagic => $DoSetMagic,
780 do_push => undef,
781 } ) for grep $in_out{$_} =~ /OUT$/, keys %in_out;
1efd22b7 782
6b09c160
YST
783 # all OUTPUT done, so now push the return value on the stack
784 if ($gotRETVAL && $RETVAL_code) {
34fa6cb6
JK
785 print "\t$RETVAL_code\n";
786 }
787 elsif ($gotRETVAL || $wantRETVAL) {
c1e43162 788 my $t = $args{optimize} && $targetable{$type_kind{$ret_type}};
fae3e113
JK
789 # Although the '$var' declared in the next line is never explicitly
790 # used within this 'elsif' block, commenting it out leads to
791 # disaster, starting with the first 'eval qq' inside the 'elsif' block
792 # below.
793 # It appears that this is related to the fact that at this point the
794 # value of $t is a reference to an array whose [2] element includes
795 # '$var' as a substring:
796 # <i> <> <(IV)$var>
34fa6cb6
JK
797 my $var = 'RETVAL';
798 my $type = $ret_type;
799
800 # 0: type, 1: with_size, 2: how, 3: how_size
801 if ($t and not $t->[1] and $t->[0] eq 'p') {
802 # PUSHp corresponds to setpvn. Treate setpv directly
803 my $what = eval qq("$t->[2]");
804 warn $@ if $@;
805
806 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
807 $prepush_done = 1;
808 }
809 elsif ($t) {
810 my $what = eval qq("$t->[2]");
811 warn $@ if $@;
812
af4112ab
JK
813 my $tsize = $t->[3];
814 $tsize = '' unless defined $tsize;
815 $tsize = eval qq("$tsize");
34fa6cb6 816 warn $@ if $@;
af4112ab 817 print "\tXSprePUSH; PUSH$t->[0]($what$tsize);\n";
34fa6cb6
JK
818 $prepush_done = 1;
819 }
820 else {
821 # RETVAL almost never needs SvSETMAGIC()
879afb6d
JK
822# &generate_output($ret_type, 0, 'RETVAL', 0);
823 generate_output( {
824 type => $ret_type,
825 num => 0,
826 var => 'RETVAL',
827 do_setmagic => 0,
828 do_push => undef,
829 } );
34fa6cb6 830 }
6b09c160 831 }
1efd22b7 832
6b09c160
YST
833 $xsreturn = 1 if $ret_type ne "void";
834 my $num = $xsreturn;
835 my $c = @outlist;
836 print "\tXSprePUSH;" if $c and not $prepush_done;
837 print "\tEXTEND(SP,$c);\n" if $c;
838 $xsreturn += $c;
879afb6d
JK
839# generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
840 generate_output( {
841 type => $var_types{$_},
842 num => $num++,
843 var => $_,
844 do_setmagic => 0,
845 do_push => 1,
846 } ) for @outlist;
1efd22b7 847
6b09c160 848 # do cleanup
7c3505a2 849 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
1efd22b7 850
6b09c160
YST
851 print Q(<<"EOF") if $ScopeThisXSUB;
852# ]]
853EOF
854 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
855# LEAVE;
856EOF
1efd22b7 857
6b09c160
YST
858 # print function trailer
859 print Q(<<"EOF");
860# ]]
861EOF
c1e43162 862 print Q(<<"EOF") if $args{except};
6b09c160
YST
863# BEGHANDLERS
864# CATCHALL
1efd22b7 865# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
6b09c160
YST
866# ENDHANDLERS
867EOF
868 if (check_keyword("CASE")) {
34fa6cb6
JK
869 blurt ("Error: No `CASE:' at top of function")
870 unless $condnum;
871 $_ = "CASE: $_"; # Restore CASE: label
872 next;
6b09c160
YST
873 }
874 last if $_ eq "$END:";
28892255 875 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
6b09c160 876 }
1efd22b7 877
c1e43162 878 print Q(<<"EOF") if $args{except};
6b09c160 879# if (errbuf[0])
1efd22b7 880# Perl_croak(aTHX_ errbuf);
6b09c160 881EOF
1efd22b7 882
6b09c160
YST
883 if ($xsreturn) {
884 print Q(<<"EOF") unless $PPCODE;
885# XSRETURN($xsreturn);
886EOF
34fa6cb6
JK
887 }
888 else {
6b09c160
YST
889 print Q(<<"EOF") unless $PPCODE;
890# XSRETURN_EMPTY;
891EOF
892 }
893
894 print Q(<<"EOF");
895#]]
896#
897EOF
898
a40ca62b
JK
899 $newXS = "newXS";
900 $proto = "";
1efd22b7 901
6b09c160
YST
902 # Build the prototype string for the xsub
903 if ($ProtoThisXSUB) {
28892255 904 $newXS = "newXSproto_portable";
1efd22b7 905
6b09c160 906 if ($ProtoThisXSUB eq 2) {
34fa6cb6 907 # User has specified empty prototype
6b09c160
YST
908 }
909 elsif ($ProtoThisXSUB eq 1) {
34fa6cb6
JK
910 my $s = ';';
911 if ($min_args < $num_args) {
912 $s = '';
913 $proto_arg[$min_args] .= ";";
914 }
915 push @proto_arg, "$s\@"
916 if $ellipsis;
917
918 $proto = join ("", grep defined, @proto_arg);
6b09c160
YST
919 }
920 else {
34fa6cb6
JK
921 # User has specified a prototype
922 $proto = $ProtoThisXSUB;
6b09c160
YST
923 }
924 $proto = qq{, "$proto"};
925 }
28892255 926
6b09c160
YST
927 if (%XsubAliases) {
928 $XsubAliases{$pname} = 0
34fa6cb6 929 unless defined $XsubAliases{$pname};
534bb3f4 930 while ( my ($xname, $value) = each %XsubAliases) {
34fa6cb6 931 push(@InitFileCode, Q(<<"EOF"));
534bb3f4 932# cv = ${newXS}(\"$xname\", XS_$Full_func_name, file$proto);
7c3505a2 933# XSANY.any_i32 = $value;
6b09c160 934EOF
6b09c160
YST
935 }
936 }
937 elsif (@Attributes) {
938 push(@InitFileCode, Q(<<"EOF"));
28892255 939# cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);
6b09c160
YST
940# apply_attrs_string("$Package", cv, "@Attributes", 0);
941EOF
942 }
943 elsif ($interface) {
534bb3f4
JK
944 while ( my ($yname, $value) = each %Interfaces) {
945 $yname = "$Package\::$yname" unless $yname =~ /::/;
88577d04 946 push(@InitFileCode, Q(<<"EOF"));
534bb3f4 947# cv = ${newXS}(\"$yname\", XS_$Full_func_name, file$proto);
7c3505a2 948# $interface_macro_set(cv,$value);
6b09c160 949EOF
6b09c160
YST
950 }
951 }
387b6f8d
S
952 elsif($newXS eq 'newXS'){ # work around P5NCI's empty newXS macro
953 push(@InitFileCode,
1efd22b7 954 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
387b6f8d 955 }
6b09c160
YST
956 else {
957 push(@InitFileCode,
1efd22b7 958 " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
6b09c160 959 }
9e831c8e 960 } # END 'PARAGRAPH' 'while' loop
6b09c160 961
d710f389 962 if ($Overload) { # make it findable with fetchmethod
6b09c160
YST
963 print Q(<<"EOF");
964#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
965#XS(XS_${Packid}_nil)
966#{
68746769 967# dXSARGS;
6b09c160
YST
968# XSRETURN_EMPTY;
969#}
970#
971EOF
972 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
973 /* Making a sub named "${Package}::()" allows the package */
974 /* to be findable via fetchmethod(), and causes */
975 /* overload::Overloaded("${Package}") to return true. */
28892255 976 (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto);
6b09c160
YST
977MAKE_FETCHMETHOD_WORK
978 }
979
980 # print initialization routine
981
982 print Q(<<"EOF");
983##ifdef __cplusplus
984#extern "C"
985##endif
986EOF
987
988 print Q(<<"EOF");
989#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
990#XS(boot_$Module_cname)
991EOF
992
993 print Q(<<"EOF");
994#[[
97aff369
JH
995##ifdef dVAR
996# dVAR; dXSARGS;
997##else
6b09c160 998# dXSARGS;
97aff369 999##endif
6b09c160
YST
1000EOF
1001
1cb9da9d
DG
1002 #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
1003 #file name argument. If the wrong qualifier is used, it causes breakage with
1004 #C++ compilers and warnings with recent gcc.
6b09c160
YST
1005 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
1006 #so `file' is unused
1007 print Q(<<"EOF") if $Full_func_name;
1cb9da9d 1008##if (PERL_REVISION == 5 && PERL_VERSION < 9)
28892255 1009# char* file = __FILE__;
1cb9da9d 1010##else
f05ddbb8 1011# const char* file = __FILE__;
1cb9da9d 1012##endif
6b09c160
YST
1013EOF
1014
1015 print Q("#\n");
1016
1017 print Q(<<"EOF");
1018# PERL_UNUSED_VAR(cv); /* -W */
1019# PERL_UNUSED_VAR(items); /* -W */
1020EOF
1efd22b7 1021
7c3505a2
JK
1022 print Q(<<"EOF") if $WantVersionChk;
1023# XS_VERSION_BOOTCHECK;
6b09c160
YST
1024#
1025EOF
1026
7c3505a2 1027 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
6b09c160 1028# {
7c3505a2 1029# CV * cv;
6b09c160
YST
1030#
1031EOF
1032
1033 print Q(<<"EOF") if ($Overload);
1034# /* register the overloading (type 'A') magic */
1035# PL_amagic_generation++;
1036# /* The magic for overload gets a GV* via gv_fetchmeth as */
1037# /* mentioned above, and looks in the SV* slot of it for */
1038# /* the "fallback" status. */
1039# sv_setsv(
1040# get_sv( "${Package}::()", TRUE ),
1041# $Fallback
1042# );
1043EOF
1044
1045 print @InitFileCode;
1046
7c3505a2 1047 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
6b09c160
YST
1048# }
1049EOF
1050
505ef4a5 1051 if (@BootCode) {
7c3505a2 1052 print "\n /* Initialisation Section */\n\n";
6b09c160
YST
1053 @line = @BootCode;
1054 print_section();
7c3505a2 1055 print "\n /* End of Initialisation Section */\n\n";
6b09c160
YST
1056 }
1057
1cb9da9d
DG
1058 print Q(<<'EOF');
1059##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
1060# if (PL_unitcheckav)
1061# call_list(PL_scopestack_ix, PL_unitcheckav);
1062##endif
0932863f 1063EOF
89345840 1064
6b09c160
YST
1065 print Q(<<"EOF");
1066# XSRETURN_YES;
1067#]]
1068#
1069EOF
1070
1071 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
7c3505a2 1072 unless $ProtoUsed;
6b09c160
YST
1073
1074 chdir($orig_cwd);
1075 select($orig_fh);
1076 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
907ce46c 1077 close $FH;
6b09c160
YST
1078
1079 return 1;
1080}
1081
1082sub errors { $errors }
1083
6b09c160
YST
1084# Input: ($_, @line) == unparsed input.
1085# Output: ($_, @line) == (rest of line, following lines).
1086# Return: the matched keyword if found, otherwise 0
1087sub check_keyword {
505ef4a5
JK
1088 $_ = shift(@line) while !/\S/ && @line;
1089 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
6b09c160
YST
1090}
1091
1092sub print_section {
505ef4a5
JK
1093 # the "do" is required for right semantics
1094 do { $_ = shift(@line) } while !/\S/ && @line;
6b09c160 1095
505ef4a5 1096 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1efd22b7 1097 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
505ef4a5 1098 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1efd22b7 1099 print "$_\n";
505ef4a5
JK
1100 }
1101 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
6b09c160
YST
1102}
1103
1104sub merge_section {
505ef4a5 1105 my $in = '';
6b09c160 1106
505ef4a5
JK
1107 while (!/\S/ && @line) {
1108 $_ = shift(@line);
1109 }
6b09c160 1110
505ef4a5
JK
1111 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1112 $in .= "$_\n";
6b09c160 1113 }
505ef4a5
JK
1114 chomp $in;
1115 return $in;
1116}
6b09c160 1117
505ef4a5
JK
1118sub process_keyword($) {
1119 my($pattern) = @_;
1120 my $kwd;
6b09c160 1121
d710f389 1122 no strict 'refs';
505ef4a5
JK
1123 &{"${kwd}_handler"}()
1124 while $kwd = check_keyword($pattern);
d710f389 1125 use strict 'refs';
505ef4a5 1126}
6b09c160
YST
1127
1128sub CASE_handler {
1129 blurt ("Error: `CASE:' after unconditional `CASE:'")
1130 if $condnum && $cond eq '';
1131 $cond = $_;
1d40e528 1132 trim_whitespace($cond);
6b09c160 1133 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
7c3505a2 1134 $_ = '';
6b09c160
YST
1135}
1136
1137sub INPUT_handler {
1138 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1139 last if /^\s*NOT_IMPLEMENTED_YET/;
1efd22b7 1140 next unless /\S/; # skip blank lines
6b09c160 1141
1d40e528 1142 trim_whitespace($_);
9e831c8e 1143 my $ln = $_;
6b09c160
YST
1144
1145 # remove trailing semicolon if no initialisation
7c3505a2 1146 s/\s*;$//g unless /[=;+].*\S/;
6b09c160
YST
1147
1148 # Process the length(foo) declarations
1149 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1150 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
be5bcef7 1151 $lengthof{$2} = undef;
1cb9da9d 1152 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
6b09c160
YST
1153 }
1154
1155 # check for optional initialisation code
7c3505a2
JK
1156 my $var_init = '';
1157 $var_init = $1 if s/\s*([=;+].*)$//s;
6b09c160
YST
1158 $var_init =~ s/"/\\"/g;
1159
1160 s/\s+/ /g;
1161 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
9e831c8e 1162 or blurt("Error: invalid argument declaration '$ln'"), next;
6b09c160
YST
1163
1164 # Check for duplicate definitions
1165 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1166 if $arg_list{$var_name}++
1efd22b7 1167 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
6b09c160
YST
1168
1169 $thisdone |= $var_name eq "THIS";
1170 $retvaldone |= $var_name eq "RETVAL";
1171 $var_types{$var_name} = $var_type;
1172 # XXXX This check is a safeguard against the unfinished conversion of
1173 # generate_init(). When generate_init() is fixed,
1174 # one can use 2-args map_type() unconditionally.
1175 if ($var_type =~ / \( \s* \* \s* \) /x) {
1176 # Function pointers are not yet supported with &output_init!
0ec7450c 1177 print "\t" . &map_type($var_type, $var_name, $hiertype);
68f166a7 1178 $printed_name = 1;
505ef4a5
JK
1179 }
1180 else {
0ec7450c 1181 print "\t" . &map_type($var_type, undef, $hiertype);
68f166a7 1182 $printed_name = 0;
6b09c160
YST
1183 }
1184 $var_num = $args_match{$var_name};
1185
1186 $proto_arg[$var_num] = ProtoString($var_type)
7c3505a2 1187 if $var_num;
6b09c160
YST
1188 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1189 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
505ef4a5
JK
1190 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1191 and $var_init !~ /\S/) {
68f166a7 1192 if ($printed_name) {
505ef4a5 1193 print ";\n";
6b09c160 1194 }
505ef4a5
JK
1195 else {
1196 print "\t$var_name;\n";
1197 }
1198 }
1199 elsif ($var_init =~ /\S/) {
68f166a7 1200 &output_init($var_type, $var_num, $var_name, $var_init, $printed_name);
505ef4a5
JK
1201 }
1202 elsif ($var_num) {
6b09c160 1203 # generate initialization code
879afb6d
JK
1204# &generate_init($var_type, $var_num, $var_name, $printed_name);
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($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1245 generate_output( {
1246 type => $var_types{$outarg},
1247 num => $var_num,
1248 var => $outarg,
1249 do_setmagic => $DoSetMagic,
1250 do_push => undef,
1251 } );
6b09c160 1252 }
1efd22b7 1253 delete $in_out{$outarg} # No need to auto-OUTPUT
6b09c160
YST
1254 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1255 }
1256}
1257
1258sub C_ARGS_handler() {
1259 my $in = merge_section();
1260
1d40e528 1261 trim_whitespace($in);
6b09c160
YST
1262 $func_args = $in;
1263}
1264
1265sub INTERFACE_MACRO_handler() {
1266 my $in = merge_section();
1267
1d40e528 1268 trim_whitespace($in);
1efd22b7 1269 if ($in =~ /\s/) { # two
6b09c160 1270 ($interface_macro, $interface_macro_set) = split ' ', $in;
505ef4a5
JK
1271 }
1272 else {
6b09c160
YST
1273 $interface_macro = $in;
1274 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1275 }
1efd22b7
JK
1276 $interface = 1; # local
1277 $Interfaces = 1; # global
6b09c160
YST
1278}
1279
1280sub INTERFACE_handler() {
1281 my $in = merge_section();
1282
1d40e528 1283 trim_whitespace($in);
6b09c160
YST
1284
1285 foreach (split /[\s,]+/, $in) {
88577d04
JK
1286 my $iface_name = $_;
1287 $iface_name =~ s/^$Prefix//;
1288 $Interfaces{$iface_name} = $_;
6b09c160
YST
1289 }
1290 print Q(<<"EOF");
1efd22b7 1291# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
6b09c160 1292EOF
1efd22b7
JK
1293 $interface = 1; # local
1294 $Interfaces = 1; # global
6b09c160
YST
1295}
1296
1297sub CLEANUP_handler() { print_section() }
1298sub PREINIT_handler() { print_section() }
1299sub POSTCALL_handler() { print_section() }
1300sub INIT_handler() { print_section() }
1301
505ef4a5
JK
1302sub GetAliases {
1303 my ($line) = @_;
1304 my ($orig) = $line;
6b09c160 1305
505ef4a5
JK
1306 # Parse alias definitions
1307 # format is
1308 # alias = value alias = value ...
6b09c160 1309
505ef4a5 1310 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
9e831c8e
JK
1311 my ($alias, $value) = ($1, $2);
1312 my $orig_alias = $alias;
6b09c160 1313
505ef4a5
JK
1314 # check for optional package definition in the alias
1315 $alias = $Packprefix . $alias if $alias !~ /::/;
6b09c160 1316
505ef4a5
JK
1317 # check for duplicate alias name & duplicate value
1318 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1319 if defined $XsubAliases{$alias};
6b09c160 1320
505ef4a5
JK
1321 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1322 if $XsubAliasValues{$value};
6b09c160 1323
505ef4a5
JK
1324 $XsubAliases = 1;
1325 $XsubAliases{$alias} = $value;
1326 $XsubAliasValues{$value} = $orig_alias;
6b09c160
YST
1327 }
1328
505ef4a5
JK
1329 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1330 if $line;
1331}
1332
1333sub ATTRS_handler () {
1334 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1335 next unless /\S/;
1d40e528 1336 trim_whitespace($_);
505ef4a5 1337 push @Attributes, $_;
6b09c160 1338 }
505ef4a5 1339}
6b09c160 1340
505ef4a5
JK
1341sub ALIAS_handler () {
1342 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1343 next unless /\S/;
1d40e528 1344 trim_whitespace($_);
505ef4a5 1345 GetAliases($_) if $_;
6b09c160 1346 }
505ef4a5 1347}
6b09c160 1348
505ef4a5 1349sub OVERLOAD_handler() {
6b09c160
YST
1350 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1351 next unless /\S/;
1d40e528 1352 trim_whitespace($_);
6b09c160
YST
1353 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1354 $Overload = 1 unless $Overload;
7c3505a2 1355 my $overload = "$Package\::(".$1;
6b09c160 1356 push(@InitFileCode,
1efd22b7 1357 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
6b09c160 1358 }
1efd22b7 1359 }
6b09c160
YST
1360}
1361
505ef4a5 1362sub FALLBACK_handler() {
1efd22b7 1363 # the rest of the current line should contain either TRUE,
6b09c160 1364 # FALSE or UNDEF
1efd22b7 1365
1d40e528 1366 trim_whitespace($_);
6b09c160 1367 my %map = (
505ef4a5
JK
1368 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1369 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1370 UNDEF => "&PL_sv_undef",
1371 );
1efd22b7 1372
6b09c160 1373 # check for valid FALLBACK value
7c3505a2 1374 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
1efd22b7 1375
7c3505a2 1376 $Fallback = $map{uc $_};
6b09c160
YST
1377}
1378
1379
505ef4a5
JK
1380sub REQUIRE_handler () {
1381 # the rest of the current line should contain a version number
1382 my ($Ver) = $_;
6b09c160 1383
1d40e528 1384 trim_whitespace($Ver);
6b09c160 1385
505ef4a5
JK
1386 death ("Error: REQUIRE expects a version number")
1387 unless $Ver;
6b09c160 1388
505ef4a5
JK
1389 # check that the version number is of the form n.n
1390 death ("Error: REQUIRE: expected a number, got '$Ver'")
1391 unless $Ver =~ /^\d+(\.\d*)?/;
6b09c160 1392
505ef4a5
JK
1393 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1394 unless $VERSION >= $Ver;
1395}
6b09c160 1396
505ef4a5
JK
1397sub VERSIONCHECK_handler () {
1398 # the rest of the current line should contain either ENABLE or
1399 # DISABLE
6b09c160 1400
1d40e528 1401 trim_whitespace($_);
6b09c160 1402
505ef4a5
JK
1403 # check for ENABLE/DISABLE
1404 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1405 unless /^(ENABLE|DISABLE)/i;
6b09c160 1406
505ef4a5
JK
1407 $WantVersionChk = 1 if $1 eq 'ENABLE';
1408 $WantVersionChk = 0 if $1 eq 'DISABLE';
6b09c160 1409
505ef4a5 1410}
6b09c160 1411
505ef4a5
JK
1412sub PROTOTYPE_handler () {
1413 my $specified;
6b09c160 1414
505ef4a5 1415 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
9e831c8e 1416 if $proto_in_this_xsub++;
6b09c160 1417
505ef4a5
JK
1418 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1419 next unless /\S/;
1420 $specified = 1;
1d40e528 1421 trim_whitespace($_);
505ef4a5
JK
1422 if ($_ eq 'DISABLE') {
1423 $ProtoThisXSUB = 0;
1424 }
1425 elsif ($_ eq 'ENABLE') {
1426 $ProtoThisXSUB = 1;
1427 }
1428 else {
1429 # remove any whitespace
1430 s/\s+//g;
1431 death("Error: Invalid prototype '$_'")
547742ac 1432 unless valid_proto_string($_);
505ef4a5
JK
1433 $ProtoThisXSUB = C_string($_);
1434 }
6b09c160
YST
1435 }
1436
505ef4a5
JK
1437 # If no prototype specified, then assume empty prototype ""
1438 $ProtoThisXSUB = 2 unless $specified;
6b09c160 1439
505ef4a5
JK
1440 $ProtoUsed = 1;
1441}
6b09c160 1442
505ef4a5
JK
1443sub SCOPE_handler () {
1444 death("Error: Only 1 SCOPE declaration allowed per xsub")
9e831c8e 1445 if $scope_in_this_xsub++;
6b09c160 1446
1d40e528 1447 trim_whitespace($_);
505ef4a5
JK
1448 death ("Error: SCOPE: ENABLE/DISABLE")
1449 unless /^(ENABLE|DISABLE)\b/i;
1450 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
1451}
6b09c160 1452
505ef4a5
JK
1453sub PROTOTYPES_handler () {
1454 # the rest of the current line should contain either ENABLE or
1455 # DISABLE
6b09c160 1456
1d40e528 1457 trim_whitespace($_);
6b09c160 1458
505ef4a5
JK
1459 # check for ENABLE/DISABLE
1460 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1461 unless /^(ENABLE|DISABLE)/i;
6b09c160 1462
505ef4a5
JK
1463 $WantPrototypes = 1 if $1 eq 'ENABLE';
1464 $WantPrototypes = 0 if $1 eq 'DISABLE';
1465 $ProtoUsed = 1;
1466}
387b6f8d 1467
505ef4a5 1468sub PushXSStack {
f0744969 1469 my %args = @_;
505ef4a5
JK
1470 # Save the current file context.
1471 push(@XSStack, {
1472 type => 'file',
1473 LastLine => $lastline,
1474 LastLineNo => $lastline_no,
1475 Line => \@line,
1476 LineNo => \@line_no,
1477 Filename => $filename,
1478 Filepathname => $filepathname,
1479 Handle => $FH,
1480 IsPipe => scalar($filename =~ /\|\s*$/),
1481 %args,
1482 });
387b6f8d 1483
505ef4a5 1484}
6b09c160 1485
505ef4a5
JK
1486sub INCLUDE_handler () {
1487 # the rest of the current line should contain a valid filename
6b09c160 1488
1d40e528 1489 trim_whitespace($_);
6b09c160 1490
505ef4a5
JK
1491 death("INCLUDE: filename missing")
1492 unless $_;
6b09c160 1493
505ef4a5
JK
1494 death("INCLUDE: output pipe is illegal")
1495 if /^\s*\|/;
6b09c160 1496
505ef4a5
JK
1497 # simple minded recursion detector
1498 death("INCLUDE loop detected")
1499 if $IncludedFiles{$_};
6b09c160 1500
9e831c8e 1501 ++$IncludedFiles{$_} unless /\|\s*$/;
505ef4a5
JK
1502
1503 if (/\|\s*$/ && /^\s*perl\s/) {
1504 Warn("The INCLUDE directive with a command is discouraged." .
1505 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1506 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1507 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1508 " the use of \$^X as the currently running perl, see" .
1509 " 'perldoc perlxs' for details.");
1510 }
387b6f8d 1511
505ef4a5 1512 PushXSStack();
6b09c160 1513
505ef4a5 1514 $FH = Symbol::gensym();
6b09c160 1515
505ef4a5
JK
1516 # open the new file
1517 open ($FH, "$_") or death("Cannot open '$_': $!");
6b09c160 1518
505ef4a5 1519 print Q(<<"EOF");
6b09c160
YST
1520#
1521#/* INCLUDE: Including '$_' from '$filename' */
1522#
1523EOF
1524
505ef4a5
JK
1525 $filename = $_;
1526 $filepathname = File::Spec->catfile($dir, $filename);
6b09c160 1527
505ef4a5
JK
1528 # Prime the pump by reading the first
1529 # non-blank line
6b09c160 1530
505ef4a5
JK
1531 # skip leading blank lines
1532 while (<$FH>) {
1533 last unless /^\s*$/;
387b6f8d
S
1534 }
1535
505ef4a5
JK
1536 $lastline = $_;
1537 $lastline_no = $.;
1538}
1539
494e8c4c 1540sub QuoteArgs {
505ef4a5
JK
1541 my $cmd = shift;
1542 my @args = split /\s+/, $cmd;
1543 $cmd = shift @args;
1544 for (@args) {
1545 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
494e8c4c 1546 }
505ef4a5
JK
1547 return join (' ', ($cmd, @args));
1548}
494e8c4c 1549
505ef4a5
JK
1550sub INCLUDE_COMMAND_handler () {
1551 # the rest of the current line should contain a valid command
387b6f8d 1552
1d40e528 1553 trim_whitespace($_);
387b6f8d 1554
505ef4a5 1555 $_ = QuoteArgs($_) if $^O eq 'VMS';
494e8c4c 1556
505ef4a5
JK
1557 death("INCLUDE_COMMAND: command missing")
1558 unless $_;
387b6f8d 1559
505ef4a5
JK
1560 death("INCLUDE_COMMAND: pipes are illegal")
1561 if /^\s*\|/ or /\|\s*$/;
387b6f8d 1562
505ef4a5 1563 PushXSStack( IsPipe => 1 );
387b6f8d 1564
505ef4a5 1565 $FH = Symbol::gensym();
387b6f8d 1566
505ef4a5
JK
1567 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1568 # the same perl interpreter as we're currently running
1569 s/^\s*\$\^X/$^X/;
387b6f8d 1570
505ef4a5
JK
1571 # open the new file
1572 open ($FH, "-|", "$_")
1573 or death("Cannot run command '$_' to include its output: $!");
387b6f8d 1574
505ef4a5 1575 print Q(<<"EOF");
387b6f8d
S
1576#
1577#/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */
1578#
1579EOF
1580
505ef4a5
JK
1581 $filename = $_;
1582 $filepathname = $filename;
1583 $filepathname =~ s/\"/\\"/g;
387b6f8d 1584
505ef4a5
JK
1585 # Prime the pump by reading the first
1586 # non-blank line
6b09c160 1587
505ef4a5
JK
1588 # skip leading blank lines
1589 while (<$FH>) {
1590 last unless /^\s*$/;
6b09c160
YST
1591 }
1592
505ef4a5
JK
1593 $lastline = $_;
1594 $lastline_no = $.;
1595}
6b09c160 1596
505ef4a5
JK
1597sub PopFile() {
1598 return 0 unless $XSStack[-1]{type} eq 'file';
6b09c160 1599
505ef4a5
JK
1600 my $data = pop @XSStack;
1601 my $ThisFile = $filename;
1602 my $isPipe = $data->{IsPipe};
6b09c160 1603
9e831c8e 1604 --$IncludedFiles{$filename}
505ef4a5 1605 unless $isPipe;
6b09c160 1606
505ef4a5 1607 close $FH;
6b09c160 1608
505ef4a5
JK
1609 $FH = $data->{Handle};
1610 # $filename is the leafname, which for some reason isused for diagnostic
1611 # messages, whereas $filepathname is the full pathname, and is used for
1612 # #line directives.
1613 $filename = $data->{Filename};
1614 $filepathname = $data->{Filepathname};
1615 $lastline = $data->{LastLine};
1616 $lastline_no = $data->{LastLineNo};
1617 @line = @{ $data->{Line} };
1618 @line_no = @{ $data->{LineNo} };
1619
1620 if ($isPipe and $? ) {
9e831c8e 1621 --$lastline_no;
505ef4a5
JK
1622 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1623 exit 1;
1624 }
6b09c160 1625
505ef4a5 1626 print Q(<<"EOF");
6b09c160
YST
1627#
1628#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1629#
1630EOF
1631
505ef4a5
JK
1632 return 1;
1633}
6b09c160 1634
505ef4a5
JK
1635sub ProtoString ($) {
1636 my ($type) = @_;
1637
1638 $proto_letter{$type} or "\$";
1639}
6b09c160
YST
1640
1641sub check_cpp {
1642 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1643 if (@cpp) {
1644 my ($cpp, $cpplevel);
1645 for $cpp (@cpp) {
1646 if ($cpp =~ /^\#\s*if/) {
505ef4a5
JK
1647 $cpplevel++;
1648 }
1649 elsif (!$cpplevel) {
1650 Warn("Warning: #else/elif/endif without #if in this function");
1651 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1652 if $XSStack[-1]{type} eq 'if';
1653 return;
1654 }
1655 elsif ($cpp =~ /^\#\s*endif/) {
1656 $cpplevel--;
6b09c160
YST
1657 }
1658 }
1659 Warn("Warning: #if without #endif in this function") if $cpplevel;
1660 }
1661}
1662
1663
1664sub Q {
1665 my($text) = @_;
1666 $text =~ s/^#//gm;
1667 $text =~ s/\[\[/{/g;
1668 $text =~ s/\]\]/}/g;
1669 $text;
1670}
1671
1672# Read next xsub into @line from ($lastline, <$FH>).
1673sub fetch_para {
1674 # parse paragraph
1675 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1676 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1677 @line = ();
7c3505a2 1678 @line_no = ();
6b09c160
YST
1679 return PopFile() if !defined $lastline;
1680
1681 if ($lastline =~
1682 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
be5bcef7 1683 my $Module = $1;
6b09c160
YST
1684 $Package = defined($2) ? $2 : ''; # keep -w happy
1685 $Prefix = defined($3) ? $3 : ''; # keep -w happy
7c3505a2 1686 $Prefix = quotemeta $Prefix;
6b09c160
YST
1687 ($Module_cname = $Module) =~ s/\W/_/g;
1688 ($Packid = $Package) =~ tr/:/_/;
1689 $Packprefix = $Package;
1690 $Packprefix .= "::" if $Packprefix ne "";
1691 $lastline = "";
1692 }
1693
1694 for (;;) {
1695 # Skip embedded PODs
1696 while ($lastline =~ /^=/) {
1697 while ($lastline = <$FH>) {
505ef4a5 1698 last if ($lastline =~ /^=cut\s*$/);
6b09c160
YST
1699 }
1700 death ("Error: Unterminated pod") unless $lastline;
1701 $lastline = <$FH>;
1702 chomp $lastline;
1703 $lastline =~ s/^\s+$//;
1704 }
1705 if ($lastline !~ /^\s*#/ ||
1efd22b7
JK
1706 # CPP directives:
1707 # ANSI: if ifdef ifndef elif else endif define undef
1708 # line error pragma
1709 # gcc: warning include_next
1710 # obj-c: import
1711 # others: ident (gcc notes that some cpps have this one)
1712 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
6b09c160
YST
1713 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1714 push(@line, $lastline);
7c3505a2 1715 push(@line_no, $lastline_no);
6b09c160
YST
1716 }
1717
1718 # Read next line and continuation lines
1719 last unless defined($lastline = <$FH>);
1720 $lastline_no = $.;
1721 my $tmp_line;
1722 $lastline .= $tmp_line
1723 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1724
1725 chomp $lastline;
1726 $lastline =~ s/^\s+$//;
1727 }
1728 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1729 1;
1730}
1731
1732sub output_init {
f0744969
JK
1733 my ($type, $num, $var, $init, $printed_name) = @_;
1734 my $arg = "ST(" . ($num - 1) . ")";
6b09c160
YST
1735
1736 if ( $init =~ /^=/ ) {
68f166a7 1737 if ($printed_name) {
6b09c160 1738 eval qq/print " $init\\n"/;
505ef4a5
JK
1739 }
1740 else {
6b09c160
YST
1741 eval qq/print "\\t$var $init\\n"/;
1742 }
9e831c8e 1743 warn $@ if $@;
505ef4a5
JK
1744 }
1745 else {
6b09c160 1746 if ( $init =~ s/^\+// && $num ) {
879afb6d
JK
1747# &generate_init($type, $num, $var, $printed_name);
1748 generate_init( {
1749 type => $type,
1750 num => $num,
1751 var => $var,
1752 printed_name => $printed_name,
1753 } );
505ef4a5 1754 }
68f166a7 1755 elsif ($printed_name) {
6b09c160
YST
1756 print ";\n";
1757 $init =~ s/^;//;
505ef4a5
JK
1758 }
1759 else {
6b09c160 1760 eval qq/print "\\t$var;\\n"/;
9e831c8e 1761 warn $@ if $@;
6b09c160
YST
1762 $init =~ s/^;//;
1763 }
1764 $deferred .= eval qq/"\\n\\t$init\\n"/;
505ef4a5 1765 warn $@ if $@;
6b09c160
YST
1766 }
1767}
1768
505ef4a5
JK
1769sub Warn {
1770 # work out the line number
eb26ba82 1771 my $warn_line_number = $line_no[@line_no - @line -1];
6b09c160 1772
eb26ba82 1773 print STDERR "@_ in $filename, line $warn_line_number\n";
505ef4a5 1774}
6b09c160 1775
505ef4a5
JK
1776sub blurt {
1777 Warn @_;
9e831c8e 1778 $errors++
505ef4a5 1779}
6b09c160 1780
505ef4a5
JK
1781sub death {
1782 Warn @_;
1783 exit 1;
1784}
6b09c160
YST
1785
1786sub generate_init {
879afb6d
JK
1787# my ($type, $num, $var, $printed_name) = @_;
1788 my $argsref = shift;
1789 my ($type, $num, $var, $printed_name) = (
1790 $argsref->{type},
1791 $argsref->{num},
1792 $argsref->{var},
1793 $argsref->{printed_name},
1794 );
be5bcef7 1795 my $arg = "ST(" . ($num - 1) . ")";
be5bcef7
JK
1796 my ($argoff, $ntype, $tk);
1797 $argoff = $num - 1;
6b09c160 1798
73e91d5a 1799 $type = tidy_type($type);
6b09c160
YST
1800 blurt("Error: '$type' not in typemap"), return
1801 unless defined($type_kind{$type});
1802
1803 ($ntype = $type) =~ s/\s*\*/Ptr/g;
be5bcef7 1804 my $subtype;
6b09c160
YST
1805 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1806 $tk = $type_kind{$type};
1807 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1808 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
68f166a7 1809 print "\t$var" unless $printed_name;
6b09c160
YST
1810 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1811 die "default value not supported with length(NAME) supplied"
1812 if defined $defaults{$var};
1813 return;
1814 }
1815 $type =~ tr/:/_/ unless $hiertype;
1816 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
7c3505a2 1817 unless defined $input_expr{$tk};
be5bcef7 1818 my $expr = $input_expr{$tk};
6b09c160
YST
1819 if ($expr =~ /DO_ARRAY_ELEM/) {
1820 blurt("Error: '$subtype' not in typemap"), return
1821 unless defined($type_kind{$subtype});
1822 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
7c3505a2 1823 unless defined $input_expr{$type_kind{$subtype}};
be5bcef7 1824 my $subexpr = $input_expr{$type_kind{$subtype}};
6b09c160
YST
1825 $subexpr =~ s/\$type/\$subtype/g;
1826 $subexpr =~ s/ntype/subtype/g;
1827 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1828 $subexpr =~ s/\n\t/\n\t\t/g;
1829 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1830 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1831 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1832 }
1833 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1834 $ScopeThisXSUB = 1;
1835 }
1836 if (defined($defaults{$var})) {
1837 $expr =~ s/(\t+)/$1 /g;
1838 $expr =~ s/ /\t/g;
68f166a7 1839 if ($printed_name) {
6b09c160 1840 print ";\n";
505ef4a5
JK
1841 }
1842 else {
6b09c160 1843 eval qq/print "\\t$var;\\n"/;
0bba9eb1 1844 warn $@ if $@;
6b09c160
YST
1845 }
1846 if ($defaults{$var} eq 'NO_INIT') {
1847 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
505ef4a5
JK
1848 }
1849 else {
6b09c160
YST
1850 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1851 }
0bba9eb1 1852 warn $@ if $@;
505ef4a5
JK
1853 }
1854 elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
68f166a7 1855 if ($printed_name) {
6b09c160 1856 print ";\n";
505ef4a5
JK
1857 }
1858 else {
6b09c160 1859 eval qq/print "\\t$var;\\n"/;
0bba9eb1 1860 warn $@ if $@;
6b09c160
YST
1861 }
1862 $deferred .= eval qq/"\\n$expr;\\n"/;
0bba9eb1 1863 warn $@ if $@;
505ef4a5
JK
1864 }
1865 else {
6b09c160 1866 die "panic: do not know how to handle this branch for function pointers"
68f166a7 1867 if $printed_name;
6b09c160 1868 eval qq/print "$expr;\\n"/;
0bba9eb1 1869 warn $@ if $@;
6b09c160
YST
1870 }
1871}
1872
1873sub generate_output {
879afb6d
JK
1874# my ($type, $num, $var, $do_setmagic, $do_push) = @_;
1875 my $argsref = shift;
1876 my ($type, $num, $var, $do_setmagic, $do_push) = (
1877 $argsref->{type},
1878 $argsref->{num},
1879 $argsref->{var},
1880 $argsref->{do_setmagic},
1881 $argsref->{do_push}
1882 );
be5bcef7 1883 my $arg = "ST(" . ($num - ($num != 0)) . ")";
be5bcef7 1884 my $ntype;
6b09c160 1885
73e91d5a 1886 $type = tidy_type($type);
6b09c160
YST
1887 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1888 print "\t$arg = sv_newmortal();\n";
1889 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1890 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
505ef4a5
JK
1891 }
1892 else {
6b09c160
YST
1893 blurt("Error: '$type' not in typemap"), return
1894 unless defined($type_kind{$type});
1895 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
7c3505a2 1896 unless defined $output_expr{$type_kind{$type}};
6b09c160
YST
1897 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1898 $ntype =~ s/\(\)//g;
be5bcef7 1899 my $subtype;
6b09c160 1900 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
be5bcef7 1901 my $expr = $output_expr{$type_kind{$type}};
6b09c160
YST
1902 if ($expr =~ /DO_ARRAY_ELEM/) {
1903 blurt("Error: '$subtype' not in typemap"), return
1efd22b7 1904 unless defined($type_kind{$subtype});
6b09c160 1905 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
7c3505a2 1906 unless defined $output_expr{$type_kind{$subtype}};
be5bcef7 1907 my $subexpr = $output_expr{$type_kind{$subtype}};
6b09c160
YST
1908 $subexpr =~ s/ntype/subtype/g;
1909 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1910 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1911 $subexpr =~ s/\n\t/\n\t\t/g;
1912 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1913 eval "print qq\a$expr\a";
0bba9eb1 1914 warn $@ if $@;
6b09c160 1915 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
505ef4a5
JK
1916 }
1917 elsif ($var eq 'RETVAL') {
6b09c160 1918 if ($expr =~ /^\t\$arg = new/) {
505ef4a5
JK
1919 # We expect that $arg has refcnt 1, so we need to
1920 # mortalize it.
1921 eval "print qq\a$expr\a";
0bba9eb1 1922 warn $@ if $@;
505ef4a5
JK
1923 print "\tsv_2mortal(ST($num));\n";
1924 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1925 }
1926 elsif ($expr =~ /^\s*\$arg\s*=/) {
1927 # We expect that $arg has refcnt >=1, so we need
1928 # to mortalize it!
1929 eval "print qq\a$expr\a";
0bba9eb1 1930 warn $@ if $@;
505ef4a5
JK
1931 print "\tsv_2mortal(ST(0));\n";
1932 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
6b09c160 1933 }
505ef4a5
JK
1934 else {
1935 # Just hope that the entry would safely write it
1936 # over an already mortalized value. By
1937 # coincidence, something like $arg = &sv_undef
1938 # works too.
1939 print "\tST(0) = sv_newmortal();\n";
1940 eval "print qq\a$expr\a";
0bba9eb1 1941 warn $@ if $@;
505ef4a5
JK
1942 # new mortals don't have set magic
1943 }
1944 }
1945 elsif ($do_push) {
6b09c160
YST
1946 print "\tPUSHs(sv_newmortal());\n";
1947 $arg = "ST($num)";
1948 eval "print qq\a$expr\a";
0bba9eb1 1949 warn $@ if $@;
6b09c160 1950 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
505ef4a5
JK
1951 }
1952 elsif ($arg =~ /^ST\(\d+\)$/) {
6b09c160 1953 eval "print qq\a$expr\a";
0bba9eb1 1954 warn $@ if $@;
6b09c160
YST
1955 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1956 }
1957 }
1958}
1959
6b09c160 19601;