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