This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Bumping version of ExtUtils::ParseXS per porting/cmpVERSION.pl
[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
17my(@XSStack); # Stack of conditionals and INCLUDEs
18my($XSS_work_idx, $cpp_next_tmp);
19
20use vars qw($VERSION);
8dfb9616 21$VERSION = '2.2209';
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
25 $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
26 $WantOptimize $process_inout $process_argtypes @tm
27 $dir $filename $filepathname %IncludedFiles
28 %type_kind %proto_letter
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
35 ); # Add these just to get compilation to happen.
36
37
38sub process_file {
39
40 # Allow for $package->process_file(%hash) in the future
41 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
42
43 $ProtoUsed = exists $args{prototypes};
44
45 # Set defaults.
46 %args = (
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,
008fb49c 59 csuffix => '.c',
6b09c160
YST		 60 %args,
61 );
62
63 # Global Constants
64
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();
494e8c4c 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
85
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});
96
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 }
104
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();
120
121 chdir($dir);
122 my $pwd = cwd();
008fb49c 123 my $csuffix = $args{csuffix};
6b09c160
YST		 124
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) {
146 next unless -f $typemap ;
147 # skip directories, binary files etc.
148 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
149 unless -T $typemap ;
150 open(TYPEMAP, $typemap)
151 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
152 my $mode = 'Typemap';
153 my $junk = "" ;
154 my $current = \$junk;
155 while (<TYPEMAP>) {
156 next if /^\s* #/;
157 my $line_no = $. + 1;
158 if (/^INPUT\s*$/) {
159 $mode = 'Input'; $current = \$junk; next;
160 }
161 if (/^OUTPUT\s*$/) {
162 $mode = 'Output'; $current = \$junk; next;
163 }
164 if (/^TYPEMAP\s*$/) {
165 $mode = 'Typemap'; $current = \$junk; next;
166 }
167 if ($mode eq 'Typemap') {
168 chomp;
169 my $line = $_ ;
170 TrimWhitespace($_) ;
171 # skip blank lines and comment lines
172 next if /^$/ or /^#/ ;
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;
175 $type = TidyType($type) ;
176 $type_kind{$type} = $kind ;
177 # prototype defaults to '$'
178 $proto = "\$" unless $proto ;
179 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
180 unless ValidProtoString($proto) ;
181 $proto_letter{$type} = C_string($proto) ;
182 } elsif (/^\s/) {
183 $$current .= $_;
184 } elsif ($mode eq 'Input') {
185 s/\s+$//;
186 $input_expr{$_} = '';
187 $current = \$input_expr{$_};
188 } else {
189 s/\s+$//;
190 $output_expr{$_} = '';
191 $current = \$output_expr{$_};
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) {
28892255 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} =~
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);
226 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
227 }
228
229 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
230
231 # Match an XS keyword
232 $BLOCK_re= '\s*(' . join('|', qw(
387b6f8d
S		 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
6b09c160
YST		 237 )) . "|$END)\\s*:";
238
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/ [({\[]
243 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
244 [)}\]] /x ;
245 # Chunk in C without comma at toplevel (no comments):
246 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
247 | (??{ $C_group_rex })
248 | " (?: (?> [^\\"]+ )
249 | \\.
250 )* " # String literal
251 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
252 )* /xs;
253
254 # Identify the version of xsubpp used
255 print <<EOM ;
256/*
257 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
258 * contents of $filename. Do not edit this file, edit $filename instead.
259 *
260 * ANY CHANGES MADE HERE WILL BE LOST!
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 {
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
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")
300 unless $lastline;
301 }
302 last if ($Package, $Prefix) =
303 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
304
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
353#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
354#else
355#define croak_xs_usage S_croak_xs_usage
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') {
385 $XSS_work_idx = @XSStack;
386 push(@XSStack, {type => 'if'});
387 } else {
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 }
408 }
409 }
410
411 next PARAGRAPH unless @line;
412
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"
422 ." (maybe last function was ended by a blank line "
423 ." followed by a statement on column one?)")
424 if $line[0] =~ /^\s/;
425
95b611b0 426 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
6b09c160
YST		 427 my (@fake_INPUT_pre); # For length(s) generated variables
428 my (@fake_INPUT);
429
430 # initialize info arrays
431 undef(%args_match);
432 undef(%var_types);
433 undef(%defaults);
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) ;
443 undef($interface);
444 undef($prepush_done);
445 $interface_macro = 'XSINTERFACE_FUNC' ;
446 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
447 $ProtoThisXSUB = $WantPrototypes ;
448 $ScopeThisXSUB = 0;
449 $xsreturn = 0;
450
451 $_ = shift(@line);
387b6f8d 452 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
6b09c160
YST		 453 &{"${kwd}_handler"}() ;
454 next PARAGRAPH unless @line ;
455 $_ = shift(@line);
456 }
457
458 if (check_keyword("BOOT")) {
459 &check_cpp;
460 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
461 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
462 push (@BootCode, @line, "") ;
463 next PARAGRAPH ;
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
474 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
475
476 # a function definition needs at least 2 lines
477 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
478 unless @line ;
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
487 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
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 }
502 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
503 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
504 $DoSetMagic = 1;
505
506 $orig_args =~ s/\\\s*/ /g; # process line continuations
507 my @args;
508
509 my %only_C_inlist; # Not in the signature of Perl function
510 if ($process_argtypes and $orig_args =~ /\S/) {
511 my $args = "$orig_args ,";
512 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
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);
89345840 522 my $out_type = '';
6b09c160 523 my $inout_var;
387b6f8d 524 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
6b09c160
YST		 525 my $type = $1;
526 $out_type = $type if $type ne 'IN';
387b6f8d
S		 527 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
528 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
6b09c160
YST		 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 }
551 } else {
552 @args = split(/\s*,\s*/, $orig_args);
553 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
554 }
555 } else {
556 @args = split(/\s*,\s*/, $orig_args);
557 for (@args) {
387b6f8d 558 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
6b09c160
YST		 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 }
565 }
566 }
567 if (defined($class)) {
568 my $arg0 = ((defined($static) or $func_name eq 'new')
569 ? "CLASS" : "THIS");
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/\.\.\.//) {
95b611b0 578 $ellipsis = 1;
6b09c160
YST		 579 if ($args[$i] eq '' && $i == $#args) {
580 $report_args .= ", ...";
581 pop(@args);
582 last;
583 }
584 }
585 if ($only_C_inlist{$args[$i]}) {
586 push @args_num, undef;
587 } else {
588 push @args_num, ++$num_args;
589 $report_args .= ", $args[$i]";
590 }
591 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
592 $extra_args++;
593 $args[$i] = $1;
594 $defaults{$args[$i]} = $2;
595 $defaults{$args[$i]} =~ s/"/\\"/g;
596 }
597 $proto_arg[$i+1] = '$' ;
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 &&
616 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
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
YST		 635EOF
636 print Q(<<"EOF") if $ALIAS ;
637# dXSI32;
638EOF
639 print Q(<<"EOF") if $INTERFACE ;
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;
c4a6f826 683 $cond = ''; # last CASE: conditional
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 = "";
698 %arg_list = () ;
699 $gotRETVAL = 0;
700
701 INPUT_handler() ;
702 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
703
704 print Q(<<"EOF") if $ScopeThisXSUB;
705# ENTER;
706# [[
707EOF
708
709 if (!$thisdone && defined($class)) {
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 }
720 }
721
722 # do code
723 if (/^\s*NOT_IMPLEMENTED_YET/) {
724 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
725 $_ = '' ;
726 } else {
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;
740 INPUT_handler() ;
741 }
742 print $deferred;
743
744 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
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")) {
752 print_section() ;
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 }
774 }
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
782 # do output variables
783 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
784 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
785 # $wantRETVAL set if 'RETVAL =' autogenerated
786 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
787 undef %outargs ;
788 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
789
790 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
791 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
792
793 # all OUTPUT done, so now push the return value on the stack
794 if ($gotRETVAL && $RETVAL_code) {
795 print "\t$RETVAL_code\n";
796 } elsif ($gotRETVAL || $wantRETVAL) {
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') {
c4a6f826 803 # PUSHp corresponds to setpvn. Treat setpv directly
6b09c160
YST		 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 }
825 }
826
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;
834
835 # do cleanup
836 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
837
838 print Q(<<"EOF") if $ScopeThisXSUB;
839# ]]
840EOF
841 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
842# LEAVE;
843EOF
844
845 # print function trailer
846 print Q(<<"EOF");
847# ]]
848EOF
849 print Q(<<"EOF") if $except;
850# BEGHANDLERS
851# CATCHALL
852# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
853# ENDHANDLERS
854EOF
855 if (check_keyword("CASE")) {
856 blurt ("Error: No `CASE:' at top of function")
857 unless $condnum;
858 $_ = "CASE: $_"; # Restore CASE: label
859 next;
860 }
861 last if $_ eq "$END:";
28892255 862 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
6b09c160
YST		 863 }
864
865 print Q(<<"EOF") if $except;
866# if (errbuf[0])
867# Perl_croak(aTHX_ errbuf);
868EOF
869
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
28892255
DG		 885 our $newXS = "newXS" ;
886 our $proto = "" ;
6b09c160
YST		 887
888 # Build the prototype string for the xsub
889 if ($ProtoThisXSUB) {
28892255 890 $newXS = "newXSproto_portable";
6b09c160
YST		 891
892 if ($ProtoThisXSUB eq 2) {
893 # User has specified empty prototype
894 }
895 elsif ($ProtoThisXSUB eq 1) {
896 my $s = ';';
897 if ($min_args < $num_args) {
898 $s = '';
899 $proto_arg[$min_args] .= ";" ;
900 }
901 push @proto_arg, "$s\@"
95b611b0 902 if $ellipsis ;
6b09c160
YST		 903
904 $proto = join ("", grep defined, @proto_arg);
905 }
906 else {
907 # User has specified a prototype
908 $proto = $ProtoThisXSUB;
909 }
910 $proto = qq{, "$proto"};
911 }
28892255 912
6b09c160
YST		 913 if (%XsubAliases) {
914 $XsubAliases{$pname} = 0
915 unless defined $XsubAliases{$pname} ;
916 while ( ($name, $value) = each %XsubAliases) {
917 push(@InitFileCode, Q(<<"EOF"));
28892255 918# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
6b09c160
YST		 919# XSANY.any_i32 = $value ;
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) {
931 $name = "$Package\::$name" unless $name =~ /::/;
932 push(@InitFileCode, Q(<<"EOF"));
28892255 933# cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
6b09c160
YST		 934# $interface_macro_set(cv,$value) ;
935EOF
6b09c160
YST		 936 }
937 }
387b6f8d
S		 938 elsif($newXS eq 'newXS'){ # work around P5NCI's empty newXS macro
939 push(@InitFileCode,
940 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
941 }
6b09c160
YST		 942 else {
943 push(@InitFileCode,
28892255 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 */
1e8125c6
FR		 1007##ifdef XS_APIVERSION_BOOTCHECK
1008# XS_APIVERSION_BOOTCHECK;
1009##endif
6b09c160 1010EOF
1e8125c6 1011
6b09c160
YST		 1012 print Q(<<"EOF") if $WantVersionChk ;
1013# XS_VERSION_BOOTCHECK ;
1014#
1015EOF
1016
1017 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1018# {
1019# CV * cv ;
1020#
1021EOF
1022
1023 print Q(<<"EOF") if ($Overload);
1024# /* register the overloading (type 'A') magic */
1025# PL_amagic_generation++;
1026# /* The magic for overload gets a GV* via gv_fetchmeth as */
1027# /* mentioned above, and looks in the SV* slot of it for */
1028# /* the "fallback" status. */
1029# sv_setsv(
1030# get_sv( "${Package}::()", TRUE ),
1031# $Fallback
1032# );
1033EOF
1034
1035 print @InitFileCode;
1036
1037 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1038# }
1039EOF
1040
1041 if (@BootCode)
1042 {
1043 print "\n /* Initialisation Section */\n\n" ;
1044 @line = @BootCode;
1045 print_section();
1046 print "\n /* End of Initialisation Section */\n\n" ;
1047 }
1048
1cb9da9d
DG		 1049 print Q(<<'EOF');
1050##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
1051# if (PL_unitcheckav)
1052# call_list(PL_scopestack_ix, PL_unitcheckav);
1053##endif
0932863f 1054EOF
89345840 1055
6b09c160
YST		 1056 print Q(<<"EOF");
1057# XSRETURN_YES;
1058#]]
1059#
1060EOF
1061
1062 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1063 unless $ProtoUsed ;
1064
1065 chdir($orig_cwd);
1066 select($orig_fh);
1067 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
907ce46c 1068 close $FH;
6b09c160
YST		 1069
1070 return 1;
1071}
1072
1073sub errors { $errors }
1074
1075sub standard_typemap_locations {
1076 # Add all the default typemap locations to the search path
1077 my @tm = qw(typemap);
1078
1079 my $updir = File::Spec->updir;
1080 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1081 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1082
1083 unshift @tm, File::Spec->catfile($dir, 'typemap');
1084 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1085 }
1086 foreach my $dir (@INC) {
1087 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1088 unshift @tm, $file if -e $file;
1089 }
1090 return @tm;
1091}
1092
1093sub TrimWhitespace
1094{
1095 $_[0] =~ s/^\s+|\s+$//go ;
1096}
1097
1098sub TidyType
1099 {
1100 local ($_) = @_ ;
1101
1102 # rationalise any '*' by joining them into bunches and removing whitespace
1103 s#\s*(\*+)\s*#$1#g;
1104 s#(\*+)# $1 #g ;
1105
1106 # change multiple whitespace into a single space
1107 s/\s+/ /g ;
1108
1109 # trim leading & trailing whitespace
1110 TrimWhitespace($_) ;
1111
1112 $_ ;
1113}
1114
1115# Input: ($_, @line) == unparsed input.
1116# Output: ($_, @line) == (rest of line, following lines).
1117# Return: the matched keyword if found, otherwise 0
1118sub check_keyword {
1119 $_ = shift(@line) while !/\S/ && @line;
1120 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1121}
1122
1123sub print_section {
1124 # the "do" is required for right semantics
1125 do { $_ = shift(@line) } while !/\S/ && @line;
1126
1127 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1128 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1129 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1130 print "$_\n";
1131 }
1132 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1133}
1134
1135sub merge_section {
1136 my $in = '';
1137
1138 while (!/\S/ && @line) {
1139 $_ = shift(@line);
1140 }
1141
1142 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1143 $in .= "$_\n";
1144 }
1145 chomp $in;
1146 return $in;
1147 }
1148
1149sub process_keyword($)
1150 {
1151 my($pattern) = @_ ;
1152 my $kwd ;
1153
1154 &{"${kwd}_handler"}()
1155 while $kwd = check_keyword($pattern) ;
1156 }
1157
1158sub CASE_handler {
1159 blurt ("Error: `CASE:' after unconditional `CASE:'")
1160 if $condnum && $cond eq '';
1161 $cond = $_;
1162 TrimWhitespace($cond);
1163 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1164 $_ = '' ;
1165}
1166
1167sub INPUT_handler {
1168 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1169 last if /^\s*NOT_IMPLEMENTED_YET/;
1170 next unless /\S/; # skip blank lines
1171
1172 TrimWhitespace($_) ;
1173 my $line = $_ ;
1174
1175 # remove trailing semicolon if no initialisation
1176 s/\s*;$//g unless /[=;+].*\S/ ;
1177
1178 # Process the length(foo) declarations
1179 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1180 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1181 $lengthof{$2} = $name;
1182 # $islengthof{$name} = $1;
1cb9da9d 1183 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
6b09c160
YST		 1184 }
1185
1186 # check for optional initialisation code
1187 my $var_init = '' ;
1188 $var_init = $1 if s/\s*([=;+].*)$//s ;
1189 $var_init =~ s/"/\\"/g;
1190
1191 s/\s+/ /g;
1192 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1193 or blurt("Error: invalid argument declaration '$line'"), next;
1194
1195 # Check for duplicate definitions
1196 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1197 if $arg_list{$var_name}++
1198 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1199
1200 $thisdone |= $var_name eq "THIS";
1201 $retvaldone |= $var_name eq "RETVAL";
1202 $var_types{$var_name} = $var_type;
1203 # XXXX This check is a safeguard against the unfinished conversion of
1204 # generate_init(). When generate_init() is fixed,
1205 # one can use 2-args map_type() unconditionally.
1206 if ($var_type =~ / \( \s* \* \s* \) /x) {
1207 # Function pointers are not yet supported with &output_init!
1208 print "\t" . &map_type($var_type, $var_name);
1209 $name_printed = 1;
1210 } else {
1211 print "\t" . &map_type($var_type);
1212 $name_printed = 0;
1213 }
1214 $var_num = $args_match{$var_name};
1215
1216 $proto_arg[$var_num] = ProtoString($var_type)
1217 if $var_num ;
1218 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1219 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1220 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1221 and $var_init !~ /\S/) {
1222 if ($name_printed) {
1223 print ";\n";
1224 } else {
1225 print "\t$var_name;\n";
1226 }
1227 } elsif ($var_init =~ /\S/) {
1228 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1229 } elsif ($var_num) {
1230 # generate initialization code
1231 &generate_init($var_type, $var_num, $var_name, $name_printed);
1232 } else {
1233 print ";\n";
1234 }
1235 }
1236}
1237
1238sub OUTPUT_handler {
1239 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1240 next unless /\S/;
1241 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1242 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1243 next;
1244 }
1245 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1246 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1247 if $outargs{$outarg} ++ ;
1248 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1249 # deal with RETVAL last
1250 $RETVAL_code = $outcode ;
1251 $gotRETVAL = 1 ;
1252 next ;
1253 }
1254 blurt ("Error: OUTPUT $outarg not an argument"), next
1255 unless defined($args_match{$outarg});
1256 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1257 unless defined $var_types{$outarg} ;
1258 $var_num = $args_match{$outarg};
1259 if ($outcode) {
1260 print "\t$outcode\n";
1261 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1262 } else {
1263 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1264 }
1265 delete $in_out{$outarg} # No need to auto-OUTPUT
1266 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1267 }
1268}
1269
1270sub C_ARGS_handler() {
1271 my $in = merge_section();
1272
1273 TrimWhitespace($in);
1274 $func_args = $in;
1275}
1276
1277sub INTERFACE_MACRO_handler() {
1278 my $in = merge_section();
1279
1280 TrimWhitespace($in);
1281 if ($in =~ /\s/) { # two
1282 ($interface_macro, $interface_macro_set) = split ' ', $in;
1283 } else {
1284 $interface_macro = $in;
1285 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1286 }
1287 $interface = 1; # local
1288 $Interfaces = 1; # global
1289}
1290
1291sub INTERFACE_handler() {
1292 my $in = merge_section();
1293
1294 TrimWhitespace($in);
1295
1296 foreach (split /[\s,]+/, $in) {
5331dc36
SP		 1297 my $name = $_;
1298 $name =~ s/^$Prefix//;
1299 $Interfaces{$name} = $_;
6b09c160
YST		 1300 }
1301 print Q(<<"EOF");
1302# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1303EOF
1304 $interface = 1; # local
1305 $Interfaces = 1; # global
1306}
1307
1308sub CLEANUP_handler() { print_section() }
1309sub PREINIT_handler() { print_section() }
1310sub POSTCALL_handler() { print_section() }
1311sub INIT_handler() { print_section() }
1312
1313sub GetAliases
1314 {
1315 my ($line) = @_ ;
1316 my ($orig) = $line ;
1317 my ($alias) ;
1318 my ($value) ;
1319
1320 # Parse alias definitions
1321 # format is
1322 # alias = value alias = value ...
1323
1324 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1325 $alias = $1 ;
1326 $orig_alias = $alias ;
1327 $value = $2 ;
1328
1329 # check for optional package definition in the alias
1330 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1331
1332 # check for duplicate alias name & duplicate value
1333 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1334 if defined $XsubAliases{$alias} ;
1335
1336 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1337 if $XsubAliasValues{$value} ;
1338
1339 $XsubAliases = 1;
1340 $XsubAliases{$alias} = $value ;
1341 $XsubAliasValues{$value} = $orig_alias ;
1342 }
1343
1344 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1345 if $line ;
1346 }
1347
1348sub ATTRS_handler ()
1349 {
1350 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1351 next unless /\S/;
1352 TrimWhitespace($_) ;
1353 push @Attributes, $_;
1354 }
1355 }
1356
1357sub ALIAS_handler ()
1358 {
1359 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1360 next unless /\S/;
1361 TrimWhitespace($_) ;
1362 GetAliases($_) if $_ ;
1363 }
1364 }
1365
1366sub OVERLOAD_handler()
1367{
1368 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1369 next unless /\S/;
1370 TrimWhitespace($_) ;
1371 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1372 $Overload = 1 unless $Overload;
1373 my $overload = "$Package\::(".$1 ;
1374 push(@InitFileCode,
28892255 1375 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
6b09c160
YST		 1376 }
1377 }
1378}
1379
1380sub FALLBACK_handler()
1381{
1382 # the rest of the current line should contain either TRUE,
1383 # FALSE or UNDEF
1384
1385 TrimWhitespace($_) ;
1386 my %map = (
68746769
SP		 1387 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1388 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1389 UNDEF => "&PL_sv_undef",
6b09c160
YST		 1390 ) ;
1391
1392 # check for valid FALLBACK value
1393 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1394
1395 $Fallback = $map{uc $_} ;
1396}
1397
1398
1399sub REQUIRE_handler ()
1400 {
1401 # the rest of the current line should contain a version number
1402 my ($Ver) = $_ ;
1403
1404 TrimWhitespace($Ver) ;
1405
1406 death ("Error: REQUIRE expects a version number")
1407 unless $Ver ;
1408
1409 # check that the version number is of the form n.n
1410 death ("Error: REQUIRE: expected a number, got '$Ver'")
1411 unless $Ver =~ /^\d+(\.\d*)?/ ;
1412
1413 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1414 unless $VERSION >= $Ver ;
1415 }
1416
1417sub VERSIONCHECK_handler ()
1418 {
1419 # the rest of the current line should contain either ENABLE or
1420 # DISABLE
1421
1422 TrimWhitespace($_) ;
1423
1424 # check for ENABLE/DISABLE
1425 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1426 unless /^(ENABLE|DISABLE)/i ;
1427
1428 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1429 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1430
1431 }
1432
1433sub PROTOTYPE_handler ()
1434 {
1435 my $specified ;
1436
1437 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1438 if $proto_in_this_xsub ++ ;
1439
1440 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1441 next unless /\S/;
1442 $specified = 1 ;
1443 TrimWhitespace($_) ;
1444 if ($_ eq 'DISABLE') {
1445 $ProtoThisXSUB = 0
1446 } elsif ($_ eq 'ENABLE') {
1447 $ProtoThisXSUB = 1
1448 } else {
1449 # remove any whitespace
1450 s/\s+//g ;
1451 death("Error: Invalid prototype '$_'")
1452 unless ValidProtoString($_) ;
1453 $ProtoThisXSUB = C_string($_) ;
1454 }
1455 }
1456
1457 # If no prototype specified, then assume empty prototype ""
1458 $ProtoThisXSUB = 2 unless $specified ;
1459
1460 $ProtoUsed = 1 ;
1461
1462 }
1463
1464sub SCOPE_handler ()
1465 {
1466 death("Error: Only 1 SCOPE declaration allowed per xsub")
1467 if $scope_in_this_xsub ++ ;
1468
28892255
DG		 1469 TrimWhitespace($_);
1470 death ("Error: SCOPE: ENABLE/DISABLE")
1471 unless /^(ENABLE|DISABLE)\b/i;
1472 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
6b09c160
YST		 1473 }
1474
1475sub PROTOTYPES_handler ()
1476 {
1477 # the rest of the current line should contain either ENABLE or
1478 # DISABLE
1479
1480 TrimWhitespace($_) ;
1481
1482 # check for ENABLE/DISABLE
1483 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1484 unless /^(ENABLE|DISABLE)/i ;
1485
1486 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1487 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1488 $ProtoUsed = 1 ;
1489
1490 }
1491
387b6f8d
S		 1492sub PushXSStack
1493 {
494e8c4c 1494 my %args = @_;
387b6f8d
S		 1495 # Save the current file context.
1496 push(@XSStack, {
1497 type => 'file',
1498 LastLine => $lastline,
1499 LastLineNo => $lastline_no,
1500 Line => \@line,
1501 LineNo => \@line_no,
1502 Filename => $filename,
1503 Filepathname => $filepathname,
1504 Handle => $FH,
494e8c4c
CBW		 1505 IsPipe => scalar($filename =~ /\|\s*$/),
1506 %args,
387b6f8d
S		 1507 }) ;
1508
1509 }
1510
6b09c160
YST		 1511sub INCLUDE_handler ()
1512 {
1513 # the rest of the current line should contain a valid filename
1514
1515 TrimWhitespace($_) ;
1516
1517 death("INCLUDE: filename missing")
1518 unless $_ ;
1519
1520 death("INCLUDE: output pipe is illegal")
1521 if /^\s*\|/ ;
1522
1523 # simple minded recursion detector
1524 death("INCLUDE loop detected")
1525 if $IncludedFiles{$_} ;
1526
1527 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1528
387b6f8d
S		 1529 if (/\|\s*$/ && /^\s*perl\s/) {
1530 Warn("The INCLUDE directive with a command is discouraged." .
1531 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1532 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1533 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1534 " the use of \$^X as the currently running perl, see" .
1535 " 'perldoc perlxs' for details.");
1536 }
1537
1538 PushXSStack();
6b09c160 1539
907ce46c 1540 $FH = Symbol::gensym();
6b09c160
YST		 1541
1542 # open the new file
1543 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1544
1545 print Q(<<"EOF");
1546#
1547#/* INCLUDE: Including '$_' from '$filename' */
1548#
1549EOF
1550
28892255 1551 $filename = $_ ;
494e8c4c 1552 $filepathname = File::Spec->catfile($dir, $filename);
6b09c160
YST		 1553
1554 # Prime the pump by reading the first
1555 # non-blank line
1556
1557 # skip leading blank lines
1558 while (<$FH>) {
1559 last unless /^\s*$/ ;
1560 }
1561
1562 $lastline = $_ ;
1563 $lastline_no = $. ;
387b6f8d
S		 1564 }
1565
494e8c4c
CBW		 1566sub QuoteArgs {
1567 my $cmd = shift;
1568 my @args = split /\s+/, $cmd;
1569 $cmd = shift @args;
1570 for (@args) {
1571 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
1572 }
1573 return join (' ', ($cmd, @args));
1574 }
1575
387b6f8d
S		 1576sub INCLUDE_COMMAND_handler ()
1577 {
1578 # the rest of the current line should contain a valid command
1579
1580 TrimWhitespace($_) ;
1581
494e8c4c
CBW		 1582 $_ = QuoteArgs($_) if $^O eq 'VMS';
1583
387b6f8d
S		 1584 death("INCLUDE_COMMAND: command missing")
1585 unless $_ ;
1586
1587 death("INCLUDE_COMMAND: pipes are illegal")
1588 if /^\s*\|/ or /\|\s*$/ ;
1589
494e8c4c 1590 PushXSStack( IsPipe => 1 );
387b6f8d
S		 1591
1592 $FH = Symbol::gensym();
1593
1594 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1595 # the same perl interpreter as we're currently running
1596 s/^\s*\$\^X/$^X/;
1597
1598 # open the new file
1599 open ($FH, "-|", "$_")
1600 or death("Cannot run command '$_' to include its output: $!") ;
1601
1602 print Q(<<"EOF");
1603#
1604#/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */
1605#
1606EOF
1607
1608 $filename = $_ ;
494e8c4c
CBW		 1609 $filepathname = $filename;
1610 $filepathname =~ s/\"/\\"/g;
387b6f8d
S		 1611
1612 # Prime the pump by reading the first
1613 # non-blank line
6b09c160 1614
387b6f8d
S		 1615 # skip leading blank lines
1616 while (<$FH>) {
1617 last unless /^\s*$/ ;
1618 }
1619
1620 $lastline = $_ ;
1621 $lastline_no = $. ;
6b09c160
YST		 1622 }
1623
1624sub PopFile()
1625 {
1626 return 0 unless $XSStack[-1]{type} eq 'file' ;
1627
1628 my $data = pop @XSStack ;
1629 my $ThisFile = $filename ;
494e8c4c 1630 my $isPipe = $data->{IsPipe};
6b09c160
YST		 1631
1632 -- $IncludedFiles{$filename}
1633 unless $isPipe ;
1634
1635 close $FH ;
1636
1637 $FH = $data->{Handle} ;
d724ebe1
NC		 1638 # $filename is the leafname, which for some reason isused for diagnostic
1639 # messages, whereas $filepathname is the full pathname, and is used for
1640 # #line directives.
6b09c160 1641 $filename = $data->{Filename} ;
d724ebe1 1642 $filepathname = $data->{Filepathname} ;
6b09c160
YST		 1643 $lastline = $data->{LastLine} ;
1644 $lastline_no = $data->{LastLineNo} ;
1645 @line = @{ $data->{Line} } ;
1646 @line_no = @{ $data->{LineNo} } ;
1647
1648 if ($isPipe and $? ) {
1649 -- $lastline_no ;
1650 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1651 exit 1 ;
1652 }
1653
1654 print Q(<<"EOF");
1655#
1656#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1657#
1658EOF
1659
1660 return 1 ;
1661 }
1662
1663sub ValidProtoString ($)
1664 {
1665 my($string) = @_ ;
1666
1667 if ( $string =~ /^$proto_re+$/ ) {
1668 return $string ;
1669 }
1670
1671 return 0 ;
1672 }
1673
1674sub C_string ($)
1675 {
1676 my($string) = @_ ;
1677
1678 $string =~ s[\\][\\\\]g ;
1679 $string ;
1680 }
1681
1682sub ProtoString ($)
1683 {
1684 my ($type) = @_ ;
1685
1686 $proto_letter{$type} or "\$" ;
1687 }
1688
1689sub check_cpp {
1690 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1691 if (@cpp) {
1692 my ($cpp, $cpplevel);
1693 for $cpp (@cpp) {
1694 if ($cpp =~ /^\#\s*if/) {
1695 $cpplevel++;
1696 } elsif (!$cpplevel) {
1697 Warn("Warning: #else/elif/endif without #if in this function");
1698 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1699 if $XSStack[-1]{type} eq 'if';
1700 return;
1701 } elsif ($cpp =~ /^\#\s*endif/) {
1702 $cpplevel--;
1703 }
1704 }
1705 Warn("Warning: #if without #endif in this function") if $cpplevel;
1706 }
1707}
1708
1709
1710sub Q {
1711 my($text) = @_;
1712 $text =~ s/^#//gm;
1713 $text =~ s/\[\[/{/g;
1714 $text =~ s/\]\]/}/g;
1715 $text;
1716}
1717
1718# Read next xsub into @line from ($lastline, <$FH>).
1719sub fetch_para {
1720 # parse paragraph
1721 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1722 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1723 @line = ();
1724 @line_no = () ;
1725 return PopFile() if !defined $lastline;
1726
1727 if ($lastline =~
1728 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1729 $Module = $1;
1730 $Package = defined($2) ? $2 : ''; # keep -w happy
1731 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1732 $Prefix = quotemeta $Prefix ;
1733 ($Module_cname = $Module) =~ s/\W/_/g;
1734 ($Packid = $Package) =~ tr/:/_/;
1735 $Packprefix = $Package;
1736 $Packprefix .= "::" if $Packprefix ne "";
1737 $lastline = "";
1738 }
1739
1740 for (;;) {
1741 # Skip embedded PODs
1742 while ($lastline =~ /^=/) {
1743 while ($lastline = <$FH>) {
1744 last if ($lastline =~ /^=cut\s*$/);
1745 }
1746 death ("Error: Unterminated pod") unless $lastline;
1747 $lastline = <$FH>;
1748 chomp $lastline;
1749 $lastline =~ s/^\s+$//;
1750 }
1751 if ($lastline !~ /^\s*#/ ||
1752 # CPP directives:
1753 # ANSI: if ifdef ifndef elif else endif define undef
1754 # line error pragma
1755 # gcc: warning include_next
1756 # obj-c: import
1757 # others: ident (gcc notes that some cpps have this one)
1758 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1759 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1760 push(@line, $lastline);
1761 push(@line_no, $lastline_no) ;
1762 }
1763
1764 # Read next line and continuation lines
1765 last unless defined($lastline = <$FH>);
1766 $lastline_no = $.;
1767 my $tmp_line;
1768 $lastline .= $tmp_line
1769 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1770
1771 chomp $lastline;
1772 $lastline =~ s/^\s+$//;
1773 }
1774 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1775 1;
1776}
1777
1778sub output_init {
1779 local($type, $num, $var, $init, $name_printed) = @_;
1780 local($arg) = "ST(" . ($num - 1) . ")";
1781
1782 if ( $init =~ /^=/ ) {
1783 if ($name_printed) {
1784 eval qq/print " $init\\n"/;
1785 } else {
1786 eval qq/print "\\t$var $init\\n"/;
1787 }
1788 warn $@ if $@;
1789 } else {
1790 if ( $init =~ s/^\+// && $num ) {
1791 &generate_init($type, $num, $var, $name_printed);
1792 } elsif ($name_printed) {
1793 print ";\n";
1794 $init =~ s/^;//;
1795 } else {
1796 eval qq/print "\\t$var;\\n"/;
1797 warn $@ if $@;
1798 $init =~ s/^;//;
1799 }
1800 $deferred .= eval qq/"\\n\\t$init\\n"/;
1801 warn $@ if $@;
1802 }
1803}
1804
1805sub Warn
1806 {
1807 # work out the line number
1808 my $line_no = $line_no[@line_no - @line -1] ;
1809
1810 print STDERR "@_ in $filename, line $line_no\n" ;
1811 }
1812
1813sub blurt
1814 {
1815 Warn @_ ;
1816 $errors ++
1817 }
1818
1819sub death
1820 {
1821 Warn @_ ;
1822 exit 1 ;
1823 }
1824
1825sub generate_init {
1826 local($type, $num, $var) = @_;
1827 local($arg) = "ST(" . ($num - 1) . ")";
1828 local($argoff) = $num - 1;
1829 local($ntype);
1830 local($tk);
1831
1832 $type = TidyType($type) ;
1833 blurt("Error: '$type' not in typemap"), return
1834 unless defined($type_kind{$type});
1835
1836 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1837 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1838 $tk = $type_kind{$type};
1839 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1840 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1841 print "\t$var" unless $name_printed;
1842 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1843 die "default value not supported with length(NAME) supplied"
1844 if defined $defaults{$var};
1845 return;
1846 }
1847 $type =~ tr/:/_/ unless $hiertype;
1848 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1849 unless defined $input_expr{$tk} ;
1850 $expr = $input_expr{$tk};
1851 if ($expr =~ /DO_ARRAY_ELEM/) {
1852 blurt("Error: '$subtype' not in typemap"), return
1853 unless defined($type_kind{$subtype});
1854 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1855 unless defined $input_expr{$type_kind{$subtype}} ;
1856 $subexpr = $input_expr{$type_kind{$subtype}};
1857 $subexpr =~ s/\$type/\$subtype/g;
1858 $subexpr =~ s/ntype/subtype/g;
1859 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1860 $subexpr =~ s/\n\t/\n\t\t/g;
1861 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1862 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1863 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1864 }
1865 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1866 $ScopeThisXSUB = 1;
1867 }
1868 if (defined($defaults{$var})) {
1869 $expr =~ s/(\t+)/$1 /g;
1870 $expr =~ s/ /\t/g;
1871 if ($name_printed) {
1872 print ";\n";
1873 } else {
1874 eval qq/print "\\t$var;\\n"/;
1875 warn $@ if $@;
1876 }
1877 if ($defaults{$var} eq 'NO_INIT') {
1878 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1879 } else {
1880 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1881 }
1882 warn $@ if $@;
1883 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1884 if ($name_printed) {
1885 print ";\n";
1886 } else {
1887 eval qq/print "\\t$var;\\n"/;
1888 warn $@ if $@;
1889 }
1890 $deferred .= eval qq/"\\n$expr;\\n"/;
1891 warn $@ if $@;
1892 } else {
1893 die "panic: do not know how to handle this branch for function pointers"
1894 if $name_printed;
1895 eval qq/print "$expr;\\n"/;
1896 warn $@ if $@;
1897 }
1898}
1899
1900sub generate_output {
1901 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1902 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1903 local($argoff) = $num - 1;
1904 local($ntype);
1905
1906 $type = TidyType($type) ;
1907 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1908 print "\t$arg = sv_newmortal();\n";
1909 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1910 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1911 } else {
1912 blurt("Error: '$type' not in typemap"), return
1913 unless defined($type_kind{$type});
1914 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1915 unless defined $output_expr{$type_kind{$type}} ;
1916 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1917 $ntype =~ s/\(\)//g;
1918 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1919 $expr = $output_expr{$type_kind{$type}};
1920 if ($expr =~ /DO_ARRAY_ELEM/) {
1921 blurt("Error: '$subtype' not in typemap"), return
1922 unless defined($type_kind{$subtype});
1923 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1924 unless defined $output_expr{$type_kind{$subtype}} ;
1925 $subexpr = $output_expr{$type_kind{$subtype}};
1926 $subexpr =~ s/ntype/subtype/g;
1927 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1928 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1929 $subexpr =~ s/\n\t/\n\t\t/g;
1930 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1931 eval "print qq\a$expr\a";
1932 warn $@ if $@;
1933 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1934 } elsif ($var eq 'RETVAL') {
1935 if ($expr =~ /^\t\$arg = new/) {
1936 # We expect that $arg has refcnt 1, so we need to
1937 # mortalize it.
1938 eval "print qq\a$expr\a";
1939 warn $@ if $@;
1940 print "\tsv_2mortal(ST($num));\n";
1941 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1942 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1943 # We expect that $arg has refcnt >=1, so we need
1944 # to mortalize it!
1945 eval "print qq\a$expr\a";
1946 warn $@ if $@;
1947 print "\tsv_2mortal(ST(0));\n";
1948 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1949 } else {
1950 # Just hope that the entry would safely write it
1951 # over an already mortalized value. By
1952 # coincidence, something like $arg = &sv_undef
1953 # works too.
1954 print "\tST(0) = sv_newmortal();\n";
1955 eval "print qq\a$expr\a";
1956 warn $@ if $@;
1957 # new mortals don't have set magic
1958 }
1959 } elsif ($do_push) {
1960 print "\tPUSHs(sv_newmortal());\n";
1961 $arg = "ST($num)";
1962 eval "print qq\a$expr\a";
1963 warn $@ if $@;
1964 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1965 } elsif ($arg =~ /^ST\(\d+\)$/) {
1966 eval "print qq\a$expr\a";
1967 warn $@ if $@;
1968 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1969 }
1970 }
1971}
1972
1973sub map_type {
1974 my($type, $varname) = @_;
1975
1976 # C++ has :: in types too so skip this
1977 $type =~ tr/:/_/ unless $hiertype;
1978 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1979 if ($varname) {
1980 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1981 (substr $type, pos $type, 0) = " $varname ";
1982 } else {
1983 $type .= "\t$varname";
1984 }
1985 }
1986 $type;
1987}
1988
1989
1990#########################################################
1991package
1992 ExtUtils::ParseXS::CountLines;
1993use strict;
1994use vars qw($SECTION_END_MARKER);
1995
1996sub TIEHANDLE {
1997 my ($class, $cfile, $fh) = @_;
1998 $cfile =~ s/\\/\\\\/g;
1999 $SECTION_END_MARKER = qq{#line --- "$cfile"};
2000
2001 return bless {buffer => '',
2002 fh => $fh,
2003 line_no => 1,
2004 }, $class;
2005}
2006
2007sub PRINT {
2008 my $self = shift;
2009 for (@_) {
2010 $self->{buffer} .= $_;
2011 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
2012 my $line = $1;
2013 ++ $self->{line_no};
2014 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
2015 print {$self->{fh}} $line;
2016 }
2017 }
2018}
2019
2020sub PRINTF {
2021 my $self = shift;
2022 my $fmt = shift;
2023 $self->PRINT(sprintf($fmt, @_));
2024}
2025
2026sub DESTROY {
2027 # Not necessary if we're careful to end with a "\n"
2028 my $self = shift;
2029 print {$self->{fh}} $self->{buffer};
2030}
2031
2032sub UNTIE {
c4a6f826 2033 # This sub does nothing, but is necessary for references to be released.
6b09c160
YST		 2034}
2035
2036sub end_marker {
2037 return $SECTION_END_MARKER;
2038}
2039
2040
20411;
2042__END__
2043
2044=head1 NAME
2045
2046ExtUtils::ParseXS - converts Perl XS code into C code
2047
2048=head1 SYNOPSIS
2049
2050 use ExtUtils::ParseXS qw(process_file);
2051
2052 process_file( filename => 'foo.xs' );
2053
2054 process_file( filename => 'foo.xs',
2055 output => 'bar.c',
2056 'C++' => 1,
2057 typemap => 'path/to/typemap',
2058 hiertype => 1,
2059 except => 1,
2060 prototypes => 1,
2061 versioncheck => 1,
2062 linenumbers => 1,
2063 optimize => 1,
2064 prototypes => 1,
2065 );
2066=head1 DESCRIPTION
2067
2068C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
2069necessary to let C functions manipulate Perl values and creates the glue
2070necessary to let Perl access those functions. The compiler uses typemaps to
2071determine how to map C function parameters and variables to Perl values.
2072
2073The compiler will search for typemap files called I<typemap>. It will use
2074the following search path to find default typemaps, with the rightmost
2075typemap taking precedence.
2076
2077 ../../../typemap:../../typemap:../typemap:typemap
2078
2079=head1 EXPORT
2080
2081None by default. C<process_file()> may be exported upon request.
2082
2083
2084=head1 FUNCTIONS
2085
2086=over 4
2087
2088=item process_xs()
2089
2090This function processes an XS file and sends output to a C file.
2091Named parameters control how the processing is done. The following
2092parameters are accepted:
2093
2094=over 4
2095
2096=item B<C++>
2097
2098Adds C<extern "C"> to the C code. Default is false.
2099
2100=item B<hiertype>
2101
c4a6f826 2102Retains C<::> in type names so that C++ hierarchical types can be
6b09c160
YST		 2103mapped. Default is false.
2104
2105=item B<except>
2106
2107Adds exception handling stubs to the C code. Default is false.
2108
2109=item B<typemap>
2110
2111Indicates that a user-supplied typemap should take precedence over the
2112default typemaps. A single typemap may be specified as a string, or
2113multiple typemaps can be specified in an array reference, with the
2114last typemap having the highest precedence.
2115
2116=item B<prototypes>
2117
2118Generates prototype code for all xsubs. Default is false.
2119
2120=item B<versioncheck>
2121
2122Makes sure at run time that the object file (derived from the C<.xs>
2123file) and the C<.pm> files have the same version number. Default is
2124true.
2125
2126=item B<linenumbers>
2127
2128Adds C<#line> directives to the C output so error messages will look
2129like they came from the original XS file. Default is true.
2130
2131=item B<optimize>
2132
2133Enables certain optimizations. The only optimization that is currently
2134affected is the use of I<target>s by the output C code (see L<perlguts>).
2135Not optimizing may significantly slow down the generated code, but this is the way
2136B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2137
2138=item B<inout>
2139
2140Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2141declarations. Default is true.
2142
2143=item B<argtypes>
2144
2145Enable recognition of ANSI-like descriptions of function signature.
2146Default is true.
2147
2148=item B<s>
2149
2150I have no clue what this does. Strips function prefixes?
2151
2152=back
2153
2154=item errors()
2155
2156This function returns the number of [a certain kind of] errors
2157encountered during processing of the XS file.
2158
2159=back
2160
2161=head1 AUTHOR
2162
2163Based on xsubpp code, written by Larry Wall.
2164
28892255
DG		 2165Maintained by:
2166
2167=over 4
2168
2169=item *
2170
2171Ken Williams, <ken@mathforum.org>
2172
2173=item *
2174
2175David Golden, <dagolden@cpan.org>
2176
2177=back
6b09c160
YST		 2178
2179=head1 COPYRIGHT
2180
28892255
DG		 2181Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All
2182rights reserved.
6b09c160
YST		 2183
2184This library is free software; you can redistribute it and/or
2185modify it under the same terms as Perl itself.
2186
2187Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2188Porters, which was released under the same license terms.
2189
2190=head1 SEE ALSO
2191
2192L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.
2193
2194=cut
Unnamed repository; edit this file 'description' to name the repository.