This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move $deferred into $self.
[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 32our (
ecafe0ca
JK
33 # The scalars in the line below remain as 'our' variables because pulling
34 # them into $self led to build problems. In most cases, strings being
35 # 'eval'-ed contain the variables' names hard-coded.
36 $FH, $Package, $func_name, $Full_func_name, $Packid, $pname,
37 @InitFileCode,
c2d2fdd0 38 %IncludedFiles, %input_expr, %output_expr,
ecafe0ca 39 %type_kind, %proto_letter,
cdfe2888
JK
40 @line, %args_match, %defaults, %var_types, %arg_list, @proto_arg,
41 %argtype_seen, %in_out, %lengthof,
ecafe0ca
JK
42 @line_no,
43 %XsubAliases, %XsubAliasValues, %Interfaces, @Attributes, %outargs,
706e7216 44 $gotRETVAL, $condnum, $cond,
d67360fa 45 $RETVAL_code, $func_args, @XSStack, $ALIAS,
a1c5c71f 46);
be5bcef7 47our ($DoSetMagic, $newXS, $proto, $Module_cname, $XsubAliases, $Interfaces, $var_num, );
6b09c160 48
551f599a
JK
49our $self = {};
50
6b09c160 51sub process_file {
1efd22b7 52
6b09c160 53 # Allow for $package->process_file(%hash) in the future
c1e43162 54 my ($pkg, %options) = @_ % 2 ? @_ : (__PACKAGE__, @_);
1efd22b7 55
551f599a 56 $self->{ProtoUsed} = exists $options{prototypes};
1efd22b7 57
6b09c160 58 # Set defaults.
c1e43162 59 my %args = (
37ddf986
JK
60 argtypes => 1,
61 csuffix => '.c',
62 except => 0,
63 hiertype => 0,
64 inout => 1,
65 linenumbers => 1,
66 optimize => 1,
67 output => \*STDOUT,
68 prototypes => 0,
69 typemap => [],
70 versioncheck => 1,
c1e43162 71 %options,
34fa6cb6 72 );
c1e43162 73 $args{except} = $args{except} ? ' TRY' : '';
6b09c160
YST
74
75 # Global Constants
1efd22b7 76
6b09c160
YST
77 my ($Is_VMS, $SymSet);
78 if ($^O eq 'VMS') {
79 $Is_VMS = 1;
80 # Establish set of global symbols with max length 28, since xsubpp
81 # will later add the 'XS_' prefix.
82 require ExtUtils::XSSymSet;
83 $SymSet = new ExtUtils::XSSymSet 28;
84 }
85 @XSStack = ({type => 'none'});
547742ac
JK
86 my $XSS_work_idx = 0;
87 my $cpp_next_tmp = 'XSubPPtmpAAAA';
88 @InitFileCode = @ExtUtils::ParseXS::Constants::InitFileCode;
89 $FH = $ExtUtils::ParseXS::Constants::FH;
c2d2fdd0
JK
90 $self->{Overload} = $ExtUtils::ParseXS::Constants::Overload;
91 $self->{errors} = $ExtUtils::ParseXS::Constants::errors;
92 $self->{Fallback} = $ExtUtils::ParseXS::Constants::Fallback;
6b09c160
YST
93
94 # Most of the 1500 lines below uses these globals. We'll have to
95 # clean this up sometime, probably. For now, we just pull them out
96 # of %args. -Ken
1efd22b7 97
c2d2fdd0
JK
98 $self->{hiertype} = $args{hiertype};
99 $self->{WantPrototypes} = $args{prototypes};
100 $self->{WantVersionChk} = $args{versioncheck};
101 $self->{WantLineNumbers} = $args{linenumbers};
1efd22b7 102
c1e43162
JK
103 for my $f ($args{filename}) {
104 die "Missing required parameter 'filename'" unless $f;
c2d2fdd0
JK
105 $self->{filepathname} = $f;
106 ($self->{dir}, $self->{filename}) = (dirname($f), basename($f));
107 $self->{filepathname} =~ s/\\/\\\\/g;
c1e43162 108 $IncludedFiles{$f}++;
6b09c160 109 }
1efd22b7 110
6b09c160
YST
111 # Open the output file if given as a string. If they provide some
112 # other kind of reference, trust them that we can print to it.
113 if (not ref $args{output}) {
114 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
115 $args{outfile} = $args{output};
116 $args{output} = $fh;
117 }
118
119 # Really, we shouldn't have to chdir() or select() in the first
120 # place. For now, just save & restore.
121 my $orig_cwd = cwd();
122 my $orig_fh = select();
1efd22b7 123
c2d2fdd0 124 chdir($self->{dir});
6b09c160 125 my $pwd = cwd();
008fb49c 126 my $csuffix = $args{csuffix};
1efd22b7 127
c2d2fdd0 128 if ($self->{WantLineNumbers}) {
6b09c160
YST
129 my $cfile;
130 if ( $args{outfile} ) {
131 $cfile = $args{outfile};
34fa6cb6
JK
132 }
133 else {
6b09c160 134 $cfile = $args{filename};
008fb49c 135 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
6b09c160
YST
136 }
137 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
138 select PSEUDO_STDOUT;
34fa6cb6
JK
139 }
140 else {
6b09c160
YST
141 select $args{output};
142 }
143
50b96cc2
JK
144 my ($type_kind_ref, $proto_letter_ref, $input_expr_ref, $output_expr_ref) =
145 process_typemaps( $args{typemap}, $pwd );
6b09c160 146
50b96cc2
JK
147 %type_kind = %{ $type_kind_ref };
148 %proto_letter = %{ $proto_letter_ref };
149 %input_expr = %{ $input_expr_ref };
150 %output_expr = %{ $output_expr_ref };
6b09c160 151
fa81e4d3
NC
152 foreach my $value (values %input_expr) {
153 $value =~ s/;*\s+\z//;
a396bf53
NC
154 # Move C pre-processor instructions to column 1 to be strictly ANSI
155 # conformant. Some pre-processors are fussy about this.
156 $value =~ s/^\s+#/#/mg;
157 }
158 foreach my $value (values %output_expr) {
159 # And again.
160 $value =~ s/^\s+#/#/mg;
6b09c160
YST
161 }
162
af4112ab 163 my %targetable = make_targetable(\%output_expr);
6b09c160 164
1efd22b7 165 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
6b09c160
YST
166
167 # Match an XS keyword
c2d2fdd0 168 $self->{BLOCK_re} = '\s*(' .
ef83c2cf
JK
169 join('|' => @ExtUtils::ParseXS::Constants::keywords) .
170 "|$END)\\s*:";
6b09c160 171
a8adbc99 172 our ($C_group_rex, $C_arg);
6b09c160
YST
173 # Group in C (no support for comments or literals)
174 $C_group_rex = qr/ [({\[]
1efd22b7 175 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
7c3505a2 176 [)}\]] /x;
6b09c160
YST
177 # Chunk in C without comma at toplevel (no comments):
178 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
1efd22b7
JK
179 | (??{ $C_group_rex })
180 | " (?: (?> [^\\"]+ )
181 | \\.
182 )* " # String literal
183 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
184 )* /xs;
185
6b09c160 186 # Identify the version of xsubpp used
7c3505a2 187 print <<EOM;
6b09c160 188/*
566395ef 189 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
c2d2fdd0 190 * contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead.
6b09c160 191 *
1efd22b7 192 * ANY CHANGES MADE HERE WILL BE LOST!
6b09c160
YST
193 *
194 */
195
196EOM
197
198
c2d2fdd0
JK
199 print("#line 1 \"$self->{filepathname}\"\n")
200 if $self->{WantLineNumbers};
6b09c160 201
c2d2fdd0
JK
202 # Open the input file (using $self->{filename} which
203 # is a basename'd $args{filename} due to chdir above)
204 open($FH, $self->{filename}) or die "cannot open $self->{filename}: $!\n";
af4112ab 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");
c2d2fdd0
JK
226 printf("#line %d \"$self->{filepathname}\"\n", $. + 1)
227 if $self->{WantLineNumbers};
34fa6cb6
JK
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.
c2d2fdd0
JK
235 die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n")
236 unless $self->{lastline};
6b09c160 237 }
cdfe2888 238 last if ($Package, $self->{Prefix}) =
6b09c160 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
c2d2fdd0 248 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
708f9ca6
DG
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
c2d2fdd0 307 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
6b09c160 308
c2d2fdd0
JK
309 $self->{lastline} = $_;
310 $self->{lastline_no} = $.;
6b09c160 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);
cdfe2888 375 undef($self->{processing_arg_with_types});
7c3505a2
JK
376 undef(%argtype_seen);
377 undef(@outlist);
378 undef(%in_out);
379 undef(%lengthof);
cdfe2888
JK
380 undef($self->{proto_in_this_xsub});
381 undef($self->{scope_in_this_xsub});
382 undef($self->{interface});
6b09c160 383 undef($prepush_done);
cdfe2888
JK
384 $self->{interface_macro} = 'XSINTERFACE_FUNC';
385 $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET';
386 $self->{ProtoThisXSUB} = $self->{WantPrototypes};
387 $self->{ScopeThisXSUB} = 0;
6b09c160
YST
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;
c2d2fdd0
JK
401 push (@BootCode, "#line $line_no[@line_no - @line] \"$self->{filepathname}\"")
402 if $self->{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
9316f72a
JK
408 ($self->{ret_type}) = tidy_type($_);
409 $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//;
6b09c160
YST
410
411 # Allow one-line ANSI-like declaration
412 unshift @line, $2
c1e43162 413 if $args{argtypes}
9316f72a 414 and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
6b09c160
YST
415
416 # a function definition needs at least 2 lines
9316f72a 417 blurt ("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH
7c3505a2 418 unless @line;
6b09c160 419
9316f72a
JK
420 $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//;
421 $static = 1 if $self->{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 428 $class = "$4 $class" if $4;
7a522819 429 ($pname = $func_name) =~ s/^($self->{Prefix})?/$self->{Packprefix}/;
081eda6f 430 my $clean_func_name;
cdfe2888 431 ($clean_func_name = $func_name) =~ s/^$self->{Prefix}//;
6b09c160
YST
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;
9316f72a 602# dXSFUNCTION($self->{ret_type});
6b09c160 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
ecafe0ca
JK
660 $self->{thisdone} = 0;
661 $self->{retvaldone} = 0;
706e7216 662 $self->{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 668
cdfe2888 669 print Q(<<"EOF") if $self->{ScopeThisXSUB};
6b09c160
YST
670# ENTER;
671# [[
672EOF
1efd22b7 673
ecafe0ca 674 if (!$self->{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 {
9316f72a
JK
703 if ($self->{ret_type} ne "void") {
704 print "\t" . &map_type($self->{ret_type}, 'RETVAL', $self->{hiertype}) . ";\n"
ecafe0ca 705 if !$self->{retvaldone};
34fa6cb6 706 $args_match{"RETVAL"} = 0;
9316f72a 707 $var_types{"RETVAL"} = $self->{ret_type};
34fa6cb6 708 print "\tdXSTARG;\n"
9316f72a 709 if $args{optimize} and $targetable{$type_kind{$self->{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 $_ = "";
cdfe2888 715 $self->{processing_arg_with_types} = 1;
34fa6cb6
JK
716 INPUT_handler();
717 }
706e7216 718 print $self->{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;
cdfe2888 725 print "\tLEAVE;\n" if $self->{ScopeThisXSUB};
34fa6cb6 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";
9316f72a 737 if ($self->{ret_type} ne "void") {
34fa6cb6
JK
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'};
cdfe2888 759 $func_name = 'XSFUNCTION' if $self->{interface};
34fa6cb6 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 767 # $wantRETVAL set if 'RETVAL =' autogenerated
9316f72a 768 ($wantRETVAL, $self->{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) {
9316f72a 785 my $t = $args{optimize} && $targetable{$type_kind{$self->{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 794 my $var = 'RETVAL';
9316f72a 795 my $type = $self->{ret_type};
34fa6cb6
JK
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 819 generate_output( {
9316f72a 820 type => $self->{ret_type},
879afb6d
JK
821 num => 0,
822 var => 'RETVAL',
823 do_setmagic => 0,
824 do_push => undef,
825 } );
34fa6cb6 826 }
6b09c160 827 }
1efd22b7 828
9316f72a 829 $xsreturn = 1 if $self->{ret_type} ne "void";
6b09c160
YST
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
cdfe2888 846 print Q(<<"EOF") if $self->{ScopeThisXSUB};
6b09c160
YST
847# ]]
848EOF
cdfe2888 849 print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE;
6b09c160
YST
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:";
c2d2fdd0 870 death(/^$self->{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 897 # Build the prototype string for the xsub
cdfe2888 898 if ($self->{ProtoThisXSUB}) {
28892255 899 $newXS = "newXSproto_portable";
1efd22b7 900
cdfe2888 901 if ($self->{ProtoThisXSUB} eq 2) {
34fa6cb6 902 # User has specified empty prototype
6b09c160 903 }
cdfe2888 904 elsif ($self->{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 916 # User has specified a prototype
cdfe2888 917 $proto = $self->{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 }
cdfe2888 938 elsif ($self->{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);
cdfe2888 943# $self->{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
c2d2fdd0 957 if ($self->{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
c2d2fdd0 1017 print Q(<<"EOF") if $self->{WantVersionChk};
7c3505a2 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
c2d2fdd0 1028 print Q(<<"EOF") if ($self->{Overload});
6b09c160
YST
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 ),
c2d2fdd0 1036# $self->{Fallback}
6b09c160
YST
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
c2d2fdd0 1066 warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n")
551f599a 1067 unless $self->{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
c2d2fdd0 1077sub report_error_count { $self->{errors} }
6b09c160 1078
6b09c160
YST
1079# Input: ($_, @line) == unparsed input.
1080# Output: ($_, @line) == (rest of line, following lines).
1081# Return: the matched keyword if found, otherwise 0
1082sub check_keyword {
505ef4a5
JK
1083 $_ = shift(@line) while !/\S/ && @line;
1084 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
6b09c160
YST
1085}
1086
1087sub print_section {
505ef4a5
JK
1088 # the "do" is required for right semantics
1089 do { $_ = shift(@line) } while !/\S/ && @line;
6b09c160 1090
c2d2fdd0
JK
1091 print("#line ", $line_no[@line_no - @line -1], " \"$self->{filepathname}\"\n")
1092 if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1093 for (; defined($_) && !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
1efd22b7 1094 print "$_\n";
505ef4a5 1095 }
c2d2fdd0 1096 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers};
6b09c160
YST
1097}
1098
1099sub merge_section {
505ef4a5 1100 my $in = '';
6b09c160 1101
505ef4a5
JK
1102 while (!/\S/ && @line) {
1103 $_ = shift(@line);
1104 }
6b09c160 1105
c2d2fdd0 1106 for (; defined($_) && !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
505ef4a5 1107 $in .= "$_\n";
6b09c160 1108 }
505ef4a5
JK
1109 chomp $in;
1110 return $in;
1111}
6b09c160 1112
505ef4a5
JK
1113sub process_keyword($) {
1114 my($pattern) = @_;
1115 my $kwd;
6b09c160 1116
d710f389 1117 no strict 'refs';
505ef4a5
JK
1118 &{"${kwd}_handler"}()
1119 while $kwd = check_keyword($pattern);
d710f389 1120 use strict 'refs';
505ef4a5 1121}
6b09c160
YST
1122
1123sub CASE_handler {
1124 blurt ("Error: `CASE:' after unconditional `CASE:'")
1125 if $condnum && $cond eq '';
1126 $cond = $_;
1d40e528 1127 trim_whitespace($cond);
6b09c160 1128 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
7c3505a2 1129 $_ = '';
6b09c160
YST
1130}
1131
1132sub INPUT_handler {
c2d2fdd0 1133 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
6b09c160 1134 last if /^\s*NOT_IMPLEMENTED_YET/;
1efd22b7 1135 next unless /\S/; # skip blank lines
6b09c160 1136
1d40e528 1137 trim_whitespace($_);
9e831c8e 1138 my $ln = $_;
6b09c160
YST
1139
1140 # remove trailing semicolon if no initialisation
7c3505a2 1141 s/\s*;$//g unless /[=;+].*\S/;
6b09c160
YST
1142
1143 # Process the length(foo) declarations
1144 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1145 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
be5bcef7 1146 $lengthof{$2} = undef;
706e7216 1147 $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
6b09c160
YST
1148 }
1149
1150 # check for optional initialisation code
7c3505a2
JK
1151 my $var_init = '';
1152 $var_init = $1 if s/\s*([=;+].*)$//s;
6b09c160
YST
1153 $var_init =~ s/"/\\"/g;
1154
1155 s/\s+/ /g;
1156 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
9e831c8e 1157 or blurt("Error: invalid argument declaration '$ln'"), next;
6b09c160
YST
1158
1159 # Check for duplicate definitions
1160 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1161 if $arg_list{$var_name}++
cdfe2888 1162 or defined $argtype_seen{$var_name} and not $self->{processing_arg_with_types};
6b09c160 1163
ecafe0ca
JK
1164 $self->{thisdone} |= $var_name eq "THIS";
1165 $self->{retvaldone} |= $var_name eq "RETVAL";
6b09c160
YST
1166 $var_types{$var_name} = $var_type;
1167 # XXXX This check is a safeguard against the unfinished conversion of
1168 # generate_init(). When generate_init() is fixed,
1169 # one can use 2-args map_type() unconditionally.
d67360fa 1170 my $printed_name;
6b09c160
YST
1171 if ($var_type =~ / \( \s* \* \s* \) /x) {
1172 # Function pointers are not yet supported with &output_init!
c2d2fdd0 1173 print "\t" . &map_type($var_type, $var_name, $self->{hiertype});
68f166a7 1174 $printed_name = 1;
505ef4a5
JK
1175 }
1176 else {
c2d2fdd0 1177 print "\t" . &map_type($var_type, undef, $self->{hiertype});
68f166a7 1178 $printed_name = 0;
6b09c160
YST
1179 }
1180 $var_num = $args_match{$var_name};
1181
a1d55b8f
JK
1182 if ($var_num) {
1183 $proto_arg[$var_num] = $proto_letter{$var_type} || "\$";
1184 }
6b09c160
YST
1185 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1186 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
505ef4a5
JK
1187 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1188 and $var_init !~ /\S/) {
68f166a7 1189 if ($printed_name) {
505ef4a5 1190 print ";\n";
6b09c160 1191 }
505ef4a5
JK
1192 else {
1193 print "\t$var_name;\n";
1194 }
1195 }
1196 elsif ($var_init =~ /\S/) {
87e6f370
JK
1197 output_init( {
1198 type => $var_type,
1199 num => $var_num,
1200 var => $var_name,
1201 init => $var_init,
1202 printed_name => $printed_name,
1203 } );
505ef4a5
JK
1204 }
1205 elsif ($var_num) {
879afb6d
JK
1206 generate_init( {
1207 type => $var_type,
1208 num => $var_num,
1209 var => $var_name,
1210 printed_name => $printed_name,
1211 } );
505ef4a5
JK
1212 }
1213 else {
6b09c160
YST
1214 print ";\n";
1215 }
1216 }
1217}
1218
1219sub OUTPUT_handler {
c2d2fdd0 1220 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
6b09c160
YST
1221 next unless /\S/;
1222 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1223 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1224 next;
1225 }
7c3505a2 1226 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s;
6b09c160 1227 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
9e831c8e 1228 if $outargs{$outarg}++;
6b09c160
YST
1229 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1230 # deal with RETVAL last
7c3505a2
JK
1231 $RETVAL_code = $outcode;
1232 $gotRETVAL = 1;
1233 next;
6b09c160
YST
1234 }
1235 blurt ("Error: OUTPUT $outarg not an argument"), next
1236 unless defined($args_match{$outarg});
1237 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
7c3505a2 1238 unless defined $var_types{$outarg};
6b09c160
YST
1239 $var_num = $args_match{$outarg};
1240 if ($outcode) {
1241 print "\t$outcode\n";
1242 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
505ef4a5
JK
1243 }
1244 else {
879afb6d
JK
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
cdfe2888 1270 ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in;
505ef4a5
JK
1271 }
1272 else {
cdfe2888
JK
1273 $self->{interface_macro} = $in;
1274 $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later
6b09c160 1275 }
cdfe2888 1276 $self->{interface} = 1; # local
1efd22b7 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 1286 my $iface_name = $_;
cdfe2888 1287 $iface_name =~ s/^$self->{Prefix}//;
88577d04 1288 $Interfaces{$iface_name} = $_;
6b09c160
YST
1289 }
1290 print Q(<<"EOF");
9316f72a 1291# XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr);
6b09c160 1292EOF
cdfe2888 1293 $self->{interface} = 1; # local
1efd22b7 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 1314 # check for optional package definition in the alias
7a522819 1315 $alias = $self->{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 () {
c2d2fdd0 1334 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
505ef4a5 1335 next unless /\S/;
1d40e528 1336 trim_whitespace($_);
505ef4a5 1337 push @Attributes, $_;
6b09c160 1338 }
505ef4a5 1339}
6b09c160 1340
505ef4a5 1341sub ALIAS_handler () {
c2d2fdd0 1342 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
505ef4a5 1343 next unless /\S/;
1d40e528 1344 trim_whitespace($_);
505ef4a5 1345 GetAliases($_) if $_;
6b09c160 1346 }
505ef4a5 1347}
6b09c160 1348
505ef4a5 1349sub OVERLOAD_handler() {
c2d2fdd0 1350 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
6b09c160 1351 next unless /\S/;
1d40e528 1352 trim_whitespace($_);
6b09c160 1353 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
c2d2fdd0 1354 $self->{Overload} = 1 unless $self->{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
c2d2fdd0 1376 $self->{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
c2d2fdd0
JK
1407 $self->{WantVersionChk} = 1 if $1 eq 'ENABLE';
1408 $self->{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")
cdfe2888 1416 if $self->{proto_in_this_xsub}++;
6b09c160 1417
c2d2fdd0 1418 for (; !/^$self->{BLOCK_re}/o; $_ = shift(@line)) {
505ef4a5
JK
1419 next unless /\S/;
1420 $specified = 1;
1d40e528 1421 trim_whitespace($_);
505ef4a5 1422 if ($_ eq 'DISABLE') {
cdfe2888 1423 $self->{ProtoThisXSUB} = 0;
505ef4a5
JK
1424 }
1425 elsif ($_ eq 'ENABLE') {
cdfe2888 1426 $self->{ProtoThisXSUB} = 1;
505ef4a5
JK
1427 }
1428 else {
1429 # remove any whitespace
1430 s/\s+//g;
1431 death("Error: Invalid prototype '$_'")
547742ac 1432 unless valid_proto_string($_);
cdfe2888 1433 $self->{ProtoThisXSUB} = C_string($_);
505ef4a5 1434 }
6b09c160
YST
1435 }
1436
505ef4a5 1437 # If no prototype specified, then assume empty prototype ""
cdfe2888 1438 $self->{ProtoThisXSUB} = 2 unless $specified;
6b09c160 1439
551f599a 1440 $self->{ProtoUsed} = 1;
505ef4a5 1441}
6b09c160 1442
505ef4a5
JK
1443sub SCOPE_handler () {
1444 death("Error: Only 1 SCOPE declaration allowed per xsub")
cdfe2888 1445 if $self->{scope_in_this_xsub}++;
6b09c160 1446
1d40e528 1447 trim_whitespace($_);
505ef4a5
JK
1448 death ("Error: SCOPE: ENABLE/DISABLE")
1449 unless /^(ENABLE|DISABLE)\b/i;
cdfe2888 1450 $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' );
505ef4a5 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
c2d2fdd0
JK
1463 $self->{WantPrototypes} = 1 if $1 eq 'ENABLE';
1464 $self->{WantPrototypes} = 0 if $1 eq 'DISABLE';
551f599a
JK
1465 $self->{ProtoUsed} = 1;
1466
505ef4a5 1467}
387b6f8d 1468
505ef4a5 1469sub PushXSStack {
f0744969 1470 my %args = @_;
505ef4a5
JK
1471 # Save the current file context.
1472 push(@XSStack, {
1473 type => 'file',
c2d2fdd0
JK
1474 LastLine => $self->{lastline},
1475 LastLineNo => $self->{lastline_no},
505ef4a5
JK
1476 Line => \@line,
1477 LineNo => \@line_no,
c2d2fdd0
JK
1478 Filename => $self->{filename},
1479 Filepathname => $self->{filepathname},
505ef4a5 1480 Handle => $FH,
c2d2fdd0 1481 IsPipe => scalar($self->{filename} =~ /\|\s*$/),
505ef4a5
JK
1482 %args,
1483 });
387b6f8d 1484
505ef4a5 1485}
6b09c160 1486
505ef4a5
JK
1487sub INCLUDE_handler () {
1488 # the rest of the current line should contain a valid filename
6b09c160 1489
1d40e528 1490 trim_whitespace($_);
6b09c160 1491
505ef4a5
JK
1492 death("INCLUDE: filename missing")
1493 unless $_;
6b09c160 1494
505ef4a5
JK
1495 death("INCLUDE: output pipe is illegal")
1496 if /^\s*\|/;
6b09c160 1497
505ef4a5
JK
1498 # simple minded recursion detector
1499 death("INCLUDE loop detected")
1500 if $IncludedFiles{$_};
6b09c160 1501
9e831c8e 1502 ++$IncludedFiles{$_} unless /\|\s*$/;
505ef4a5
JK
1503
1504 if (/\|\s*$/ && /^\s*perl\s/) {
1505 Warn("The INCLUDE directive with a command is discouraged." .
1506 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1507 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1508 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1509 " the use of \$^X as the currently running perl, see" .
1510 " 'perldoc perlxs' for details.");
1511 }
387b6f8d 1512
505ef4a5 1513 PushXSStack();
6b09c160 1514
505ef4a5 1515 $FH = Symbol::gensym();
6b09c160 1516
505ef4a5
JK
1517 # open the new file
1518 open ($FH, "$_") or death("Cannot open '$_': $!");
6b09c160 1519
505ef4a5 1520 print Q(<<"EOF");
6b09c160 1521#
c2d2fdd0 1522#/* INCLUDE: Including '$_' from '$self->{filename}' */
6b09c160
YST
1523#
1524EOF
1525
c2d2fdd0
JK
1526 $self->{filename} = $_;
1527 $self->{filepathname} = File::Spec->catfile($self->{dir}, $self->{filename});
6b09c160 1528
505ef4a5
JK
1529 # Prime the pump by reading the first
1530 # non-blank line
6b09c160 1531
505ef4a5
JK
1532 # skip leading blank lines
1533 while (<$FH>) {
1534 last unless /^\s*$/;
387b6f8d
S
1535 }
1536
c2d2fdd0
JK
1537 $self->{lastline} = $_;
1538 $self->{lastline_no} = $.;
505ef4a5
JK
1539}
1540
494e8c4c 1541sub QuoteArgs {
505ef4a5
JK
1542 my $cmd = shift;
1543 my @args = split /\s+/, $cmd;
1544 $cmd = shift @args;
1545 for (@args) {
1546 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
494e8c4c 1547 }
505ef4a5
JK
1548 return join (' ', ($cmd, @args));
1549}
494e8c4c 1550
505ef4a5
JK
1551sub INCLUDE_COMMAND_handler () {
1552 # the rest of the current line should contain a valid command
387b6f8d 1553
1d40e528 1554 trim_whitespace($_);
387b6f8d 1555
505ef4a5 1556 $_ = QuoteArgs($_) if $^O eq 'VMS';
494e8c4c 1557
505ef4a5
JK
1558 death("INCLUDE_COMMAND: command missing")
1559 unless $_;
387b6f8d 1560
505ef4a5
JK
1561 death("INCLUDE_COMMAND: pipes are illegal")
1562 if /^\s*\|/ or /\|\s*$/;
387b6f8d 1563
505ef4a5 1564 PushXSStack( IsPipe => 1 );
387b6f8d 1565
505ef4a5 1566 $FH = Symbol::gensym();
387b6f8d 1567
505ef4a5
JK
1568 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1569 # the same perl interpreter as we're currently running
1570 s/^\s*\$\^X/$^X/;
387b6f8d 1571
505ef4a5
JK
1572 # open the new file
1573 open ($FH, "-|", "$_")
1574 or death("Cannot run command '$_' to include its output: $!");
387b6f8d 1575
505ef4a5 1576 print Q(<<"EOF");
387b6f8d 1577#
c2d2fdd0 1578#/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */
387b6f8d
S
1579#
1580EOF
1581
c2d2fdd0
JK
1582 $self->{filename} = $_;
1583 $self->{filepathname} = $self->{filename};
1584 $self->{filepathname} =~ s/\"/\\"/g;
387b6f8d 1585
505ef4a5
JK
1586 # Prime the pump by reading the first
1587 # non-blank line
6b09c160 1588
505ef4a5
JK
1589 # skip leading blank lines
1590 while (<$FH>) {
1591 last unless /^\s*$/;
6b09c160
YST
1592 }
1593
c2d2fdd0
JK
1594 $self->{lastline} = $_;
1595 $self->{lastline_no} = $.;
505ef4a5 1596}
6b09c160 1597
505ef4a5
JK
1598sub PopFile() {
1599 return 0 unless $XSStack[-1]{type} eq 'file';
6b09c160 1600
505ef4a5 1601 my $data = pop @XSStack;
c2d2fdd0 1602 my $ThisFile = $self->{filename};
505ef4a5 1603 my $isPipe = $data->{IsPipe};
6b09c160 1604
c2d2fdd0 1605 --$IncludedFiles{$self->{filename}}
505ef4a5 1606 unless $isPipe;
6b09c160 1607
505ef4a5 1608 close $FH;
6b09c160 1609
505ef4a5
JK
1610 $FH = $data->{Handle};
1611 # $filename is the leafname, which for some reason isused for diagnostic
1612 # messages, whereas $filepathname is the full pathname, and is used for
1613 # #line directives.
c2d2fdd0
JK
1614 $self->{filename} = $data->{Filename};
1615 $self->{filepathname} = $data->{Filepathname};
1616 $self->{lastline} = $data->{LastLine};
1617 $self->{lastline_no} = $data->{LastLineNo};
505ef4a5
JK
1618 @line = @{ $data->{Line} };
1619 @line_no = @{ $data->{LineNo} };
1620
1621 if ($isPipe and $? ) {
c2d2fdd0
JK
1622 --$self->{lastline_no};
1623 print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ;
505ef4a5
JK
1624 exit 1;
1625 }
6b09c160 1626
505ef4a5 1627 print Q(<<"EOF");
6b09c160 1628#
c2d2fdd0 1629#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */
6b09c160
YST
1630#
1631EOF
1632
505ef4a5
JK
1633 return 1;
1634}
6b09c160 1635
6b09c160
YST
1636sub check_cpp {
1637 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1638 if (@cpp) {
1639 my ($cpp, $cpplevel);
1640 for $cpp (@cpp) {
1641 if ($cpp =~ /^\#\s*if/) {
505ef4a5
JK
1642 $cpplevel++;
1643 }
1644 elsif (!$cpplevel) {
1645 Warn("Warning: #else/elif/endif without #if in this function");
1646 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1647 if $XSStack[-1]{type} eq 'if';
1648 return;
1649 }
1650 elsif ($cpp =~ /^\#\s*endif/) {
1651 $cpplevel--;
6b09c160
YST
1652 }
1653 }
1654 Warn("Warning: #if without #endif in this function") if $cpplevel;
1655 }
1656}
1657
1658
1659sub Q {
1660 my($text) = @_;
1661 $text =~ s/^#//gm;
1662 $text =~ s/\[\[/{/g;
1663 $text =~ s/\]\]/}/g;
1664 $text;
1665}
1666
1667# Read next xsub into @line from ($lastline, <$FH>).
1668sub fetch_para {
1669 # parse paragraph
1670 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
c2d2fdd0 1671 if !defined $self->{lastline} && $XSStack[-1]{type} eq 'if';
6b09c160 1672 @line = ();
7c3505a2 1673 @line_no = ();
c2d2fdd0 1674 return PopFile() if !defined $self->{lastline};
6b09c160 1675
c2d2fdd0 1676 if ($self->{lastline} =~
6b09c160 1677 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
be5bcef7 1678 my $Module = $1;
6b09c160 1679 $Package = defined($2) ? $2 : ''; # keep -w happy
cdfe2888
JK
1680 $self->{Prefix} = defined($3) ? $3 : ''; # keep -w happy
1681 $self->{Prefix} = quotemeta $self->{Prefix};
6b09c160
YST
1682 ($Module_cname = $Module) =~ s/\W/_/g;
1683 ($Packid = $Package) =~ tr/:/_/;
7a522819
JK
1684 $self->{Packprefix} = $Package;
1685 $self->{Packprefix} .= "::" if $self->{Packprefix} ne "";
c2d2fdd0 1686 $self->{lastline} = "";
6b09c160
YST
1687 }
1688
1689 for (;;) {
1690 # Skip embedded PODs
c2d2fdd0
JK
1691 while ($self->{lastline} =~ /^=/) {
1692 while ($self->{lastline} = <$FH>) {
1693 last if ($self->{lastline} =~ /^=cut\s*$/);
6b09c160 1694 }
c2d2fdd0
JK
1695 death ("Error: Unterminated pod") unless $self->{lastline};
1696 $self->{lastline} = <$FH>;
1697 chomp $self->{lastline};
1698 $self->{lastline} =~ s/^\s+$//;
6b09c160 1699 }
c2d2fdd0 1700 if ($self->{lastline} !~ /^\s*#/ ||
1efd22b7
JK
1701 # CPP directives:
1702 # ANSI: if ifdef ifndef elif else endif define undef
1703 # line error pragma
1704 # gcc: warning include_next
1705 # obj-c: import
1706 # others: ident (gcc notes that some cpps have this one)
c2d2fdd0
JK
1707 $self->{lastline} =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1708 last if $self->{lastline} =~ /^\S/ && @line && $line[-1] eq "";
1709 push(@line, $self->{lastline});
1710 push(@line_no, $self->{lastline_no});
6b09c160
YST
1711 }
1712
1713 # Read next line and continuation lines
c2d2fdd0
JK
1714 last unless defined($self->{lastline} = <$FH>);
1715 $self->{lastline_no} = $.;
6b09c160 1716 my $tmp_line;
c2d2fdd0
JK
1717 $self->{lastline} .= $tmp_line
1718 while ($self->{lastline} =~ /\\$/ && defined($tmp_line = <$FH>));
6b09c160 1719
c2d2fdd0
JK
1720 chomp $self->{lastline};
1721 $self->{lastline} =~ s/^\s+$//;
6b09c160
YST
1722 }
1723 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1724 1;
1725}
1726
1727sub output_init {
87e6f370
JK
1728 my $argsref = shift;
1729 my ($type, $num, $var, $init, $printed_name) = (
1730 $argsref->{type},
1731 $argsref->{num},
1732 $argsref->{var},
1733 $argsref->{init},
1734 $argsref->{printed_name}
1735 );
f0744969 1736 my $arg = "ST(" . ($num - 1) . ")";
6b09c160
YST
1737
1738 if ( $init =~ /^=/ ) {
68f166a7 1739 if ($printed_name) {
6b09c160 1740 eval qq/print " $init\\n"/;
505ef4a5
JK
1741 }
1742 else {
6b09c160
YST
1743 eval qq/print "\\t$var $init\\n"/;
1744 }
9e831c8e 1745 warn $@ if $@;
505ef4a5
JK
1746 }
1747 else {
6b09c160 1748 if ( $init =~ s/^\+// && $num ) {
879afb6d
JK
1749 generate_init( {
1750 type => $type,
1751 num => $num,
1752 var => $var,
1753 printed_name => $printed_name,
1754 } );
505ef4a5 1755 }
68f166a7 1756 elsif ($printed_name) {
6b09c160
YST
1757 print ";\n";
1758 $init =~ s/^;//;
505ef4a5
JK
1759 }
1760 else {
6b09c160 1761 eval qq/print "\\t$var;\\n"/;
9e831c8e 1762 warn $@ if $@;
6b09c160
YST
1763 $init =~ s/^;//;
1764 }
706e7216 1765 $self->{deferred} .= eval qq/"\\n\\t$init\\n"/;
505ef4a5 1766 warn $@ if $@;
6b09c160
YST
1767 }
1768}
1769
6b09c160 1770sub generate_init {
879afb6d
JK
1771 my $argsref = shift;
1772 my ($type, $num, $var, $printed_name) = (
1773 $argsref->{type},
1774 $argsref->{num},
1775 $argsref->{var},
1776 $argsref->{printed_name},
1777 );
be5bcef7 1778 my $arg = "ST(" . ($num - 1) . ")";
be5bcef7
JK
1779 my ($argoff, $ntype, $tk);
1780 $argoff = $num - 1;
6b09c160 1781
73e91d5a 1782 $type = tidy_type($type);
6b09c160
YST
1783 blurt("Error: '$type' not in typemap"), return
1784 unless defined($type_kind{$type});
1785
1786 ($ntype = $type) =~ s/\s*\*/Ptr/g;
be5bcef7 1787 my $subtype;
6b09c160
YST
1788 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1789 $tk = $type_kind{$type};
1790 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1791 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
68f166a7 1792 print "\t$var" unless $printed_name;
6b09c160
YST
1793 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1794 die "default value not supported with length(NAME) supplied"
1795 if defined $defaults{$var};
1796 return;
1797 }
c2d2fdd0 1798 $type =~ tr/:/_/ unless $self->{hiertype};
6b09c160 1799 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
7c3505a2 1800 unless defined $input_expr{$tk};
be5bcef7 1801 my $expr = $input_expr{$tk};
6b09c160
YST
1802 if ($expr =~ /DO_ARRAY_ELEM/) {
1803 blurt("Error: '$subtype' not in typemap"), return
1804 unless defined($type_kind{$subtype});
1805 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
7c3505a2 1806 unless defined $input_expr{$type_kind{$subtype}};
be5bcef7 1807 my $subexpr = $input_expr{$type_kind{$subtype}};
6b09c160
YST
1808 $subexpr =~ s/\$type/\$subtype/g;
1809 $subexpr =~ s/ntype/subtype/g;
1810 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1811 $subexpr =~ s/\n\t/\n\t\t/g;
1812 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1813 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1814 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1815 }
1816 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
cdfe2888 1817 $self->{ScopeThisXSUB} = 1;
6b09c160
YST
1818 }
1819 if (defined($defaults{$var})) {
1820 $expr =~ s/(\t+)/$1 /g;
1821 $expr =~ s/ /\t/g;
68f166a7 1822 if ($printed_name) {
6b09c160 1823 print ";\n";
505ef4a5
JK
1824 }
1825 else {
6b09c160 1826 eval qq/print "\\t$var;\\n"/;
0bba9eb1 1827 warn $@ if $@;
6b09c160
YST
1828 }
1829 if ($defaults{$var} eq 'NO_INIT') {
706e7216 1830 $self->{deferred} .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
505ef4a5
JK
1831 }
1832 else {
706e7216 1833 $self->{deferred} .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
6b09c160 1834 }
0bba9eb1 1835 warn $@ if $@;
505ef4a5 1836 }
cdfe2888 1837 elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) {
68f166a7 1838 if ($printed_name) {
6b09c160 1839 print ";\n";
505ef4a5
JK
1840 }
1841 else {
6b09c160 1842 eval qq/print "\\t$var;\\n"/;
0bba9eb1 1843 warn $@ if $@;
6b09c160 1844 }
706e7216 1845 $self->{deferred} .= eval qq/"\\n$expr;\\n"/;
0bba9eb1 1846 warn $@ if $@;
505ef4a5
JK
1847 }
1848 else {
6b09c160 1849 die "panic: do not know how to handle this branch for function pointers"
68f166a7 1850 if $printed_name;
6b09c160 1851 eval qq/print "$expr;\\n"/;
0bba9eb1 1852 warn $@ if $@;
6b09c160
YST
1853 }
1854}
1855
1856sub generate_output {
879afb6d
JK
1857 my $argsref = shift;
1858 my ($type, $num, $var, $do_setmagic, $do_push) = (
1859 $argsref->{type},
1860 $argsref->{num},
1861 $argsref->{var},
1862 $argsref->{do_setmagic},
1863 $argsref->{do_push}
1864 );
be5bcef7 1865 my $arg = "ST(" . ($num - ($num != 0)) . ")";
be5bcef7 1866 my $ntype;
6b09c160 1867
73e91d5a 1868 $type = tidy_type($type);
6b09c160
YST
1869 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1870 print "\t$arg = sv_newmortal();\n";
1871 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1872 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
505ef4a5
JK
1873 }
1874 else {
6b09c160
YST
1875 blurt("Error: '$type' not in typemap"), return
1876 unless defined($type_kind{$type});
1877 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
7c3505a2 1878 unless defined $output_expr{$type_kind{$type}};
6b09c160
YST
1879 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1880 $ntype =~ s/\(\)//g;
be5bcef7 1881 my $subtype;
6b09c160 1882 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
be5bcef7 1883 my $expr = $output_expr{$type_kind{$type}};
6b09c160
YST
1884 if ($expr =~ /DO_ARRAY_ELEM/) {
1885 blurt("Error: '$subtype' not in typemap"), return
59863c7c 1886 unless defined($type_kind{$subtype});
6b09c160 1887 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
59863c7c 1888 unless defined $output_expr{$type_kind{$subtype}};
be5bcef7 1889 my $subexpr = $output_expr{$type_kind{$subtype}};
6b09c160
YST
1890 $subexpr =~ s/ntype/subtype/g;
1891 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1892 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1893 $subexpr =~ s/\n\t/\n\t\t/g;
1894 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1895 eval "print qq\a$expr\a";
0bba9eb1 1896 warn $@ if $@;
6b09c160 1897 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
505ef4a5
JK
1898 }
1899 elsif ($var eq 'RETVAL') {
6b09c160 1900 if ($expr =~ /^\t\$arg = new/) {
505ef4a5
JK
1901 # We expect that $arg has refcnt 1, so we need to
1902 # mortalize it.
1903 eval "print qq\a$expr\a";
0bba9eb1 1904 warn $@ if $@;
505ef4a5
JK
1905 print "\tsv_2mortal(ST($num));\n";
1906 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1907 }
1908 elsif ($expr =~ /^\s*\$arg\s*=/) {
1909 # We expect that $arg has refcnt >=1, so we need
1910 # to mortalize it!
1911 eval "print qq\a$expr\a";
0bba9eb1 1912 warn $@ if $@;
505ef4a5
JK
1913 print "\tsv_2mortal(ST(0));\n";
1914 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
6b09c160 1915 }
505ef4a5
JK
1916 else {
1917 # Just hope that the entry would safely write it
1918 # over an already mortalized value. By
1919 # coincidence, something like $arg = &sv_undef
1920 # works too.
1921 print "\tST(0) = sv_newmortal();\n";
1922 eval "print qq\a$expr\a";
0bba9eb1 1923 warn $@ if $@;
505ef4a5
JK
1924 # new mortals don't have set magic
1925 }
1926 }
1927 elsif ($do_push) {
6b09c160
YST
1928 print "\tPUSHs(sv_newmortal());\n";
1929 $arg = "ST($num)";
1930 eval "print qq\a$expr\a";
0bba9eb1 1931 warn $@ if $@;
6b09c160 1932 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
505ef4a5
JK
1933 }
1934 elsif ($arg =~ /^ST\(\d+\)$/) {
6b09c160 1935 eval "print qq\a$expr\a";
0bba9eb1 1936 warn $@ if $@;
6b09c160
YST
1937 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1938 }
1939 }
1940}
1941
87e6f370
JK
1942sub Warn {
1943 # work out the line number
1944 my $warn_line_number = $line_no[@line_no - @line -1];
1945
c2d2fdd0 1946 print STDERR "@_ in $self->{filename}, line $warn_line_number\n";
87e6f370
JK
1947}
1948
1949sub blurt {
1950 Warn @_;
c2d2fdd0 1951 $self->{errors}++
87e6f370
JK
1952}
1953
1954sub death {
1955 Warn @_;
1956 exit 1;
1957}
1958
6b09c160 19591;