Profile of deprecate.pm

Filename	/usr/share/perl/5.20/deprecate.pm
Statements	Executed 0 statements in 0s

Line	Calls	Time in subs	Code
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			# Debian-specific change: recommend the separate Debian packages of
11			# deprecated modules where available
12
13			our %DEBIAN_PACKAGES = (
14			'CGI' => 'libcgi-pm-perl',
15			'CGI::Apache' => 'libcgi-pm-perl',
16			'CGI::Carp' => 'libcgi-pm-perl',
17			'CGI::Cookie' => 'libcgi-pm-perl',
18			'CGI::Fast' => 'libcgi-fast-perl',
19			'CGI::Pretty' => 'libcgi-pm-perl',
20			'CGI::Push' => 'libcgi-pm-perl',
21			'CGI::Switch' => 'libcgi-pm-perl',
22			'CGI::Util' => 'libcgi-pm-perl',
23			'Module::Build' => 'libmodule-build-perl',
24			'Package::Constants' => 'libpackage-constants-perl',
25			);
26
27			# This isn't a public API. It's internal to code maintained by the perl-porters
28			# If you would like it to be a public API, please send a patch with
29			# documentation and tests. Until then, it may change without warning.
30			sub __loaded_from_core {
31			my ($package, $file, $expect_leaf) = @_;
32
33			foreach my $pair ([qw(sitearchexp archlibexp)],
34			[qw(sitelibexp privlibexp)]) {
35	4	23µs	my ($site, $priv) = @Config{@$pair}; # spent 23µs making 4 calls to Config::FETCH, avg 6µs/call
36			if ($^O eq 'VMS') {
37			for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) };
38			}
39			# Just in case anyone managed to configure with trailing /s
40			s!/*$!!g foreach $site, $priv;
41
42			next if $site eq $priv;
43			if (uc("$priv/$expect_leaf") eq uc($file)) {
44			return 1;
45			}
46			}
47			return 0;
48			}
49
50			sub import {
51			my ($package, $file) = caller;
52
53			my $expect_leaf = "$package.pm";
54			$expect_leaf =~ s!::!/!g;
55
56			if (__loaded_from_core($package, $file, $expect_leaf)) {
57			my $call_depth=1;
58			my @caller;
59			while (@caller = caller $call_depth++) {
60			last if $caller[7] # use/require
61			and $caller[6] eq $expect_leaf; # the package file
62			}
63			unless (@caller) {
64			require Carp;
65			Carp::cluck(<<"EOM");
66			Can't find use/require $expect_leaf in caller stack
67			EOM
68			return;
69			}
70
71			# This is fragile, because it
72			# is directly poking in the internals of warnings.pm
73			my ($call_file, $call_line, $callers_bitmask) = @caller[1,2,9];
74
75			if (defined $callers_bitmask
76			&& (vec($callers_bitmask, $warnings::Offsets{deprecated}, 1)
77			\|\| vec($callers_bitmask, $warnings::Offsets{all}, 1))) {
78			if (my $deb = $DEBIAN_PACKAGES{$package}) {
79			warn <<"EOM";
80			$package will be removed from the Perl core distribution in the next major release. Please install the separate $deb package. It is being used at $call_file, line $call_line.
81			EOM
82			} else {
83			warn <<"EOM";
84			$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.
85			EOM
86			}
87			}
88			}
89			}
90
91			1;
92
93			__END__
94
95			=head1 NAME
96
97			deprecate - Perl pragma for deprecating the core version of a module
98
99			=head1 SYNOPSIS
100
101			use deprecate; # always deprecate the module in which this occurs
102
103			use if $] > 5.010, 'deprecate'; # conditionally deprecate the module
104
105
106			=head1 DESCRIPTION
107
108			This module is used using C<use deprecate;> (or something that calls
109			C<< deprecate->import() >>, for example C<use if COND, deprecate;>).
110
111			If the module that includes C<use deprecate> is located in a core library
112			directory, a deprecation warning is issued, encouraging the user to use
113			the version on CPAN. If that module is located in a site library, it is
114			the CPAN version, and no warning is issued.
115
116			=head2 EXPORT
117
118			None by default. The only method is C<import>, called by C<use deprecate;>.
119
120
121			=head1 SEE ALSO
122
123			First example to C<use deprecate;> was L<Switch>.
124
125
126			=head1 AUTHOR
127
128			Original version by Nicholas Clark
129
130
131			=head1 COPYRIGHT AND LICENSE
132
133			Copyright (C) 2009, 2011
134
135			This library is free software; you can redistribute it and/or modify
136			it under the same terms as Perl itself, either Perl version 5.10.0 or,
137			at your option, any later version of Perl 5 you may have available.
138
139
140			=cut