This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
use VERSION needs to enable uni8bit hint
[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     /* special case */
304     assert(PL_curcop == &PL_compiling);
305     if (FEATURE_UNICODE_IS_ENABLED) PL_hints |=  HINT_UNI_8_BIT;
306     else                            PL_hints &= ~HINT_UNI_8_BIT;
307 }
308 #endif /* PERL_IN_OP_C */
309 EOJ
310
311 read_only_bottom_close_and_rename($h);
312
313
314 ###########################################################################
315 # Template for feature.pm
316
317 __END__
318 package feature;
319
320 our $VERSION = '1.25';
321
322 FEATURES
323
324 # This gets set (for now) in $^H as well as in %^H,
325 # for runtime speed of the uc/lc/ucfirst/lcfirst functions.
326 # See HINT_UNI_8_BIT in perl.h.
327 our $hint_uni8bit = 0x00000800;
328
329 # TODO:
330 # - think about versioned features (use feature switch => 2)
331
332 =head1 NAME
333
334 feature - Perl pragma to enable new features
335
336 =head1 SYNOPSIS
337
338     use feature qw(say switch);
339     given ($foo) {
340         when (1)          { say "\$foo == 1" }
341         when ([2,3])      { say "\$foo == 2 || \$foo == 3" }
342         when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
343         when ($_ > 100)   { say "\$foo > 100" }
344         default           { say "None of the above" }
345     }
346
347     use feature ':5.10'; # loads all features available in perl 5.10
348
349     use v5.10;           # implicitly loads :5.10 feature bundle
350
351 =head1 DESCRIPTION
352
353 It is usually impossible to add new syntax to Perl without breaking
354 some existing programs.  This pragma provides a way to minimize that
355 risk. New syntactic constructs, or new semantic meanings to older
356 constructs, can be enabled by C<use feature 'foo'>, and will be parsed
357 only when the appropriate feature pragma is in scope.  (Nevertheless, the
358 C<CORE::> prefix provides access to all Perl keywords, regardless of this
359 pragma.)
360
361 =head2 Lexical effect
362
363 Like other pragmas (C<use strict>, for example), features have a lexical
364 effect. C<use feature qw(foo)> will only make the feature "foo" available
365 from that point to the end of the enclosing block.
366
367     {
368         use feature 'say';
369         say "say is available here";
370     }
371     print "But not here.\n";
372
373 =head2 C<no feature>
374
375 Features can also be turned off by using C<no feature "foo">.  This too
376 has lexical effect.
377
378     use feature 'say';
379     say "say is available here";
380     {
381         no feature 'say';
382         print "But not here.\n";
383     }
384     say "Yet it is here.";
385
386 C<no feature> with no features specified will turn off all features.
387
388 =head1 AVAILABLE FEATURES
389
390 =head2 The 'say' feature
391
392 C<use feature 'say'> tells the compiler to enable the Perl 6 style
393 C<say> function.
394
395 See L<perlfunc/say> for details.
396
397 This feature is available starting with Perl 5.10.
398
399 =head2 The 'state' feature
400
401 C<use feature 'state'> tells the compiler to enable C<state>
402 variables.
403
404 See L<perlsub/"Persistent Private Variables"> for details.
405
406 This feature is available starting with Perl 5.10.
407
408 =head2 The 'switch' feature
409
410 C<use feature 'switch'> tells the compiler to enable the Perl 6
411 given/when construct.
412
413 See L<perlsyn/"Switch statements"> for details.
414
415 This feature is available starting with Perl 5.10.
416
417 =head2 The 'unicode_strings' feature
418
419 C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
420 in all string operations executed within its scope (unless they are also
421 within the scope of either C<use locale> or C<use bytes>).  The same applies
422 to all regular expressions compiled within the scope, even if executed outside
423 it.
424
425 C<no feature 'unicode_strings'> tells the compiler to use the traditional
426 Perl semantics wherein the native character set semantics is used unless it is
427 clear to Perl that Unicode is desired.  This can lead to some surprises
428 when the behavior suddenly changes.  (See
429 L<perlunicode/The "Unicode Bug"> for details.)  For this reason, if you are
430 potentially using Unicode in your program, the
431 C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
432
433 This feature is available starting with Perl 5.12, but was not fully
434 implemented until Perl 5.14.
435
436 =head2 The 'unicode_eval' and 'evalbytes' features
437
438 Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
439 string, will evaluate it as a string of characters, ignoring any
440 C<use utf8> declarations.  C<use utf8> exists to declare the encoding of
441 the script, which only makes sense for a stream of bytes, not a string of
442 characters.  Source filters are forbidden, as they also really only make
443 sense on strings of bytes.  Any attempt to activate a source filter will
444 result in an error.
445
446 The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
447 the argument passed to it as a string of bytes.  It dies if the string
448 contains any characters outside the 8-bit range.  Source filters work
449 within C<evalbytes>: they apply to the contents of the string being
450 evaluated.
451
452 Together, these two features are intended to replace the historical C<eval>
453 function, which has (at least) two bugs in it, that cannot easily be fixed
454 without breaking existing programs:
455
456 =over
457
458 =item *
459
460 C<eval> behaves differently depending on the internal encoding of the
461 string, sometimes treating its argument as a string of bytes, and sometimes
462 as a string of characters.
463
464 =item *
465
466 Source filters activated within C<eval> leak out into whichever I<file>
467 scope is currently being compiled.  To give an example with the CPAN module
468 L<Semi::Semicolons>:
469
470     BEGIN { eval "use Semi::Semicolons;  # not filtered here " }
471     # filtered here!
472
473 C<evalbytes> fixes that to work the way one would expect:
474
475     use feature "evalbytes";
476     BEGIN { evalbytes "use Semi::Semicolons;  # filtered " }
477     # not filtered
478
479 =back
480
481 These two features are available starting with Perl 5.16.
482
483 =head2 The 'current_sub' feature
484
485 This provides the C<__SUB__> token that returns a reference to the current
486 subroutine or C<undef> outside of a subroutine.
487
488 This feature is available starting with Perl 5.16.
489
490 =head2 The 'array_base' feature
491
492 This feature supports the legacy C<$[> variable.  See L<perlvar/$[> and
493 L<arybase>.  It is on by default but disabled under C<use v5.16> (see
494 L</IMPLICIT LOADING>, below).
495
496 This feature is available under this name starting with Perl 5.16.  In
497 previous versions, it was simply on all the time, and this pragma knew
498 nothing about it.
499
500 =head1 FEATURE BUNDLES
501
502 It's possible to load multiple features together, using
503 a I<feature bundle>.  The name of a feature bundle is prefixed with
504 a colon, to distinguish it from an actual feature.
505
506   use feature ":5.10";
507
508 The following feature bundles are available:
509
510   bundle    features included
511   --------- -----------------
512 PODTURES
513 The C<:default> bundle represents the feature set that is enabled before
514 any C<use feature> or C<no feature> declaration.
515
516 Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
517 no effect.  Feature bundles are guaranteed to be the same for all sub-versions.
518
519   use feature ":5.14.0";    # same as ":5.14"
520   use feature ":5.14.1";    # same as ":5.14"
521
522 =head1 IMPLICIT LOADING
523
524 Instead of loading feature bundles by name, it is easier to let Perl do
525 implicit loading of a feature bundle for you.
526
527 There are two ways to load the C<feature> pragma implicitly:
528
529 =over 4
530
531 =item *
532
533 By using the C<-E> switch on the Perl command-line instead of C<-e>.
534 That will enable the feature bundle for that version of Perl in the
535 main compilation unit (that is, the one-liner that follows C<-E>).
536
537 =item *
538
539 By explicitly requiring a minimum Perl version number for your program, with
540 the C<use VERSION> construct.  That is,
541
542     use v5.10.0;
543
544 will do an implicit
545
546     no feature;
547     use feature ':5.10';
548
549 and so on.  Note how the trailing sub-version
550 is automatically stripped from the
551 version.
552
553 But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
554
555     use 5.010;
556
557 with the same effect.
558
559 If the required version is older than Perl 5.10, the ":default" feature
560 bundle is automatically loaded instead.
561
562 =back
563
564 =cut
565
566 sub current_bundle {
567     my $bundle_number = $^H & $hint_mask;
568     return if $bundle_number == $hint_mask;
569     return $feature_bundle{@hint_bundles[$bundle_number >> $hint_shift]};
570 }
571
572 sub normalise_hints {
573     # Delete any keys that may be left over from last time.
574     delete @^H{ values(%feature) };
575     $^H |= $hint_mask;
576     for (@{+shift}) {
577         $^H{$feature{$_}} = 1;
578         $^H |= $hint_uni8bit if $_ eq 'unicode_strings';
579     }
580 }
581
582 sub import {
583     my $class = shift;
584     if (@_ == 0) {
585         croak("No features specified");
586     }
587     if (my $features = current_bundle) {
588         # Features are enabled implicitly via bundle hints.
589         normalise_hints $features;
590     }
591     while (@_) {
592         my $name = shift(@_);
593         if (substr($name, 0, 1) eq ":") {
594             my $v = substr($name, 1);
595             if (!exists $feature_bundle{$v}) {
596                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
597                 if (!exists $feature_bundle{$v}) {
598                     unknown_feature_bundle(substr($name, 1));
599                 }
600             }
601             unshift @_, @{$feature_bundle{$v}};
602             next;
603         }
604         if (!exists $feature{$name}) {
605             unknown_feature($name);
606         }
607         $^H{$feature{$name}} = 1;
608         $^H |= $hint_uni8bit if $name eq 'unicode_strings';
609     }
610 }
611
612 sub unimport {
613     my $class = shift;
614
615     if (my $features = current_bundle) {
616         # Features are enabled implicitly via bundle hints.
617         normalise_hints $features;
618     }
619
620     # A bare C<no feature> should disable *all* features
621     if (!@_) {
622         delete @^H{ values(%feature) };
623         $^H &= ~ $hint_uni8bit;
624         return;
625     }
626
627     while (@_) {
628         my $name = shift;
629         if (substr($name, 0, 1) eq ":") {
630             my $v = substr($name, 1);
631             if (!exists $feature_bundle{$v}) {
632                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
633                 if (!exists $feature_bundle{$v}) {
634                     unknown_feature_bundle(substr($name, 1));
635                 }
636             }
637             unshift @_, @{$feature_bundle{$v}};
638             next;
639         }
640         if (!exists($feature{$name})) {
641             unknown_feature($name);
642         }
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;