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.
require 5.002;
use Cwd;
-use vars '$cplusplus';
+use vars qw($cplusplus $hiertype);
use vars '%v';
use Config;
$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($_) ;
foreach $typemap (@tm) {
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) ;
}
# 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 OVERLOAD
)) . "|$END)\\s*:";
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 = $_ ;
# Check for duplicate definitions
blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
- if $arg_list{$var_name}++
+ if $arg_list{$var_name}++
or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
$thisdone |= $var_name eq "THIS";
}
$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} ;
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*$/);
# *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)");
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
-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;
if defined $defaults{$var};
return;
}
- $type =~ tr/:/_/;
+ $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}} ;
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 / commitdiff