This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
in INSTALL, make clear -DDEBUGGING is much slower
[perl5.git] / regen / feature.pl
diff --git a/regen/feature.pl b/regen/feature.pl
index 32d7123..0a23271 100755 (executable)
--- a/regen/feature.pl
+++ b/regen/feature.pl
@@ -5,7 +5,8 @@
 #    lib/feature.pm
 #    feature.h
 #
 #    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.
 
 #
 # This script is normally invoked from regen.pl.
 
@@ -29,6 +30,7 @@ my %feature = (
     current_sub     => '__SUB__',
     unicode_eval    => 'unieval',
     unicode_strings => 'unicode',
     current_sub     => '__SUB__',
     unicode_eval    => 'unieval',
     unicode_strings => 'unicode',
+    fc              => 'fc',
 );
 
 # NOTE: If a feature is ever enabled in a non-contiguous range of Perl
 );
 
 # NOTE: If a feature is ever enabled in a non-contiguous range of Perl
@@ -44,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
     "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
     "5.16"   =>        [qw(say state switch unicode_strings unicode_eval
-                   evalbytes current_sub)],
+                   evalbytes current_sub fc)],
 );
 
 
 );
 
 
@@ -83,12 +85,17 @@ for my $bund (
 
 my $HintShift;
 my $HintMask;
 
 my $HintShift;
 my $HintMask;
+my $Uni8Bit;
 
 open "perl.h", "perl.h" or die "$0 cannot open perl.h: $!";
 
 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/
        my $hex = $HintMask = $1;
        my $bits = sprintf "%b", oct $1;
        $bits =~ /^0*1+(0*)\z/
@@ -99,10 +106,12 @@ perlh: {
        $bits =~ /1{$bits_needed}/
            or die "Not enough bits (need $bits_needed)"
                 . " in $bits (binary for $hex):\n\n$_\n";
        $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 =
 close "perl.h";
 
 my @HintedBundles =
@@ -135,7 +144,7 @@ sub longest {
     $long;
 }
 
     $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)
 my $width = length longest keys %feature;
 for(sort { length $a <=> length $b } keys %feature) {
     print $pm "    $_" . " "x($width-length)
@@ -160,9 +169,14 @@ for (sort keys %Aliases) {
 
 print $pm <<EOPM;
 
 
 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
 
 
 EOPM
 
 
@@ -194,7 +208,6 @@ read_only_bottom_close_and_rename($pm);
 ###########################################################################
 # Generate feature.h
 
 ###########################################################################
 # Generate feature.h
 
-my $first_bit = sprintf "0x%08x", 1 << $HintShift;
 print $h <<EOH;
 
 #if defined(PERL_CORE) || defined (PERL_EXT)
 print $h <<EOH;
 
 #if defined(PERL_CORE) || defined (PERL_EXT)
@@ -214,17 +227,22 @@ print $h <<'EOH';
 
 #define CURRENT_HINTS \
     (PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_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)                                       \
 
 #define FEATURE_IS_ENABLED(name)                                       \
-       (((PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints) \
+       ((CURRENT_HINTS                                                  \
           & HINT_LOCALIZE_HH)                                            \
            && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 /* The longest string we pass in.  */
           & HINT_LOCALIZE_HH)                                            \
            && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 /* The longest string we pass in.  */
-#define MAX_FEATURE_LEN (sizeof("unicode_strings")-1)
-
 EOH
 
 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
 ) {
 for (
     sort { length $a <=> length $b } keys %feature
 ) {
@@ -271,8 +289,39 @@ EOH4
 print $h <<EOH;
 
 #endif /* PERL_CORE or PERL_EXT */
 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
 
 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);
 
 
 read_only_bottom_close_and_rename($h);
 
 
@@ -282,15 +331,10 @@ read_only_bottom_close_and_rename($h);
 __END__
 package feature;
 
 __END__
 package feature;
 
-our $VERSION = '1.25';
+our $VERSION = '1.26';
 
 FEATURES
 
 
 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)
 
 # TODO:
 # - think about versioned features (use feature switch => 2)
 
@@ -375,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.
 
 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.
 
 
 This feature is available starting with Perl 5.10.
 
@@ -462,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.
 
 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
 =head1 FEATURE BUNDLES
 
 It's possible to load multiple features together, using
@@ -534,15 +587,24 @@ sub current_bundle {
     return $feature_bundle{@hint_bundles[$bundle_number >> $hint_shift]};
 }
 
     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) {
 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(@_);
     }
     while (@_) {
         my $name = shift(@_);
@@ -569,10 +631,8 @@ sub unimport {
     my $class = shift;
 
     if (my $features = current_bundle) {
     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
     }
 
     # A bare C<no feature> should disable *all* features
Unnamed repository; edit this file 'description' to name the repository.