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.
=cut
-require 5.0;
+require 5.002;
use Cwd;
-use vars '$cplusplus';
+use vars qw($cplusplus $hiertype);
use vars '%v';
use Config;
$ProtoUsed = 0 ;
$WantLineNumbers = 1 ;
$WantOptimize = 1 ;
+$Overload = 0;
my $process_inout = 1;
my $process_argtypes = 1;
$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';
# change multiple whitespace into a single space
s/\s+/ /g ;
-
+
# trim leading & trailing whitespace
TrimWhitespace($_) ;
../../lib/ExtUtils/typemap ../../../typemap ../../typemap
../typemap typemap);
foreach $typemap (@tm) {
- next unless -e $typemap ;
+ next unless -f $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; }
$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) ;
}
}
foreach $key (keys %input_expr) {
- $input_expr{$key} =~ s/\n+$//;
+ $input_expr{$key} =~ s/;*\s+\z//;
}
$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
# 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.
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)) {
sub merge_section {
my $in = '';
-
+
while (!/\S/ && @line) {
$_ = shift(@line);
}
-
+
for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
$in .= "$_\n";
}
my($pattern) = @_ ;
my $kwd ;
- &{"${kwd}_handler"}()
+ &{"${kwd}_handler"}()
while $kwd = check_keyword($pattern) ;
}
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 = $_ ;
# 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 ;
# 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";
}
$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*$/
} 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;
sub INTERFACE_handler() {
my $in = merge_section();
-
+
TrimWhitespace($in);
-
+
foreach (split /[\s,]+/, $in) {
$Interfaces{$_} = $_;
}
$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
{
# 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} ;
}
}
+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
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)) {
$specified = 1 ;
TrimWhitespace($_) ;
if ($_ eq 'DISABLE') {
- $ProtoThisXSUB = 0
+ $ProtoThisXSUB = 0
}
elsif ($_ eq 'ENABLE') {
- $ProtoThisXSUB = 1
+ $ProtoThisXSUB = 1
}
else {
# remove any whitespace
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
}
}
sub PROTOTYPES_handler ()
{
# the rest of the current line should contain either ENABLE or
- # DISABLE
+ # DISABLE
TrimWhitespace($_) ;
sub INCLUDE_handler ()
{
# the rest of the current line should contain a valid filename
-
+
TrimWhitespace($_) ;
-
+
death("INCLUDE: filename missing")
unless $_ ;
Filename => $filename,
Handle => $FH,
}) ;
-
+
++ $FH ;
# open the new file
open ($FH, "$_") or death("Cannot open '$_': $!") ;
-
+
print Q<<"EOF" ;
#
#/* INCLUDE: Including '$_' from '$filename' */
$filename = $_ ;
- # Prime the pump by reading the first
+ # Prime the pump by reading the first
# non-blank line
# skip leading blank lines
$lastline = $_ ;
$lastline_no = $. ;
-
+
}
-
+
sub PopFile()
{
return 0 unless $XSStack[-1]{type} eq 'file' ;
my $data = pop @XSStack ;
my $ThisFile = $filename ;
my $isPipe = ($filename =~ /\|\s*$/) ;
-
+
-- $IncludedFiles{$filename}
unless $isPipe ;
# 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;
}
for(;;) {
- # Skip embedded PODs
+ # Skip embedded PODs
while ($lastline =~ /^=/) {
while ($lastline = <$FH>) {
last if ($lastline =~ /^=cut\s*$/);
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);
$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) {
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;
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;
}
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;
}
last;
}
}
- if ($only_outlist{$args[$i]}) {
+ if ($only_C_inlist{$args[$i]}) {
push @args_num, undef;
} else {
push @args_num, ++$num_args;
# *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)");
$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;
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() ;
}
print $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();
# $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;
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;
# ]]
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");
# sv_setpv((SV*)cv$proto) ;
EOF
}
- }
+ }
elsif (@Attributes) {
push(@InitFileCode, Q<<"EOF");
# cv = newXS(\"$pname\", XS_$Full_func_name, file);
#
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 ;
#
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;
{
# 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
local($tk);
$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}} ;
$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 {
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) {
projects / p5sagit/p5-mst-13.2.git / blobdiff