File Coverage

blib/lib/Error/TryCatch.pm

Criterion	Covered	Total	%
statement	40	96	41.6
branch	2	34	5.8
condition	0	3	0.0
subroutine	12	20	60.0
pod	0	1	0.0
total	54	154	35.0

# Error::TryCatch
#
# Copyright (c) 2005-2009 Nilson Santos Figueiredo Jr. .
# All rights reserved.  This program is free software;
# you can redistribute it and/or modify it under the same
# terms as perl itself.
#
# Some portions based on Error.pm from Graham Barr

#####################################################################
# WARNING!                                                          #
# This code is old, don't blame me if it's an unreadable mess.      #
# Some day I might clean it up. Be glad that, apparently, it works. #
#####################################################################

package Error::TryCatch;
use warnings;
use strict;
use vars qw($VERSION @EXPORT $DEFAULT_EXCEPTION $DEBUG);
use base 'Exporter';
use Filter::Simple;
use Parse::RecDescent;
use Carp;

$VERSION = '0.07';
@EXPORT = qw(throw);

$DEFAULT_EXCEPTION = 'Error::Unhandled' unless defined $DEFAULT_EXCEPTION;

my $grammar = q!

program:  statement(s)
statement: starting_bracket | except_handler(s) | non_relevant
starting_bracket: /^[\s]*[{}]/
non_relevant:
                 { bless { __VALUE__ => join "", @{ $item[1] } }, $item[0] }
   | /[^\n]*\n?/
exception_type: /[\w_]+(?:::[\w_]+)*/
except_handler: "try" /[\s]*/  /[\s]*/
			  | "catch" /[\s]*/ exception_type with(?)  /[\s]*/
			  | "otherwise" /[\s]*/  /[\s]*/
			  | "finally" /[\s]*/  /[\s]*/

with: "with"

!;

my $parser = new Parse::RecDescent($grammar);

FILTER {
	return unless defined $_;
	my $tree = $parser->program($_);
	$_ = _traverse($tree);
};

sub _traverse {
	my $tree = shift;
	my $code;
	for my $stm (@{$tree->{'statement(s)'}}) {
		if (defined $stm->{'non_relevant'}) {
			$code .= $stm->{'non_relevant'}->{'__VALUE__'}
				if defined $stm->{'non_relevant'}->{'__VALUE__'};
		}
		elsif (defined $stm->{'starting_bracket'}) {
			$code .= $stm->{'starting_bracket'}->{'__VALUE__'};
		}
		elsif (defined $stm->{'except_handler(s)'}) {
			my %clauses;
			for my $eh (@{$stm->{'except_handler(s)'}}) {
				my $innertree = $parser->program($eh->{'__DIRECTIVE1__'});
				my $innercode = _traverse($innertree);

				# try to keep line count
				$eh->{'__PATTERN1__'} =~ s/[^\n]//g;
				$eh->{'__PATTERN2__'} =~ s/[^\n]//g;
				$innercode = $eh->{'__PATTERN1__'} . $innercode . $eh->{'__PATTERN2__'};

				my $clause = $eh->{'__STRING1__'};
				if ($clause ne 'catch') {
					$clauses{$clause} = $innercode;
				}
				elsif ($clause eq 'catch') {
					push(@{$clauses{'catch'}}, {
						exception => $eh->{'exception_type'}->{'__VALUE__'},
						code	  => $innercode
					});
				}
				else { die 'unexpected parse error(1)' }
			}
			if (defined $clauses{try}) {
				my $innercode = "eval $clauses{try};";
				if (defined($clauses{catch}) || defined $clauses{otherwise}) {
					$innercode .= 'if ($@) {$@ = new '.$DEFAULT_EXCEPTION.'($@) unless ref($@);';
					my $catch = defined $clauses{catch};
					if ($catch) {
						my $els = '';
						for my $clause (@{$clauses{catch}}) {
							$innercode .= "${els}if (\$\@->isa('$clause->{exception}')) $clause->{code}";
							$els = 'els' if ($els eq '');
						}
					}
					if (defined $clauses{otherwise}) {
						$innercode .= 'else' if $catch;
						$innercode .= $clauses{otherwise};
					}
                    elsif ($catch) {
                        $innercode .= 'else{Carp::croak($@)}';
                    }
					$innercode .= '}';
				}
				if (defined $clauses{finally}) {
					$innercode = "eval{$innercode};$clauses{finally};if(\$\@){die \$\@}";
				}
				$code .= $innercode;
			}
			else { die "syntax error: no try clause found\n"	}
		}
		else { die "unexpected parse error(2)\n" }
	}
	return $code;
}

sub throw { croak @_ }

1;

package Error::Generic;
use base 'Class::Accessor';
use Carp;

# overloadable
__PACKAGE__->mk_accessors(qw[package file line text value]);
sub stringify { $_[0]->text }

use overload (
	'""'	   =>	'stringify',
	'0+'	   =>	'value',
	'bool'     =>	sub { return 1 },
	'fallback' =>	1
);

sub get { $_[0]->{"-$_[1]"} }
sub set { $_[0]->{"-$_[1]"} = $_[2] }

sub new {
	my $class  = shift;
	my ($pkg, $file, $line) = caller(1);
	my %e = (
		'-package'	=> $pkg,
		'-file'		=> $file,
		'-line'		=> $line,
		'-value'	=> 0,
		@_
	);
	if ($Error::TryCatch::DEBUG) {
		warn "thrown $class\n";
		for (keys %e) { warn "\t$_ => ". (defined($e{$_}) ? $e{$_} : "(undef)") ."\n" }
	}
    bless { %e }, $class;
}

1;

package Error::Unhandled;
use base 'Error::Generic';

sub new {
	my $class = shift;
	my $text = shift;
	chomp $text;

	my @args;
	@args = ( -file => $1, -line => $2)
	  if($text =~ s/ at (\S+) line (\d+)([.\n]+)?$//s);

	__PACKAGE__->SUPER::new(-text => $text, -value => $text, @args);
}

sub stringify { $_[0]->text . " at " . $_[0]->file . " line " . $_[0]->line . ".\n" }

1;
__END__