| 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: |