lib/deprecate.pm

   1 #!perl -w
   2 use strict;
   3
   4 package deprecate;
   5 use Config;
   6 use Carp;
   7 use warnings;
   8 our $VERSION = 0.01;
   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         # Just in case anyone managed to configure with trailing /s
  19         s!/*$!!g foreach $site, $priv;
  20
  21         next if $site eq $priv;
  22         if ("$priv/$expect_leaf" eq $file) {
  23             my $call_depth=1;
  24             my @caller;
  25             while (@caller = caller $call_depth++) {
  26                 last if $caller[7]                      # use/require
  27                     and $caller[6] eq $expect_leaf;     # the package file
  28             }
  29             unless (@caller) {
  30                 require Carp;
  31                 Carp::cluck(<<"EOM");
  32 Can't find use/require $expect_leaf in caller stack
  33 EOM
  34                 next;
  35             }
  36
  37             # This is fragile, because it
  38             # is directly poking in the internals of warnings.pm
  39             my ($call_file, $call_line, $callers_bitmask) = @caller[1,2,9];
  40
  41             if (defined $callers_bitmask
  42                 && (vec($callers_bitmask, $warnings::Offsets{deprecated}, 1)
  43                     || vec($callers_bitmask, $warnings::Offsets{all}, 1))) {
  44                 warn <<"EOM";
  45 $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
  46 EOM
  47             }
  48             return;
  49         }
  50     }
  51 }
  52
  53 1;