Merge a2e3917 into f77b2d0

MANIFEST

@@ -5667,6 +5667,7 @@ t/lib/Devel/nodb.pm		Module for t/run/switchd.t
 t/lib/Devel/switchd.pm		Module for t/run/switchd.t
 t/lib/Devel/switchd_empty.pm	Module for t/run/switchd.t
 t/lib/Devel/switchd_goto.pm	Module for t/run/switchd.t
+t/lib/feature/api		Test API for checking features enabled/disabled
 t/lib/feature/bareword_filehandles	Tests for enabling/disabling bareword_filehandles feature
 t/lib/feature/bits		Tests for feature bit handling
 t/lib/feature/bundle		Tests for feature bundles

lib/feature.pm

@@ -562,6 +562,76 @@ also does the equivalent of C<use strict>; see L<perlfunc/use> for details.
 
 =back
 
+=head1 CHECKING FEATURES
+
+C<feature> provides some simple APIs to check which features are enabled.
+
+These functions cannot be imported and must be called by their fully
+qualified names.  If you don't otherwise need to set a feature you will
+need to ensure C<feature> is loaded with:
+
+  use feature ();
+
+=over
+
+=item feature_enabled($feature)
+
+=item feature_enabled($feature, $depth)
+
+  package MyStandardEnforcer;
+  use feature ();
+  use Carp "croak";
+  sub import {
+    croak "disable indirect!" if feature::feature_enabled("indirect");
+  }
+
+Test whether a named feature is enabled at a given level in the call
+stack, returning a true value if it is.  C<$depth> defaults to 1,
+which checks the scope that called the scope calling
+feature::feature_enabled().
+
+croaks for an unknown feature name.
+
+=item features_enabled()
+
+=item features_enabled($depth)
+
+  package ReportEnabledFeatures;
+  use feature "say";
+  sub import {
+    say STDERR join " ", feature::features_enabled();
+  }
+
+Returns a list of the features enabled at a given level in the call
+stack.  C<$depth> defaults to 1, which checks the scope that called
+the scope calling feature::features_enabled().
+
+=item feature_bundle()
+
+=item feature_bundle($depth)
+
+Returns the feature bundle, if any, selected at a given level in the
+call stack.  C<$depth> defaults to 1, which checks the scope that called
+the scope calling feature::feature_bundle().
+
+Returns an undefined value if no feature bundle is selected in the
+scope.
+
+The bundle name returned will be for the earliest bundle matching the
+selected bundle, so:
+
+  use feature ();
+  use v5.12;
+  BEGIN { print feature::feature_bundle(0); }
+
+will print C<5.11>.
+
+This returns internal state, at this point C<use v5.12;> sets the
+feature bundle, but C< use feature ":5.12"; > does not set the feature
+bundle.  This may change in a future release of perl.
+
+=back
+
 =cut
 
 sub import {
@@ -651,6 +721,67 @@ sub croak {
     Carp::croak(@_);
 }
 
+sub features_enabled {
+    my ($depth) = @_;
+
+    $depth //= 1;
+    my @frame = caller($depth+1)
+      or return;
+    my ($hints, $hinthash) = @frame[8, 10];
+
+    my $bundle_number = $hints & $hint_mask;
+    if ($bundle_number != $hint_mask) {
+        return $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}->@*;
+    }
+    else {
+        my @features;
+        for my $feature (sort keys %feature) {
+            if ($hinthash->{$feature{$feature}}) {
+                push @features, $feature;
+            }
+        }
+        return @features;
+    }
+}
+
+sub feature_enabled {
+    my ($feature, $depth) = @_;
+
+    $depth //= 1;
+    my @frame = caller($depth+1)
+      or return;
+    my ($hints, $hinthash) = @frame[8, 10];
+
+    my $hint_feature = $feature{$feature}
+      or croak "Unknown feature $feature";
+    my $bundle_number = $hints & $hint_mask;
+    if ($bundle_number != $hint_mask) {
+        my $bundle = $hint_bundles[$bundle_number >> $hint_shift];
+        for my $bundle_feature ($feature_bundle{$bundle}->@*) {
+            return 1 if $bundle_feature eq $feature;
+        }
+        return 0;
+    }
+    else {
+        return $hinthash->{$hint_feature} // 0;
+    }
+}
+
+sub feature_bundle {
+    my $depth = shift;
+
+    $depth //= 1;
+    my @frame = caller($depth+1)
+      or return;
+    my $bundle_number = $frame[8] & $hint_mask;
+    if ($bundle_number != $hint_mask) {
+        return $hint_bundles[$bundle_number >> $hint_shift];
+    }
+    else {
+        return undef;
+    }
+}
+
 1;
 
 # ex: set ro:

regen/feature.pl

@@ -905,6 +905,76 @@ =head1 IMPLICIT LOADING
 
 =back
 
