Change 16135: Merge macperl xsubpp with current xsubpp
[email protected] (Chris Nandor) Wed, 24 Apr 2002 15:22:29 -0400
| Newsgroups | perl.perl5.changes.mac |
|---|---|
| Message-ID | <p05100316b8ecb668b406@[10.0.1.177]> |
Change 16135 by pudge@pudge-mobile on 2002/04/24 18:08:45
Merge macperl xsubpp with current xsubpp
Affected files ...
.... //depot/macperl/macos/xsubpp#2 edit
Differences ...
==== //depot/macperl/macos/xsubpp#2 (text) ====
Index: perl/macos/xsubpp
--- perl/macos/xsubpp.~1~ Wed Apr 24 12:15:10 2002
+++ perl/macos/xsubpp Wed Apr 24 12:15:10 2002
@@ -34,6 +34,10 @@
Adds ``extern "C"'' to the C code.
+=item B<-hiertype>
+
+Retains '::' in type names so that C++ hierachical types can be mapped.
+
=item B<-except>
Adds exception handling stubs to the C code.
@@ -100,7 +104,7 @@
require 5.002;
use Cwd;
-use vars '$cplusplus';
+use vars qw($cplusplus $hiertype);
use vars '%v';
use Config;
@@ -124,9 +128,7 @@
$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n";
-$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
-# mjn
-$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+$proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
$except = "";
$WantPrototypes = -1 ;
@@ -134,6 +136,7 @@
$ProtoUsed = 0 ;
$WantLineNumbers = 1 ;
$WantOptimize = 1 ;
+$Overload = 0;
my $process_inout = 1;
my $process_argtypes = 1;
@@ -143,12 +146,13 @@
$flag =~ s/^-// ;
$spat = quotemeta shift, next SWITCH if $flag eq 's';
$cplusplus = 1, next SWITCH if $flag eq 'C++';
+ $hiertype = 1, next SWITCH if $flag eq 'hiertype';
$WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes';
$WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
$WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck';
$WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck';
# XXX left this in for compat
- $WantCAPI = 1, next SWITCH if $flag eq 'object_capi';
+ next SWITCH if $flag eq 'object_capi';
$except = " TRY", next SWITCH if $flag eq 'except';
push(@tm,shift), next SWITCH if $flag eq 'typemap';
$WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers';
@@ -204,7 +208,7 @@
# change multiple whitespace into a single space
s/\s+/ /g ;
-
+
# trim leading & trailing whitespace
TrimWhitespace($_) ;
@@ -234,16 +238,16 @@
foreach $typemap (@tm) {
next unless -e $typemap ;
# skip directories, binary files etc.
- warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
+ warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
unless -T $typemap ;
- open(TYPEMAP, $typemap)
+ open(TYPEMAP, $typemap)
or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
$mode = 'Typemap';
$junk = "" ;
$current = \$junk;
while (<TYPEMAP>) {
next if /^\s*#/;
- my $line_no = $. + 1;
+ my $line_no = $. + 1;
if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
@@ -259,7 +263,7 @@
$type_kind{$type} = $kind ;
# prototype defaults to '$'
$proto = "\$" unless $proto ;
- warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
+ warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$type} = C_string($proto) ;
}
@@ -281,7 +285,7 @@
}
foreach $key (keys %input_expr) {
- $input_expr{$key} =~ s/\n+$//;
+ $input_expr{$key} =~ s/;*\s+\z//;
}
$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
@@ -306,9 +310,9 @@
# Match an XS keyword
$BLOCK_re= '\s*(' . join('|', qw(
- REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
+ REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
- SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL
+ SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD
)) . "|$END)\\s*:";
# Input: ($_, @line) == unparsed input.
@@ -379,7 +383,7 @@
sub print_section {
# the "do" is required for right semantics
do { $_ = shift(@line) } while !/\S/ && @line;
-
+
print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
@@ -390,11 +394,11 @@
sub merge_section {
my $in = '';
-
+
while (!/\S/ && @line) {
$_ = shift(@line);
}
-
+
for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
$in .= "$_\n";
}
@@ -407,7 +411,7 @@
my($pattern) = @_ ;
my $kwd ;
- &{"${kwd}_handler"}()
+ &{"${kwd}_handler"}()
while $kwd = check_keyword($pattern) ;
}
@@ -423,7 +427,7 @@
sub INPUT_handler {
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
last if /^\s*NOT_IMPLEMENTED_YET/;
- next unless /\S/; # skip blank lines
+ next unless /\S/; # skip blank lines
TrimWhitespace($_) ;
my $line = $_ ;
@@ -431,6 +435,14 @@
# remove trailing semicolon if no initialisation
s/\s*;$//g unless /[=;+].*\S/ ;
+ # Process the length(foo) declarations
+ if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
+ print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
+ $lengthof{$2} = $name;
+ # $islengthof{$name} = $1;
+ $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
+ }
+
# check for optional initialisation code
my $var_init = '' ;
$var_init = $1 if s/\s*([=;+].*)$//s ;
@@ -442,8 +454,8 @@
# Check for duplicate definitions
blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
- if $arg_list{$var_name}++
- or defined $arg_types{$var_name} and not $processing_arg_with_types;
+ if $arg_list{$var_name}++
+ or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
$thisdone |= $var_name eq "THIS";
$retvaldone |= $var_name eq "RETVAL";
@@ -461,7 +473,7 @@
}
$var_num = $args_match{$var_name};
- $proto_arg[$var_num] = ProtoString($var_type)
+ $proto_arg[$var_num] = ProtoString($var_type)
if $var_num ;
$func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
@@ -510,21 +522,21 @@
} else {
&generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
}
- delete $in_out{$outarg} # No need to auto-OUTPUT
+ delete $in_out{$outarg} # No need to auto-OUTPUT
if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
}
}
sub C_ARGS_handler() {
my $in = merge_section();
-
+
TrimWhitespace($in);
$func_args = $in;
-}
+}
sub INTERFACE_MACRO_handler() {
my $in = merge_section();
-
+
TrimWhitespace($in);
if ($in =~ /\s/) { # two
($interface_macro, $interface_macro_set) = split ' ', $in;
@@ -538,9 +550,9 @@
sub INTERFACE_handler() {
my $in = merge_section();
-
+
TrimWhitespace($in);
-
+
foreach (split /[\s,]+/, $in) {
$Interfaces{$_} = $_;
}
@@ -551,10 +563,10 @@
$Interfaces = 1; # global
}
-sub CLEANUP_handler() { print_section() }
-sub PREINIT_handler() { print_section() }
-sub POSTCALL_handler() { print_section() }
-sub INIT_handler() { print_section() }
+sub CLEANUP_handler() { print_section() }
+sub PREINIT_handler() { print_section() }
+sub POSTCALL_handler() { print_section() }
+sub INIT_handler() { print_section() }
sub GetAliases
{
@@ -574,7 +586,7 @@
# check for optional package definition in the alias
$alias = $Packprefix . $alias if $alias !~ /::/ ;
-
+
# check for duplicate alias name & duplicate value
Warn("Warning: Ignoring duplicate alias '$orig_alias'")
if defined $XsubAliases{$alias} ;
@@ -609,6 +621,21 @@
}
}
+sub OVERLOAD_handler()
+{
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
+ $Overload = 1 unless $Overload;
+ my $overload = "$Package\::(".$1 ;
+ push(@InitFileCode,
+ " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
+ }
+ }
+
+}
+
sub REQUIRE_handler ()
{
# the rest of the current line should contain a version number
@@ -624,30 +651,30 @@
unless $Ver =~ /^\d+(\.\d*)?/ ;
death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
- unless $XSUBPP_version >= $Ver ;
+ unless $XSUBPP_version >= $Ver ;
}
sub VERSIONCHECK_handler ()
{
# the rest of the current line should contain either ENABLE or
# DISABLE
-
+
TrimWhitespace($_) ;
-
+
# check for ENABLE/DISABLE
death ("Error: VERSIONCHECK: ENABLE/DISABLE")
unless /^(ENABLE|DISABLE)/i ;
-
+
$WantVersionChk = 1 if $1 eq 'ENABLE' ;
$WantVersionChk = 0 if $1 eq 'DISABLE' ;
-
+
}
sub PROTOTYPE_handler ()
{
my $specified ;
- death("Error: Only 1 PROTOTYPE definition allowed per xsub")
+ death("Error: Only 1 PROTOTYPE definition allowed per xsub")
if $proto_in_this_xsub ++ ;
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
@@ -655,10 +682,10 @@
$specified = 1 ;
TrimWhitespace($_) ;
if ($_ eq 'DISABLE') {
- $ProtoThisXSUB = 0
+ $ProtoThisXSUB = 0
}
elsif ($_ eq 'ENABLE') {
- $ProtoThisXSUB = 1
+ $ProtoThisXSUB = 1
}
else {
# remove any whitespace
@@ -678,17 +705,17 @@
sub SCOPE_handler ()
{
- death("Error: Only 1 SCOPE declaration allowed per xsub")
+ death("Error: Only 1 SCOPE declaration allowed per xsub")
if $scope_in_this_xsub ++ ;
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
next unless /\S/;
TrimWhitespace($_) ;
if ($_ =~ /^DISABLE/i) {
- $ScopeThisXSUB = 0
+ $ScopeThisXSUB = 0
}
elsif ($_ =~ /^ENABLE/i) {
- $ScopeThisXSUB = 1
+ $ScopeThisXSUB = 1
}
}
@@ -697,7 +724,7 @@
sub PROTOTYPES_handler ()
{
# the rest of the current line should contain either ENABLE or
- # DISABLE
+ # DISABLE
TrimWhitespace($_) ;
@@ -714,9 +741,9 @@
sub INCLUDE_handler ()
{
# the rest of the current line should contain a valid filename
-
+
TrimWhitespace($_) ;
-
+
death("INCLUDE: filename missing")
unless $_ ;
@@ -739,12 +766,12 @@
Filename => $filename,
Handle => $FH,
}) ;
-
+
++ $FH ;
# open the new file
open ($FH, "$_") or death("Cannot open '$_': $!") ;
-
+
print Q<<"EOF" ;
#
#/* INCLUDE: Including '$_' from '$filename' */
@@ -753,7 +780,7 @@
$filename = $_ ;
- # Prime the pump by reading the first
+ # Prime the pump by reading the first
# non-blank line
# skip leading blank lines
@@ -763,7 +790,7 @@
$lastline = $_ ;
$lastline_no = $. ;
-
+
}
sub XS_PUSH_handler
@@ -853,7 +880,7 @@
my $data = pop @XSStack ;
my $ThisFile = $filename ;
my $isPipe = ($filename =~ /\|\s*$/) ;
-
+
-- $IncludedFiles{$filename}
unless $isPipe ;
@@ -941,15 +968,15 @@
# Identify the version of xsubpp used
print <<EOM ;
/*
- * This file was generated automatically by xsubpp version $XSUBPP_version from the
+ * This file was generated automatically by xsubpp version $XSUBPP_version from the
* contents of $filename. Do not edit this file, edit $filename instead.
*
- * ANY CHANGES MADE HERE WILL BE LOST!
+ * ANY CHANGES MADE HERE WILL BE LOST!
*
*/
EOM
-
+
print("#line 1 \"$filename\"\n")
if $WantLineNumbers;
@@ -976,9 +1003,6 @@
last if ($Module, $Package, $Prefix) =
/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
- if ($OBJ) {
- s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
- }
XS_process($_);
}
&Exit unless defined $_;
@@ -1011,7 +1035,7 @@
}
for(;;) {
- # Skip embedded PODs
+ # Skip embedded PODs
while ($lastline =~ /^=/) {
while ($lastline = <$FH>) {
last if ($lastline =~ /^=cut\s*$/);
@@ -1275,7 +1299,7 @@
death ("Code is not inside a function"
." (maybe last function was ended by a blank line "
- ." followed by a a statement on column one?)")
+ ." followed by a statement on column one?)")
if $line[0] =~ /^\s/;
# initialize info arrays
@@ -1289,11 +1313,14 @@
undef($RETVAL_no_return) ;
undef(%arg_list) ;
undef(@proto_arg) ;
- undef(@arg_with_types) ;
+ undef(@fake_INPUT_pre) ; # For length(s) generated variables
+ undef(@fake_INPUT) ;
undef($processing_arg_with_types) ;
- undef(%arg_types) ;
+ undef(%argtype_seen) ;
undef(@outlist) ;
undef(%in_out) ;
+ undef(%lengthof) ;
+ # undef(%islengthof) ;
undef($proto_in_this_xsub) ;
undef($scope_in_this_xsub) ;
undef($interface);
@@ -1362,7 +1389,7 @@
$orig_args =~ s/\\\s*/ /g; # process line continuations
- my %only_outlist;
+ my %only_C_inlist; # Not in the signature of Perl function
if ($process_argtypes and $orig_args =~ /\S/) {
my $args = "$orig_args ,";
if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
@@ -1370,10 +1397,10 @@
for ( @args ) {
s/^\s+//;
s/\s+$//;
- my $arg = $_;
- my $default;
- ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
- my ($pre, $name) = ($arg =~ /(.*?) \s* \b(\w+) \s* $ /x);
+ my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
+ my ($pre, $name) = ($arg =~ /(.*?) \s*
+ \b ( \w+ | length\( \s*\w+\s* \) )
+ \s* $ /x);
next unless length $pre;
my $out_type;
my $inout_var;
@@ -1381,14 +1408,26 @@
my $type = $1;
$out_type = $type if $type ne 'IN';
$arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
+ $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
}
- if (/\W/) { # Has a type
- push @arg_with_types, $arg;
+ my $islength;
+ if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
+ $name = "XSauto_length_of_$1";
+ $islength = 1;
+ die "Default value on length() argument: `$_'"
+ if length $default;
+ }
+ if (length $pre or $islength) { # Has a type
+ if ($islength) {
+ push @fake_INPUT_pre, $arg;
+ } else {
+ push @fake_INPUT, $arg;
+ }
# warn "pushing '$arg'\n";
- $arg_types{$name} = $arg;
- $_ = "$name$default";
+ $argtype_seen{$name}++;
+ $_ = "$name$default"; # Assigns to @args
}
- $only_outlist{$_} = 1 if $out_type eq "OUTLIST";
+ $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
push @outlist, $name if $out_type =~ /OUTLIST$/;
$in_out{$name} = $out_type if $out_type;
}
@@ -1402,7 +1441,7 @@
if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
my $out_type = $1;
next if $out_type eq 'IN';
- $only_outlist{$_} = 1 if $out_type eq "OUTLIST";
+ $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
push @outlist, $name if $out_type =~ /OUTLIST$/;
$in_out{$_} = $out_type;
}
@@ -1427,7 +1466,7 @@
last;
}
}
- if ($only_outlist{$args[$i]}) {
+ if ($only_C_inlist{$args[$i]}) {
push @args_num, undef;
} else {
push @args_num, ++$num_args;
@@ -1466,6 +1505,7 @@
# print function header
print Q<<"EOF";
+#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
#XS(XS_${Full_func_name})
#[[
# dXSARGS;
@@ -1491,17 +1531,26 @@
# *errbuf = '\0';
EOF
- if ($ALIAS)
+ if ($ALIAS)
{ print Q<<"EOF" if $cond }
# if ($cond)
# Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv)));
EOF
- else
+ else
{ print Q<<"EOF" if $cond }
# if ($cond)
# Perl_croak(aTHX_ "Usage: $pname($report_args)");
EOF
+ #gcc -Wall: if an xsub has no arguments and PPCODE is used
+ #it is likely none of ST, XSRETURN or XSprePUSH macros are used
+ #hence `ax' (setup by dXSARGS) is unused
+ #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
+ #but such a move could break third-party extensions
+ print Q<<"EOF" if $PPCODE and $num_args == 0;
+# PERL_UNUSED_VAR(ax); /* -Wall */
+EOF
+
print Q<<"EOF" if $PPCODE;
# SP -= items;
EOF
@@ -1528,7 +1577,7 @@
$gotRETVAL = 0;
INPUT_handler() ;
- process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ;
+ process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
print Q<<"EOF" if $ScopeThisXSUB;
# ENTER;
@@ -1562,15 +1611,15 @@
if $WantOptimize and $targetable{$type_kind{$ret_type}};
}
- if (@arg_with_types) {
- unshift @line, @arg_with_types, $_;
+ if (@fake_INPUT or @fake_INPUT_pre) {
+ unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
$_ = "";
$processing_arg_with_types = 1;
INPUT_handler() ;
}
XS_process($deferred);
- process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
+ process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
if (check_keyword("PPCODE")) {
print_section();
@@ -1614,7 +1663,7 @@
# $wantRETVAL set if 'RETVAL =' autogenerated
($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
undef %outargs ;
- process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE");
+ process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
&generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
for grep $in_out{$_} =~ /OUT$/, keys %in_out;
@@ -1662,7 +1711,7 @@
generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
# do cleanup
- process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ;
+ process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
print Q<<"EOF" if $ScopeThisXSUB;
# ]]
@@ -1729,18 +1778,18 @@
else {
my $s = ';';
if ($min_args < $num_args) {
- $s = '';
+ $s = '';
$proto_arg[$min_args] .= ";" ;
}
- push @proto_arg, "$s\@"
+ push @proto_arg, "$s\@"
if $elipsis ;
-
+
$proto = ', "' . join ("", @proto_arg) . '"';
}
}
if (%XsubAliases) {
- $XsubAliases{$pname} = 0
+ $XsubAliases{$pname} = 0
unless defined $XsubAliases{$pname} ;
while ( ($name, $value) = each %XsubAliases) {
push(@InitFileCode, Q<<"EOF");
@@ -1751,7 +1800,7 @@
# sv_setpv((SV*)cv$proto) ;
EOF
}
- }
+ }
elsif (@Attributes) {
push(@InitFileCode, Q<<"EOF");
# cv = newXS(\"$pname\", XS_$Full_func_name, file);
@@ -1785,16 +1834,23 @@
EOF
print Q<<"EOF";
+#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
#XS(boot_$Module_cname)
EOF
print Q<<"EOF";
#[[
# dXSARGS;
+EOF
+
+#-Wall: if there is no $Full_func_name there are no xsubs in this .xs
+#so `file' is unused
+print Q<<"EOF" if $Full_func_name;
# char* file = __FILE__;
-#
EOF
+print Q "#\n";
+
print Q<<"EOF" if $WantVersionChk ;
# XS_VERSION_BOOTCHECK ;
#
@@ -1806,6 +1862,18 @@
#
EOF
+print Q<<"EOF" if ($Overload);
+# {
+# /* create the package stash */
+# HV *hv = get_hv(\"$Package\::OVERLOAD\",TRUE);
+# SV *sv = *hv_fetch(hv,"register",8,1);
+# sv_inc(sv);
+# SvSETMAGIC(sv);
+# /* Make it findable via fetchmethod */
+# newXS(\"$Package\::()\", NULL, file);
+# }
+EOF
+
print @InitFileCode;
print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
@@ -1826,7 +1894,7 @@
#
EOF
-warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
+warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
unless $ProtoUsed ;
&Exit;
@@ -1869,14 +1937,14 @@
{
# work out the line number
my $line_no = $line_no[@line_no - @line -1] ;
-
+
print STDERR "@_ in $filename, line $line_no\n" ;
}
-sub blurt
-{
+sub blurt
+{
Warn @_ ;
- $errors ++
+ $errors ++
}
sub death
@@ -1893,23 +1961,31 @@
$arg ||= "ST(" . ($num - 1) . ")";
$type = TidyType($type) ;
- blurt("Error: '$type' not in typemap"), return
+ blurt("Error: '$type' not in typemap"), return
unless defined($type_kind{$type});
($ntype = $type) =~ s/\s*\*/Ptr/g;
($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
$tk = $type_kind{$type};
$tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
- $type =~ tr/:/_/;
+ if ($tk eq 'T_PV' and exists $lengthof{$var}) {
+ print "\t$var" unless $name_printed;
+ print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
+ die "default value not supported with length(NAME) supplied"
+ if defined $defaults{$var};
+ return;
+ }
+ $type =~ tr/:/_/ unless $hiertype;
blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
unless defined $input_expr{$tk} ;
$expr = $input_expr{$tk};
if ($expr =~ /DO_ARRAY_ELEM/) {
- blurt("Error: '$subtype' not in typemap"), return
+ blurt("Error: '$subtype' not in typemap"), return
unless defined($type_kind{$subtype});
blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
unless defined $input_expr{$type_kind{$subtype}} ;
$subexpr = $input_expr{$type_kind{$subtype}};
+ $subexpr =~ s/\$type/\$subtype/g;
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
$subexpr =~ s/\n\t/\n\t\t/g;
@@ -1935,7 +2011,7 @@
$deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
}
warn $@ if $@;
- } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
+ } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
if ($name_printed) {
print ";\n";
} else {
@@ -1961,6 +2037,7 @@
$arg ||= "ST(" . ($num - ($num != 0)) . ")";
$type = TidyType($type) ;
if ($type =~ /^array\(([^,]*),(.*)\)/) {
+ print "\t$arg = sv_newmortal();\n";
print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
} else {
@@ -2033,7 +2110,8 @@
sub map_type {
my($type, $varname) = @_;
- $type =~ tr/:/_/;
+ # C++ has :: in types too so skip this
+ $type =~ tr/:/_/ unless $hiertype;
$type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
if ($varname) {
if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
End of Patch.