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