+=head1 CHECKING FEATURES
+
+C<feature> provides some simple APIs to check which features are enabled.
+
+These functions cannot be imported and must be called by their fully
+qualified names.  If you don't otherwise need to set a feature you will
+need to ensure C<feature> is loaded with:
+
+  use feature ();
+
+=over
+
+=item feature_enabled($feature)
+
+=item feature_enabled($feature, $depth)
+
+  package MyStandardEnforcer;
+  use feature ();
+  use Carp "croak";
+  sub import {
+    croak "disable indirect!" if feature::feature_enabled("indirect");
+  }
+
+Test whether a named feature is enabled at a given level in the call
+stack, returning a true value if it is.  C<$depth> defaults to 1,
+which checks the scope that called the scope calling
+feature::feature_enabled().
+
+croaks for an unknown feature name.
+
+=item features_enabled()
+
+=item features_enabled($depth)
+
+  package ReportEnabledFeatures;
+  use feature "say";
+  sub import {
+    say STDERR join " ", feature::features_enabled();
+  }
+
+Returns a list of the features enabled at a given level in the call
+stack.  C<$depth> defaults to 1, which checks the scope that called
+the scope calling feature::features_enabled().
+
+=item feature_bundle()
+
+=item feature_bundle($depth)
+
+Returns the feature bundle, if any, selected at a given level in the
+call stack.  C<$depth> defaults to 1, which checks the scope that called
+the scope calling feature::feature_bundle().
+
+Returns an undefined value if no feature bundle is selected in the
+scope.
+
+The bundle name returned will be for the earliest bundle matching the
+selected bundle, so:
+
+  use feature ();
+  use v5.12;
+  BEGIN { print feature::feature_bundle(0); }
+
+will print C<5.11>.
+
+This returns internal state, at this point C<use v5.12;> sets the
+feature bundle, but C< use feature ":5.12"; > does not set the feature
+bundle.  This may change in a future release of perl.
+
+=back
+
 =cut
 
 sub import {
@@ -994,4 +1064,65 @@ sub croak {
     Carp::croak(@_);
 }
 
+sub features_enabled {
+    my ($depth) = @_;
+
+    $depth //= 1;
+    my @frame = caller($depth+1)
+      or return;
+    my ($hints, $hinthash) = @frame[8, 10];
+
+    my $bundle_number = $hints & $hint_mask;
+    if ($bundle_number != $hint_mask) {
+        return $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}->@*;
+    }
+    else {
+        my @features;
+        for my $feature (sort keys %feature) {
+            if ($hinthash->{$feature{$feature}}) {
+                push @features, $feature;
+            }
+        }
+        return @features;
+    }
+}
+
+sub feature_enabled {
+    my ($feature, $depth) = @_;
+
+    $depth //= 1;
+    my @frame = caller($depth+1)
+      or return;
+    my ($hints, $hinthash) = @frame[8, 10];
+
+    my $hint_feature = $feature{$feature}
+      or croak "Unknown feature $feature";
+    my $bundle_number = $hints & $hint_mask;
+    if ($bundle_number != $hint_mask) {
+        my $bundle = $hint_bundles[$bundle_number >> $hint_shift];
+        for my $bundle_feature ($feature_bundle{$bundle}->@*) {
+            return 1 if $bundle_feature eq $feature;
+        }
+        return 0;
+    }
+    else {
+        return $hinthash->{$hint_feature} // 0;
+    }
+}
+
+sub feature_bundle {
+    my $depth = shift;
+
+    $depth //= 1;
+    my @frame = caller($depth+1)
+      or return;
+    my $bundle_number = $frame[8] & $hint_mask;
+    if ($bundle_number != $hint_mask) {
+        return $hint_bundles[$bundle_number >> $hint_shift];
+    }
+    else {
+        return undef;
+    }
+}
+
 1;

t/lib/feature/api

@@ -0,0 +1,48 @@
+Test the API
+
+__END__
+# NAME test feature enabled by bundle
+use feature ();
+BEGIN {
+   print "default: ", join(" ", feature::features_enabled(0)), "\n";
+   print "unicode_strings ", feature::feature_enabled("unicode_strings", 0) ? "is" : "is not",
+         " enabled\n";
+   print "bundle: ", feature::feature_bundle(0) // "undef", "\n";
+}
+use v5.12;
+BEGIN {
+   print "5.12: ", join(" ", feature::features_enabled(0)), "\n";
+   print "unicode_strings ", feature::feature_enabled("unicode_strings", 0) ? "is" : "is not",
+         " enabled\n";
+   print "bundle: ", feature::feature_bundle(0) // "undef", "\n";
+}
+EXPECT
+default: bareword_filehandles indirect multidimensional
+unicode_strings is not enabled
+bundle: default
+5.12: bareword_filehandles indirect multidimensional say state switch unicode_strings
+unicode_strings is enabled
+bundle: 5.11
+########
+# NAME test features enabled explicitly
+no feature "indirect";
+BEGIN {
+    print "no feature indirect: ", join(" ", feature::features_enabled(0)), "\n";
+    print "indirect ", feature::feature_enabled("indirect", 0) ? "is" : "is not",
+         " enabled\n";
+   print "bundle: ", feature::feature_bundle(0) // "undef", "\n";
+}
+use feature "unicode_strings";
+BEGIN {
+   print "added unicode_strings: ", join(" ", feature::features_enabled(0)), "\n";
+   print "unicode_strings ", feature::feature_enabled("unicode_strings", 0) ? "is" : "is not",
+         " enabled\n";
+   print "bundle: ", feature::feature_bundle(0) // "undef", "\n";
+}
+EXPECT
+no feature indirect: bareword_filehandles multidimensional
+indirect is not enabled
+bundle: undef
+added unicode_strings: bareword_filehandles multidimensional unicode_strings
+unicode_strings is enabled
+bundle: undef