File Coverage

blib/lib/Exception/Class/TCF.pm

Criterion	Covered	Total	%
statement	121	162	74.6
branch	48	76	63.1
condition	6	12	50.0
subroutine	22	34	64.7
pod	19	26	73.0
total	216	310	69.6

package Exception::Class::TCF;
use Exception::Class (
    'Exception::Class::TCF' => {
        'isa'    => 'Exception::Class::Base',
        'fields' => ['Message']
    }
);
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
require Exporter;
@ISA       = qw(Exporter Exception::Class::Base);
@EXPORT    = qw(&try &catch &throw &finally);
@EXPORT_OK = qw(&isThrowing &deactivate &handleWarn &handleDie &make);
$VERSION   = '0.03';

my $DEFAULT_UNCAUGHT = "Exception of type %s thrown but not caught";
my %PROTECTED = map { $_ => 1 } qw(Message);

sub UNIVERSAL::throw (@) {
    my ( $pack, $file, $line ) = caller;
    warn "Parsing problem with throw at $file line $line.\n";
    &Exception::Class::TCF::throw(@_)
}

sub UNIVERSAL::make (@) {
    my($pack,$file,$line) = caller;
    warn "Parsing problem with throw at $file line $line.\n";
    &Exception::Class::TCF::make(@_)
}

sub UNIVERSAL::catch (@) {
    &Exception::Class::TCF::catch(@_)
}

sub isException {
    my $class = shift;
    $class = ref $class if ref $class;
    &isBelow($class,'Exception::Class::TCF');
}

sub isBelow {
    my($class,$above) = @_;
    $class->isa($above) || $class->isa('Exception::Class::TCF::'.$above);
}

sub new {
    my($class) = shift;
    unshift @_,'Message' if @_ % 2;
    my %args = @_;
    my $self = $class->SUPER::new( 'Message' => $args{'Message'} );
    bless $self, $class;
    for my $key ( keys %args ) {
        if ( $key ne 'Message' ) {
            $self->setFields( $key, $args{$key} );
        }
    }
    return $self;
}

sub make {
    my $class = shift;
    unless ($class =~ m/^Exception::Class::TCF::/o) {
        my $fclass = 'Exception::Class::TCF::' . $class;
        $class = $fclass if isException($fclass);
    }
    return $class->new(@_);
}

sub type {
    my $type = ref($_[0]) || $_[0];
    $type =~ s/^Exception::Class::TCF:://o;
    return $type;
}

sub setFields {
    my($self) = shift;
    if (ref $self) {
        my ( $key, $val );
        while ( ( $key, $val ) = splice @_, 2, 0 ) {
            next if $self->isProtected($val);
            $self->{$key} = $val;
        }
    }
    return $self;
}

sub hasField {
    ref($_[0]) && exists $_[0]->{$_[1]};
}

sub protectedFields { keys %PROTECTED }
sub isProtected { exists $PROTECTED{$_[1]} }

sub removeFields {
    my($self) = shift;
    if (ref $self) {
        my($name);
        foreach ($name) {
            next if $PROTECTED{$name};
            delete $self->{$name};
        }
    }
    return $self;
}

sub getField {
    ref($_[0]) && $_[0]->{$_[1]};
}

sub setMessage {
    my ( $self, $msg ) = @_;
    if (ref $self) {
        $self->{'Message'} = $msg;
    }
    return $self;
}

sub message {
    ref($_[0]) && exists $_[0]->{'Message'} && $_[0]->{'Message'};
}

my $dTHROWING;
my ( @ARGS, $EXCEPTION, $CATCHING, $THROWING, @STACK );
my ( $HANDLE_DIE, $HANDLE_WARN );

###  These variables are used for the following purposes:
###  $EXCEPTION
###    contains the current active exception and
###  @ARGS
###    the remaining arguments to the throw that threw it.
###  $CATCHING
###    tells if we're in a handler (but haven't entered any
###    try blocks in the handler).
###  $THROWING
###    tells if we have an active exception.
###  $dTHROWING
###    is used for shortlived communication between throw and try,
###    it is often the same as $THROWING but not always.
###  @STACK
###    is used for the stack needed to implement the scoping rules
###    for the active exception.
###  $HANDLE_DIE
###    set if an ordinary die should be considered as throwing
###    a Die exception
###  $HANDLE_WARN
###    set if a warn should be considered as throwing
###    a Warning exception

sub handleDie {
    $HANDLE_DIE = defined $_[0];
}

sub handleWarn {
    my $oldhw = $HANDLE_WARN;
    $HANDLE_WARN = $_[0];
}

sub deactivate {
    if ($THROWING) {
        undef $EXCEPTION;
        undef @ARGS;
        $THROWING = $CATCHING = 0;
    }
}

sub dieMess {
    my($self) = @_;
    my($type) = $self->type;
    my $UNCAUGHT = $DEFAULT_UNCAUGHT;
    if ($self->hasField('DyingMessage')) {
        $UNCAUGHT = $self->getField('DyingMessage');
    }
    my $mess = sprintf $UNCAUGHT, $type;
    if ( $mess =~ m/\n$/o ) {
        return $mess;
    }
    else {
        my ( $pack, $file, $line ) = caller 2;
        ( $pack, $file, $line ) = caller 3 if ($pack eq 'Exception::Class::TCF');
        return "$mess at $file line $line\n";
    }
}

