5 xsubpp - compiler to convert Perl XS code into C code
9 B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-typemap typemap>]... file.xs
13 I<xsubpp> will compile XS code into C code by embedding the constructs
14 necessary to let C functions manipulate Perl values and creates the glue
15 necessary to let Perl access those functions. The compiler uses typemaps to
16 determine how to map C function parameters and variables to Perl values.
18 The compiler will search for typemap files called I<typemap>. It will use
19 the following search path to find default typemaps, with the rightmost
20 typemap taking precedence.
22 ../../../typemap:../../typemap:../typemap:typemap
30 Adds ``extern "C"'' to the C code.
35 Adds exception handling stubs to the C code.
37 =item B<-typemap typemap>
39 Indicates that a user-supplied typemap should take precedence over the
40 default typemaps. This option may be used multiple times, with the last
41 typemap having the highest precedence.
45 Prints the I<xsubpp> version number to standard output, then exits.
51 No environment variables are used.
57 =head1 MODIFICATION HISTORY
59 See the file F<changes.pod>.
68 $XSUBPP_version = "1.923";
71 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-s pattern] [-typemap typemap]... file.xs\n";
74 SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
77 $spat = shift, next SWITCH if $flag eq 's';
78 $cplusplus = 1, next SWITCH if $flag eq 'C++';
79 $except = " TRY", next SWITCH if $flag eq 'except';
80 push(@tm,shift), next SWITCH if $flag eq 'typemap';
81 (print "xsubpp version $XSUBPP_version\n"), exit
85 @ARGV == 1 or die $usage;
87 # Check for error message from VMS
88 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
89 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
90 or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
91 or ($dir, $filename) = ('.', $ARGV[0]);
96 $_[0] =~ s/^\s+|\s+$//go ;
103 # rationalise any '*' by joining them into bunches and removing whitespace
107 # change multiple whitespace into a single space
110 # trim leading & trailing whitespace
116 $typemap = shift @ARGV;
117 foreach $typemap (@tm) {
118 die "Can't find $typemap in $pwd\n" unless -r $typemap;
120 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
121 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
123 foreach $typemap (@tm) {
124 next unless -e $typemap ;
125 # skip directories, binary files etc.
126 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
128 open(TYPEMAP, $typemap)
129 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
135 if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
136 if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
137 if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
138 if ($mode eq 'Typemap') {
142 # skip blank lines and comment lines
143 next if /^$/ or /^#/ ;
144 my($type,$kind) = /^\s*(.*?\S)\s+(\S+)\s*$/ or
145 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next;
146 $type_kind{TidyType($type)} = $kind ;
151 elsif ($mode eq 'Input') {
153 $input_expr{$_} = '';
154 $current = \$input_expr{$_};
158 $output_expr{$_} = '';
159 $current = \$output_expr{$_};
165 foreach $key (keys %input_expr) {
166 $input_expr{$key} =~ s/\n+$//;
169 $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
171 # Match an XS keyword
172 $BLOCK_re= "\\s*(REQUIRE|BOOT|CASE|PREINIT|INPUT|INIT|CODE|PPCODE|OUTPUT|CLEANUP|ALIAS|$END)\\s*:";
174 # Input: ($_, @line) == unparsed input.
175 # Output: ($_, @line) == (rest of line, following lines).
176 # Return: the matched keyword if found, otherwise 0
178 $_ = shift(@line) while !/\S/ && @line;
179 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
184 $_ = shift(@line) while !/\S/ && @line;
185 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
191 blurt ("Error: `CASE:' after unconditional `CASE:'")
192 if $condnum && $cond eq '';
194 TrimWhitespace($cond);
195 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
200 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
201 last if /^\s*NOT_IMPLEMENTED_YET/;
202 next unless /\S/; # skip blank lines
207 # remove trailing semicolon if no initialisation
208 s/\s*;$//g unless /=/ ;
210 # check for optional initialisation code
212 $var_init = $1 if s/\s*(=.*)$//s ;
213 $var_init =~ s/"/\\"/g;
216 my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
217 or blurt("Error: invalid argument declaration '$line'"), next;
219 # Check for duplicate definitions
220 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
221 if $arg_list{$var_name} ++ ;
223 $thisdone |= $var_name eq "THIS";
224 $retvaldone |= $var_name eq "RETVAL";
225 $var_types{$var_name} = $var_type;
226 print "\t" . &map_type($var_type);
227 $var_num = $args_match{$var_name};
229 $var_addr{$var_name} = 1;
230 $func_args =~ s/\b($var_name)\b/&$1/;
232 if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
233 print "\t$var_name;\n";
234 } elsif ($var_init =~ /\S/) {
235 &output_init($var_type, $var_num, "$var_name $var_init");
237 # generate initialization code
238 &generate_init($var_type, $var_num, $var_name);
246 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
248 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
249 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
250 if $outargs{$outarg} ++ ;
251 if (!$gotRETVAL and $outarg eq 'RETVAL') {
252 # deal with RETVAL last
253 $RETVAL_code = $outcode ;
257 blurt ("Error: OUTPUT $outarg not an argument"), next
258 unless defined($args_match{$outarg});
259 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
260 unless defined $var_types{$outarg} ;
262 print "\t$outcode\n";
264 $var_num = $args_match{$outarg};
265 &generate_output($var_types{$outarg}, $var_num, $outarg);
277 # Parse alias definitions
279 # alias = value alias = value ...
281 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
283 $orig_alias = $alias ;
286 # check for optional package definition in the alias
287 $alias = $Packprefix . $alias if $alias !~ /::/ ;
289 # check for duplicate alias name & duplicate value
290 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
291 if defined $XsubAliases{$pname}{$alias} ;
293 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values")
294 if $XsubAliasValues{$pname}{$value} ;
296 $XsubAliases{$pname}{$alias} = $value ;
297 $XsubAliasValues{$pname}{$value} = $orig_alias ;
300 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
306 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
309 GetAliases($_) if $_ ;
315 # the rest of the current line should contain a version number
318 TrimWhitespace($Ver) ;
320 death ("Error: REQUIRE expects a version number")
323 # check that the version number is of the form n.n
324 death ("Error: REQUIRE: expected a number, got '$Ver'")
325 unless $Ver =~ /^\d+(\.\d*)?/ ;
327 death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
328 unless $XSUBPP_version >= $Ver ;
332 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
334 my ($cpp, $cpplevel);
336 if ($cpp =~ /^\#\s*if/) {
338 } elsif (!$cpplevel) {
339 Warn("Warning: #else/elif/endif without #if in this function");
341 } elsif ($cpp =~ /^\#\s*endif/) {
345 Warn("Warning: #if without #endif in this function") if $cpplevel;
358 open(F, $filename) or die "cannot open $filename: $!\n";
360 # Identify the version of xsubpp used
363 * This file was generated automatically by xsubpp version $XSUBPP_version from the
364 * contents of $filename. Don't edit this file, edit $filename instead.
366 * ANY CHANGES MADE HERE WILL BE LOST!
374 last if ($Module, $Package, $Prefix) =
375 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
378 &Exit unless defined $_;
381 my $lastline_no = $.;
384 # Read next xsub into @line from ($lastline, <F>).
389 return 0 unless defined $lastline;
392 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
394 $Package = defined($2) ? $2 : ''; # keep -w happy
395 $Prefix = defined($3) ? $3 : ''; # keep -w happy
396 ($Module_cname = $Module) =~ s/\W/_/g;
397 ($Packid = $Package) =~ tr/:/_/;
398 $Packprefix = $Package;
399 $Packprefix .= "::" if $Packprefix ne "";
404 if ($lastline !~ /^\s*#/ ||
405 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
406 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
407 push(@line, $lastline);
408 push(@line_no, $lastline_no) ;
411 # Read next line and continuation lines
412 last unless defined($lastline = <F>);
415 $lastline .= $tmp_line
416 while ($lastline =~ /\\$/ && defined($tmp_line = <F>));
419 $lastline =~ s/^\s+$//;
421 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
426 while (fetch_para()) {
427 # Print initial preprocessor statements and blank lines
428 print shift(@line), "\n"
429 while @line && $line[0] !~ /^[^\#]/;
431 next PARAGRAPH unless @line;
433 death ("Code is not inside a function")
434 if $line[0] =~ /^\s/;
436 # initialize info arrays
448 if (check_keyword("REQUIRE")) {
450 next PARAGRAPH unless @line ;
454 if (check_keyword("BOOT")) {
456 push (@BootCode, $_, @line, "") ;
461 # extract return type, function name and arguments
462 my($ret_type) = TidyType($_);
464 # a function definition needs at least 2 lines
465 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
468 $static = 1 if $ret_type =~ s/^static\s+//;
470 $func_header = shift(@line);
471 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
472 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
474 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
475 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
477 # Check for duplicate function definition
478 if (defined $Func_name{"${Packid}_$func_name"} ) {
479 Warn("Warning: duplicate function definition '$func_name' detected")
482 push(@Func_name, "${Packid}_$func_name");
483 push(@Func_pname, $pname);
485 $Func_name{"${Packid}_$func_name"} ++ ;
487 @args = split(/\s*,\s*/, $orig_args);
488 if (defined($class)) {
489 my $arg0 = (defined($static) ? "CLASS" : "THIS");
490 unshift(@args, $arg0);
491 ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
493 $orig_args =~ s/"/\\"/g;
494 $min_args = $num_args = @args;
495 foreach $i (0..$num_args-1) {
496 if ($args[$i] =~ s/\.\.\.//) {
499 if ($args[$i] eq '' && $i == $num_args - 1) {
504 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
507 $defaults{$args[$i]} = $2;
508 $defaults{$args[$i]} =~ s/"/\\"/g;
511 if (defined($class)) {
512 $func_args = join(", ", @args[1..$#args]);
514 $func_args = join(", ", @args);
516 @args_match{@args} = 1..@args;
518 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
519 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
521 # print function header
523 #XS(XS_${Packid}_$func_name)
527 print Q<<"EOF" if $ALIAS ;
531 $cond = ($min_args ? qq(items < $min_args) : 0);
533 elsif ($min_args == $num_args) {
534 $cond = qq(items != $min_args);
537 $cond = qq(items < $min_args || items > $num_args);
540 print Q<<"EOF" if $except;
546 { print Q<<"EOF" if $cond }
548 # croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
551 { print Q<<"EOF" if $cond }
553 # croak("Usage: $pname($orig_args)");
556 print Q<<"EOF" if $PPCODE;
560 # Now do a block of some sort.
563 $cond = ''; # last CASE: condidional
564 push(@line, "$END:");
565 push(@line_no, $line_no[-1]);
569 &CASE_handler if check_keyword("CASE");
574 # do initialization of input variables
583 while ($kwd = check_keyword("INPUT|PREINIT")) {
584 if ($kwd eq 'PREINIT') { &print_section; } else { &INPUT_handler; }
586 if (!$thisdone && defined($class)) {
587 if (defined($static)) {
589 $var_types{"CLASS"} = "char *";
590 &generate_init("char *", 1, "CLASS");
594 $var_types{"THIS"} = "$class *";
595 &generate_init("$class *", 1, "THIS");
600 if (/^\s*NOT_IMPLEMENTED_YET/) {
601 print "\n\tcroak(\"$pname: not implemented yet\");\n";
604 if ($ret_type ne "void") {
605 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
607 $args_match{"RETVAL"} = 0;
608 $var_types{"RETVAL"} = $ret_type;
611 while ($kwd = check_keyword("INIT|ALIAS")) {
612 if ($kwd eq 'INIT') {
620 if (check_keyword("PPCODE")) {
622 death ("PPCODE must be last thing") if @line;
623 print "\tPUTBACK;\n\treturn;\n";
624 } elsif (check_keyword("CODE")) {
626 } elsif ($func_name eq "DESTROY") {
628 print "delete THIS;\n";
631 if ($ret_type ne "void") {
635 if (defined($static)) {
636 if ($func_name =~ /^new/) {
637 $func_name = "$class";
641 } elsif (defined($class)) {
644 $func_name =~ s/^($spat)//
646 print "$func_name($func_args);\n";
650 # do output variables
654 &OUTPUT_handler while check_keyword("OUTPUT");
656 # all OUTPUT done, so now push the return value on the stack
657 if ($gotRETVAL && $RETVAL_code) {
658 print "\t$RETVAL_code\n";
659 } elsif ($gotRETVAL || $wantRETVAL) {
660 &generate_output($ret_type, 0, 'RETVAL');
664 &print_section while check_keyword("CLEANUP");
666 # print function trailer
670 print Q<<EOF if $except;
673 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
676 if (check_keyword("CASE")) {
677 blurt ("Error: No `CASE:' at top of function")
679 $_ = "CASE: $_"; # Restore CASE: label
682 last if $_ eq "$END:";
683 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
686 print Q<<EOF if $except;
691 print Q<<EOF unless $PPCODE;
701 # print initialization routine
706 #XS(boot_$Module_cname)
709 # char* file = __FILE__;
713 print Q<<"EOF" if defined %XsubAliases ;
720 $pname = shift(@Func_pname);
722 if ($XsubAliases{$pname}) {
723 $XsubAliases{$pname}{$pname} = 0
724 unless defined $XsubAliases{$pname}{$pname} ;
725 while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
727 # cv = newXS(\"$name\", XS_$_, file);
728 # XSANY.any_i32 = $value ;
733 print " newXS(\"$pname\", XS_$_, file);\n";
737 print Q<<"EOF" if defined %XsubAliases ;
743 print "\n /* Initialisation Section */\n" ;
744 print grep (s/$/\n/, @BootCode) ;
745 print "\n /* End of Initialisation Section */\n\n" ;
758 local($type, $num, $init) = @_;
759 local($arg) = "ST(" . ($num - 1) . ")";
761 eval qq/print " $init\\\n"/;
766 # work out the line number
767 my $line_no = $line_no[@line_no - @line -1] ;
769 print STDERR "@_ in $filename, line $line_no\n" ;
785 local($type, $num, $var) = @_;
786 local($arg) = "ST(" . ($num - 1) . ")";
787 local($argoff) = $num - 1;
791 $type = TidyType($type) ;
792 blurt("Error: '$type' not in typemap"), return
793 unless defined($type_kind{$type});
795 ($ntype = $type) =~ s/\s*\*/Ptr/g;
796 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
797 $tk = $type_kind{$type};
798 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
800 blurt("Error: No INPUT definition for type '$type' found"), return
801 unless defined $input_expr{$tk} ;
802 $expr = $input_expr{$tk};
803 if ($expr =~ /DO_ARRAY_ELEM/) {
804 blurt("Error: '$subtype' not in typemap"), return
805 unless defined($type_kind{$subtype});
806 blurt("Error: No INPUT definition for type '$subtype' found"), return
807 unless defined $input_expr{$type_kind{$subtype}} ;
808 $subexpr = $input_expr{$type_kind{$subtype}};
809 $subexpr =~ s/ntype/subtype/g;
810 $subexpr =~ s/\$arg/ST(ix_$var)/g;
811 $subexpr =~ s/\n\t/\n\t\t/g;
812 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
813 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
814 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
816 if (defined($defaults{$var})) {
817 $expr =~ s/(\t+)/$1 /g;
819 eval qq/print "\\t$var;\\n"/;
820 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
821 } elsif ($expr !~ /^\t\$var =/) {
822 eval qq/print "\\t$var;\\n"/;
823 $deferred .= eval qq/"\\n$expr;\\n"/;
825 eval qq/print "$expr;\\n"/;
829 sub generate_output {
830 local($type, $num, $var) = @_;
831 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
832 local($argoff) = $num - 1;
835 $type = TidyType($type) ;
836 if ($type =~ /^array\(([^,]*),(.*)\)/) {
837 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
839 blurt("Error: '$type' not in typemap"), return
840 unless defined($type_kind{$type});
841 blurt("Error: No OUTPUT definition for type '$type' found"), return
842 unless defined $output_expr{$type_kind{$type}} ;
843 ($ntype = $type) =~ s/\s*\*/Ptr/g;
845 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
846 $expr = $output_expr{$type_kind{$type}};
847 if ($expr =~ /DO_ARRAY_ELEM/) {
848 blurt("Error: '$subtype' not in typemap"), return
849 unless defined($type_kind{$subtype});
850 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
851 unless defined $output_expr{$type_kind{$subtype}} ;
852 $subexpr = $output_expr{$type_kind{$subtype}};
853 $subexpr =~ s/ntype/subtype/g;
854 $subexpr =~ s/\$arg/ST(ix_$var)/g;
855 $subexpr =~ s/\$var/${var}[ix_$var]/g;
856 $subexpr =~ s/\n\t/\n\t\t/g;
857 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
858 eval "print qq\a$expr\a";
860 elsif ($var eq 'RETVAL') {
861 if ($expr =~ /^\t\$arg = /) {
862 eval "print qq\a$expr\a";
863 print "\tsv_2mortal(ST(0));\n";
866 print "\tST(0) = sv_newmortal();\n";
867 eval "print qq\a$expr\a";
870 elsif ($arg =~ /^ST\(\d+\)$/) {
871 eval "print qq\a$expr\a";
880 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
886 # If this is VMS, the exit status has meaning to the shell, so we
887 # use a predictable value (SS$_Abort) rather than an arbitrary
889 exit ($Is_VMS ? 44 : $errors) ;