1 | | | | | # -*- buffer-read-only: t -*- |
2 | | | | | # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! |
3 | | | | | # This file is built by regen/feature.pl. |
4 | | | | | # Any changes made here will be lost! |
5 | | | | | |
6 | | | | | package feature; |
7 | | | | | |
8 | 1 | 400ns | | | our $VERSION = '1.32'; |
9 | | | | | |
10 | 1 | 6µs | | | our %feature = ( |
11 | | | | | fc => 'feature_fc', |
12 | | | | | say => 'feature_say', |
13 | | | | | state => 'feature_state', |
14 | | | | | switch => 'feature_switch', |
15 | | | | | evalbytes => 'feature_evalbytes', |
16 | | | | | array_base => 'feature_arybase', |
17 | | | | | current_sub => 'feature___SUB__', |
18 | | | | | lexical_subs => 'feature_lexsubs', |
19 | | | | | unicode_eval => 'feature_unieval', |
20 | | | | | unicode_strings => 'feature_unicode', |
21 | | | | | ); |
22 | | | | | |
23 | 1 | 6µs | | | our %feature_bundle = ( |
24 | | | | | "5.10" => [qw(array_base say state switch)], |
25 | | | | | "5.11" => [qw(array_base say state switch unicode_strings)], |
26 | | | | | "5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)], |
27 | | | | | "all" => [qw(array_base current_sub evalbytes fc lexical_subs say state switch unicode_eval unicode_strings)], |
28 | | | | | "default" => [qw(array_base)], |
29 | | | | | ); |
30 | | | | | |
31 | 1 | 1µs | | | $feature_bundle{"5.12"} = $feature_bundle{"5.11"}; |
32 | 1 | 300ns | | | $feature_bundle{"5.13"} = $feature_bundle{"5.11"}; |
33 | 1 | 400ns | | | $feature_bundle{"5.14"} = $feature_bundle{"5.11"}; |
34 | 1 | 300ns | | | $feature_bundle{"5.16"} = $feature_bundle{"5.15"}; |
35 | 1 | 200ns | | | $feature_bundle{"5.17"} = $feature_bundle{"5.15"}; |
36 | 1 | 100ns | | | $feature_bundle{"5.18"} = $feature_bundle{"5.15"}; |
37 | 1 | 200ns | | | $feature_bundle{"5.9.5"} = $feature_bundle{"5.10"}; |
38 | | | | | |
39 | 1 | 100ns | | | our $hint_shift = 26; |
40 | 1 | 0s | | | our $hint_mask = 0x1c000000; |
41 | 1 | 900ns | | | our @hint_bundles = qw( default 5.10 5.11 5.15 ); |
42 | | | | | |
43 | | | | | # This gets set (for now) in $^H as well as in %^H, |
44 | | | | | # for runtime speed of the uc/lc/ucfirst/lcfirst functions. |
45 | | | | | # See HINT_UNI_8_BIT in perl.h. |
46 | 1 | 100ns | | | our $hint_uni8bit = 0x00000800; |
47 | | | | | |
48 | | | | | # TODO: |
49 | | | | | # - think about versioned features (use feature switch => 2) |
50 | | | | | |
51 | | | | | sub import { |
52 | | | | | my $class = shift; |
53 | | | | | |
54 | | | | | if (!@_) { |
55 | | | | | croak("No features specified"); |
56 | | | | | } |
57 | | | | | |
58 | | | | | __common(1, @_); |
59 | | | | | } |
60 | | | | | |
61 | | | | | sub unimport { |
62 | | | | | my $class = shift; |
63 | | | | | |
64 | | | | | # A bare C<no feature> should reset to the default bundle |
65 | | | | | if (!@_) { |
66 | | | | | $^H &= ~($hint_uni8bit|$hint_mask); |
67 | | | | | return; |
68 | | | | | } |
69 | | | | | |
70 | | | | | __common(0, @_); |
71 | | | | | } |
72 | | | | | |
73 | | | | | sub __common { |
74 | | | | | my $import = shift; |
75 | | | | | my $bundle_number = $^H & $hint_mask; |
76 | | | | | my $features = $bundle_number != $hint_mask |
77 | | | | | && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}; |
78 | | | | | if ($features) { |
79 | | | | | # Features are enabled implicitly via bundle hints. |
80 | | | | | # Delete any keys that may be left over from last time. |
81 | | | | | delete @^H{ values(%feature) }; |
82 | | | | | $^H |= $hint_mask; |
83 | | | | | for (@$features) { |
84 | | | | | $^H{$feature{$_}} = 1; |
85 | | | | | $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; |
86 | | | | | } |
87 | | | | | } |
88 | | | | | while (@_) { |
89 | | | | | my $name = shift; |
90 | | | | | if (substr($name, 0, 1) eq ":") { |
91 | | | | | my $v = substr($name, 1); |
92 | | | | | if (!exists $feature_bundle{$v}) { |
93 | | | | | $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/; |
94 | | | | | if (!exists $feature_bundle{$v}) { |
95 | | | | | unknown_feature_bundle(substr($name, 1)); |
96 | | | | | } |
97 | | | | | } |
98 | | | | | unshift @_, @{$feature_bundle{$v}}; |
99 | | | | | next; |
100 | | | | | } |
101 | | | | | if (!exists $feature{$name}) { |
102 | | | | | unknown_feature($name); |
103 | | | | | } |
104 | | | | | if ($import) { |
105 | | | | | $^H{$feature{$name}} = 1; |
106 | | | | | $^H |= $hint_uni8bit if $name eq 'unicode_strings'; |
107 | | | | | } else { |
108 | | | | | delete $^H{$feature{$name}}; |
109 | | | | | $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings'; |
110 | | | | | } |
111 | | | | | } |
112 | | | | | } |
113 | | | | | |
114 | | | | | sub unknown_feature { |
115 | | | | | my $feature = shift; |
116 | | | | | croak(sprintf('Feature "%s" is not supported by Perl %vd', |
117 | | | | | $feature, $^V)); |
118 | | | | | } |
119 | | | | | |
120 | | | | | sub unknown_feature_bundle { |
121 | | | | | my $feature = shift; |
122 | | | | | croak(sprintf('Feature bundle "%s" is not supported by Perl %vd', |
123 | | | | | $feature, $^V)); |
124 | | | | | } |
125 | | | | | |
126 | | | | | sub croak { |
127 | | | | | require Carp; |
128 | | | | | Carp::croak(@_); |
129 | | | | | } |
130 | | | | | |
131 | 1 | 8µs | | | 1; |
132 | | | | | |
133 | | | | | # ex: set ro: |