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     my $err = '';
  35
  36     return $err if $sub_util_loaded or $sub_name_loaded;
  37
  38     local $@;
  39
  40     # prefer Sub::Name to Sub::Util
  41     # this is rather arbitrary but remember this code exists only
  42     # on perls 5.8.9 ~ 5.13.5
  43
  44     # when changing version also change in Makefile.PL
  45     my $sn_ver = 0.04;
  46
  47     eval {
  48       require Sub::Name;
  49       Sub::Name->VERSION($sn_ver);
  50       $sub_name_loaded = 1;
  51     }
  52       or
  53     eval {
  54       require Sub::Util;
  55       $sub_util_loaded = 1;
  56     }
  57       or
  58     $err = "When running under -d on this perl $], namespace::clean requires either Sub::Name $sn_ver or Sub::Util to be installed"
  59     ;
  60
  61     $err;
  62   }
  63
  64   sub set_subname {
  65     if( my $err = _namer_load_error() ) {
  66       die $err;
  67     }
  68     elsif( $sub_name_loaded ) {
  69       &Sub::Name::subname;
  70     }
  71     elsif( $sub_util_loaded ) {
  72       &Sub::Util::set_subname;
  73     }
  74     else {
  75       die "How the fuck did we get here? Read source and debug please!";
  76     }
  77   }
  78
  79   sub get_subname {
  80     if(
  81       _namer_load_error()
  82         or
  83       ! $sub_util_loaded
  84     ) {
  85       require B;
  86       my $gv = B::svref_2object( $_[0] )->GV;
  87       join '::', $gv->STASH->NAME, $gv->NAME;
  88     }
  89     else {
  90       &Sub::Util::subname;
  91     }
  92   }
  93 }
  94 1;
  95 EOS
  96
  97 }
  98
  99 1;