sub die {
    CORE::die $_[0]->dieMess;
}

sub isThrowing {
    $THROWING || $CATCHING;
}

sub throw (@) {
    my ( $self, @args ) = @_;
    # throw;
    unless (@_) {
        unless ( $CATCHING || $THROWING ) {
            $THROWING = 0;
            my ( $pack, $file, $line ) = caller;
            CORE::die "Rethrow without an active exception at $file line $line\n";
        }
        $EXCEPTION->throw(@ARGS);      ## To get correct inheritance
    }
    $self = make($self) unless ref $self;
    ### Check here that it is an exception? or in make?
    # Is in a try block
    if ( @STACK ) {
        $EXCEPTION = $self;
        @ARGS = @args;
        local $SIG{'__DIE__'} = 'IGNORE';
        $THROWING = 1;
        $dTHROWING = 1;
        CORE::die; ## Maybe $self->die(@args) so Warning does not throw?
    }
    # Thrown to the wolves
    else {
        $self->die(@args);
    }
}

## We 'my' some functions to make them unchangeable from the outside

my $findException = sub {
    my($class,$excs) = @_;
    if ($class eq 'Exception::Class::TCF') {
        return grep($_ eq 'Default', @$excs) ? 'Default' : "";
    }
    my $fclass =  $class;
    $class =~ s/^Exception::Class::TCF:://o;
    return $class if $class eq 'Die' && !$HANDLE_DIE;
    foreach (@$excs) {
        return $_ if &isBelow($fclass,$_);
    }
    "";
};

my $popFrame = sub {
    ($EXCEPTION,$CATCHING,$THROWING,@ARGS) = @{pop @STACK};
};

my $pushFrame = sub {
    push @STACK,[$EXCEPTION,$CATCHING,$THROWING,@ARGS];
    $CATCHING =  $THROWING = 0;
    undef @ARGS;
    undef $EXCEPTION;
};

package Exception::Class::TCF::Warning;

package Exception::Class::TCF;

sub try (&@) {
    my($block,@catches) = @_;
    my($exc,@args,$res);
    &$pushFrame;
    $HANDLE_WARN &&
      local ( $SIG{'__WARN__'} =  sub { throw Exception::Class::TCF::Warning @_;  } );
    $dTHROWING = 0;
    $res = eval { &$block() };
    $exc = $EXCEPTION;
    @args = @ARGS;
    if ($@) {
          my($action,$type,%excs,@excs,$finalAction);
          while (($type,$action) = splice @catches,0,2) {
              unless (ref $action eq 'CODE') {
                  my($pack,$file,$line) = caller;
                  warn "Handler for exception key $type is not a function ",
                       "reference at $file line $line\n";
                  next;
              }

              $type =~ s/^Exception::Class::TCF:://o;
              $type = 'Exception::Class::TCF' if $type eq 'Default';
              if ($type eq 'Finally') {
                  $finalAction = $action if ref $action eq 'CODE';
                  next;
              }
              $excs{$type} = $action;
              push @excs,$type;
          }
          my $catchDie = exists $excs{'Die'};
           # A 'die', not a 'throw'
          unless ($dTHROWING) {
              if ($catchDie || $HANDLE_DIE) {
                  $exc = new Exception::Class::TCF::Die;
                  @args = ($@);
              }
              else {
                  &$popFrame();
                  CORE::die $@;
              }
          }
          $dTHROWING = 0;
          my $class = ref($exc) ? ref($exc) : $exc;
          my $raisedType = &$findException($class,\@excs);
          unless (exists $excs{$raisedType}) {
              &$popFrame;
              &$finalAction() if defined $finalAction;
              return $exc->throw(@args);
          }
          $CATCHING = 1;
          $res =  eval { &{$excs{$raisedType}}($exc,@args) };
          $CATCHING = 0;
          $exc = $EXCEPTION;
          @args = @ARGS;
          &$popFrame();
          &$finalAction() if defined $finalAction;
          return $exc->throw(@args) if $dTHROWING;
          CORE::die $@ if $@;
          return $res;
    }
    &$popFrame();
    my(%catches) = @catches;
    &{$catches{'Finally'}}() if ref $catches{'Finally'} eq 'CODE';
    $res;
}

sub catch (@) {
    return @_;
}

sub finally (&) {
    return ('Finally',$_[0]);
}

package Exception::Class::TCF::Die;
use vars '@ISA';
@ISA = qw(Exception::Class::TCF::Error);

package Exception::Class::TCF::Error;
use vars '@ISA';
@ISA = qw(Exception::Class::TCF);

sub die {
    die $_[0]->dieMess;
}

package Exception::Class::TCF::Warning;
use vars '@ISA';
@ISA = qw(Exception::Class::TCF);

sub die {
    warn $_[0]->dieMess;
}

1;

__DATA__