lib/deprecate.pm

   1 package deprecate;
   2 use strict;
   3 use warnings;
   4 our $VERSION = 0.01;
   5
   6 # our %Config can ignore %Config::Config, e.g. for testing
   7 our %Config;
   8 unless (%Config) { require Config; *Config = \%Config::Config; }
   9
  10 sub import {
  11     my ($package, $file, $line) = caller;
  12     my $expect_leaf = "$package.pm";
  13     $expect_leaf =~ s!::!/!g;
  14
  15     foreach my $pair ([qw(sitearchexp archlibexp)],
  16                       [qw(sitelibexp privlibexp)]) {
  17         my ($site, $priv) = @Config{@$pair};
  18         if ($^O eq 'VMS') {
  19             for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) };
  20         }
  21         # Just in case anyone managed to configure with trailing /s
  22         s!/*$!!g foreach $site, $priv;
  23
  24         next if $site eq $priv;
  25         if (uc("$priv/$expect_leaf") eq uc($file)) {
  26             my $call_depth=1;
  27             my @caller;
  28             while (@caller = caller $call_depth++) {
  29                 last if $caller[7]                      # use/require
  30                     and $caller[6] eq $expect_leaf;     # the package file
  31             }
  32             unless (@caller) {
  33                 require Carp;
  34                 Carp::cluck(<<"EOM");
  35 Can't find use/require $expect_leaf in caller stack
  36 EOM
  37                 next;
  38             }
  39
  40             # This is fragile, because it
  41             # is directly poking in the internals of warnings.pm
  42             my ($call_file, $call_line, $callers_bitmask) = @caller[1,2,9];
  43
  44             if (defined $callers_bitmask
  45                 && (vec($callers_bitmask, $warnings::Offsets{deprecated}, 1)
  46                     || vec($callers_bitmask, $warnings::Offsets{all}, 1))) {
  47                 warn <<"EOM";
  48 $package will be removed from the Perl core distribution in the next major release. Please install it from CPAN. It is being used at $call_file, line $call_line.
  49 EOM
  50             }
  51             return;
  52         }
  53     }
  54 }
  55
  56 1;
  57
  58 __END__
  59
  60 =head1 NAME
  61
  62 deprecate - Perl pragma for deprecating the core version of a module
  63
  64 =head1 SYNOPSIS
  65
  66     use deprecate;      # always deprecate the module in which this occurs
  67
  68     use if $] > 5.010, 'deprecate';     # conditionally deprecate the module
  69
  70
  71 =head1 DESCRIPTION
  72
  73 This module is used using C<use deprecate;> (or something that calls
  74 C<< deprecate->import() >>, for example C<use if COND, deprecate;>).
  75
  76 If the module that includes C<use deprecate> is located in a core library
  77 directory, a deprecation warning is issued, encouraging the user to use
  78 the version on CPAN.  If that module is located in a site library, it is
  79 the CPAN version, and no warning is issued.
  80
  81 =head2 EXPORT
  82
  83 None by default.  The only method is C<import>, called by C<use deprecate;>.
  84
  85
  86 =head1 SEE ALSO
  87
  88 First example to C<use deprecate;> was L<Switch>.
  89
  90
  91 =head1 AUTHOR
  92
  93 Original version by Nicholas Clark
  94
  95
  96 =head1 COPYRIGHT AND LICENSE
  97
  98 Copyright (C) 2009
  99
 100 This library is free software; you can redistribute it and/or modify
 101 it under the same terms as Perl itself, either Perl version 5.10.0 or,
 102 at your option, any later version of Perl 5 you may have available.
 103
 104
 105 =cut