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