File Coverage

blib/lib/namespace/clean/_Util.pm
Criterion Covered Total %
statement 16 16 100.0
branch n/a
condition 1 3 33.3
subroutine 6 6 100.0
pod n/a
total 23 25 92.0


line stmt bran cond sub pod time code
1             ### !!!ACHTUNG!!!
2             #
3             # This module is to be loaded at configure time straight from the Makefile.PL
4             # in order to get access to some of the constants / utils
5             # None of the dependencies will be available yet at this point, so make
6             # sure to never use anything beyond what the minimum supported perl came with
7             # (no, relying on configure_requires is not ok)
8              
9             package # hide from the pauses
10             namespace::clean::_Util;
11              
12 13     13   49 use warnings;
  13         16  
  13         339  
13 13     13   41 use strict;
  13         17  
  13         258  
14              
15 13     13   50 use base 'Exporter';
  13         17  
  13         1254  
16             our @EXPORT_OK = qw( DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT );
17              
18 13   33 13   52 use constant DEBUGGER_NEEDS_CV_RENAME => ( ( "$]" > 5.008_008 ) and ( "$]" < 5.013_006 ) );
  13         13  
  13         1147  
19 13     13   53 use constant DEBUGGER_NEEDS_CV_PIVOT => ( ( ! DEBUGGER_NEEDS_CV_RENAME ) and ( "$]" < 5.015_005 ) );
  13         22  
  13         1006  
20              
21             # FIXME - ideally this needs to be provided by some abstraction lib
22             # but we don't have that yet
23             BEGIN {
24             #
25             # Note - both get_subname and set_subname are only called by one block
26             # which is compiled away unless CV_RENAME is true ( the 5.8.9 ~ 5.12 range ).
27             # Hence we compile/provide the definitions here only when needed
28             #
29 13     13   216 DEBUGGER_NEEDS_CV_RENAME and ( eval <<'EOS' or die $@ );
30             {
31             my( $sub_name_loaded, $sub_util_loaded );
32              
33             sub _namer_load_error {
34             return '' if $sub_util_loaded or $sub_name_loaded;
35              
36             # if S::N is loaded first *and* so is B - then go with that, otherwise
37             # prefer Sub::Util as S::U will provide a faster get_subname and will
38             # not need further require() calls
39             # this is rather arbitrary but remember this code exists only perls
40             # between 5.8.9 ~ 5.13.5
41              
42             # when changing version also change in Makefile.PL
43             my $sn_ver = 0.04;
44              
45             local $@;
46             my $err = '';
47              
48             (
49             ! (
50             $INC{"B.pm"}
51             and
52             $INC{"Sub/Name.pm"}
53             and
54             eval { Sub::Name->VERSION($sn_ver) }
55             )
56             and
57             eval { require Sub::Util }
58             and
59             # see https://github.com/moose/Moo/commit/dafa5118
60             defined &Sub::Util::set_subname
61             and
62             $sub_util_loaded = 1
63             )
64             or
65             (
66             eval { require Sub::Name and Sub::Name->VERSION($sn_ver) }
67             and
68             $sub_name_loaded = 1
69             )
70             or
71             $err = "When running under -d on this perl $], namespace::clean requires either Sub::Name $sn_ver or Sub::Util to be installed"
72             ;
73              
74             $err;
75             }
76              
77             sub set_subname {
78             if( my $err = _namer_load_error() ) {
79             die $err;
80             }
81             elsif( $sub_name_loaded ) {
82             &Sub::Name::subname;
83             }
84             elsif( $sub_util_loaded ) {
85             &Sub::Util::set_subname;
86             }
87             else {
88             die "How the fuck did we get here? Read source and debug please!";
89             }
90             }
91              
92             sub get_subname {
93             if(
94             _namer_load_error()
95             or
96             ! $sub_util_loaded
97             ) {
98             require B;
99             my $gv = B::svref_2object( $_[0] )->GV;
100             join '::', $gv->STASH->NAME, $gv->NAME;
101             }
102             else {
103             &Sub::Util::subname;
104             }
105             }
106             }
107             1;
108             EOS
109              
110             }
111              
112             1;