integrate cfgperl contents into mainline; resolve h2xs.PL conflict

by declaring new globals "our" (XXX this means h2xs generated code
won't run on earlier versions; a switch to generate compatible
source is needed)

p4raw-id: //depot/perl@4271

1 files changed, 580 insertions, 116 deletions

diff --git a/utils/h2xs.PL b/utils/h2xs.PL
index ae266de3cb..b3031c3465 100644
--- a/utils/h2xs.PL
+++ b/utils/h2xs.PL
@@ -81,7 +81,11 @@ the POD template.
 =item B<-F>
 
 Additional flags to specify to C preprocessor when scanning header for
-function declarations. Should not be used without B<-x>.
+function declarations.  Should not be used without B<-x>.
+
+=item B<-M> I<regular expression>
+
+selects functions/macros to process.
 
 =item B<-O>
 
@@ -108,7 +112,7 @@ Turn on debugging messages.
 =item B<-f>
 
 Allows an extension to be created for a header even if that header is
-not found in /usr/include.
+not found in standard include directories.
 
 =item B<-h>
 
@@ -118,6 +122,21 @@ Print the usage, help and version for this h2xs and exit.
 
 Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
 
+=item B<-o> I<regular expression>
+
+Use "opaque" data type for the C types matched by the regular
+expression, even if these types are C<typedef>-equivalent to types
+from typemaps.  Should not be used without B<-x>.
+
+This may be useful since, say, types which are C<typedef>-equivalent
+to integers may represent OS-related handles, and one may want to work
+with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
+Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types.
+
+The type-to-match is whitewashed (except for commas, which have no
+whitespace before them, and multiple C<*> which have no whitespace
+between them).
+
 =item B<-p> I<prefix>
 
 Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> 
@@ -145,7 +164,8 @@ but XSUBs are emitted only for the declarations included from file NAME2.
 Note that some types of arguments/return-values for functions may
 result in XSUB-declarations/typemap-entries which need
 hand-editing. Such may be objects which cannot be converted from/to a
-pointer (like C<long long>), pointers to functions, or arrays.
+pointer (like C<long long>), pointers to functions, or arrays.  See
+also the section on L<LIMITATIONS of B<-x>>.
 
 =back
 
@@ -198,6 +218,12 @@ pointer (like C<long long>), pointers to functions, or arrays.
 	# Same with function declaration in proto.h as visible from perl.h.
 	h2xs -xAn perl2 perl.h,proto.h
 
+	# Same but select only functions which match /^av_/
+	h2xs -M '^av_' -xAn perl2 perl.h,proto.h
+
+	# Same but treat SV* etc as "opaque" types
+	h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
+
 =head1 ENVIRONMENT
 
 No environment variables are used.
@@ -214,10 +240,74 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
 
 The usual warnings if it cannot read or write the files involved.
 
+=head1 LIMITATIONS of B<-x>
+
+F<h2xs> would not distinguish whether an argument to a C function
+which is of the form, say, C<int *>, is an input, output, or
+input/output parameter.  In particular, argument declarations of the
+form
+
+    int
+    foo(n)
+	int *n
+
+should be better rewritten as
+
+    int
+    foo(n)
+	int &n
+
+if C<n> is an input parameter.
+
+Additionally, F<h2xs> has no facilities to intuit that a function
+
+   int
+   foo(addr,l)
+	char *addr
+	int   l
+
+takes a pair of address and length of data at this address, so it is better
+to rewrite this function as
+
+    int
+    foo(sv)
+	SV *addr
+    PREINIT:
+	STRLEN len;
+	char *s;
+    CODE:
+	s = SvPV(sv,len);
+	RETVAL = foo(s, len);
+    OUTPUT:
+	RETVAL
+
+or alternately
+
+    static int
+    my_foo(SV *sv)
+    {
+	STRLEN len;
+	char *s = SvPV(sv,len);
+
+	return foo(s, len);
+    }
+
+    MODULE = foo	PACKAGE = foo	PREFIX = my_
+
+    int
+    foo(sv)
+	SV *sv
+
+See L<perlxs> and L<perlxstut> for additional details.
+
 =cut
 
