1package deprecate; 2use strict; 3use warnings; 4our $VERSION = 0.02; 5 6# our %Config can ignore %Config::Config, e.g. for testing 7our %Config; 8unless (%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. 13sub __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 33sub 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"); 49Can't find use/require $expect_leaf in caller stack 50EOM 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. 63EOM 64 } 65 } 66} 67 681; 69 70__END__ 71 72=head1 NAME 73 74deprecate - 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 85This module is used using C<use deprecate;> (or something that calls 86C<< deprecate->import() >>, for example C<use if COND, deprecate;>). 87 88If the module that includes C<use deprecate> is located in a core library 89directory, a deprecation warning is issued, encouraging the user to use 90the version on CPAN. If that module is located in a site library, it is 91the CPAN version, and no warning is issued. 92 93=head2 EXPORT 94 95None by default. The only method is C<import>, called by C<use deprecate;>. 96 97 98=head1 SEE ALSO 99 100First example to C<use deprecate;> was L<Switch>. 101 102 103=head1 AUTHOR 104 105Original version by Nicholas Clark 106 107 108=head1 COPYRIGHT AND LICENSE 109 110Copyright (C) 2009, 2011 111 112This library is free software; you can redistribute it and/or modify 113it under the same terms as Perl itself, either Perl version 5.10.0 or, 114at your option, any later version of Perl 5 you may have available. 115 116 117=cut 118