lib/feature.pm

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