Commit | Line | Data |
---|---|---|
e76b2c0c | 1 | package deprecate; |
c0f08d2c | 2 | use strict; |
e76b2c0c | 3 | use warnings; |
6e9efe03 | 4 | our $VERSION = 0.03; |
e76b2c0c | 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 | ||
4ffaa343 NC |
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) = @_; | |
e76b2c0c NC |
15 | |
16 | foreach my $pair ([qw(sitearchexp archlibexp)], | |
17 | [qw(sitelibexp privlibexp)]) { | |
18 | my ($site, $priv) = @Config{@$pair}; | |
096fcbb8 CB |
19 | if ($^O eq 'VMS') { |
20 | for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) }; | |
21 | } | |
e76b2c0c NC |
22 | # Just in case anyone managed to configure with trailing /s |
23 | s!/*$!!g foreach $site, $priv; | |
24 | ||
25 | next if $site eq $priv; | |
096fcbb8 | 26 | if (uc("$priv/$expect_leaf") eq uc($file)) { |
4ffaa343 NC |
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"); | |
d4be36a8 RB |
49 | Can't find use/require $expect_leaf in caller stack |
50 | EOM | |
4ffaa343 NC |
51 | return; |
52 | } | |
d4be36a8 | 53 | |
4ffaa343 NC |
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]; | |
e76b2c0c | 57 | |
4ffaa343 NC |
58 | if (defined $callers_bitmask |
59 | && (vec($callers_bitmask, $warnings::Offsets{deprecated}, 1) | |
60 | || vec($callers_bitmask, $warnings::Offsets{all}, 1))) { | |
61 | warn <<"EOM"; | |
c0f08d2c | 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. |
e76b2c0c | 63 | EOM |
e76b2c0c NC |
64 | } |
65 | } | |
66 | } | |
67 | ||
68 | 1; | |
04fd187e RB |
69 | |
70 | __END__ | |
71 | ||
72 | =head1 NAME | |
73 | ||
b032e888 | 74 | deprecate - Perl pragma for deprecating the core version of a module |
04fd187e RB |
75 | |
76 | =head1 SYNOPSIS | |
77 | ||
555bd962 | 78 | use deprecate; # always deprecate the module in which this occurs |
04fd187e | 79 | |
555bd962 | 80 | use if $] > 5.010, 'deprecate'; # conditionally deprecate the module |
04fd187e RB |
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 | ||
4ffaa343 | 110 | Copyright (C) 2009, 2011 |
04fd187e RB |
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 |