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.922";
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 "\ncroak(\"$pname: not implemented yet\");\n";
603 if ($ret_type ne "void") {
604 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
606 $args_match{"RETVAL"} = 0;
607 $var_types{"RETVAL"} = $ret_type;
610 while ($kwd = check_keyword("INIT|ALIAS")) {
611 if ($kwd eq 'INIT') {
619 if (check_keyword("PPCODE")) {
621 death ("PPCODE must be last thing") if @line;
622 print "\tPUTBACK;\n\treturn;\n";
623 } elsif (check_keyword("CODE")) {
625 } elsif ($func_name eq "DESTROY") {
627 print "delete THIS;\n";
630 if ($ret_type ne "void") {
634 if (defined($static)) {
635 if ($func_name =~ /^new/) {
636 $func_name = "$class";
640 } elsif (defined($class)) {
643 $func_name =~ s/^($spat)//
645 print "$func_name($func_args);\n";
649 # do output variables
653 &OUTPUT_handler while check_keyword("OUTPUT");
655 # all OUTPUT done, so now push the return value on the stack
656 if ($gotRETVAL && $RETVAL_code) {
657 print "\t$RETVAL_code\n";
658 } elsif ($gotRETVAL || $wantRETVAL) {
659 &generate_output($ret_type, 0, 'RETVAL');
663 &print_section while check_keyword("CLEANUP");
665 # print function trailer
669 print Q<<EOF if $except;
672 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
675 if (check_keyword("CASE")) {
676 blurt ("Error: No `CASE:' at top of function")
678 $_ = "CASE: $_"; # Restore CASE: label
681 last if $_ eq "$END:";
682 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
685 print Q<<EOF if $except;
690 print Q<<EOF unless $PPCODE;
700 # print initialization routine
701 print qq/extern "C"\n/ if $cplusplus;
703 #XS(boot_$Module_cname)
706 # char* file = __FILE__;
710 print Q<<"EOF" if defined %XsubAliases ;
717 $pname = shift(@Func_pname);
719 if ($XsubAliases{$pname}) {
720 $XsubAliases{$pname}{$pname} = 0
721 unless defined $XsubAliases{$pname}{$pname} ;
722 while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
724 # cv = newXS(\"$name\", XS_$_, file);
725 # XSANY.any_i32 = $value ;
730 print " newXS(\"$pname\", XS_$_, file);\n";
734 print Q<<"EOF" if defined %XsubAliases ;
740 print "\n /* Initialisation Section */\n" ;
741 print grep (s/$/\n/, @BootCode) ;
742 print "\n /* End of Initialisation Section */\n\n" ;
755 local($type, $num, $init) = @_;
756 local($arg) = "ST(" . ($num - 1) . ")";
758 eval qq/print " $init\\\n"/;
763 # work out the line number
764 my $line_no = $line_no[@line_no - @line -1] ;
766 print STDERR "@_ in $filename, line $line_no\n" ;
782 local($type, $num, $var) = @_;
783 local($arg) = "ST(" . ($num - 1) . ")";
784 local($argoff) = $num - 1;
788 $type = TidyType($type) ;
789 blurt("Error: '$type' not in typemap"), return
790 unless defined($type_kind{$type});
792 ($ntype = $type) =~ s/\s*\*/Ptr/g;
793 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
794 $tk = $type_kind{$type};
795 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
797 blurt("Error: No INPUT definition for type '$type' found"), return
798 unless defined $input_expr{$tk} ;
799 $expr = $input_expr{$tk};
800 if ($expr =~ /DO_ARRAY_ELEM/) {
801 blurt("Error: '$subtype' not in typemap"), return
802 unless defined($type_kind{$subtype});
803 blurt("Error: No INPUT definition for type '$subtype' found"), return
804 unless defined $input_expr{$type_kind{$subtype}} ;
805 $subexpr = $input_expr{$type_kind{$subtype}};
806 $subexpr =~ s/ntype/subtype/g;
807 $subexpr =~ s/\$arg/ST(ix_$var)/g;
808 $subexpr =~ s/\n\t/\n\t\t/g;
809 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
810 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
811 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
813 if (defined($defaults{$var})) {
814 $expr =~ s/(\t+)/$1 /g;
816 eval qq/print "\\t$var;\\n"/;
817 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
818 } elsif ($expr !~ /^\t\$var =/) {
819 eval qq/print "\\t$var;\\n"/;
820 $deferred .= eval qq/"\\n$expr;\\n"/;
822 eval qq/print "$expr;\\n"/;
826 sub generate_output {
827 local($type, $num, $var) = @_;
828 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
829 local($argoff) = $num - 1;
832 $type = TidyType($type) ;
833 if ($type =~ /^array\(([^,]*),(.*)\)/) {
834 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
836 blurt("Error: '$type' not in typemap"), return
837 unless defined($type_kind{$type});
838 blurt("Error: No OUTPUT definition for type '$type' found"), return
839 unless defined $output_expr{$type_kind{$type}} ;
840 ($ntype = $type) =~ s/\s*\*/Ptr/g;
842 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
843 $expr = $output_expr{$type_kind{$type}};
844 if ($expr =~ /DO_ARRAY_ELEM/) {
845 blurt("Error: '$subtype' not in typemap"), return
846 unless defined($type_kind{$subtype});
847 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
848 unless defined $output_expr{$type_kind{$subtype}} ;
849 $subexpr = $output_expr{$type_kind{$subtype}};
850 $subexpr =~ s/ntype/subtype/g;
851 $subexpr =~ s/\$arg/ST(ix_$var)/g;
852 $subexpr =~ s/\$var/${var}[ix_$var]/g;
853 $subexpr =~ s/\n\t/\n\t\t/g;
854 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
855 eval "print qq\a$expr\a";
857 elsif ($var eq 'RETVAL') {
858 if ($expr =~ /^\t\$arg = /) {
859 eval "print qq\a$expr\a";
860 print "\tsv_2mortal(ST(0));\n";
863 print "\tST(0) = sv_newmortal();\n";
864 eval "print qq\a$expr\a";
867 elsif ($arg =~ /^ST\(\d+\)$/) {
868 eval "print qq\a$expr\a";
877 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
883 # If this is VMS, the exit status has meaning to the shell, so we
884 # use a predictable value (SS$_Abort) rather than an arbitrary
886 exit ($Is_VMS ? 44 : $errors) ;