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