To \X{221E} and beyond in ExtUtils::Constant

Message-ID: <20020324225006.GB410@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@15482

2 files changed, 346 insertions, 69 deletions

diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm
index 8e6bf24e70..1268ce02ba 100644
--- a/lib/ExtUtils/Constant.pm
+++ b/lib/ExtUtils/Constant.pm
@@ -1,6 +1,6 @@
 package ExtUtils::Constant;
 use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
-$VERSION = '0.11';
+$VERSION = '0.12';
 
 =head1 NAME
 
@@ -110,7 +110,10 @@ $Text::Wrap::columns = 80;
 
 @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 
+# '' is used as a flag to indicate non-ascii macro names, and hence the need
+# to pass in the utf8 on/off flag.
 %XS_Constant = (
+		''    => '',
 		IV    => 'PUSHi(iv)',
 		UV    => 'PUSHu((UV)iv)',
 		NV    => 'PUSHn(nv)',
@@ -137,8 +140,9 @@ $Text::Wrap::columns = 80;
 
 =item C_stringify NAME
 
-A function which returns a correctly \ escaped version of the string passed
-suitable for C's "" or ''.  It will also be valid as a perl "" string.
+A function which returns a 7 bit ASCII correctly \ escaped version of the
+string passed suitable for C's "" or ''. It will die if passed Unicode
+characters.
 
 =cut
 
@@ -146,6 +150,7 @@ suitable for C's "" or ''.  It will also be valid as a perl "" string.
 sub C_stringify {
   local $_ = shift;
   return unless defined $_;
+  confess "Wide character in '$_' intended as a C identifier" if tr/\0-\377//c;
   s/\\/\\\\/g;
   s/([\"\'])/\\$1/g;	# Grr. fix perl mode.
   s/\n/\\n/g;		# Ensure newlines don't end up in octal
@@ -153,8 +158,40 @@ sub C_stringify {
   s/\t/\\t/g;
   s/\f/\\f/g;
   s/\a/\\a/g;
+  s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
   unless ($] < 5.006) {
-    # This will elict a warning on 5.005_03 about [: :] being reserved unless
+    # This will elicit 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;
+  }
+  $_;
+}
+
+=item perl_stringify NAME
+
+A function which returns a 7 bit ASCII correctly \ escaped version of the
+string passed suitable for a perl "" string.
+
+=cut
+
+# Hopefully make a happy perl identifier.
+sub perl_stringify {
+  local $_ = shift;
+  return unless defined $_;
+  s/\\/\\\\/g;
+  s/([\"\'])/\\$1/g;	# Grr. fix perl mode.
+  s/\n/\\n/g;		# Ensure newlines don't end up in octal
+  s/\r/\\r/g;
+  s/\t/\\t/g;
+  s/\f/\\f/g;
+  s/\a/\\a/g;
+  s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
+  unless ($] < 5.006) {
+    # This will elicit a warning on 5.005_03 about [: :] being reserved unless
     # I cheat
     my $cheat = '([[:^print:]])';
     s/$cheat/sprintf "\\%03o", ord $1/ge;
@@ -178,6 +215,7 @@ sub constant_types () {
   push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++;
   push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++;
   foreach (sort keys %XS_Constant) {
+    next if $_ eq '';
     push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++;
   }
   push @lines, << 'EOT';
@@ -243,7 +281,7 @@ sub memEQ_clause {
 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<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 C code to proceed and follow the assignment. I<PRE> will be at the start
 of a block, so variables may be defined in it.
 
 =cut
@@ -265,7 +303,8 @@ sub assign {
     $close = "$indent}\n";
     $indent .= "  ";
   }
-  die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
+  confess "undef \$type" unless defined $type;
+  confess "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
   my $typeset = $XS_TypeSet{$type};
   if (ref $typeset) {
     die "Type $type is aggregate, but only single value given"
@@ -291,31 +330,34 @@ sub assign {
 
 =item return_clause
 
-return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
+return_clause ITEM, INDENT
 
-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
-pointer and length) then I<VALUE> should be a reference to an array of
-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
-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.
+A function to return a suitable C<#ifdef> clause. I<ITEM> is a hashref
+(as passed to C<C_constant> and C<match_clause>. I<INDENT> is the number
+of spaces to indent, defaulting to 6.
 
 =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, $pre, $post,
-      $def_pre, $def_post) = @_;
+  my ($item, $indent) = @_;
+
+  my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post, $type)
+    = @$item{qw (name value macro default pre post def_pre def_post type)};
+  $value = $name unless defined $value;
+  $macro = $name unless defined $macro;
+
   $macro = $value unless defined $macro;
   $indent = ' ' x ($indent || 6);
+  unless ($type) {
+    # use Data::Dumper; print STDERR Dumper ($item);
+    confess "undef \$type";
+  }
 
   my $clause;
 
@@ -351,7 +393,51 @@ sub return_clause ($$$$$$$$$) {
       $clause .= "#endif\n";
     }
   }
-  return $clause
+  return $clause;
+}
+
+=pod
+
+XXX document me
+
+=cut
+
+sub match_clause {
+  # $offset defined if we have checked an offset.
+  my ($item, $offset, $indent) = @_;
+  $indent = ' ' x ($indent || 4);
+  my $body = '';
+  my ($no, $yes, $either, $name, $inner_indent);
+  if (ref $item eq 'ARRAY') {
+    ($yes, $no) = @$item;
+    $either = $yes || $no;
+    confess "$item is $either expecting hashref in [0] || [1]"
+      unless ref $either eq 'HASH';
+    $name = $either->{name};
+  } else {
+    confess "$item->{name} has utf8 flag '$item->{utf8}', should be false"
+      if $item->{utf8};
+    $name = $item->{name};
+    $inner_indent = $indent;
+  }
+
+  $body .= memEQ_clause ($name, $offset, length $indent);
+  if ($yes) {
+    $body .= $indent . "  if (utf8) {\n";
+  } elsif ($no) {
+    $body .= $indent . "  if (!utf8) {\n";
+  }
+  if ($either) {
+    $body .= return_clause ($either, 4 + length $indent);
+    if ($yes and $no) {
+      $body .= $indent . "  } else {\n";
+      $body .= return_clause ($no, 4 + length $indent); 
+    }
+    $body .= $indent . "  }";
+  } else {
+    $body .= return_clause ($item, 2 + length $indent);
+  }
+  $body .= $indent . "}\n";
 }
 
 =item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
@@ -378,7 +464,17 @@ sub switch_clause {
     $body = wrap ($leader, $follower, $comment) . "\n";
     $leader = $follower;
   }
-  $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
+  my @safe_names = @names;
+  foreach (@safe_names) {
+    next unless tr/A-Za-z0-9_//c;
+    $_ = '"' . perl_stringify ($_) . '"';
+    # Ensure that the enclosing C comment doesn't end
+    # by turning */  into *" . "/
+    s!\*\/!\*"."/!gs;
+    # gcc -Wall doesn't like finding /* inside a comment
+    s!\/\*!/"."\*!gs;
+  }
+  $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n";
   # Figure out what to switch on.
   # (RMS, Spread of jump table, Position, Hashref)
   my @best = (1e38, ~0);
@@ -422,17 +518,8 @@ sub switch_clause {
     $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";
+      # warn "You are here";
+      $body .= match_clause ($thisone, $offset, 2 + length $indent);
     }
     $body .= $indent . "  break;\n";
   }
@@ -454,6 +541,7 @@ sub params {
     warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
   }
   my $params = {};
+  $params->{''} = 1 if $what->{''};
   $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN};
   $params->{NV} = 1 if $what->{NV};
   $params->{PV} = 1 if $what->{PV} || $what->{PVN};
@@ -487,6 +575,15 @@ sub dump_names {
     my $type;
     if (ref $_) {
       $type = $_->{type} || $default_type;
+      if ($_->{utf8}) {
+        # For simplicity always skip the bytes case, and reconstitute this entry
+        # from its utf8 twin.
+        next if $_->{utf8} eq 'no';
+        # Copy the hashref, as we don't want to mess with the caller's hashref.
+        $_ = {%$_};
+        utf8::decode ($_->{name});
+        delete $_->{utf8};
+      }
     } else {
       $_ = {name=>$_};
       $type = $default_type;
@@ -520,7 +617,7 @@ sub dump_names {
 		   $indent . "               ", join (" ", sort @simple) . ")");
   if (@complex) {
     foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
-      my $name = C_stringify $item->{name};
+      my $name = perl_stringify $item->{name};
       my $line = ",\n$indent            {name=>\"$name\"";
       $line .= ", type=>\"$item->{type}\"" if defined $item->{type};
       foreach my $thing (qw (macro value default pre post def_pre def_post)) {
@@ -528,9 +625,9 @@ sub dump_names {
         if (defined $value) {
           if (ref $value) {
             $line .= ", $thing=>[\""
-              . join ('", "', map {C_stringify $_} @$value) . '"]';
+              . join ('", "', map {perl_stringify $_} @$value) . '"]';
           } else {
-            $line .= ", $thing=>\"" . C_stringify($value) . "\"";
+            $line .= ", $thing=>\"" . perl_stringify($value) . "\"";
           }
         }
       }
@@ -581,7 +678,7 @@ EOT
 
 print constant_types(); # macro defs
 EOT
-  $package = C_stringify($package);
+  $package = perl_stringify($package);
   $result .=
     "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, ";
   # The form of the indent parameter isn't defined. (Yet)
@@ -675,6 +772,16 @@ Rarely needed.
 
 Equivalents of I<pre> and I<post> for the default value.
 
+=item utf8
+
+Generated internally. Is zero or undefined if name is 7 bit ASCII,
+"no" if the name is 8 bit (and so should only match if SvUTF8() is false),
+"yes" if the name is utf8 encoded.
+
+The internals automatically clone any name with characters 128-255 but none
+256+ (ie one that could be either in bytes or utf8) into a second entry
+which is utf8 encoded.
+
 =back
 
 I<PACKAGE> is the name of the package, and is only used in comments inside the
@@ -737,42 +844,71 @@ sub C_constant {
       # Figure out what types we're dealing with, and assign all unknowns to the
       # default type
     }
-    foreach (@items) {
-      my $name;
-      if (ref $_) {
-        my $orig = $_;
+    my @new_items;
+    foreach my $orig (@items) {
+      my ($name, $item);
+      if (ref $orig) {
         # Make a copy which is a normalised version of the ref passed in.
-        $name = $_->{name};
-        my ($type, $macro, $value) = @$_{qw (type macro value)};
+        $name = $orig->{name};
+        my ($type, $macro, $value) = @$orig{qw (type macro value)};
         $type ||= $default_type;
         $what->{$type} = 1;
-        $_ = {name=>$name, type=>$type};
+        $item = {name=>$name, type=>$type};
 
         undef $macro if defined $macro and $macro eq $name;
-        $_->{macro} = $macro if defined $macro;
+        $item->{macro} = $macro if defined $macro;
         undef $value if defined $value and $value eq $name;
-        $_->{value} = $value if defined $value;
+        $item->{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;
+          $item->{$key} = $value if defined $value;
           # warn "$key $value";
         }
       } else {
-        $name = $_;
-        $_ = {name=>$_, type=>$default_type};
+        $name = $orig;
+        $item = {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";
+      warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$item->{type}};
+      if ($name !~ tr/\0-\177//c) {
+        # No characters outside 7 bit ASCII.
+        if (exists $items->{$name}) {
+          die "Multiple definitions for macro $name";
+        }
+        $items->{$name} = $item;
+      } else {
+        # No characters outside 8 bit. This is hardest.
+        if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') {
+          confess "Unexpected ASCII definition for macro $name";
+        }
+        if ($name !~ tr/\0-\377//c) {
+          $item->{utf8} = 'no';
+          $items->{$name}[1] = $item;
+          push @new_items, $item;
+          # Copy item, to create the utf8 variant.
+          $item = {%$item};
+        }
+        # Encode the name as utf8 bytes.
+        utf8::encode($name);
+        if ($items->{$name}[0]) {
+          die "Multiple definitions for macro $name";
+        }
+        $item->{utf8} = 'yes';
+        $item->{name} = $name;
+        $items->{$name}[0] = $item;
+        # We have need for the utf8 flag.
+        $what->{''} = 1;
       }
-      $items->{$name} = $_;
+      push @new_items, $item;
     }
+    @items = @new_items;
+    # use Data::Dumper; print Dumper @items;
   }
   my $params = params ($what);
 
   my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
   $body .= ", STRLEN len" unless defined $namelen;
+  $body .= ", int utf8" if $params->{''};
   $body .= ", IV *iv_return" if $params->{IV};
   $body .= ", NV *nv_return" if $params->{NV};
   $body .= ", const char **pv_return" if $params->{PV};
@@ -800,16 +936,7 @@ sub C_constant {
       next unless $by_length[$i];	# None of this length
       $body .= "  case $i:\n";
       if (@{$by_length[$i]} == 1) {
-        my $thisone = $by_length[$i]->[0];
-        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, $pre, $post, $def_pre, $def_post);
-        $body .= "    }\n";
+        $body .= match_clause ($by_length[$i]->[0]);
       } elsif (@{$by_length[$i]} < $breakout) {
         $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
       } else {
@@ -818,11 +945,13 @@ sub C_constant {
         my $what = {};
         foreach (@{$by_length[$i]}) {
           $what->{$_->{type}} = 1;
+          $what->{''} = 1 if $_->{utf8};
         }
         $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 .= ", utf8" if $params->{''};
         $body .= ", iv_return" if $params->{IV};
         $body .= ", nv_return" if $params->{NV};
         $body .= ", pv_return" if $params->{PV};
@@ -906,6 +1035,14 @@ EOT
     INPUT:
 	SV *		sv;
         const char *	s = SvPV(sv, len);
+EOT
+  if ($params->{''}) {
+  $xs .= << 'EOT';
+    INPUT:
+	int		utf8 = SvUTF8(sv);
+EOT
+  }
+  $xs .= << 'EOT';
     PPCODE:
 EOT
 
@@ -916,6 +1053,7 @@ EOT
 EOT
   }
   $xs .= "	type = $C_subname(aTHX_ s, len";
+  $xs .= ', utf8' if $params->{''};
   $xs .= ', &iv' if $params->{IV};
   $xs .= ', &nv' if $params->{NV};
   $xs .= ', &pv' if $params->{PV};
@@ -938,6 +1076,8 @@ EOT
 EOT
 
   foreach $type (sort keys %XS_Constant) {
+    # '' marks utf8 flag needed.
+    next if $type eq '';
     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
       unless $what->{$type};
     $xs .= "        case PERL_constant_IS$type:\n";
diff --git a/lib/ExtUtils/t/Constant.t b/lib/ExtUtils/t/Constant.t
index 5b6bf56466..d321b207b1 100644
--- a/lib/ExtUtils/t/Constant.t
+++ b/lib/ExtUtils/t/Constant.t
@@ -1,6 +1,6 @@
 #!/usr/bin/perl -w
 
-print "1..27\n";
+print "1..48\n";
 
 BEGIN {
     if( $ENV{PERL_CORE} ) {
@@ -37,10 +37,13 @@ mkdir $dir, 0777 or die "mkdir: $!\n";
 
 my $output = "output";
 
+# For debugging set this to 1.
+my $keep_files = 0;
+
 END {
     use File::Path;
     print "# $dir being removed...\n";
-    rmtree($dir);
+    rmtree($dir) unless $keep_files;
 }
 
 my $package = "ExtTest";
@@ -52,6 +55,13 @@ N => 0, 'NE' => 45, E => 90, SE => 135, S => 180, SW => 225, W => 270, NW => 315
 
 my $parent_rfc1149 =
   'A Standard for the Transmission of IP Datagrams on Avian Carriers';
+# Check that 8 bit and unicode names don't cause problems.
+my $pound = chr 163; # A pound sign. (Currency)
+my $inf = chr 0x221E;
+# Check that we can distiguish the pathological case of a string, and the
+# utf8 representation of that string.
+my $pound_bytes = my $pound_utf8 = $pound . '1';
+utf8::encode ($pound_bytes);
 
 my @names = ("FIVE", {name=>"OK6", type=>"PV",},
              {name=>"OK7", type=>"PVN",
@@ -71,12 +81,45 @@ my @names = ("FIVE", {name=>"OK6", type=>"PV",},
               pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
               	   . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
                    . "SvIVX(temp_sv) = 1149;"},
+             {name=>"perl", type=>"PV",},
 );
 
 push @names, $_ foreach keys %compass;
 
+# Automatically compile the list of all the macro names, and make them
+# exported constants.
 my @names_only = map {(ref $_) ? $_->{name} : $_} @names;
 
+# Exporter::Heavy (currently) isn't able to export these names:
+push @names, ({name=>"*/", type=>"PV", value=>'"CLOSE"', macro=>1},
+              {name=>"/*", type=>"PV", value=>'"OPEN"', macro=>1},
+              {name=>$pound, type=>"PV", value=>'"Sterling"', macro=>1},
+              {name=>$inf, type=>"PV", value=>'"Infinity"', macro=>1},
+              {name=>$pound_utf8, type=>"PV", value=>'"1 Pound"', macro=>1},
+              {name=>$pound_bytes, type=>"PV", value=>'"1 Pound (as bytes)"',
+               macro=>1},
+             );
+
+=pod
+
+The above set of names seems to produce a suitably bad set of compile
+problems on a Unicode naive version of ExtUtils::Constant (ie 0.11):
+
+nick@thinking-cap 15439-32-utf$ PERL_CORE=1 ./perl lib/ExtUtils/t/Constant.t
+1..33
+# perl=/stuff/perl5/15439-32-utf/perl
+# ext-30370 being created...
+Wide character in print at lib/ExtUtils/t/Constant.t line 140.
+ok 1
+ok 2
+# make = 'make'
+ExtTest.xs: In function `constant_1':
+ExtTest.xs:80: warning: multi-character character constant
+ExtTest.xs:80: warning: case value out of range
+ok 3
+
+=cut
+
 my $types = {};
 my $constant_types = constant_types(); # macro defs
 my $C_constant = join "\n",
@@ -98,7 +141,7 @@ print FH <<"EOT";
 #define Undef 1
 #define RFC1149 "$parent_rfc1149"
 #undef NOTDEF
-
+#define perl "rules"
 EOT
 
 while (my ($point, $bearing) = each %compass) {
@@ -149,8 +192,10 @@ $VERSION = '0.01';
 @EXPORT_OK = qw(
 EOT
 
+# Print the names of all our autoloaded constants
 print FH "\t$_\n" foreach (@names_only);
 print FH ");\n";
+# Print the AUTOLOAD subroutine ExtUtils::Constant generated for us
 print FH autoload ($package, $]);
 print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
 close FH or die "close $pm: $!\n";
@@ -164,6 +209,8 @@ print FH "use strict;\n";
 print FH "use $package qw(@names_only);\n";
 print FH <<"EOT";
 
+use utf8;
+
 print "1..1\n";
 if (open OUTPUT, ">$output") {
   print "ok 1\n";
@@ -350,8 +397,98 @@ if ($open eq '/*') {
   print "not ok 22 # \$open='$open'\n";
 }
 EOT
+
+# Do this in 7 bit in case someone is testing with some settings that cause
+# 8 bit files incapable of storing this character.
+my @values
+ = map {"'" . join (",", unpack "U*", $_) . "'"}
+ ($pound, $inf, $pound_bytes, $pound_utf8);
+# Values is a list of strings, such as ('194,163,49', '163,49')
+
+print FH <<'EOT';
+
+# I can see that this child test program might be about to use parts of
+# Test::Builder
+
+my $test = 23;
+my ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"}
+EOT
+
+print FH join ",", @values;
+
+print FH << 'EOT';
+;
+
+foreach (["perl", "rules", "rules"],
+	 ["/*", "OPEN", "OPEN"],
+	 ["*/", "CLOSE", "CLOSE"],
+	 [$pound, 'Sterling', []],
+         [$inf, 'Infinity', []],
+	 [$pound_utf8, '1 Pound', '1 Pound (as bytes)'],
+	 [$pound_bytes, '1 Pound (as bytes)', []],
+        ) {
+  # Flag an expected error with a reference for the expect string.
+  my ($string, $expect, $expect_bytes) = @$_;
+  (my $name = $string) =~ s/([^ -~])/sprintf '\x{%X}', ord $1/ges;
+  print "# \"$name\" => \'$expect\'\n";
+  # Try to force this to be bytes if possible.
+  utf8::downgrade ($string, 1);
+EOT
+
+print FH  "my (\$error, \$got) = ${package}::constant (\$string);\n";
+
+print FH <<'EOT';
+  if ($error or $got ne $expect) {
+    print "not ok $test # error '$error', got '$got'\n";
+  } else {
+    print "ok $test\n";
+  }
+  $test++;
+  print "# Now upgrade '$name' to utf8\n";
+  utf8::upgrade ($string);
+EOT
+
+print FH  "my (\$error, \$got) = ${package}::constant (\$string);\n";
+
+print FH <<'EOT';
+  if ($error or $got ne $expect) {
+    print "not ok $test # error '$error', got '$got'\n";
+  } else {
+    print "ok $test\n";
+  }
+  $test++;
+  if (defined $expect_bytes) {
+    print "# And now with the utf8 byte sequence for name\n";
+    # Try the encoded bytes.
+    utf8::encode ($string);
+EOT
+
+print FH "my (\$error, \$got) = ${package}::constant (\$string);\n";
+
+print FH <<'EOT';
+    if (ref $expect_bytes) {
+      # Error expected.
+      if ($error) {
+        print "ok $test # error='$error' (as expected)\n";
+      } else {
+        print "not ok $test # expected error, got no error and '$got'\n";
+      }
+    } elsif ($got ne $expect_bytes) {
+      print "not ok $test # error '$error', expect '$expect_bytes', got '$got'\n";
+    } else {
+      print "ok $test\n";
+    }
+    $test++;
+  }
+}
+EOT
+
 close FH or die "close $testpl: $!\n";
 
+# This is where the test numbers carry on after the test number above are
+# relayed
+my $test = 44;
+
 ################ Makefile.PL
 # We really need a Makefile.PL because make test for a no dynamic linking perl
 # will run Makefile.PL again as part of the "make perl" target.
@@ -446,8 +583,6 @@ if (open OUTPUT, "<$output") {
   print "# Open <$output failed: $!\n";
 }
 
-my $test = 23;
-
 if ($?) {
   print "not ok $test # $maketest failed: $?\n";
   print "# $_" foreach @makeout;
@@ -504,8 +639,10 @@ if ($?) {
 }
 $test++;
 
-foreach (@files) {
-  unlink $_ or warn "unlink $_: $!";
+unless ($keep_files) {
+  foreach (@files) {
+    unlink $_ or warn "unlink $_: $!";
+  }
 }
 
 my $fail;