source: for-distributions/trunk/bin/windows/perl/bin/xsubpp.bat@ 14489

Last change on this file since 14489 was 14489, checked in by oranfry, 17 years ago

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