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