X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c6b36e452c0b3d11d99efcc36f6a80394940f0c3..def5f8a53f98ed8396459ef94f852412f5f3012c:/regen/feature.pl

diff --git a/regen/feature.pl b/regen/feature.pl
index f4e8d1e..0a23271 100755
--- a/regen/feature.pl
+++ b/regen/feature.pl
@@ -5,7 +5,8 @@
 #    lib/feature.pm
 #    feature.h
 #
-# from information hardcoded into this script.
+# from information hardcoded into this script and from two #defines
+# in perl.h.
 #
 # This script is normally invoked from regen.pl.
 
@@ -25,14 +26,11 @@ my %feature = (
     state           => 'state',
     switch          => 'switch',
     evalbytes       => 'evalbytes',
+    array_base      => 'arybase',
     current_sub     => '__SUB__',
     unicode_eval    => 'unieval',
     unicode_strings => 'unicode',
-);
-
-# These work backwards--the presence of the hint elem disables the feature:
-my %default_feature = (
-    array_base      => 'noarybase',
+    fc              => 'fc',
 );
 
 # NOTE: If a feature is ever enabled in a non-contiguous range of Perl
@@ -40,7 +38,7 @@ my %default_feature = (
 #       be changed to account.
 
 my %feature_bundle = (
-     default =>	[keys %default_feature],
+     default =>	[qw(array_base)],
     "5.9.5"  =>	[qw(say state switch array_base)],
     "5.10"   =>	[qw(say state switch array_base)],
     "5.11"   =>	[qw(say state switch unicode_strings array_base)],
@@ -48,9 +46,9 @@ my %feature_bundle = (
     "5.13"   =>	[qw(say state switch unicode_strings array_base)],
     "5.14"   =>	[qw(say state switch unicode_strings array_base)],
     "5.15"   =>	[qw(say state switch unicode_strings unicode_eval
-		    evalbytes current_sub)],
+		    evalbytes current_sub fc)],
     "5.16"   =>	[qw(say state switch unicode_strings unicode_eval
-		    evalbytes current_sub)],
+		    evalbytes current_sub fc)],
 );
 
 
