lib/deprecate.pm

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