Commit | Line | Data |
---|---|---|
e76b2c0c | 1 | package deprecate; |
c0f08d2c | 2 | use strict; |
e76b2c0c NC |
3 | use warnings; |
4 | our $VERSION = 0.01; | |
5 | ||
c0f08d2c RB |
6 | # our %Config can ignore %Config::Config, e.g. for testing |
7 | our %Config; | |
8 | unless (%Config) { require Config; *Config = \%Config::Config; } | |
9 | ||
e76b2c0c NC |
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) { | |
d4be36a8 RB |
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 | ||
e76b2c0c | 37 | # This is fragile, because it |
d4be36a8 RB |
38 | # is directly poking in the internals of warnings.pm |
39 | my ($call_file, $call_line, $callers_bitmask) = @caller[1,2,9]; | |
e76b2c0c NC |
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"; | |
c0f08d2c | 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. |
e76b2c0c NC |
46 | EOM |
47 | } | |
48 | return; | |
49 | } | |
50 | } | |
51 | } | |
52 | ||
53 | 1; | |
04fd187e RB |
54 | |
55 | __END__ | |
56 | ||
57 | =head1 NAME | |
58 | ||
b032e888 | 59 | deprecate - Perl pragma for deprecating the core version of a module |
04fd187e RB |
60 | |
61 | =head1 SYNOPSIS | |
62 | ||
63 | use deprecate; # always deprecate the module in which this occurs | |
64 | ||
65 | use if $[ > 5.010, 'deprecate'; # conditionally deprecate the module | |
66 | ||
67 | ||
68 | =head1 DESCRIPTION | |
69 | ||
70 | This module is used using C<use deprecate;> (or something that calls | |
71 | C<< deprecate->import() >>, for example C<use if COND, deprecate;>). | |
72 | ||
73 | If the module that includes C<use deprecate> is located in a core library | |
74 | directory, a deprecation warning is issued, encouraging the user to use | |
75 | the version on CPAN. If that module is located in a site library, it is | |
76 | the CPAN version, and no warning is issued. | |
77 | ||
78 | =head2 EXPORT | |
79 | ||
80 | None by default. The only method is C<import>, called by C<use deprecate;>. | |
81 | ||
82 | ||
83 | =head1 SEE ALSO | |
84 | ||
85 | First example to C<use deprecate;> was L<Switch>. | |
86 | ||
87 | ||
88 | =head1 AUTHOR | |
89 | ||
90 | Original version by Nicholas Clark | |
91 | ||
92 | ||
93 | =head1 COPYRIGHT AND LICENSE | |
94 | ||
95 | Copyright (C) 2009 | |
96 | ||
97 | This library is free software; you can redistribute it and/or modify | |
98 | it under the same terms as Perl itself, either Perl version 5.10.0 or, | |
99 | at your option, any later version of Perl 5 you may have available. | |
100 | ||
101 | ||
102 | =cut |