1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
package feature;
our $VERSION = '1.01';
# (feature name) => (internal name, used in %^H)
my %feature = (
switch => 'feature_switch',
"~~" => "feature_~~",
say => "feature_say",
err => "feature_err",
dor => "feature_err",
state => "feature_state",
);
my %feature_bundle = (
"5.10" => [qw(switch ~~ say err state)],
);
# Here are some notes that probably shouldn't be in the public
# documentation, but which it's useful to have somewhere.
#
# One side-effect of the change is that C<prototype("CORE::continue")>
# no longer throws the error C<Can't find an opnumber for "continue">.
# One of the tests in t/op/cproto.t had to be changed to accommodate
# this, but it really shouldn't affect real-world code.
#
# TODO:
# - sort out the smartmatch semantics
# - think about versioned features (use switch => 2)
#
# -- Robin 2005-12
=head1 NAME
feature - Perl pragma to enable new syntactic features
=head1 SYNOPSIS
use feature qw(switch say);
given ($foo) {
when (1) { say "\$foo == 1" }
when ([2,3]) { say "\$foo == 2 || \$foo == 3" }
when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
when ($_ > 100) { say "\$foo > 100" }
default { say "None of the above" }
}
=head1 DESCRIPTION
It is usually impossible to add new syntax to Perl without breaking
some existing programs. This pragma provides a way to minimize that
risk. New syntactic constructs can be enabled by C<use feature 'foo'>,
and will be parsed only when the appropriate feature pragma is in
scope.
=head2 The 'switch' feature
C<use feature 'switch'> tells the compiler to enable the Perl 6
given/when construct from here to the end of the enclosing BLOCK.
See L<perlsyn/"Switch statements"> for details.
=head2 The '~~' feature
C<use feature '~~'> tells the compiler to enable the Perl 6
smart match C<~~> operator from here to the end of the enclosing BLOCK.
See L<perlsyn/"Smart Matching in Detail"> for details.
=head2 The 'say' feature
C<use feature 'say'> tells the compiler to enable the Perl 6
C<say> function from here to the end of the enclosing BLOCK.
See L<perlfunc/say> for details.
=head2 the 'err' feature
C<use feature 'err'> tells the compiler to enable the C<err>
operator from here to the end of the enclosing BLOCK.
C<err> is a low-precedence variant of the C<//> operator:
see C<perlop> for details.
=head2 the 'dor' feature
The 'dor' feature is an alias for the 'err' feature.
=head2 the 'state' feature
C<use feature 'state'> tells the compiler to enable C<state>
variables from here to the end of the enclosing BLOCK.
=head1 FEATURE BUNDLES
It's possible to load a whole slew of features in one go, using
a I<feature bundle>. The name of a feature bundle is prefixed with
a colon, to distinguish it from an actual feature. At present, the
only feature bundle is C<use feature ":5.10">, which is equivalent
to C<use feature qw(switch ~~ say err state)>.
=cut
sub import {
my $class = shift;
if (@_ == 0) {
require Carp;
Carp->import("croak");
croak("No features specified");
}
while (@_) {
my $name = shift(@_);
if ($name =~ /^:(.*)/) {
if (!exists $feature_bundle{$1}) {
require Carp;
Carp->import("croak");
croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
$1, $^V));
}
unshift @_, @{$feature_bundle{$1}};
next;
}
if (!exists $feature{$name}) {
require Carp;
Carp->import("croak");
croak(sprintf('Feature "%s" is not supported by Perl %vd',
$name, $^V));
}
$^H{$feature{$name}} = 1;
}
}
sub unimport {
my $class = shift;
# A bare C<no feature> should disable *all* features
if (!@_) {
delete @^H{ values(%feature) };
return;
}
while (@_) {
my $name = shift;
if ($name =~ /^:(.*)/) {
if (!exists $feature_bundle{$1}) {
require Carp;
Carp->import("croak");
croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
$1, $^V));
}
unshift @_, @{$feature_bundle{$1}};
next;
}
if (!exists($feature{$name})) {
require Carp;
Carp->import("croak");
croak(sprintf('Feature "%s" is not supported by Perl %vd',
$name, $^V));
}
else {
delete $^H{$feature{$name}};
}
}
}
1;
|
