Mailing List Archive

# This is my patch a to perl5.002beta1.

exit 0 # Just in case

This is patch.2b1a to perl5.002beta1. This is simply
xsubpp-1.944. It includes perl prototype support.

This is simply Paul's posting re-wrapped as patch.
Nothing else is included.

cd to your perl source directory and type
patch -p1 -N < patch.2b1a

Patch and enjoy,

Andy Dougherty doughera@lafcol.lafayette.edu
Dept. of Physics
Lafayette College, Easton PA 18042


Index: XSUB.h
*** perl5.002beta1/XSUB.h Fri Nov 10 13:11:02 1995
--- perl5.002b1a/XSUB.h Sat Dec 2 15:43:54 1995
***************
*** 33,35 ****
--- 33,37 ----
#define XSRETURN_YES do { XST_mYES(0); XSRETURN(1); } while (0)
#define XSRETURN_UNDEF do { XST_mUNDEF(0); XSRETURN(1); } while (0)
#define XSRETURN_EMPTY do { XSRETURN(0); } while (0)
+
+ #define newXSproto(a,b,c,d) sv_setpv(newXS(a,b,c), d)
Index: lib/ExtUtils/xsubpp
*** perl5.002beta1/lib/ExtUtils/xsubpp Mon Nov 20 11:03:49 1995
--- perl5.002b1a/lib/ExtUtils/xsubpp Sat Dec 2 15:43:55 1995
***************
*** 6,12 ****

=head1 SYNOPSIS

! B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-typemap typemap>]... file.xs

=head1 DESCRIPTION

--- 6,12 ----

=head1 SYNOPSIS

! B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-noprototypes>] [B<-typemap typemap>]... file.xs

=head1 DESCRIPTION

***************
*** 44,49 ****
--- 44,52 ----

Prints the I<xsubpp> version number to standard output, then exits.

+ =item B<-noprototypes>
+
+
=back

=head1 ENVIRONMENT
***************
*** 65,81 ****
=cut

# Global Constants
! $XSUBPP_version = "1.923";
! require 5.001;

! $usage = "Usage: xsubpp [-v] [-C++] [-except] [-s pattern] [-typemap typemap]... file.xs\n";

$except = "";
SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
$flag = shift @ARGV;
$flag =~ s/^-// ;
$spat = shift, next SWITCH if $flag eq 's';
$cplusplus = 1, next SWITCH if $flag eq 'C++';
$except = " TRY", next SWITCH if $flag eq 'except';
push(@tm,shift), next SWITCH if $flag eq 'typemap';
(print "xsubpp version $XSUBPP_version\n"), exit
--- 68,89 ----
=cut

# Global Constants
! $XSUBPP_version = "1.924";
! require 5.002;
!
! $usage = "Usage: xsubpp [-v] [-C++] [-except] [-noprototypes] [-s pattern] [-typemap typemap]... file.xs\n";

! $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;

