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