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