Commit | Line | Data |
---|---|---|
e76b2c0c | 1 | package deprecate; |
c0f08d2c | 2 | use strict; |
e76b2c0c | 3 | use warnings; |
4348516b | 4 | our $VERSION = 0.04; |
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 | ||
776df88f | 74 | deprecate - Perl pragma for deprecating the inclusion of a module in core |
04fd187e RB |
75 | |
76 | =head1 SYNOPSIS | |
77 | ||
776df88f | 78 | use deprecate; # warn about future absence if loaded from core |
04fd187e RB |
79 | |
80 | ||
81 | =head1 DESCRIPTION | |
82 | ||
776df88f AP |
83 | This pragma simplifies the maintenance of dual-life modules that will no longer |
84 | be included in the Perl core in a future Perl release, but are still included | |
85 | currently. | |
86 | ||
87 | The purpose of the pragma is to alert users to the status of such a module by | |
88 | issuing a warning that encourages them to install the module from CPAN, so that | |
89 | a future upgrade to a perl which omits the module will not break their code. | |
90 | ||
91 | This warning will only be issued if the module was loaded from a core library | |
92 | directory, which allows the C<use deprecate> line to be included in the CPAN | |
93 | version of the module. Because the pragma remains silent when the module is run | |
94 | from a non-core library directory, the pragma call does not need to be patched | |
95 | into or out of either the core or CPAN version of the module. The exact same | |
96 | code can be shipped for either purpose. | |
97 | ||
98 | =head2 Important Caveat | |
99 | ||
100 | Note that when a module installs from CPAN to a core library directory rather | |
101 | than the site library directories, the user gains no protection from having | |
102 | installed it. | |
103 | ||
104 | At the same time, this pragma cannot detect when such a module has installed | |
105 | from CPAN to the core library, and so it would endlessly and uselessly exhort | |
106 | the user to upgrade. | |
107 | ||
108 | Therefore modules that can install from CPAN to the core library must make sure | |
109 | not to call this pragma when they have done so. Generally this means that the | |
110 | exact logic from the installer must be mirrored inside the module. E.g.: | |
111 | ||
112 | # Makefile.PL | |
113 | WriteMakefile( | |
114 | # ... | |
115 | INSTALLDIRS => ( "$]" >= 5.011 ? 'site' : 'perl' ), | |
116 | ); | |
117 | ||
118 | # lib/Foo/Bar.pm | |
119 | use if "$]" >= 5.011, 'deprecate'; | |
120 | ||
121 | (The above example shows the most important case of this: when the target is | |
122 | a Perl older than 5.12 (where the core library directories take precedence over | |
123 | the site library directories) and the module being installed was included in | |
124 | core in that Perl version. Under those circumstances, an upgrade of the module | |
125 | from CPAN is only possible by installing to the core library.) | |
04fd187e | 126 | |
a64ac81e AP |
127 | |
128 | =head1 EXPORT | |
04fd187e RB |
129 | |
130 | None by default. The only method is C<import>, called by C<use deprecate;>. | |
131 | ||
132 | ||
133 | =head1 SEE ALSO | |
134 | ||
135 | First example to C<use deprecate;> was L<Switch>. | |
136 | ||
137 | ||
138 | =head1 AUTHOR | |
139 | ||
140 | Original version by Nicholas Clark | |
141 | ||
142 | ||
143 | =head1 COPYRIGHT AND LICENSE | |
144 | ||
4ffaa343 | 145 | Copyright (C) 2009, 2011 |
04fd187e RB |
146 | |
147 | This library is free software; you can redistribute it and/or modify | |
148 | it under the same terms as Perl itself, either Perl version 5.10.0 or, | |
149 | at your option, any later version of Perl 5 you may have available. | |
150 | ||
151 | ||
152 | =cut |