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