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