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