package LIMS::Local::ErrorHandler;
# http://www.stonehenge.com/merlyn/PerlJournal/col05.html
use strict;
$|++;
use Carp;
use CGI qw(:standard);
use POSIX qw(strftime);
use LIMS::Model::Email;
use Data::Dumper;
use Sub::Exporter -setup => { exports => [ qw(set_errorhandler_args) ] };
BEGIN {
use vars qw($cfg);
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 = $@;
$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;
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);
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 = (
incident => $incident,
message => $message,
user => $user,
);
# record reason for death into the error log
warn join "", map {
sprintf "crash %s [%s %s]: %s\n", $incident, $user, $time, $_;
}
split /\n+/, $message;
# alert admin (unless test harness):
send_email(\%report) unless $ENV{ROSEDB_DEVINIT} =~ /test/;
# now give the user a place to record their experience
print output(\%report);
return;
}
sub send_email {
my $report = shift;
my $settings = $cfg->{settings};
# need 'to' & 'from' attr from settings:
my $from = $settings->{email_from} || return 0;
my $smtp = $settings->{smtp} || return 0;
my $to = $settings->{admin_contact} || 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 $rtn = LIMS::Local::Mail::dispatch(\%mail); # doesn't supply _app_cfg
my $rtn = LIMS::Model::Email->send_message(\%mail);
# do something with $rtn error if exists ?
}
sub output {
my $report = shift;
my $css = q!
body {
background: #c0c0c0;
}
a { text-decoration: underline }
a:hover { text-decoration: none }
a:visited { color: #00f }
h2 { color: #f00; }
th { vertical-align: top; text-align: right; }
td { color: #00f; }
.content {
background: #fff;
margin: 10px;
border: 1px solid #000;
padding: 0px 20px;
}
.message {
color: #00f;
padding: 10px;
background-color: #ffffe0;
border-top: solid 2px #c0c0c0;
border-bottom: solid 2px #c0c0c0;
font-style: italic;
}
.error {
font-weight: bold;
margin: 15px;
}
.itemhidden { display: none; }
.itemshown { display: inline; }
!;
my $link = 'tell us what you were doing at the time';
my $contact_telno = $cfg->{settings}->{service_telno};
my $js = qq!
function make_blank() {
document.form1.comments.innerHTML = "";
}
function toggleview (id1,id2) {
var obj1 = document.getElementById(id1);
var obj2 = document.getElementById(id2);
(obj1.className=="itemshown") ? obj1.className="itemhidden" : obj1.className="itemshown";
(obj1.className=="itemshown") ? obj2.innerHTML="$link" : obj2.innerHTML="$link";
}!;
my @html = (
start_html(-title=>'500 Internal Server Error', -style=>{-code => $css}, -script => $js),
div({-class=>'content'},
h2('500 Internal Server Error'),
p({-class=>'error'}, 'An error has occurred - incident number ' . $report->{incident}),
p({-class=>'message'}, $report->{message} ),
p( 'Relevant details have already been logged, but if you want to ',
a({-href=>"javascript:toggleview('form','toggleform')", id=>'toggleform'}, $link),
'it might help us determine the cause more accurately and fix the problem more easily.'),
div({class=>'itemhidden', id=>'form'},
hr,
start_form(-method => 'post', -action => '/script/cgi/crash_reporter.cgi',
-name => 'form1'),
hidden('incident', $report->{incident}),
hidden('message', $report->{message}),
table(
Tr(
th( 'Name:' ),
td( textfield( -name => 'name', size => 40 ), '[optional]'),
),
Tr(
th( 'Contact telephone number:' ),
td( textfield( -name => 'tel', size => 40 ), '[optional]'),
),
Tr(
th( 'Email address:' ),
td( textfield( -name => 'email', size => 40 ), '[optional]' ),
),
Tr(
th( 'Summary:' ),
td(
textarea( -name => 'comments', rows => 10, cols => 60,
default=>'Describe your circumstances here. What were you trying to do?',
onClick=>'make_blank();',
)
),
),
),
p({align=>'center'}, submit(-value=>'Submit') ),
end_form(),
hr,
),
p( "Or, you can contact us at $contact_telno with reference incident number "
. $report->{incident} ),
),
end_html,
);
unshift @html, header() if grep $ENV{$_}, qw(MOD_PERL FAST_CGI);
return join "\n", @html;
}
1;
