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.
59 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
61 SWITCH: while ($ARGV[0] =~ s/^-//) {
63 $spat = shift, next SWITCH if $flag eq 's';
64 $cplusplus = 1, next SWITCH if $flag eq 'C++';
65 $except = 1, next SWITCH if $flag eq 'except';
66 push(@tm,shift), next SWITCH if $flag eq 'typemap';
69 @ARGV == 1 or die $usage;
71 ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
72 or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
73 or ($dir, $filename) = ('.', $ARGV[0]);
76 $typemap = shift @ARGV;
77 foreach $typemap (@tm) {
78 die "Can't find $typemap in $pwd\n" unless -r $typemap;
80 unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
81 foreach $typemap (@tm) {
82 open(TYPEMAP, $typemap) || next;
87 if (/^INPUT\s*$/) { $mode = Input, next }
88 if (/^OUTPUT\s*$/) { $mode = Output, next }
89 if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
90 if ($mode eq Typemap) {
92 ($typename, $kind) = split(/\t+/, $_, 2);
93 $type_kind{$typename} = $kind if $kind ne '';
95 elsif ($mode eq Input) {
101 $input_expr{$_} = '';
102 $current = \$input_expr{$_};
111 $output_expr{$_} = '';
112 $current = \$output_expr{$_};
119 foreach $key (keys %input_expr) {
120 $input_expr{$key} =~ s/\n+$//;
131 open(F, $filename) || die "cannot open $filename\n";
134 last if ($Module, $foo, $Package, $foo1, $Prefix) =
135 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
144 if ($lastline ne "") {
146 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
152 ($Module_cname = $Module) =~ s/\W/_/g;
153 ($Packid = $Package) =~ s/:/_/g;
154 $Packprefix = $Package;
155 $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
159 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
162 push(@line, $_) if $_ ne "";
165 push(@line, $lastline);
170 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
172 if (/^\S/ && @line && $line[-1] eq "") {
180 pop(@line) while @line && $line[-1] =~ /^\s*$/;
182 $PPCODE = grep(/PPCODE:/, @line);
186 while (&fetch_para) {
187 # initialize info arrays
196 # extract return type, function name and arguments
197 $ret_type = shift(@line);
198 if ($ret_type =~ /^BOOT:/) {
199 push (@BootCode, @line, "", "") ;
202 if ($ret_type =~ /^static\s+(.*)$/) {
206 $func_header = shift(@line);
207 ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
208 if ($func_name =~ /(.*)::(.*)/) {
212 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
213 push(@Func_name, "${Packid}_$func_name");
214 push(@Func_pname, $pname);
215 @args = split(/\s*,\s*/, $orig_args);
216 if (defined($class)) {
217 if (defined($static)) {
218 unshift(@args, "CLASS");
219 $orig_args = "CLASS, $orig_args";
220 $orig_args =~ s/^CLASS, $/CLASS/;
223 unshift(@args, "THIS");
224 $orig_args = "THIS, $orig_args";
225 $orig_args =~ s/^THIS, $/THIS/;
228 $orig_args =~ s/"/\\"/g;
229 $min_args = $num_args = @args;
230 foreach $i (0..$num_args-1) {
231 if ($args[$i] =~ s/\.\.\.//) {
234 if ($args[i] eq '' && $i == $num_args - 1) {
239 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
242 $defaults{$args[$i]} = $2;
243 $defaults{$args[$i]} =~ s/"/\\"/g;
246 if (defined($class)) {
247 $func_args = join(", ", @args[1..$#args]);
249 $func_args = join(", ", @args);
251 @args_match{@args} = 1..@args;
253 # print function header
255 #XS(XS_${Packid}_$func_name)
260 $cond = qq(items < $min_args);
262 elsif ($min_args == $num_args) {
263 $cond = qq(items != $min_args);
266 $cond = qq(items < $min_args || items > $num_args);
269 print Q<<"EOF" if $except;
276 # croak("Usage: $pname($orig_args)");
280 print Q<<"EOF" if $PPCODE;
284 # Now do a block of some sort.
291 if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
292 $cond = shift(@line);
294 print " if ($cond)\n";
296 elsif ($cond ne '') {
297 print " else if ($cond)\n";
316 # do initialization of input variables
322 last if /^\s*NOT_IMPLEMENTED_YET/;
323 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
324 # Catch common error. Much more error checking required here.
325 blurt("Error: no tab in $pname argument declaration '$_'\n")
326 unless (m/\S+\s*\t\s*\S+/);
327 ($var_type, $var_name, $var_init) =
328 /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
329 if ($var_name =~ /^&/) {
331 $var_addr{$var_name} = 1;
333 $thisdone |= $var_name eq "THIS";
334 $retvaldone |= $var_name eq "RETVAL";
335 $var_types{$var_name} = $var_type;
336 print "\t" . &map_type($var_type);
337 $var_num = $args_match{$var_name};
338 if ($var_addr{$var_name}) {
339 $func_args =~ s/\b($var_name)\b/&\1/;
341 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
342 if ($var_init !~ /^\s*$/) {
343 &output_init($var_type, $var_num,
344 "$var_name $var_init");
346 # generate initialization code
347 &generate_init($var_type, $var_num, $var_name);
352 print "\t$var_name;\n";
355 if (!$thisdone && defined($class)) {
356 if (defined($static)) {
358 $var_types{"CLASS"} = "char *";
359 &generate_init("char *", 1, "CLASS");
363 $var_types{"THIS"} = "$class *";
364 &generate_init("$class *", 1, "THIS");
369 if (/^\s*NOT_IMPLEMENTED_YET/) {
370 print "\ncroak(\"$pname: not implemented yet\");\n";
372 if ($ret_type ne "void") {
373 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
375 $args_match{"RETVAL"} = 0;
376 $var_types{"RETVAL"} = $ret_type;
382 die "PPCODE must be last thing"
383 if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
386 print "\tPUTBACK;\n\treturn;\n";
387 } elsif (/^\s*CODE:/) {
391 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
394 } elsif ($func_name eq "DESTROY") {
397 print "delete THIS;\n"
401 if ($ret_type ne "void") {
404 if (defined($static)) {
405 if ($func_name =~ /^new/) {
406 $func_name = "$class";
411 } elsif (defined($class)) {
414 if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
417 print "$func_name($func_args);\n";
418 &generate_output($ret_type, 0, "RETVAL")
419 unless $ret_type eq "void";
423 # do output variables
424 if (/^\s*OUTPUT\s*:/) {
427 last if /^\s*CLEANUP\s*:/;
429 ($outarg, $outcode) = split(/\t+/);
431 print "\t$outcode\n";
433 die "$outarg not an argument"
434 unless defined($args_match{$outarg});
435 $var_num = $args_match{$outarg};
436 &generate_output($var_types{$outarg}, $var_num,
442 if (/^\s*CLEANUP\s*:/) {
445 last if /^\s*CASE\s*:/;
449 # print function trailer
455 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
464 if (/^\s*CASE\s*:/) {
469 print Q<<EOF if $except;
474 print Q<<EOF unless $PPCODE;
484 # print initialization routine
485 print qq/extern "C"\n/ if $cplusplus;
487 #XS(boot_$Module_cname)
490 # char* file = __FILE__;
495 $pname = shift(@Func_pname);
496 print " newXS(\"$pname\", XS_$_, file);\n";
501 print "\n /* Initialisation Section */\n\n" ;
502 print grep (s/$/\n/, @BootCode) ;
503 print " /* End of Initialisation Section */\n\n" ;
506 print " ST(0) = &sv_yes;\n";
507 print " XSRETURN(1);\n";
511 local($type, $num, $init) = @_;
512 local($arg) = "ST(" . ($num - 1) . ")";
514 eval qq/print " $init\\\n"/;
517 sub blurt { warn @_; $errors++ }
520 local($type, $num, $var) = @_;
521 local($arg) = "ST(" . ($num - 1) . ")";
522 local($argoff) = $num - 1;
526 blurt("$type not in typemap"), return unless defined($type_kind{$type});
527 ($ntype = $type) =~ s/\s*\*/Ptr/g;
529 $subtype =~ s/Ptr$//;
530 $subtype =~ s/Array$//;
531 $tk = $type_kind{$type};
532 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
534 $expr = $input_expr{$tk};
535 if ($expr =~ /DO_ARRAY_ELEM/) {
536 $subexpr = $input_expr{$type_kind{$subtype}};
537 $subexpr =~ s/ntype/subtype/g;
538 $subexpr =~ s/\$arg/ST(ix_$var)/g;
539 $subexpr =~ s/\n\t/\n\t\t/g;
540 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
541 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
542 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
544 if (defined($defaults{$var})) {
545 $expr =~ s/(\t+)/$1 /g;
547 eval qq/print "\\t$var;\\n"/;
548 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
549 } elsif ($expr !~ /^\t\$var =/) {
550 eval qq/print "\\t$var;\\n"/;
551 $deferred .= eval qq/"\\n$expr;\\n"/;
553 eval qq/print "$expr;\\n"/;
557 sub generate_output {
558 local($type, $num, $var) = @_;
559 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
560 local($argoff) = $num - 1;
563 if ($type =~ /^array\(([^,]*),(.*)\)/) {
564 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
566 blurt("$type not in typemap"), return
567 unless defined($type_kind{$type});
568 ($ntype = $type) =~ s/\s*\*/Ptr/g;
571 $subtype =~ s/Ptr$//;
572 $subtype =~ s/Array$//;
573 $expr = $output_expr{$type_kind{$type}};
574 if ($expr =~ /DO_ARRAY_ELEM/) {
575 $subexpr = $output_expr{$type_kind{$subtype}};
576 $subexpr =~ s/ntype/subtype/g;
577 $subexpr =~ s/\$arg/ST(ix_$var)/g;
578 $subexpr =~ s/\$var/${var}[ix_$var]/g;
579 $subexpr =~ s/\n\t/\n\t\t/g;
580 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
581 eval "print qq\a$expr\a";
583 elsif ($var eq 'RETVAL') {
584 if ($expr =~ /^\t\$arg = /) {
585 eval "print qq\a$expr\a";
586 print "\tsv_2mortal(ST(0));\n";
589 print "\tST(0) = sv_newmortal();\n";
590 eval "print qq\a$expr\a";
593 elsif ($arg =~ /^ST\(\d+\)$/) {
594 eval "print qq\a$expr\a";
596 elsif ($arg =~ /^ST\(\d+\)$/) {
597 eval "print qq\a$expr\a";
599 elsif ($arg =~ /^ST\(\d+\)$/) {
600 eval "print qq\a$expr\a";
609 if ($type =~ /^array\(([^,]*),(.*)\)/) {