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 { | |
3d7c117d | 14 | require './regen/regen_lib.pl'; |
69bcf1d3 FC |
15 | push @INC, './lib'; |
16 | } | |
69bcf1d3 | 17 | |
3b8e6999 N |
18 | use strict; |
19 | use warnings; | |
c452a42f FC |
20 | |
21 | ########################################################################### | |
22 | # Hand-editable data | |
23 | ||
c6b36e45 | 24 | # (feature name) => (internal name, used in %^H and macro names) |
69bcf1d3 | 25 | my %feature = ( |
67bdaa9e FC |
26 | say => 'say', |
27 | state => 'state', | |
28 | switch => 'switch', | |
cec892e7 | 29 | bitwise => 'bitwise', |
67bdaa9e FC |
30 | evalbytes => 'evalbytes', |
31 | current_sub => '__SUB__', | |
baabe3fb | 32 | refaliasing => 'refaliasing', |
158becca | 33 | postderef_qq => 'postderef_qq', |
67bdaa9e | 34 | unicode_eval => 'unieval', |
82d83da3 | 35 | declared_refs => 'myref', |
67bdaa9e | 36 | unicode_strings => 'unicode', |
2a4315f8 | 37 | fc => 'fc', |
30d9c59b | 38 | signatures => 'signatures', |
813e85a0 | 39 | isa => 'isa', |
0b657b19 | 40 | indirect => 'indirect', |
1ad5a39c | 41 | multidimensional => 'multidimensional', |
0f2beabb | 42 | bareword_filehandles => 'bareword_filehandles', |
a1325b90 | 43 | try => 'try', |
f79e2ff9 | 44 | defer => 'defer', |
69bcf1d3 FC |
45 | ); |
46 | ||
40e4d872 FC |
47 | # NOTE: If a feature is ever enabled in a non-contiguous range of Perl |
48 | # versions, any code below that uses %BundleRanges will have to | |
49 | # be changed to account. | |
50 | ||
52fc5c56 | 51 | # 5.odd implies the next 5.even, but an explicit 5.even can override it. |
3b8e6999 N |
52 | |
53 | # features bundles | |
0f2beabb | 54 | use constant V5_9_5 => sort qw{say state switch indirect multidimensional bareword_filehandles}; |
3b8e6999 N |
55 | use constant V5_11 => sort ( +V5_9_5, qw{unicode_strings} ); |
56 | use constant V5_15 => sort ( +V5_11, qw{unicode_eval evalbytes current_sub fc} ); | |
57 | use constant V5_23 => sort ( +V5_15, qw{postderef_qq} ); | |
58 | use constant V5_27 => sort ( +V5_23, qw{bitwise} ); | |
cdba169f RS |
59 | |
60 | use constant V5_35 => sort grep {; $_ ne 'switch' | |
d5c835da | 61 | && $_ ne 'bareword_filehandles' |
cdba169f RS |
62 | && $_ ne 'indirect' |
63 | && $_ ne 'multidimensional' } +V5_27; | |
3b8e6999 | 64 | |
69bcf1d3 | 65 | my %feature_bundle = ( |
3b8e6999 | 66 | all => [ sort keys %feature ], |
0f2beabb | 67 | default => [ qw{indirect multidimensional bareword_filehandles} ], |
3b8e6999 N |
68 | # using 5.9.5 features bundle |
69 | "5.9.5" => [ +V5_9_5 ], | |
70 | "5.10" => [ +V5_9_5 ], | |
71 | # using 5.11 features bundle | |
72 | "5.11" => [ +V5_11 ], | |
73 | "5.13" => [ +V5_11 ], | |
74 | # using 5.15 features bundle | |
75 | "5.15" => [ +V5_15 ], | |
76 | "5.17" => [ +V5_15 ], | |
77 | "5.19" => [ +V5_15 ], | |
78 | "5.21" => [ +V5_15 ], | |
79 | # using 5.23 features bundle | |
80 | "5.23" => [ +V5_23 ], | |
81 | "5.25" => [ +V5_23 ], | |
82 | # using 5.27 features bundle | |
83 | "5.27" => [ +V5_27 ], | |
84 | "5.29" => [ +V5_27 ], | |
85 | "5.31" => [ +V5_27 ], | |
86 | "5.33" => [ +V5_27 ], | |
915e574d RS |
87 | # using 5.35 features bundle |
88 | "5.35" => [ +V5_35 ], | |
69bcf1d3 FC |
89 | ); |
90 | ||
db629560 | 91 | my @noops = qw( postderef lexical_subs ); |
c22e17d0 | 92 | my @removed = qw( array_base ); |
db629560 | 93 | |
c452a42f | 94 | |
69bcf1d3 | 95 | ########################################################################### |
c452a42f | 96 | # More data generated from the above |
69bcf1d3 | 97 | |
9f601cf3 TC |
98 | if (keys %feature > 32) { |
99 | die "cop_features only has room for 32 features"; | |
100 | } | |
101 | ||
102 | my %feature_bits; | |
103 | my $mask = 1; | |
104 | for my $feature (sort keys %feature) { | |
105 | $feature_bits{$feature} = $mask; | |
106 | $mask <<= 1; | |
107 | } | |
108 | ||
52fc5c56 FC |
109 | for (keys %feature_bundle) { |
110 | next unless /^5\.(\d*[13579])\z/; | |
111 | $feature_bundle{"5.".($1+1)} ||= $feature_bundle{$_}; | |
112 | } | |
113 | ||
f2c01b15 FC |
114 | my %UniqueBundles; # "say state switch" => 5.10 |
115 | my %Aliases; # 5.12 => 5.11 | |
116 | for( sort keys %feature_bundle ) { | |
117 | my $value = join(' ', sort @{$feature_bundle{$_}}); | |
118 | if (exists $UniqueBundles{$value}) { | |
119 | $Aliases{$_} = $UniqueBundles{$value}; | |
120 | } | |
121 | else { | |
122 | $UniqueBundles{$value} = $_; | |
123 | } | |
124 | } | |
40e4d872 FC |
125 | # start end |
126 | my %BundleRanges; # say => ['5.10', '5.15'] # unique bundles for values | |
127 | for my $bund ( | |
128 | sort { $a eq 'default' ? -1 : $b eq 'default' ? 1 : $a cmp $b } | |
129 | values %UniqueBundles | |
130 | ) { | |
03222170 | 131 | next if $bund =~ /[^\d.]/ and $bund ne 'default'; |
40e4d872 FC |
132 | for (@{$feature_bundle{$bund}}) { |
133 | if (@{$BundleRanges{$_} ||= []} == 2) { | |
134 | $BundleRanges{$_}[1] = $bund | |
135 | } | |
136 | else { | |
137 | push @{$BundleRanges{$_}}, $bund; | |
138 | } | |
139 | } | |
140 | } | |
69bcf1d3 | 141 | |
47222a2d | 142 | my $HintShift; |
ada44f8c | 143 | my $HintMask; |
3489ea76 | 144 | my $Uni8Bit; |
47222a2d | 145 | |
1ae6ead9 | 146 | open "perl.h", "<", "perl.h" or die "$0 cannot open perl.h: $!"; |
3489ea76 FC |
147 | while (readline "perl.h") { |
148 | next unless /#\s*define\s+(HINT_FEATURE_MASK|HINT_UNI_8_BIT)/; | |
149 | my $is_u8b = $1 =~ 8; | |
150 | /(0x[A-Fa-f0-9]+)/ or die "No hex number in:\n\n$_\n "; | |
151 | if ($is_u8b) { | |
152 | $Uni8Bit = $1; | |
153 | } | |
154 | else { | |
ada44f8c | 155 | my $hex = $HintMask = $1; |
47222a2d FC |
156 | my $bits = sprintf "%b", oct $1; |
157 | $bits =~ /^0*1+(0*)\z/ | |
158 | or die "Non-contiguous bits in $bits (binary for $hex):\n\n$_\n "; | |
159 | $HintShift = length $1; | |
160 | my $bits_needed = | |
161 | length sprintf "%b", scalar keys %UniqueBundles; | |
162 | $bits =~ /1{$bits_needed}/ | |
163 | or die "Not enough bits (need $bits_needed)" | |
5d826eae | 164 | . " in $bits (binary for $hex):\n\n$_\n "; |
47222a2d | 165 | } |
3489ea76 | 166 | if ($Uni8Bit && $HintMask) { last } |
47222a2d | 167 | } |
3489ea76 FC |
168 | die "No HINT_FEATURE_MASK defined in perl.h" unless $HintMask; |
169 | die "No HINT_UNI_8_BIT defined in perl.h" unless $Uni8Bit; | |
170 | ||
47222a2d FC |
171 | close "perl.h"; |
172 | ||
ada44f8c FC |
173 | my @HintedBundles = |
174 | ('default', grep !/[^\d.]/, sort values %UniqueBundles); | |
175 | ||
47222a2d | 176 | |
f2c01b15 | 177 | ########################################################################### |
c452a42f | 178 | # Open files to be generated |
f2c01b15 FC |
179 | |
180 | my ($pm, $h) = map { | |
69bcf1d3 | 181 | open_new($_, '>', { by => 'regen/feature.pl' }); |
f2c01b15 | 182 | } 'lib/feature.pm', 'feature.h'; |
69bcf1d3 FC |
183 | |
184 | ||
c452a42f FC |
185 | ########################################################################### |
186 | # Generate lib/feature.pm | |
187 | ||
69bcf1d3 FC |
188 | while (<DATA>) { |
189 | last if /^FEATURES$/ ; | |
190 | print $pm $_ ; | |
191 | } | |
192 | ||
193 | sub longest { | |
194 | my $long; | |
195 | for(@_) { | |
196 | if (!defined $long or length $long < length) { | |
197 | $long = $_; | |
198 | } | |
199 | } | |
200 | $long; | |
201 | } | |
202 | ||
0bb01b05 | 203 | print $pm "our %feature = (\n"; |
69bcf1d3 | 204 | my $width = length longest keys %feature; |
ebd25686 | 205 | for(sort { length $a <=> length $b || $a cmp $b } keys %feature) { |
67bdaa9e FC |
206 | print $pm " $_" . " "x($width-length) |
207 | . " => 'feature_$feature{$_}',\n"; | |
69bcf1d3 FC |
208 | } |
209 | print $pm ");\n\n"; | |
210 | ||
69bcf1d3 | 211 | print $pm "our %feature_bundle = (\n"; |
9f601cf3 | 212 | my $bund_width = length longest values %UniqueBundles; |
88da30d7 FC |
213 | for( sort { $UniqueBundles{$a} cmp $UniqueBundles{$b} } |
214 | keys %UniqueBundles ) { | |
215 | my $bund = $UniqueBundles{$_}; | |
9f601cf3 | 216 | print $pm qq' "$bund"' . " "x($bund_width-length $bund) |
88da30d7 | 217 | . qq' => [qw($_)],\n'; |
69bcf1d3 FC |
218 | } |
219 | print $pm ");\n\n"; | |
220 | ||
88da30d7 FC |
221 | for (sort keys %Aliases) { |
222 | print $pm | |
223 | qq'\$feature_bundle{"$_"} = \$feature_bundle{"$Aliases{$_}"};\n'; | |
224 | }; | |
69bcf1d3 | 225 | |
db629560 FC |
226 | print $pm "my \%noops = (\n"; |
227 | print $pm " $_ => 1,\n", for @noops; | |
228 | print $pm ");\n"; | |
229 | ||
c22e17d0 DIM |
230 | print $pm "my \%removed = (\n"; |
231 | print $pm " $_ => 1,\n", for @removed; | |
232 | print $pm ");\n"; | |
233 | ||
ada44f8c FC |
234 | print $pm <<EOPM; |
235 | ||
0bb01b05 FC |
236 | our \$hint_shift = $HintShift; |
237 | our \$hint_mask = $HintMask; | |
238 | our \@hint_bundles = qw( @HintedBundles ); | |
3489ea76 FC |
239 | |
240 | # This gets set (for now) in \$^H as well as in %^H, | |
241 | # for runtime speed of the uc/lc/ucfirst/lcfirst functions. | |
242 | # See HINT_UNI_8_BIT in perl.h. | |
243 | our \$hint_uni8bit = $Uni8Bit; | |
ada44f8c FC |
244 | EOPM |
245 | ||
69bcf1d3 FC |
246 | |
247 | while (<DATA>) { | |
2b3fe414 FC |
248 | last if /^PODTURES$/ ; |
249 | print $pm $_ ; | |
250 | } | |
251 | ||
252 | select +(select($pm), $~ = 'PODTURES')[0]; | |
253 | format PODTURES = | |
254 | ^<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ | |
255 | $::bundle, $::feature | |
256 | . | |
257 | ||
258 | for ('default', sort grep /\.\d[02468]/, keys %feature_bundle) { | |
259 | $::bundle = ":$_"; | |
260 | $::feature = join ' ', @{$feature_bundle{$_}}; | |
261 | write $pm; | |
262 | print $pm "\n"; | |
263 | } | |
264 | ||
265 | while (<DATA>) { | |
69bcf1d3 FC |
266 | print $pm $_ ; |
267 | } | |
268 | ||
269 | read_only_bottom_close_and_rename($pm); | |
270 | ||
c452a42f FC |
271 | |
272 | ########################################################################### | |
273 | # Generate feature.h | |
274 | ||
f2c01b15 FC |
275 | print $h <<EOH; |
276 | ||
3dd7db29 JK |
277 | #ifndef PERL_FEATURE_H_ |
278 | #define PERL_FEATURE_H_ | |
279 | ||
f2c01b15 FC |
280 | #if defined(PERL_CORE) || defined (PERL_EXT) |
281 | ||
282 | #define HINT_FEATURE_SHIFT $HintShift | |
283 | ||
f2c01b15 FC |
284 | EOH |
285 | ||
9f601cf3 TC |
286 | for (sort keys %feature_bits) { |
287 | printf $h "#define FEATURE_%s_BIT%*s %#06x\n", uc($feature{$_}), | |
288 | $width-length($feature{$_}), "", $feature_bits{$_}; | |
289 | } | |
290 | print $h "\n"; | |
291 | ||
f2c01b15 | 292 | my $count; |
016d11cb FC |
293 | for (@HintedBundles) { |
294 | (my $key = uc) =~ y/.//d; | |
295 | print $h "#define FEATURE_BUNDLE_$key ", $count++, "\n"; | |
f2c01b15 FC |
296 | } |
297 | ||
7d058bc9 | 298 | print $h <<'EOH'; |
2b9e0ab7 | 299 | #define FEATURE_BUNDLE_CUSTOM (HINT_FEATURE_MASK >> HINT_FEATURE_SHIFT) |
f2c01b15 | 300 | |
7d058bc9 | 301 | #define CURRENT_HINTS \ |
d1fd0100 | 302 | (PL_curcop == &PL_compiling ? PL_hints : PL_curcop->cop_hints) |
035b6821 FC |
303 | #define CURRENT_FEATURE_BUNDLE \ |
304 | ((CURRENT_HINTS & HINT_FEATURE_MASK) >> HINT_FEATURE_SHIFT) | |
d1fd0100 | 305 | |
9f601cf3 TC |
306 | #define FEATURE_IS_ENABLED_MASK(mask) \ |
307 | ((CURRENT_HINTS & HINT_LOCALIZE_HH) \ | |
308 | ? (PL_curcop->cop_features & (mask)) : FALSE) | |
309 | ||
7d058bc9 | 310 | /* The longest string we pass in. */ |
03222170 FC |
311 | EOH |
312 | ||
1b6e8741 FC |
313 | my $longest_internal_feature_name = longest values %feature; |
314 | print $h <<EOL; | |
315 | #define MAX_FEATURE_LEN (sizeof("$longest_internal_feature_name")-1) | |
316 | ||
317 | EOL | |
318 | ||
03222170 | 319 | for ( |
ebd25686 | 320 | sort { length $a <=> length $b || $a cmp $b } keys %feature |
03222170 FC |
321 | ) { |
322 | my($first,$last) = | |
323 | map { (my $__ = uc) =~ y/.//d; $__ } @{$BundleRanges{$_}}; | |
3fff3427 | 324 | my $name = $feature{$_}; |
03222170 | 325 | my $NAME = uc $name; |
f298f061 | 326 | if ($last && $first eq 'DEFAULT') { # '>= DEFAULT' warns |
beda0318 | 327 | print $h <<EOI; |
23fa16fc | 328 | #define FEATURE_${NAME}_IS_ENABLED \\ |
beda0318 FC |
329 | ( \\ |
330 | CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last \\ | |
331 | || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\ | |
23fa16fc | 332 | FEATURE_IS_ENABLED_MASK(FEATURE_${NAME}_BIT)) \\ |
beda0318 FC |
333 | ) |
334 | ||
335 | EOI | |
336 | } | |
337 | elsif ($last) { | |
03222170 | 338 | print $h <<EOH3; |
23fa16fc | 339 | #define FEATURE_${NAME}_IS_ENABLED \\ |
03222170 FC |
340 | ( \\ |
341 | (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_$first && \\ | |
342 | CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_$last) \\ | |
343 | || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\ | |
23fa16fc | 344 | FEATURE_IS_ENABLED_MASK(FEATURE_${NAME}_BIT)) \\ |
03222170 FC |
345 | ) |
346 | ||
347 | EOH3 | |
348 | } | |
ebd25686 | 349 | elsif ($first) { |
03222170 | 350 | print $h <<EOH4; |
23fa16fc | 351 | #define FEATURE_${NAME}_IS_ENABLED \\ |
03222170 FC |
352 | ( \\ |
353 | CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_$first \\ | |
354 | || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\ | |
23fa16fc | 355 | FEATURE_IS_ENABLED_MASK(FEATURE_${NAME}_BIT)) \\ |
03222170 FC |
356 | ) |
357 | ||
358 | EOH4 | |
359 | } | |
ebd25686 FC |
360 | else { |
361 | print $h <<EOH5; | |
23fa16fc | 362 | #define FEATURE_${NAME}_IS_ENABLED \\ |
ebd25686 FC |
363 | ( \\ |
364 | CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \\ | |
23fa16fc | 365 | FEATURE_IS_ENABLED_MASK(FEATURE_${NAME}_BIT) \\ |
ebd25686 FC |
366 | ) |
367 | ||
368 | EOH5 | |
369 | } | |
03222170 FC |
370 | } |
371 | ||
372 | print $h <<EOH; | |
373 | ||
9f601cf3 TC |
374 | #define SAVEFEATUREBITS() SAVEI32(PL_compiling.cop_features) |
375 | ||
376 | #define CLEARFEATUREBITS() (PL_compiling.cop_features = 0) | |
377 | ||
378 | #define STOREFEATUREBITSHH(hh) \\ | |
379 | (hv_stores((hh), "feature/bits", newSVuv(PL_compiling.cop_features))) | |
380 | ||
381 | #define FETCHFEATUREBITSHH(hh) \\ | |
382 | STMT_START { \\ | |
383 | SV **fbsv = hv_fetchs((hh), "feature/bits", FALSE); \\ | |
384 | PL_compiling.cop_features = fbsv ? SvUV(*fbsv) : 0; \\ | |
385 | } STMT_END | |
386 | ||
f2c01b15 | 387 | #endif /* PERL_CORE or PERL_EXT */ |
4160ddbd FC |
388 | |
389 | #ifdef PERL_IN_OP_C | |
390 | PERL_STATIC_INLINE void | |
391 | S_enable_feature_bundle(pTHX_ SV *ver) | |
392 | { | |
393 | SV *comp_ver = sv_newmortal(); | |
394 | PL_hints = (PL_hints &~ HINT_FEATURE_MASK) | |
395 | | ( | |
f2c01b15 FC |
396 | EOH |
397 | ||
4160ddbd FC |
398 | for (reverse @HintedBundles[1..$#HintedBundles]) { # skip default |
399 | my $numver = $_; | |
400 | if ($numver eq '5.10') { $numver = '5.009005' } # special case | |
401 | else { $numver =~ s/\./.0/ } # 5.11 => 5.011 | |
402 | (my $macrover = $_) =~ y/.//d; | |
403 | print $h <<" EOK"; | |
404 | (sv_setnv(comp_ver, $numver), | |
405 | vcmp(ver, upg_version(comp_ver, FALSE)) >= 0) | |
406 | ? FEATURE_BUNDLE_$macrover : | |
407 | EOK | |
408 | } | |
409 | ||
410 | print $h <<EOJ; | |
411 | FEATURE_BUNDLE_DEFAULT | |
412 | ) << HINT_FEATURE_SHIFT; | |
6389c777 FC |
413 | /* special case */ |
414 | assert(PL_curcop == &PL_compiling); | |
415 | if (FEATURE_UNICODE_IS_ENABLED) PL_hints |= HINT_UNI_8_BIT; | |
416 | else PL_hints &= ~HINT_UNI_8_BIT; | |
4160ddbd FC |
417 | } |
418 | #endif /* PERL_IN_OP_C */ | |
3dd7db29 | 419 | |
b34c1a7e TC |
420 | #ifdef PERL_IN_MG_C |
421 | ||
422 | #define magic_sethint_feature(keysv, keypv, keylen, valsv, valbool) \\ | |
423 | S_magic_sethint_feature(aTHX_ (keysv), (keypv), (keylen), (valsv), (valbool)) | |
424 | PERL_STATIC_INLINE void | |
425 | S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen, | |
426 | SV *valsv, bool valbool) { | |
427 | if (keysv) | |
428 | keypv = SvPV_const(keysv, keylen); | |
429 | ||
430 | if (memBEGINs(keypv, keylen, "feature_")) { | |
431 | const char *subf = keypv + (sizeof("feature_")-1); | |
432 | U32 mask = 0; | |
433 | switch (*subf) { | |
434 | EOJ | |
435 | ||
436 | my %pref; | |
437 | for my $key (sort values %feature) { | |
438 | push @{$pref{substr($key, 0, 1)}}, $key; | |
439 | } | |
440 | ||
441 | for my $pref (sort keys %pref) { | |
442 | print $h <<EOS; | |
443 | case '$pref': | |
444 | EOS | |
445 | my $first = 1; | |
446 | for my $subkey (@{$pref{$pref}}) { | |
447 | my $rest = substr($subkey, 1); | |
448 | my $if = $first ? "if" : "else if"; | |
449 | print $h <<EOJ; | |
450 | $if (keylen == sizeof("feature_$subkey")-1 | |
451 | && memcmp(subf+1, "$rest", keylen - sizeof("feature_")) == 0) { | |
452 | mask = FEATURE_\U${subkey}\E_BIT; | |
453 | break; | |
454 | } | |
455 | EOJ | |
456 | ||
457 | $first = 0; | |
458 | } | |
459 | print $h <<EOS; | |
460 | return; | |
461 | ||
462 | EOS | |
463 | } | |
464 | ||
465 | print $h <<EOJ; | |
466 | default: | |
467 | return; | |
468 | } | |
469 | if (valsv ? SvTRUE(valsv) : valbool) | |
470 | PL_compiling.cop_features |= mask; | |
471 | else | |
472 | PL_compiling.cop_features &= ~mask; | |
473 | } | |
474 | } | |
475 | #endif /* PERL_IN_MG_C */ | |
476 | ||
3dd7db29 | 477 | #endif /* PERL_FEATURE_H_ */ |
4160ddbd FC |
478 | EOJ |
479 | ||
f2c01b15 FC |
480 | read_only_bottom_close_and_rename($h); |
481 | ||
c452a42f FC |
482 | |
483 | ########################################################################### | |
484 | # Template for feature.pm | |
485 | ||
69bcf1d3 FC |
486 | __END__ |
487 | package feature; | |
488 | ||
cdba169f | 489 | our $VERSION = '1.69'; |
69bcf1d3 FC |
490 | |
491 | FEATURES | |
492 | ||
69bcf1d3 FC |
493 | # TODO: |
494 | # - think about versioned features (use feature switch => 2) | |
495 | ||
496 | =head1 NAME | |
497 | ||
498 | feature - Perl pragma to enable new features | |
499 | ||
500 | =head1 SYNOPSIS | |
501 | ||
d15aa6ae RS |
502 | use feature qw(fc say); |
503 | ||
504 | # Without the "use feature" above, this code would not be able to find | |
505 | # the built-ins "say" or "fc": | |
506 | say "The case-folded version of $x is: " . fc $x; | |
507 | ||
508 | ||
509 | # set features to match the :5.10 bundle, which may turn off or on | |
510 | # multiple features (see below) | |
511 | use feature ':5.10'; | |
69bcf1d3 | 512 | |
69bcf1d3 | 513 | |
d15aa6ae RS |
514 | # implicitly loads :5.10 feature bundle |
515 | use v5.10; | |
69bcf1d3 FC |
516 | |
517 | =head1 DESCRIPTION | |
518 | ||
519 | It is usually impossible to add new syntax to Perl without breaking | |
520 | some existing programs. This pragma provides a way to minimize that | |
521 | risk. New syntactic constructs, or new semantic meanings to older | |
522 | constructs, can be enabled by C<use feature 'foo'>, and will be parsed | |
523 | only when the appropriate feature pragma is in scope. (Nevertheless, the | |
524 | C<CORE::> prefix provides access to all Perl keywords, regardless of this | |
525 | pragma.) | |
526 | ||
527 | =head2 Lexical effect | |
528 | ||
529 | Like other pragmas (C<use strict>, for example), features have a lexical | |
301381dc | 530 | effect. C<use feature qw(foo)> will only make the feature "foo" available |
69bcf1d3 FC |
531 | from that point to the end of the enclosing block. |
532 | ||
533 | { | |
534 | use feature 'say'; | |
535 | say "say is available here"; | |
536 | } | |
537 | print "But not here.\n"; | |
538 | ||
539 | =head2 C<no feature> | |
540 | ||
541 | Features can also be turned off by using C<no feature "foo">. This too | |
542 | has lexical effect. | |
543 | ||
544 | use feature 'say'; | |
545 | say "say is available here"; | |
546 | { | |
547 | no feature 'say'; | |
548 | print "But not here.\n"; | |
549 | } | |
550 | say "Yet it is here."; | |
551 | ||
39ec54a5 RS |
552 | C<no feature> with no features specified will reset to the default group. To |
553 | disable I<all> features (an unusual request!) use C<no feature ':all'>. | |
69bcf1d3 FC |
554 | |
555 | =head1 AVAILABLE FEATURES | |
556 | ||
557 | =head2 The 'say' feature | |
558 | ||
5d6cc146 | 559 | C<use feature 'say'> tells the compiler to enable the Raku-inspired |
69bcf1d3 FC |
560 | C<say> function. |
561 | ||
562 | See L<perlfunc/say> for details. | |
563 | ||
564 | This feature is available starting with Perl 5.10. | |
565 | ||
566 | =head2 The 'state' feature | |
567 | ||
568 | C<use feature 'state'> tells the compiler to enable C<state> | |
569 | variables. | |
570 | ||
571 | See L<perlsub/"Persistent Private Variables"> for details. | |
572 | ||
573 | This feature is available starting with Perl 5.10. | |
574 | ||
575 | =head2 The 'switch' feature | |
576 | ||
d23c9e49 RS |
577 | B<WARNING>: This feature is still experimental and the implementation may |
578 | change or be removed in future versions of Perl. For this reason, Perl will | |
579 | warn when you use the feature, unless you have explicitly disabled the warning: | |
7caca87c DB |
580 | |
581 | no warnings "experimental::smartmatch"; | |
582 | ||
5d6cc146 | 583 | C<use feature 'switch'> tells the compiler to enable the Raku |
69bcf1d3 FC |
584 | given/when construct. |
585 | ||
48238296 | 586 | See L<perlsyn/"Switch Statements"> for details. |
69bcf1d3 FC |
587 | |
588 | This feature is available starting with Perl 5.10. | |
589 | ||
590 | =head2 The 'unicode_strings' feature | |
591 | ||
850b7ec9 | 592 | C<use feature 'unicode_strings'> tells the compiler to use Unicode rules |
69bcf1d3 FC |
593 | in all string operations executed within its scope (unless they are also |
594 | within the scope of either C<use locale> or C<use bytes>). The same applies | |
595 | to all regular expressions compiled within the scope, even if executed outside | |
2269d15c KW |
596 | it. It does not change the internal representation of strings, but only how |
597 | they are interpreted. | |
69bcf1d3 FC |
598 | |
599 | C<no feature 'unicode_strings'> tells the compiler to use the traditional | |
850b7ec9 | 600 | Perl rules wherein the native character set rules is used unless it is |
69bcf1d3 FC |
601 | clear to Perl that Unicode is desired. This can lead to some surprises |
602 | when the behavior suddenly changes. (See | |
603 | L<perlunicode/The "Unicode Bug"> for details.) For this reason, if you are | |
604 | potentially using Unicode in your program, the | |
605 | C<use feature 'unicode_strings'> subpragma is B<strongly> recommended. | |
606 | ||
2e2b2571 | 607 | This feature is available starting with Perl 5.12; was almost fully |
d6c970c7 | 608 | implemented in Perl 5.14; and extended in Perl 5.16 to cover C<quotemeta>; |
20ae58f7 AC |
609 | was extended further in Perl 5.26 to cover L<the range |
610 | operator|perlop/Range Operators>; and was extended again in Perl 5.28 to | |
611 | cover L<special-cased whitespace splitting|perlfunc/split>. | |
69bcf1d3 FC |
612 | |
613 | =head2 The 'unicode_eval' and 'evalbytes' features | |
614 | ||
9891e9b7 KW |
615 | Together, these two features are intended to replace the legacy string |
616 | C<eval> function, which behaves problematically in some instances. They are | |
617 | available starting with Perl 5.16, and are enabled by default by a | |
618 | S<C<use 5.16>> or higher declaration. | |
619 | ||
620 | C<unicode_eval> changes the behavior of plain string C<eval> to work more | |
621 | consistently, especially in the Unicode world. Certain (mis)behaviors | |
622 | couldn't be changed without breaking some things that had come to rely on | |
623 | them, so the feature can be enabled and disabled. Details are at | |
624 | L<perlfunc/Under the "unicode_eval" feature>. | |
625 | ||
e6f2f64a FG |
626 | C<evalbytes> is like string C<eval>, but it treats its argument as a byte |
627 | string. Details are at L<perlfunc/evalbytes EXPR>. Without a | |
9891e9b7 KW |
628 | S<C<use feature 'evalbytes'>> nor a S<C<use v5.16>> (or higher) declaration in |
629 | the current scope, you can still access it by instead writing | |
630 | C<CORE::evalbytes>. | |
69bcf1d3 FC |
631 | |
632 | =head2 The 'current_sub' feature | |
633 | ||
634 | This provides the C<__SUB__> token that returns a reference to the current | |
635 | subroutine or C<undef> outside of a subroutine. | |
636 | ||
637 | This feature is available starting with Perl 5.16. | |
638 | ||
639 | =head2 The 'array_base' feature | |
640 | ||
c22e17d0 DIM |
641 | This feature supported the legacy C<$[> variable. See L<perlvar/$[>. |
642 | It was on by default but disabled under C<use v5.16> (see | |
643 | L</IMPLICIT LOADING>, below) and unavailable since perl 5.30. | |
69bcf1d3 FC |
644 | |
645 | This feature is available under this name starting with Perl 5.16. In | |
646 | previous versions, it was simply on all the time, and this pragma knew | |
647 | nothing about it. | |
648 | ||
2a4315f8 BF |
649 | =head2 The 'fc' feature |
650 | ||
651 | C<use feature 'fc'> tells the compiler to enable the C<fc> function, | |
652 | which implements Unicode casefolding. | |
653 | ||
654 | See L<perlfunc/fc> for details. | |
655 | ||
656 | This feature is available from Perl 5.16 onwards. | |
657 | ||
ca40957e FC |
658 | =head2 The 'lexical_subs' feature |
659 | ||
8f7d85af FC |
660 | In Perl versions prior to 5.26, this feature enabled |
661 | declaration of subroutines via C<my sub foo>, C<state sub foo> | |
662 | and C<our sub foo> syntax. See L<perlsub/Lexical Subroutines> for details. | |
ca40957e | 663 | |
8f7d85af FC |
664 | This feature is available from Perl 5.18 onwards. From Perl 5.18 to 5.24, |
665 | it was classed as experimental, and Perl emitted a warning for its | |
666 | usage, except when explicitly disabled: | |
ca40957e | 667 | |
8f7d85af | 668 | no warnings "experimental::lexical_subs"; |
ca40957e | 669 | |
8f7d85af FC |
670 | As of Perl 5.26, use of this feature no longer triggers a warning, though |
671 | the C<experimental::lexical_subs> warning category still exists (for | |
672 | compatibility with code that disables it). In addition, this syntax is | |
673 | not only no longer experimental, but it is enabled for all Perl code, | |
674 | regardless of what feature declarations are in scope. | |
ca40957e | 675 | |
f86d720e RS |
676 | =head2 The 'postderef' and 'postderef_qq' features |
677 | ||
1c2511e0 AC |
678 | The 'postderef_qq' feature extends the applicability of L<postfix |
679 | dereference syntax|perlref/Postfix Dereference Syntax> so that postfix array | |
680 | and scalar dereference are available in double-quotish interpolations. For | |
681 | example, it makes the following two statements equivalent: | |
f86d720e | 682 | |
1c2511e0 AC |
683 | my $s = "[@{ $h->{a} }]"; |
684 | my $s = "[$h->{a}->@*]"; | |
f86d720e | 685 | |
1c2511e0 AC |
686 | This feature is available from Perl 5.20 onwards. In Perl 5.20 and 5.22, it |
687 | was classed as experimental, and Perl emitted a warning for its | |
2ad792cd AC |
688 | usage, except when explicitly disabled: |
689 | ||
690 | no warnings "experimental::postderef"; | |
691 | ||
1c2511e0 | 692 | As of Perl 5.24, use of this feature no longer triggers a warning, though |
2ad792cd AC |
693 | the C<experimental::postderef> warning category still exists (for |
694 | compatibility with code that disables it). | |
f86d720e | 695 | |
1c2511e0 AC |
696 | The 'postderef' feature was used in Perl 5.20 and Perl 5.22 to enable |
697 | postfix dereference syntax outside double-quotish interpolations. In those | |
698 | versions, using it triggered the C<experimental::postderef> warning in the | |
699 | same way as the 'postderef_qq' feature did. As of Perl 5.24, this syntax is | |
700 | not only no longer experimental, but it is enabled for all Perl code, | |
701 | regardless of what feature declarations are in scope. | |
702 | ||
30d9c59b Z |
703 | =head2 The 'signatures' feature |
704 | ||
705 | B<WARNING>: This feature is still experimental and the implementation may | |
d23c9e49 RS |
706 | change or be removed in future versions of Perl. For this reason, Perl will |
707 | warn when you use the feature, unless you have explicitly disabled the warning: | |
30d9c59b Z |
708 | |
709 | no warnings "experimental::signatures"; | |
710 | ||
711 | This enables unpacking of subroutine arguments into lexical variables | |
712 | by syntax such as | |
713 | ||
714 | sub foo ($left, $right) { | |
715 | return $left + $right; | |
716 | } | |
717 | ||
718 | See L<perlsub/Signatures> for details. | |
719 | ||
720 | This feature is available from Perl 5.20 onwards. | |
721 | ||
baabe3fb | 722 | =head2 The 'refaliasing' feature |
82848c10 FC |
723 | |
724 | B<WARNING>: This feature is still experimental and the implementation may | |
d23c9e49 RS |
725 | change or be removed in future versions of Perl. For this reason, Perl will |
726 | warn when you use the feature, unless you have explicitly disabled the warning: | |
82848c10 | 727 | |
baabe3fb | 728 | no warnings "experimental::refaliasing"; |
82848c10 FC |
729 | |
730 | This enables aliasing via assignment to references: | |
731 | ||
732 | \$a = \$b; # $a and $b now point to the same scalar | |
733 | \@a = \@b; # to the same array | |
734 | \%a = \%b; | |
735 | \&a = \&b; | |
736 | foreach \%hash (@array_of_hash_refs) { | |
737 | ... | |
738 | } | |
739 | ||
740 | See L<perlref/Assigning to References> for details. | |
741 | ||
742 | This feature is available from Perl 5.22 onwards. | |
743 | ||
70ea8edf FC |
744 | =head2 The 'bitwise' feature |
745 | ||
70ea8edf FC |
746 | This makes the four standard bitwise operators (C<& | ^ ~>) treat their |
747 | operands consistently as numbers, and introduces four new dotted operators | |
748 | (C<&. |. ^. ~.>) that treat their operands consistently as strings. The | |
749 | same applies to the assignment variants (C<&= |= ^= &.= |.= ^.=>). | |
750 | ||
751 | See L<perlop/Bitwise String Operators> for details. | |
752 | ||
193789ac FC |
753 | This feature is available from Perl 5.22 onwards. Starting in Perl 5.28, |
754 | C<use v5.28> will enable the feature. Before 5.28, it was still | |
755 | experimental and would emit a warning in the "experimental::bitwise" | |
756 | category. | |
70ea8edf | 757 | |
5c703779 FC |
758 | =head2 The 'declared_refs' feature |
759 | ||
760 | B<WARNING>: This feature is still experimental and the implementation may | |
d23c9e49 RS |
761 | change or be removed in future versions of Perl. For this reason, Perl will |
762 | warn when you use the feature, unless you have explicitly disabled the warning: | |
5c703779 FC |
763 | |
764 | no warnings "experimental::declared_refs"; | |
765 | ||
766 | This allows a reference to a variable to be declared with C<my>, C<state>, | |
767 | our C<our>, or localized with C<local>. It is intended mainly for use in | |
768 | conjunction with the "refaliasing" feature. See L<perlref/Declaring a | |
769 | Reference to a Variable> for examples. | |
770 | ||
771 | This feature is available from Perl 5.26 onwards. | |
772 | ||
813e85a0 PE |
773 | =head2 The 'isa' feature |
774 | ||
775 | This allows the use of the C<isa> infix operator, which tests whether the | |
776 | scalar given by the left operand is an object of the class given by the | |
777 | right operand. See L<perlop/Class Instance Operator> for more details. | |
778 | ||
157bd0a3 PE |
779 | This feature is available from Perl 5.32 onwards. From Perl 5.32 to 5.34, |
780 | it was classed as experimental, and Perl emitted a warning for its usage, | |
781 | except when explicitly disabled: | |
782 | ||
783 | no warnings "experimental::isa"; | |
784 | ||
785 | As of Perl 5.36, use of this feature no longer triggers a warning (though the | |
786 | C<experimental::isa> warning category stilll exists for compatibility with | |
787 | code that disables it). | |
813e85a0 | 788 | |
0b657b19 DIM |
789 | =head2 The 'indirect' feature |
790 | ||
791 | This feature allows the use of L<indirect object | |
792 | syntax|perlobj/Indirect Object Syntax> for method calls, e.g. C<new | |
793 | Foo 1, 2;>. It is enabled by default, but can be turned off to | |
794 | disallow indirect object syntax. | |
795 | ||
796 | This feature is available under this name from Perl 5.32 onwards. In | |
797 | previous versions, it was simply on all the time. To disallow (or | |
798 | warn on) indirect object syntax on older Perls, see the L<indirect> | |
799 | CPAN module. | |
800 | ||
1ad5a39c TC |
801 | =head2 The 'multidimensional' feature |
802 | ||
803 | This feature enables multidimensional array emulation, a perl 4 (or | |
804 | earlier) feature that was used to emulate multidimensional arrays with | |
c7888de9 EAV |
805 | hashes. This works by converting code like C<< $foo{$x, $y} >> into |
806 | C<< $foo{join($;, $x, $y)} >>. It is enabled by default, but can be | |
1ad5a39c TC |
807 | turned off to disable multidimensional array emulation. |
808 | ||
809 | When this feature is disabled the syntax that is normally replaced | |
810 | will report a compilation error. | |
811 | ||
812 | This feature is available under this name from Perl 5.34 onwards. In | |
813 | previous versions, it was simply on all the time. | |
814 | ||
815 | You can use the L<multidimensional> module on CPAN to disable | |
816 | multidimensional array emulation for older versions of Perl. | |
817 | ||
0f2beabb TC |
818 | =head2 The 'bareword_filehandles' feature. |
819 | ||
820 | This feature enables bareword filehandles for builtin functions | |
821 | operations, a generally discouraged practice. It is enabled by | |
822 | default, but can be turned off to disable bareword filehandles, except | |
823 | for the exceptions listed below. | |
824 | ||
825 | The perl built-in filehandles C<STDIN>, C<STDOUT>, C<STDERR>, C<DATA>, | |
826 | C<ARGV>, C<ARGVOUT> and the special C<_> are always enabled. | |
827 | ||
d5c835da RS |
828 | This behavior was always present in versions before Perl 5.34. In Perl 5.34, |
829 | it was made controllable with the C<feature> pragma, but was on by default. | |
830 | It is not present in the C<:5.36> feature bundle, so C<use v5.36> disables | |
831 | this feature. | |
0f2beabb TC |
832 | |
833 | You can use the L<bareword::filehandles> module on CPAN to disable | |
834 | bareword filehandles for older versions of perl. | |
835 | ||
a1325b90 PE |
836 | =head2 The 'try' feature. |
837 | ||
35b06c4c RS |
838 | B<WARNING>: This feature is still experimental and the implementation may |
839 | change or be removed in future versions of Perl. For this reason, Perl will | |
840 | warn when you use the feature, unless you have explicitly disabled the warning: | |
841 | ||
842 | no warnings "experimental::try"; | |
843 | ||
a1325b90 | 844 | This feature enables the C<try> and C<catch> syntax, which allows exception |
4a485c3e | 845 | handling, where exceptions thrown from the body of the block introduced with |
a1325b90 PE |
846 | C<try> are caught by executing the body of the C<catch> block. |
847 | ||
848 | For more information, see L<perlsyn/"Try Catch Exception Handling">. | |
849 | ||
f79e2ff9 PE |
850 | =head2 The 'defer' feature |
851 | ||
852 | This feature enables the C<defer> block syntax, which allows a block of code | |
853 | to be deferred until when the flow of control leaves the block which contained | |
854 | it. For more details, see L<perlsyn/defer>. | |
855 | ||
69bcf1d3 FC |
856 | =head1 FEATURE BUNDLES |
857 | ||
858 | It's possible to load multiple features together, using | |
859 | a I<feature bundle>. The name of a feature bundle is prefixed with | |
860 | a colon, to distinguish it from an actual feature. | |
861 | ||
862 | use feature ":5.10"; | |
863 | ||
864 | The following feature bundles are available: | |
865 | ||
866 | bundle features included | |
867 | --------- ----------------- | |
2b3fe414 | 868 | PODTURES |
69bcf1d3 FC |
869 | The C<:default> bundle represents the feature set that is enabled before |
870 | any C<use feature> or C<no feature> declaration. | |
871 | ||
872 | Specifying sub-versions such as the C<0> in C<5.14.0> in feature bundles has | |
873 | no effect. Feature bundles are guaranteed to be the same for all sub-versions. | |
874 | ||
875 | use feature ":5.14.0"; # same as ":5.14" | |
876 | use feature ":5.14.1"; # same as ":5.14" | |
877 | ||
878 | =head1 IMPLICIT LOADING | |
879 | ||
880 | Instead of loading feature bundles by name, it is easier to let Perl do | |
881 | implicit loading of a feature bundle for you. | |
882 | ||
883 | There are two ways to load the C<feature> pragma implicitly: | |
884 | ||
885 | =over 4 | |
886 | ||
887 | =item * | |
888 | ||
889 | By using the C<-E> switch on the Perl command-line instead of C<-e>. | |
890 | That will enable the feature bundle for that version of Perl in the | |
891 | main compilation unit (that is, the one-liner that follows C<-E>). | |
892 | ||
893 | =item * | |
894 | ||
895 | By explicitly requiring a minimum Perl version number for your program, with | |
896 | the C<use VERSION> construct. That is, | |
897 | ||
898 | use v5.10.0; | |
899 | ||
900 | will do an implicit | |
901 | ||
39ec54a5 | 902 | no feature ':all'; |
69bcf1d3 FC |
903 | use feature ':5.10'; |
904 | ||
905 | and so on. Note how the trailing sub-version | |
906 | is automatically stripped from the | |
907 | version. | |
908 | ||
909 | But to avoid portability warnings (see L<perlfunc/use>), you may prefer: | |
910 | ||
911 | use 5.010; | |
912 | ||
913 | with the same effect. | |
914 | ||
915 | If the required version is older than Perl 5.10, the ":default" feature | |
916 | bundle is automatically loaded instead. | |
917 | ||
affe54fa AC |
918 | Unlike C<use feature ":5.12">, saying C<use v5.12> (or any higher version) |
919 | also does the equivalent of C<use strict>; see L<perlfunc/use> for details. | |
920 | ||
69bcf1d3 FC |
921 | =back |
922 | ||
7e18321c TC |
923 | =head1 CHECKING FEATURES |
924 | ||
925 | C<feature> provides some simple APIs to check which features are enabled. | |
926 | ||
927 | These functions cannot be imported and must be called by their fully | |
928 | qualified names. If you don't otherwise need to set a feature you will | |
929 | need to ensure C<feature> is loaded with: | |
930 | ||
931 | use feature (); | |
932 | ||
933 | =over | |
934 | ||
935 | =item feature_enabled($feature) | |
936 | ||
937 | =item feature_enabled($feature, $depth) | |
938 | ||
939 | package MyStandardEnforcer; | |
940 | use feature (); | |
941 | use Carp "croak"; | |
942 | sub import { | |
943 | croak "disable indirect!" if feature::feature_enabled("indirect"); | |
944 | } | |
945 | ||
946 | Test whether a named feature is enabled at a given level in the call | |
947 | stack, returning a true value if it is. C<$depth> defaults to 1, | |
948 | which checks the scope that called the scope calling | |
949 | feature::feature_enabled(). | |
950 | ||
951 | croaks for an unknown feature name. | |
952 | ||
953 | =item features_enabled() | |
954 | ||
955 | =item features_enabled($depth) | |
956 | ||
957 | package ReportEnabledFeatures; | |
958 | use feature "say"; | |
959 | sub import { | |
960 | say STDERR join " ", feature::features_enabled(); | |
961 | } | |
962 | ||
963 | Returns a list of the features enabled at a given level in the call | |
964 | stack. C<$depth> defaults to 1, which checks the scope that called | |
965 | the scope calling feature::features_enabled(). | |
966 | ||
967 | =item feature_bundle() | |
968 | ||
969 | =item feature_bundle($depth) | |
970 | ||
971 | Returns the feature bundle, if any, selected at a given level in the | |
972 | call stack. C<$depth> defaults to 1, which checks the scope that called | |
973 | the scope calling feature::feature_bundle(). | |
974 | ||
975 | Returns an undefined value if no feature bundle is selected in the | |
976 | scope. | |
977 | ||
978 | The bundle name returned will be for the earliest bundle matching the | |
979 | selected bundle, so: | |
980 | ||
981 | use feature (); | |
982 | use v5.12; | |
983 | BEGIN { print feature::feature_bundle(0); } | |
984 | ||
985 | will print C<5.11>. | |
986 | ||
987 | This returns internal state, at this point C<use v5.12;> sets the | |
988 | feature bundle, but C< use feature ":5.12"; > does not set the feature | |
989 | bundle. This may change in a future release of perl. | |
990 | ||
991 | =back | |
992 | ||
69bcf1d3 FC |
993 | =cut |
994 | ||
995 | sub import { | |
22055af9 | 996 | shift; |
36143a0c NC |
997 | |
998 | if (!@_) { | |
69bcf1d3 FC |
999 | croak("No features specified"); |
1000 | } | |
36143a0c | 1001 | |
d3757264 | 1002 | __common(1, @_); |
69bcf1d3 FC |
1003 | } |
1004 | ||
1005 | sub unimport { | |
22055af9 | 1006 | shift; |
69bcf1d3 | 1007 | |
39ec54a5 | 1008 | # A bare C<no feature> should reset to the default bundle |
69bcf1d3 | 1009 | if (!@_) { |
39ec54a5 RS |
1010 | $^H &= ~($hint_uni8bit|$hint_mask); |
1011 | return; | |
69bcf1d3 FC |
1012 | } |
1013 | ||
d3757264 NC |
1014 | __common(0, @_); |
1015 | } | |
1016 | ||
1017 | ||
1018 | sub __common { | |
1019 | my $import = shift; | |
0c8d5017 NC |
1020 | my $bundle_number = $^H & $hint_mask; |
1021 | my $features = $bundle_number != $hint_mask | |
9f601cf3 | 1022 | && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}; |
0c8d5017 | 1023 | if ($features) { |
da5b5421 | 1024 | # Features are enabled implicitly via bundle hints. |
d9ee6ccb NC |
1025 | # Delete any keys that may be left over from last time. |
1026 | delete @^H{ values(%feature) }; | |
1027 | $^H |= $hint_mask; | |
1028 | for (@$features) { | |
1029 | $^H{$feature{$_}} = 1; | |
1030 | $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; | |
1031 | } | |
da5b5421 | 1032 | } |
69bcf1d3 FC |
1033 | while (@_) { |
1034 | my $name = shift; | |
1035 | if (substr($name, 0, 1) eq ":") { | |
1036 | my $v = substr($name, 1); | |
1037 | if (!exists $feature_bundle{$v}) { | |
1038 | $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/; | |
1039 | if (!exists $feature_bundle{$v}) { | |
1040 | unknown_feature_bundle(substr($name, 1)); | |
1041 | } | |
1042 | } | |
1043 | unshift @_, @{$feature_bundle{$v}}; | |
1044 | next; | |
1045 | } | |
36143a0c | 1046 | if (!exists $feature{$name}) { |
db629560 FC |
1047 | if (exists $noops{$name}) { |
1048 | next; | |
1049 | } | |
c22e17d0 DIM |
1050 | if (!$import && exists $removed{$name}) { |
1051 | next; | |
1052 | } | |
69bcf1d3 | 1053 | unknown_feature($name); |
69bcf1d3 | 1054 | } |
d3757264 NC |
1055 | if ($import) { |
1056 | $^H{$feature{$name}} = 1; | |
1057 | $^H |= $hint_uni8bit if $name eq 'unicode_strings'; | |
1058 | } else { | |
69bcf1d3 FC |
1059 | delete $^H{$feature{$name}}; |
1060 | $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings'; | |
1061 | } | |
1062 | } | |
1063 | } | |
1064 | ||
1065 | sub unknown_feature { | |
1066 | my $feature = shift; | |
1067 | croak(sprintf('Feature "%s" is not supported by Perl %vd', | |
1068 | $feature, $^V)); | |
1069 | } | |
1070 | ||
1071 | sub unknown_feature_bundle { | |
1072 | my $feature = shift; | |
1073 | croak(sprintf('Feature bundle "%s" is not supported by Perl %vd', | |
1074 | $feature, $^V)); | |
1075 | } | |
1076 | ||
1077 | sub croak { | |
1078 | require Carp; | |
1079 | Carp::croak(@_); | |
1080 | } | |
1081 | ||
7e18321c TC |
1082 | sub features_enabled { |
1083 | my ($depth) = @_; | |
1084 | ||
1085 | $depth //= 1; | |
1086 | my @frame = caller($depth+1) | |
1087 | or return; | |
1088 | my ($hints, $hinthash) = @frame[8, 10]; | |
1089 | ||
1090 | my $bundle_number = $hints & $hint_mask; | |
1091 | if ($bundle_number != $hint_mask) { | |
1092 | return $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}->@*; | |
1093 | } | |
1094 | else { | |
1095 | my @features; | |
1096 | for my $feature (sort keys %feature) { | |
1097 | if ($hinthash->{$feature{$feature}}) { | |
1098 | push @features, $feature; | |
1099 | } | |
1100 | } | |
1101 | return @features; | |
1102 | } | |
1103 | } | |
1104 | ||
1105 | sub feature_enabled { | |
1106 | my ($feature, $depth) = @_; | |
1107 | ||
1108 | $depth //= 1; | |
1109 | my @frame = caller($depth+1) | |
1110 | or return; | |
1111 | my ($hints, $hinthash) = @frame[8, 10]; | |
1112 | ||
1113 | my $hint_feature = $feature{$feature} | |
1114 | or croak "Unknown feature $feature"; | |
1115 | my $bundle_number = $hints & $hint_mask; | |
1116 | if ($bundle_number != $hint_mask) { | |
1117 | my $bundle = $hint_bundles[$bundle_number >> $hint_shift]; | |
1118 | for my $bundle_feature ($feature_bundle{$bundle}->@*) { | |
1119 | return 1 if $bundle_feature eq $feature; | |
1120 | } | |
1121 | return 0; | |
1122 | } | |
1123 | else { | |
1124 | return $hinthash->{$hint_feature} // 0; | |
1125 | } | |
1126 | } | |
1127 | ||
1128 | sub feature_bundle { | |
1129 | my $depth = shift; | |
1130 | ||
1131 | $depth //= 1; | |
1132 | my @frame = caller($depth+1) | |
1133 | or return; | |
1134 | my $bundle_number = $frame[8] & $hint_mask; | |
1135 | if ($bundle_number != $hint_mask) { | |
1136 | return $hint_bundles[$bundle_number >> $hint_shift]; | |
1137 | } | |
1138 | else { | |
1139 | return undef; | |
1140 | } | |
1141 | } | |
1142 | ||
69bcf1d3 | 1143 | 1; |