7 $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
9 SWITCH: while ($ARGV[0] =~ s/^-//) {
11 $spat = shift, next SWITCH if $flag eq 's';
12 $cplusplus = 1, next SWITCH if $flag eq 'C++';
13 $except = 1, next SWITCH if $flag eq 'except';
14 push(@tm,shift), next SWITCH if $flag eq 'typemap';
17 @ARGV == 1 or die $usage;
19 ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
20 or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
21 or ($dir, $filename) = ('.', $ARGV[0]);
24 $typemap = shift @ARGV;
25 foreach $typemap (@tm) {
26 die "Can't find $typemap in $pwd\n" unless -r $typemap;
28 unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
29 foreach $typemap (@tm) {
30 open(TYPEMAP, $typemap) || next;
35 if (/^INPUT\s*$/) { $mode = Input, next }
36 if (/^OUTPUT\s*$/) { $mode = Output, next }
37 if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
38 if ($mode eq Typemap) {
40 ($typename, $kind) = split(/\t+/, $_, 2);
41 $type_kind{$typename} = $kind if $kind ne '';
43 elsif ($mode eq Input) {
50 $current = \$input_expr{$_};
59 $output_expr{$_} = '';
60 $current = \$output_expr{$_};
67 foreach $key (keys %input_expr) {
68 $input_expr{$key} =~ s/\n+$//;
79 open(F, $filename) || die "cannot open $filename\n";
82 last if ($Module, $foo, $Package, $foo1, $Prefix) =
83 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
92 if ($lastline ne "") {
94 /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
100 ($Module_cname = $Module) =~ s/\W/_/g;
101 ($Packid = $Package) =~ s/:/_/g;
102 $Packprefix = $Package;
103 $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
107 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
110 push(@line, $_) if $_ ne "";
113 push(@line, $lastline);
118 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
120 if (/^\S/ && @line && $line[-1] eq "") {
128 pop(@line) while @line && $line[-1] =~ /^\s*$/;
130 $PPCODE = grep(/PPCODE:/, @line);
134 while (&fetch_para) {
135 # initialize info arrays
144 # extract return type, function name and arguments
145 $ret_type = shift(@line);
146 if ($ret_type =~ /^BOOT:/) {
147 push (@BootCode, @line, "", "") ;
150 if ($ret_type =~ /^static\s+(.*)$/) {
154 $func_header = shift(@line);
155 ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
156 if ($func_name =~ /(.*)::(.*)/) {
160 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
161 push(@Func_name, "${Packid}_$func_name");
162 push(@Func_pname, $pname);
163 @args = split(/\s*,\s*/, $orig_args);
164 if (defined($class)) {
165 if (defined($static)) {
166 unshift(@args, "CLASS");
167 $orig_args = "CLASS, $orig_args";
168 $orig_args =~ s/^CLASS, $/CLASS/;
171 unshift(@args, "THIS");
172 $orig_args = "THIS, $orig_args";
173 $orig_args =~ s/^THIS, $/THIS/;
176 $orig_args =~ s/"/\\"/g;
177 $min_args = $num_args = @args;
178 foreach $i (0..$num_args-1) {
179 if ($args[$i] =~ s/\.\.\.//) {
182 if ($args[i] eq '' && $i == $num_args - 1) {
187 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
190 $defaults{$args[$i]} = $2;
191 $defaults{$args[$i]} =~ s/"/\\"/g;
194 if (defined($class)) {
195 $func_args = join(", ", @args[1..$#args]);
197 $func_args = join(", ", @args);
199 @args_match{@args} = 1..@args;
201 # print function header
203 #XS(XS_${Packid}_$func_name)
208 $cond = qq(items < $min_args);
210 elsif ($min_args == $num_args) {
211 $cond = qq(items != $min_args);
214 $cond = qq(items < $min_args || items > $num_args);
217 print Q<<"EOF" if $except;
224 # croak("Usage: $pname($orig_args)");
228 print Q<<"EOF" if $PPCODE;
232 # Now do a block of some sort.
239 if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
240 $cond = shift(@line);
242 print " if ($cond)\n";
244 elsif ($cond ne '') {
245 print " else if ($cond)\n";
264 # do initialization of input variables
270 last if /^\s*NOT_IMPLEMENTED_YET/;
271 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
272 # Catch common error. Much more error checking required here.
273 blurt("Error: no tab in $pname argument declaration '$_'\n")
274 unless (m/\S+\s*\t\s*\S+/);
275 ($var_type, $var_name, $var_init) =
276 /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
277 if ($var_name =~ /^&/) {
279 $var_addr{$var_name} = 1;
281 $thisdone |= $var_name eq "THIS";
282 $retvaldone |= $var_name eq "RETVAL";
283 $var_types{$var_name} = $var_type;
284 print "\t" . &map_type($var_type);
285 $var_num = $args_match{$var_name};
286 if ($var_addr{$var_name}) {
287 $func_args =~ s/\b($var_name)\b/&\1/;
289 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
290 if ($var_init !~ /^\s*$/) {
291 &output_init($var_type, $var_num,
292 "$var_name $var_init");
294 # generate initialization code
295 &generate_init($var_type, $var_num, $var_name);
300 print "\t$var_name;\n";
303 if (!$thisdone && defined($class)) {
304 if (defined($static)) {
306 $var_types{"CLASS"} = "char *";
307 &generate_init("char *", 1, "CLASS");
311 $var_types{"THIS"} = "$class *";
312 &generate_init("$class *", 1, "THIS");
317 if (/^\s*NOT_IMPLEMENTED_YET/) {
318 print "\ncroak(\"$pname: not implemented yet\");\n";
320 if ($ret_type ne "void") {
321 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
323 $args_match{"RETVAL"} = 0;
324 $var_types{"RETVAL"} = $ret_type;
330 die "PPCODE must be last thing"
331 if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
334 print "\tPUTBACK;\n\treturn;\n";
335 } elsif (/^\s*CODE:/) {
339 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
342 } elsif ($func_name eq "DESTROY") {
345 print "delete THIS;\n"
349 if ($ret_type ne "void") {
352 if (defined($static)) {
353 if ($func_name =~ /^new/) {
354 $func_name = "$class";
359 } elsif (defined($class)) {
362 if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
365 print "$func_name($func_args);\n";
366 &generate_output($ret_type, 0, "RETVAL")
367 unless $ret_type eq "void";
371 # do output variables
372 if (/^\s*OUTPUT\s*:/) {
375 last if /^\s*CLEANUP\s*:/;
377 ($outarg, $outcode) = split(/\t+/);
379 print "\t$outcode\n";
381 die "$outarg not an argument"
382 unless defined($args_match{$outarg});
383 $var_num = $args_match{$outarg};
384 &generate_output($var_types{$outarg}, $var_num,
390 if (/^\s*CLEANUP\s*:/) {
393 last if /^\s*CASE\s*:/;
397 # print function trailer
403 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
412 if (/^\s*CASE\s*:/) {
417 print Q<<EOF if $except;
422 print Q<<EOF unless $PPCODE;
432 # print initialization routine
433 print qq/extern "C"\n/ if $cplusplus;
435 #XS(boot_$Module_cname)
438 # char* file = __FILE__;
443 $pname = shift(@Func_pname);
444 print " newXS(\"$pname\", XS_$_, file);\n";
449 print "\n /* Initialisation Section */\n\n" ;
450 print grep (s/$/\n/, @BootCode) ;
451 print " /* End of Initialisation Section */\n\n" ;
454 print " ST(0) = &sv_yes;\n";
455 print " XSRETURN(1);\n";
459 local($type, $num, $init) = @_;
460 local($arg) = "ST(" . ($num - 1) . ")";
462 eval qq/print " $init\\\n"/;
465 sub blurt { warn @_; $errors++ }
468 local($type, $num, $var) = @_;
469 local($arg) = "ST(" . ($num - 1) . ")";
470 local($argoff) = $num - 1;
474 blurt("$type not in typemap"), return unless defined($type_kind{$type});
475 ($ntype = $type) =~ s/\s*\*/Ptr/g;
477 $subtype =~ s/Ptr$//;
478 $subtype =~ s/Array$//;
479 $tk = $type_kind{$type};
480 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
482 $expr = $input_expr{$tk};
483 if ($expr =~ /DO_ARRAY_ELEM/) {
484 $subexpr = $input_expr{$type_kind{$subtype}};
485 $subexpr =~ s/ntype/subtype/g;
486 $subexpr =~ s/\$arg/ST(ix_$var)/g;
487 $subexpr =~ s/\n\t/\n\t\t/g;
488 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
489 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
490 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
492 if (defined($defaults{$var})) {
493 $expr =~ s/(\t+)/$1 /g;
495 eval qq/print "\\t$var;\\n"/;
496 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
497 } elsif ($expr !~ /^\t\$var =/) {
498 eval qq/print "\\t$var;\\n"/;
499 $deferred .= eval qq/"\\n$expr;\\n"/;
501 eval qq/print "$expr;\\n"/;
505 sub generate_output {
506 local($type, $num, $var) = @_;
507 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
508 local($argoff) = $num - 1;
511 if ($type =~ /^array\(([^,]*),(.*)\)/) {
512 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
514 blurt("$type not in typemap"), return
515 unless defined($type_kind{$type});
516 ($ntype = $type) =~ s/\s*\*/Ptr/g;
519 $subtype =~ s/Ptr$//;
520 $subtype =~ s/Array$//;
521 $expr = $output_expr{$type_kind{$type}};
522 if ($expr =~ /DO_ARRAY_ELEM/) {
523 $subexpr = $output_expr{$type_kind{$subtype}};
524 $subexpr =~ s/ntype/subtype/g;
525 $subexpr =~ s/\$arg/ST(ix_$var)/g;
526 $subexpr =~ s/\$var/${var}[ix_$var]/g;
527 $subexpr =~ s/\n\t/\n\t\t/g;
528 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
529 eval "print qq\a$expr\a";
531 elsif ($var eq 'RETVAL') {
532 if ($expr =~ /^\t\$arg = /) {
533 eval "print qq\a$expr\a";
534 print "\tsv_2mortal(ST(0));\n";
537 print "\tST(0) = sv_newmortal();\n";
538 eval "print qq\a$expr\a";
541 elsif ($arg =~ /^ST\(\d+\)$/) {
542 eval "print qq\a$expr\a";
544 elsif ($arg =~ /^ST\(\d+\)$/) {
545 eval "print qq\a$expr\a";
547 elsif ($arg =~ /^ST\(\d+\)$/) {
548 eval "print qq\a$expr\a";
557 if ($type =~ /^array\(([^,]*),(.*)\)/) {
566 ##############################################################################
568 # These next few lines are legal in both Perl and nroff.
572 'di \" finish diversion--previous line must be blank
573 .nr nl 0-1 \" fake up transition to first page again
574 .nr % 0 \" start at page 1
575 '; __END__ ############# From here on it's a standard manual page ############
576 .TH XSUBPP 1 "August 9, 1994"
579 xsubpp \- compiler to convert Perl XS code into C code
581 .B xsubpp [-C++] [-except] [-typemap typemap] file.xs
584 will compile XS code into C code by embedding the constructs necessary to
585 let C functions manipulate Perl values and creates the glue necessary to let
586 Perl access those functions. The compiler uses typemaps to determine how
587 to map C function parameters and variables to Perl values.
589 The compiler will search for typemap files called
591 It will use the following search path to find default typemaps, with the
592 rightmost typemap taking precedence.
595 ../../../typemap:../../typemap:../typemap:typemap
601 Adds ``extern "C"'' to the C code.
604 Adds exception handling stubs to the C code.
607 Indicates that a user-supplied typemap should take precedence over the
608 default typemaps. This option may be used multiple times, with the last
609 typemap having the highest precedence.
611 No environment variables are used.