Mercurial > repo

comparison perl-5.22.2/regen/feature.pl @ 8045:a16537d2fe07

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author HackBot
date Sat, 14 May 2016 14:54:38 +0000
parents
children
comparison
equal deleted inserted replaced
8044:711c038a7dce 8045:a16537d2fe07
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;