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