view release on metacpan or  search on metacpan

lib/App/Framework/Base/Object/ErrorHandle.pm  view on Meta::CPAN

package App::Framework::Base::Object::ErrorHandle ;

=head1 NAME

App::Framework::Base::Object::ErrorHandle - Adds error handling to basic object

=head1 SYNOPSIS

use App::Framework::Base::Object::ErrorHandle ;


=head1 DESCRIPTION

Any object derived from this class can throw an error and some registered error handler will catch (and handle) that error.

Hierarchy of catch handlers is:

	catch_fn set for this object instance
	any registered global catch function (last registered first)
	default handler
	
Global catch functions, when registered, are added to a stack so that the last one registered is called first.

Each handler must return either 1=handled, or 0=not handled to tell this object whether to move on to the next handler.

NOTE: The default handler may be over-ridden by any derived object. 

This object is set up such that when used as stand-alone objects (i.e. outside of an application framework), then errors are handled
with die(), warn() etc.


=head1 DIAGNOSTICS

Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.

=head1 AUTHOR

Steve Price C<< <sdprice at cpan.org> >>

=head1 BUGS

None that I know of!

=head1 INTERFACE

=over 4

=cut

use strict ;
use Carp ;

our $VERSION = "1.004" ;

#============================================================================================
# USES
#============================================================================================
use App::Framework::Base::Object ;

#============================================================================================
# OBJECT HIERARCHY
#============================================================================================
our @ISA = qw(App::Framework::Base::Object) ; 

#============================================================================================
# GLOBALS
#============================================================================================

my %FIELDS = (
	'errors'	=> [],		# List of errors for this object
	'catch_fn'	=> undef,	# Function called if error is thrown
) ;

# Keep track of all errors
my @all_errors = () ;

# Error type priority
my %ERR_TYPES = (
	'fatal'		=> 0x80,
	'nonfatal'	=> 0x40,
	'warning'	=> 0x08,
	'note'		=> 0x04,
	'none'		=> 0x00,
	
) ;

# Error handler stack
my @GLOBAL_ERROR_HANDLERS = () ;

# Some useful masks
my $ERR_TYPE_MASK = 0xF0 ;
my $ERR_TYPE_WARN = 0x08 ;
my $ERR_TYPE_NOTE = 0x04 ;


#============================================================================================
# CONSTRUCTOR 
#============================================================================================

=item B<new([%args])>

Create a new App::Framework::Base::Object::ErrorHandle.

The %args are specified as they would be in the B<set> method, for example:

	'mmap_handler' => $mmap_handler

The full list of possible arguments are :

	'fields'	=> Either ARRAY list of valid field names, or HASH of field names with default values 

=cut

sub new
{
	my ($obj, %args) = @_ ;

	my $class = ref($obj) || $obj ;

	# Create object
	my $this = $class->SUPER::new(%args) ;
	
	
	return($this) ;
}



#============================================================================================
# CLASS METHODS 
#============================================================================================

lib/App/Framework/Base/Object/ErrorHandle.pm  view on Meta::CPAN

=item B<register_global_handler($code_ref)>

Add a new global error handler on to the stack

=cut

sub register_global_handler
{
	my $class = shift ;
	my ($code_ref) = @_ ;
	
	push @GLOBAL_ERROR_HANDLERS, $code_ref ;
}

#-----------------------------------------------------------------------------

=item B<default_error_handler($error)>

Last ditch attempt to handle errors. Uses die(), warn() etc as appropriate.

=cut

sub default_error_handler
{
	my $this = shift ;
	my ($error) = @_ ;

	my $handled = 0 ;

	# If it's an error, stop
	if ($this->is_error($error))
	{
		my ($msg, $exitcode) = $this->error_split($error) ;
		die "Error: $msg\n" ;
		$handled = 1 ;
	}
	if ($this->is_warning($error))
	{
		my ($msg, $exitcode) = $this->error_split($error) ;
		warn "Warning: $msg\n" ;
		$handled = 1 ;
	}
	if ($this->is_note($error))
	{
		my ($msg, $exitcode) = $this->error_split($error) ;
		print "Note: $msg\n" ;
		$handled = 1 ;
	}

	return $handled ;
}


#============================================================================================
# OBJECT METHODS 
#============================================================================================