$except = "";
+ $WantPrototypes = 1 ;
SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
$flag = shift @ARGV;
$flag =~ s/^-// ;
$spat = shift, next SWITCH if $flag eq 's';
$cplusplus = 1, next SWITCH if $flag eq 'C++';
+ $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes';
+ $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
$except = " TRY", next SWITCH if $flag eq 'except';
push(@tm,shift), next SWITCH if $flag eq 'typemap';
(print "xsubpp version $XSUBPP_version\n"), exit
***************
*** 141,149 ****
TrimWhitespace($_) ;
# skip blank lines and comment lines
next if /^$/ or /^#/ ;
! my($type,$kind) = /^\s*(.*?\S)\s+(\S+)\s*$/ or
! warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 columns\n"), next;
! $type_kind{TidyType($type)} = $kind ;
}
elsif (/^\s/) {
$$current .= $_;
--- 149,163 ----
TrimWhitespace($_) ;
# skip blank lines and comment lines
next if /^$/ or /^#/ ;
! my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
! warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
! $type = TidyType($type) ;
! $type_kind{$type} = $kind ;
! # prototype defaults to '$'
! $proto = '$' unless $proto ;
! warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
! unless ValidProtoString($proto) ;
! $proto_letter{$type} = C_string($proto) ;
}
elsif (/^\s/) {
$$current .= $_;
***************
*** 169,175 ****
$END = "!End!\n\n"; # "impossible" keyword (multiple newline)

# Match an XS keyword
! $BLOCK_re= "\\s*(REQUIRE|BOOT|CASE|PREINIT|INPUT|INIT|CODE|PPCODE|OUTPUT|CLEANUP|ALIAS|$END)\\s*:";

# Input: ($_, @line) == unparsed input.
# Output: ($_, @line) == (rest of line, following lines).
--- 183,192 ----
$END = "!End!\n\n"; # "impossible" keyword (multiple newline)

# Match an XS keyword
! $BLOCK_re= '\s*(' . join('|', qw(
! REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
! CLEANUP ALIAS PROTOTYPES PROTOTYPE
! )) . "|$END)\\s*:";

# Input: ($_, @line) == unparsed input.
# Output: ($_, @line) == (rest of line, following lines).
***************
*** 225,230 ****
--- 242,249 ----
$var_types{$var_name} = $var_type;
print "\t" . &map_type($var_type);
$var_num = $args_match{$var_name};
+
+ $proto_arg[$var_num] = ProtoString($var_type) ;
if ($var_addr) {
$var_addr{$var_name} = 1;
$func_args =~ s/\b($var_name)\b/&$1/;
***************
*** 301,307 ****
if $line ;
}

! sub ALIAS_handler
{
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
next unless /\S/;
--- 320,326 ----
if $line ;
}

! sub ALIAS_handler ()
{
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
next unless /\S/;
***************
*** 310,316 ****
}
}

! sub REQUIRE_handler
{
# the rest of the current line should contain a version number
my ($Ver) = $_ ;
--- 329,335 ----
}
}

! sub REQUIRE_handler ()
{
# the rest of the current line should contain a version number
my ($Ver) = $_ ;
***************
*** 328,333 ****
--- 347,415 ----
unless $XSUBPP_version >= $Ver ;
}

