Create regen/feature.pl

This script generates lib/feature.pm.  Soon it will be made to gener-
ate other files, too.

6 files changed, 488 insertions, 21 deletions

diff --git a/Cross/Makefile-cross-SH b/Cross/Makefile-cross-SH
index 4e72adcf8a..eaa1057132 100644
--- a/Cross/Makefile-cross-SH
+++ b/Cross/Makefile-cross-SH
@@ -848,6 +848,7 @@ CHMOD_W = chmod +w
 #	opcode.pl:	opcode.h opnames.h pp_proto.h
 #	regcomp.pl:	regnodes.h
 #	warnings.pl:	warnings.h lib/warnings.pm
+#	feature.pl:	lib/feature.pl
 # The correct versions should be already supplied with the perl kit,
 # in case you don't have perl available.
 # To force them to be regenerated, run
@@ -856,7 +857,8 @@ CHMOD_W = chmod +w
 # (make regen_headers is kept for backwards compatibility)
 
 AUTOGEN_FILES = opcode.h opnames.h pp_proto.h proto.h embed.h embedvar.h \
-		perlapi.h perlapi.c regnodes.h warnings.h lib/warnings.pm
+		perlapi.h perlapi.c regnodes.h warnings.h lib/warnings.pm \
+		lib/feature.pm
 
 .PHONY: regen_headers regen_all
 
diff --git a/MANIFEST b/MANIFEST
index 9b0067cb16..b9d796e2e1 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4822,6 +4822,7 @@ regcomp.h			Private declarations for above
 regcomp.sym			Data for regnodes.h
 regen/embed_lib.pl		Reads embed.fnc and regen/opcodes
 regen/embed.pl			Produces {embed,embedvar,proto}.h
+regen/feature.pl		Generates feature.pm
 regen/keywords.pl		Program to write keywords.h
 regen/mg_vtable.pl		generate mg_vtable.h
 regen/mk_PL_charclass.pl	Populate the PL_charclass table
diff --git a/Makefile.SH b/Makefile.SH
index 0bc963378f..4791e5c73a 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -1153,6 +1153,7 @@ CHMOD_W = chmod +w
 #	opcode.pl:	opcode.h opnames.h pp_proto.h
 #	regcomp.pl:	regnodes.h
 #	warnings.pl:	warnings.h lib/warnings.pm
+#	feature.pl:	lib/feature.pm
 # The correct versions should be already supplied with the perl kit,
 # in case you don't have perl available.
 # To force them to be regenerated, run
@@ -1161,7 +1162,8 @@ CHMOD_W = chmod +w
 # (make regen_headers is kept for backwards compatibility)
 
 AUTOGEN_FILES = opcode.h opnames.h pp_proto.h proto.h embed.h embedvar.h \
-		perlapi.h perlapi.c regnodes.h warnings.h lib/warnings.pm
+		perlapi.h perlapi.c regnodes.h warnings.h lib/warnings.pm \
+		lib/feature.pm
 
 .PHONY: regen_headers regen_all
 
diff --git a/lib/feature.pm b/lib/feature.pm
index c482e5bce3..a3cfdbe37e 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -1,8 +1,12 @@
+# -*- buffer-read-only: t -*-
+# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
+# This file is built by regen/feature.pl.
+# Any changes made here will be lost!
+
 package feature;
 
 our $VERSION = '1.25';
 
