XS::APItest, svpeek.t: Test the correct thing
[perl.git] / lib / deprecate.pm
1 package deprecate;
2 use strict;
3 use warnings;
4 our $VERSION = 0.03;
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