regen/feature.pl

   1 #!/usr/bin/perl
   2 #
   3 # Regenerate (overwriting only if changed):
   4 #
   5 #    lib/feature.pm
   6 #
   7 # from information hardcoded into this script.
   8 #
   9 # This script is normally invoked from regen.pl.
  10
  11 BEGIN {
  12     require 'regen/regen_lib.pl';
  13     push @INC, './lib';
  14 }
  15 use strict ;
  16
  17 # (feature name) => (internal name, used in %^H)
  18 my %feature = (
  19     say             => 'feature_say',
  20     state           => 'feature_state',
  21     switch          => 'feature_switch',
  22     evalbytes       => 'feature_evalbytes',
  23     current_sub     => 'feature___SUB__',
  24     unicode_eval    => 'feature_unieval',
  25     unicode_strings => 'feature_unicode',
  26 );
  27
  28 # These work backwards--the presence of the hint elem disables the feature:
  29 my %default_feature = (
  30     array_base      => 'feature_no$[',
  31 );
  32
  33 my %feature_bundle = (
  34      default => [keys %default_feature],
  35     "5.9.5"  => [qw(say state switch array_base)],
  36     "5.10"   => [qw(say state switch array_base)],
  37     "5.11"   => [qw(say state switch unicode_strings array_base)],
  38     "5.12"   => [qw(say state switch unicode_strings array_base)],
  39     "5.13"   => [qw(say state switch unicode_strings array_base)],
  40     "5.14"   => [qw(say state switch unicode_strings array_base)],
  41     "5.15"   => [qw(say state switch unicode_strings unicode_eval
  42                     evalbytes current_sub)],
  43     "5.16"   => [qw(say state switch unicode_strings unicode_eval
  44                     evalbytes current_sub)],
  45 );
  46
  47 ###########################################################################
  48
  49
  50 my ($pm) = map {
  51     open_new($_, '>', { by => 'regen/feature.pl' });
  52 } 'lib/feature.pm';
  53
  54
  55 while (<DATA>) {
  56     last if /^FEATURES$/ ;
  57     print $pm $_ ;
  58 }
  59
  60 sub longest {
  61     my $long;
  62     for(@_) {
  63         if (!defined $long or length $long < length) {
  64             $long = $_;
  65         }
  66     }
  67     $long;
  68 }
  69
  70 print $pm "my %feature = (\n";
  71 my $width = length longest keys %feature;
  72 for(sort { length $a <=> length $b } keys %feature) {
  73     print $pm "    $_" . " "x($width-length) . " => '$feature{$_}',\n";
  74 }
  75 print $pm ");\n\n";
  76
  77 print $pm "my %default_feature = (\n";
  78 $width = length longest keys %default_feature;
  79 for(sort { length $a <=> length $b } keys %default_feature) {
  80     print $pm "    $_" . " "x($width-length)
  81         . " => '$default_feature{$_}',\n";
  82 }
  83 print $pm ");\n\n";
  84
  85 print $pm "our %feature_bundle = (\n";
  86 my $prevkey;
  87 my $prev;
  88 my @same;
  89 $width = length longest keys %feature_bundle;
  90 for( sort keys %feature_bundle ) {
  91     my $value = join(' ', sort @{$feature_bundle{$_}});
  92     if (/^5\.\d\d\z/ && $prevkey
  93          && substr($_,-2) - substr($prevkey,-2) == 1 && $value eq $prev) {
  94         push @same, $_;
  95         $prevkey = $_;
  96         next;
  97     }
  98     if(/^5\.\d\d\z/) {
  99         $prev = $value;
 100         $prevkey = $_;
 101     }
 102     print $pm qq'    "$_"' . " "x($width-length) . qq' => [qw($value)],\n';
 103 }
 104 print $pm ");\n\n";
 105
 106 print $pm "
 107 # Each of these is the same as the previous bundle
 108 for (", join(',',map /\.(.*)/, @same), ') {
 109     $feature_bundle{"5.$_"} = $feature_bundle{"5.".($_-1)}
 110 }';
 111
 112
 113 while (<DATA>) {
 114     print $pm $_ ;
 115 }
 116
 117 read_only_bottom_close_and_rename($pm);
 118
 119 open "perl.h", "perl.h" or die "$0 cannot open perl.h: $!";
 120 perlh: {
 121     while (readline "perl.h") {
 122         next unless /#define\s+HINT_FEATURE_MASK/;
 123         /(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n ";
 124         my $hex = $1;
 125         my $bits = sprintf "%b", oct $1;
 126         $bits =~ /^0*1+0*\z/
 127          or die "Non-contiguous bits in $bits (binary for $hex):\n\n$_\n ";
 128         my $bits_needed =
 129             length sprintf "%b", scalar keys(%feature_bundle) - @same;
 130         $bits =~ /1{$bits_needed}/
 131             or die "Not enough bits (need $bits_needed)"
 132                  . " in $bits (binary for $hex):\n\n$_\n";
 133         last perlh;
 134     }
 135     die "No HINT_FEATURE_MASK defined in perl.h";
 136 }
 137 close "perl.h";
 138
 139 __END__
 140 package feature;
 141
 142 our $VERSION = '1.25';
 143
 144 FEATURES
 145
 146 # This gets set (for now) in $^H as well as in %^H,
 147 # for runtime speed of the uc/lc/ucfirst/lcfirst functions.
 148 # See HINT_UNI_8_BIT in perl.h.
 149 our $hint_uni8bit = 0x00000800;
 150
 151 # TODO:
 152 # - think about versioned features (use feature switch => 2)
 153
 154 =head1 NAME
 155
 156 feature - Perl pragma to enable new features
 157
 158 =head1 SYNOPSIS
 159
 160     use feature qw(say switch);
 161     given ($foo) {
 162         when (1)          { say "\$foo == 1" }
 163         when ([2,3])      { say "\$foo == 2 || \$foo == 3" }
 164         when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
 165         when ($_ > 100)   { say "\$foo > 100" }
 166         default           { say "None of the above" }
 167     }
 168
 169     use feature ':5.10'; # loads all features available in perl 5.10
 170
 171     use v5.10;           # implicitly loads :5.10 feature bundle
 172
 173 =head1 DESCRIPTION
 174
 175 It is usually impossible to add new syntax to Perl without breaking
 176 some existing programs.  This pragma provides a way to minimize that
 177 risk. New syntactic constructs, or new semantic meanings to older
 178 constructs, can be enabled by C<use feature 'foo'>, and will be parsed
 179 only when the appropriate feature pragma is in scope.  (Nevertheless, the
 180 C<CORE::> prefix provides access to all Perl keywords, regardless of this
 181 pragma.)
 182
 183 =head2 Lexical effect
 184
 185 Like other pragmas (C<use strict>, for example), features have a lexical
 186 effect. C<use feature qw(foo)> will only make the feature "foo" available
 187 from that point to the end of the enclosing block.
 188
 189     {
 190         use feature 'say';
 191         say "say is available here";
 192     }
 193     print "But not here.\n";
 194
 195 =head2 C<no feature>
 196
 197 Features can also be turned off by using C<no feature "foo">.  This too
 198 has lexical effect.
 199
 200     use feature 'say';
 201     say "say is available here";
 202     {
 203         no feature 'say';
 204         print "But not here.\n";
 205     }
 206     say "Yet it is here.";
 207
 208 C<no feature> with no features specified will turn off all features.
 209
 210 =head1 AVAILABLE FEATURES
 211
 212 =head2 The 'say' feature
 213
 214 C<use feature 'say'> tells the compiler to enable the Perl 6 style
 215 C<say> function.
 216
 217 See L<perlfunc/say> for details.
 218
 219 This feature is available starting with Perl 5.10.
 220
 221 =head2 The 'state' feature
 222
 223 C<use feature 'state'> tells the compiler to enable C<state>
 224 variables.
 225
 226 See L<perlsub/"Persistent Private Variables"> for details.
 227
 228 This feature is available starting with Perl 5.10.
 229
 230 =head2 The 'switch' feature
 231
 232 C<use feature 'switch'> tells the compiler to enable the Perl 6
 233 given/when construct.
 234
 235 See L<perlsyn/"Switch statements"> for details.
 236
 237 This feature is available starting with Perl 5.10.
 238
 239 =head2 The 'unicode_strings' feature
 240
 241 C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
 242 in all string operations executed within its scope (unless they are also
 243 within the scope of either C<use locale> or C<use bytes>).  The same applies
 244 to all regular expressions compiled within the scope, even if executed outside
 245 it.
 246
 247 C<no feature 'unicode_strings'> tells the compiler to use the traditional
 248 Perl semantics wherein the native character set semantics is used unless it is
 249 clear to Perl that Unicode is desired.  This can lead to some surprises
 250 when the behavior suddenly changes.  (See
 251 L<perlunicode/The "Unicode Bug"> for details.)  For this reason, if you are
 252 potentially using Unicode in your program, the
 253 C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
 254
 255 This feature is available starting with Perl 5.12, but was not fully
 256 implemented until Perl 5.14.
 257
 258 =head2 The 'unicode_eval' and 'evalbytes' features
 259
 260 Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
 261 string, will evaluate it as a string of characters, ignoring any
 262 C<use utf8> declarations.  C<use utf8> exists to declare the encoding of
 263 the script, which only makes sense for a stream of bytes, not a string of
 264 characters.  Source filters are forbidden, as they also really only make
 265 sense on strings of bytes.  Any attempt to activate a source filter will
 266 result in an error.
 267
 268 The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
 269 the argument passed to it as a string of bytes.  It dies if the string
 270 contains any characters outside the 8-bit range.  Source filters work
 271 within C<evalbytes>: they apply to the contents of the string being
 272 evaluated.
 273
 274 Together, these two features are intended to replace the historical C<eval>
 275 function, which has (at least) two bugs in it, that cannot easily be fixed
 276 without breaking existing programs:
 277
 278 =over
 279
 280 =item *
 281
 282 C<eval> behaves differently depending on the internal encoding of the
 283 string, sometimes treating its argument as a string of bytes, and sometimes
 284 as a string of characters.
 285
 286 =item *
 287
 288 Source filters activated within C<eval> leak out into whichever I<file>
 289 scope is currently being compiled.  To give an example with the CPAN module
 290 L<Semi::Semicolons>:
 291
 292     BEGIN { eval "use Semi::Semicolons;  # not filtered here " }
 293     # filtered here!
 294
 295 C<evalbytes> fixes that to work the way one would expect:
 296
 297     use feature "evalbytes";
 298     BEGIN { evalbytes "use Semi::Semicolons;  # filtered " }
 299     # not filtered
 300
 301 =back
 302
 303 These two features are available starting with Perl 5.16.
 304
 305 =head2 The 'current_sub' feature
 306
 307 This provides the C<__SUB__> token that returns a reference to the current
 308 subroutine or C<undef> outside of a subroutine.
 309
 310 This feature is available starting with Perl 5.16.
 311
 312 =head2 The 'array_base' feature
 313
 314 This feature supports the legacy C<$[> variable.  See L<perlvar/$[> and
 315 L<arybase>.  It is on by default but disabled under C<use v5.16> (see
 316 L</IMPLICIT LOADING>, below).
 317
 318 This feature is available under this name starting with Perl 5.16.  In
 319 previous versions, it was simply on all the time, and this pragma knew
 320 nothing about it.
 321
 322 =head1 FEATURE BUNDLES
 323
 324 It's possible to load multiple features together, using
 325 a I<feature bundle>.  The name of a feature bundle is prefixed with
 326 a colon, to distinguish it from an actual feature.
 327
 328   use feature ":5.10";
 329
 330 The following feature bundles are available:
 331
 332   bundle    features included
 333   --------- -----------------
 334   :default  array_base
 335
 336   :5.10     say state switch array_base
 337
 338   :5.12     say state switch unicode_strings array_base
 339
 340   :5.14     say state switch unicode_strings array_base
 341
 342   :5.16     say state switch unicode_strings
 343             unicode_eval evalbytes current_sub
 344
 345 The C<:default> bundle represents the feature set that is enabled before
 346 any C<use feature> or C<no feature> declaration.
 347
 348 Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
 349 no effect.  Feature bundles are guaranteed to be the same for all sub-versions.
 350
 351   use feature ":5.14.0";    # same as ":5.14"
 352   use feature ":5.14.1";    # same as ":5.14"
 353
 354 =head1 IMPLICIT LOADING
 355
 356 Instead of loading feature bundles by name, it is easier to let Perl do
 357 implicit loading of a feature bundle for you.
 358
 359 There are two ways to load the C<feature> pragma implicitly:
 360
 361 =over 4
 362
 363 =item *
 364
 365 By using the C<-E> switch on the Perl command-line instead of C<-e>.
 366 That will enable the feature bundle for that version of Perl in the
 367 main compilation unit (that is, the one-liner that follows C<-E>).
 368
 369 =item *
 370
 371 By explicitly requiring a minimum Perl version number for your program, with
 372 the C<use VERSION> construct.  That is,
 373
 374     use v5.10.0;
 375
 376 will do an implicit
 377
 378     no feature;
 379     use feature ':5.10';
 380
 381 and so on.  Note how the trailing sub-version
 382 is automatically stripped from the
 383 version.
 384
 385 But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
 386
 387     use 5.010;
 388
 389 with the same effect.
 390
 391 If the required version is older than Perl 5.10, the ":default" feature
 392 bundle is automatically loaded instead.
 393
 394 =back
 395
 396 =cut
 397
 398 sub import {
 399     my $class = shift;
 400     if (@_ == 0) {
 401         croak("No features specified");
 402     }
 403     while (@_) {
 404         my $name = shift(@_);
 405         if (substr($name, 0, 1) eq ":") {
 406             my $v = substr($name, 1);
 407             if (!exists $feature_bundle{$v}) {
 408                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
 409                 if (!exists $feature_bundle{$v}) {
 410                     unknown_feature_bundle(substr($name, 1));
 411                 }
 412             }
 413             unshift @_, @{$feature_bundle{$v}};
 414             next;
 415         }
 416         if (!exists $feature{$name}) {
 417           if (!exists $default_feature{$name}) {
 418             unknown_feature($name);
 419           }
 420           delete $^H{$default_feature{$name}}; next;
 421         }
 422         $^H{$feature{$name}} = 1;
 423         $^H |= $hint_uni8bit if $name eq 'unicode_strings';
 424     }
 425 }
 426
 427 sub unimport {
 428     my $class = shift;
 429
 430     # A bare C<no feature> should disable *all* features
 431     if (!@_) {
 432         delete @^H{ values(%feature) };
 433         $^H &= ~ $hint_uni8bit;
 434         @^H{ values(%default_feature) } = (1) x keys %default_feature;
 435         return;
 436     }
 437
 438     while (@_) {
 439         my $name = shift;
 440         if (substr($name, 0, 1) eq ":") {
 441             my $v = substr($name, 1);
 442             if (!exists $feature_bundle{$v}) {
 443                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
 444                 if (!exists $feature_bundle{$v}) {
 445                     unknown_feature_bundle(substr($name, 1));
 446                 }
 447             }
 448             unshift @_, @{$feature_bundle{$v}};
 449             next;
 450         }
 451         if (!exists($feature{$name})) {
 452           if (!exists $default_feature{$name}) {
 453             unknown_feature($name);
 454           }
 455           $^H{$default_feature{$name}} = 1; next;
 456         }
 457         else {
 458             delete $^H{$feature{$name}};
 459             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
 460         }
 461     }
 462 }
 463
 464 sub unknown_feature {
 465     my $feature = shift;
 466     croak(sprintf('Feature "%s" is not supported by Perl %vd',
 467             $feature, $^V));
 468 }
 469
 470 sub unknown_feature_bundle {
 471     my $feature = shift;
 472     croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
 473             $feature, $^V));
 474 }
 475
 476 sub croak {
 477     require Carp;
 478     Carp::croak(@_);
 479 }
 480
 481 1;