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