package Exception;

# DESCRIPTION:
#
# An attempt at writing an exception handling package
# implementing exception handling mechanism similar
# to those present in Java/C++.  This package
# (and the Exception class it implements) may also
# be used to encapsulate any piece of code still relaying
# on try/die as a means to track program failures.
# For example, catch() method is coded to recognize
# and deal with die strings ($@ scalar).  There are
# other approaches at implementing similar exception
# mechanism where $@ would hold an exception object.
# This package, however, avoids storing
# object refs in $@ (e.g. via die $object) in order
# to be reverse compatible with code relaying on
# $@ being a scalar (conventional try/die mechanism).
# Such may be a case if the code implementing/utilizing
# this Exception package is used inside a different
# package/program that has no knowledge of the Exception
# package.
#
# Here're a few examples of how Exception package could
# be used inside your code:
#
# sub foo {
#   for ((my $i=10;$i>-10;$i--) {
#         print "Result: ". (10/$i) ."\n";
#     }
# }
#
# (by the way, i _do_ hate having to see
# that 'sub' word right after try...
# since there's no other way to
# pass a block of code as an argument other than
# via the anonymous sub/closure)
#
# try sub {
#     foo();
# };
#
# # catch _all_ exceptions here
# if (my $exception = catch()) {
#    # will log error and quit.
#    $exception->fatal();
# }
#
# Note: relating to the use of 'try sub { ... };' construct you
# may replace it in favor of 'eval { }' unless you require special
# exception handling (which may only be done witih the try() sub,
# at least in the future implementations ;-)
#
# Therefore an alternative code might look something like this:
# eval {
#     foo();
# };
#
# # catch all exceptions
# if (my $exception = catch()) {
#    # will log error and quit.
#    $exception->fatal();
# }
#
#
# EXAMPLE 1:
#
# All these examples dealt with exceptions caused
# by an 'uncontrolled' (meaning none of the Exeption
# methods was invoked to cause them) die.  However,
# lets also look at how throw() works.
#
#  use Exception;
#
#  sub foo {
#    for ((my $i=10;$i>-10;$i--) {
#        if ($i == 0) {
#           # create and throw a new exception
#           throw new Exception, "Can't devide by 0!";
#        }
#        print "Result: ". (10/$i) ."\n";
#    }
#  }
#
#  eval {
#    foo();
#  };
#
#  # catch any exception (even that
#  # caused by an uncontrolled die)
#  if (catch()) {
#    $_->fatal(); # handle exception
#  }
#
#  print "did ok\n";
#
# EXAMPLE 2:
#
# Here's how throwable() might be used.
# (note, sub foo() is unchanged)
#
# use Myexception;
#
#  eval {
#    # expecting exception 'MyException'
#    # (so, in case of an uncontrolled die()
#    #  a 'MyException' object will be created)
#    # Note that throwable('Exception') is
#    # 'implied' by default even if throwable()
#    # is not invoked here explicitly
#    # since any die should cause an exception.
#    #
#    throwable('MyException');
#    foo();
#  };
#
#  # catch Myexception exception object
#  # note: this object is infact created
#  #       inside the catch() method
#  #       based on value set by throwable().
#  #       This will only happen if there was an
#  #       uncontrolled die!  That is, if
#  #       throwable() was followed by a
#  #       throw() somewhere inside the same
#  #       eval{} block, an exception object
#  #       created by throw() will be generated
#  #       and returned by this catch().
#  if (catch()) {
#    $_->fatal(); # handle exception
#  }
#
# More examples are coming soon...
# (I still keep most of them in my head)
#

use Devel::StackTrace;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(try throw catch throwable);
$::trace_depth = 10;
$::error_text = ""; # $@
# Recent exception (works similar to $@ for die())
# Cleared only after it's caught.
$::recent = undef;
# Name of an exception to expect in case
# of an uncontrolled (without explicit throw()) die.
$::throwable = __PACKAGE__;
@::stack_items = qw(package filename line subroutine hasargs
                    wantarray evaltext is_require hints bitmask);