-my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/;
+use strict;
+
+
+my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
 my $TEMPLATE_VERSION = '0.01';
+my @ARGS = @ARGV;
 
 use Getopt::Std;
 
@@ -228,6 +318,7 @@ version: $H2XS_VERSION
     -A   Omit all autoloading facilities (implies -c).
     -C   Omit creating the Changes file, add HISTORY heading to stub POD.
     -F   Additional flags for C preprocessor (used with -x).
+    -M   Mask to select C functions/macros (default is select all).
     -O   Allow overwriting of a pre-existing extension directory.
     -P   Omit the stub POD section.
     -X   Omit the XS portion (implies both -c and -f).
@@ -236,6 +327,7 @@ version: $H2XS_VERSION
     -f   Force creation of the extension even if the C header does not exist.
     -h   Display this help message
     -n   Specify a name to use for the extension (recommended).
+    -o   Regular expression for \"opaque\" types.
     -p   Specify a prefix which should be removed from the Perl function names.
     -s   Create subroutines for specified macros.
     -v   Specify a version number for this extension.
@@ -247,7 +339,9 @@ extra_libraries
 }
 
 
-getopts("ACF:OPXcdfhn:p:s:v:x") || usage;
+getopts("ACF:M:OPXcdfhn:o:p:s:v:x") || usage;
+use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_c
+	    $opt_d $opt_f $opt_h $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
 
 usage if $opt_h;
 
@@ -261,7 +355,9 @@ $opt_c = 1 if $opt_A;
 # -X implies -c and -f
 $opt_c = $opt_f = 1 if $opt_X;
 
