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