X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2FConstant.pm;h=cb3931821d7a3b5c2f94a48994322eaf3e717592;hb=983ffd37e39751798fdd14853511af238c5fe291;hp=25feacc5ff6798c97675d6bc935f5857a9e92271;hpb=3414cef00cbe871b34a427fbbdf64738315ff89e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm
index 25feacc..cb39318 100644
--- a/lib/ExtUtils/Constant.pm
+++ b/lib/ExtUtils/Constant.pm
@@ -1,4 +1,6 @@
 package ExtUtils::Constant;
+use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
+$VERSION = '0.10';
 
 =head1 NAME
 
@@ -6,14 +8,15 @@ ExtUtils::Constant - generate XS code to import C header constants
 
 =head1 SYNOPSIS
 
-    use ExtUtils::Constant qw (constant_types C_constant XS_constant);
-    print constant_types(); # macro defs
-    foreach (C_constant ("Foo", undef, "IV", undef, undef, undef,
-                         @names) ) {
-	print $_, "\n"; # C constant subs
-    }
-    print "MODULE = Foo		PACKAGE = Foo\n";
-    print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant
+    use ExtUtils::Constant qw (WriteConstants);
+    WriteConstants(
+        NAME => 'Foo',
+        NAMES => [qw(FOO BAR BAZ)],
+        C_FILE => 'constants.c',
+        XS_FILE => 'constants.xs',
+    );
+    # Generates wrapper code to make the values of the constants FOO BAR BAZ
+    #  available to perl
 
 =head1 DESCRIPTION
 
@@ -25,8 +28,18 @@ constants.
 
 =head1 USAGE
 
-Generally one only needs to call the 3 functions shown in the synopsis,
-C<constant_types()>, C<C_constant> and C<XS_constant>.
+Generally one only needs to call the C<WriteConstants> function, and then
+
+    #include "constants.c"
+
+in the C section of C<Foo.xs>
+
+    INCLUDE constants.xs
+
+in the XS section of C<Foo.xs>.
+
+For greater flexibility use C<constant_types()>, C<C_constant> and
+C<XS_constant>, with which C<WriteConstants> is implemented.
 
 Currently this module understands the following types. h2xs may only know
 a subset. The sizes of the numeric types are chosen by the C<Configure>
@@ -55,6 +68,10 @@ NUL terminated string, length will be determined with C<strlen>
 A fixed length thing, given as a [pointer, length] pair. If you know the
 length of a string at compile time you may use this instead of I<PV>
 
+=item SV
+
+A B<mortal> SV.
+
 =item YES
 
 Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
@@ -75,45 +92,48 @@ C<undef>.  The value of the macro is not needed.
 
 =cut
 
-require 5.006; # I think, for [:cntrl:] in REGEXP
-use warnings;
+if ($] >= 5.006) {
+  eval "use warnings; 1" or die $@;
+}
 use strict;
 use Carp;
 
 use Exporter;
-use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
 use Text::Wrap;
 $Text::Wrap::huge = 'overflow';
 $Text::Wrap::columns = 80;
 
 @ISA = 'Exporter';
-$VERSION = '0.04';
 
 %EXPORT_TAGS = ( 'all' => [ qw(
 	XS_constant constant_types return_clause memEQ_clause C_stringify
-	C_constant autoload
+	C_constant autoload WriteConstants WriteMakefileSnippet
 ) ] );
 
 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 
 %XS_Constant = (
-                IV => 'PUSHi(iv)',
-                UV => 'PUSHu((UV)iv)',
-                NV => 'PUSHn(nv)',
-                PV => 'PUSHp(pv, strlen(pv))',
-                PVN => 'PUSHp(pv, iv)',
-		YES => 'PUSHs(&PL_sv_yes)',
-		NO => 'PUSHs(&PL_sv_no)',
-		UNDEF => ''	# implicit undef
+		IV    => 'PUSHi(iv)',
+		UV    => 'PUSHu((UV)iv)',
+		NV    => 'PUSHn(nv)',
+		PV    => 'PUSHp(pv, strlen(pv))',
+		PVN   => 'PUSHp(pv, iv)',
+		SV    => 'PUSHs(sv)',
+		YES   => 'PUSHs(&PL_sv_yes)',
+		NO    => 'PUSHs(&PL_sv_no)',
+		UNDEF => '',	# implicit undef
 );
 
 %XS_TypeSet = (
-                IV => '*iv_return =',
-                UV => '*iv_return = (IV)',
-                NV => '*nv_return =',
-                PV => '*pv_return =',
-                PVN => ['*pv_return =', '*iv_return = (IV)'],
-		YES => undef, NO => undef, UNDEF => undef
+		IV    => '*iv_return =',
+		UV    => '*iv_return = (IV)',
+		NV    => '*nv_return =',
+		PV    => '*pv_return =',
+		PVN   => ['*pv_return =', '*iv_return = (IV)'],
+		SV    => '*sv_return = ',
+		YES   => undef,
+		NO    => undef,
+		UNDEF => undef,
 );
 
 