#-----------------------------------------------------------------------------

=item B<_throw_error($error)>

Add a new error to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub _throw_error
{
	my $this = shift ;
	my ($error) = @_ ;
	
	# Add to this object's list
	push @{$this->errors()}, $error ;

	# Add to global list
	$this->_global_error($error) ;
	
	## Handle the error 
	my $handled = 0 ;

	# See if we have a registered catch function
	my $catch_fn = $this->catch_fn() ;
	if ($catch_fn)
	{
		$handled = &$catch_fn($error) ;
	}
	
	# if not handled, try global
	if (!$handled)
	{
		for (my $i = scalar(@GLOBAL_ERROR_HANDLERS)-1; ($i>=0) && !$handled; --$i)
		{
			$catch_fn = $GLOBAL_ERROR_HANDLERS[$i] ;
			$handled = &$catch_fn($error) ;
		}
	}

	# when all else fails, do it yourself
	if (!$handled)
	{
		$handled = $this->default_error_handler($error) ;
	}
	
	# If all REALLY fails, die!	
	if (!$handled)
	{
		my ($msg, $exitcode) = $this->error_split($error) ;
		die "Unhandled Error: $msg ($exitcode)\n" ;
	}

}

#-----------------------------------------------------------------------------

=item B<rethrow_error($error_ref)>

Throws an error for this object based on an error object associated with a different object
 
=cut

sub rethrow_error
{
	my $this = shift ;
	my ($error) = @_ ;
	
	# Create copy of error
	my %err_copy = () ;
	foreach (keys %$error)
	{
		$err_copy{$_} = $error->{$_} ;
	}
	$err_copy{'parent'} = $this ;
	
	$this->_throw_error(\%err_copy) ;
	
}


#-----------------------------------------------------------------------------

=item B<throw_error([%args])>

Add a new error to this object instance, also adds the error to this Class list
keeping track of all runtime errors

%args hash contains:

	* type = fatal, nonfatal, warning, note
	* message = text message
	* errorcode = integer error code value

=cut

sub throw_error
{
	my $this = shift ;
	my (%args) = @_ ;
	
	# Convert args into an error
	my $error = _create_error('parent'=>$this, %args) ;

	$this->_throw_error($error) ;
	
}

#-----------------------------------------------------------------------------

=item B<throw_fatal($message, [$errorcode])>

Add a new error (type=fatal) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_fatal
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'fatal', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}


#-----------------------------------------------------------------------------

=item B<throw_nonfatal($message, [$errorcode])>

Add a new error (type=nonfatal) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_nonfatal
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'nonfatal', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}

#-----------------------------------------------------------------------------

=item B<throw_warning($message, [$errorcode])>

Add a new error (type=warning) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_warning
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'warning', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}

#-----------------------------------------------------------------------------

=item B<throw_note($message, [$errorcode])>

Add a new error (type=note) to this object instance, also adds the error to this Class list
keeping track of all runtime errors

=cut

sub throw_note
{
	my $this = shift ;
	my ($message, $errorcode) = @_ ;
	
	# Convert args into an error
	$this->throw_error('type'=>'note', 'message'=>$message, 'errorcode'=>$errorcode) ;
	
}



#-----------------------------------------------------------------------------

=item B<last_error()>

Returns a hash containing the information from the last (worst case) error stored for this object
i.e. if a 'fatal' error is followed by some 'note's then the 'fatal' error is returned

Hash contains:

	* type = fatal, error, warning, note
	* message = text message
	* errorcode = integer error code value

If there are no errors, returns undef

=cut

sub last_error
{
	my $this = shift ;
	my (%args) = @_ ;

	my $errors_aref = $this->errors() ;

	my $error = _latest_worst_error($errors_aref) ;
	
	return $error ;
}


#-----------------------------------------------------------------------------

=item B<error()>

Returns a hash containing the information from the last actual error (i.e. only 'fatal' or 'nonfatal' types) stored for this object

Hash contains:

	* type = fatal, error, warning, note
	* message = text message
	* errorcode = integer error code value

If there are no errors, returns undef

=cut

sub error
{
	my $this = shift ;
	my (%args) = @_ ;

	my $error = $this->last_error() ;
	
	# Ensure this is something worth reporting
	if ($error)