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