File Coverage

lib/UR/Exit.pm

Criterion	Covered	Total	%
statement	20	50	40.0
branch	6	30	20.0
condition	0	9	0.0
subroutine	6	8	75.0
pod	4	5	80.0
total	36	102	35.2

package UR::Exit;

=pod

=head1 NAME

UR::Exit - methods to allow clean application exits.

=head1 SYNOPSIS

  UR::Exit->exit_handler(\&mysub);

  UR::Exit->clean_exit($value);

=head1 DESCRIPTION

This module provides the ability to perform certain operations before
an application exits.

=cut

# set up module
require 5.006_000;
use warnings;
use strict;
require UR;
our $VERSION = "0.46"; # UR $VERSION;;
our (@ISA, @EXPORT, @EXPORT_OK);

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw();

use Carp;


=pod

=head1 METHODS

These methods provide exit functionality.

=over 4

=item exit_handler

  UR::Exit->exit_handler(\&mysub);

Specifies that a given subroutine be run when the application exits.
(Unimplimented!)

=cut

sub exit_handler
{
    die "Unimplimented";
}

=pod

=item clean_exit

  UR::Exit->clean_exit($value);

Exit the application, running all registered subroutines.
(Unimplimented!  Just exits the application directly.)

=cut

sub clean_exit
{
    my $class = shift;
    my ($value) = @_;
    $value = 0 unless defined($value);
    exit($value);
}

=pod

=item death

Catch any die or warn calls.  This is a universal place to catch die
and warn if debugging.

=cut

sub death
{
    unless ($ENV{'UR_STACK_DUMP_ON_DIE'}) {
        return;
    }

    # workaround common error
    if ($_[0] =~ /Can.*t upgrade that kind of scalar during global destruction/)
    {
        exit 1;
    }

    if (defined $^S) {
        # $^S is defined when perl is executing (as opposed to interpreting)
        if ($^S) {
            # $^S is true when its executing in an eval, false outside of one
            return;
        }
    } else {
        # interpreter is parsing a module or string eval
        # check the call stack depth for up-stream evals
        # fall back to perls default handler if there is one
        my $call_stack_depth = 0;
        for (1) {
            my @details = caller($call_stack_depth);
            #print Data::Dumper::Dumper(\@details);
            last if scalar(@details) == 0;

            if ($details[1] =~ /\(eval .*\)/) {
                #print "";
                return;
            }
            elsif ($details[3] eq "(eval)") {
                #print "";
                return;
            }
            $call_stack_depth++;
            redo;
        }
    }

    if
    (
        $_[0] =~ /\n$/
        and UNIVERSAL::can("UR::Context::Process","is_initialized")
        and defined(UR::Context::Process->is_initialized)
        and (UR::Context::Process->is_initialized == 1)
    )
    {
        # Do normal death if there is a newline at the end, and all other
        # things are sane.
        return;
    }
    else
    {
        # Dump the call stack in other cases.
        # This is a developer error occurring while things are
        # initializing.
        local $Carp::CarpLevel = 1;
        Carp::confess(@_);
    	return;
    }
}

=pod

=item warning

Give more informative warnings.

=cut

sub warning
{

    unless ($ENV{'UR_STACK_DUMP_ON_WARN'}) {
        warn @_;
        return;
    }

    return if $_[0] =~ /Attempt to free unreferenced scalar/;
    return if $_[0] =~ /Use of uninitialized value in exit at/;
    return if $_[0] =~ /Use of uninitialized value in subroutine entry at/;
    return if $_[0] =~ /One or more DATA sections were not processed by Inline/;
    UR::ModuleBase->warning_message(@_);
    if ($_[0] =~ /Deep recursion on subroutine/)
    {
        print STDERR "Forced exit by UR::Exit on deep recursion.\n";
        print STDERR Carp::longmess("Stack tail:");
        exit 1;
    }
    return;
}

#$SIG{__DIE__} = \&death unless ($SIG{__DIE__});
#$SIG{__WARN__} = \&warning unless ($SIG{__WARN__});

sub enable_hooks_for_warn_and_die {
    $SIG{__DIE__} = \&death;
    $SIG{__WARN__} = \&warning;
}

&enable_hooks_for_warn_and_die();


1;
__END__