@@ -135,8 +155,15 @@ sub C_stringify {
   s/\t/\\t/g;
   s/\f/\\f/g;
   s/\a/\\a/g;
-  s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
-  s/\177/\\177/g;	# DEL doesn't seem to be a [:cntrl:]
+  unless ($] < 5.006) {
+    # This will elict a warning on 5.005_03 about [: :] being reserved unless
+    # I cheat
+    my $cheat = '([[:^print:]])';
+    s/$cheat/sprintf "\\%03o", ord $1/ge;
+  } else {
+    require POSIX;
+    s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
+  }
   $_;
 }
 
@@ -160,6 +187,12 @@ sub constant_types () {
 #ifndef NVTYPE
 typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it.  */
 #endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support.  */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support.  */
+#endif
 EOT
 
   return join '', @lines;
@@ -207,11 +240,13 @@ sub memEQ_clause {
   return $body;
 }
 
-=item assign INDENT, TYPE, VALUE...
+=item assign INDENT, TYPE, PRE, POST, VALUE...
 
 A function to return a suitable assignment clause. If I<TYPE> is aggregate
 (eg I<PVN> expects both pointer and length) then there should be multiple
-I<VALUE>s for the components.
+I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
+of C code to preceed and follow the assignment. I<PRE> will be at the start
+of a block, so variables may be defined in it.
 
 =cut
 
@@ -220,7 +255,18 @@ I<VALUE>s for the components.
 sub assign {
   my $indent = shift;
   my $type = shift;
+  my $pre = shift;
+  my $post = shift || '';
   my $clause;
+  my $close;
+  if ($pre) {
+    chomp $pre;
+    $clause = $indent . "{\n$pre";
+    $clause .= ";" unless $pre =~ /;$/;
+    $clause .= "\n";
+    $close = "$indent}\n";
+    $indent .= "  ";
+  }
   die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
   my $typeset = $XS_TypeSet{$type};
   if (ref $typeset) {
@@ -234,11 +280,20 @@ sub assign {
       if @_ > 1;
     $clause .= $indent . "$typeset $_[0];\n";
   }
+  chomp $post;
+  if (length $post) {
+    $clause .= "$post";
+    $clause .= ";" unless $post =~ /;$/;
+    $clause .= "\n";
+  }
   $clause .= "${indent}return PERL_constant_IS$type;\n";
+  $clause .= $close if $close;
   return $clause;
 }
 
-=item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT
+=item return_clause
+
+return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
 
 A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
 I<VALUE> when not defined.  If I<TYPE> is aggregate (eg I<PVN> expects both
@@ -247,17 +302,20 @@ values in the order expected by the type.  C<C_constant> will always call
 this function with I<MACRO> defined, defaulting to the constant's name.
 I<DEFAULT> if defined is an array reference giving default type and and
 value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
+The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
+and follow the value, and the default value.
 
 =cut
 
-sub return_clause ($$$$$) {
+sub return_clause ($$$$$$$$$) {
 ##ifdef thingy
 #      *iv_return = thingy;
 #      return PERL_constant_ISIV;
 ##else
 #      return PERL_constant_NOTDEF;
 ##endif
-  my ($value, $type, $indent, $macro, $default) = @_;
+  my ($value, $type, $indent, $macro, $default, $pre, $post,
+      $def_pre, $def_post) = @_;
   $macro = $value unless defined $macro;
   $indent = ' ' x ($indent || 6);
 
@@ -266,39 +324,129 @@ sub return_clause ($$$$$) {
   ##ifdef thingy
   if (ref $macro) {
     $clause = $macro->[0];
-  } else {
+  } elsif ($macro ne "1") {
     $clause = "#ifdef $macro\n";
   }
 
   #      *iv_return = thingy;
   #      return PERL_constant_ISIV;
-  $clause .= assign ($indent, $type, ref $value ? @$value : $value);
-
-  ##else
-  $clause .= "#else\n";
-  
-  #      return PERL_constant_NOTDEF;
-  if (!defined $default) {
-    $clause .= "${indent}return PERL_constant_NOTDEF;\n";
-  } else {
-    $clause .= assign ($indent, ref $default ? @$default : $default);
-  }
+  $clause .= assign ($indent, $type, $pre, $post,
+                     ref $value ? @$value : $value);
 
-  ##endif
-  if (ref $macro) {
-    $clause .= $macro->[1];
-  } else {
-    $clause .= "#endif\n";
+  if (ref $macro or $macro ne "1") {
+    ##else
+    $clause .= "#else\n";
+
+    #      return PERL_constant_NOTDEF;
+    if (!defined $default) {
+      $clause .= "${indent}return PERL_constant_NOTDEF;\n";
+    } else {
+      my @default = ref $default ? @$default : $default;
+      $type = shift @default;
+      $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
+    }
+
+    ##endif
+    if (ref $macro) {
+      $clause .= $macro->[1];
+    } else {
+      $clause .= "#endif\n";
+    }
   }
   return $clause
 }
 
+=item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
+
+An internal function to generate a suitable C<switch> clause, called by
+C<C_constant> I<ITEM>s are in the hash ref format as given in the description
+of C<C_constant>, and must all have the names of the same length, given by
+I<NAMELEN> (This is not checked).  I<ITEMHASH> is a reference to a hash,
+keyed by name, values being the hashrefs in the I<ITEM> list.
+(No parameters are modified, and there can be keys in the I<ITEMHASH> that
+are not in the list of I<ITEM>s without causing problems).
+
+=cut
+
+sub switch_clause {
+  my ($indent, $comment, $namelen, $items, @items) = @_;
+  $indent = ' ' x ($indent || 2);
+
+  my @names = sort map {$_->{name}} @items;
+  my $leader = $indent . '/* ';
+  my $follower = ' ' x length $leader;
+  my $body = $indent . "/* Names all of length $namelen.  */\n";
+  if ($comment) {
+    $body = wrap ($leader, $follower, $comment) . "\n";
+    $leader = $follower;
+  }
+  $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
+  # Figure out what to switch on.
+  # (RMS, Spread of jump table, Position, Hashref)
+  my @best = (1e38, ~0);
+  foreach my $i (0 .. ($namelen - 1)) {
+    my ($min, $max) = (~0, 0);
+    my %spread;
+    foreach (@names) {
+      my $char = substr $_, $i, 1;
+      my $ord = ord $char;
+      $max = $ord if $ord > $max;
+      $min = $ord if $ord < $min;
+      push @{$spread{$char}}, $_;
+      # warn "$_ $char";
+    }
+    # I'm going to pick the character to split on that minimises the root
+    # mean square of the number of names in each case. Normally this should
+    # be the one with the most keys, but it may pick a 7 where the 8 has
+    # one long linear search. I'm not sure if RMS or just sum of squares is
+    # actually better.
+    # $max and $min are for the tie-breaker if the root mean squares match.
+    # Assuming that the compiler may be building a jump table for the
+    # switch() then try to minimise the size of that jump table.
+    # Finally use < not <= so that if it still ties the earliest part of
+    # the string wins. Because if that passes but the memEQ fails, it may
+    # only need the start of the string to bin the choice.
+    # I think. But I'm micro-optimising. :-)
+    my $ss;
+    $ss += @$_ * @$_ foreach values %spread;
+    my $rms = sqrt ($ss / keys %spread);
+    if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
+      @best = ($rms, $max - $min, $i, \%spread);
+    }
+  }
+  die "Internal error. Failed to pick a switch point for @names"
+    unless defined $best[2];
+  # use Data::Dumper; print Dumper (@best);
+  my ($offset, $best) = @best[2,3];
+  $body .= $indent . "/* Offset $offset gives the best switch position.  */\n";
+  $body .= $indent . "switch (name[$offset]) {\n";
+  foreach my $char (sort keys %$best) {
+    $body .= $indent . "case '" . C_stringify ($char) . "':\n";
+    foreach my $name (sort @{$best->{$char}}) {
+      my $thisone = $items->{$name};
+      my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
+        = @$thisone{qw (value macro default pre post def_pre def_post)};
+      $value = $name unless defined $value;
+      $macro = $name unless defined $macro;
+
+      # We have checked this offset.
+      $body .= memEQ_clause ($name, $offset, 2 + length $indent);
+      $body .= return_clause ($value, $thisone->{type},  4 + length $indent,
+                              $macro, $default, $pre, $post,
+                              $def_pre, $def_post);
+      $body .= $indent . "  }\n";
+    }
+    $body .= $indent . "  break;\n";
+  }
+  $body .= $indent . "}\n";
+  return $body;
+}
+
 =item params WHAT
 
 An internal function. I<WHAT> should be a hashref of types the constant
-function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
-$use_pv> to show which combination of pointers will be needed in the C
-argument list.
+function will return. I<params> returns a hashref keyed IV NV PV SV to show
+which combination of pointers will be needed in the C argument list.
 
 =cut
 
@@ -307,84 +455,85 @@ sub params {
   foreach (sort keys %$what) {
     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
   }
-  my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
-  my $use_nv = $what->{NV};
-  my $use_pv = $what->{PV} || $what->{PVN};
-  return ($use_iv, $use_nv, $use_pv);
+  my $params = {};
+  $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
+  $params->{NV} = 1 if $what->{NV};
+  $params->{PV} = 1 if $what->{PV} || $what->{PVN};
+  $params->{SV} = 1 if $what->{SV};
+  return $params;
 }
 
-=item dump_names  
+=item dump_names
 
-dump_names  PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM...
+dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM...
 
 An internal function to generate the embedded perl code that will regenerate
-the constant subroutines.  Parameters are the same as for C_constant, except
-that there is no NAMELEN.
+the constant subroutines.  I<DEFAULT_TYPE>, I<TYPES> and I<ITEM>s are the
+same as for C_constant.  I<INDENT> is treated as number of spaces to indent
+by.  I<OPTIONS> is a hashref of options. Currently only C<declare_types> is
+recognised.  If the value is true a C<$types> is always declared in the perl
+code generated, if defined and false never declared, and if undefined C<$types>
+is only declared if the values in I<TYPES> as passed in cannot be inferred from
+I<DEFAULT_TYPES> and the I<ITEM>s.
 
 =cut
 
 sub dump_names {
-  my ($package, $subname, $default_type, $what, $indent, @items) = @_;
-  my (@simple, @complex);
+  my ($default_type, $what, $indent, $options, @items) = @_;
+  my $declare_types = $options->{declare_types};
+  $indent = ' ' x ($indent || 0);
+
+  my $result;
+  my (@simple, @complex, %used_types);
   foreach (@items) {
-    my $type = $_->{type} || $default_type;
+    my $type;
+    if (ref $_) {
+      $type = $_->{type} || $default_type;
+    } else {
+      $_ = {name=>$_};
+      $type = $default_type;
+    }
+    $used_types{$type}++;
     if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
         and !defined ($_->{macro}) and !defined ($_->{value})
-        and !defined ($_->{default})) {
+        and !defined ($_->{default}) and !defined ($_->{pre})
+        and !defined ($_->{post}) and !defined ($_->{def_pre})
+        and !defined ($_->{def_post})) {
       # It's the default type, and the name consists only of A-Za-z0-9_
       push @simple, $_->{name};
     } else {
       push @complex, $_;
     }
   }
-  my $result = <<"EOT";
-  /* When generated this function returned values for the list of names given
-     in this section of perl code.  Rather than manually editing these functions
-     to add or remove constants, which would result in this comment and section
-     of code becoming inaccurate, we recommend that you edit this section of
-     code, and use it to regenerate a new set of constant functions which you
-     then use to replace the originals.
-
-     Regenerate these constant functions by feeding this entire source file to
-     perl -x
 
-#!$^X -w
-use ExtUtils::Constant qw (constant_types C_constant XS_constant);
-
-EOT
-  $result .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what)
- . "};\n";
-  $result .= wrap ("my \@names = (qw(",
-		   "               ", join (" ", sort @simple) . ")");
+  if (!defined $declare_types) {
+    # Do they pass in any types we weren't already using?
+    foreach (keys %$what) {
+      next if $used_types{$_};
+      $declare_types++; # Found one in $what that wasn't used.
+      last; # And one is enough to terminate this loop
+    }
+  }
+  if ($declare_types) {
+    $result = $indent . 'my $types = {map {($_, 1)} qw('
+      . join (" ", sort keys %$what) . ")};\n";
+  }
+  $result .= wrap ($indent . "my \@names = (qw(",
+		   $indent . "               ", join (" ", sort @simple) . ")");
   if (@complex) {
     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
       my $name = C_stringify $item->{name};
-      my ($macro, $value, $default) = @$item{qw (macro value default)};
-      my $line = ",\n            {name=>\"$name\"";
+      my $line = ",\n$indent            {name=>\"$name\"";
       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
-      if (defined $macro) {
-        if (ref $macro) {
-          $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
-            . '"]';
-        } else {
-          $line .= ", macro=>\"" . C_stringify($macro) . "\"";
-        }
-      }
-      if (defined $value) {
-        if (ref $value) {
-          $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
-            . '"]';
-        } else {
-          $line .= ", value=>\"" . C_stringify($value) . "\"";
-        }
-      }
-      if (defined $default) {
-        if (ref $default) {
-          $line .= ', default=>["'. join ('", "', map {C_stringify $_}
-                                          @$default)
-            . '"]';
-        } else {
-          $line .= ", default=>\"" . C_stringify($default) . "\"";
+      foreach my $thing (qw (macro value default pre post def_pre def_post)) {
+        my $value = $item->{$thing};
+        if (defined $value) {
+          if (ref $value) {
+            $line .= ", $thing=>[\""
+              . join ('", "', map {C_stringify $_} @$value) . '"]';
+          } else {
+            $line .= ", $thing=>\"" . C_stringify($value) . "\"";
+          }
         }
       }
       $line .= "}";
@@ -398,6 +547,38 @@ EOT
   }
   $result .= ");\n";
 
+  $result;
+}
+
+
+=item dogfood
+
+dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
+
+An internal function to generate the embedded perl code that will regenerate
+the constant subroutines.  Parameters are the same as for C_constant.
+
+=cut
+
+sub dogfood {
+  my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
+    = @_;
+  my $result = <<"EOT";
+  /* When generated this function returned values for the list of names given
+     in this section of perl code.  Rather than manually editing these functions
+     to add or remove constants, which would result in this comment and section
+     of code becoming inaccurate, we recommend that you edit this section of
+     code, and use it to regenerate a new set of constant functions which you
+     then use to replace the originals.
+
+     Regenerate these constant functions by feeding this entire source file to
+     perl -x
+
+#!$^X -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+EOT
+  $result .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items);
   $result .= <<'EOT';
 
 print constant_types(); # macro defs
@@ -409,12 +590,13 @@ EOT
   if (defined $indent) {
     require Data::Dumper;
     $Data::Dumper::Terse=1;
+    $Data::Dumper::Terse=1; # Not used once. :-)
     chomp ($indent = Data::Dumper::Dumper ($indent));
     $result .= $indent;
   } else {
     $result .= 'undef';
   }
-  $result .= ', undef, @names) ) {
+  $result .= ", $breakout" . ', @names) ) {
     print $_, "\n"; # C constant subs
 }
 print "#### XS Section:\n";
@@ -423,13 +605,13 @@ __END__
    */
 
 ';
-  
+
   $result;
 }
 
-=item C_constant 
+=item C_constant
 
-C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
+C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
 
 A function that returns a B<list> of C subroutine definitions that return
 the value and type of constants when passed the name by the XS wrapper.
@@ -468,12 +650,33 @@ pre-processor constructions such as
 
 to be used to determine if a constant is to be defined.
 
+A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif>
+test is omitted.
+
 =item default
 
 Default value to use (instead of C<croak>ing with "your vendor has not
 defined...") to return if the macro isn't defined. Specify a reference to
 an array with type followed by value(s).
 
+=item pre
+
+C code to use before the assignment of the value of the constant. This allows
+you to use temporary variables to extract a value from part of a C<struct>
+and return this as I<value>. This C code is places at the start of a block,
+so you can declare variables in it.
+
+=item post
+
+C code to place between the assignment of value (to a temporary) and the
+return from the function. This allows you to clear up anything in I<pre>.
+Rarely needed.
+
+=item def_pre
+=item def_post
+
+Equivalents of I<pre> and I<post> for the default value.
+
 =back
 
 I<PACKAGE> is the name of the package, and is only used in comments inside the
@@ -494,134 +697,101 @@ be used to pass in information used to change the C indentation style used.]
 The best way to maintain consistency is to pass in a hash reference and let
 this function update it.
 
-I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
-this length, and that the constant name passed in by perl is checked and
-also of this length. It is used during recursion, and should be C<undef>
-unless the caller has checked all the lengths during code generation, and
-the generated subroutine is only to be called with a name of this length.
+I<BREAKOUT> governs when child functions of I<SUBNAME> are generated.  If there
+are I<BREAKOUT> or more I<ITEM>s with the same length of name, then the code
+to switch between them is placed into a function named I<SUBNAME>_I<LEN>, for
+example C<constant_5> for names 5 characters long.  The default I<BREAKOUT> is
+3.  A single C<ITEM> is always inlined.
 
 =cut
 
+# The parameter now BREAKOUT was previously documented as:
+#
+# I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s are of
+# this length, and that the constant name passed in by perl is checked and
+# also of this length. It is used during recursion, and should be C<undef>
+# unless the caller has checked all the lengths during code generation, and
+# the generated subroutine is only to be called with a name of this length.
+#
+# As you can see it now performs this function during recursion by being a
+# scalar reference.
+
 sub C_constant {
-  my ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_;
+  my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
+    = @_;
   $package ||= 'Foo';
   $subname ||= 'constant';
   # I'm not using this. But a hashref could be used for full formatting without
   # breaking this API
   # $indent ||= 0;
-   $default_type ||= 'IV';
-  if (!ref $what) {
-    # Convert line of the form IV,UV,NV to hash
-    $what = {map {$_ => 1} split /,\s*/, ($what || '')};
-    # Figure out what types we're dealing with, and assign all unknowns to the
-    # default type
-  }
-  my %items;
-  foreach (@items) {
-    my $name;
-    if (ref $_) {
-      # Make a copy which is a normalised version of the ref passed in.
-      $name = $_->{name};
-      my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
-      $type ||= $default_type;
-      $what->{$type} = 1;
-      $_ = {name=>$name, type=>$type};
-
-      undef $macro if defined $macro and $macro eq $name;
-      $_->{macro} = $macro if defined $macro;
-      undef $value if defined $value and $value eq $name;
-      $_->{value} = $value if defined $value;
-      $_->{default} = $default if defined $default;
-    } else {
-      $name = $_;
-      $_ = {name=>$_, type=>$default_type};
-      $what->{$default_type} = 1;
+
+  my ($namelen, $items);
+  if (ref $breakout) {
+    # We are called recursively. We trust @items to be normalised, $what to
+    # be a hashref, and pinch %$items from our parent to save recalculation.
+    ($namelen, $items) = @$breakout;
+  } else {
+    $breakout ||= 3;
+    $default_type ||= 'IV';
+    if (!ref $what) {
+      # Convert line of the form IV,UV,NV to hash
+      $what = {map {$_ => 1} split /,\s*/, ($what || '')};
+      # Figure out what types we're dealing with, and assign all unknowns to the
+      # default type
     }
-    warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
-    if (exists $items{$name}) {
-      die "Multiple definitions for macro $name";
+    foreach (@items) {
+      my $name;
+      if (ref $_) {
+        my $orig = $_;
+        # Make a copy which is a normalised version of the ref passed in.
+        $name = $_->{name};
+        my ($type, $macro, $value) = @$_{qw (type macro value)};
+        $type ||= $default_type;
+        $what->{$type} = 1;
+        $_ = {name=>$name, type=>$type};
+
+        undef $macro if defined $macro and $macro eq $name;
+        $_->{macro} = $macro if defined $macro;
+        undef $value if defined $value and $value eq $name;
+        $_->{value} = $value if defined $value;
+        foreach my $key (qw(default pre post def_pre def_post)) {
+          my $value = $orig->{$key};
+          $_->{$key} = $value if defined $value;
+          # warn "$key $value";
+        }
+      } else {
+        $name = $_;
+        $_ = {name=>$_, type=>$default_type};
+        $what->{$default_type} = 1;
+      }
+      warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
+      if (exists $items->{$name}) {
+        die "Multiple definitions for macro $name";
+      }
+      $items->{$name} = $_;
     }
-    $items{$name} = $_;
   }
-  my ($use_iv, $use_nv, $use_pv) = params ($what);
+  my $params = params ($what);
 
-  my ($body, @subs) = "static int\n$subname (const char *name";
+  my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
   $body .= ", STRLEN len" unless defined $namelen;
-  $body .= ", IV *iv_return" if $use_iv;
-  $body .= ", NV *nv_return" if $use_nv;
-  $body .= ", const char **pv_return" if $use_pv;
+  $body .= ", IV *iv_return" if $params->{IV};
+  $body .= ", NV *nv_return" if $params->{NV};
+  $body .= ", const char **pv_return" if $params->{PV};
+  $body .= ", SV **sv_return" if $params->{SV};
   $body .= ") {\n";
 
   if (defined $namelen) {
     # We are a child subroutine. Print the simple description
-    my @names = sort map {$_->{name}} @items;
-    my $names = << 'EOT'
-  /* When generated this function returned values for the list of names given
-     here.  However, subsequent manual editing may have added or removed some.
-EOT
-     . wrap ("     ", "     ", join (" ", @names) . " */") . "\n";
-    # Figure out what to switch on.
-    # (RMS, Spread of jump table, Position, Hashref)
-    my @best = (1e38, ~0);
-    foreach my $i (0 .. ($namelen - 1)) {
-      my ($min, $max) = (~0, 0);
-      my %spread;
-      foreach (@names) {
-        my $char = substr $_, $i, 1;
-        my $ord = ord $char;
-        $max = $ord if $ord > $max; 
-        $min = $ord if $ord < $min;
-        push @{$spread{$char}}, $_;
-        # warn "$_ $char";
-      }
-      # I'm going to pick the character to split on that minimises the root
-      # mean square of the number of names in each case. Normally this should
-      # be the one with the most keys, but it may pick a 7 where the 8 has
-      # one long linear search. I'm not sure if RMS or just sum of squares is
-      # actually better.
-      # $max and $min are for the tie-breaker if the root mean squares match.
-      # Assuming that the compiler may be building a jump table for the
-      # switch() then try to minimise the size of that jump table.
-      # Finally use < not <= so that if it still ties the earliest part of
-      # the string wins. Because if that passes but the memEQ fails, it may
-      # only need the start of the string to bin the choice.
-      # I think. But I'm micro-optimising. :-)
-      my $ss;
-      $ss += @$_ * @$_ foreach values %spread;
-      my $rms = sqrt ($ss / keys %spread);
-      if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
-        @best = ($rms, $max - $min, $i, \%spread);
-      }
-    }
-    die "Internal error. Failed to pick a switch point for @names"
-      unless defined $best[2];
-    # use Data::Dumper; print Dumper (@best);
-    my ($offset, $best) = @best[2,3];
-    $body .= "  /* Names all of length $namelen.  */\n";
-    $body .= $names;
-    $body .= "  /* Offset $offset gives the best switch position.  */\n";
-    $body .= "  switch (name[$offset]) {\n";
-    foreach my $char (sort keys %$best) {
-      $body .= "  case '" . C_stringify ($char) . "':\n";
-      foreach my $name (sort @{$best->{$char}}) {
-        my $thisone = $items{$name};
-        my ($value, $macro, $default) = @$thisone{qw (value macro default)};
-        $value = $name unless defined $value;
-        $macro = $name unless defined $macro;
-
-        $body .= memEQ_clause ($name, $offset); # We have checked this offset.
-        $body .= return_clause ($value, $thisone->{type}, undef, $macro,
-                                $default);
-        $body .= "    }\n";
-      }
-      $body .= "    break;\n";
-    }
-    $body .= "  }\n";
+    my $comment = 'When generated this function returned values for the list'
+      . ' of names given here.  However, subsequent manual editing may have'
+        . ' added or removed some.';
+    $body .= switch_clause (2, $comment, $namelen, $items, @items);
   } else {
     # We are the top level.
     $body .= "  /* Initially switch on the length of the name.  */\n";
-    $body .= dump_names ($package, $subname, $default_type, $what, $indent,
-                         @items);
+    $body .= dogfood ($package, $subname, $default_type, $what, $indent,
+                      $breakout, @items);
     $body .= "  switch (len) {\n";
     # Need to group names of the same length
     my @by_length;
@@ -633,22 +803,32 @@ EOT
       $body .= "  case $i:\n";
       if (@{$by_length[$i]} == 1) {
         my $thisone = $by_length[$i]->[0];
-        my ($name, $value, $macro, $default)
-          = @$thisone{qw (name value macro default)};
+        my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
+          = @$thisone{qw (name value macro default pre post def_pre def_post)};
         $value = $name unless defined $value;
         $macro = $name unless defined $macro;
 
         $body .= memEQ_clause ($name);
         $body .= return_clause ($value, $thisone->{type}, undef, $macro,
-                                $default);
+                                $default, $pre, $post, $def_pre, $def_post);
         $body .= "    }\n";
+      } elsif (@{$by_length[$i]} < $breakout) {
+        $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
       } else {
-        push @subs, C_constant ($package, "${subname}_$i", $default_type,
-                                $what, $indent, $i, @{$by_length[$i]});
-        $body .= "    return ${subname}_$i (name";
-        $body .= ", iv_return" if $use_iv;
-        $body .= ", nv_return" if $use_nv;
-        $body .= ", pv_return" if $use_pv;
+        # Only use the minimal set of parameters actually needed by the types
+        # of the names of this length.
+        my $what = {};
+        foreach (@{$by_length[$i]}) {
+          $what->{$_->{type}} = 1;
+        }
+        $params = params ($what);
+        push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
+                                $indent, [$i, $items], @{$by_length[$i]});
+        $body .= "    return ${subname}_$i (aTHX_ name";
+        $body .= ", iv_return" if $params->{IV};
+        $body .= ", nv_return" if $params->{NV};
+        $body .= ", pv_return" if $params->{PV};
+        $body .= ", sv_return" if $params->{SV};
         $body .= ");\n";
       }
       $body .= "    break;\n";
@@ -691,7 +871,7 @@ sub XS_constant {
     # Convert line of the form IV,UV,NV to hash
     $what = {map {$_ => 1} split /,\s*/, ($what)};
   }
-  my ($use_iv, $use_nv, $use_pv) = params ($what);
+  my $params = params ($what);
   my $type;
 
   my $xs = <<"EOT";
@@ -707,17 +887,17 @@ $subname(sv)
         int		type;
 EOT
 
-  if ($use_iv) {
+  if ($params->{IV}) {
     $xs .= "	IV		iv;\n";
   } else {
     $xs .= "	/* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
   }
-  if ($use_nv) {
+  if ($params->{NV}) {
     $xs .= "	NV		nv;\n";
   } else {
     $xs .= "	/* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
   }
-  if ($use_pv) {
+  if ($params->{PV}) {
     $xs .= "	const char	*pv;\n";
   } else {
     $xs .=
@@ -731,16 +911,17 @@ EOT
     PPCODE:
 EOT
 
-  if ($use_iv xor $use_nv) {
+  if ($params->{IV} xor $params->{NV}) {
     $xs .= << "EOT";
-        /* Change this to $C_subname(s, len, &iv, &nv);
+        /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
            if you need to return both NVs and IVs */
 EOT
   }
-  $xs .= "	type = $C_subname(s, len";
-  $xs .= ', &iv' if $use_iv;
-  $xs .= ', &nv' if $use_nv;
-  $xs .= ', &pv' if $use_pv;
+  $xs .= "	type = $C_subname(aTHX_ s, len";
+  $xs .= ', &iv' if $params->{IV};
+  $xs .= ', &nv' if $params->{NV};
+  $xs .= ', &pv' if $params->{PV};
+  $xs .= ', &sv' if $params->{SV};
   $xs .= ");\n";
 
   $xs .= << "EOT";
@@ -753,7 +934,7 @@ EOT
           break;
         case PERL_constant_NOTDEF:
           sv = sv_2mortal(newSVpvf(
-	    "Your vendor has not defined $package macro %s used", s));
+	    "Your vendor has not defined $package macro %s, used", s));
           PUSHs(sv);
           break;
 EOT
@@ -761,13 +942,18 @@ EOT
   foreach $type (sort keys %XS_Constant) {
     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
       unless $what->{$type};
-    $xs .= << "EOT";
-        case PERL_constant_IS$type:
+    $xs .= "        case PERL_constant_IS$type:\n";
+    if (length $XS_Constant{$type}) {
+      $xs .= << "EOT";
           EXTEND(SP, 1);
           PUSHs(&PL_sv_undef);
           $XS_Constant{$type};
-          break;
 EOT
+    } else {
+      # Do nothing. return (), which will be correctly interpreted as
+      # (undef, undef)
+    }
+    $xs .= "          break;\n";
     unless ($what->{$type}) {
       chop $xs; # Yes, another need for chop not chomp.
       $xs .= " */\n";
@@ -776,7 +962,7 @@ EOT
   $xs .= << "EOT";
         default:
           sv = sv_2mortal(newSVpvf(
-	    "Unexpected return type %d while processing $package macro %s used",
+	    "Unexpected return type %d while processing $package macro %s, used",
                type, s));
           PUSHs(sv);
         }
@@ -812,7 +998,7 @@ sub autoload {
 
   $func .= "\n\n"
   . "    my \$constname;\n";
-  $func .= 
+  $func .=
     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
 
   $func .= <<"EOT";
@@ -855,6 +1041,137 @@ END
 
   return $func;
 }
+
+
+=item WriteMakefileSnippet
+
+WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] 
+
+An function to generate perl code for Makefile.PL that will regenerate
+the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
+with the addition of C<INDENT> to specify the number of leading spaces
+(default 2).
+
+Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
+C<XS_FILE> are recognised.
+
+=cut
+
+sub WriteMakefileSnippet {
+  my %args = @_;
+  my $indent = $args{INDENT} || 2;
+
+  my $result = <<"EOT";
+ExtUtils::Constant::WriteConstants(
+                                   NAME         => '$args{NAME}',
+                                   NAMES        => \\\@names,
+                                   DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
+EOT
+  foreach (qw (C_FILE XS_FILE)) {
+    next unless exists $args{$_};
+    $result .= sprintf "                                   %-12s => '%s',\n",
+      $_, $args{$_};
+  }
+  $result .= <<'EOT';
+                                );
+EOT
+
+  $result =~ s/^/' 'x$indent/gem;
+  return dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef,
+                           @{$args{NAMES}})
+          . $result;
+}
+
+=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
+
+Writes a file of C code and a file of XS code which you should C<#include>
+and C<INCLUDE> in the C and XS sections respectively of your module's XS
+code.  You probaby want to do this in your C<Makefile.PL>, so that you can
+easily edit the list of constants without touching the rest of your module.
+The attributes supported are
+
+=over 4
+
+=item NAME
+
+Name of the module.  This must be specified
+
+=item DEFAULT_TYPE
+
+The default type for the constants.  If not specified C<IV> is assumed.
+
+=item BREAKOUT_AT
+
+The names of the constants are grouped by length.  Generate child subroutines
+for each group with this number or more names in.
+
+=item NAMES
+
+An array of constants' names, either scalars containing names, or hashrefs
+as detailed in L<"C_constant">.
+
+=item C_FILE
+
+The name of the file to write containing the C code.  The default is
+C<constants.c>.
+
+=item XS_FILE
+
+The name of the file to write containing the XS code.  The default is
+C<constants.xs>.
+
+=item SUBNAME
+
+The perl visible name of the XS subroutine generated which will return the
+constants. The default is C<constant>.
+
+=item C_SUBNAME
+
+The name of the C subroutine generated which will return the constants.
+The default is I<SUBNAME>.  Child subroutines have C<_> and the name
+length appended, so constants with 10 character names would be in
+C<constant_10> with the default I<XS_SUBNAME>.
+
+=back
+
+=cut
+
+sub WriteConstants {
+  my %ARGS =
+    ( # defaults
+     C_FILE =>       'constants.c',
+     XS_FILE =>      'constants.xs',
+     SUBNAME =>      'constant',
+     DEFAULT_TYPE => 'IV',
+     @_);
+
+  $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
+
+  croak "Module name not specified" unless length $ARGS{NAME};
+
+  open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
+  open my $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
+
+  # As this subroutine is intended to make code that isn't edited, there's no
+  # need for the user to specify any types that aren't found in the list of
+  # names.
+  my $types = {};
+
+  print $c_fh constant_types(); # macro defs
+  print $c_fh "\n";
+
+  # indent is still undef. Until anyone implents indent style rules with it.
+  foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
+                       $types, undef, $ARGS{BREAKOUT_AT}, @{$ARGS{NAMES}})) {
+    print $c_fh $_, "\n"; # C constant subs
+  }
+  print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
+                            $ARGS{C_SUBNAME});
+
+  close $c_fh or warn "Error closing $ARGS{C_FILE}: $!";
+  close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
+}
+
 1;
 __END__