sub new {
  # new() may be invoked via an existing object
  # like: $exception_object->new()
  # or via package name
  # like: new Exception()
  #   or: Exception::new()
  # Therefore, ref() will return object's
  # class name if first case is true; otherwise,
  # name of this package will be used (from $_[0])
  my $class = ref($_[0]) || $_[0];
  $DB::single = 1;

  my $self = {
              # text of exception (optional)
              info => $_[1],
          # i figure this data is useful to have?
              time => CORE::time(),
              pid  => $$,
              uid  => $<,
              euid => $>,
              gid => $(,
              egid => $),
              stack => new Devel::StackTrace(ignore_package => __PACKA
+GE__),
             };

  bless($self, $class);
}

# standard accessor to property 'info'
sub info {
  return $_[0]->{info} if wantarray;
  $_[0]->{info} = $_[1];
}

#################################
## SUBS THAT MAY BE REDEFINED
#################################
sub trace_as_string {
  $DB::single = 1;
  my $self = shift;
  my $trace_str;
  $trace_str = $self->{stack}->as_string();
  return $trace_str;
}

sub as_string {
  my $self = shift;
  return "\nEXCEPTION!!"
    . "\nINFO:\n  " . $self->{info}
    . "\nTRACE:\n " . $self->trace_as_string()
    . "\n";
}

# fatal(error code)
#
# Cause program to die! Print exception information
# to STDERR and exit with given error code
# or 1 by default.
sub fatal {
  my ($self, $errcode) = ($_[0], $_[1] || 1);
  print STDERR $self->as_string();
  exit($errcode);
}

#################################
## CLASS METHODS
#################################

# catch(list of exception names)
#
sub catch {
  # $@ should always be set (either via
  # die() or throw())
  return undef unless $@;
  $::error_text = $@;
  $@ = "";

  unless ($::recent) {
    # if no 'throw()' was invoked
    # $::recent will not not be set
    # and therefore, we have to check the
    # $@ variable set by an uncontrolled
    # die().  In such case,
    # we'll create a default throwable
    # exception (set with throwable())
    #

    $DB::single = 1;
    $::throwable ||= __PACKAGE__;
    $::recent = eval('new '.caller().'::'. $::throwable .'()');
    if ($@) {
      die "Failed to initialize '$::throwable' exception!\n"
         ."Check that throwable('YourClassName') refers to existing cl
+ass.\n";
    }
    $::recent->info($::error_text);
  }

  # look at list of exceptions that
  # have to be caught and return
  # recent exception if a match is found.
  # Default throwable exception name is used if no other
  # list of exceptions to look for was specified (in the
  # argument list)
  #
  my $recent_type = ref($::recent);
  for (@_ || $::throwable) {
    return get_recent() if $recent_type =~ m/$_/;
  }

  # rethrow uncaught exception
  throw($::recent);
}

sub clear_recent {
  $::recent = undef;
}

sub get_recent {
  my $bug = $::recent;
  $::recent = undef;
  $::throwable = "";
  return $bug;
}

# try a block of code (anonymous sub)
# do nothing more (for now) than a simple
# eval.
sub try {
  # return if not dealing with code!
  return unless (ref $_[0] eq 'CODE');

  # make sure that the sub is executed
  # in its own (native) package!
  my $package = ref $_[0];
  eval "package $package; " . '$_[0]->();';
}

# should receive a reference to an Exception
# object
sub throw {
  $_[0]->info($_[1]) if @_ == 2;

  # save exception, which will be examined
  # later inside catch()
  $::recent ||= $_[0];

  # cause die to interrupt program
  # (normally this will simply cause
  #  eval {} inside try() to return
  #  having $@ set to die string!)
  die $_[0]->info();
}

sub throwable {
    # implements:
    # eval {
    #        throwable 'Exception';
    #        ...
    # }
    # this tells which exception object
    # should be created on an uncontrolled die.
    # Any throw() statements inside
    # the block are still valid and may be
    # used to throw other than the default
    # exception.
    #

    $::throwable = $_[0];
}

1;
[download]