# 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.
###########################################################################
# Hand-editable data
-# (feature name) => (internal name, used in %^H)
+# (feature name) => (internal name, used in %^H and macro names)
my %feature = (
say => 'say',
state => 'state',
switch => 'switch',
evalbytes => 'evalbytes',
+ array_base => 'arybase',
current_sub => '__SUB__',
+ lexical_subs => 'lexsubs',
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
# versions, any code below that uses %BundleRanges will have to
# be changed to account.
+# 5.odd implies the next 5.even, but an explicit 5.even can override it.
my %feature_bundle = (
- default => [keys %default_feature],
+ all => [ keys %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)],
- "5.12" => [qw(say state switch unicode_strings array_base)],
"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)],
- "5.16" => [qw(say state switch unicode_strings unicode_eval
- evalbytes current_sub)],
+ evalbytes current_sub fc)],
+ "5.17" => [qw(say state switch unicode_strings unicode_eval
+ evalbytes current_sub fc)],
);
+my @experimental = qw( lexical_subs );
+
###########################################################################
# More data generated from the above
+for (keys %feature_bundle) {
+ next unless /^5\.(\d*[13579])\z/;
+ $feature_bundle{"5.".($1+1)} ||= $feature_bundle{$_};
+}
+
my %UniqueBundles; # "say state switch" => 5.10
my %Aliases; # 5.12 => 5.11
for( sort keys %feature_bundle ) {
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/
length sprintf "%b", scalar keys %UniqueBundles;
$bits =~ /1{$bits_needed}/
or die "Not enough bits (need $bits_needed)"
- . " in $bits (binary for $hex):\n\n$_\n";
- last perlh;
+ . " in $bits (binary for $hex):\n\n$_\n ";
}
- 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 =
$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) {
+for(sort { length $a <=> length $b || $a cmp $b } keys %feature) {
print $pm " $_" . " "x($width-length)
. " => 'feature_$feature{$_}',\n";
}
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} }
qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n';
};
+print $pm "my \%experimental = (\n";
+print $pm " $_ => 1,\n", for @experimental;
+print $pm ");\n";
+
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
###########################################################################
# Generate feature.h
-my $first_bit = sprintf "0x%08x", 1 << $HintShift;
print $h <<EOH;
#if defined(PERL_CORE) || defined (PERL_EXT)
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)
+
+/* Avoid using ... && Perl_feature_is_enabled(...) as that triggers a bug in
+ the HP-UX cc on PA-RISC */
+#define FEATURE_IS_ENABLED(name) \
+ ((CURRENT_HINTS \
+ & HINT_LOCALIZE_HH) \
+ ? Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)) : FALSE)
+/* 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 || $a cmp $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) {
+ if ($last && $first eq 'DEFAULT') { # ‘>= DEFAULT’ warns
+ print $h <<EOI;
+#define FEATURE_$NAME\_IS_ENABLED \\
+ ( \\
+ CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last \\
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
+ FEATURE_IS_ENABLED("$name")) \\
+ )
+
+EOI
+ }
+ elsif ($last) {
print $h <<EOH3;
#define FEATURE_$NAME\_IS_ENABLED \\
( \\
(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
}
- else {
+ elsif ($first) {
print $h <<EOH4;
#define FEATURE_$NAME\_IS_ENABLED \\
( \\
CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_$first \\
|| (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
- FEATURE_IS_ENABLED$default("$name")) \\
+ FEATURE_IS_ENABLED("$name")) \\
)
EOH4
}
+ else {
+ print $h <<EOH5;
+#define FEATURE_$NAME\_IS_ENABLED \\
+ ( \\
+ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
+ FEATURE_IS_ENABLED("$name") \\
+ )
+
+EOH5
+ }
}
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);
__END__
package feature;
-our $VERSION = '1.25';
+our $VERSION = '1.31';
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)
=head2 Lexical effect
Like other pragmas (C<use strict>, for example), features have a lexical
-effect. C<use feature qw(foo)> will only make the feature "foo" available
+effect. C<use feature qw(foo)> will only make the feature "foo" available
from that point to the end of the enclosing block.
{
}
say "Yet it is here.";
-C<no feature> with no features specified will turn off all features.
+C<no feature> with no features specified will reset to the default group. To
+disable I<all> features (an unusual request!) use C<no feature ':all'>.
=head1 AVAILABLE FEATURES
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.
in all string operations executed within its scope (unless they are also
within the scope of either C<use locale> or C<use bytes>). The same applies
to all regular expressions compiled within the scope, even if executed outside
-it.
+it. It does not change the internal representation of strings, but only how
+they are interpreted.
C<no feature 'unicode_strings'> tells the compiler to use the traditional
Perl semantics wherein the native character set semantics is used unless it is
potentially using Unicode in your program, the
C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
-This feature is available starting with Perl 5.12, but was not fully
-implemented until Perl 5.14.
+This feature is available starting with Perl 5.12; was almost fully
+implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>.
=head2 The 'unicode_eval' and 'evalbytes' features
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.
+
+=head2 The 'lexical_subs' feature
+
+B<WARNING>: This feature is still experimental and the implementation may
+change in future versions of Perl. For this reason, F<feature.pm> will
+warn when you enable the feature, unless you have explicitly disabled the
+warning:
+
+ no warnings "experimental::lexical_subs";
+
+This enables declaration of subroutines via C<my sub foo>, C<state sub foo>
+and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details.
+
+This feature is available from Perl 5.18 onwards.
+
=head1 FEATURE BUNDLES
It's possible to load multiple features together, using
will do an implicit
- no feature;
+ no feature ':all';
use feature ':5.10';
and so on. Note how the trailing sub-version
=cut
-sub current_bundle {
- my $bundle_number = $^H & $hint_mask;
- return if $bundle_number == $hint_mask;
- return $feature_bundle{@hint_bundles[$bundle_number >> $hint_shift]};
-}
-
sub import {
my $class = shift;
- if (@_ == 0) {
+
+ if (!@_) {
croak("No features specified");
}
- if (my $features = current_bundle) {
- # Features are enabled implicitly via bundle hints
- unshift @_, @$features;
- $^H |= $hint_mask;
- }
- while (@_) {
- my $name = shift(@_);
- if (substr($name, 0, 1) eq ":") {
- my $v = substr($name, 1);
- if (!exists $feature_bundle{$v}) {
- $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
- if (!exists $feature_bundle{$v}) {
- unknown_feature_bundle(substr($name, 1));
- }
- }
- unshift @_, @{$feature_bundle{$v}};
- 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';
- }
+
+ __common(1, @_);
}
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;
- }
-
- # A bare C<no feature> should disable *all* features
+ # A bare C<no feature> should reset to the default bundle
if (!@_) {
- delete @^H{ values(%feature) };
- $^H &= ~ $hint_uni8bit;
- @^H{ values(%default_feature) } = (1) x keys %default_feature;
- return;
+ $^H &= ~($hint_uni8bit|$hint_mask);
+ return;
}
+ __common(0, @_);
+}
+
+
+sub __common {
+ my $import = shift;
+ my $bundle_number = $^H & $hint_mask;
+ my $features = $bundle_number != $hint_mask
+ && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
+ if ($features) {
+ # Features are enabled implicitly via bundle hints.
+ # Delete any keys that may be left over from last time.
+ delete @^H{ values(%feature) };
+ $^H |= $hint_mask;
+ for (@$features) {
+ $^H{$feature{$_}} = 1;
+ $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
+ }
+ }
while (@_) {
my $name = shift;
if (substr($name, 0, 1) eq ":") {
unshift @_, @{$feature_bundle{$v}};
next;
}
- if (!exists($feature{$name})) {
- if (!exists $default_feature{$name}) {
+ if (!exists $feature{$name}) {
unknown_feature($name);
- }
- $^H{$default_feature{$name}} = 1; next;
}
- else {
+ if ($import) {
+ $^H{$feature{$name}} = 1;
+ $^H |= $hint_uni8bit if $name eq 'unicode_strings';
+ if ($experimental{$name}) {
+ require warnings;
+ warnings::warnif("experimental::$name",
+ "The $name feature is experimental");
+ }
+ } else {
delete $^H{$feature{$name}};
$^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
}
https://perl5.git.perl.org / perl5.git / blobdiff