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.38';
 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 'signatures' feature
 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::signatures";
 581
 582 This enables unpacking of subroutine arguments into lexical variables
 583 by syntax such as
 584
 585     sub foo ($left, $right) {
 586         return $left + $right;
 587     }
 588
 589 See L<perlsub/Signatures> for details.
 590
 591 This feature is available from Perl 5.20 onwards.
 592
 593 =head2 The 'refaliasing' feature
 594
 595 B<WARNING>: This feature is still experimental and the implementation may
 596 change in future versions of Perl.  For this reason, Perl will
 597 warn when you use the feature, unless you have explicitly disabled the
 598 warning:
 599
 600     no warnings "experimental::refaliasing";
 601
 602 This enables aliasing via assignment to references:
 603
 604     \$a = \$b; # $a and $b now point to the same scalar
 605     \@a = \@b; #                     to the same array
 606     \%a = \%b;
 607     \&a = \&b;
 608     foreach \%hash (@array_of_hash_refs) {
 609         ...
 610     }
 611
 612 See L<perlref/Assigning to References> for details.
 613
 614 This feature is available from Perl 5.22 onwards.
 615
 616 =head1 FEATURE BUNDLES
 617
 618 It's possible to load multiple features together, using
 619 a I<feature bundle>.  The name of a feature bundle is prefixed with
 620 a colon, to distinguish it from an actual feature.
 621
 622   use feature ":5.10";
 623
 624 The following feature bundles are available:
 625
 626   bundle    features included
 627   --------- -----------------
 628 PODTURES
 629 The C<:default> bundle represents the feature set that is enabled before
 630 any C<use feature> or C<no feature> declaration.
 631
 632 Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
 633 no effect.  Feature bundles are guaranteed to be the same for all sub-versions.
 634
 635   use feature ":5.14.0";    # same as ":5.14"
 636   use feature ":5.14.1";    # same as ":5.14"
 637
 638 =head1 IMPLICIT LOADING
 639
 640 Instead of loading feature bundles by name, it is easier to let Perl do
 641 implicit loading of a feature bundle for you.
 642
 643 There are two ways to load the C<feature> pragma implicitly:
 644
 645 =over 4
 646
 647 =item *
 648
 649 By using the C<-E> switch on the Perl command-line instead of C<-e>.
 650 That will enable the feature bundle for that version of Perl in the
 651 main compilation unit (that is, the one-liner that follows C<-E>).
 652
 653 =item *
 654
 655 By explicitly requiring a minimum Perl version number for your program, with
 656 the C<use VERSION> construct.  That is,
 657
 658     use v5.10.0;
 659
 660 will do an implicit
 661
 662     no feature ':all';
 663     use feature ':5.10';
 664
 665 and so on.  Note how the trailing sub-version
 666 is automatically stripped from the
 667 version.
 668
 669 But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
 670
 671     use 5.010;
 672
 673 with the same effect.
 674
 675 If the required version is older than Perl 5.10, the ":default" feature
 676 bundle is automatically loaded instead.
 677
 678 =back
 679
 680 =cut
 681
 682 sub import {
 683     my $class = shift;
 684
 685     if (!@_) {
 686         croak("No features specified");
 687     }
 688
 689     __common(1, @_);
 690 }
 691
 692 sub unimport {
 693     my $class = shift;
 694
 695     # A bare C<no feature> should reset to the default bundle
 696     if (!@_) {
 697         $^H &= ~($hint_uni8bit|$hint_mask);
 698         return;
 699     }
 700
 701     __common(0, @_);
 702 }
 703
 704
 705 sub __common {
 706     my $import = shift;
 707     my $bundle_number = $^H & $hint_mask;
 708     my $features = $bundle_number != $hint_mask
 709         && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
 710     if ($features) {
 711         # Features are enabled implicitly via bundle hints.
 712         # Delete any keys that may be left over from last time.
 713         delete @^H{ values(%feature) };
 714         $^H |= $hint_mask;
 715         for (@$features) {
 716             $^H{$feature{$_}} = 1;
 717             $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
 718         }
 719     }
 720     while (@_) {
 721         my $name = shift;
 722         if (substr($name, 0, 1) eq ":") {
 723             my $v = substr($name, 1);
 724             if (!exists $feature_bundle{$v}) {
 725                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
 726                 if (!exists $feature_bundle{$v}) {
 727                     unknown_feature_bundle(substr($name, 1));
 728                 }
 729             }
 730             unshift @_, @{$feature_bundle{$v}};
 731             next;
 732         }
 733         if (!exists $feature{$name}) {
 734             unknown_feature($name);
 735         }
 736         if ($import) {
 737             $^H{$feature{$name}} = 1;
 738             $^H |= $hint_uni8bit if $name eq 'unicode_strings';
 739         } else {
 740             delete $^H{$feature{$name}};
 741             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
 742         }
 743     }
 744 }
 745
 746 sub unknown_feature {
 747     my $feature = shift;
 748     croak(sprintf('Feature "%s" is not supported by Perl %vd',
 749             $feature, $^V));
 750 }
 751
 752 sub unknown_feature_bundle {
 753     my $feature = shift;
 754     croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
 755             $feature, $^V));
 756 }
 757
 758 sub croak {
 759     require Carp;
 760     Carp::croak(@_);
 761 }
 762
 763 1;