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
CommitLineData
69bcf1d3
FC
1#!/usr/bin/perl
2#
3# Regenerate (overwriting only if changed):
4#
5# lib/feature.pm
f2c01b15 6# feature.h
69bcf1d3 7#
d73d634c
FC
8# from information hardcoded into this script and from one #define
9# in perl.h.
69bcf1d3
FC
10#
11# This script is normally invoked from regen.pl.
12
13BEGIN {
14 require 'regen/regen_lib.pl';
15 push @INC, './lib';
16}
17use strict ;
18
c452a42f
FC
19
20###########################################################################
21# Hand-editable data
22
c6b36e45 23# (feature name) => (internal name, used in %^H and macro names)
69bcf1d3 24my %feature = (
67bdaa9e
FC
25 say => 'say',
26 state => 'state',
27 switch => 'switch',
28 evalbytes => 'evalbytes',
3fff3427 29 array_base => 'arybase',
67bdaa9e
FC
30 current_sub => '__SUB__',
31 unicode_eval => 'unieval',
32 unicode_strings => 'unicode',
69bcf1d3
FC
33);
34
40e4d872
FC
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
69bcf1d3 39my %feature_bundle = (
3fff3427 40 default => [qw(array_base)],
69bcf1d3
FC
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
c452a42f 53
69bcf1d3 54###########################################################################
c452a42f 55# More data generated from the above
69bcf1d3 56
f2c01b15
FC
57my %UniqueBundles; # "say state switch" => 5.10
58my %Aliases; # 5.12 => 5.11
59for( 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}
40e4d872
FC
68 # start end
69my %BundleRanges; # say => ['5.10', '5.15'] # unique bundles for values
70for my $bund (
71 sort { $a eq 'default' ? -1 : $b eq 'default' ? 1 : $a cmp $b }
72 values %UniqueBundles
73) {
03222170 74 next if $bund =~ /[^\d.]/ and $bund ne 'default';
40e4d872
FC
75 for (@{$feature_bundle{$bund}}) {
76 if (@{$BundleRanges{$_} ||= []} == 2) {
77 $BundleRanges{$_}[1] = $bund
78 }
79 else {
80 push @{$BundleRanges{$_}}, $bund;
81 }
82 }
83}
69bcf1d3 84
47222a2d 85my $HintShift;
ada44f8c 86my $HintMask;
47222a2d
FC
87
88open "perl.h", "perl.h" or die "$0 cannot open perl.h: $!";
89perlh: {
90 while (readline "perl.h") {
19109a04 91 next unless /#\s*define\s+HINT_FEATURE_MASK/;
47222a2d 92 /(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n ";
ada44f8c 93 my $hex = $HintMask = $1;
47222a2d
FC
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}
107close "perl.h";
108
ada44f8c
FC
109my @HintedBundles =
110 ('default', grep !/[^\d.]/, sort values %UniqueBundles);
111
47222a2d 112
f2c01b15 113###########################################################################
c452a42f 114# Open files to be generated
f2c01b15
FC
115
116my ($pm, $h) = map {
69bcf1d3 117 open_new($_, '>', { by => 'regen/feature.pl' });
f2c01b15 118} 'lib/feature.pm', 'feature.h';
69bcf1d3
FC
119
120
c452a42f
FC
121###########################################################################
122# Generate lib/feature.pm
123
69bcf1d3
FC
124while (<DATA>) {
125 last if /^FEATURES$/ ;
126 print $pm $_ ;
127}
128
129sub longest {
130 my $long;
131 for(@_) {
132 if (!defined $long or length $long < length) {
133 $long = $_;
134 }
135 }
136 $long;
137}
138
139print $pm "my %feature = (\n";
140my $width = length longest keys %feature;
141for(sort { length $a <=> length $b } keys %feature) {
67bdaa9e
FC
142 print $pm " $_" . " "x($width-length)
143 . " => 'feature_$feature{$_}',\n";
69bcf1d3
FC
144}
145print $pm ");\n\n";
146
69bcf1d3 147print $pm "our %feature_bundle = (\n";
88da30d7
FC
148$width = length longest values %UniqueBundles;
149for( 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';
69bcf1d3
FC
154}
155print $pm ");\n\n";
156
88da30d7
FC
157for (sort keys %Aliases) {
158 print $pm
159 qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n';
160};
69bcf1d3 161
ada44f8c
FC
162print $pm <<EOPM;
163
164my \$hint_shift = $HintShift;
165my \$hint_mask = $HintMask;
166my \@hint_bundles = qw( @HintedBundles );
167EOPM
168
69bcf1d3
FC
169
170while (<DATA>) {
2b3fe414
FC
171 last if /^PODTURES$/ ;
172 print $pm $_ ;
173}
174
175select +(select($pm), $~ = 'PODTURES')[0];
176format PODTURES =
177 ^<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
178$::bundle, $::feature
179.
180
181for ('default', sort grep /\.\d[02468]/, keys %feature_bundle) {
182 $::bundle = ":$_";
183 $::feature = join ' ', @{$feature_bundle{$_}};
184 write $pm;
185 print $pm "\n";
186}
187
188while (<DATA>) {
69bcf1d3
FC
189 print $pm $_ ;
190}
191
192read_only_bottom_close_and_rename($pm);
193
c452a42f
FC
194
195###########################################################################
196# Generate feature.h
197
f2c01b15
FC
198print $h <<EOH;
199
200#if defined(PERL_CORE) || defined (PERL_EXT)
201
202#define HINT_FEATURE_SHIFT $HintShift
203
f2c01b15
FC
204EOH
205
206my $count;
016d11cb
FC
207for (@HintedBundles) {
208 (my $key = uc) =~ y/.//d;
209 print $h "#define FEATURE_BUNDLE_$key ", $count++, "\n";
f2c01b15
FC
210}
211
7d058bc9 212print $h <<'EOH';
2b9e0ab7 213#define FEATURE_BUNDLE_CUSTOM (HINT_FEATURE_MASK >> HINT_FEATURE_SHIFT)
f2c01b15 214
7d058bc9 215#define CURRENT_HINTS \
d1fd0100
FC
216 (PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints)
217#define CURRENT_FEATURE_BUNDLE (CURRENT_HINTS >> HINT_FEATURE_SHIFT)
218
7d058bc9 219#define FEATURE_IS_ENABLED(name) \
ef744b29 220 ((CURRENT_HINTS \
7d058bc9
FC
221 & HINT_LOCALIZE_HH) \
222 && Perl_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
223/* The longest string we pass in. */
03222170
FC
224EOH
225
1b6e8741
FC
226my $longest_internal_feature_name = longest values %feature;
227print $h <<EOL;
228#define MAX_FEATURE_LEN (sizeof("$longest_internal_feature_name")-1)
229
230EOL
231
03222170 232for (
3fff3427 233 sort { length $a <=> length $b } keys %feature
03222170
FC
234) {
235 my($first,$last) =
236 map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}};
3fff3427 237 my $name = $feature{$_};
03222170 238 my $NAME = uc $name;
beda0318
FC
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 && \\
3fff3427 245 FEATURE_IS_ENABLED("$name")) \\
beda0318
FC
246 )
247
248EOI
249 }
250 elsif ($last) {
03222170
FC
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 && \\
3fff3427 257 FEATURE_IS_ENABLED("$name")) \\
03222170
FC
258 )
259
260EOH3
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 && \\
3fff3427 268 FEATURE_IS_ENABLED("$name")) \\
03222170
FC
269 )
270
271EOH4
272 }
273}
274
275print $h <<EOH;
276
f2c01b15 277#endif /* PERL_CORE or PERL_EXT */
4160ddbd
FC
278
279#ifdef PERL_IN_OP_C
280PERL_STATIC_INLINE void
281S_enable_feature_bundle(pTHX_ SV *ver)
282{
283 SV *comp_ver = sv_newmortal();
284 PL_hints = (PL_hints &~ HINT_FEATURE_MASK)
285 | (
f2c01b15
FC
286EOH
287
4160ddbd
FC
288for (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
300print $h <<EOJ;
301 FEATURE_BUNDLE_DEFAULT
302 ) << HINT_FEATURE_SHIFT;
6389c777
FC
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;
4160ddbd
FC
307}
308#endif /* PERL_IN_OP_C */
309EOJ
310
f2c01b15
FC
311read_only_bottom_close_and_rename($h);
312
c452a42f
FC
313
314###########################################################################
315# Template for feature.pm
316
69bcf1d3
FC
317__END__
318package feature;
319
320our $VERSION = '1.25';
321
322FEATURES
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.
327our $hint_uni8bit = 0x00000800;
328
329# TODO:
330# - think about versioned features (use feature switch => 2)
331
332=head1 NAME
333
334feature - 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
353It is usually impossible to add new syntax to Perl without breaking
354some existing programs. This pragma provides a way to minimize that
355risk. New syntactic constructs, or new semantic meanings to older
356constructs, can be enabled by C<use feature 'foo'>, and will be parsed
357only when the appropriate feature pragma is in scope. (Nevertheless, the
358C<CORE::> prefix provides access to all Perl keywords, regardless of this
359pragma.)
360
361=head2 Lexical effect
362
363Like other pragmas (C<use strict>, for example), features have a lexical
364effect. C<use feature qw(foo)> will only make the feature "foo" available
365from 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
375Features can also be turned off by using C<no feature "foo">. This too
376has 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
386C<no feature> with no features specified will turn off all features.
387
388=head1 AVAILABLE FEATURES
389
390=head2 The 'say' feature
391
392C<use feature 'say'> tells the compiler to enable the Perl 6 style
393C<say> function.
394
395See L<perlfunc/say> for details.
396
397This feature is available starting with Perl 5.10.
398
399=head2 The 'state' feature
400
401C<use feature 'state'> tells the compiler to enable C<state>
402variables.
403
404See L<perlsub/"Persistent Private Variables"> for details.
405
406This feature is available starting with Perl 5.10.
407
408=head2 The 'switch' feature
409
410C<use feature 'switch'> tells the compiler to enable the Perl 6
411given/when construct.
412
413See L<perlsyn/"Switch statements"> for details.
414
415This feature is available starting with Perl 5.10.
416
417=head2 The 'unicode_strings' feature
418
419C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
420in all string operations executed within its scope (unless they are also
421within the scope of either C<use locale> or C<use bytes>). The same applies
422to all regular expressions compiled within the scope, even if executed outside
423it.
424
425C<no feature 'unicode_strings'> tells the compiler to use the traditional
426Perl semantics wherein the native character set semantics is used unless it is
427clear to Perl that Unicode is desired. This can lead to some surprises
428when the behavior suddenly changes. (See
429L<perlunicode/The "Unicode Bug"> for details.) For this reason, if you are
430potentially using Unicode in your program, the
431C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
432
433This feature is available starting with Perl 5.12, but was not fully
434implemented until Perl 5.14.
435
436=head2 The 'unicode_eval' and 'evalbytes' features
437
438Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
439string, will evaluate it as a string of characters, ignoring any
440C<use utf8> declarations. C<use utf8> exists to declare the encoding of
441the script, which only makes sense for a stream of bytes, not a string of
442characters. Source filters are forbidden, as they also really only make
443sense on strings of bytes. Any attempt to activate a source filter will
444result in an error.
445
446The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
447the argument passed to it as a string of bytes. It dies if the string
448contains any characters outside the 8-bit range. Source filters work
449within C<evalbytes>: they apply to the contents of the string being
450evaluated.
451
452Together, these two features are intended to replace the historical C<eval>
453function, which has (at least) two bugs in it, that cannot easily be fixed
454without breaking existing programs:
455
456=over
457
458=item *
459
460C<eval> behaves differently depending on the internal encoding of the
461string, sometimes treating its argument as a string of bytes, and sometimes
462as a string of characters.
463
464=item *
465
466Source filters activated within C<eval> leak out into whichever I<file>
467scope is currently being compiled. To give an example with the CPAN module
468L<Semi::Semicolons>:
469
470 BEGIN { eval "use Semi::Semicolons; # not filtered here " }
471 # filtered here!
472
473C<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
481These two features are available starting with Perl 5.16.
482
483=head2 The 'current_sub' feature
484
485This provides the C<__SUB__> token that returns a reference to the current
486subroutine or C<undef> outside of a subroutine.
487
488This feature is available starting with Perl 5.16.
489
490=head2 The 'array_base' feature
491
492This feature supports the legacy C<$[> variable. See L<perlvar/$[> and
493L<arybase>. It is on by default but disabled under C<use v5.16> (see
494L</IMPLICIT LOADING>, below).
495
496This feature is available under this name starting with Perl 5.16. In
497previous versions, it was simply on all the time, and this pragma knew
498nothing about it.
499
500=head1 FEATURE BUNDLES
501
502It's possible to load multiple features together, using
503a I<feature bundle>. The name of a feature bundle is prefixed with
504a colon, to distinguish it from an actual feature.
505
506 use feature ":5.10";
507
508The following feature bundles are available:
509
510 bundle features included
511 --------- -----------------
2b3fe414 512PODTURES
69bcf1d3
FC
513The C<:default> bundle represents the feature set that is enabled before
514any C<use feature> or C<no feature> declaration.
515
516Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
517no 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
524Instead of loading feature bundles by name, it is easier to let Perl do
525implicit loading of a feature bundle for you.
526
527There are two ways to load the C<feature> pragma implicitly:
528
529=over 4
530
531=item *
532
533By using the C<-E> switch on the Perl command-line instead of C<-e>.
534That will enable the feature bundle for that version of Perl in the
535main compilation unit (that is, the one-liner that follows C<-E>).
536
537=item *
538
539By explicitly requiring a minimum Perl version number for your program, with
540the C<use VERSION> construct. That is,
541
542 use v5.10.0;
543
544will do an implicit
545
546 no feature;
547 use feature ':5.10';
548
549and so on. Note how the trailing sub-version
550is automatically stripped from the
551version.
552
553But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
554
555 use 5.010;
556
557with the same effect.
558
559If the required version is older than Perl 5.10, the ":default" feature
560bundle is automatically loaded instead.
561
562=back
563
564=cut
565
9c1e3432
FC
566sub 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
83141fdc
FC
572sub 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
69bcf1d3
FC
582sub import {
583 my $class = shift;
584 if (@_ == 0) {
585 croak("No features specified");
586 }
1e0dc09f 587 if (my $features = current_bundle) {
6634bb9d 588 # Features are enabled implicitly via bundle hints.
83141fdc 589 normalise_hints $features;
1e0dc09f 590 }
69bcf1d3
FC
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}) {
69bcf1d3 605 unknown_feature($name);
69bcf1d3
FC
606 }
607 $^H{$feature{$name}} = 1;
608 $^H |= $hint_uni8bit if $name eq 'unicode_strings';
609 }
610}
611
612sub unimport {
613 my $class = shift;
614
1e0dc09f 615 if (my $features = current_bundle) {
83141fdc
FC
616 # Features are enabled implicitly via bundle hints.
617 normalise_hints $features;
1e0dc09f
FC
618 }
619
69bcf1d3
FC
620 # A bare C<no feature> should disable *all* features
621 if (!@_) {
622 delete @^H{ values(%feature) };
623 $^H &= ~ $hint_uni8bit;
69bcf1d3
FC
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})) {
69bcf1d3 641 unknown_feature($name);
69bcf1d3
FC
642 }
643 else {
644 delete $^H{$feature{$name}};
645 $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
646 }
647 }
648}
649
650sub unknown_feature {
651 my $feature = shift;
652 croak(sprintf('Feature "%s" is not supported by Perl %vd',
653 $feature, $^V));
654}
655
656sub unknown_feature_bundle {
657 my $feature = shift;
658 croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
659 $feature, $^V));
660}
661
662sub croak {
663 require Carp;
664 Carp::croak(@_);
665}
666
6671;