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