This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2763d0995f5abc09626c5c178e483dc49ed53f9f
[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.
9 #
10 # This script is normally invoked from regen.pl.
11
12 BEGIN {
13     require 'regen/regen_lib.pl';
14     push @INC, './lib';
15 }
16 use strict ;
17
18
19 ###########################################################################
20 # Hand-editable data
21
22 # (feature name) => (internal name, used in %^H and macro names)
23 my %feature = (
24     say             => 'say',
25     state           => 'state',
26     switch          => 'switch',
27     evalbytes       => 'evalbytes',
28     array_base      => 'arybase',
29     current_sub     => '__SUB__',
30     unicode_eval    => 'unieval',
31     unicode_strings => 'unicode',
32 );
33
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
38 my %feature_bundle = (
39      default => [qw(array_base)],
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
52
53 ###########################################################################
54 # More data generated from the above
55
56 my %UniqueBundles; # "say state switch" => 5.10
57 my %Aliases;       #  5.12 => 5.11
58 for( 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 }
67                            # start   end
68 my %BundleRanges; # say => ['5.10', '5.15'] # unique bundles for values
69 for my $bund (
70     sort { $a eq 'default' ? -1 : $b eq 'default' ? 1 : $a cmp $b }
71          values %UniqueBundles
72 ) {
73     next if $bund =~ /[^\d.]/ and $bund ne 'default';
74     for (@{$feature_bundle{$bund}}) {
75         if (@{$BundleRanges{$_} ||= []} == 2) {
76             $BundleRanges{$_}[1] = $bund
77         }
78         else {
79             push @{$BundleRanges{$_}}, $bund;
80         }
81     }
82 }
83
84 my $HintShift;
85 my $HintMask;
86
87 open "perl.h", "perl.h" or die "$0 cannot open perl.h: $!";
88 perlh: {
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 ";
92         my $hex = $HintMask = $1;
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 }
106 close "perl.h";
107
108 my @HintedBundles =
109     ('default', grep !/[^\d.]/, sort values %UniqueBundles);
110
111
112 ###########################################################################
113 # Open files to be generated
114
115 my ($pm, $h) = map {
116     open_new($_, '>', { by => 'regen/feature.pl' });
117 } 'lib/feature.pm', 'feature.h';
118
119
120 ###########################################################################
121 # Generate lib/feature.pm
122
123 while (<DATA>) {
124     last if /^FEATURES$/ ;
125     print $pm $_ ;
126 }
127
128 sub longest {
129     my $long;
130     for(@_) {
131         if (!defined $long or length $long < length) {
132             $long = $_;
133         }
134     }
135     $long;
136 }
137
138 print $pm "my %feature = (\n";
139 my $width = length longest keys %feature;
140 for(sort { length $a <=> length $b } keys %feature) {
141     print $pm "    $_" . " "x($width-length)
142             . " => 'feature_$feature{$_}',\n";
143 }
144 print $pm ");\n\n";
145
146 print $pm "our %feature_bundle = (\n";
147 $width = length longest values %UniqueBundles;
148 for( 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';
153 }
154 print $pm ");\n\n";
155
156 for (sort keys %Aliases) {
157     print $pm
158         qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n';
159 };
160
161 print $pm <<EOPM;
162
163 my \$hint_shift   = $HintShift;
164 my \$hint_mask    = $HintMask;
165 my \@hint_bundles = qw( @HintedBundles );
166 EOPM
167
168
169 while (<DATA>) {
170     last if /^PODTURES$/ ;
171     print $pm $_ ;
172 }
173
174 select +(select($pm), $~ = 'PODTURES')[0];
175 format PODTURES =
176   ^<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
177 $::bundle, $::feature
178 .
179
180 for ('default', sort grep /\.\d[02468]/, keys %feature_bundle) {
181     $::bundle = ":$_";
182     $::feature = join ' ', @{$feature_bundle{$_}};
183     write $pm;
184     print $pm "\n";
185 }
186
187 while (<DATA>) {
188     print $pm $_ ;
189 }
190
191 read_only_bottom_close_and_rename($pm);
192
193
194 ###########################################################################
195 # Generate feature.h
196
197 my $first_bit = sprintf "0x%08x", 1 << $HintShift;
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         (((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
226 EOH
227
228 for (
229     sort { length $a <=> length $b } keys %feature
230 ) {
231     my($first,$last) =
232         map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}};
233     my $name = $feature{$_};
234     my $NAME = uc $name;
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 && \\
241          FEATURE_IS_ENABLED("$name")) \\
242     )
243
244 EOI
245     }
246     elsif ($last) {
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 && \\
253          FEATURE_IS_ENABLED("$name")) \\
254     )
255
256 EOH3
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 && \\
264          FEATURE_IS_ENABLED("$name")) \\
265     )
266
267 EOH4
268     }
269 }
270
271 print $h <<EOH;
272
273 #endif /* PERL_CORE or PERL_EXT */
274
275 #ifdef PERL_IN_OP_C
276 PERL_STATIC_INLINE void
277 S_enable_feature_bundle(pTHX_ SV *ver)
278 {
279     SV *comp_ver = sv_newmortal();
280     PL_hints = (PL_hints &~ HINT_FEATURE_MASK)
281              | (
282 EOH
283
284 for (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
296 print $h <<EOJ;
297                           FEATURE_BUNDLE_DEFAULT
298                ) << HINT_FEATURE_SHIFT;
299 }
300 #endif /* PERL_IN_OP_C */
301 EOJ
302
303 read_only_bottom_close_and_rename($h);
304
305
306 ###########################################################################
307 # Template for feature.pm
308
309 __END__
310 package feature;
311
312 our $VERSION = '1.25';
313
314 FEATURES
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.
319 our $hint_uni8bit = 0x00000800;
320
321 # TODO:
322 # - think about versioned features (use feature switch => 2)
323
324 =head1 NAME
325
326 feature - 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
345 It is usually impossible to add new syntax to Perl without breaking
346 some existing programs.  This pragma provides a way to minimize that
347 risk. New syntactic constructs, or new semantic meanings to older
348 constructs, can be enabled by C<use feature 'foo'>, and will be parsed
349 only when the appropriate feature pragma is in scope.  (Nevertheless, the
350 C<CORE::> prefix provides access to all Perl keywords, regardless of this
351 pragma.)
352
353 =head2 Lexical effect
354
355 Like other pragmas (C<use strict>, for example), features have a lexical
356 effect. C<use feature qw(foo)> will only make the feature "foo" available
357 from 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
367 Features can also be turned off by using C<no feature "foo">.  This too
368 has 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
378 C<no feature> with no features specified will turn off all features.
379
380 =head1 AVAILABLE FEATURES
381
382 =head2 The 'say' feature
383
384 C<use feature 'say'> tells the compiler to enable the Perl 6 style
385 C<say> function.
386
387 See L<perlfunc/say> for details.
388
389 This feature is available starting with Perl 5.10.
390
391 =head2 The 'state' feature
392
393 C<use feature 'state'> tells the compiler to enable C<state>
394 variables.
395
396 See L<perlsub/"Persistent Private Variables"> for details.
397
398 This feature is available starting with Perl 5.10.
399
400 =head2 The 'switch' feature
401
402 C<use feature 'switch'> tells the compiler to enable the Perl 6
403 given/when construct.
404
405 See L<perlsyn/"Switch statements"> for details.
406
407 This feature is available starting with Perl 5.10.
408
409 =head2 The 'unicode_strings' feature
410
411 C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
412 in all string operations executed within its scope (unless they are also
413 within the scope of either C<use locale> or C<use bytes>).  The same applies
414 to all regular expressions compiled within the scope, even if executed outside
415 it.
416
417 C<no feature 'unicode_strings'> tells the compiler to use the traditional
418 Perl semantics wherein the native character set semantics is used unless it is
419 clear to Perl that Unicode is desired.  This can lead to some surprises
420 when the behavior suddenly changes.  (See
421 L<perlunicode/The "Unicode Bug"> for details.)  For this reason, if you are
422 potentially using Unicode in your program, the
423 C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
424
425 This feature is available starting with Perl 5.12, but was not fully
426 implemented until Perl 5.14.
427
428 =head2 The 'unicode_eval' and 'evalbytes' features
429
430 Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
431 string, will evaluate it as a string of characters, ignoring any
432 C<use utf8> declarations.  C<use utf8> exists to declare the encoding of
433 the script, which only makes sense for a stream of bytes, not a string of
434 characters.  Source filters are forbidden, as they also really only make
435 sense on strings of bytes.  Any attempt to activate a source filter will
436 result in an error.
437
438 The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
439 the argument passed to it as a string of bytes.  It dies if the string
440 contains any characters outside the 8-bit range.  Source filters work
441 within C<evalbytes>: they apply to the contents of the string being
442 evaluated.
443
444 Together, these two features are intended to replace the historical C<eval>
445 function, which has (at least) two bugs in it, that cannot easily be fixed
446 without breaking existing programs:
447
448 =over
449
450 =item *
451
452 C<eval> behaves differently depending on the internal encoding of the
453 string, sometimes treating its argument as a string of bytes, and sometimes
454 as a string of characters.
455
456 =item *
457
458 Source filters activated within C<eval> leak out into whichever I<file>
459 scope is currently being compiled.  To give an example with the CPAN module
460 L<Semi::Semicolons>:
461
462     BEGIN { eval "use Semi::Semicolons;  # not filtered here " }
463     # filtered here!
464
465 C<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
473 These two features are available starting with Perl 5.16.
474
475 =head2 The 'current_sub' feature
476
477 This provides the C<__SUB__> token that returns a reference to the current
478 subroutine or C<undef> outside of a subroutine.
479
480 This feature is available starting with Perl 5.16.
481
482 =head2 The 'array_base' feature
483
484 This feature supports the legacy C<$[> variable.  See L<perlvar/$[> and
485 L<arybase>.  It is on by default but disabled under C<use v5.16> (see
486 L</IMPLICIT LOADING>, below).
487
488 This feature is available under this name starting with Perl 5.16.  In
489 previous versions, it was simply on all the time, and this pragma knew
490 nothing about it.
491
492 =head1 FEATURE BUNDLES
493
494 It's possible to load multiple features together, using
495 a I<feature bundle>.  The name of a feature bundle is prefixed with
496 a colon, to distinguish it from an actual feature.
497
498   use feature ":5.10";
499
500 The following feature bundles are available:
501
502   bundle    features included
503   --------- -----------------
504 PODTURES
505 The C<:default> bundle represents the feature set that is enabled before
506 any C<use feature> or C<no feature> declaration.
507
508 Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
509 no 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
516 Instead of loading feature bundles by name, it is easier to let Perl do
517 implicit loading of a feature bundle for you.
518
519 There are two ways to load the C<feature> pragma implicitly:
520
521 =over 4
522
523 =item *
524
525 By using the C<-E> switch on the Perl command-line instead of C<-e>.
526 That will enable the feature bundle for that version of Perl in the
527 main compilation unit (that is, the one-liner that follows C<-E>).
528
529 =item *
530
531 By explicitly requiring a minimum Perl version number for your program, with
532 the C<use VERSION> construct.  That is,
533
534     use v5.10.0;
535
536 will do an implicit
537
538     no feature;
539     use feature ':5.10';
540
541 and so on.  Note how the trailing sub-version
542 is automatically stripped from the
543 version.
544
545 But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
546
547     use 5.010;
548
549 with the same effect.
550
551 If the required version is older than Perl 5.10, the ":default" feature
552 bundle is automatically loaded instead.
553
554 =back
555
556 =cut
557
558 sub 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
564 sub import {
565     my $class = shift;
566     if (@_ == 0) {
567         croak("No features specified");
568     }
569     if (my $features = current_bundle) {
570         # Features are enabled implicitly via bundle hints
571         unshift @_, @$features;
572         $^H |= $hint_mask;
573     }
574     while (@_) {
575         my $name = shift(@_);
576         if (substr($name, 0, 1) eq ":") {
577             my $v = substr($name, 1);
578             if (!exists $feature_bundle{$v}) {
579                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
580                 if (!exists $feature_bundle{$v}) {
581                     unknown_feature_bundle(substr($name, 1));
582                 }
583             }
584             unshift @_, @{$feature_bundle{$v}};
585             next;
586         }
587         if (!exists $feature{$name}) {
588             unknown_feature($name);
589         }
590         $^H{$feature{$name}} = 1;
591         $^H |= $hint_uni8bit if $name eq 'unicode_strings';
592     }
593 }
594
595 sub unimport {
596     my $class = shift;
597
598     if (my $features = current_bundle) {
599         # Features are enabled implicitly via bundle hints
600         # Pass them to import() to put them in a form we can handle.
601         import(undef, @$features);
602         $^H |= $hint_mask;
603     }
604
605     # A bare C<no feature> should disable *all* features
606     if (!@_) {
607         delete @^H{ values(%feature) };
608         $^H &= ~ $hint_uni8bit;
609         return;
610     }
611
612     while (@_) {
613         my $name = shift;
614         if (substr($name, 0, 1) eq ":") {
615             my $v = substr($name, 1);
616             if (!exists $feature_bundle{$v}) {
617                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
618                 if (!exists $feature_bundle{$v}) {
619                     unknown_feature_bundle(substr($name, 1));
620                 }
621             }
622             unshift @_, @{$feature_bundle{$v}};
623             next;
624         }
625         if (!exists($feature{$name})) {
626             unknown_feature($name);
627         }
628         else {
629             delete $^H{$feature{$name}};
630             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
631         }
632     }
633 }
634
635 sub unknown_feature {
636     my $feature = shift;
637     croak(sprintf('Feature "%s" is not supported by Perl %vd',
638             $feature, $^V));
639 }
640
641 sub unknown_feature_bundle {
642     my $feature = shift;
643     croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
644             $feature, $^V));
645 }
646
647 sub croak {
648     require Carp;
649     Carp::croak(@_);
650 }
651
652 1;