lib/legacy.pm

   1 package legacy;
   2
   3 our $VERSION = '1.00';
   4
   5 $unicode8bit::hint_bits = 0x00000800;
   6
   7 my %legacy_bundle = (
   8     "5.10" => [qw(unicode8bit)],
   9     "5.11" => [qw(unicode8bit)],
  10 );
  11
  12 my %legacy = ( 'unicode8bit' => '0' );
  13
  14 =head1 NAME
  15
  16 legacy - Perl pragma to preserve legacy behaviors or enable new non-default
  17 behaviors
  18
  19 =head1 SYNOPSIS
  20
  21  use legacy ':5.10'; # Keeps semantics the same as in perl 5.10
  22
  23  no legacy;
  24
  25 =cut
  26
  27     #no legacy qw(unicode8bit);
  28
  29 =pod
  30
  31 =head1 DESCRIPTION
  32
  33 Some programs may rely on behaviors that for others are problematic or
  34 even wrong.  A new version of Perl may change behaviors from past ones,
  35 and when it is viewed that the old way of doing things may be required
  36 to still be supported, that behavior will be added to the list recognized
  37 by this pragma to allow that.
  38
  39 Additionally, a new behavior may be supported in a new version of Perl, but
  40 for whatever reason the default remains the old one.  This pragma can enable
  41 the new behavior.
  42
  43 Like other pragmas (C<use feature>, for example), C<use legacy qw(foo)> will
  44 only make the legacy behavior for "foo" available from that point to the end of
  45 the enclosing block.
  46
  47 B<This pragma is, for the moment, a skeleton and does not actually affect any
  48 behaviors yet>
  49
  50 =head2 B<use legacy>
  51
  52 Preserve the old way of doing things when a new version of Perl is
  53 released that changes things
  54
  55 =head2 B<no legacy>
  56
  57 Turn on a new behavior in a version of Perl that understands
  58 it but has it turned off by default.  For example, C<no legacy 'foo'> turns on
  59 behavior C<foo> in the lexical scope of the pragma.  Simply C<no legacy>
  60 turns on all new behaviors known to the pragma.
  61
  62 =head1 LEGACY BUNDLES
  63
  64 It's possible to turn off all new behaviors past a given release by
  65 using a I<legacy bundle>, which is the name of the release prefixed with
  66 a colon, to distinguish it from an individual legacy behavior.
  67
  68 Specifying sub-versions such as the C<0> in C<5.10.0> in legacy bundles has
  69 no effect: legacy bundles are guaranteed to be the same for all sub-versions.
  70
  71 Legacy bundles are not allowed with C<no legacy>
  72
  73 =cut
  74
  75 sub import {
  76     my $class = shift;
  77     if (@_ == 0) {
  78         croak("No legacy behaviors specified");
  79     }
  80     while (@_) {
  81         my $name = shift(@_);
  82         if (substr($name, 0, 1) eq ":") {
  83             my $v = substr($name, 1);
  84             if (!exists $legacy_bundle{$v}) {
  85                 $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
  86                 if (!exists $legacy_bundle{$v}) {
  87                     unknown_legacy_bundle(substr($name, 1));
  88                 }
  89             }
  90             unshift @_, @{$legacy_bundle{$v}};
  91             next;
  92         }
  93         if (!exists $legacy{$name}) {
  94             unknown_legacy($name);
  95         }
  96         $^H &= ~$unicode8bit::hint_bits;    # The only thing it could be as of yet
  97     }
  98 }
  99
 100
 101 sub unimport {
 102     my $class = shift;
 103
 104     # A bare C<no legacy> should disable *all* legacy behaviors
 105     if (!@_) {
 106         unshift @_, keys(%legacy);
 107     }
 108
 109     while (@_) {
 110         my $name = shift;
 111         if (substr($name, 0, 1) eq ":") {
 112             croak(sprintf('Legacy bundles (%s) are not allowed in "no legacy"',
 113                 $name));
 114         }
 115         if (!exists($legacy{$name})) {
 116             unknown_legacy($name);
 117         }
 118         else {
 119             $^H |= $unicode8bit::hint_bits; # The only thing it could be as of yet
 120         }
 121     }
 122 }
 123
 124 sub unknown_legacy {
 125     my $legacy = shift;
 126     croak(sprintf('Legacy "%s" is not supported by Perl %vd', $legacy, $^V));
 127 }
 128
 129 sub unknown_legacy_bundle {
 130     my $legacy = shift;
 131     croak(sprintf('Legacy bundle "%s" is not supported by Perl %vd',
 132         $legacy, $^V));
 133 }
 134
 135 sub croak {
 136     require Carp;
 137     Carp::croak(@_);
 138 }
 139
 140 1;