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