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