error.pm

platform file from motorola kernel code

package Error;

#
# Copyright 1999 by Daryn M. Sharp, All rights reserved.
#
# This program is free software, you can redistribute it and/or
# modify it under the same terms as Perl itself.
#

use strict;
use integer;
use overload '""' => \&stringify;

my $Pkg = __PACKAGE__;
my $DieCrap = qr{(?: |\n\t)(?:(\S+)\(.*\) called )?at (\S+) line (\S+)\.?\n.*\Z}so;

our $Verbose;
our $Compat;
our $Debug;

*CORE::GLOBAL::die = \¨

sub new {
	my $this = shift;
	my $class = ref($this) || $this;

	my $self = {
		data    => [@_],
		stack   => [],
		verbose => $Verbose,
	};
	$self->{id} = "$self";

	bless($self,$class);
	$self->{verbose} ||= (substr($self->text,-1) ne "\n");
	$self;
}

sub create {
	my $self = shift;
	my $e = @_ ? shift : ($@ || undef);
	(!defined($e) || (ref($e) && $e->isa($Pkg))) ? $e : $self->new($e);
}

sub _annotate {
	my $self = shift;
	unshift(@_,' ') if $self->{verbose};

	push(@{$self->{data}},
		map { (ref($_) && $_->isa($Pkg))
			? $_->stringify($self->{verbose})
			: $_
		} @_
	);
	$self;
}

sub catch { goto(&Exception::_add_catch) }

sub die {
	my $self = @_
		? UNIVERSAL::isa($_[0],$Pkg) && shift
		: $Pkg->create;

	if (ref($self)) {
		$self->throw(@_);
	} else {
		my ($n,$pkg);
		
		# try to deal with Carp messages
		while ($pkg = caller($n++)) {
			($pkg eq 'Carp') ? next: last;
		}

		$pkg .= '::'.$Pkg unless ($pkg->isa($Pkg) || $pkg =~ /::$Pkg$/o);
		# FIXME: nice idea, but need to prevent looping
		#if ($pkg->isa($Pkg)) {
		#	unshift(@_,$pkg);
		#	goto(&{$pkg->can('die')});
		#}
		eval qq{package $pkg; use base '$Pkg'} unless $pkg->isa($Pkg);

		my $str = join('',@_);
		$str = 'Died' if ($str eq '');
		if ($str =~ s/$DieCrap//o) {
			$pkg->new($str)->_throw([undef,$2,$3,$1]);
		} else {
			$pkg->new($str)->_throw;
		}
	}
}

# needs more work
sub croak {
	my $self = shift;
	my ($skip,$pkg);

	($skip,$pkg) = @{pop()} if (ref($_[-1]) eq 'ARRAY');
	unless (defined($pkg)) {
		$pkg = ref($self) || $self;
		$pkg =~ s/::$Pkg$//o;
		$pkg = caller if ($pkg eq $Pkg);
	}

	my $frame = _findframe($pkg,$skip);

	if (ref($self)) {
		$self->_throw($frame,@_);
	} else {
		(my $str = shift) =~ s/$DieCrap//o;
		$self->new($str)->_throw($frame);
	}
}

sub throw {
	splice(@_,1,0 => undef);
	goto(&{$_[0]->can('_throw')});
}

sub _throw {
	my ($self,$frame,$note) = @_;

	my %frame = (
		why  => $^S ? (@{$self->{stack}} ? 'propogated' : 'raised') : 'died',
		note => (ref($note) && $note->isa($Pkg)) ? $note->_shortstring : $note,
	);

	$frame = _findframe($Pkg,0) unless defined($frame);

	@frame{qw(pack file line sub)} = @$frame;
	push(@{$self->{stack}},\%frame);

	$self->_die;
}

sub _die { CORE::die(@_) }

sub data { shift->{data} }

sub text { join('',@{shift->{data}}) }

sub type { ref($_[0]) }

sub _findframe {
	my ($pkg,$skip) = @_;
	my $frame;

	my $n = 1;
	while (my $pack = caller(++$n)) {
		print "[$n] {$pkg/$skip} call stack: @{[caller($n)]}\n" if $Debug;
		next if (
			$pack->isa($pkg) ||
			$pack->isa('Exception') ||
			(caller($n))[3] eq 'Exception::try' ||
			$skip-- > 0
		);

		$frame = [caller($n)];
		last;
	}

	$frame || [caller($n-1)];
}

sub _shortstring {
	my ($self) = shift;
	my $pfx = '['.$self->type.'] ';

	my $str = $self->text;
	chomp($str);
	$str =~ s/^/$pfx/mg;
	$str;
}

sub stringify {
	my $self = shift;
	if ($Compat) {
		$self->stringify_compat(@_);
	} else {
		$self->stringify_better(@_);
	}
}

sub	stringify_better {
	my ($self,$verbose) = @_;

	my $text = $self->_shortstring . "\n";
	if ($self->{verbose} || $verbose) {
		foreach my $frame (@{$self->{stack}}) {
			$text .= "\t...".$frame->{why};
			$text .= ' due to '.$frame->{note} if defined($frame->{note});
			$text .= " at $frame->{file} line $frame->{line}.\n";
		}
	}

	$text;
}

sub stringify_compat {
	my $self = shift;

	my $text = $self->text;
	if (substr($text,-1) ne "\n") {
		my $frame = $self->{stack}[-1];
		$text .= ' due to '.$frame->{note} if defined($frame->{note});
		$text .= " at $frame->{file} line $frame->{line}.\n";
	}

	$text;
}

sub stacktrace { shift->stringify(1) }

package Fatal::Error;
use base 'Error';

sub new {
	my $self = shift->SUPER::new(@_);
	$self->{fatal} = 1;
	$self;
}

sub die { shift->new(@_)->throw }

1;