#       .Copyright (C)  1999-2002 TUCOWS.com Inc.
#       .Created:       11/19/1999
#       .Contactid:     <admin@opensrs.org>
#       .Url:           http://www.opensrs.org
#       .Originally Developed by:
#                       Tucows/OpenSRS
#       .Authors:       Leonid Igolnik,
#			Evgeniy Pirogov
#
#
#       This program is free software; you can redistribute it and/or
#       modify it under the terms of the GNU Lesser General Public 
#       License as published by the Free Software Foundation; either 
#       version 2.1 of the License, or (at your option) any later version.
#
#       This program is distributed in the hope that it will be useful, but
#       WITHOUT ANY WARRANTY; without even the implied warranty of
#       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#       Lesser General Public License for more details.
#
#       You should have received a copy of the GNU Lesser General Public
#       License along with this program; if not, write to the Free Software
#       Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

package Core::Exception;
use strict;

#BEGIN {
#   *CORE::GLOBAL::die = sub {
#	if ($Core::Exception::In_Try) {
#	    throw('internal', @_);
#	} else {
#	    CORE::die(@_);
#	}
#    } 
#}

use Exporter;
use vars  qw ( @ISA @EXPORT );
@ISA    = qw ( Exporter );
@EXPORT = qw ( try catch strict_throw throw );

# Set while try block is executed
use vars '$In_Try';

#use Core::Exception;
#
#try { 
#   print "in try\n"; 
#   throw "ErrorState",{q=>1,e=>2,r=>3};
#   throw "ErrorState %s", $file;
#   die "crazi fish\n";
# } catch {
# 	_final        => sub { my $Er = shift; print "finally\n";},
#       ErrorState    => sub { my $Er = shift; print "Catcher\n";},
#	_other        => sub { my $Er = shift; print "otherwise\n";},
#       qr/DBI/is     => sub { my $Er = shift; print "DBI Error",$Er->info,"\n";},
#        }
#;	


sub try (&$) {
    my($try, $catchers) = @_;

    # Set the flag to indicate that we are inside try block
    $In_Try++;

    # Try the code. 
    eval {
	#clean old error message
	local($SIG{'__DIE__'});
	&$try()
    };

    # Reset the flag
    $In_Try--;

    my $_error = $@;

    my $lE;
    if ($_error) { #perl doesn't initialize $! when die in DESTROY
	$lE = ref $_error eq 'Core::Exception::Err' ?
		    $_error : new Core::Exception::Err 0, 'internal', $_error;
	undef $@;
    }

    if (exists $catchers->{'_final'}) {
	my $finally = $catchers->{'_final'};
	&$finally($lE);
    }

    if (defined $lE) {
	my $catcher = $catchers->{$lE->name};
	
	unless ($catcher) {
	    #check regexp catchers at first
	    my @all_catchers = keys %$catchers;
	    my $regexp_catcher;

	    # Check all regexp rules
	    foreach (grep /^\(\?/, @all_catchers){
		next unless $lE->info =~ /$_/;
		$catcher = $catchers->{$_};
		last;
	    }
	}
	
	$catcher ||= $catchers->{'_other'} unless $lE->strict;

	throw($lE) if not defined $catcher;

	&$catcher($lE);
    } #if

}

sub catch ($) { shift; }

sub throw {
    Core::Exception::Err->_throw(0, @_);
}

sub strict_throw {
    Core::Exception::Err->_throw(1, @_);
}

1;
package Core::Exception::Err;
use Data::Dumper;
use vars qw($AUTOLOAD);
use Carp qw(croak);

my %fields = (
	      callstack   => undef,
	      name        => undef,
	      info        => undef
	      );

sub new {
    my $class  = shift;
    $class = ref($class) || $class;
    $fields{strict} = shift;
    my $name = shift;
    $name ||= 'internal';
    $fields{'name'} = $name;

    my $info = shift;
    if (defined $info && not ref $info) {
	if (scalar @_ == 0) {
	    unshift @_, $info;
	    $info = '%s';
	}
	$fields{'info'} = sprintf $info, @_;
	if ($fields{name} eq 'internal') {
	    $fields{name} = 'db' if $fields{info} =~ /DBD|DBI/;
	}
    } else {
	$fields{'info'} = $info;
    }

    {
	my $i = 0;
	my $callstack;
	my ($pkg, $file, $line);
	while (($pkg, $file, $line) = caller($i++)) {
	    next if $pkg =~ /^Core::Exception/;
	    $callstack.="\n[$$ module:$pkg,file:$file,line:$line] ";
	} 
	$fields{'callstack'} = $callstack;
    }

    my $self = {
        %fields,
    };
    bless $self, $class;

    return $self;
} 

sub DESTROY {
# Prevent AUTOLOAD from catching DESTROY
}

sub AUTOLOAD {
    my $self = shift;
    my $type = ref($self) ||
		croak "$self is not an object AUTOLOAD == $AUTOLOAD";

    my $name = $AUTOLOAD;
    $name =~ s/.*://;   # strip fully-qualified portion

    unless (exists $self->{$name} ) {
        croak "There is no such `$name' field in object of class $type";
    } 

    return $self->{$name};
}

sub dump {
    my $self = shift;
    my $dump = "Exception:" . $self->name . ($self->strict ? '(strict)' : '') .
		"\nCallStack " .
		$self->callstack."\n" .
		($self->info ? Dumper($self->info) : "");
}

sub _throw {
    my ($self, $strict, $obj_or_type, @args) = @_;
    my $class;
    my $exception;
    if (ref $obj_or_type eq 'Core::Exception::Err') {
	$exception = $obj_or_type;
    } else {
	$exception = $self->new($strict, $obj_or_type, @args);
    }
    
    if ($Core::Exception::In_Try) {
	CORE::die $exception;
    } else {
	CORE::die $exception->dump;
    }
}

1;
