File Coverage

blib/lib/MongoDB/Role/_DeprecationWarner.pm
Criterion Covered Total %
statement 15 57 26.3
branch 0 20 0.0
condition 0 7 0.0
subroutine 5 10 50.0
pod n/a
total 20 94 21.2


line stmt bran cond sub pod time code
1             # Copyright 2016 - present MongoDB, Inc.
2             #
3             # Licensed under the Apache License, Version 2.0 (the "License");
4             # you may not use this file except in compliance with the License.
5             # You may obtain a copy of the License at
6             #
7             # http://www.apache.org/licenses/LICENSE-2.0
8             #
9             # Unless required by applicable law or agreed to in writing, software
10             # distributed under the License is distributed on an "AS IS" BASIS,
11             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12             # See the License for the specific language governing permissions and
13             # limitations under the License.
14              
15 59     59   84458 use strict;
  59         134  
  59         1738  
16 59     59   293 use warnings;
  59         118  
  59         2338  
17             package MongoDB::Role::_DeprecationWarner;
18              
19             # MongoDB interface for issuing deprecation warnings
20              
21 59     59   334 use version;
  59         126  
  59         903  
22             our $VERSION = 'v2.2.2';
23              
24 59     59   4720 use Moo::Role;
  59         116  
  59         385  
25              
26 59     59   18082 use namespace::clean;
  59         122  
  59         355  
27              
28             my %CALL_SITES;
29              
30             sub _warn_deprecated_method {
31 0     0     my ( $self, $old, $new ) = @_;
32              
33 0 0         return if $ENV{PERL_MONGO_NO_DEP_WARNINGS};
34 0           my $trace = _get_trace();
35 0 0         return unless defined $trace; # already warned from this location
36              
37 0           my $msg = "# The '$old' method will be removed in a future major release.";
38 0           $msg .= _get_alternative($new);
39              
40 0           return __warn_deprecated($msg, $trace);
41             }
42              
43             # Expected to be called from BUILD
44             sub _warn_deprecated_class {
45 0     0     my ( $self, $old, $new, $uplevel ) = @_;
46              
47 0 0         return if $ENV{PERL_MONGO_NO_DEP_WARNINGS};
48              
49 0           my $trace = _get_trace(2);
50 0 0         return unless defined $trace; # already warned from this location
51              
52 0           my $msg = "# The '$old' class will be removed in a future major release.";
53 0           $msg .= _get_alternative($new);
54              
55             # fixup name of constructor
56 0           my $class = ref($self);
57 0           $trace =~ s/\S+ called at/${class}::new called at/;
58              
59 0           return __warn_deprecated($msg, $trace);
60             }
61              
62             sub __warn_deprecated {
63 0     0     my ( $msg, $trace ) = @_;
64 0           chomp $msg;
65 0           warn("#\n# *** DEPRECATION WARNING ***\n#\n$msg\n$trace");
66 0           return;
67             }
68              
69             sub _get_alternative {
70 0     0     my ($new) = @_;
71             # Arrayref is a list of replacement methods; string is just a message
72 0 0         if ( ref $new eq 'ARRAY' ) {
73 0 0         if ( @$new == 1 ) {
    0          
74 0           return "\n# Use '$new->[0]' instead.";
75             }
76             elsif (@$new > 1) {
77 0           my $last = pop @$new;
78 0           my $list = join(", ", map { "'$_'" } @$new);
  0            
79 0           return "\n# Use $list or '$last' instead.";
80             }
81             else {
82 0           return "";
83             }
84             }
85 0   0       return "\n # $new" // "";
86             }
87              
88             sub _get_trace {
89 0     0     my ($uplevel) = @_;
90 0   0       $uplevel //= 0;
91              
92 0           my ( $callsite_found, $pkg, $file, $line, $sub );
93 0           my ( $trace, $i ) = ( "", $uplevel + 1 );
94              
95             # Accumulate the stack trace. Start at uplevel + caller(2) to skip
96             # '__warn_deprecated' and its internal caller in the stack trace
97 0           while ( ++$i ) {
98             # Use CORE::caller to get a real stack-trace, not one overridden by
99             # CORE::GLOBAL::caller
100 0           ( $pkg, $file, $line, $sub ) = CORE::caller($i);
101 0 0         last unless defined $pkg;
102              
103             # We want to check the deprecated function's caller and shortcut if
104             # we've already reported from that location. As we walk up the
105             # stack to build the trace, the first caller is usually the
106             # call-site, but we ignore Sub::Uplevel and use the first
107             # non-uplevel caller as the call-site.
108              
109 0 0 0       if ( !$callsite_found && $pkg ne 'Sub::Uplevel' ) {
110 0           $callsite_found++;
111 0 0         return if $CALL_SITES{ $pkg, $line, $file }++;
112             }
113              
114 0           $trace .= "# $sub called at $file line $line\n";
115             }
116              
117 0           return $trace;
118             }
119              
120              
121             1;