5 xsubpp - compiler to convert Perl XS code into C code
9 B<xsubpp> [B<-C++>] [B<-except>] [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.
47 No environment variables are used.
53 =head1 MODIFICATION HISTORY
57 I<xsubpp> as released with Perl 5.000
61 I<xsubpp> as released with Perl 5.001
65 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 22 May 1995.
71 Added I<xsubpp> version number for the first time. As previous releases
72 of I<xsubpp> did not have a formal version number, a numbering scheme
73 has been applied retrospectively.
77 If OUTPUT: is being used to specify output parameters and RETVAL is
78 also to be returned, it is now no longer necessary for the user to
79 ensure that RETVAL is specified last.
83 The I<xsubpp> version number, the .xs filename and a time stamp are
84 written to the generated .c file as a comment.
88 When I<xsubpp> is parsing the definition of both the input parameters
89 and the OUTPUT parameters, any duplicate definitions will be noted and
94 I<xsubpp> is slightly more forgiving with extra whitespace.
100 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 23 May 1995.
106 More whitespace restrictions have been relaxed. In particular some
107 cases where a tab character was used to delimit fields has been
108 removed. In these cases any whitespace will now suffice.
110 The specific places where changes have been made are in the TYPEMAP
111 section of a typemap file and the input and OUTPUT: parameter
112 declarations sections in a .xs file.
116 More error checking added.
118 Before processing each typemap file I<xsubpp> now checks that it is a
119 text file. If not an warning will be displayed. In addition, a warning
120 will be displayed if it is not possible to open the typemap file.
122 In the TYPEMAP section of a typemap file, an error will be raised if
123 the line does not have 2 columns.
125 When parsing input parameter declarations check that there is at least
126 a type and name pair.
132 When parsing the OUTPUT arguments check that they are all present in
133 the corresponding input argument definitions.
137 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 1 June 1995.
139 Started tidy up to allow clean run using C<-w> flag.
141 Added some more error checking.
143 The CASE: functionality now works.
147 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 3 June 1995.
149 Added some more error checking.
153 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 5 June 1995.
155 When an error or warning message is printed C<xsubpp> will now attempt
156 to identify the exact line in the C<.xs> file where the fault occurs.
157 This can be achieved in the majority of cases.
161 Changes by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>, 6 June 1995.
163 Accept backslash-newline as in C. Allow preprocessor directives
164 anywhere. Ignore whitespace in front of comments and on blank lines.
168 Changes by Paul Marquess <pmarquess@bfsec.bt.co.uk>, 21 June 1995.
174 Changed duplicate function error to a warning.
178 Changed the comment placed at the top of the C<.c> file to be more like
179 the comment used by MakeMaker.
183 When parsing the type for an XSUB parameter I<xsubpp> can now accept
184 definitions like this:
188 i.e. the '*' is recognised as part of the type, rather than the first
189 character of the variable.
193 Fixed a problem with command line parsing - I<xsubpp> was not properly
194 detecting the case where there was no filename present on the command
206 $XSUBPP_version = "1.9" ;
208 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
210 SWITCH: while ($ARGV[0] =~ /^-/) {
213 $spat = shift, next SWITCH if $flag eq 's';
214 $cplusplus = 1, next SWITCH if $flag eq 'C++';
215 $except = 1, next SWITCH if $flag eq 'except';
216 push(@tm,shift), next SWITCH if $flag eq 'typemap';
219 @ARGV == 1 or die $usage;
221 # Check for error message from VMS
222 if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
223 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
224 or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
225 or ($dir, $filename) = ('.', $ARGV[0]);
230 $_[0] =~ s/^\s+|\s+$//go ;
237 # rationalise any '*' by joining them into bunches and removing whitespace
241 # change multiple whitespace into a single space
244 # trim leading & trailing whitespace
250 $typemap = shift @ARGV;
251 foreach $typemap (@tm) {
252 die "Can't find $typemap in $pwd\n" unless -r $typemap;
254 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
255 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
257 foreach $typemap (@tm) {
258 next unless -e $typemap ;
259 # skip directories, binary files etc.
260 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
262 open(TYPEMAP, $typemap)
263 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
269 if (/^INPUT\s*$/) { $mode = 'Input'; next; }
270 if (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
271 if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
272 if ($mode eq 'Typemap') {
276 # skip blank lines and comment lines
277 next if /^$/ or /^#/ ;
278 my @words = split (' ') ;
279 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next
281 my $kind = pop @words ;
282 TrimWhitespace($kind) ;
283 $type_kind{TidyType("@words")} = $kind ;
285 elsif ($mode eq 'Input') {
291 $input_expr{$_} = '';
292 $current = \$input_expr{$_};
301 $output_expr{$_} = '';
302 $current = \$output_expr{$_};
309 foreach $key (keys %input_expr) {
310 $input_expr{$key} =~ s/\n+$//;
321 open(F, $filename) or die "cannot open $filename: $!\n";
323 # Identify the version of xsubpp used
326 * This file was generated automatically by xsubpp version $XSUBPP_version from the
327 * contents of $filename. Don't edit this file, edit $filename instead.
329 * ANY CHANGES MADE HERE WILL BE LOST!
337 last if ($Module, $Package, $Prefix) =
338 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
341 &Exit unless defined $_;
344 my $lastline_no = $.;
347 # Read next xsub into @line from ($lastline, <F>).
352 return 0 unless defined $lastline;
355 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
359 ($Module_cname = $Module) =~ s/\W/_/g;
360 ($Packid = $Package) =~ s/:/_/g;
361 $Packprefix = $Package;
362 $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
367 if ($lastline !~ /^\s*#/ ||
368 $lastline =~ /^#[ \t]*((if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
369 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
370 push(@line, $lastline);
371 push(@line_no, $lastline_no) ;
374 # Read next line and continuation lines
375 last unless defined($lastline = <F>);
378 $lastline .= $tmp_line
379 while ($lastline =~ /\\\n$/ && defined($tmp_line = <F>));
382 $lastline =~ s/^\s+$//;
384 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
385 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
390 while (&fetch_para) {
391 # Print initial preprocessor statements and blank lines
392 print shift(@line), "\n"
393 while @line && $line[0] !~ /^[^\#]/;
395 next PARAGRAPH unless @line;
397 death ("Code is not inside a function")
398 if $line[0] =~ /^\s/;
400 # initialize info arrays
401 # my(%args_match,%var_types,%var_addr);
402 # my($class,$static,$elipsis,$wantRETVAL,%arg_list);
413 # extract return type, function name and arguments
414 my($ret_type) = TidyType(shift(@line));
416 if ($ret_type =~ /^BOOT\s*:/) {
417 push (@BootCode, @line, "", "") ;
421 # a function definition needs at least 2 lines
422 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
425 if ($ret_type =~ /^static\s+(.*)$/) {
429 $func_header = shift(@line);
430 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
431 unless $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
433 ($func_name, $orig_args) = ($1, $2) ;
434 if ($func_name =~ /(.*)::(.*)/) {
438 $Prefix = '' unless defined $Prefix ; # keep -w happy
439 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
441 # Check for duplicate function definition
442 Warn("Warning: duplicate function definition '$func_name' detected")
443 if defined $Func_name{"${Packid}_$func_name"} ;
444 $Func_name{"${Packid}_$func_name"} ++ ;
446 push(@Func_name, "${Packid}_$func_name");
447 push(@Func_pname, $pname);
448 @args = split(/\s*,\s*/, $orig_args);
449 if (defined($class)) {
450 if (defined($static)) {
451 unshift(@args, "CLASS");
452 $orig_args = "CLASS, $orig_args";
453 $orig_args =~ s/^CLASS, $/CLASS/;
456 unshift(@args, "THIS");
457 $orig_args = "THIS, $orig_args";
458 $orig_args =~ s/^THIS, $/THIS/;
461 $orig_args =~ s/"/\\"/g;
462 $min_args = $num_args = @args;
463 foreach $i (0..$num_args-1) {
464 if ($args[$i] =~ s/\.\.\.//) {
467 if ($args[$i] eq '' && $i == $num_args - 1) {
472 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
475 $defaults{$args[$i]} = $2;
476 $defaults{$args[$i]} =~ s/"/\\"/g;
479 if (defined($class)) {
480 $func_args = join(", ", @args[1..$#args]);
482 $func_args = join(", ", @args);
484 @args_match{@args} = 1..@args;
486 # print function header
488 #XS(XS_${Packid}_$func_name)
493 $cond = qq(items < $min_args);
495 elsif ($min_args == $num_args) {
496 $cond = qq(items != $min_args);
499 $cond = qq(items < $min_args || items > $num_args);
502 print Q<<"EOF" if $except;
509 # croak("Usage: $pname($orig_args)");
513 print Q<<"EOF" if $PPCODE;
517 # Now do a block of some sort.
525 if ($line[0] =~ s/^\s*CASE\s*:\s*//) {
526 $cond = shift(@line);
527 TrimWhitespace($cond) ;
529 # Check $cond is not blank
530 blurt("Error: First CASE: needs a condition")
532 print " if ($cond)\n"
534 elsif ($cond ne '') {
535 print " else if ($cond)\n";
538 blurt ("Error: Too many CASE: statements without a condition")
558 # do initialization of input variables
566 last if /^\s*NOT_IMPLEMENTED_YET/;
567 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
574 # remove trailing semicolon if no initialisation
575 s/\s*;+\s*$//g unless /=/ ;
577 # check for optional initialisation code
579 $var_init = $1 if s/\s*(=.*)$// ;
581 my @words = split (' ') ;
582 blurt("Error: invalid argument declaration '$line'"), next
584 my $var_name = pop @words ;
586 # move any *'s from the variable name to the type
588 if $var_name =~ s/^(\*+)// ;
590 # check that removing the *'s hasn't eaten the whole variable
591 blurt("Error: invalid argument declaration '$line'"), next
594 my $var_type = "@words" ;
596 # catch many errors similar to: SV<tab>* name
597 blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
598 unless ($var_name =~ m/^&?\w+$/);
599 if ($var_name =~ /^&/) {
601 $var_addr{$var_name} = 1;
604 # Check for duplicate definitions
605 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
606 if $arg_list{$var_name} ++ ;
608 $thisdone |= $var_name eq "THIS";
609 $retvaldone |= $var_name eq "RETVAL";
610 $var_types{$var_name} = $var_type;
611 print "\t" . &map_type($var_type);
612 $var_num = $args_match{$var_name};
613 if ($var_addr{$var_name}) {
614 $func_args =~ s/\b($var_name)\b/&$1/;
616 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
617 if ($var_init !~ /^\s*$/) {
618 &output_init($var_type, $var_num,
619 "$var_name $var_init");
621 # generate initialization code
622 &generate_init($var_type, $var_num, $var_name);
627 print "\t$var_name;\n";
630 if (!$thisdone && defined($class)) {
631 if (defined($static)) {
633 $var_types{"CLASS"} = "char *";
634 &generate_init("char *", 1, "CLASS");
638 $var_types{"THIS"} = "$class *";
639 &generate_init("$class *", 1, "THIS");
644 if (/^\s*NOT_IMPLEMENTED_YET/) {
645 print "\ncroak(\"$pname: not implemented yet\");\n";
647 if ($ret_type ne "void") {
648 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
650 $args_match{"RETVAL"} = 0;
651 $var_types{"RETVAL"} = $ret_type;
653 if (/^\s*PPCODE\s*:/) {
657 death ("PPCODE must be last thing")
658 if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
661 print "\tPUTBACK;\n\treturn;\n";
662 } elsif (/^\s*CODE\s*:/) {
666 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
669 } elsif ($func_name eq "DESTROY") {
672 print "delete THIS;\n"
676 if ($ret_type ne "void") {
680 if (defined($static)) {
681 if ($func_name =~ /^new/) {
682 $func_name = "$class";
687 } elsif (defined($class)) {
690 $func_name =~ s/^($spat)//
692 print "$func_name($func_args);\n";
696 # do output variables
697 if (/^\s*OUTPUT\s*:/) {
703 last if /^\s*(CLEANUP|CASE)\s*:/;
706 my ($outarg, $outcode) = /^(\S+)\s*(.*)/ ;
707 if (!$gotRETVAL and $outarg eq 'RETVAL') {
708 # deal with RETVAL last
709 $RETVAL_code = $outcode ;
713 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
714 if $outargs{$outarg} ++ ;
715 blurt ("Error: OUTPUT $outarg not an argument"), next
716 unless defined($args_match{$outarg});
717 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
718 unless defined $var_types{$outarg} ;
720 print "\t$outcode\n";
722 $var_num = $args_match{$outarg};
723 &generate_output($var_types{$outarg}, $var_num,
730 { print "\t$RETVAL_code\n" }
732 { &generate_output($ret_type, 0, 'RETVAL') }
736 # all OUTPUT done, so now push the return value on the stack
737 &generate_output($ret_type, 0, "RETVAL")
738 if $wantRETVAL and ! $gotRETVAL ;
741 if (/^\s*CLEANUP\s*:/) {
744 last if /^\s*CASE\s*:/;
748 # print function trailer
754 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
763 if (/^\s*CASE\s*:/) {
768 print Q<<EOF if $except;
773 print Q<<EOF unless $PPCODE;
783 # print initialization routine
784 print qq/extern "C"\n/ if $cplusplus;
786 #XS(boot_$Module_cname)
789 # char* file = __FILE__;
794 $pname = shift(@Func_pname);
795 print " newXS(\"$pname\", XS_$_, file);\n";
800 print "\n /* Initialisation Section */\n\n" ;
801 print grep (s/$/\n/, @BootCode) ;
802 print " /* End of Initialisation Section */\n\n" ;
815 local($type, $num, $init) = @_;
816 local($arg) = "ST(" . ($num - 1) . ")";
818 eval qq/print " $init\\\n"/;
823 # work out the line number
824 my $line_no = $line_no[@line_no - @line -1] ;
826 print STDERR "@_ in $filename, line $line_no\n" ;
842 local($type, $num, $var) = @_;
843 local($arg) = "ST(" . ($num - 1) . ")";
844 local($argoff) = $num - 1;
848 $type = TidyType($type) ;
849 blurt("Error: '$type' not in typemap"), return
850 unless defined($type_kind{$type});
852 ($ntype = $type) =~ s/\s*\*/Ptr/g;
854 $subtype =~ s/Ptr$//;
855 $subtype =~ s/Array$//;
856 $tk = $type_kind{$type};
857 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
859 blurt("Error: No INPUT definition for type '$type' found"), return
860 unless defined $input_expr{$tk} ;
861 $expr = $input_expr{$tk};
862 if ($expr =~ /DO_ARRAY_ELEM/) {
863 blurt("Error: '$subtype' not in typemap"), return
864 unless defined($type_kind{$subtype});
865 blurt("Error: No INPUT definition for type '$subtype' found"), return
866 unless defined $input_expr{$type_kind{$subtype}} ;
867 $subexpr = $input_expr{$type_kind{$subtype}};
868 $subexpr =~ s/ntype/subtype/g;
869 $subexpr =~ s/\$arg/ST(ix_$var)/g;
870 $subexpr =~ s/\n\t/\n\t\t/g;
871 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
872 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
873 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
875 if (defined($defaults{$var})) {
876 $expr =~ s/(\t+)/$1 /g;
878 eval qq/print "\\t$var;\\n"/;
879 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
880 } elsif ($expr !~ /^\t\$var =/) {
881 eval qq/print "\\t$var;\\n"/;
882 $deferred .= eval qq/"\\n$expr;\\n"/;
884 eval qq/print "$expr;\\n"/;
888 sub generate_output {
889 local($type, $num, $var) = @_;
890 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
891 local($argoff) = $num - 1;
894 $type = TidyType($type) ;
895 if ($type =~ /^array\(([^,]*),(.*)\)/) {
896 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
898 blurt("Error: '$type' not in typemap"), return
899 unless defined($type_kind{$type});
900 blurt("Error: No OUTPUT definition for type '$type' found"), return
901 unless defined $output_expr{$type_kind{$type}} ;
902 ($ntype = $type) =~ s/\s*\*/Ptr/g;
905 $subtype =~ s/Ptr$//;
906 $subtype =~ s/Array$//;
907 $expr = $output_expr{$type_kind{$type}};
908 if ($expr =~ /DO_ARRAY_ELEM/) {
909 blurt("Error: '$subtype' not in typemap"), return
910 unless defined($type_kind{$subtype});
911 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
912 unless defined $output_expr{$type_kind{$subtype}} ;
913 $subexpr = $output_expr{$type_kind{$subtype}};
914 $subexpr =~ s/ntype/subtype/g;
915 $subexpr =~ s/\$arg/ST(ix_$var)/g;
916 $subexpr =~ s/\$var/${var}[ix_$var]/g;
917 $subexpr =~ s/\n\t/\n\t\t/g;
918 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
919 eval "print qq\a$expr\a";
921 elsif ($var eq 'RETVAL') {
922 if ($expr =~ /^\t\$arg = /) {
923 eval "print qq\a$expr\a";
924 print "\tsv_2mortal(ST(0));\n";
927 print "\tST(0) = sv_newmortal();\n";
928 eval "print qq\a$expr\a";
931 elsif ($arg =~ /^ST\(\d+\)$/) {
932 eval "print qq\a$expr\a";
941 if ($type =~ /^array\(([^,]*),(.*)\)/) {
950 # If this is VMS, the exit status has meaning to the shell, so we
951 # use a predictable value (SS$_Abort) rather than an arbitrary
953 exit ($Is_VMS ? 44 : $errors) ;