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