4 $usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
5 die $usage unless (@ARGV >= 2 && @ARGV <= 6);
7 SWITCH: while ($ARGV[0] =~ /^-/) {
9 $aflag = 1, next SWITCH if $flag =~ /^-a$/;
10 $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
11 $cflag = 1, next SWITCH if $flag =~ /^-c$/;
12 $eflag = 1, next SWITCH if $flag =~ /^-e$/;
16 $typemap = shift @ARGV;
17 open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
19 next if /^\s*$/ || /^#/;
21 ($typename, $kind) = split(/\t+/, $_, 2);
22 $type_kind{$typename} = $kind;
26 %input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
29 $var = (int)SvIV($arg)
31 $var = ($type)SvIV($arg)
33 $var = (unsigned int)SvIV($arg)
35 $var = (short)SvIV($arg)
37 $var = (unsigned short)SvIV($arg)
39 $var = (long)SvIV($arg)
41 $var = (unsigned long)SvIV($arg)
43 $var = (char)*SvPV($arg,na)
45 $var = (unsigned char)SvIV($arg)
47 $var = (float)SvNV($arg)
53 $var = ($type)(unsigned long)SvNV($arg)
55 if (SvTYPE($arg) == SVt_REF)
56 $var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
58 croak(\"$var is not a reference\")
60 if (sv_isa($arg, \"${ntype}\"))
61 $var = ($type)(unsigned long)SvNV((SV*)SvANY($arg));
63 croak(\"$var is not of type ${ntype}\")
65 if (sv_isa($arg, \"${ntype}\")) {
66 ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNV((SV*)SvANY($arg));
67 $var = ${type}_desc->ptr;
70 croak(\"$var is not of type ${ntype}\")
72 if (SvTYPE($arg) == SVt_REF)
73 $var = *($type)(unsigned long)SvNV((SV*)SvANY($arg));
75 croak(\"$var is not a reference\")
77 if (sv_isa($arg, \"${ntype}\"))
78 $var = *($type)(unsigned long)SvNV((SV*)SvANY($arg));
80 croak(\"$var is not of type ${ntype}\")
84 $var = ($type)SvPV($arg,na)
86 $var = XS_unpack_$ntype($arg)
88 $var = XS_unpack_$ntype($arg)
90 $var = make_perl_cb_$type($arg)
92 $var = $ntype(items -= $argoff);
93 U32 ix_$var = $argoff;
98 $var.dptr = SvPV($arg, $var.dsize);
104 $* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
106 sv_setiv($arg, (I32)$var);
108 sv_setiv($arg, (I32)$var);
110 sv_setiv($arg, (I32)$var);
112 sv_setiv($arg, (I32)$var);
114 sv_setiv($arg, (I32)$var);
116 sv_setiv($arg, (I32)$var);
118 sv_setiv($arg, (I32)$var);
120 sv_setpvn($arg, (char *)&$var, 1);
122 sv_setiv($arg, (I32)$var);
124 sv_setnv($arg, (double)$var);
126 sv_setnv($arg, $var);
128 sv_setpv($arg, $var);
130 sv_setnv($arg, (double)(unsigned long)$var);
132 sv_setptrref($arg, $var);
134 sv_setptrobj($arg, $var, \"${ntype}\");
136 sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
138 sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
139 ($var ? (void*)new $ntype($var) : 0));
143 sv_setpvn($arg, (char *)&$var, sizeof($var));
145 sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
147 XS_pack_$ntype($arg, $var);
149 XS_pack_$ntype($arg, $var, count_$ntype);
151 sv_setpvn($arg, $var.chp(), $var.size());
153 sv_setpvn($arg, $var.context.value().chp(),
154 $var.context.value().size());
156 ST_EXTEND($var.size);
157 for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
158 ST(ix_$var) = sv_mortalcopy(&sv_undef);
163 sv_setpvn($arg, $var.dptr, $var.dsize);
165 sv_usepvn($arg, $var.dptr, $var.dsize);
168 $uvfile = shift @ARGV;
169 open(F, $uvfile) || die "cannot open $uvfile\n";
172 print qq|#include "cfm/basic.h"\n|;
176 last if ($Module, $foo, $Package, $foo1, $Prefix) =
177 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
181 $Package .= "::" if defined $Package && $Package ne "";
188 next if /^(#.*\n?)+$/;
189 if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
196 $Package .= "::" if defined $Package && $Package ne "";
201 # initialize info arrays
210 # extract return type, function name and arguments
211 $ret_type = shift(@_);
212 if ($ret_type =~ /^static\s+(.*)$/) {
216 $func_header = shift(@_);
217 ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
218 if ($func_name =~ /(.*)::(.*)/) {
222 ($pname = $func_name) =~ s/^($Prefix)?/$Package/;
223 push(@Func_name, "${Pack}_$func_name");
224 push(@Func_pname, $pname);
225 @args = split(/\s*,\s*/, $orig_args);
226 if (defined($class) && !defined($static)) {
227 unshift(@args, "THIS");
228 $orig_args = "THIS, $orig_args";
229 $orig_args =~ s/^THIS, $/THIS/;
231 $orig_args =~ s/"/\\"/g;
232 $min_args = $num_args = @args;
233 foreach $i (0..$num_args-1) {
234 if ($args[$i] =~ s/\.\.\.//) {
237 if ($args[i] eq '' && $i == $num_args - 1) {
242 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
245 $defaults{$args[$i]} = $2;
246 $defaults{$args[$i]} =~ s/"/\\"/g;
249 if (defined($class) && !defined($static)) {
250 $func_args = join(", ", @args[1..$#args]);
252 $func_args = join(", ", @args);
254 @args_match{@args} = 1..@args;
256 # print function header
257 print <<"EOF" if $aflag;
259 XS_${Pack}_$func_name(int, int sp, int items)
261 print <<"EOF" if !$aflag;
263 XS_${Pack}_$func_name(ix, sp, items)
268 print <<"EOF" if $elipsis;
270 if (items < $min_args) {
271 croak("Usage: $pname($orig_args)");
274 print <<"EOF" if !$elipsis;
276 if (items < $min_args || items > $num_args) {
277 croak("Usage: $pname($orig_args)");
281 # Now do a block of some sort.
288 if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
291 print " if ($cond)\n";
293 elsif ($cond ne '') {
294 print " else if ($cond)\n";
302 print <<"EOF" if $eflag;
305 print <<"EOF" if !$eflag;
309 # do initialization of input variables
313 while ($_ = shift(@_)) {
314 last if /^\s*NOT_IMPLEMENTED_YET/;
315 last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
316 ($var_type, $var_name, $var_init) =
317 /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
318 if ($var_name =~ /^&/) {
320 $var_addr{$var_name} = 1;
322 $thisdone |= $var_name eq "THIS";
323 $retvaldone |= $var_name eq "RETVAL";
324 $var_types{$var_name} = $var_type;
325 print "\t" . &map_type($var_type);
326 $var_num = $args_match{$var_name};
327 if ($var_addr{$var_name}) {
328 $func_args =~ s/\b($var_name)\b/&\1/;
330 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
331 if ($var_init !~ /^\s*$/) {
332 &output_init($var_type, $var_num,
333 "$var_name $var_init");
335 # generate initialization code
336 &generate_init($var_type, $var_num, $var_name);
341 print "\t$var_name;\n";
344 if (!$thisdone && defined($class) && !defined($static)) {
346 $var_types{"THIS"} = "$class *";
347 &generate_init("$class *", 1, "THIS");
351 if (/^\s*NOT_IMPLEMENTED_YET/) {
352 print "\ncroak(\"$pname: not implemented yet\");\n";
354 if ($ret_type ne "void") {
355 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
357 $args_match{"RETVAL"} = 0;
358 $var_types{"RETVAL"} = $ret_type;
362 while ($_ = shift(@_)) {
363 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
368 if ($ret_type ne "void") {
371 if (defined($static)) {
373 } elsif (defined($class)) {
376 if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
379 print "$func_name($func_args);\n";
380 &generate_output($ret_type, 0, "RETVAL")
381 unless $ret_type eq "void";
385 # do output variables
386 if (/^\s*OUTPUT\s*:/) {
387 while ($_ = shift(@_)) {
388 last if /^\s*CLEANUP\s*:/;
390 ($outarg, $outcode) = split(/\t+/);
392 print "\t$outcode\n";
394 die "$outarg not an argument"
395 unless defined($args_match{$outarg});
396 $var_num = $args_match{$outarg};
397 &generate_output($var_types{$outarg}, $var_num,
403 if (/^\s*CLEANUP\s*:/) {
404 while ($_ = shift(@_)) {
405 last if /^\s*CASE\s*:/;
409 # print function trailer
410 print <<EOF if $eflag;
414 croak("%s: %s\\tpropagated", Xname, Xreason);
417 print <<EOF if !$eflag;
420 if (/^\s*CASE\s*:/) {
431 # print initialization routine
432 print qq/extern "C"\n/ if $cflag;
434 int init_$Module(ix,sp,items)
439 char* file = __FILE__;
444 $pname = shift(@Func_pname);
445 print " newXSUB(\"$pname\", 0, XS_$_, file);\n";
450 local($type, $num, $init) = @_;
451 local($arg) = "ST($num)";
453 eval qq/print " $init\\\n"/;
457 local($type, $num, $var) = @_;
458 local($arg) = "ST($num)";
459 local($argoff) = $num - 1;
462 die "$type not in typemap" if !defined($type_kind{$type});
463 ($ntype = $type) =~ s/\s*\*/Ptr/g;
465 $subtype =~ s/Ptr$//;
466 $subtype =~ s/Array$//;
467 $expr = $input_expr{$type_kind{$type}};
468 if ($expr =~ /DO_ARRAY_ELEM/) {
469 $subexpr = $input_expr{$type_kind{$subtype}};
470 $subexpr =~ s/ntype/subtype/g;
471 $subexpr =~ s/\$arg/ST(ix_$var)/g;
472 $subexpr =~ s/\n\t/\n\t\t/g;
473 $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
474 $subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
475 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
477 if (defined($defaults{$var})) {
478 $expr =~ s/(\t+)/$1 /g;
480 eval qq/print "\\t$var;\\n"/;
481 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
482 } elsif ($expr !~ /^\t\$var =/) {
483 eval qq/print "\\t$var;\\n"/;
484 $deferred .= eval qq/"\\n$expr;\\n"/;
486 eval qq/print "$expr;\\n"/;
490 sub generate_output {
491 local($type, $num, $var) = @_;
492 local($arg) = "ST($num)";
493 local($argoff) = $num - 1;
496 if ($type =~ /^array\(([^,]*),(.*)\)/) {
497 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
499 die "$type not in typemap" if !defined($type_kind{$type});
500 ($ntype = $type) =~ s/\s*\*/Ptr/g;
503 $subtype =~ s/Ptr$//;
504 $subtype =~ s/Array$//;
505 $expr = $output_expr{$type_kind{$type}};
506 if ($expr =~ /DO_ARRAY_ELEM/) {
507 $subexpr = $output_expr{$type_kind{$subtype}};
508 $subexpr =~ s/ntype/subtype/g;
509 $subexpr =~ s/\$arg/ST(ix_$var)/g;
510 $subexpr =~ s/\$var/${var}[ix_$var]/g;
511 $subexpr =~ s/\n\t/\n\t\t/g;
512 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
514 elsif ($arg eq 'ST(0)') {
515 print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
517 eval "print qq\f$expr\f";
524 if ($type =~ /^array\(([^,]*),(.*)\)/) {