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