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