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