File Coverage

blib/lib/namespace/clean/_Util.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch	2	4	50.0
condition	1	3	33.3
subroutine	8	8	100.0
pod	0	1	0.0
total	33	40	82.5

###       !!!ACHTUNG!!!
#
# This module is to be loaded at configure time straight from the Makefile.PL
# in order to get access to some of the constants / utils
# None of the dependencies will be available yet at this point, so make
# sure to never use anything beyond what the minimum supported perl came with
# (no, relying on configure_requires is not ok)

package namespace::clean::_Util;

use warnings;
use strict;

use base 'Exporter';
our @EXPORT_OK = qw( stash_for DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT );

# FIXME This is a crock of shit, needs to go away
# currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151
# kill ith fire when PS::XS is *finally* fixed
BEGIN {
  my $provider;

  if ( $] < 5.008007 ) {
    require Package::Stash::PP;
    $provider = 'Package::Stash::PP';
  }
  else {
    require Package::Stash;
    $provider = 'Package::Stash';
  }
  eval <<"EOS" or die $@;

sub stash_for (\$) {
  $provider->new(\$_[0]);
}

1;

EOS
}

use constant DEBUGGER_NEEDS_CV_RENAME => ( ( $] > 5.008_008 ) and ( $] < 5.013_006 ) );
use constant DEBUGGER_NEEDS_CV_PIVOT => ( ( ! DEBUGGER_NEEDS_CV_RENAME ) and ( $] < 5.015_005 ) );

# FIXME - ideally this needs to be provided by some abstraction lib
# but we don't have that yet
BEGIN {
  DEBUGGER_NEEDS_CV_RENAME and ( eval <<'EOS' or die $@ );
{
  my( $sub_name_loaded, $sub_util_loaded );

  sub _namer_load_error {
    my $err = '';

    return $err if $sub_util_loaded or $sub_name_loaded;

    local $@;

    # prefer Sub::Name to Sub::Util
    # this is rather arbitrary but remember this code exists only
    # on perls 5.8.9 ~ 5.13.5

    # when changing version also change in Makefile.PL
    my $sn_ver = 0.04;

    eval {
      require Sub::Name;
      Sub::Name->VERSION($sn_ver);
      $sub_name_loaded = 1;
    }
      or
    eval {
      require Sub::Util;
      $sub_util_loaded = 1;
    }
      or
    $err = "When running under -d on this perl $], namespace::clean requires either Sub::Name $sn_ver or Sub::Util to be installed"
    ;

    $err;
  }

  sub set_subname {
    if( my $err = _namer_load_error() ) {
      die $err;
    }
    elsif( $sub_name_loaded ) {
      &Sub::Name::subname;
    }
    elsif( $sub_util_loaded ) {
      &Sub::Util::set_subname;
    }
    else {
      die "How the fuck did we get here? Read source and debug please!";
    }
  }

  sub get_subname {
    if(
      _namer_load_error()
        or
      ! $sub_util_loaded
    ) {
      require B;
      my $gv = B::svref_2object( $_[0] )->GV;
      join '::', $gv->STASH->NAME, $gv->NAME;
    }
    else {
      &Sub::Util::subname;
    }
  }
}
1;
EOS

}

1;