@@ -87,12 +85,17 @@ for my $bund (
 
 my $HintShift;
 my $HintMask;
+my $Uni8Bit;
 
 open "perl.h", "perl.h" or die "$0 cannot open perl.h: $!";
-perlh: {
-    while (readline "perl.h") {
-	next unless /#define\s+HINT_FEATURE_MASK/;
-	/(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n ";
+while (readline "perl.h") {
+    next unless /#\s*define\s+(HINT_FEATURE_MASK|HINT_UNI_8_BIT)/;
+    my $is_u8b = $1 =~ 8;
+    /(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n ";
+    if ($is_u8b) {
+	$Uni8Bit = $1;
+    }
+    else {
 	my $hex = $HintMask = $1;
 	my $bits = sprintf "%b", oct $1;
 	$bits =~ /^0*1+(0*)\z/
@@ -103,10 +106,12 @@ perlh: {
 	$bits =~ /1{$bits_needed}/
 	    or die "Not enough bits (need $bits_needed)"
 		 . " in $bits (binary for $hex):\n\n$_\n";
-	last perlh;
     }
-    die "No HINT_FEATURE_MASK defined in perl.h";
+    if ($Uni8Bit && $HintMask) { last }
 }
+die "No HINT_FEATURE_MASK defined in perl.h" unless $HintMask;
+die "No HINT_UNI_8_BIT defined in perl.h"    unless $Uni8Bit;
+
 close "perl.h";
 
 my @HintedBundles =
@@ -139,7 +144,7 @@ sub longest {
     $long;
 }
 
-print $pm "my %feature = (\n";
+print $pm "our %feature = (\n";
 my $width = length longest keys %feature;
 for(sort { length $a <=> length $b } keys %feature) {
     print $pm "    $_" . " "x($width-length)
@@ -147,14 +152,6 @@ for(sort { length $a <=> length $b } keys %feature) {
 }
 print $pm ");\n\n";
 
-print $pm "my %default_feature = (\n";
-$width = length longest keys %default_feature;
-for(sort { length $a <=> length $b } keys %default_feature) {
-    print $pm "    $_" . " "x($width-length)
-	. " => 'feature_$default_feature{$_}',\n";
-}
-print $pm ");\n\n";
-
 print $pm "our %feature_bundle = (\n";
 $width = length longest values %UniqueBundles;
 for( sort { $UniqueBundles{$a} cmp $UniqueBundles{$b} }
@@ -172,9 +169,14 @@ for (sort keys %Aliases) {
 
 print $pm <<EOPM;
 
-my \$hint_shift   = $HintShift;
-my \$hint_mask    = $HintMask;
-my \@hint_bundles = qw( @HintedBundles );
+our \$hint_shift   = $HintShift;
+our \$hint_mask    = $HintMask;
+our \@hint_bundles = qw( @HintedBundles );
+
+# This gets set (for now) in \$^H as well as in %^H,
+# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
+# See HINT_UNI_8_BIT in perl.h.
+our \$hint_uni8bit = $Uni8Bit;
 EOPM
 
 
@@ -206,7 +208,6 @@ read_only_bottom_close_and_rename($pm);
 ###########################################################################
 # Generate feature.h
 
-my $first_bit = sprintf "0x%08x", 1 << $HintShift;
 print $h <<EOH;
 
 #if defined(PERL_CORE) || defined (PERL_EXT)
@@ -221,23 +222,33 @@ for (@HintedBundles) {
     print $h "#define FEATURE_BUNDLE_$key	", $count++, "\n";
 }
 
-print $h <<EOH;
+print $h <<'EOH';
 #define FEATURE_BUNDLE_CUSTOM	(HINT_FEATURE_MASK >> HINT_FEATURE_SHIFT)
 
-#define CURRENT_HINTS \\
+#define CURRENT_HINTS \
     (PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints)
-#define CURRENT_FEATURE_BUNDLE	(CURRENT_HINTS >> HINT_FEATURE_SHIFT)
-
+#define CURRENT_FEATURE_BUNDLE \
+    ((CURRENT_HINTS & HINT_FEATURE_MASK) >> HINT_FEATURE_SHIFT)
+
+#define FEATURE_IS_ENABLED(name)				        \
+	((CURRENT_HINTS							 \
+	   & HINT_LOCALIZE_HH)						  \
+	    && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
+/* The longest string we pass in.  */
 EOH
 
+my $longest_internal_feature_name = longest values %feature;
+print $h <<EOL;
+#define MAX_FEATURE_LEN (sizeof("$longest_internal_feature_name")-1)
+
+EOL
+
 for (
-    sort { length $a <=> length $b } keys %feature, keys %default_feature
+    sort { length $a <=> length $b } keys %feature
 ) {
     my($first,$last) =
 	map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}};
-    my $default = '';
-    my $name = $feature{$_}               # skip "no"
-	    || ($default = '_d', substr $default_feature{$_}, 2);
+    my $name = $feature{$_};
     my $NAME = uc $name;
     if ($last && $first eq 'DEFAULT') { #  ‘>= DEFAULT’ warns
 	print $h <<EOI;
@@ -245,7 +256,7 @@ for (
     ( \\
 	CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last \\
      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
-	 FEATURE_IS_ENABLED$default("$name")) \\
+	 FEATURE_IS_ENABLED("$name")) \\
     )
 
 EOI
@@ -257,7 +268,7 @@ EOI
 	(CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_$first && \\
 	 CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last) \\
      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
-	 FEATURE_IS_ENABLED$default("$name")) \\
+	 FEATURE_IS_ENABLED("$name")) \\
     )
 
 EOH3
@@ -268,7 +279,7 @@ EOH3
     ( \\
 	CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_$first \\
      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
-	 FEATURE_IS_ENABLED$default("$name")) \\
+	 FEATURE_IS_ENABLED("$name")) \\
     )
 
 EOH4
@@ -278,8 +289,39 @@ EOH4
 print $h <<EOH;
 
 #endif /* PERL_CORE or PERL_EXT */
+
+#ifdef PERL_IN_OP_C
+PERL_STATIC_INLINE void
+S_enable_feature_bundle(pTHX_ SV *ver)
+{
+    SV *comp_ver = sv_newmortal();
+    PL_hints = (PL_hints &~ HINT_FEATURE_MASK)
+	     | (
 EOH
 
+for (reverse @HintedBundles[1..$#HintedBundles]) { # skip default
+    my $numver = $_;
+    if ($numver eq '5.10') { $numver = '5.009005' } # special case
+    else		   { $numver =~ s/\./.0/  } # 5.11 => 5.011
+    (my $macrover = $_) =~ y/.//d;
+    print $h <<"    EOK";
+		  (sv_setnv(comp_ver, $numver),
+		   vcmp(ver, upg_version(comp_ver, FALSE)) >= 0)
+			? FEATURE_BUNDLE_$macrover :
+    EOK
+}
+
+print $h <<EOJ;
+			  FEATURE_BUNDLE_DEFAULT
+	       ) << HINT_FEATURE_SHIFT;
+    /* special case */
+    assert(PL_curcop == &PL_compiling);
+    if (FEATURE_UNICODE_IS_ENABLED) PL_hints |=  HINT_UNI_8_BIT;
+    else			    PL_hints &= ~HINT_UNI_8_BIT;
+}
+#endif /* PERL_IN_OP_C */
+EOJ
+
 read_only_bottom_close_and_rename($h);
 
 
@@ -289,15 +331,10 @@ read_only_bottom_close_and_rename($h);
 __END__
 package feature;
 
-our $VERSION = '1.25';
+our $VERSION = '1.26';
 
 FEATURES
 
-# This gets set (for now) in $^H as well as in %^H,
-# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
-# See HINT_UNI_8_BIT in perl.h.
-our $hint_uni8bit = 0x00000800;
-
 # TODO:
 # - think about versioned features (use feature switch => 2)
 
@@ -382,7 +419,7 @@ This feature is available starting with Perl 5.10.
 C<use feature 'switch'> tells the compiler to enable the Perl 6
 given/when construct.
 
-See L<perlsyn/"Switch statements"> for details.
+See L<perlsyn/"Switch Statements"> for details.
 
 This feature is available starting with Perl 5.10.
 
@@ -469,6 +506,15 @@ This feature is available under this name starting with Perl 5.16.  In
 previous versions, it was simply on all the time, and this pragma knew
 nothing about it.
 
+=head2 The 'fc' feature
+
+C<use feature 'fc'> tells the compiler to enable the C<fc> function,
+which implements Unicode casefolding.
+
+See L<perlfunc/fc> for details.
+
+This feature is available from Perl 5.16 onwards.
+
 =head1 FEATURE BUNDLES
 
 It's possible to load multiple features together, using
@@ -541,15 +587,24 @@ sub current_bundle {
     return $feature_bundle{@hint_bundles[$bundle_number >> $hint_shift]};
 }
 
+sub normalise_hints {
+    # Delete any keys that may be left over from last time.
+    delete @^H{ values(%feature) };
+    $^H |= $hint_mask;
+    for (@{+shift}) {
+	$^H{$feature{$_}} = 1;
+	$^H |= $hint_uni8bit if $_ eq 'unicode_strings';
+    }
+}
+
 sub import {
     my $class = shift;
     if (@_ == 0) {
         croak("No features specified");
     }
     if (my $features = current_bundle) {
-	# Features are enabled implicitly via bundle hints
-	unshift @_, @$features;
-	$^H |= $hint_mask;
+	# Features are enabled implicitly via bundle hints.
+	normalise_hints $features;
     }
     while (@_) {
         my $name = shift(@_);
@@ -565,10 +620,7 @@ sub import {
             next;
         }
         if (!exists $feature{$name}) {
-	  if (!exists $default_feature{$name}) {
             unknown_feature($name);
-	  }
-	  delete $^H{$default_feature{$name}}; next;
         }
         $^H{$feature{$name}} = 1;
         $^H |= $hint_uni8bit if $name eq 'unicode_strings';
@@ -579,17 +631,14 @@ sub unimport {
     my $class = shift;
 
     if (my $features = current_bundle) {
-	# Features are enabled implicitly via bundle hints
-	# Pass them to import() to put them in a form we can handle.
-	import(undef, @$features);
-	$^H |= $hint_mask;
+	# Features are enabled implicitly via bundle hints.
+	normalise_hints $features;
     }
 
     # A bare C<no feature> should disable *all* features
     if (!@_) {
         delete @^H{ values(%feature) };
         $^H &= ~ $hint_uni8bit;
-	@^H{ values(%default_feature) } = (1) x keys %default_feature;
         return;
     }
 
@@ -607,10 +656,7 @@ sub unimport {
             next;
         }
         if (!exists($feature{$name})) {
-	  if (!exists $default_feature{$name}) {
             unknown_feature($name);
-	  }
-	  $^H{$default_feature{$name}} = 1; next;
         }
         else {
             delete $^H{$feature{$name}};