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 /* Avoid using ... && Perl_feature_is_enabled(...) as that triggers a bug in
 235    the HP-UX cc on PA-RISC */
 236 #define FEATURE_IS_ENABLED(name)                                        \
 237         ((CURRENT_HINTS                                                  \
 238            & HINT_LOCALIZE_HH)                                            \
 239             ? Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)) : FALSE)
 240 /* The longest string we pass in.  */
 241 EOH
 242
 243 my $longest_internal_feature_name = longest values %feature;
 244 print $h <<EOL;
 245 #define MAX_FEATURE_LEN (sizeof("$longest_internal_feature_name")-1)
 246
 247 EOL
 248
 249 for (
 250     sort { length $a <=> length $b } keys %feature
 251 ) {
 252     my($first,$last) =
 253         map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}};
 254     my $name = $feature{$_};
 255     my $NAME = uc $name;
 256     if ($last && $first eq 'DEFAULT') { #  ‘>= DEFAULT’ warns
 257         print $h <<EOI;
 258 #define FEATURE_$NAME\_IS_ENABLED \\
 259     ( \\
 260         CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last \\
 261      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
 262          FEATURE_IS_ENABLED("$name")) \\
 263     )
 264
 265 EOI
 266     }
 267     elsif ($last) {
 268         print $h <<EOH3;
 269 #define FEATURE_$NAME\_IS_ENABLED \\
 270     ( \\
 271         (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_$first && \\
 272          CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last) \\
 273      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
 274          FEATURE_IS_ENABLED("$name")) \\
 275     )
 276
 277 EOH3
 278     }
 279     else {
 280         print $h <<EOH4;
 281 #define FEATURE_$NAME\_IS_ENABLED \\
 282     ( \\
 283         CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_$first \\
 284      || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\
 285          FEATURE_IS_ENABLED("$name")) \\
 286     )
 287
 288 EOH4
 289     }
 290 }
 291
 292 print $h <<EOH;
 293
 294 #endif /* PERL_CORE or PERL_EXT */
 295
 296 #ifdef PERL_IN_OP_C
 297 PERL_STATIC_INLINE void
 298 S_enable_feature_bundle(pTHX_ SV *ver)
 299 {
 300     SV *comp_ver = sv_newmortal();
 301     PL_hints = (PL_hints &~ HINT_FEATURE_MASK)
 302              | (
 303 EOH
 304
 305 for (reverse @HintedBundles[1..$#HintedBundles]) { # skip default
 306     my $numver = $_;
 307     if ($numver eq '5.10') { $numver = '5.009005' } # special case
 308     else                   { $numver =~ s/\./.0/  } # 5.11 => 5.011
 309     (my $macrover = $_) =~ y/.//d;
 310     print $h <<"    EOK";
 311                   (sv_setnv(comp_ver, $numver),
 312                    vcmp(ver, upg_version(comp_ver, FALSE)) >= 0)
 313                         ? FEATURE_BUNDLE_$macrover :
 314     EOK
 315 }
 316
 317 print $h <<EOJ;
 318                           FEATURE_BUNDLE_DEFAULT
 319                ) << HINT_FEATURE_SHIFT;
 320     /* special case */
 321     assert(PL_curcop == &PL_compiling);
 322     if (FEATURE_UNICODE_IS_ENABLED) PL_hints |=  HINT_UNI_8_BIT;
 323     else                            PL_hints &= ~HINT_UNI_8_BIT;
 324 }
 325 #endif /* PERL_IN_OP_C */
 326 EOJ
 327
 328 read_only_bottom_close_and_rename($h);
 329
 330
 331 ###########################################################################
 332 # Template for feature.pm
 333
 334 __END__
 335 package feature;
 336
 337 our $VERSION = '1.27';
 338
 339 FEATURES
 340
 341 # TODO:
 342 # - think about versioned features (use feature switch => 2)
 343
 344 =head1 NAME
 345
 346 feature - Perl pragma to enable new features
 347
 348 =head1 SYNOPSIS
 349
 350     use feature qw(say switch);
 351     given ($foo) {
 352         when (1)          { say "\$foo == 1" }
 353         when ([2,3])      { say "\$foo == 2 || \$foo == 3" }
 354         when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
 355         when ($_ > 100)   { say "\$foo > 100" }
 356         default           { say "None of the above" }
 357     }
 358
 359     use feature ':5.10'; # loads all features available in perl 5.10
 360
 361     use v5.10;           # implicitly loads :5.10 feature bundle
 362
 363 =head1 DESCRIPTION
 364
 365 It is usually impossible to add new syntax to Perl without breaking
 366 some existing programs.  This pragma provides a way to minimize that
 367 risk. New syntactic constructs, or new semantic meanings to older
 368 constructs, can be enabled by C<use feature 'foo'>, and will be parsed
 369 only when the appropriate feature pragma is in scope.  (Nevertheless, the
 370 C<CORE::> prefix provides access to all Perl keywords, regardless of this
 371 pragma.)
 372
 373 =head2 Lexical effect
 374
 375 Like other pragmas (C<use strict>, for example), features have a lexical
 376 effect. C<use feature qw(foo)> will only make the feature "foo" available
 377 from that point to the end of the enclosing block.
 378
 379     {
 380         use feature 'say';
 381         say "say is available here";
 382     }
 383     print "But not here.\n";
 384
 385 =head2 C<no feature>
 386
 387 Features can also be turned off by using C<no feature "foo">.  This too
 388 has lexical effect.
 389
 390     use feature 'say';
 391     say "say is available here";
 392     {
 393         no feature 'say';
 394         print "But not here.\n";
 395     }
 396     say "Yet it is here.";
 397
 398 C<no feature> with no features specified will reset to the default group.  To
 399 disable I<all> features (an unusual request!) use C<no feature ':all'>.
 400
 401 =head1 AVAILABLE FEATURES
 402
 403 =head2 The 'say' feature
 404
 405 C<use feature 'say'> tells the compiler to enable the Perl 6 style
 406 C<say> function.
 407
 408 See L<perlfunc/say> for details.
 409
 410 This feature is available starting with Perl 5.10.
 411
 412 =head2 The 'state' feature
 413
 414 C<use feature 'state'> tells the compiler to enable C<state>
 415 variables.
 416
 417 See L<perlsub/"Persistent Private Variables"> for details.
 418
 419 This feature is available starting with Perl 5.10.
 420
 421 =head2 The 'switch' feature
 422
 423 C<use feature 'switch'> tells the compiler to enable the Perl 6
 424 given/when construct.
 425
 426 See L<perlsyn/"Switch Statements"> for details.
 427
 428 This feature is available starting with Perl 5.10.
 429
 430 =head2 The 'unicode_strings' feature
 431
 432 C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
 433 in all string operations executed within its scope (unless they are also
 434 within the scope of either C<use locale> or C<use bytes>).  The same applies
 435 to all regular expressions compiled within the scope, even if executed outside
 436 it.
 437
 438 C<no feature 'unicode_strings'> tells the compiler to use the traditional
 439 Perl semantics wherein the native character set semantics is used unless it is
 440 clear to Perl that Unicode is desired.  This can lead to some surprises
 441 when the behavior suddenly changes.  (See
 442 L<perlunicode/The "Unicode Bug"> for details.)  For this reason, if you are
 443 potentially using Unicode in your program, the
 444 C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
 445
 446 This feature is available starting with Perl 5.12; was almost fully
 447 implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>.
 448
 449 =head2 The 'unicode_eval' and 'evalbytes' features
 450
 451 Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
 452 string, will evaluate it as a string of characters, ignoring any
 453 C<use utf8> declarations.  C<use utf8> exists to declare the encoding of
 454 the script, which only makes sense for a stream of bytes, not a string of
 455 characters.  Source filters are forbidden, as they also really only make
 456 sense on strings of bytes.  Any attempt to activate a source filter will
 457 result in an error.
 458
 459 The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
 460 the argument passed to it as a string of bytes.  It dies if the string
 461 contains any characters outside the 8-bit range.  Source filters work
 462 within C<evalbytes>: they apply to the contents of the string being
 463 evaluated.
 464
 465 Together, these two features are intended to replace the historical C<eval>
 466 function, which has (at least) two bugs in it, that cannot easily be fixed
 467 without breaking existing programs:
 468
 469 =over
 470
 471 =item *
 472
 473 C<eval> behaves differently depending on the internal encoding of the
 474 string, sometimes treating its argument as a string of bytes, and sometimes
 475 as a string of characters.
 476
 477 =item *
 478
 479 Source filters activated within C<eval> leak out into whichever I<file>
 480 scope is currently being compiled.  To give an example with the CPAN module
 481 L<Semi::Semicolons>:
 482
 483     BEGIN { eval "use Semi::Semicolons;  # not filtered here " }
 484     # filtered here!
 485
 486 C<evalbytes> fixes that to work the way one would expect:
 487
 488     use feature "evalbytes";
 489     BEGIN { evalbytes "use Semi::Semicolons;  # filtered " }
 490     # not filtered
 491
 492 =back
 493
 494 These two features are available starting with Perl 5.16.
 495
 496 =head2 The 'current_sub' feature
 497
 498 This provides the C<__SUB__> token that returns a reference to the current
 499 subroutine or C<undef> outside of a subroutine.
 500
 501 This feature is available starting with Perl 5.16.
 502
 503 =head2 The 'array_base' feature
 504
 505 This feature supports the legacy C<$[> variable.  See L<perlvar/$[> and
 506 L<arybase>.  It is on by default but disabled under C<use v5.16> (see
 507 L</IMPLICIT LOADING>, below).
 508
 509 This feature is available under this name starting with Perl 5.16.  In
 510 previous versions, it was simply on all the time, and this pragma knew
 511 nothing about it.
 512
 513 =head2 The 'fc' feature
 514
 515 C<use feature 'fc'> tells the compiler to enable the C<fc> function,
 516 which implements Unicode casefolding.
 517
 518 See L<perlfunc/fc> for details.
 519
 520 This feature is available from Perl 5.16 onwards.
 521
 522 =head1 FEATURE BUNDLES
 523
 524 It's possible to load multiple features together, using
 525 a I<feature bundle>.  The name of a feature bundle is prefixed with
 526 a colon, to distinguish it from an actual feature.
 527
 528   use feature ":5.10";
 529
 530 The following feature bundles are available:
 531
 532   bundle    features included
 533   --------- -----------------
 534 PODTURES
 535 The C<:default> bundle represents the feature set that is enabled before
 536 any C<use feature> or C<no feature> declaration.
 537
 538 Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
 539 no effect.  Feature bundles are guaranteed to be the same for all sub-versions.
 540
 541   use feature ":5.14.0";    # same as ":5.14"
 542   use feature ":5.14.1";    # same as ":5.14"
 543
 544 =head1 IMPLICIT LOADING
 545
 546 Instead of loading feature bundles by name, it is easier to let Perl do
 547 implicit loading of a feature bundle for you.
 548
 549 There are two ways to load the C<feature> pragma implicitly:
 550
 551 =over 4
 552
 553 =item *
 554
 555 By using the C<-E> switch on the Perl command-line instead of C<-e>.
 556 That will enable the feature bundle for that version of Perl in the
 557 main compilation unit (that is, the one-liner that follows C<-E>).
 558
 559 =item *
 560
 561 By explicitly requiring a minimum Perl version number for your program, with
 562 the C<use VERSION> construct.  That is,
 563
 564     use v5.10.0;
 565
 566 will do an implicit
 567
 568     no feature ':all';
 569     use feature ':5.10';
 570
 571 and so on.  Note how the trailing sub-version
 572 is automatically stripped from the
 573 version.
 574
 575 But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
 576
 577     use 5.010;
 578
 579 with the same effect.
 580
 581 If the required version is older than Perl 5.10, the ":default" feature
 582 bundle is automatically loaded instead.
 583
 584 =back
 585
 586 =cut
 587
 588 sub import {
 589     my $class = shift;
 590
 591     if (!@_) {
 592         croak("No features specified");
 593     }
 594
 595     __common(1, @_);
 596 }
 597
 598 sub unimport {
 599     my $class = shift;
 600
 601     # A bare C<no feature> should reset to the default bundle
 602     if (!@_) {
 603         $^H &= ~($hint_uni8bit|$hint_mask);
 604         return;
 605     }
 606
 607     __common(0, @_);
 608 }
 609
 610
 611 sub __common {
 612     my $import = shift;
 613     my $bundle_number = $^H & $hint_mask;
 614     my $features = $bundle_number != $hint_mask
 615         && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
 616     if ($features) {
 617         # Features are enabled implicitly via bundle hints.
 618         # Delete any keys that may be left over from last time.
 619         delete @^H{ values(%feature) };
 620         $^H |= $hint_mask;
 621         for (@$features) {
 622             $^H{$feature{$_}} = 1;
 623             $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
 624         }
 625     }
 626     while (@_) {
 627         my $name = shift;
 628         if (substr($name, 0, 1) eq ":") {
 629             my $v = substr($name, 1);
 630             if (!exists $feature_bundle{$v}) {
 631                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
 632                 if (!exists $feature_bundle{$v}) {
 633                     unknown_feature_bundle(substr($name, 1));
 634                 }
 635             }
 636             unshift @_, @{$feature_bundle{$v}};
 637             next;
 638         }
 639         if (!exists $feature{$name}) {
 640             unknown_feature($name);
 641         }
 642         if ($import) {
 643             $^H{$feature{$name}} = 1;
 644             $^H |= $hint_uni8bit if $name eq 'unicode_strings';
 645         } else {
 646             delete $^H{$feature{$name}};
 647             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
 648         }
 649     }
 650 }
 651
 652 sub unknown_feature {
 653     my $feature = shift;
 654     croak(sprintf('Feature "%s" is not supported by Perl %vd',
 655             $feature, $^V));
 656 }
 657
 658 sub unknown_feature_bundle {
 659     my $feature = shift;
 660     croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
 661             $feature, $^V));
 662 }
 663
 664 sub croak {
 665     require Carp;
 666     Carp::croak(@_);
 667 }
 668
 669 1;