+ sub PROTOTYPE_handler ()
+ {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ if ($_ eq 'DISABLE') {
+ $ProtoThisXSUB = 0
+ }
+ elsif ($_ eq 'ENABLE') {
+ $ProtoThisXSUB = 1
+ }
+ else {
+ # remove any whitespace
+ s/\s+//g ;
+ death("Error: Invalid prototype '$_'")
+ unless ValidProtoString($_) ;
+ $ProtoThisXSUB = C_string($_) ;
+ }
+ }
+ }
+
+ sub PROTOTYPES_handler ()
+ {
+ # the rest of the current line should contain either ENABLE or
+ # DISABLE
+
+ TrimWhitespace($_) ;
+
+ # check for ENABLE/DISABLE
+ death ("Error: PROTOTYPES: ENABLE/DISABLE")
+ unless /^(ENABLE|DISABLE)/i ;
+
+ $WantPrototypes = 1 if $1 eq 'ENABLE' ;
+ $WantPrototypes = 0 if $1 eq 'DISABLE' ;
+
+ }
+
+ sub ValidProtoString ($)
+ {
+ my($string) = @_ ;
+
+ if ( $string =~ /^$proto_re+$/ ) {
+ return $string ;
+ }
+
+ return 0 ;
+ }
+
+ sub C_string ($)
+ {
+ my($string) = @_ ;
+
+ $string =~ s[\\][\\\\]g ;
+ $string ;
+ }
+
+ sub ProtoString ($)
+ {
+ my ($type) = @_ ;
+
+ $proto_letter{$type} or '$' ;
+ }
+
sub check_cpp {
my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
if (@cpp) {
***************
*** 443,452 ****
undef($elipsis);
undef($wantRETVAL) ;
undef(%arg_list) ;

$_ = shift(@line);
! if (check_keyword("REQUIRE")) {
! REQUIRE_handler() ;
next PARAGRAPH unless @line ;
$_ = shift(@line);
}
--- 525,539 ----
undef($elipsis);
undef($wantRETVAL) ;
undef(%arg_list) ;
+ undef(@proto_arg) ;
+ $ProtoThisXSUB = $WantPrototypes ;

$_ = shift(@line);
! while ($kwd = check_keyword("REQUIRE|PROTOTYPES")) {
! if ($kwd eq 'REQUIRE')
! { REQUIRE_handler() }
! else
! { PROTOTYPES_handler() }
next PARAGRAPH unless @line ;
$_ = shift(@line);
}
***************
*** 507,512 ****
--- 594,600 ----
$defaults{$args[$i]} = $2;
$defaults{$args[$i]} =~ s/"/\\"/g;
}
+ $proto_arg[$i+1] = '$' ;
}
if (defined($class)) {
$func_args = join(", ", @args[1..$#args]);
***************
*** 608,620 ****
$var_types{"RETVAL"} = $ret_type;
}
print $deferred;
! while ($kwd = check_keyword("INIT|ALIAS")) {
if ($kwd eq 'INIT') {
&print_section
}
! else {
! ALIAS_handler
! }
}

if (check_keyword("PPCODE")) {
--- 696,709 ----
$var_types{"RETVAL"} = $ret_type;
}
print $deferred;
! while ($kwd = check_keyword("INIT|ALIAS|PROTOTYPE")) {
if ($kwd eq 'INIT') {
&print_section
}
! elsif ($kwd eq 'PROTOTYPE')
! { PROTOTYPE_handler() }
! else
! { ALIAS_handler() }
}

if (check_keyword("PPCODE")) {
***************
*** 634,640 ****
}
if (defined($static)) {
if ($func_name =~ /^new/) {
! $func_name = "$class";
} else {
print "${class}::";
}
--- 723,729 ----
}
if (defined($static)) {
if ($func_name =~ /^new/) {
! $func_name .= " $class";
} else {
print "${class}::";
}
***************
*** 696,701 ****
--- 785,809 ----
#]]
#
EOF
+
+ # Build the prototype string for the xsub
+ if ($ProtoThisXSUB) {
+ if ($ProtoThisXSUB != 1) {
+ $ProtoXSUB{$pname} = '"' . $ProtoThisXSUB . '"'
+ }
+ else {
+ my $s = ';';
+ if ($min_args < $num_args) {
+ $s = '';
+ $proto_arg[$min_args] .= ";" ;
+ }
+ push @proto_arg, "${s}@"
+ if $elipsis ;
+
+ $ProtoXSUB{$pname} = '"' . join ("", @proto_arg) . '"'
+ }
+ }
+
}

# print initialization routine
***************
*** 718,723 ****
--- 826,838 ----

for (@Func_name) {
$pname = shift(@Func_pname);
+ my $newXS = "newXS" ;
+ my $proto = "" ;
+
+ if ($ProtoXSUB{$pname}) {
+ $newXS = "newXSproto" ;
+ $proto = ", $ProtoXSUB{$pname}" ;
+ }

if ($XsubAliases{$pname}) {
$XsubAliases{$pname}{$pname} = 0
***************
*** 727,736 ****
# cv = newXS(\"$name\", XS_$_, file);
# XSANY.any_i32 = $value ;
EOF
}
}
else {
! print " newXS(\"$pname\", XS_$_, file);\n";
}
}

--- 842,854 ----
# cv = newXS(\"$name\", XS_$_, file);
# XSANY.any_i32 = $value ;
EOF
+ print Q<<"EOF" if $proto ;
+ # sv_setpv(cv, $ProtoXSUB{$pname}) ;
+ EOF
}
}
else {
! print " ${newXS}(\"$pname\", XS_$_, file$proto);\n";
}
}



End of patch.