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