-# (feature name) => (internal name, used in %^H)
 my %feature = (
     say             => 'feature_say',
     state           => 'feature_state',
@@ -13,33 +17,27 @@ my %feature = (
     unicode_strings => 'feature_unicode',
 );
 
-# These work backwards--the presence of the hint elem disables the feature:
 my %default_feature = (
-    array_base      => 'feature_no$[',
+    array_base => 'feature_no$[',
 );
 
-# 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;
-
-# NB. the latest bundle must be loaded by the -E switch (see toke.c)
-
 our %feature_bundle = (
-    "default" => [keys %default_feature],
-    "5.10" => [qw(say state switch array_base)],
-    "5.11" => [qw(say state switch unicode_strings array_base)],
-    "5.15" => [qw(say state switch unicode_strings unicode_eval
-                  evalbytes current_sub)],
+    "5.10"    => [qw(array_base say state switch)],
+    "5.11"    => [qw(array_base say state switch unicode_strings)],
+    "5.15"    => [qw(current_sub evalbytes say state switch unicode_eval unicode_strings)],
+    "5.9.5"   => [qw(array_base say state switch)],
+    "default" => [qw(array_base)],
 );
 
+
 # Each of these is the same as the previous bundle
-for(12...14, 16) {
+for (12,13,14,16) {
     $feature_bundle{"5.$_"} = $feature_bundle{"5.".($_-1)}
 }
-
-# special case
-$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
+# 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)
@@ -372,3 +370,5 @@ sub croak {
 }
 
 1;
+
+# ex: set ro:
diff --git a/regen.pl b/regen.pl
index 1f2a583ed0..62dc82074e 100644
--- a/regen.pl
+++ b/regen.pl
@@ -23,6 +23,7 @@ reentr.pl
 regcomp.pl
 warnings.pl
 embed.pl
+feature.pl
 );
 
 my $tap = $ARGV[0] && $ARGV[0] eq '--tap' ? '# ' : '';
diff --git a/regen/feature.pl b/regen/feature.pl
new file mode 100644
index 0000000000..3e2057485e
--- /dev/null
+++ b/regen/feature.pl
@@ -0,0 +1,461 @@
+#!/usr/bin/perl
+# 
+# Regenerate (overwriting only if changed):
+#
+#    lib/feature.pm
+#
+# from information hardcoded into this script.
+#
+# This script is normally invoked from regen.pl.
+
+BEGIN {
+    require 'regen/regen_lib.pl';
+    push @INC, './lib';
+}
+use strict ;
+
+# (feature name) => (internal name, used in %^H)
+my %feature = (
+    say             => 'feature_say',
+    state           => 'feature_state',
+    switch          => 'feature_switch',
+    evalbytes       => 'feature_evalbytes',
+    current_sub     => 'feature___SUB__',
+    unicode_eval    => 'feature_unieval',
+    unicode_strings => 'feature_unicode',
+);
+
+# These work backwards--the presence of the hint elem disables the feature:
+my %default_feature = (
+    array_base      => 'feature_no$[',
+);
+
+my %feature_bundle = (
+     default =>	[keys %default_feature],
+    "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)],
+);
+
+###########################################################################
+
+
+my ($pm) = map {
+    open_new($_, '>', { by => 'regen/feature.pl' });
+} 'lib/feature.pm';
+
+
+while (<DATA>) {
+    last if /^FEATURES$/ ;
+    print $pm $_ ;
+}
+
+sub longest {
+    my $long;
+    for(@_) {
+	if (!defined $long or length $long < length) {
+	    $long = $_;
+	}
+    }
+    $long;
+}
+
+print $pm "my %feature = (\n";
+my $width = length longest keys %feature;
+for(sort { length $a <=> length $b } keys %feature) {
+    print $pm "    $_" . " "x($width-length) . " => '$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)
+	. " => '$default_feature{$_}',\n";
+}
+print $pm ");\n\n";
+
+print $pm "our %feature_bundle = (\n";
+my $prevkey;
+my $prev;
+my @same;
+$width = length longest keys %feature_bundle;
+for( sort keys %feature_bundle ) {
+    my $value = join(' ', sort @{$feature_bundle{$_}});
+    if (/^5\.\d\d\z/ && $prevkey
+	 && substr($_,-2) - substr($prevkey,-2) == 1 && $value eq $prev) {
+	push @same, $_;
+	$prevkey = $_;
+	next;
+    }
+    if(/^5\.\d\d\z/) {
+	$prev = $value;
+	$prevkey = $_;
+    }
+    print $pm qq'    "$_"' . " "x($width-length) . qq' => [qw($value)],\n';
+}
+print $pm ");\n\n";
+
+print $pm "
+# Each of these is the same as the previous bundle
+for (", join(',',map /\.(.*)/, @same), ') {
+    $feature_bundle{"5.$_"} = $feature_bundle{"5.".($_-1)}
+}';
+
+
+while (<DATA>) {
+    print $pm $_ ;
+}
+
+read_only_bottom_close_and_rename($pm);
+
+__END__
+package feature;
+
+our $VERSION = '1.25';
+
+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)
+
+=head1 NAME
+
+feature - Perl pragma to enable new features
+
+=head1 SYNOPSIS
+
+    use feature qw(say switch);
+    given ($foo) {
+        when (1)          { say "\$foo == 1" }
+        when ([2,3])      { say "\$foo == 2 || \$foo == 3" }
+        when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
+        when ($_ > 100)   { say "\$foo > 100" }
+        default           { say "None of the above" }
+    }
+
+    use feature ':5.10'; # loads all features available in perl 5.10
+
+    use v5.10;           # implicitly loads :5.10 feature bundle
+
+=head1 DESCRIPTION
+
+It is usually impossible to add new syntax to Perl without breaking
+some existing programs.  This pragma provides a way to minimize that
+risk. New syntactic constructs, or new semantic meanings to older
+constructs, can be enabled by C<use feature 'foo'>, and will be parsed
+only when the appropriate feature pragma is in scope.  (Nevertheless, the
+C<CORE::> prefix provides access to all Perl keywords, regardless of this
+pragma.)
+
+=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
+from that point to the end of the enclosing block.
+
+    {
+        use feature 'say';
+        say "say is available here";
+    }
+    print "But not here.\n";
+
+=head2 C<no feature>
+
+Features can also be turned off by using C<no feature "foo">.  This too
+has lexical effect.
+
+    use feature 'say';
+    say "say is available here";
+    {
+        no feature 'say';
+        print "But not here.\n";
+    }
+    say "Yet it is here.";
+
+C<no feature> with no features specified will turn off all features.
+
+=head1 AVAILABLE FEATURES
+
+=head2 The 'say' feature
+
+C<use feature 'say'> tells the compiler to enable the Perl 6 style
+C<say> function.
+
+See L<perlfunc/say> for details.
+
+This feature is available starting with Perl 5.10.
+
+=head2 The 'state' feature
+
+C<use feature 'state'> tells the compiler to enable C<state>
+variables.
+
+See L<perlsub/"Persistent Private Variables"> for details.
+
+This feature is available starting with Perl 5.10.
+
+=head2 The 'switch' feature
+
+C<use feature 'switch'> tells the compiler to enable the Perl 6
+given/when construct.
+
+See L<perlsyn/"Switch statements"> for details.
+
+This feature is available starting with Perl 5.10.
+
+=head2 The 'unicode_strings' feature
+
+C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
+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.
+
+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
+clear to Perl that Unicode is desired.  This can lead to some surprises
+when the behavior suddenly changes.  (See
+L<perlunicode/The "Unicode Bug"> for details.)  For this reason, if you are
+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.
+
+=head2 The 'unicode_eval' and 'evalbytes' features
+
+Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
+string, will evaluate it as a string of characters, ignoring any
+C<use utf8> declarations.  C<use utf8> exists to declare the encoding of
+the script, which only makes sense for a stream of bytes, not a string of
+characters.  Source filters are forbidden, as they also really only make
+sense on strings of bytes.  Any attempt to activate a source filter will
+result in an error.
+
+The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
+the argument passed to it as a string of bytes.  It dies if the string
+contains any characters outside the 8-bit range.  Source filters work
+within C<evalbytes>: they apply to the contents of the string being
+evaluated.
+
+Together, these two features are intended to replace the historical C<eval>
+function, which has (at least) two bugs in it, that cannot easily be fixed
+without breaking existing programs:
+
+=over
+
+=item *
+
+C<eval> behaves differently depending on the internal encoding of the
+string, sometimes treating its argument as a string of bytes, and sometimes
+as a string of characters.
+
+=item *
+
+Source filters activated within C<eval> leak out into whichever I<file>
+scope is currently being compiled.  To give an example with the CPAN module
+L<Semi::Semicolons>:
+
+    BEGIN { eval "use Semi::Semicolons;  # not filtered here " }
+    # filtered here!
+
+C<evalbytes> fixes that to work the way one would expect:
+
+    use feature "evalbytes";
+    BEGIN { evalbytes "use Semi::Semicolons;  # filtered " }
+    # not filtered
+
+=back
+
+These two features are available starting with Perl 5.16.
+
+=head2 The 'current_sub' feature
+
+This provides the C<__SUB__> token that returns a reference to the current
+subroutine or C<undef> outside of a subroutine.
+
+This feature is available starting with Perl 5.16.
+
+=head2 The 'array_base' feature
+
+This feature supports the legacy C<$[> variable.  See L<perlvar/$[> and
+L<arybase>.  It is on by default but disabled under C<use v5.16> (see
+L</IMPLICIT LOADING>, below).
+
+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.
+
+=head1 FEATURE BUNDLES
+
+It's possible to load multiple features together, using
+a I<feature bundle>.  The name of a feature bundle is prefixed with
+a colon, to distinguish it from an actual feature.
+
+  use feature ":5.10";
+
+The following feature bundles are available:
+
+  bundle    features included
+  --------- -----------------
+  :default  array_base
+
+  :5.10     say state switch array_base
+
+  :5.12     say state switch unicode_strings array_base
+
+  :5.14     say state switch unicode_strings array_base
+
+  :5.16     say state switch unicode_strings
+            unicode_eval evalbytes current_sub
+
+The C<:default> bundle represents the feature set that is enabled before
+any C<use feature> or C<no feature> declaration.
+
+Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
+no effect.  Feature bundles are guaranteed to be the same for all sub-versions.
+
+  use feature ":5.14.0";    # same as ":5.14"
+  use feature ":5.14.1";    # same as ":5.14"
+
+=head1 IMPLICIT LOADING
+
+Instead of loading feature bundles by name, it is easier to let Perl do
+implicit loading of a feature bundle for you.
+
+There are two ways to load the C<feature> pragma implicitly:
+
+=over 4
+
+=item *
+
+By using the C<-E> switch on the Perl command-line instead of C<-e>.
+That will enable the feature bundle for that version of Perl in the
+main compilation unit (that is, the one-liner that follows C<-E>).
+
+=item *
+
+By explicitly requiring a minimum Perl version number for your program, with
+the C<use VERSION> construct.  That is,
+
+    use v5.10.0;
+
+will do an implicit
+
+    no feature;
+    use feature ':5.10';
+
+and so on.  Note how the trailing sub-version
+is automatically stripped from the
+version.
+
+But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
+
+    use 5.010;
+
+with the same effect.
+
+If the required version is older than Perl 5.10, the ":default" feature
+bundle is automatically loaded instead.
+
+=back
+
+=cut
+
+sub import {
+    my $class = shift;
+    if (@_ == 0) {
+        croak("No features specified");
+    }
+    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';
+    }
+}
+
+sub unimport {
+    my $class = shift;
+
+    # 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;
+    }
+
+    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);
+	  }
+	  $^H{$default_feature{$name}} = 1; next;
+        }
+        else {
+            delete $^H{$feature{$name}};
+            $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
+        }
+    }
+}
+
+sub unknown_feature {
+    my $feature = shift;
+    croak(sprintf('Feature "%s" is not supported by Perl %vd',
+            $feature, $^V));
+}
+
+sub unknown_feature_bundle {
+    my $feature = shift;
+    croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
+            $feature, $^V));
+}
+
+sub croak {
+    require Carp;
+    Carp::croak(@_);
+}
+
+1;