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