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