• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Local::ErrorHandler;

# http://www.stonehenge.com/merlyn/PerlJournal/col05.html

use strict;

$|++;

use Carp;
use Data::Dumper;
use POSIX qw(strftime);
use LIMS::Model::Email;
use LIMS::Local::ScriptHelpers;

use Sub::Exporter -setup => { exports => [ qw(set_errorhandler_args) ] };

BEGIN {
    use vars qw($cfg);

    use FindBin qw($Bin); # warn 'BIN:'.$Bin; exit;

    use LIMS::Local::Config;
    $cfg = LIMS::Local::Config->instance;

    use CGI::Application;
=begin
    use Devel::Events::Objects;
    use Devel::Cycle;
    use Devel::Events::Handler::ObjectTracker;
    use Devel::Events::Filter::RemoveFields;
    use Devel::Events::Generator::Objects;

    my $tracker = Devel::Events::Handler::ObjectTracker->new();

    my $gen = Devel::Events::Generator::Objects->new(
        handler => Devel::Events::Filter::RemoveFields->new(
            fields => [qw/generator/], # don't need to have a ref to $gen in each event
            handler => $tracker,
        ),
    );
=cut
    no warnings 'redefine';
    *CGI::Application::__get_body = sub {
        my $self  = shift;
        my $rm    = shift;

        my ($rmeth, $is_autoload) = $self->__get_runmeth($rm);

        my $body;
#        $gen->enable();
        eval {
            $body = $is_autoload ? $self->$rmeth($rm) : $self->$rmeth();
        };
#        $gen->disable();
=begin
        my @leaked_objects = keys %{ $tracker->live_objects };

        print "leaked ", scalar(@leaked_objects), " objects\n";

        foreach my $object ( @leaked_objects ) {
            print "Leaked object: $object\n";

            # the event that generated it
            # print Dumper( $object, $tracker->live_objects->{$object} );
            print '$object: ' . $object . "\n";
            print '$tracker->live_objects->{$object}' .  $tracker->live_objects->{$object}. "\n";
            find_cycle( $object );
        }
=cut
        if ($@) {
            my $error = $@; # warn Dumper [$error, $self->error_mode];
            $self->call_hook('error', $error);
            if (my $em = $self->error_mode) {
                $body = $self->$em( $error );
            }
            else {
                my $error_string = "Error executing run mode '$rm': $error";
                # warn $error_string;
                $body = LIMS::Local::ErrorHandler::fatal_error($error_string);
            }
        }

        # Make sure that $body is not undefined (suppress 'uninitialized value'
        # warnings)
        return defined $body ? $body : '';
    }
}

################################################################################
# need 'to', 'from' & 'smtp' vars supplying via $args to initiate email to admin
################################################################################

use vars qw($args);
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->use_path("$Bin/..");  # for ScriptHelpers to find correct path for templates

sub set_errorhandler_args {
    $args = shift; # warn Dumper $args;
}

sub fatal_error {
    my $message = shift;

#    my ($package, $file, $line) = caller; warn Dumper ($package, $file, $line); # don't need it
    my $incident = unpack "H*", pack "NS", time, $$;

    my $time = strftime "%d-%b-%Y %H:%M:%S", localtime;
    my $user = uc $args->{user};

    my %report = (
		settings => $cfg->{settings},
        incident => $incident,
        message  => $message,
        user     => $user,
    );

    # record reason for death into the error log/console (unless test harness)
    unless ($ENV{HARNESS_ACTIVE}) {
        warn join "", map {
            sprintf "crash %s [%s %s]: %s\n", $incident, $user, $time, $_;
        }
        split /\n+/, $message;
    }

    # maybe alert admin:
    if ( $ENV{ROSEDB_DEVINIT} =~ /prod/ ) {
        my $response = _send_email(\%report);
        $report{mail_response} = $response->string; # if $response->type ne 'success'; # for tt
    }

    # now give the user a place to record their experience
	my $output = $tools->process_template('error/errorhandler.tt', \%report);
	# warn Dumper $output;
    return \$output;
}

sub _send_email {
    my $report = shift;

    my $settings = $cfg->{settings};

    # need 'to' & 'from' attr from settings:
    my $smtp = $settings->{smtp}           || return 0;
    my $from = $settings->{service_email}  || return 0;
    my $to   = $settings->{sysadmin_email} || return 0;

    my $subject = sprintf '%s [%s]', $report->{incident}, $report->{user};
    my $message = $report->{message};

    my %mail = (
        recipient => $to,
        from      => $from,
		config    => $settings,
		message   => $message,
		subject   => $subject,
	); # DEBUG(\%mail);

    my $res = LIMS::Model::Email->send_message(\%mail); # Return::Value object
    return $res;
}

1;