1 diff -ru :perl:lib:ExtUtils: :perl.new:lib:ExtUtils:xsubpp
2 --- :perl:lib:ExtUtils:xsubpp Mon Feb 19 17:07:32 2001
3 +++ :perl.new:lib:ExtUtils:xsubpp Mon Feb 19 15:31:31 2001
5 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
6 or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
7 or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
8 + or ($dir, $filename) = $ARGV[0] =~ m#(.*):(.*)#
9 or ($dir, $filename) = ('.', $ARGV[0]);
11 +$Is_MacOS = $^O eq 'MacOS';
12 +if ($Is_MacOS && $dir eq '.') {
19 foreach $typemap (@tm) {
20 die "Can't find $typemap in $pwd\n" unless -r $typemap;
22 -unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
23 +if ($Is_MacOS) { my @tmp;
24 + foreach (qw(:::: ::: :: :)) {
25 + push @tmp, "$_:lib:ExtUtils:typemap";
26 + push @tmp, "$_:macos:lib:ExtUtils:typemap";
27 + push @tmp, "$_:Mac:typemap";
28 + push @tmp, "$_:macos:ext:Mac:typemap";
29 + push @tmp, "$_:typemap";
31 + unshift @tm, @tmp, "typemap";
33 + unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
34 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
38 foreach $typemap (@tm) {
39 next unless -e $typemap ;
40 # skip directories, binary files etc.
42 print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
43 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
44 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
48 print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
58 + my($type, $value, $xpush) = @_;
60 + print "\tEXTEND(sp, 1);\n";
63 + &generate_output($type, 0, "($value)", "*sp", 1);
67 +sub XS_OUTPUT_handler
69 + my($type, $value, $arg) = @_;
71 + &generate_output($type, 0, "($value)", 0, 0, $arg);
77 + my($type, $var, $arg) = @_;
78 + &generate_init($type, 0, $var, 0, 0, $arg, 1);
85 + my($type, $var, $pop) = @_;
86 + &generate_init($type, 0, $var, "TOPs", 1);
87 + print "\tPOPs;\n" if $pop;
93 + my(@bits,@pieces,$item);
94 + @bits = split /,/, $_[0];
96 + $item .= "," if $item;
97 + $item .= shift @bits;
98 + if (tr/(// == tr/)//
100 + && tr/[// == tr/]//
104 + push @pieces, $item;
115 + while (length($text)) {
116 + if ($text =~ s/^.*\bXS_PUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
117 + XS_PUSH_handler($1, $2, 0);
118 + } elsif ($text =~ s/^.*\bXS_XPUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
119 + XS_PUSH_handler($1, $2, 1);
120 + } elsif ($text =~ s/^.*\bXS_OUTPUT\((.*)\)\s*;?.*\n?//) {
121 + XS_OUTPUT_handler(SplitArgs($1));
122 + } elsif ($text =~ s/^.*\bXS_INPUT\((.*)\)\s*;?.*\n?//) {
123 + XS_INPUT_handler(SplitArgs($1));
124 + } elsif ($text =~ s/^.*\bXS_POP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
125 + XS_POP_handler($1, $2, 1);
126 + } elsif ($text =~ s/^.*\bXS_TOP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
127 + XS_POP_handler($1, $2, 0);
128 + } elsif ($text =~ s/^(.*\n?)//) {
136 return 0 unless $XSStack[-1]{type} eq 'file' ;
138 my $podstartline = $.;
141 - print("/* Skipped embedded POD. */\n");
142 - printf("#line %d \"$filename\"\n", $. + 1)
143 + XS_process("/* Skipped embedded POD. */\n");
144 + XS_process(sprintf("#line %d \"$filename\"\n", $. + 1))
150 s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
155 &Exit unless defined $_;
157 @@ -949,6 +1045,185 @@
166 + if ($line =~ s/^( +)//) { $indent += length $1; next; }
167 + if ($line =~ s/^\t//) { $indent += 8 - ($indent & 7); next; }
175 + # extract return type, function name and arguments
176 + my($deref, $structpack) = /(\**)\s*(\S+)/;
177 + my($handle) = ($^O eq "MacOS") && ($deref eq "**");
178 + $deref =~ s/\*$/->/;
179 + $deref =~ s/\*/\[0\]/g;
181 + my($structtype) = $structpack;
183 + # a struct definition needs at least 2 lines
184 + blurt ("Error: Struct definition too short '$structpack'"), next PARAGRAPH
187 + ($clean_struct_name = $structpack) =~ s/^$Prefix//;
188 + $Full_struct_name = "${Packid}_$clean_struct_name";
189 + if ($Is_VMS) { $Full_struct_name = $SymSet->addsym($Full_struct_name); }
191 + # Check for duplicate function definition
192 + for $tmp (@XSStack) {
193 + next unless defined $tmp->{functions}{$Full_struct_name};
194 + Warn("Warning: duplicate struct definition '$clean_struct_name' detected");
198 + # print struct function header
200 +#XS(XS_${Full_struct_name})
204 +# if (items < 1 || items > 2)
205 +# croak("Usage: %s(STRUCT [, VALUE])", GvNAME(CvGV(cv)));
209 + # Now do a block of some sort.
212 + my($structinput, $structoutput, $structindir, $structoutdir);
213 + my(@field, @fieldindir, @fieldoutdir, @input, @output);
214 + $structindir = $structoutdir = line_directive();
216 + while (defined $_) {
217 + $_ = shift @line while /^\s*$/;
218 + my($fieldindir) = line_directive();
219 + my($fieldoutdir)= $fieldindir;
220 + my($indent,$fieldtype,$fieldname) =
221 + m|^(\s*)(\S.*\S)\s*\b(\w+)\s*;?\s*(?:/\*.*\*/)?$|;
222 + $indent = indent $indent;
223 + $fieldtype = TidyType $fieldtype;
224 + my($input, $output);
225 + my $var = "STRUCT$deref$fieldname";
227 + while (/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) {
228 + if (/ALIAS\s*(.*)/) {
231 + } elsif (/READ_ONLY/) {
232 + $fieldindir = line_directive();
235 + } elsif (/INPUT/) {
236 + last unless ($_ = shift @line);
237 + $fieldindir = line_directive();
238 + while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) {
243 + last unless ($_ = shift @line);
244 + $fieldoutdir = line_directive();
245 + while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) {
251 + if ($fieldname eq "STRUCT") {
252 + $structindir = $fieldindir;
253 + $structoutdir= $fieldoutdir;
254 + $structtype = $fieldtype;
256 + $structinput = eval "qq\a$input\a";
257 + $structoutput= eval "qq\a$output\a";
259 + if ($input =~ /READ_ONLY/) {
260 + $input = "\tcroak(\"$var is read-only\");\n";
263 + $input = eval "qq\a$input\a";
265 + $input = "\tXS_INPUT($fieldtype, $var, ST(1));";
269 + $output = "\tPUSHs(sv_newmortal());\n" . eval "qq\a$output\a";
271 + $output = "\tXS_PUSH($fieldtype, $var);";
273 + push @field, $fieldname;
274 + push @fieldindir, $fieldindir;
275 + push @fieldoutdir, $fieldoutdir;
276 + push @input, $input;
277 + push @output, $output;
282 +# $structtype STRUCT;
284 + print "\tchar STRUCT_state;\n" if $handle;
285 + print "\n$structindir";
286 + XS_process($structinput || "\tXS_INPUT($structtype, STRUCT, ST(0));");
287 + print "\n\tSTRUCT_state = HGetState((Handle)STRUCT); HLock((Handle)STRUCT);\n" if ($handle);
289 +# if (items == 1) [[ /* Get field */
294 +# case $_: /* $field[$_] */
296 + print $fieldoutdir[$_];
297 + XS_process($output[$_]);
304 +# ]] else [[ /* Set field */
309 +# case $_: /* $field[$_] */
311 + print $fieldindir[$_];
312 + XS_process($input[$_]);
320 + print $structoutdir;
321 + XS_process($structoutput || "\tXS_OUTPUT($structtype, STRUCT, ST(0))\n");
325 + print "\tHSetState((Handle)STRUCT, STRUCT_state);\n" if $handle;
333 + push(@InitFileCode, Q<<"EOF");
334 +# cv = newXS(\"${structpack}::$field[$_]\", XS_$Full_struct_name, file);
335 +# XSANY.any_i32 = $_ ;
341 while (fetch_para()) {
342 # Print initial preprocessor statements and blank lines
343 @@ -1040,7 +1315,11 @@
348 + if (s/^STRUCT\s*//) {
353 # extract return type, function name and arguments
354 ($ret_type) = TidyType($_);
355 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
356 @@ -1285,7 +1564,7 @@
357 $processing_arg_with_types = 1;
361 + XS_process($deferred);
363 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
365 @@ -1338,7 +1617,7 @@
367 # all OUTPUT done, so now push the return value on the stack
368 if ($gotRETVAL && $RETVAL_code) {
369 - print "\t$RETVAL_code\n";
370 + XS_process("\t$RETVAL_code\n");
371 } elsif ($gotRETVAL || $wantRETVAL) {
372 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
374 @@ -1574,6 +1853,14 @@
380 + # work out the line number
381 + my $line_no = $line_no[@line_no - @line -1] ;
383 + return "#line $line_no \"$filename\"\n" ;
388 # work out the line number
389 @@ -1595,12 +1882,12 @@
393 - local($type, $num, $var) = @_;
394 - local($arg) = "ST(" . ($num - 1) . ")";
395 + local($type, $num, $var, $arg, $immed) = @_;
396 local($argoff) = $num - 1;
400 + $arg ||= "ST(" . ($num - 1) . ")";
401 $type = TidyType($type) ;
402 blurt("Error: '$type' not in typemap"), return
403 unless defined($type_kind{$type});
404 @@ -1656,17 +1943,18 @@
406 die "panic: do not know how to handle this branch for function pointers"
408 - eval qq/print "$expr;\\n"/;
409 + eval qq/XS_process "$expr;\\n"/;
414 sub generate_output {
415 - local($type, $num, $var, $do_setmagic, $do_push) = @_;
416 - local($arg) = "ST(" . ($num - ($num != 0)) . ")";
417 + local($type, $num, $var, $do_setmagic, $do_push, $arg, $mortalize) = @_;
418 local($argoff) = $num - 1;
421 + $mortalize ||= $var eq 'RETVAL';
422 + $arg ||= "ST(" . ($num - ($num != 0)) . ")";
423 $type = TidyType($type) ;
424 if ($type =~ /^array\(([^,]*),(.*)\)/) {
425 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
426 @@ -1695,30 +1983,30 @@
428 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
430 - elsif ($var eq 'RETVAL') {
431 + elsif ($mortalize) {
432 if ($expr =~ /^\t\$arg = new/) {
433 # We expect that $arg has refcnt 1, so we need to
435 eval "print qq\a$expr\a";
437 - print "\tsv_2mortal(ST($num));\n";
438 - print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
439 + print "\tsv_2mortal($arg);\n";
440 + print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
442 elsif ($expr =~ /^\s*\$arg\s*=/) {
443 # We expect that $arg has refcnt >=1, so we need
445 eval "print qq\a$expr\a";
447 - print "\tsv_2mortal(ST(0));\n";
448 - print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
449 + print "\tsv_2mortal($arg);\n";
450 + print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
453 # Just hope that the entry would safely write it
454 # over an already mortalized value. By
455 # coincidence, something like $arg = &sv_undef
457 - print "\tST(0) = sv_newmortal();\n";
458 - eval "print qq\a$expr\a";
459 + print "\t$arg = sv_newmortal();\n";
460 + eval "XS_process qq\a$expr\a";
462 # new mortals don't have set magic
464 @@ -1730,8 +2018,8 @@
466 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
468 - elsif ($arg =~ /^ST\(\d+\)$/) {
469 - eval "print qq\a$expr\a";
471 + eval "XS_process qq\a$expr\a";
473 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;