File Coverage

blib/lib/Devel/GlobalPhase.pm

Criterion	Covered	Total	%
statement	23	24	95.8
branch	7	12	58.3
condition	3	6	50.0
subroutine	7	7	100.0
pod	1	2	50.0
total	41	51	80.3

package Devel::GlobalPhase;
use strict;
use warnings;

our $VERSION = '0.002004';
$VERSION = eval $VERSION;

use base 'Exporter';

our @EXPORT = qw(global_phase);

sub global_phase ();
sub tie_global_phase;

sub import {
  my $class = shift;
  my $var;
  my @imports = map {
    ($_ && $_ eq '-var') ? do {
      $var = 1;
      ();
    } : $_;
  } @_;
  if (@imports || !$var) {
    Exporter::export_to_level($class, 1, @imports);
  }
  if ($var) {
    tie_global_phase;
  }
}

BEGIN {
  if (defined ${^GLOBAL_PHASE}) {
    eval <<'END_CODE' or die $@;

sub global_phase () {
  return ${^GLOBAL_PHASE};
}

sub tie_global_phase { 1 }

1;

END_CODE
  }
  else {
    eval <<'END_CODE' or die $@;

use B ();

my $global_phase = 'START';
if (B::main_start()->isa('B::NULL')) {
  # loaded during initial compile
  eval <<'END_EVAL' or die $@;

    CHECK { $global_phase = 'CHECK' }
    # try to install an END block as late as possible so it will run first.
    INIT  { eval q( END { $global_phase = 'END' } ) }
    # INIT is FIFO so we can force our sub to be first
    unshift @{ B::init_av()->object_2svref }, sub { $global_phase = 'INIT' };

    1;

END_EVAL
}
else {
  # loaded during runtime
  $global_phase = 'RUN';
}
END { $global_phase = 'END' }

sub global_phase () {
  if ($global_phase eq 'DESTRUCT') {
    # no need for extra checks at this point
  }
  elsif ($global_phase eq 'START') {
    # we use a CHECK block to set this as well, but we can't force
    # ours to run before other CHECKS
    if (!B::main_root()->isa('B::NULL') && B::main_cv()->DEPTH == 0) {
      $global_phase = 'CHECK';
    }
  }
  elsif (${B::main_cv()} == 0) {
    $global_phase = 'DESTRUCT';
  }
  elsif ($global_phase eq 'INIT' && B::main_cv()->DEPTH > 0) {
    $global_phase = 'RUN';
  }

  if ($global_phase eq 'RUN' && $^S) {
    # END blocks are FILO so we can't install one to run first.
    # only way to detect END reliably seems to be by using caller.
    # I hate this but it seems to be the best available option.
    # The top two frames will be an eval and the END block.
    my $i = 0;
    $i++ while CORE::caller($i + 1);
    if ($i < 1) {
      # there should always be the sub call and an eval frame ($^S is true).
      # this will only happen if we're in END, but the outer frames are broken.
      $global_phase = 'END';
    }
    elsif ($i > 1) {
      # If we're ENDing due to an exit or die in a sub generated in an eval,
      # these caller calls can cause a segfault.  I can't find a way to detect
      # this.
      my @top = CORE::caller($i);
      my @next = CORE::caller($i - 1);
      if (
        $top[3] eq '(eval)'
        && $next[3] =~ /::END$/
        && $top[2] == $next[2]
        && $top[1] eq $next[1]
        && $top[0] eq 'main'
        && $next[0] eq 'main'
      ) {
        $global_phase = 'END';
      }
    }
  }

  return $global_phase;
}

{
  package # hide
    Devel::GlobalPhase::_Tie;

  sub TIESCALAR { bless \(my $s), $_[0]; }
  sub STORE { die sprintf "Modification of a read-only value attempted at %s line %s.\n", (caller(0))[1,2]; }
  *FETCH = \&Devel::GlobalPhase::global_phase;
  sub DESTROY {
    my $tied = tied ${^GLOBAL_PHASE};
    if ($tied && $tied == $_[0]) {
      untie ${^GLOBAL_PHASE};
      my $phase = Devel::GlobalPhase::global_phase;
      Internals::SvREADONLY($phase, 1) if defined &Internals::SvREADONLY;
      *{^GLOBAL_PHASE} = \$phase;
    }
  }
}

sub tie_global_phase {
  unless ('Devel::GlobalPhase::_Tie' eq ref tied ${^GLOBAL_PHASE}) {
    tie ${^GLOBAL_PHASE}, 'Devel::GlobalPhase::_Tie';
  }
  1;
}

1;
END_CODE
  }
}

1;

__END__