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