This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[perl5.git] / ext / xsubpp
CommitLineData
93a17b20
LW
1#!/usr/bin/perl
2# $Header$
3
463ee0b2 4$usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
93a17b20
LW
5die $usage unless (@ARGV >= 2 && @ARGV <= 6);
6
7SWITCH: while ($ARGV[0] =~ /^-/) {
8 $flag = shift @ARGV;
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$/;
13 die $usage;
14}
15
16$typemap = shift @ARGV;
17open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
18while (<TYPEMAP>) {
19 next if /^\s*$/ || /^#/;
20 chop;
21 ($typename, $kind) = split(/\t+/, $_, 2);
22 $type_kind{$typename} = $kind;
23}
24close(TYPEMAP);
25
26%input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
27
28T_INT
463ee0b2 29 $var = (int)SvIV($arg)
93a17b20 30T_ENUM
463ee0b2 31 $var = ($type)SvIV($arg)
93a17b20 32T_U_INT
463ee0b2 33 $var = (unsigned int)SvIV($arg)
93a17b20 34T_SHORT
463ee0b2 35 $var = (short)SvIV($arg)
93a17b20 36T_U_SHORT
463ee0b2 37 $var = (unsigned short)SvIV($arg)
93a17b20 38T_LONG
463ee0b2 39 $var = (long)SvIV($arg)
93a17b20 40T_U_LONG
463ee0b2 41 $var = (unsigned long)SvIV($arg)
93a17b20 42T_CHAR
463ee0b2 43 $var = (char)*SvPV($arg,na)
93a17b20 44T_U_CHAR
463ee0b2 45 $var = (unsigned char)SvIV($arg)
93a17b20 46T_FLOAT
463ee0b2 47 $var = (float)SvNV($arg)
93a17b20 48T_DOUBLE
463ee0b2 49 $var = SvNV($arg)
93a17b20 50T_STRING
463ee0b2 51 $var = SvPV($arg,na)
93a17b20 52T_PTR
463ee0b2
LW
53 $var = ($type)(unsigned long)SvNV($arg)
54T_PTRREF
ed6116ce
LW
55 if (SvROK($arg))
56 $var = ($type)(unsigned long)SvNV((SV*)SvRV($arg));
463ee0b2
LW
57 else
58 croak(\"$var is not a reference\")
59T_PTROBJ
60 if (sv_isa($arg, \"${ntype}\"))
ed6116ce 61 $var = ($type)(unsigned long)SvNV((SV*)SvRV($arg));
463ee0b2
LW
62 else
63 croak(\"$var is not of type ${ntype}\")
64T_PTRDESC
65 if (sv_isa($arg, \"${ntype}\")) {
ed6116ce 66 ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNV((SV*)SvRV($arg));
463ee0b2
LW
67 $var = ${type}_desc->ptr;
68 }
69 else
70 croak(\"$var is not of type ${ntype}\")
71T_REFREF
ed6116ce
LW
72 if (SvROK($arg))
73 $var = *($type)(unsigned long)SvNV((SV*)SvRV($arg));
463ee0b2
LW
74 else
75 croak(\"$var is not a reference\")
76T_REFOBJ
77 if (sv_isa($arg, \"${ntype}\"))
ed6116ce 78 $var = *($type)(unsigned long)SvNV((SV*)SvRV($arg));
463ee0b2
LW
79 else
80 croak(\"$var is not of type ${ntype}\")
93a17b20
LW
81T_OPAQUE
82 $var NOT IMPLEMENTED
83T_OPAQUEPTR
463ee0b2 84 $var = ($type)SvPV($arg,na)
93a17b20 85T_PACKED
463ee0b2 86 $var = XS_unpack_$ntype($arg)
93a17b20 87T_PACKEDARRAY
463ee0b2 88 $var = XS_unpack_$ntype($arg)
93a17b20
LW
89T_CALLBACK
90 $var = make_perl_cb_$type($arg)
91T_ARRAY
92 $var = $ntype(items -= $argoff);
93 U32 ix_$var = $argoff;
94 while (items--) {
95 DO_ARRAY_ELEM;
96 }
463ee0b2
LW
97T_DATUM
98 $var.dptr = SvPV($arg, $var.dsize);
99T_GDATUM
100 UNIMPLEMENTED
93a17b20
LW
101T_PLACEHOLDER
102T_END
103
104$* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
105T_INT
463ee0b2 106 sv_setiv($arg, (I32)$var);
93a17b20 107T_ENUM
463ee0b2 108 sv_setiv($arg, (I32)$var);
93a17b20 109T_U_INT
463ee0b2 110 sv_setiv($arg, (I32)$var);
93a17b20 111T_SHORT
463ee0b2 112 sv_setiv($arg, (I32)$var);
93a17b20 113T_U_SHORT
463ee0b2 114 sv_setiv($arg, (I32)$var);
93a17b20 115T_LONG
463ee0b2 116 sv_setiv($arg, (I32)$var);
93a17b20 117T_U_LONG
463ee0b2 118 sv_setiv($arg, (I32)$var);
93a17b20 119T_CHAR
463ee0b2 120 sv_setpvn($arg, (char *)&$var, 1);
93a17b20 121T_U_CHAR
463ee0b2 122 sv_setiv($arg, (I32)$var);
93a17b20 123T_FLOAT
463ee0b2 124 sv_setnv($arg, (double)$var);
93a17b20 125T_DOUBLE
463ee0b2 126 sv_setnv($arg, $var);
93a17b20 127T_STRING
463ee0b2 128 sv_setpv($arg, $var);
93a17b20 129T_PTR
463ee0b2
LW
130 sv_setnv($arg, (double)(unsigned long)$var);
131T_PTRREF
132 sv_setptrref($arg, $var);
133T_PTROBJ
134 sv_setptrobj($arg, $var, \"${ntype}\");
135T_PTRDESC
136 sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
137T_REFREF
138 sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
139 ($var ? (void*)new $ntype($var) : 0));
140T_REFOBJ
141 NOT IMPLEMENTED
93a17b20 142T_OPAQUE
463ee0b2 143 sv_setpvn($arg, (char *)&$var, sizeof($var));
93a17b20 144T_OPAQUEPTR
463ee0b2 145 sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
93a17b20 146T_PACKED
463ee0b2 147 XS_pack_$ntype($arg, $var);
93a17b20 148T_PACKEDARRAY
463ee0b2 149 XS_pack_$ntype($arg, $var, count_$ntype);
93a17b20 150T_DATAUNIT
463ee0b2 151 sv_setpvn($arg, $var.chp(), $var.size());
93a17b20 152T_CALLBACK
463ee0b2 153 sv_setpvn($arg, $var.context.value().chp(),
93a17b20
LW
154 $var.context.value().size());
155T_ARRAY
156 ST_EXTEND($var.size);
157 for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
463ee0b2 158 ST(ix_$var) = sv_mortalcopy(&sv_undef);
93a17b20
LW
159 DO_ARRAY_ELEM
160 }
161 sp += $var.size - 1;
463ee0b2
LW
162T_DATUM
163 sv_setpvn($arg, $var.dptr, $var.dsize);
164T_GDATUM
165 sv_usepvn($arg, $var.dptr, $var.dsize);
93a17b20
LW
166T_END
167
168$uvfile = shift @ARGV;
169open(F, $uvfile) || die "cannot open $uvfile\n";
170
171if ($eflag) {
172 print qq|#include "cfm/basic.h"\n|;
173}
174
175while (<F>) {
176 last if ($Module, $foo, $Package, $foo1, $Prefix) =
177 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
178 print $_;
179}
180$Pack = $Package;
463ee0b2 181$Package .= "::" if defined $Package && $Package ne "";
93a17b20
LW
182$/ = "";
183
184while (<F>) {
185 # parse paragraph
186 chop;
187 next if /^\s*$/;
188 next if /^(#.*\n?)+$/;
189 if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
190 $Module = $1;
191 $foo = $2;
192 $Package = $3;
193 $Pack = $Package;
194 $foo1 = $4;
195 $Prefix = $5;
463ee0b2 196 $Package .= "::" if defined $Package && $Package ne "";
93a17b20
LW
197 next;
198 }
199 split(/[\t ]*\n/);
200
201 # initialize info arrays
202 undef(%args_match);
203 undef(%var_types);
204 undef(%var_addr);
205 undef(%defaults);
206 undef($class);
207 undef($static);
208 undef($elipsis);
209
210 # extract return type, function name and arguments
211 $ret_type = shift(@_);
212 if ($ret_type =~ /^static\s+(.*)$/) {
213 $static = 1;
214 $ret_type = $1;
215 }
216 $func_header = shift(@_);
217 ($func_name, $orig_args) = $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
218 if ($func_name =~ /(.*)::(.*)/) {
219 $class = $1;
220 $func_name = $2;
221 }
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/;
230 }
231 $orig_args =~ s/"/\\"/g;
232 $min_args = $num_args = @args;
233 foreach $i (0..$num_args-1) {
234 if ($args[$i] =~ s/\.\.\.//) {
235 $elipsis = 1;
236 $min_args--;
237 if ($args[i] eq '' && $i == $num_args - 1) {
238 pop(@args);
239 last;
240 }
241 }
242 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
243 $min_args--;
244 $args[$i] = $1;
245 $defaults{$args[$i]} = $2;
246 $defaults{$args[$i]} =~ s/"/\\"/g;
247 }
248 }
249 if (defined($class) && !defined($static)) {
250 $func_args = join(", ", @args[1..$#args]);
251 } else {
252 $func_args = join(", ", @args);
253 }
254 @args_match{@args} = 1..@args;
255
256 # print function header
257 print <<"EOF" if $aflag;
258static int
463ee0b2 259XS_${Pack}_$func_name(int, int sp, int items)
93a17b20
LW
260EOF
261 print <<"EOF" if !$aflag;
262static int
463ee0b2 263XS_${Pack}_$func_name(ix, sp, items)
93a17b20
LW
264register int ix;
265register int sp;
266register int items;
267EOF
268 print <<"EOF" if $elipsis;
269{
270 if (items < $min_args) {
463ee0b2 271 croak("Usage: $pname($orig_args)");
93a17b20
LW
272 }
273EOF
274 print <<"EOF" if !$elipsis;
275{
276 if (items < $min_args || items > $num_args) {
463ee0b2 277 croak("Usage: $pname($orig_args)");
93a17b20
LW
278 }
279EOF
280
281# Now do a block of some sort.
282
283$condnum = 0;
284if (!@_) {
285 @_ = "CLEANUP:";
286}
287while (@_) {
288 if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
289 $cond = shift(@_);
290 if ($condnum == 0) {
291 print " if ($cond)\n";
292 }
293 elsif ($cond ne '') {
294 print " else if ($cond)\n";
295 }
296 else {
297 print " else\n";
298 }
299 $condnum++;
300 }
301
302 print <<"EOF" if $eflag;
303 TRY {
304EOF
305 print <<"EOF" if !$eflag;
306 {
307EOF
308
309 # do initialization of input variables
310 $thisdone = 0;
311 $retvaldone = 0;
463ee0b2 312 $deferred = "";
93a17b20
LW
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 =~ /^&/) {
319 $var_name =~ s/^&//;
320 $var_addr{$var_name} = 1;
321 }
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/;
329 }
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");
334 } elsif ($var_num) {
335 # generate initialization code
336 &generate_init($var_type, $var_num, $var_name);
337 } else {
338 print ";\n";
339 }
340 } else {
341 print "\t$var_name;\n";
342 }
343 }
344 if (!$thisdone && defined($class) && !defined($static)) {
345 print "\t$class *";
346 $var_types{"THIS"} = "$class *";
347 &generate_init("$class *", 1, "THIS");
348 }
349
350 # do code
351 if (/^\s*NOT_IMPLEMENTED_YET/) {
463ee0b2 352 print "\ncroak(\"$pname: not implemented yet\");\n";
93a17b20
LW
353 } else {
354 if ($ret_type ne "void") {
355 print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
356 if !$retvaldone;
357 $args_match{"RETVAL"} = 0;
358 $var_types{"RETVAL"} = $ret_type;
359 }
463ee0b2 360 print $deferred;
93a17b20
LW
361 if (/^\s*CODE:/) {
362 while ($_ = shift(@_)) {
363 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
364 print "$_\n";
365 }
366 } else {
367 print "\n\t";
368 if ($ret_type ne "void") {
463ee0b2 369 print "RETVAL = ";
93a17b20
LW
370 }
371 if (defined($static)) {
372 print "$class::";
373 } elsif (defined($class)) {
374 print "THIS->";
375 }
376 if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
377 $func_name = $2;
378 }
379 print "$func_name($func_args);\n";
380 &generate_output($ret_type, 0, "RETVAL")
381 unless $ret_type eq "void";
382 }
383 }
384
385 # do output variables
386 if (/^\s*OUTPUT\s*:/) {
387 while ($_ = shift(@_)) {
388 last if /^\s*CLEANUP\s*:/;
389 s/^\s+//;
390 ($outarg, $outcode) = split(/\t+/);
391 if ($outcode) {
392 print "\t$outcode\n";
393 } else {
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,
398 $outarg);
399 }
400 }
401 }
402 # do cleanup
403 if (/^\s*CLEANUP\s*:/) {
404 while ($_ = shift(@_)) {
405 last if /^\s*CASE\s*:/;
406 print "$_\n";
407 }
408 }
409 # print function trailer
410 print <<EOF if $eflag;
411 }
412 BEGHANDLERS
413 CATCHALL
463ee0b2 414 croak("%s: %s\\tpropagated", Xname, Xreason);
93a17b20
LW
415 ENDHANDLERS
416EOF
417 print <<EOF if !$eflag;
418 }
419EOF
420 if (/^\s*CASE\s*:/) {
421 unshift(@_, $_);
422 }
423}
424 print <<EOF;
425 return sp;
426}
427
428EOF
429}
430
431# print initialization routine
432print qq/extern "C"\n/ if $cflag;
433print <<"EOF";
463ee0b2
LW
434int init_$Module(ix,sp,items)
435int ix;
436int sp;
437int items;
93a17b20 438{
463ee0b2
LW
439 char* file = __FILE__;
440
93a17b20
LW
441EOF
442
443for (@Func_name) {
444 $pname = shift(@Func_pname);
463ee0b2 445 print " newXSUB(\"$pname\", 0, XS_$_, file);\n";
93a17b20
LW
446}
447print "}\n";
448
449sub output_init {
450 local($type, $num, $init) = @_;
451 local($arg) = "ST($num)";
452
463ee0b2 453 eval qq/print " $init\\\n"/;
93a17b20
LW
454}
455
456sub generate_init {
457 local($type, $num, $var) = @_;
458 local($arg) = "ST($num)";
459 local($argoff) = $num - 1;
460 local($ntype);
461
462 die "$type not in typemap" if !defined($type_kind{$type});
463 ($ntype = $type) =~ s/\s*\*/Ptr/g;
464 $subtype = $ntype;
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/;
476 }
477 if (defined($defaults{$var})) {
478 $expr =~ s/(\t+)/$1 /g;
479 $expr =~ s/ /\t/g;
463ee0b2
LW
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"/;
93a17b20 482 } elsif ($expr !~ /^\t\$var =/) {
463ee0b2
LW
483 eval qq/print "\\t$var;\\n"/;
484 $deferred .= eval qq/"\\n$expr;\\n"/;
93a17b20 485 } else {
463ee0b2 486 eval qq/print "$expr;\\n"/;
93a17b20
LW
487 }
488}
489
490sub generate_output {
491 local($type, $num, $var) = @_;
492 local($arg) = "ST($num)";
493 local($argoff) = $num - 1;
494 local($ntype);
495
496 if ($type =~ /^array\(([^,]*),(.*)\)/) {
463ee0b2 497 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
93a17b20
LW
498 } else {
499 die "$type not in typemap" if !defined($type_kind{$type});
500 ($ntype = $type) =~ s/\s*\*/Ptr/g;
501 $ntype =~ s/\(\)//g;
502 $subtype = $ntype;
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/;
513 }
463ee0b2
LW
514 elsif ($arg eq 'ST(0)') {
515 print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
516 }
93a17b20
LW
517 eval "print qq\f$expr\f";
518 }
519}
520
521sub map_type {
522 local($type) = @_;
523
524 if ($type =~ /^array\(([^,]*),(.*)\)/) {
525 return "$1 *";
526 } else {
527 return $type;
528 }
529}