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}; | |
096fcbb8 CB |
18 | if ($^O eq 'VMS') { |
19 | for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) }; | |
20 | } | |
e76b2c0c NC |
21 | # Just in case anyone managed to configure with trailing /s |
22 | s!/*$!!g foreach $site, $priv; | |
23 | ||
24 | next if $site eq $priv; | |
096fcbb8 | 25 | if (uc("$priv/$expect_leaf") eq uc($file)) { |
d4be36a8 RB |
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 | ||
e76b2c0c | 40 | # This is fragile, because it |
d4be36a8 RB |
41 | # is directly poking in the internals of warnings.pm |
42 | my ($call_file, $call_line, $callers_bitmask) = @caller[1,2,9]; | |
e76b2c0c NC |
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"; | |
c0f08d2c | 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. |
e76b2c0c NC |
49 | EOM |
50 | } | |
51 | return; | |
52 | } | |
53 | } | |
54 | } | |
55 | ||
56 | 1; | |
04fd187e RB |
57 | |
58 | __END__ | |
59 | ||
60 | =head1 NAME | |
61 | ||
b032e888 | 62 | deprecate - Perl pragma for deprecating the core version of a module |
04fd187e RB |
63 | |
64 | =head1 SYNOPSIS | |
65 | ||
66 | use deprecate; # always deprecate the module in which this occurs | |
67 | ||
6fcc101e | 68 | use if $] > 5.010, 'deprecate'; # conditionally deprecate the module |
04fd187e RB |
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 |