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