lib/namespace/clean/_Util.pm

   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 use warnings;
  13 use strict;
  14
  15 use base 'Exporter';
  16 our @EXPORT_OK = qw( DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT );
  17
  18 use constant DEBUGGER_NEEDS_CV_RENAME => ( ( $] > 5.008_008 ) and ( $] < 5.013_006 ) );
  19 use constant DEBUGGER_NEEDS_CV_PIVOT => ( ( ! DEBUGGER_NEEDS_CV_RENAME ) and ( $] < 5.015_005 ) );
  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   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;