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