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;
$WantLineNumbers = 1 ;
$WantOptimize = 1 ;
$Overload = 0;
+$Fallback = 'PL_sv_undef';
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($_) ;
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
+ SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
)) . "|$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 = $_ ;
# 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} ;
}
+sub FALLBACK_handler()
+{
+ # the rest of the current line should contain either TRUE,
+ # FALSE or UNDEF
+
+ TrimWhitespace($_) ;
+ my %map = (
+ TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
+ FALSE => "PL_sv_no", 0 => "PL_sv_no",
+ UNDEF => "PL_sv_undef",
+ ) ;
+
+ # check for valid FALLBACK value
+ death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
+
+ $Fallback = $map{uc $_} ;
+}
+
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;
my $podstartline = $.;
do {
if (/^=cut\s*$/) {
- print("/* Skipped embedded POD. */\n");
+ # We can't just write out a /* */ comment, as our embedded
+ # POD might itself be in a comment. We can't put a /**/
+ # comment inside #if 0, as the C standard says that the source
+ # file is decomposed into preprocessing characters in the stage
+ # before preprocessing commands are executed.
+ # I don't want to leave the text as barewords, because the spec
+ # isn't clear whether macros are expanded before or after
+ # preprocessing commands are executed, and someone pathological
+ # may just have defined one of the 3 words as a macro that does
+ # something strange. Multiline strings are illegal in C, so
+ # the "" we write must be a string literal. And they aren't
+ # concatenated until 2 steps later, so we are safe.
+ print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
printf("#line %d \"$filename\"\n", $. + 1)
if $WantLineNumbers;
next firstmodule
}
for(;;) {
- # Skip embedded PODs
+ # Skip embedded PODs
while ($lastline =~ /^=/) {
while ($lastline = <$FH>) {
last if ($lastline =~ /^=cut\s*$/);
$xsreturn = 0;
$_ = shift(@line);
- while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
+ while ($kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
&{"${kwd}_handler"}() ;
next PARAGRAPH unless @line ;
$_ = shift(@line);
# *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)");
$xsreturn = 1 if $ret_type ne "void";
my $num = $xsreturn;
my $c = @outlist;
- print "\tXSprePUSH;" if $c and not $prepush_done;
+ # (PP)CODE set different values of SP; reset to PPCODE's with 0 output
+ print "\tXSprePUSH;" if $c and not $prepush_done;
+ # Take into account stuff already put on stack
+ print "\t++SP;" if $c and not $prepush_done and $xsreturn;
+ # Now SP corresponds to ST($xsreturn), so one can combine PUSH and ST()
print "\tEXTEND(SP,$c);\n" if $c;
$xsreturn += $c;
generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
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);
}
}
+if ($Overload) # make it findable with fetchmethod
+{
+
+ print Q<<"EOF";
+#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
+#XS(XS_${Packid}_nil)
+#{
+# XSRETURN_EMPTY;
+#}
+#
+EOF
+ unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
+ /* Making a sub named "${Package}::()" allows the package */
+ /* to be findable via fetchmethod(), and causes */
+ /* overload::Overloaded("${Package}") to return true. */
+ newXS("${Package}::()", XS_${Packid}_nil, file$proto);
+MAKE_FETCHMETHOD_WORK
+}
+
# print initialization routine
print Q<<"EOF";
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);
-# }
+# /* register the overloading (type 'A') magic */
+# PL_amagic_generation++;
+# /* The magic for overload gets a GV* via gv_fetchmeth as */
+# /* mentioned above, and looks in the SV* slot of it for */
+# /* the "fallback" status. */
+# sv_setsv(
+# get_sv( "${Package}::()", TRUE ),
+# $Fallback
+# );
EOF
print @InitFileCode;
#
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 / blobdiff