Bivio::Die
# Copyright (c) 1999-2009 bivio Software, Inc. All rights reserved.
# $Id$
package Bivio::Die;
use strict;
use base 'Bivio::Collection::Attributes';
use Bivio::DieCode;
use Bivio::IO::Alert;
use Bivio::IO::Config;
use Bivio::IO::Trace;
use Carp ();
# C<Bivio::Die> manages per-instance/class handlers for C<die>. When C<die> is
# called, C<Bivio::Die> searches up the stack for calls to public
# methods of instances and classes which can C<handle_die>. The
# C<handle_die> methods are called in LIFO order, i.e. the most recently
# called to current.
#
# C<handle_die> methods may change the die code, but they should not
# call L<die|"die"> or C<CORE::die>. This will result in an error state.
#
# Classes do not register with this module. Instead, the method
# L<catch|"catch"> which sets C<$SIG{__DIE__}> locally is used.
#
# This module is policy neutral with respect to error handling. It
# holds errors and it is the responsibility of the L<catch|"catch"> caller
# and C<handle_die> implementers to do something about the errors.
our($_TRACE);
our($_CURRENT_SELF);
our($_IN_CATCH);
our($_IN_HANDLE_DIE);
our($_CATCH_QUIETLY);
my($_STACK_TRACE) = 0;
my($_STACK_TRACE_ERROR) = 0;
my($_STACK_TRACE_SEPARATOR) = "\t" . join('', '-' x 64, "\n");
my($_A) = 'Bivio::IO::Alert';
Bivio::IO::Config->register({
'stack_trace' => $_STACK_TRACE,
'stack_trace_error' => $_STACK_TRACE_ERROR,
'stack_trace_separator' => $_STACK_TRACE_SEPARATOR,
});
sub as_string {
# (self) : string
# Returns Die object and all its subsequent errors as a string.
my($self) = @_;
my($res) = '';
for (my($curr) = $self; $curr; $curr = $curr->unsafe_get('next')) {
if ($curr->is_destroyed) {
$res .= "$curr->is_destroyed returned true unexpectedly";
next;
}
$res .= "$curr->as_string: $@\n"
unless eval {
$res .= $_A->format(
$curr->unsafe_get(qw(package file line)),
undef,
[$curr->unsafe_get('code'), ': ', _as_string_args($curr)],
);
chomp($res);
1;
};
}
return $res;
}
sub catch {
# (self, any) : Bivio.Die
# (self, any, ref) : any
# Installs a local C<$SIG{__DIE__}> handler, calls I<code>.
# If I<code> succeeds without error, C<undef> is returned.
# Otherwise, a C<Bivio::Die> object is returned. These may
# be chained, i.e. if there is a C<die> within a C<die>,
# the first instance will be linked to the second and can
# be retrieved with L<get_next|"get_next">.
#
# The stack is unwound until this method (catch) is found and then we unwind
# one more to allow the caller of catch to have a C<handle_die> routine.
#
# If a call to C<handle_die> results in a C<die>, a new die
# object will be created and chained on to the current die.
#
# You may not call catch from within a die handler, because
# C<$SIG{__DIE__}> is specifically disabled.
#
# If I<code> is a string or string_ref, will be evaled in the caller's package.
#
# If I<die> is a ref (scalar or ref), the return value of this method
# will be the return value (with appropriate wantarray context) of I<code>.
# I<die> will be C<undef> if I<code> succeeded.
# If I<code> threw a Die, I<die> will contain that value
# and the return value will be C<undef> or an empty list.
#
# $_ is localized in this call. Do not assume it will be modified by I<code>.
my($proto, $code, $die) = @_;
local($_CURRENT_SELF);
local($_IN_CATCH) = 1;
local($SIG{__DIE__}) = sub {
my($msg) = $_A->format_args($_[0]);
_handle_die(
_new_from_core_die(
$proto,
Bivio::DieCode->DIE,
_add_program_error({
message => $msg eq "\n" ? $_A->get_last_warning
: $_A->fixup_perl_error($msg, 1),
}),
(caller)[0,1,2],
Carp::longmess("die"),
),
);
return;
};
# Call in appropriate context and return appropriate result
unless (ref($die) =~ /^SCALAR$|^REF$/) {
# Normal case: no $die arg
_eval($code);
return _catch_done($proto);
}
if (wantarray) {
# Return array with $die
my(@res) = _eval($code);
$$die = _catch_done($proto);
return $$die ? () : @res;
}
# Return scalar with $die
my $res = _eval($code);
$$die = _catch_done($proto);
return $$die ? undef : $res;
}
sub catch_and_rethrow {
my($proto, $op, $before_rethrow) = @_;
my($self);
my(@res) = $proto->catch($op, \$self);
$before_rethrow->($self);
$self->throw
if $self;
return $proto->return_scalar_or_array(@res);
}
sub catch_quietly {
local($_CATCH_QUIETLY) = 1;
return shift->catch(@_);
}
sub catch_quietly_unless_test {
my($method) = Bivio::IO::Config->is_test ? 'catch' : 'catch_quietly';
return shift->$method(@_);
}
sub destroy {
# (self) : undef
# Destroys self and removes from the current chain. The initial error is not
# actually destroyed, but is set in L<is_destroyed|"is_destroyed"> state. This
# allows L<catch|"catch"> to know there is an error while also knowing all errors
# were handled. I<code> is set to C<undef> which is the flag that this
# instance was destroyed.
#
# If self is not part of the current catch, then it is simply set to destroyed
# and its next link is left untouched.
my($self) = @_;
$self->put('code' => undef);
# No current chain
return unless $_CURRENT_SELF;
# Head of chain
if ($_CURRENT_SELF eq $self) {
my($next) = $_CURRENT_SELF->unsafe_get('next');
$_CURRENT_SELF->put('next', undef);
$_CURRENT_SELF = $next;
return;
}
# Somewhere in the chain?
my($curr, $next) = $_CURRENT_SELF;
while ($next = $curr->unsafe_get('next')) {
next unless $next eq $self;
$curr->put('next', $next->unsafe_get('next'));
$self->put('next' => undef);
last;
}
# Not part of "current" chain. Don't update next link.
return;
}
sub die {
my($proto) = shift;
my($cc) = $_A->is_calling_context($_[0])
? shift : $_A->calling_context;
$proto->throw(
$cc,
Bivio::DieCode->DIE,
_add_program_error({message => $_A->format_args(@_)}),
Carp::longmess('Bivio::Die::die'),
);
# DOES NOT RETURN
}
sub eval {
# (proto, code_ref) : any
# (proto, string) : any
# (proto, string_ref) : any
# Calls eval on I<code>, but turns off any handle_die processing. This should be
# used everywhere in place of a normal eval. Returns the result of I<sub>.
#
# If I<code> is a string or string_ref, will be evaled in the caller's package.
#
# NOTE: Warnings are not suppressed during code execution.
#
# $_ is localized in this call. Do not assume it will be modified by I<code>.
#
# Returns C<undef> in the event of an error, just like C<CORE::eval>.
my(undef, $code) = @_;
local($_CATCH_QUIETLY) = 1;
local($SIG{__DIE__});
local($_CURRENT_SELF) = $_CURRENT_SELF;
return _eval($code);
}
sub eval_or_die {
# (proto, any) : any
# Calls L<catch|"catch"> preserving calling context (using wantarray). If the
# operation fails, rethrows the die. Otherwise, returns the result as in
# L<catch|"catch"> with preseved call context.
#
# $_ is localized in this call. Do not assume it will be modified by I<code>.
my($proto, $code) = @_;
my($die);
if (wantarray) {
my(@res) = $proto->catch($code, \$die);
return @res unless $die;
}
else {
my $res = $proto->catch($code, \$die);
return $res unless $die;
}
$die->throw;
# DOES NOT RETURN
}
sub handle_config {
# (proto, string, hash) : undef
# stack_trace : boolean [false]
#
# If true, will print a stack trace on L<throw|"throw">.
#
# stack_trace_error : boolean [false]
#
# If true, will print a stack trace on a L<throw|"throw"> which contains a
# I<program_error> attribute which evaluates to I<true>. I<program_error> is
# set automatically for C<CORE::die> calls and other internal errors in
# handling L<throw|"throw"> calls, e.g. die within die.
my(undef, $cfg) = @_;
$_STACK_TRACE = $cfg->{stack_trace} ? 1 : 0;
$_STACK_TRACE_ERROR = $cfg->{stack_trace_error} ? 1 : 0;
$_STACK_TRACE_ERROR = 0 if $_STACK_TRACE;
$_STACK_TRACE_SEPARATOR = $cfg->{stack_trace_separator};
return;
}
sub is_destroyed {
# (self) : boolean
# Returns true if the instance was destroyed.
return !shift->unsafe_get('code');
}
sub set_code {
# (self, Bivio.DieCode, string, any, ...) : undef
# Change the I<code> associated with I<self> and set new attributes.
my($self, $code, @new_attrs) = @_;
my($attrs) = $self->unsafe_get('attrs');
$self->put(code => _check_code($code, $attrs));
%$attrs = (%$attrs, @new_attrs) if @new_attrs;
return;
}
sub throw {
# Any of the parameters may be undef. Package and line will be filled in by this
# module. If you'd like to implement a module specific die, you might:
#
# sub throw_die {
# my($self, $code, $msg) = @_;
# Bivio::Die->throw(Bivio::DieCode->unsafe_from_any($code),
# {msg => $msg, object => $self}, caller);
# }
#
# C<caller> will be called in an array context and return the appropriate
# attributes about the caller in the right order. Note that
# L<Bivio::Type::Enum::unsafe_from_any|Bivio::Type::Enum/"unsafe_from_any">
# returns C<undef> if $code isn't found, so it is entirely safe.
#
# If I<code> is C<undef>, it will be set to C<Bivio::DieCode::UNKNOWN>.
# If I<code> is a string, it will be converted to a L<Bivio::DieCode>
# if possible.
#
# If I<attrs> is C<undef>, it will be set to the empty hash.
# If I<attrs> is a not a reference, it will be set to C<{message => $attrs}>.
# If I<attrs> is not a hash, it will be set to C<{attrs => $attrs}>.
#
# In the second form, I<self> is "rethrown".
my($proto) = shift;
local($_CURRENT_SELF)
unless $_IN_CATCH;
if (ref($proto)) {
# Rethrow of an existing die. If inside a catch, set as current
# and pass by name.
$_CURRENT_SELF = $proto;
CORE::die("$proto\n")
if $_IN_CATCH;
# Not in a catch, so must call handle_die explicitly
_handle_die($proto);
# _handle_die returns, but user called die. So need to
# throw a bogus exception.
CORE::die(
$proto->unsafe_get('throw_quietly')
? "\n" : $proto->as_string."\n",
);
}
my($cc) = shift
if $_A->is_calling_context($_[0]);
my($code, $attrs) = (shift, shift);
my($package, $file, $line) = $cc ? $cc->get_top_package_file_line_sub
: (shift, shift, shift);
my($self) = _new_from_throw(
$proto,
$code,
$attrs,
$package, $file, $line,
shift || Carp::longmess('Bivio::Die::throw'),
);
CORE::die($_IN_CATCH ? "$self\n" : $self->as_string."\n");
# DOES NOT RETURN
}
sub throw_die {
# (proto, Bivio.DieCode, hash_ref, string, string, int) : undef
# Calls L<throw|"throw">. This allows clean implementations of
# C<throw_die> in other modules. You can pass C<Bivio::Die> as a
# C<$die> object (see e.g. L<Bivio::SQL::Connection|Bivio::SQL::Connection>).
my($proto, $code, $attrs, $package, $file, $line) = @_;
shift->throw($code, $attrs, $package, $file, $line,
Carp::longmess('Bivio::Die::throw_die'));
# DOES NOT RETURN
}
sub throw_or_die {
# (proto, any, hash_ref, string, string, int) : undef
# (proto, string, ...) : undef
# Calls L<throw|"throw"> if I<code> is a Bivio::DieCode name or reference.
# Otherwise, calls L<die|"die">.
my($proto) = shift;
my($cc) = $_A->is_calling_context($_[0]) ? shift : $_A->calling_context;
my($code) = @_;
my($m) = UNIVERSAL::isa($code, 'Bivio::DieCode')
|| Bivio::DieCode->is_valid_name($code)
&& Bivio::DieCode->unsafe_from_name($code)
? 'throw' : 'die';
$proto->$m($cc, @_);
# DOES NOT RETURN
}
sub throw_quietly {
# (proto, Bivio.DieCode, hash_ref, string, string, int) : undef
# (self) : undef
# Same as L<throw|"throw">, but no stack trace or error message is output.
my($proto, $code, $attrs, $package, $file, $line) = @_;
if (ref($proto)) {
$proto->put(throw_quietly => 1);
$proto->throw($proto, $code, $attrs, $package, $file, $line,
Carp::longmess('Bivio::Die::throw_quietly'));
# DOES NOT RETURN
}
my($self) = _new_from_throw($proto, $code, $attrs, $package, $file, $line,
Carp::longmess('Bivio::Die::throw_quietly'));
# Be quiet
CORE::die($_IN_CATCH ? "$self\n" : "\n");
# DOES NOT RETURN
}
sub _add_program_error {
my($attrs) = @_;
$attrs ||= {};
$attrs->{program_error} = 1
unless exists($attrs->{program_error});
return $attrs;
}
sub _as_string_args {
my($self) = @_;
my($attrs) = {%{$self->unsafe_get('attrs') || {}}};
delete($attrs->{program_error});
my($m) = delete($attrs->{message});
my($msg) = [
$m ? ($m, ' ') : (),
map(($_, '=>', $attrs->{$_}, ' '), sort(keys(%$attrs))),
];
pop(@$msg);
return @$msg;
}
sub _caller {
my($i) = 0;
# Avoid insanity
0 while caller(++$i) eq __PACKAGE__ && $i < 1_000_000;
return [caller($i)];
}
sub _catch_done {
# () : Bivio.Die
# Returns $_CURRENT_SELF if got an error ($@) or undef. Handles
# case where _eval() fails because of a syntax error.
# Cleans up catch state.
my($proto) = @_;
return $_CURRENT_SELF
|| ($@ ? _new_from_eval_syntax_error($proto) : undef);
}
sub _check_code {
# (any, hash_ref) : Bivio.DieCode
# Validates code and sets attributes to error state if invalid.
my($code, $attrs) = @_;
unless (defined($code)) {
$attrs = _add_program_error($attrs);
return Bivio::DieCode->UNKNOWN;
}
return $code
if UNIVERSAL::isa($code, 'Bivio::DieCode');
my($c) = Bivio::DieCode->unsafe_from_any($code);
return $c
if $c;
%$attrs = (code => $code, attrs => {%$attrs});
$attrs = _add_program_error($attrs);
return Bivio::DieCode->INVALID_DIE_CODE;
}
sub _eval {
# (any) : any
# Evaluates code (maintaining return context)
my($code) = @_;
local($_);
# Don't put in newline, because would change line numbering
my($caller) = _caller()->[0];
unless (ref($code) eq 'CODE') {
my($c) = ref($code) ? $$code : $code;
return
unless $code = eval(qq{package $caller; sub {$c}});
}
return eval(qq{package $caller; \$code->();});
}
sub _handle_die {
# (self) : undef
# Called from within $SIG{__DIE__} inside catch. $_CURRENT_SELF is
# already created. Calls the die handlers sequentially. If errors
# occur, chains them on to $_CURRENT_SELF by calling _new_from_core_die.
local($_IN_HANDLE_DIE) = 1;
eval {
local($SIG{__DIE__});
my($self) = @_;
_print_stack($self)
if _want_stack_trace($self);
my($i) = 0;
my(@a);
my($prev_proto) = '';
my($stop) = -1;
my(%already_seen);
# Iterate until just one routine after catch
while ($stop <= 0 && do { { package DB; @a = caller($i++) } } ) {
# Only start incrementing stop when "catch" is seen
$stop++ if $stop >= 0;
my($sub, $has_args) = @a[3,4];
# Only call if argument is to a public method in a module
next unless defined($sub) && $sub =~ /::[a-z]\w+$/ && $has_args;
if ($sub eq __PACKAGE__.'::catch') {
# This gives us one more loop iteration
$stop++;
next;
}
# Does this sub's argument (self or proto) implement handle_die?
my($proto) = $DB::args[0];
next unless $proto && UNIVERSAL::can($proto, 'handle_die');
# Don't call twice if in same "entry" into self or proto.
# OK to call multiple times on instances of same class.
next if $already_seen{$proto}++;
# Continue if successful eval
next if eval {
_trace("calling ", ref($proto) || $proto, "->handle_die")
if $_TRACE;
$proto->handle_die($self);
1;
};
# Unsuccessful eval, chain the error.
my($msg) = $_A->fixup_perl_error($@);
# If not rethrow of an existing error?
if ($msg eq "$self\n") {
# In this case, we don't want as_string
_trace("$self: self rethrown") if $_TRACE;
}
elsif ($msg eq "$_CURRENT_SELF\n") {
# In this case, we don't want as_string
_trace("$_CURRENT_SELF: older die rethrown") if $_TRACE;
$self = $_CURRENT_SELF;
}
else {
eval {
_trace($proto, "->handle_die: ", $msg) if $_TRACE;
};
$msg =~ / at (\S+|\(eval \d+\)) line (\d+)\.\n$/;
_new_from_core_die(
$self,
Bivio::DieCode->DIE_WITHIN_HANDLE_DIE,
_add_program_error({
message => $msg,
proto => $proto,
file => $1,
line => $2,
}),
ref($proto) || $proto, $1, $2,
Carp::longmess('Bivio::Die::_handle_die'),
);
}
}
_print_stack_other($self, 'stack_other')
if _want_stack_trace($self);
1;
} || warn($@);
return;
}
sub _new {
# (proto, Bivio.DieCode, hash_ref, string, string, string, string) : Bivio.Die
# Creates a new Bivio::Die from the specified parameters which all must
# be "valid". Sets $_CURRENT_SELF if $_CURRENT_SELF is undef.
my($proto, $code, $attrs, $package, $file, $line, $stack) = @_;
my($self) = $proto->new({
next => undef,
code => $code,
attrs => $attrs,
package => $package,
file => $file,
line => $line,
});
# FRAGILE
$self->put(throw_quietly => 1) if (caller(2))[3] =~ /throw_quietly/;
if ($_CURRENT_SELF) {
my($curr, $next) = $_CURRENT_SELF;
$curr = $next while $next = $curr->unsafe_get('next');
$curr->put('next' => $self);
}
else {
$_CURRENT_SELF = $self;
}
_trace($self) if $_TRACE;
# After trace, since we print stack separately
$self->put(stack => $stack || '');
_print_stack($self) if $_TRACE || $_STACK_TRACE;
return $self;
}
sub _new_from_core_die {
# (proto, hash_ref, string, string, string, string) : Bivio.Die
# Called with the result of a CORE::die. If $attrs->{message} is equal to the
# string form of any of the current die values, then return that value.
# Otherwise, create new Bivio::Die from the listed values.
my($proto, $code, $attrs, $package, $file, $line, $stack) = @_;
if ($_CURRENT_SELF) {
my($msg) = $attrs->{message};
for (my($curr) = $_CURRENT_SELF; $curr; $curr = $curr->unsafe_get('next')) {
next unless $msg eq "$curr\n";
return $curr;
}
}
return _new($proto, $code, $attrs, $package, $file, $line, $stack);
}
sub _new_from_eval_syntax_error {
# (proto) : Bivio.Die
# When eval gets a syntax error, we don't get a call to "die". Don't
# ask me why she swallowed the fly....
#
# We create a new Die and trace stack if necessary.
my($proto) = @_;
my($msg) = $_A->fixup_perl_error($@);
my($self) = _new_from_throw(
$proto,
Bivio::DieCode->DIE,
_add_program_error({message => $msg}),
undef,
undef,
undef,
Carp::longmess($msg),
);
_print_stack($self)
if _want_stack_trace($self);
return $self;
}
sub _new_from_throw {
# (proto, any, hash_ref, string, string, string, string) : Bivio.Die
# Sets attrs, file, line, etc.
my($proto, $code, $attrs, $package, $file, $line, $stack) = @_;
$attrs = defined($attrs) ? !ref($attrs) ? {message => $attrs}
: {attrs => $attrs} : {}
unless ref($attrs) eq 'HASH';
$attrs->{message} ||= '';
my($caller) = _caller();
return _new(
$proto,
_check_code($code, $attrs),
$attrs,
$package || $caller->[0],
$file || $caller->[1],
$line || $caller->[2],
$stack,
);
}
sub _print_stack {
my($self, $which) = @_;
$which ||= 'stack';
my($key) = $which . '_printed';
my($sp, $tq) = $self->unsafe_get($key, 'throw_quietly');
return
if $sp;
return
unless $_TRACE
|| $_STACK_TRACE
|| !$tq
&& !$_CATCH_QUIETLY
&& $_STACK_TRACE_ERROR
&& _add_program_error($self->unsafe_get('attrs'))->{program_error};
if ($which eq 'stack') {
$_A->print_literally(
$self->as_string, "\n",
$self->unsafe_get('stack'),
$_STACK_TRACE_SEPARATOR,
);
}
else {
_print_stack_other($self);
}
$self->put($key => 1);
return;
}
sub _print_stack_other {
my($self) = @_;
return
unless Bivio::UNIVERSAL->is_super_of('Bivio::IO::Ref')
and my $attrs = $self->unsafe_get('attrs');
return $_A->print_literally(
map(
{
my($stack) = $attrs->{$_};
(
$_, ":\n",
map(
"\t" . ($self->b_can('as_string_for_stack_trace', $_) ? $_->as_string_for_stack_trace : $_->as_string) . "\n",
@$stack,
),
$_STACK_TRACE_SEPARATOR,
);
}
grep($_ =~ /_stack$/ && ref($attrs->{$_}) eq 'ARRAY', sort(keys(%$attrs))),
),
);
}
sub _want_stack_trace {
my($self) = @_;
return $_TRACE
|| $_STACK_TRACE
|| $_STACK_TRACE_ERROR
&& ($self->unsafe_get('attrs') || {program_error => 1})
->{program_error};
}
1;