This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d4e23368a3309dacc12b1bdfeb9952cf349c8888
[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 # (feature name) => (internal name, used in %^H)
19 my %feature = (
20     say             => 'feature_say',
21     state           => 'feature_state',
22     switch          => 'feature_switch',
23     evalbytes       => 'feature_evalbytes',
24     current_sub     => 'feature___SUB__',
25     unicode_eval    => 'feature_unieval',
26     unicode_strings => 'feature_unicode',
27 );
28
29 # These work backwards--the presence of the hint elem disables the feature:
30 my %default_feature = (
31     array_base      => 'feature_no$[',
32 );
33
34 my %feature_bundle = (
35      default => [keys %default_feature],
36     "5.9.5"  => [qw(say state switch array_base)],
37     "5.10"   => [qw(say state switch array_base)],
38     "5.11"   => [qw(say state switch unicode_strings array_base)],
39     "5.12"   => [qw(say state switch unicode_strings array_base)],
40     "5.13"   => [qw(say state switch unicode_strings array_base)],
41     "5.14"   => [qw(say state switch unicode_strings array_base)],
42     "5.15"   => [qw(say state switch unicode_strings unicode_eval
43                     evalbytes current_sub)],
44     "5.16"   => [qw(say state switch unicode_strings unicode_eval
45                     evalbytes current_sub)],
46 );
47
48 ###########################################################################
49
50 my %UniqueBundles; # "say state switch" => 5.10
51 my %Aliases;       #  5.12 => 5.11
52 for( sort keys %feature_bundle ) {
53     my $value = join(' ', sort @{$feature_bundle{$_}});
54     if (exists $UniqueBundles{$value}) {
55         $Aliases{$_} = $UniqueBundles{$value};
56     }
57     else {
58         $UniqueBundles{$value} = $_;
59     }
60 }
61
62 ###########################################################################
63
64
65 my ($pm, $h) = map {
66     open_new($_, '>', { by => 'regen/feature.pl' });
67 } 'lib/feature.pm', 'feature.h';
68
69
70 while (<DATA>) {
71     last if /^FEATURES$/ ;
72     print $pm $_ ;
73 }
74
75 sub longest {
76     my $long;
77     for(@_) {
78         if (!defined $long or length $long < length) {
79             $long = $_;
80         }
81     }
82     $long;
83 }
84
85 print $pm "my %feature = (\n";
86 my $width = length longest keys %feature;
87 for(sort { length $a <=> length $b } keys %feature) {
88     print $pm "    $_" . " "x($width-length) . " => '$feature{$_}',\n";
89 }
90 print $pm ");\n\n";
91
92 print $pm "my %default_feature = (\n";
93 $width = length longest keys %default_feature;
94 for(sort { length $a <=> length $b } keys %default_feature) {
95     print $pm "    $_" . " "x($width-length)
96         . " => '$default_feature{$_}',\n";
97 }
98 print $pm ");\n\n";
99
100 print $pm "our %feature_bundle = (\n";
101 my $prevkey;
102 my $prev;
103 my @same;
104 $width = length longest keys %feature_bundle;
105 for( sort keys %feature_bundle ) {
106     my $value = join(' ', sort @{$feature_bundle{$_}});
107     if (/^5\.\d\d\z/ && $prevkey
108          && substr($_,-2) - substr($prevkey,-2) == 1 && $value eq $prev) {
109         push @same, $_;
110         $prevkey = $_;
111         next;
112     }
113     if(/^5\.\d\d\z/) {
114         $prev = $value;
115         $prevkey = $_;
116     }
117     print $pm qq'    "$_"' . " "x($width-length) . qq' => [qw($value)],\n';
118 }
119 print $pm ");\n\n";
120
121 print $pm "
122 # Each of these is the same as the previous bundle
123 for (", join(',',map /\.(.*)/, @same), ') {
124     $feature_bundle{"5.$_"} = $feature_bundle{"5.".($_-1)}
125 }';
126
127
128 while (<DATA>) {
129     print $pm $_ ;
130 }
131
132 read_only_bottom_close_and_rename($pm);
133
134 my $HintShift;
135
136 open "perl.h", "perl.h" or die "$0 cannot open perl.h: $!";
137 perlh: {
138     while (readline "perl.h") {
139         next unless /#define\s+HINT_FEATURE_MASK/;
140         /(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n ";
141         my $hex = $1;
142         my $bits = sprintf "%b", oct $1;
143         $bits =~ /^0*1+(0*)\z/
144          or die "Non-contiguous bits in $bits (binary for $hex):\n\n$_\n ";
145         $HintShift = length $1;
146         my $bits_needed =
147             length sprintf "%b", scalar keys(%feature_bundle) - @same;
148         $bits =~ /1{$bits_needed}/
149             or die "Not enough bits (need $bits_needed)"
150                  . " in $bits (binary for $hex):\n\n$_\n";
151         last perlh;
152     }
153     die "No HINT_FEATURE_MASK defined in perl.h";
154 }
155 close "perl.h";
156
157 my $first_bit = sprintf "0x%08x", 1 << $HintShift;
158 print $h <<EOH;
159
160 #if defined(PERL_CORE) || defined (PERL_EXT)
161
162 #define HINT_FEATURE_SHIFT      $HintShift
163
164 #define FEATURE_BUNDLE_DEFAULT  0
165 EOH
166
167 my $count;
168 for (sort values %UniqueBundles) {
169     (my $key = $_) =~ y/.//d;
170     next if $key =~ /\D/;
171     print $h "#define FEATURE_BUNDLE_$key       ", ++$count, "\n";
172 }
173
174 print $h <<EOH;
175 #define FEATURE_BUNDLE_CUSTOM   HINT_FEATURE_MASK >> HINT_FEATURE_SHIFT
176
177 #endif /* PERL_CORE or PERL_EXT */
178 EOH
179
180 read_only_bottom_close_and_rename($h);
181
182 __END__
183 package feature;
184
185 our $VERSION = '1.25';
186
187 FEATURES
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 = 0x00000800;
193
194 # TODO:
195 # - think about versioned features (use feature switch => 2)
196
197 =head1 NAME
198
199 feature - Perl pragma to enable new features
200
201 =head1 SYNOPSIS
202
203     use feature qw(say switch);
204     given ($foo) {
205         when (1)          { say "\$foo == 1" }
206         when ([2,3])      { say "\$foo == 2 || \$foo == 3" }
207         when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
208         when ($_ > 100)   { say "\$foo > 100" }
209         default           { say "None of the above" }
210     }
211
212     use feature ':5.10'; # loads all features available in perl 5.10
213
214     use v5.10;           # implicitly loads :5.10 feature bundle
215
216 =head1 DESCRIPTION
217
218 It is usually impossible to add new syntax to Perl without breaking
219 some existing programs.  This pragma provides a way to minimize that
220 risk. New syntactic constructs, or new semantic meanings to older
221 constructs, can be enabled by C<use feature 'foo'>, and will be parsed
222 only when the appropriate feature pragma is in scope.  (Nevertheless, the
223 C<CORE::> prefix provides access to all Perl keywords, regardless of this
224 pragma.)
225
226 =head2 Lexical effect
227
228 Like other pragmas (C<use strict>, for example), features have a lexical
229 effect. C<use feature qw(foo)> will only make the feature "foo" available
230 from that point to the end of the enclosing block.
231
232     {
233         use feature 'say';
234         say "say is available here";
235     }
236     print "But not here.\n";
237
238 =head2 C<no feature>
239
240 Features can also be turned off by using C<no feature "foo">.  This too
241 has lexical effect.
242
243     use feature 'say';
244     say "say is available here";
245     {
246         no feature 'say';
247         print "But not here.\n";
248     }
249     say "Yet it is here.";
250
251 C<no feature> with no features specified will turn off all features.
252
253 =head1 AVAILABLE FEATURES
254
255 =head2 The 'say' feature
256
257 C<use feature 'say'> tells the compiler to enable the Perl 6 style
258 C<say> function.
259
260 See L<perlfunc/say> for details.
261
262 This feature is available starting with Perl 5.10.
263
264 =head2 The 'state' feature
265
266 C<use feature 'state'> tells the compiler to enable C<state>
267 variables.
268
269 See L<perlsub/"Persistent Private Variables"> for details.
270
271 This feature is available starting with Perl 5.10.
272
273 =head2 The 'switch' feature
274
275 C<use feature 'switch'> tells the compiler to enable the Perl 6
276 given/when construct.
277
278 See L<perlsyn/"Switch statements"> for details.
279
280 This feature is available starting with Perl 5.10.
281
282 =head2 The 'unicode_strings' feature
283
284 C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
285 in all string operations executed within its scope (unless they are also
286 within the scope of either C<use locale> or C<use bytes>).  The same applies
287 to all regular expressions compiled within the scope, even if executed outside
288 it.
289
290 C<no feature 'unicode_strings'> tells the compiler to use the traditional
291 Perl semantics wherein the native character set semantics is used unless it is
292 clear to Perl that Unicode is desired.  This can lead to some surprises
293 when the behavior suddenly changes.  (See
294 L<perlunicode/The "Unicode Bug"> for details.)  For this reason, if you are
295 potentially using Unicode in your program, the
296 C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
297
298 This feature is available starting with Perl 5.12, but was not fully
299 implemented until Perl 5.14.
300
301 =head2 The 'unicode_eval' and 'evalbytes' features
302
303 Under the C<unicode_eval> feature, Perl's C<eval> function, when passed a
304 string, will evaluate it as a string of characters, ignoring any
305 C<use utf8> declarations.  C<use utf8> exists to declare the encoding of
306 the script, which only makes sense for a stream of bytes, not a string of
307 characters.  Source filters are forbidden, as they also really only make
308 sense on strings of bytes.  Any attempt to activate a source filter will
309 result in an error.
310
311 The C<evalbytes> feature enables the C<evalbytes> keyword, which evaluates
312 the argument passed to it as a string of bytes.  It dies if the string
313 contains any characters outside the 8-bit range.  Source filters work
314 within C<evalbytes>: they apply to the contents of the string being
315 evaluated.
316
317 Together, these two features are intended to replace the historical C<eval>
318 function, which has (at least) two bugs in it, that cannot easily be fixed
319 without breaking existing programs:
320
321 =over
322
323 =item *
324
325 C<eval> behaves differently depending on the internal encoding of the
326 string, sometimes treating its argument as a string of bytes, and sometimes
327 as a string of characters.
328
329 =item *
330
331 Source filters activated within C<eval> leak out into whichever I<file>
332 scope is currently being compiled.  To give an example with the CPAN module
333 L<Semi::Semicolons>:
334
335     BEGIN { eval "use Semi::Semicolons;  # not filtered here " }
336     # filtered here!
337
338 C<evalbytes> fixes that to work the way one would expect:
339
340     use feature "evalbytes";
341     BEGIN { evalbytes "use Semi::Semicolons;  # filtered " }
342     # not filtered
343
344 =back
345
346 These two features are available starting with Perl 5.16.
347
348 =head2 The 'current_sub' feature
349
350 This provides the C<__SUB__> token that returns a reference to the current
351 subroutine or C<undef> outside of a subroutine.
352
353 This feature is available starting with Perl 5.16.
354
355 =head2 The 'array_base' feature
356
357 This feature supports the legacy C<$[> variable.  See L<perlvar/$[> and
358 L<arybase>.  It is on by default but disabled under C<use v5.16> (see
359 L</IMPLICIT LOADING>, below).
360
361 This feature is available under this name starting with Perl 5.16.  In
362 previous versions, it was simply on all the time, and this pragma knew
363 nothing about it.
364
365 =head1 FEATURE BUNDLES
366
367 It's possible to load multiple features together, using
368 a I<feature bundle>.  The name of a feature bundle is prefixed with
369 a colon, to distinguish it from an actual feature.
370
371   use feature ":5.10";
372
373 The following feature bundles are available:
374
375   bundle    features included
376   --------- -----------------
377   :default  array_base
378
379   :5.10     say state switch array_base
380
381   :5.12     say state switch unicode_strings array_base
382
383   :5.14     say state switch unicode_strings array_base
384
385   :5.16     say state switch unicode_strings
386             unicode_eval evalbytes current_sub
387
388 The C<:default> bundle represents the feature set that is enabled before
389 any C<use feature> or C<no feature> declaration.
390
391 Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has
392 no effect.  Feature bundles are guaranteed to be the same for all sub-versions.
393
394   use feature ":5.14.0";    # same as ":5.14"
395   use feature ":5.14.1";    # same as ":5.14"
396
397 =head1 IMPLICIT LOADING
398
399 Instead of loading feature bundles by name, it is easier to let Perl do
400 implicit loading of a feature bundle for you.
401
402 There are two ways to load the C<feature> pragma implicitly:
403
404 =over 4
405
406 =item *
407
408 By using the C<-E> switch on the Perl command-line instead of C<-e>.
409 That will enable the feature bundle for that version of Perl in the
410 main compilation unit (that is, the one-liner that follows C<-E>).
411
412 =item *
413
414 By explicitly requiring a minimum Perl version number for your program, with
415 the C<use VERSION> construct.  That is,
416
417     use v5.10.0;
418
419 will do an implicit
420
421     no feature;
422     use feature ':5.10';
423
424 and so on.  Note how the trailing sub-version
425 is automatically stripped from the
426 version.
427
428 But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
429
430     use 5.010;
431
432 with the same effect.
433
434 If the required version is older than Perl 5.10, the ":default" feature
435 bundle is automatically loaded instead.
436
437 =back
438
439 =cut
440
441 sub import {
442     my $class = shift;
443     if (@_ == 0) {
444         croak("No features specified");
445     }
446     while (@_) {
447         my $name = shift(@_);
448         if (substr($name, 0, 1) eq ":") {
449             my $v = substr($name, 1);
450             if (!exists $feature_bundle{$v}) {
451                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
452                 if (!exists $feature_bundle{$v}) {
453                     unknown_feature_bundle(substr($name, 1));
454                 }
455             }
456             unshift @_, @{$feature_bundle{$v}};
457             next;
458         }
459         if (!exists $feature{$name}) {
460           if (!exists $default_feature{$name}) {
461             unknown_feature($name);
462           }
463           delete $^H{$default_feature{$name}}; next;
464         }
465         $^H{$feature{$name}} = 1;
466         $^H |= $hint_uni8bit if $name eq 'unicode_strings';
467     }
468 }
469
470 sub unimport {
471     my $class = shift;
472
473     # A bare C<no feature> should disable *all* features
474     if (!@_) {
475         delete @^H{ values(%feature) };
476         $^H &= ~ $hint_uni8bit;
477         @^H{ values(%default_feature) } = (1) x keys %default_feature;
478         return;
479     }
480
481     while (@_) {
482         my $name = shift;
483         if (substr($name, 0, 1) eq ":") {
484             my $v = substr($name, 1);
485             if (!exists $feature_bundle{$v}) {
486                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
487                 if (!exists $feature_bundle{$v}) {
488                     unknown_feature_bundle(substr($name, 1));
489                 }
490             }
491             unshift @_, @{$feature_bundle{$v}};
492             next;
493         }
494         if (!exists($feature{$name})) {
495           if (!exists $default_feature{$name}) {
496             unknown_feature($name);
497           }
498           $^H{$default_feature{$name}} = 1; next;
499         }
500         else {
501             delete $^H{$feature{$name}};
502             $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
503         }
504     }
505 }
506
507 sub unknown_feature {
508     my $feature = shift;
509     croak(sprintf('Feature "%s" is not supported by Perl %vd',
510             $feature, $^V));
511 }
512
513 sub unknown_feature_bundle {
514     my $feature = shift;
515     croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
516             $feature, $^V));
517 }
518
519 sub croak {
520     require Carp;
521     Carp::croak(@_);
522 }
523
524 1;