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