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