-%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+my $extralibs;
+my @path_h;
 
 while (my $arg = shift) {
     if ($arg =~ /^-l/i) {
@@ -274,34 +370,68 @@ while (my $arg = shift) {
 usage "Must supply header file or module name\n"
         unless (@path_h or $opt_n);
 
+my $fmask;
+my $tmask;
+
+$fmask = qr{$opt_M} if defined $opt_M;
+$tmask = qr{$opt_o} if defined $opt_o;
+my $tmask_all = $tmask && $opt_o eq '.';
+
+if ($opt_x) {
+  eval {require C::Scan; 1}
+    or die <<EOD;
+C::Scan required if you use -x option.
+To install C::Scan, execute
+   perl -MCPAN -e "install C::Scan"
+EOD
+  unless ($tmask_all) {
+    $C::Scan::VERSION >= 0.70
+      or die <<EOD;
+C::Scan v. 0.70 or later required unless you use -o . option.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+   perl -MCPAN -e "install C::Scan"
+EOD
+  }
+} elsif ($opt_o or $opt_F) {
+  warn <<EOD;
+Options -o and -F do not make sense without -x.
+EOD
+}
+
+my @path_h_ini = @path_h;
+my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
 
 if( @path_h ){
+    use Config;
+    use File::Spec;
+    my @paths;
+    if ($^O eq 'VMS') {  # Consider overrides of default location
+      # XXXX This is not equivalent to what the older version did:
+      #		it was looking at $hadsys header-file per header-file...
+      my($hadsys) = grep s!^sys/!!i , @path_h;
+      @paths = qw( Sys\$Library VAXC$Include );
+      push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
+      push @paths, qw( DECC$Library_Include DECC$System_Include );
+    } else {
+      @paths = (File::Spec->curdir(), $Config{usrinc},
+		(split ' ', $Config{locincpth}), '/usr/include');
+    }
     foreach my $path_h (@path_h) {
         $name ||= $path_h;
     if( $path_h =~ s#::#/#g && $opt_n ){
 	warn "Nesting of headerfile ignored with -n\n";
     }
     $path_h .= ".h" unless $path_h =~ /\.h$/;
-    $fullpath = $path_h;
+    my $fullpath = $path_h;
     $path_h =~ s/,.*$// if $opt_x;
-    if ($^O eq 'VMS') {  # Consider overrides of default location
-	if ($path_h !~ m![:>\[]!) {
-	    my($hadsys) = ($path_h =~ s!^sys/!!i);
-	    if ($ENV{'DECC$System_Include'})     { $path_h = "DECC\$System_Include:$path_h";    }
-	    elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h";   }
-	    elsif ($ENV{'GNU_CC_Include'})       { $path_h = 'GNU_CC_Include:' .
-	                                            ($hadsys ? '[vms]' : '[000000]') . $path_h; }
-	    elsif ($ENV{'VAXC$Include'})         { $path_h = "VAXC\$_Include:$path_h";          }
-	    else                                 { $path_h = "Sys\$Library:$path_h";            }
-	}
-    }
-    elsif ($^O eq 'os2') {
-	$path_h = "/usr/include/$path_h" 
-	  if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h"; 
-    }
-    else { 
-      $path_h = "/usr/include/$path_h" 
-	if $path_h !~ m#^[./]# and -r "/usr/include/$path_h"; 
+    $fullpath{$path_h} = $fullpath;
+
+    if (not -f $path_h) {
+      my $tmp_path_h = $path_h;
+      for my $dir (@paths) {
+	last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
+      }
     }
 
     if (!$opt_c) {
@@ -310,10 +440,24 @@ if( @path_h ){
       # Record the names of simple #define constants into const_names
             # Function prototypes are processed below.
       open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
+    defines:
       while (<CH>) {
-	if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) {
-	    print "Matched $_ ($1)\n" if $opt_d;
-	    $_ = $1;
+	if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
+	    my $def = $1;
+	    my $rest = $2;
+	    $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
+	    $rest =~ s/^\s+//;
+	    $rest =~ s/\s+$//;
+	    # Cannot do: (-1) and ((LHANDLE)3) are OK:
+	    #print("Skip non-wordy $def => $rest\n"),
+	    #  next defines if $rest =~ /[^\w\$]/;
+	    if ($rest =~ /"/) {
+	      print("Skip stringy $def => $rest\n") if $opt_d;
+	      next defines;
+	    }
+	    print "Matched $_ ($def)\n" if $opt_d;
+	    $seen_define{$def} = $rest;
+	    $_ = $def;
 	    next if /^_.*_h_*$/i; # special case, but for what?
 	    if (defined $opt_p) {
 	      if (!/^$opt_p(\d)/) {
@@ -323,17 +467,20 @@ if( @path_h ){
 		warn "can't remove $opt_p prefix from '$_'!\n";
 	      }
 	    }
-	    $const_names{$_}++;
+	    $prefixless{$def} = $_;
+	    if (!$fmask or /$fmask/) {
+		print "... Passes mask of -M.\n" if $opt_d and $fmask;
+		$const_names{$_}++;
+	    }
 	  }
       }
       close(CH);
     }
     }
-    @const_names = sort keys %const_names;
 }
 
 
-$module = $opt_n || do {
+my $module = $opt_n || do {
 	$name =~ s/\.h$//;
 	if( $name !~ /::/ ){
 		$name =~ s#^.*/##;
@@ -342,6 +489,7 @@ $module = $opt_n || do {
 	$name;
 };
 
+my ($ext, $nested, @modparts, $modfname, $modpname);
 (chdir 'ext', $ext = 'ext/') if -d 'ext';
 
 if( $module =~ /::/ ){
@@ -363,7 +511,7 @@ if ($opt_O) {
 	die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
 }
 if( $nested ){
-	$modpath = "";
+	my $modpath = "";
 	foreach (@modparts){
 		mkdir("$modpath$_", 0777);
 		$modpath .= "$_/";
@@ -376,19 +524,28 @@ my %types_seen;
 my %std_types;
 my $fdecls = [];
 my $fdecls_parsed = [];
+my $typedef_rex;
+my %typedefs_pre;
+my %known_fnames;
+
+my @fnames;
+my @fnames_no_prefix;
 
 if( ! $opt_X ){  # use XS, unless it was disabled
   open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
   if ($opt_x) {
-    require C::Scan;		# Run-time directive
     require Config;		# Run-time directive
     warn "Scanning typemaps...\n";
     get_typemap();
-    my $c;
-    my $filter;
+    my @td;
+    my @good_td;
+    my $addflags = $opt_F || '';
+
     foreach my $filename (@path_h) {
-      my $addflags = $opt_F || '';
-      if ($fullpath =~ /,/) {
+      my $c;
+      my $filter;
+
+      if ($fullpath{$filename} =~ /,/) {
 	$filename = $`;
 	$filter = $';
       }
@@ -396,12 +553,71 @@ if( ! $opt_X ){  # use XS, unless it was disabled
       $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
 	'add_cppflags' => $addflags;
       $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
-      
+
       push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
       push(@$fdecls, @{$c->get('fdecls')});
+
+      push @td, @{$c->get('typedefs_maybe')};
+
+      unless ($tmask_all) {
+	warn "Scanning $filename for typedefs...\n";
+	my $td = $c->get('typedef_hash');
+	# eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
+	my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
+	push @good_td, @f_good_td;
+	@typedefs_pre{@f_good_td}  = map $_->[0], @$td{@f_good_td};
+      }
+    }
+    { local $" = '|';
+      $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b);
+    }
+    %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
+    if ($fmask) {
+      my @good;
+      for my $i (0..$#$fdecls_parsed) {
+	next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
+	push @good, $i;
+	print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
+	  if $opt_d;
+      }
+      $fdecls = [@$fdecls[@good]];
+      $fdecls_parsed = [@$fdecls_parsed[@good]];
+    }
+    @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
+    # Sort declarations:
+    {
+      my %h = map( ($_->[1], $_), @$fdecls_parsed);
+      $fdecls_parsed = [ @h{@fnames} ];
+    }
+    @fnames_no_prefix = @fnames;
+    @fnames_no_prefix
+      = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
+    # Remove macros which expand to typedefs
+    print "Typedefs are @td.\n" if $opt_d;
+    my %td = map {($_, $_)} @td;
+    # Add some other possible but meaningless values for macros
+    for my $k (qw(char double float int long short unsigned signed void)) {
+      $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
+    }
+    # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
+    my $n = 0;
+    my %bad_macs;
+    while (keys %td > $n) {
+      $n = keys %td;
+      my ($k, $v);
+      while (($k, $v) = each %seen_define) {
+	# print("found '$k'=>'$v'\n"), 
+	$bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
+      }
+    }
+    # Now %bad_macs contains names of bad macros
+    for my $k (keys %bad_macs) {
+      delete $const_names{$prefixless{$k}};
+      print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
     }
   }
 }
+my @const_names = sort keys %const_names;
 
 open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
 
@@ -411,6 +627,7 @@ warn "Writing $ext$modpname/$modfname.pm\n";
 print PM <<"END";
 package $module;
 
+require 5.005_62;
 use strict;
 END
 
@@ -455,10 +672,22 @@ $myISA .= ' DynaLoader' 	unless $opt_X;  # no XS
 $myISA .= ');';
 print PM "\n$myISA\n\n";
 
+my @exported_names = (@const_names, @fnames_no_prefix);
+
 print PM<<"END";
 # Items to export into callers namespace by default. Note: do not export
 # names by default without a very good reason. Use EXPORT_OK instead.
 # Do not simply export all your public functions/methods/constants.
+
+# This allows declaration	use $module ':all';
+# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+	@exported_names
+) ] );
+
+our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
+
 our \@EXPORT = qw(
 	@const_names
 );
@@ -486,8 +715,15 @@ sub AUTOLOAD {
 		croak "Your vendor has not defined $module macro \$constname";
 	}
     }
-    no strict 'refs';
-    *\$AUTOLOAD = sub () { \$val };
+    {  no strict 'refs';
+       # Next line doesn't help with older Perls; in newers: no such warnings
+       # local \$^W = 0;		# Prototype mismatch: sub XXX vs ()
+       if (\$] >= 5.00561) {	# Fixed between 5.005_53 and 5.005_61
+	 *\$AUTOLOAD = sub () { \$val };
+       } else {
+	 *\$AUTOLOAD = sub { \$val };
+       }
+    }
     goto &\$AUTOLOAD;
 }
 
@@ -499,6 +735,7 @@ bootstrap $module \$VERSION;
 END
 }
 
+my $after;
 if( $opt_P ){ # if POD is disabled
 	$after = '__END__';
 }
@@ -522,8 +759,8 @@ print PM <<"END";
 __END__
 END
 
-$author = "A. U. Thor";
-$email = 'a.u.thor@a.galaxy.far.far.away';
+my $author = "A. U. Thor";
+my $email = 'a.u.thor@a.galaxy.far.far.away';
 
 my $revhist = '';
 $revhist = <<EOT if $opt_C;
@@ -534,32 +771,45 @@ $revhist = <<EOT if $opt_C;
 
 =item $TEMPLATE_VERSION
 
-Original version; created by h2xs $H2XS_VERSION
+Original version; created by h2xs $H2XS_VERSION with options
+
+  @ARGS
 
 =back
 
 EOT
 
-my $const_doc = '';
-my $fdecl_doc = '';
+my $exp_doc = <<EOD;
+
+=head2 EXPORT
+
+None by default.
+
+EOD
 if (@const_names and not $opt_P) {
-  $const_doc = <<EOD;
-\n=head2 Exported constants
+  $exp_doc .= <<EOD;
+=head2 Exportable constants
 
   @{[join "\n  ", @const_names]}
 
 EOD
 }
 if (defined $fdecls and @$fdecls and not $opt_P) {
-  $fdecl_doc = <<EOD;
-\n=head2 Exported functions
+  $exp_doc .= <<EOD;
+=head2 Exportable functions
 
-  @{[join "\n  ", @$fdecls]}
+EOD
+  $exp_doc .= <<EOD if $opt_p;
+When accessing these functions from Perl, prefix C<$opt_p> should be removed.
+
+EOD
+  $exp_doc .= <<EOD;
+  @{[join "\n  ", @known_fnames{@fnames}]}
 
 EOD
 }
 
-$pod = <<"END" unless $opt_P;
+my $pod = <<"END" unless $opt_P;
 ## Below is the stub of documentation for your module. You better edit it!
 #
 #=head1 NAME
@@ -578,7 +828,7 @@ $pod = <<"END" unless $opt_P;
 #unedited.
 #
 #Blah blah blah.
-#$const_doc$fdecl_doc$revhist
+#$exp_doc$revhist
 #=head1 AUTHOR
 #
 #$author, $email
@@ -606,7 +856,7 @@ print XS <<"END";
 
 END
 if( @path_h ){
-    foreach my $path_h (@path_h) {
+    foreach my $path_h (@path_h_ini) {
 	my($h) = $path_h;
 	$h =~ s#^/usr/include/##;
 	if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
@@ -615,54 +865,180 @@ if( @path_h ){
     print XS "\n";
 }
 
-if( ! $opt_c ){
-print XS <<"END";
-static int
-not_here(char *s)
+my %pointer_typedefs;
+my %struct_typedefs;
+
+sub td_is_pointer {
+  my $type = shift;
+  my $out = $pointer_typedefs{$type};
+  return $out if defined $out;
+  my $otype = $type;
+  $out = ($type =~ /\*$/);
+  # This converts only the guys which do not have trailing part in the typedef
+  if (not $out
+      and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+    $type = normalize_type($type);
+    print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
+      if $opt_d;
+    $out = td_is_pointer($type);
+  }
+  return ($pointer_typedefs{$otype} = $out);
+}
+
+sub td_is_struct {
+  my $type = shift;
+  my $out = $struct_typedefs{$type};
+  return $out if defined $out;
+  my $otype = $type;
+  $out = ($type =~ /^struct\b/) && !td_is_pointer($type);
+  # This converts only the guys which do not have trailing part in the typedef
+  if (not $out
+      and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+    $type = normalize_type($type);
+    print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
+      if $opt_d;
+    $out = td_is_struct($type);
+  }
+  return ($struct_typedefs{$otype} = $out);
+}
+
+# Some macros will bomb if you try to return them from a double-returning func.
+# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
+# Fortunately, we can detect both these cases...
+sub protect_convert_to_double {
+  my $in = shift;
+  my $val;
+  return '' unless defined ($val = $seen_define{$in});
+  return '(IV)' if $known_fnames{$val};
+  # OUT_t of ((OUT_t)-1):
+  return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
+  td_is_pointer($2) ? '(IV)' : '';
+}
+
+# For each of the generated functions, length($pref) leading
+# letters are already checked.  Moreover, it is recommended that
+# the generated functions uses switch on letter at offset at least
+# $off + length($pref).
+#
+# The given list has length($pref) chars removed at front, it is
+# guarantied that $off leading chars in the rest are the same for all
+# elts of the list.
+#
+# Returns: how at which offset it was decided to make a switch, or -1 if none.
+
+sub write_const;
+
+sub write_const {
+  my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
+  my %leading;
+  my $offarg = length $pref;
+
+  if (@$list == 0) {		# Can happen on the initial iteration only
+    print $fh <<"END";
+static double
+constant(char *name, int len, int arg)
 {
-    croak("$module::%s not implemented on this architecture", s);
+    errno = EINVAL;
+    return 0;
+}
+END
     return -1;
+  }
+
+  if (@$list == 1) {		# Can happen on the initial iteration only
+    my $protect = protect_convert_to_double("$pref$list->[0]");
+
+    print $fh <<"END";
+static double
+constant(char *name, int len, int arg)
+{
+    if (strEQ(name + $offarg, "$list->[0]")) {	/* $pref removed */
+#ifdef $pref$list->[0]
+	return $protect$pref$list->[0];
+#else
+	errno = ENOENT;
+	return 0;
+#endif
+    }
+    errno = EINVAL;
+    return 0;
 }
+END
+    return -1;
+  }
 
+  for my $n (@$list) {
+    my $c = substr $n, $off, 1;
+    $leading{$c} = [] unless exists $leading{$c};
+    push @{$leading{$c}}, substr $n, $off + 1;
+  }
+
+  if (keys(%leading) == 1) {
+    return 1 + write_const $fh, $pref, $off + 1, $list;
+  }
+
+  my $leader = substr $list->[0], 0, $off;
+  foreach my $letter (keys %leading) {
+    write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
+      if @{$leading{$letter}} > 1;
+  }
+
+  my $npref = "_$pref";
+  $npref = '' if $pref eq '';
+
+  print $fh <<"END";
 static double
-constant(char *name, int arg)
+constant$npref(char *name, int len, int arg)
 {
     errno = 0;
-    switch (*name) {
 END
 
-my(@AZ, @az, @under);
-
-foreach(@const_names){
-    @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
-    @az = 'a' .. 'z' if !@az && /^[a-z]/;
-    @under = '_'  if !@under && /^_/;
-}
+  print $fh <<"END" if $off;
+    if ($offarg + $off >= len ) {
+	errno = EINVAL;
+	return 0;
+    }
+END
 
-foreach $letter (@AZ, @az, @under) {
+  print $fh <<"END";
+    switch (name[$offarg + $off]) {
+END
 
-    last if $letter eq 'a' && !@const_names;
+  foreach my $letter (sort keys %leading) {
+    my $let = $letter;
+    $let = '\0' if $letter eq '';
 
-    print XS "    case '$letter':\n";
-    my($name);
-    while (substr($const_names[0],0,1) eq $letter) {
-	$name = shift(@const_names);
-	$macro = $prefix{$name} ? "$opt_p$name" : $name;
-	next if $const_xsub{$macro};
-	print XS <<"END";
-	if (strEQ(name, "$name"))
-#ifdef $macro
-	    return $macro;
+    print $fh <<EOP;
+    case '$let':
+EOP
+    if (@{$leading{$letter}} > 1) {
+      # It makes sense to call a function
+      if ($off) {
+	print $fh <<EOP;
+	if (!strnEQ(name + $offarg,"$leader", $off))
+	    break;
+EOP
+      }
+      print $fh <<EOP;
+	return constant_$pref$leader$letter(name, len, arg);
+EOP
+    } else {
+      # Do it ourselves
+      my $protect
+	= protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
+
+      print $fh <<EOP;
+	if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) {	/* $pref removed */
+#ifdef $pref$leader$letter$leading{$letter}[0]
+	    return $protect$pref$leader$letter$leading{$letter}[0];
 #else
 	    goto not_there;
 #endif
-END
+	}
+EOP
     }
-    print XS <<"END";
-	break;
-END
-}
-print XS <<"END";
+  }
+  print $fh <<"END";
     }
     errno = EINVAL;
     return 0;
@@ -673,9 +1049,26 @@ not_there:
 }
 
 END
+
 }
 
+if( ! $opt_c ) {
+  print XS <<"END";
+static int
+not_here(char *s)
+{
+    croak("$module::%s not implemented on this architecture", s);
+    return -1;
+}
+
+END
+
+  write_const(\*XS, '', 0, \@const_names);
+}
+
+my $prefix;
 $prefix = "PREFIX = $opt_p" if defined $opt_p;
+
 # Now switch from C to XS by issuing the first MODULE declaration:
 print XS <<"END";
 
@@ -706,14 +1099,22 @@ END
 print XS <<"END" unless $opt_c;
 
 double
-constant(name,arg)
-	char *		name
+constant(sv,arg)
+PREINIT:
+	STRLEN		len;
+INPUT:
+	SV *		sv
+	char *		s = SvPV(sv, len);
 	int		arg
+CODE:
+	RETVAL = constant(s,len,arg);
+OUTPUT:
+	RETVAL
 
 END
 
 my %seen_decl;
-
+my %typemap;
 
 sub print_decl {
   my $fh = shift;
@@ -722,7 +1123,7 @@ sub print_decl {
   return if $seen_decl{$name}++; # Need to do the same for docs as well?
 
   my @argnames = map {$_->[1]} @$args;
-  my @argtypes = map { normalize_type( $_->[0] ) } @$args;
+  my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
   my @argarrays = map { $_->[4] || '' } @$args;
   my $numargs = @$args;
   if ($numargs and $argtypes[-1] eq '...') {
@@ -730,15 +1131,15 @@ sub print_decl {
     $argnames[-1] = '...';
   }
   local $" = ', ';
-  $type = normalize_type($type);
-  
+  $type = normalize_type($type, 1);
+
   print $fh <<"EOP";
 
 $type
 $name(@argnames)
 EOP
 
-  for $arg (0 .. $numargs - 1) {
+  for my $arg (0 .. $numargs - 1) {
     print $fh <<"EOP";
 	$argtypes[$arg]	$argnames[$arg]$argarrays[$arg]
 EOP
@@ -752,9 +1153,11 @@ sub get_typemap {
   my $stdtypemap =  "$Config::Config{privlib}/ExtUtils/typemap";
   unshift @tm, $stdtypemap;
   my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
-  my $image;
-  
-  foreach $typemap (@tm) {
+
+  # Start with useful default values
+  $typemap{float} = 'T_DOUBLE';
+
+  foreach my $typemap (@tm) {
     next unless -e $typemap ;
     # skip directories, binary files etc.
     warn " Scanning $typemap\n";
@@ -770,11 +1173,12 @@ sub get_typemap {
       elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
       elsif ($mode eq 'Typemap') {
 	next if /^\s*($|\#)/ ;
-	if ( ($type, $image) = 
+	my ($type, $image);
+	if ( ($type, $image) =
 	     /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
 	     # This may reference undefined functions:
 	     and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
-	  normalize_type($type);
+	  $typemap{normalize_type($type)} = $image;
 	}
       }
     }
@@ -785,24 +1189,54 @@ sub get_typemap {
 }
 
 
-sub normalize_type {
-  my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
+sub normalize_type {		# Second arg: do not strip const's before \*
   my $type = shift;
-  $type =~ s/$ignore_mods//go;
-  $type =~ s/([\]\[()])/ \1 /g;
-  $type =~ s/\s+/ /g;
+  my $do_keep_deep_const = shift;
+  # If $do_keep_deep_const this is heuristical only
+  my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
+  my $ignore_mods 
+    = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
+  if ($do_keep_deep_const) {	# Keep different compiled /RExen/o separately!
+    $type =~ s/$ignore_mods//go;
+  } else {
+    $type =~ s/$ignore_mods//go;
+  }
+  $type =~ s/([^\s\w])/ \1 /g;
   $type =~ s/\s+$//;
   $type =~ s/^\s+//;
-  $type =~ s/\b\*/ */g;
-  $type =~ s/\*\b/* /g;
-  $type =~ s/\*\s+(?=\*)/*/g;
+  $type =~ s/\s+/ /g;
+  $type =~ s/\* (?=\*)/*/g;
+  $type =~ s/\. \. \./.../g;
+  $type =~ s/ ,/,/g;
   $types_seen{$type}++ 
     unless $type eq '...' or $type eq 'void' or $std_types{$type};
   $type;
 }
 
+my $need_opaque;
+
+sub assign_typemap_entry {
+  my $type = shift;
+  my $otype = $type;
+  my $entry;
+  if ($tmask and $type =~ /$tmask/) {
+    print "Type $type matches -o mask\n" if $opt_d;
+    $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+  }
+  elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+    $type = normalize_type $type;
+    print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
+    $entry = assign_typemap_entry($type);
+  }
+  $entry ||= $typemap{$otype}
+    || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+  $typemap{$otype} = $entry;
+  $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
+  return $entry;
+}
+
 if ($opt_x) {
-    for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+    for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
 }
 
 close XS;
@@ -812,10 +1246,32 @@ if (%types_seen) {
   warn "Writing $ext$modpname/typemap\n";
   open TM, ">typemap" or die "Cannot open typemap file for write: $!";
 
-  for $type (keys %types_seen) {
-    print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
+  for $type (sort keys %types_seen) {
+    my $entry = assign_typemap_entry $type;
+    print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
   }
 
+  print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
+#############################################################################
+INPUT
+T_OPAQUE_STRUCT
+	if (sv_derived_from($arg, \"${ntype}\")) {
+	    STRLEN len;
+	    char  *s = SvPV((SV*)SvRV($arg), len);
+
+	    if (len != sizeof($var))
+		croak(\"Size %d of packed data != expected %d\",
+			len, sizeof($var));
+	    $var = *($type *)s;
+	}
+	else
+	    croak(\"$var is not of type ${ntype}\")
+#############################################################################
+OUTPUT
+T_OPAQUE_STRUCT
+	sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
+EOP
+
   close TM or die "Cannot close typemap file for write: $!";
 }
 
@@ -833,8 +1289,9 @@ print PL "WriteMakefile(\n";
 print PL "    'NAME'	=> '$module',\n";
 print PL "    'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n"; 
 if( ! $opt_X ){ # print C stuff, unless XS is disabled
+  $opt_F = '' unless defined $opt_F;
   print PL "    'LIBS'	=> ['$extralibs'],   # e.g., '-lm' \n";
-  print PL "    'DEFINE'	=> '',     # e.g., '-DHAVE_SOMETHING' \n";
+  print PL "    'DEFINE'	=> '$opt_F',     # e.g., '-DHAVE_SOMETHING' \n";
   print PL "    'INC'	=> '',     # e.g., '-I/usr/include/other' \n";
 }
 print PL ");\n";
@@ -871,17 +1328,24 @@ _END_
 close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
 
 unless ($opt_C) {
-    warn "Writing $ext$modpname/Changes\n";
-    open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
-    print EX "Revision history for Perl extension $module.\n\n";
-    print EX "$TEMPLATE_VERSION  ",scalar localtime,"\n";
-    print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
-    close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
+  warn "Writing $ext$modpname/Changes\n";
+  $" = ' ';
+  open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
+  @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
+  print EX <<EOP;
+Revision history for Perl extension $module.
+
+$TEMPLATE_VERSION  @{[scalar localtime]}
+\t- original version; created by h2xs $H2XS_VERSION with options
+\t\t@ARGS
+
+EOP
+  close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
 }
 
 warn "Writing $ext$modpname/MANIFEST\n";
 open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
-@files = <*>;
+my @files = <*>;
 if (!@files) {
   eval {opendir(D,'.');};
   unless ($@) { @files = readdir(D); closedir(D); }