regen/feature.pl

   1 #!/usr/bin/perl
   2 #
   3 # Regenerate (overwriting only if changed):
   4 #
   5 #    lib/feature.pm
   6 #    feature.h
   7 #
   8 # from information hardcoded into this script and from two #defines
   9 # in perl.h.
  10 #
  11 # This script is normally invoked from regen.pl.
  12
  13 BEGIN {
  14     require 'regen/regen_lib.pl';
  15     push @INC, './lib';
  16 }
  17 use strict ;
  18
  19
  20 ###########################################################################
  21 # Hand-editable data
  22
  23 # (feature name) => (internal name, used in %^H and macro names)
  24 my %feature = (
  25     say             => 'say',
  26     state           => 'state',
  27     switch          => 'switch',
  28     evalbytes       => 'evalbytes',
  29     array_base      => 'arybase',
  30     current_sub     => '__SUB__',
  31     unicode_eval    => 'unieval',
  32     unicode_strings => 'unicode',
  33     fc              => 'fc',
  34 );
  35
  36 # NOTE: If a feature is ever enabled in a non-contiguous range of Perl
  37 #       versions, any code below that uses %BundleRanges will have to
  38 #       be changed to account.
  39
  40 my %feature_bundle = (
  41      all     => [ keys %feature ],
  42      default => [qw(array_base)],
  43     "5.9.5"  => [qw(say state switch array_base)],
  44     "5.10"   => [qw(say state switch array_base)],
  45     "5.11"   => [qw(say state switch unicode_strings array_base)],
  46     "5.12"   => [qw(say state switch unicode_strings array_base)],
  47     "5.13"   => [qw(say state switch unicode_strings array_base)],
  48     "5.14"   => [qw(say state switch unicode_strings array_base)],
  49     "5.15"   => [qw(say state switch unicode_strings unicode_eval
  50                     evalbytes current_sub fc)],
  51     "5.16"   => [qw(say state switch unicode_strings unicode_eval
  52                     evalbytes current_sub fc)],
  53 );
  54
  55
  56 ###########################################################################
  57 # More data generated from the above
  58
  59 my %UniqueBundles; # "say state switch" => 5.10
  60 my %Aliases;       #  5.12 => 5.11
  61 for( sort keys %feature_bundle ) {
  62     my $value = join(' ', sort @{$feature_bundle{$_}});
  63     if (exists $UniqueBundles{$value}) {
  64         $Aliases{$_} = $UniqueBundles{$value};
  65     }
  66     else {
  67         $UniqueBundles{$value} = $_;
  68     }
  69 }
  70                            # start   end
  71 my %BundleRanges; # say => ['5.10', '5.15'] # unique bundles for values
  72 for my $bund (
  73     sort { $a eq 'default' ? -1 : $b eq 'default' ? 1 : $a cmp $b }
  74          values %UniqueBundles
  75 ) {
  76     next if $bund =~ /[^\d.]/ and $bund ne 'default';
  77     for (@{$feature_bundle{$bund}}) {
  78         if (@{$BundleRanges{$_} ||= []} == 2) {
  79             $BundleRanges{$_}[1] = $bund
  80         }
  81         else {
  82             push @{$BundleRanges{$_}}, $bund;
  83         }
  84     }
  85 }
  86
  87 my $HintShift;
  88 my $HintMask;
  89 my $Uni8Bit;
  90
  91 open "perl.h", "perl.h" or die "$0 cannot open perl.h: $!";
  92 while (readline "perl.h") {
  93     next unless /#\s*define\s+(HINT_FEATURE_MASK|HINT_UNI_8_BIT)/;
  94     my $is_u8b = $1 =~ 8;
  95     /(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n ";
  96     if ($is_u8b) {
  97         $Uni8Bit = $1;
  98     }
  99     else {
 100         my $hex = $HintMask = $1;
 101         my $bits = sprintf "%b", oct $1;
 102         $bits =~ /^0*1+(0*)\z/
 103          or die "Non-contiguous bits in $bits (binary for $hex):\n\n$_\n ";
 104         $HintShift = length $1;
 105         my $bits_needed =
 106             length sprintf "%b", scalar keys %UniqueBundles;
 107         $bits =~ /1{$bits_needed}/
 108             or die "Not enough bits (need $bits_needed)"
 109                  . " in $bits (binary for $hex):\n\n$_\n ";
 110     }
 111     if ($Uni8Bit && $HintMask) { last }
 112 }
 113 die "No HINT_FEATURE_MASK defined in perl.h" unless $HintMask;
 114 die "No HINT_UNI_8_BIT defined in perl.h"    unless $Uni8Bit;
 115
 116 close "perl.h";
 117
 118 my @HintedBundles =
 119     ('default', grep !/[^\d.]/, sort values %UniqueBundles);
 120
 121
 122 ###########################################################################
 123 # Open files to be generated
 124
 125 my ($pm, $h) = map {
 126     open_new($_, '>', { by => 'regen/feature.pl' });
 127 } 'lib/feature.pm', 'feature.h';
 128
 129
 130 ###########################################################################
 131 # Generate lib/feature.pm
 132
 133 while (<DATA>) {
 134     last if /^FEATURES$/ ;
 135     print $pm $_ ;
 136 }
 137
 138 sub longest {
 139     my $long;
 140     for(@_) {
 141         if (!defined $long or length $long < length) {
 142             $long = $_;
 143         }
 144     }
 145     $long;
 146 }
 147
 148 print $pm "our %feature = (\n";
 149 my $width = length longest keys %feature;
 150 for(sort { length $a <=> length $b } keys %feature) {
 151     print $pm "    $_" . " "x($width-length)
 152             . " => 'feature_$feature{$_}',\n";
 153 }
 154 print $pm ");\n\n";
 155
 156 print $pm "our %feature_bundle = (\n";
 157 $width = length longest values %UniqueBundles;
 158 for( sort { $UniqueBundles{$a} cmp $UniqueBundles{$b} }
 159           keys %UniqueBundles ) {
 160     my $bund = $UniqueBundles{$_};
 161     print $pm qq'    "$bund"' . " "x($width-length $bund)
 162             . qq' => [qw($_)],\n';
 163 }
 164 print $pm ");\n\n";
 165
 166 for (sort keys %Aliases) {
 167     print $pm
 168         qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n';
 169 };
 170
 171 print $pm <<EOPM;
 172
 173 our \$hint_shift   = $HintShift;
 174 our \$hint_mask    = $HintMask;
 175 our \@hint_bundles = qw( @HintedBundles );
 176
 177 # This gets set (for now) in \$^H as well as in %^H,
 178 # for runtime speed of the uc/lc/ucfirst/lcfirst functions.
 179 # See HINT_UNI_8_BIT in perl.h.
 180 our \$hint_uni8bit = $Uni8Bit;
 181 EOPM
 182
 183
 184 while (<DATA>) {
 185     last if /^PODTURES$/ ;
 186     print $pm $_ ;
 187 }
 188
 189 select +(select($pm), $~ = 'PODTURES')[0];
 190 format PODTURES =
 191   ^<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
 192 $::bundle, $::feature
 193 .
 194
 195 for ('default', sort grep /\.\d[02468]/, keys %feature_bundle) {
 196     $::bundle = ":$_";
 197     $::feature = join ' ', @{$feature_bundle{$_}};
 198     write $pm;
 199     print $pm "\n";
 200 }
 201
 202 while (<DATA>) {
 203     print $pm $_ ;
 204 }
 205
 206 read_only_bottom_close_and_rename($pm);
 207
 208
 209 ###########################################################################
 210 # Generate feature.h
 211
 212 print $h <<EOH;
 213
 214 #if defined(PERL_CORE) || defined (PERL_EXT)
 215
 216 #define HINT_FEATURE_SHIFT      $HintShift
 217
 218 EOH
 219
 220 my $count;
 221 for (@HintedBundles) {
 222     (my $key = uc) =~ y/.//d;
 223     print $h "#define FEATURE_BUNDLE_$key       ", $count++, "\n";
 224 }
 225
 226 print $h <<'EOH';
 227 #define FEATURE_BUNDLE_CUSTOM   (HINT_FEATURE_MASK >> HINT_FEATURE_SHIFT)
 228
 229 #define CURRENT_HINTS \
 230     (PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints)
 231 #define CURRENT_FEATURE_BUNDLE \
 232     ((CURRENT_HINTS & HINT_FEATURE_MASK) >> HINT_FEATURE_SHIFT)
 233
 234 #define FEATURE_IS_ENABLED(name)                                        \
 235         ((CURRENT_HINTS                                                  \
 236            & HINT_LOCALIZE_HH)                                            \
 237             && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 238 /* The longest string we pass in.  */
 239 EOH
 240
 241 my $longest_internal_feature_name = longest values %feature;
 242 print $h <<EOL;
 243 #define MAX_FEATURE_LEN (sizeof("$longest_internal_feature_name")-1)
 244
 245 EOL
 246
 247 for (
 248     sort { length $a <=> length $b } keys %feature
 249 ) {
 250     my($first,$last) =
 251         map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}};
 252     my $name = $feature{$_};
 253     my $NAME = uc $name;
 254     if ($last && $first eq 'DEFAULT') { #  ‘>= DEFAULT’ warns
 255         print $h <<EOI;
 256 #define FEATURE_$NAME\_IS_ENABLED \\
 257     ( \\
 258         CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last \\
 259      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
 260          FEATURE_IS_ENABLED("$name")) \\
 261     )
 262
 263 EOI
 264     }
 265     elsif ($last) {
 266         print $h <<EOH3;
 267 #define FEATURE_$NAME\_IS_ENABLED \\
 268     ( \\
 269         (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_$first && \\
 270          CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last) \\
 271      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
 272          FEATURE_IS_ENABLED("$name")) \\
 273     )
 274
 275 EOH3
 276     }
 277     else {
 278         print $h <<EOH4;
 279 #define FEATURE_$NAME\_IS_ENABLED \\
 280     ( \\
 281         CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_$first \\
 282      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
 283          FEATURE_IS_ENABLED("$name")) \\
 284     )
 285
 286 EOH4
 287     }
 288 }
 289
 290 print $h <<EOH;
 291
 292 #endif /* PERL_CORE or PERL_EXT */
 293
 294 #ifdef PERL_IN_OP_C
 295 PERL_STATIC_INLINE void
 296 S_enable_feature_bundle(pTHX_ SV *ver)
 297 {
 298     SV *comp_ver = sv_newmortal();
 299     PL_hints = (PL_hints &~ HINT_FEATURE_MASK)
 300              | (
 301 EOH
 302
 303 for (reverse @HintedBundles[1..$#HintedBundles]) { # skip default
 304     my $numver = $_;
 305     if ($numver eq '5.10') { $numver = '5.009005' } # special case
 306     else                   { $numver =~ s/\./.0/  } # 5.11 => 5.011
 307     (my $macrover = $_) =~ y/.//d;
 308     print $h <<"    EOK";
 309                   (sv_setnv(comp_ver, $numver),
 310                    vcmp(ver, upg_version(comp_ver, FALSE)) >= 0)
 311                         ? FEATURE_BUNDLE_$macrover :
 312     EOK
 313 }
 314
 315 print $h <<EOJ;
 316                           FEATURE_BUNDLE_DEFAULT
 317                ) << HINT_FEATURE_SHIFT;
 318     /* special case */
 319     assert(PL_curcop == &PL_compiling);
 320     if (FEATURE_UNICODE_IS_ENABLED) PL_hints |=  HINT_UNI_8_BIT;
 321     else                            PL_hints &= ~HINT_UNI_8_BIT;
 322 }
 323 #endif /* PERL_IN_OP_C */
 324 EOJ
 325
 326 read_only_bottom_close_and_rename($h);
 327
 328
 329 ###########################################################################
 330 # Template for feature.pm
 331
 332 __END__
 333 package feature;
 334
 335 our $VERSION = '1.27';
 336
 337 FEATURES
 338
 339 # TODO:
 340 # - think about versioned features (use feature switch => 2)
 341
 342 =head1 NAME
 343
 344 feature - Perl pragma to enable new features
 345
 346 =head1 SYNOPSIS
 347
 348     use feature qw(say switch);
 349     given ($foo) {
 350         when (1)          { say "\$foo == 1" }
 351         when ([2,3])      { say "\$foo == 2 || \$foo == 3" }
 352         when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
 353         when ($_ > 100)   { say "\$foo > 100" }
 354         default           { say "None of the above" }
 355     }
 356
 357     use feature ':5.10'; # loads all features available in perl 5.10
 358
 359     use v5.10;           # implicitly loads :5.10 feature bundle
 360
 361 =head1 DESCRIPTION
 362
 363 It is usually impossible to add new syntax to Perl without breaking
 364 some existing programs.  This pragma provides a way to minimize that
 365 risk. New syntactic constructs, or new semantic meanings to older
 366 constructs, can be enabled by C<use feature 'foo'>, and will be parsed
 367 only when the appropriate feature pragma is in scope.  (Nevertheless, the
 368 C<CORE::> prefix provides access to all Perl keywords, regardless of this
 369 pragma.)
 370
 371 =head2 Lexical effect
 372
 373 Like other pragmas (C<use strict>, for example), features have a lexical
 374 effect. C<use feature qw(foo)> will only make the feature "foo" available
 375 from that point to the end of the enclosing block.
 376
 377     {
 378         use feature 'say';
 379         say "say is available here";
 380     }
 381     print "But not here.\n";
 382
 383 =head2 C<no feature>
 384
 385 Features can also be turned off by using C<no feature "foo">.  This too
 386 has lexical effect.
 387
 388     use feature 'say';
 389     say "say is available here";
 390     {
 391         no feature 'say';
 392         print "But not here.\n";
 393     }
 394     say "Yet it is here.";
 395
 396 C<no feature> with no features specified will reset to the default group.  To
 397 disable I<all> features (an unusual request!) use C<no feature ':all'>.
 398
 399 =head1 AVAILABLE FEATURES
 400
 401 =head2 The 'say' feature
 402
 403 C<use feature 'say'> tells the compiler to enable the Perl 6 style
 404 C<say> function.
 405
 406 See L<perlfunc/say> for details.
 407
 408 This feature is available starting with Perl 5.10.
 409
 410 =head2 The 'state' feature
 411
 412 C<use feature 'state'> tells the compiler to enable C<state>
 413 variables.
 414
 415 See L<perlsub/"Persistent Private Variables"> for details.
 416
 417 This feature is available starting with Perl 5.10.
 418
 419 =head2 The 'switch' feature
 420
 421 C<use feature 'switch'> tells the compiler to enable the Perl 6
 422 given/when construct.
 423
 424 See L<perlsyn/"Switch Statements"> for details.
 425
 426 This feature is available starting with Perl 5.10.
 427
 428 =head2 The 'unicode_strings' feature
 429
 430 C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
 431 in all string operations executed within its scope (unless they are also
 432 within the scope of either C<use locale> or C<use bytes>).  The same applies
 433 to all regular expressions compiled within the scope, even if executed outside
 434 it.
 435
 436 C<no feature 'unicode_strings'> tells the compiler to use the traditional
 437 Perl semantics wherein the native character set semantics is used unless it is
 438 clear to Perl that Unicode is desired.  This can lead to some surprises
 439 when the behavior suddenly changes.  (See
 440 L<perlunicode/The "Unicode Bug"> for details.)  For this reason, if you are
 441 potentially using Unicode in your program, the
 442 C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
 443
 444 This feature is available starting with Perl 5.12; was almost fully
 445 implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>.
 446
 447 =head2 The 'unicode_eval' and 'evalbytes' features
 448
 449 Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
 450 string, will evaluate it as a string of characters, ignoring any
 451 C<use utf8> declarations.  C<use utf8> exists to declare the encoding of
 452 the script, which only makes sense for a stream of bytes, not a string of
 453 characters.  Source filters are forbidden, as they also really only make
 454 sense on strings of bytes.  Any attempt to activate a source filter will
 455 result in an error.
 456
 457 The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
 458 the argument passed to it as a string of bytes.  It dies if the string
 459 contains any characters outside the 8-bit range.  Source filters work
 460 within C<evalbytes>: they apply to the contents of the string being
 461 evaluated.
 462
 463 Together, these two features are intended to replace the historical C<eval>
 464 function, which has (at least) two bugs in it, that cannot easily be fixed
 465 without breaking existing programs:
 466
 467 =over
 468
 469 =item *
 470
 471 C<eval> behaves differently depending on the internal encoding of the
 472 string, sometimes treating its argument as a string of bytes, and sometimes
 473 as a string of characters.
 474
 475 =item *
 476
 477 Source filters activated within C<eval> leak out into whichever I<file>
 478 scope is currently being compiled.  To give an example with the CPAN module
 479 L<Semi::Semicolons>:
 480
 481     BEGIN { eval "use Semi::Semicolons;  # not filtered here " }
 482     # filtered here!
 483
 484 C<evalbytes> fixes that to work the way one would expect:
 485
 486     use feature "evalbytes";
 487     BEGIN { evalbytes "use Semi::Semicolons;  # filtered " }
 488     # not filtered
 489
 490 =back
 491
 492 These two features are available starting with Perl 5.16.
 493
 494 =head2 The 'current_sub' feature
 495
 496 This provides the C<__SUB__> token that returns a reference to the current
 497 subroutine or C<undef> outside of a subroutine.
 498
 499 This feature is available starting with Perl 5.16.
 500
 501 =head2 The 'array_base' feature
 502
 503 This feature supports the legacy C<$[> variable.  See L<perlvar/$[> and
 504 L<arybase>.  It is on by default but disabled under C<use v5.16> (see
 505 L</IMPLICIT LOADING>, below).
 506
 507 This feature is available under this name starting with Perl 5.16.  In
 508 previous versions, it was simply on all the time, and this pragma knew
 509 nothing about it.
 510
 511 =head2 The 'fc' feature
 512
 513 C<use feature 'fc'> tells the compiler to enable the C<fc> function,
 514 which implements Unicode casefolding.
 515
 516 See L<perlfunc/fc> for details.
 517
 518 This feature is available from Perl 5.16 onwards.
 519
 520 =head1 FEATURE BUNDLES
 521
 522 It's possible to load multiple features together, using
 523 a I<feature bundle>.  The name of a feature bundle is prefixed with
 524 a colon, to distinguish it from an actual feature.
 525
 526   use feature ":5.10";
 527
 528 The following feature bundles are available:
 529
 530   bundle    features included
 531   --------- -----------------
 532 PODTURES
 533 The C<:default> bundle represents the feature set that is enabled before
 534 any C<use feature> or C<no feature> declaration.
 535
 536 Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
 537 no effect.  Feature bundles are guaranteed to be the same for all sub-versions.
 538
 539   use feature ":5.14.0";    # same as ":5.14"
 540   use feature ":5.14.1";    # same as ":5.14"
 541
 542 =head1 IMPLICIT LOADING
 543
 544 Instead of loading feature bundles by name, it is easier to let Perl do
 545 implicit loading of a feature bundle for you.
 546
 547 There are two ways to load the C<feature> pragma implicitly:
 548
 549 =over 4
 550
 551 =item *
 552
 553 By using the C<-E> switch on the Perl command-line instead of C<-e>.
 554 That will enable the feature bundle for that version of Perl in the
 555 main compilation unit (that is, the one-liner that follows C<-E>).
 556
 557 =item *
 558
 559 By explicitly requiring a minimum Perl version number for your program, with
 560 the C<use VERSION> construct.  That is,
 561
 562     use v5.10.0;
 563
 564 will do an implicit
 565
 566     no feature ':all';
 567     use feature ':5.10';
 568
 569 and so on.  Note how the trailing sub-version
 570 is automatically stripped from the
 571 version.
 572
 573 But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
 574
 575     use 5.010;
 576
 577 with the same effect.
 578
 579 If the required version is older than Perl 5.10, the ":default" feature
 580 bundle is automatically loaded instead.
 581
 582 =back
 583
 584 =cut
 585
 586 sub current_bundle {
 587     my $bundle_number = $^H & $hint_mask;
 588     return if $bundle_number == $hint_mask;
 589     return $feature_bundle{@hint_bundles[$bundle_number >> $hint_shift]};
 590 }
 591
 592 sub normalise_hints {
 593     # Delete any keys that may be left over from last time.
 594     delete @^H{ values(%feature) };
 595     $^H |= $hint_mask;
 596     for (@{+shift}) {
 597         $^H{$feature{$_}} = 1;
 598         $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
 599     }
 600 }
 601
 602 sub import {
 603     my $class = shift;
 604     if (@_ == 0) {
 605         croak("No features specified");
 606     }
 607     if (my $features = current_bundle) {
 608         # Features are enabled implicitly via bundle hints.
 609         normalise_hints $features;
 610     }
 611     while (@_) {
 612         my $name = shift(@_);
 613         if (substr($name, 0, 1) eq ":") {
 614             my $v = substr($name, 1);
 615             if (!exists $feature_bundle{$v}) {
 616                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
 617                 if (!exists $feature_bundle{$v}) {
 618                     unknown_feature_bundle(substr($name, 1));
 619                 }
 620             }
 621             unshift @_, @{$feature_bundle{$v}};
 622             next;
 623         }
 624         if (!exists $feature{$name}) {
 625             unknown_feature($name);
 626         }
 627         $^H{$feature{$name}} = 1;
 628         $^H |= $hint_uni8bit if $name eq 'unicode_strings';
 629     }
 630 }
 631
 632 sub unimport {
 633     my $class = shift;
 634
 635     # A bare C<no feature> should reset to the default bundle
 636     if (!@_) {
 637         $^H &= ~($hint_uni8bit|$hint_mask);
 638         return;
 639     }
 640
 641     if (my $features = current_bundle) {
 642         # Features are enabled implicitly via bundle hints.
 643         normalise_hints $features;
 644     }
 645
 646     while (@_) {
 647         my $name = shift;
 648         if (substr($name, 0, 1) eq ":") {
 649             my $v = substr($name, 1);
 650             if (!exists $feature_bundle{$v}) {
 651                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
 652                 if (!exists $feature_bundle{$v}) {
 653                     unknown_feature_bundle(substr($name, 1));
 654                 }
 655             }
 656             unshift @_, @{$feature_bundle{$v}};
 657             next;
 658         }
 659         if (!exists($feature{$name})) {
 660             unknown_feature($name);
 661         }
 662         else {
 663             delete $^H{$feature{$name}};
 664             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
 665         }
 666     }
 667 }
 668
 669 sub unknown_feature {
 670     my $feature = shift;
 671     croak(sprintf('Feature "%s" is not supported by Perl %vd',
 672             $feature, $^V));
 673 }
 674
 675 sub unknown_feature_bundle {
 676     my $feature = shift;
 677     croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
 678             $feature, $^V));
 679 }
 680
 681 sub croak {
 682     require Carp;
 683     Carp::croak(@_);
 684 }
 685
 686 1;