Update release manager documents for producing .xz tarballs
[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     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;