File Coverage

blib/lib/SQL/Preproc/ExceptContainer.pm

Criterion	Covered	Total	%
statement	28	53	52.8
branch	0	10	0.0
condition	0	3	0.0
subroutine	5	9	55.5
pod	0	4	0.0
total	33	79	41.7

#
#	SQL::Preproc::ExceptContainer - a container for exception
#	objects so scope gets cleaned up properly
#
package SQL::Preproc::ExceptContainer;

use SQL::Preproc::Exception;
use strict;
our $VERSION = '0.10';

sub new_SQLERROR {
#
#	use an array, since we're pretty final
#	and it uses much less memory
#
	my $obj = [];
	bless $obj, shift;
	$obj->[0] = shift;	# sqlpp_ctxt
	$obj->[1] = SQL::Preproc::Exception->new($obj->[0], @_);
	push @{$obj->[0]->{SQLERROR}}, $obj->[1];
	return $obj;
}

sub new_NOTFOUND {
#
#	use an array, since we're pretty final
#	and it uses much less memory
#
	my $obj = [];
	bless $obj, shift;
	$obj->[0] = shift;	# sqlpp_ctxt
	$obj->[1] = SQL::Preproc::Exception->new($obj->[0], @_);
	push @{$obj->[0]->{NOTFOUND}}, $obj->[1];
	return $obj;
}

sub DESTROY {
	my $obj = shift;
#
#	remove the Exception object from us *and*
#	from the sqlpp_ctxt
#
	my $ctxt = $obj->[0];
	my $except = $obj->[1];
	$obj->[0] = undef;
	$obj->[1] = undef;
#
#	in theory we should be at the top of the stack, but
#	to be safe, we'll splice anyway
#	also note that we don't permit the base handler to
#	be destroyed
#
	foreach (1..$#{$ctxt->{SQLERROR}}) {
		splice (@{$ctxt->{SQLERROR}}, $_, 1),
		return 1
			if ($ctxt->{SQLERROR}[$_] eq $except);
	}

	foreach (1..$#{$ctxt->{NOTFOUND}}) {
		splice (@{$ctxt->{NOTFOUND}}, $_, 1),
		return 1
			if ($ctxt->{NOTFOUND}[$_] eq $except);
	}
#
#	the exception will be destroyed now
#
	1;
}
#
#	default handlers
#	SQLERROR: die
#	NOTFOUND: silently ignore
#
sub default_SQLERROR {
	my $obj = [];
	bless $obj, shift;
	$obj->[0] = shift;	# sqlpp_ctxt
	$obj->[1] = SQL::Preproc::Exception->new($obj->[0],
		sub {
			my ($obj, $err, $state, $errstr) = @_;
			$err = '(Unknown error)' unless defined($err);
			$state = '(Unknown state)' unless (defined($state) && ($state ne ''));
			$errstr = '(No error message)' unless defined($errstr);
			my ($pkg, $subr, $line) = caller(1);

			die "Error $err (SQLSTATE $state): $errstr
at $pkg\:\:$subr: $line";
		});
	$obj->[0]{SQLERROR}[0] = $obj->[1];
	return $obj;
}

sub default_NOTFOUND {
	my $obj = [];
	bless $obj, shift;
	$obj->[0] = shift;	# sqlpp_ctxt
	$obj->[1] = SQL::Preproc::Exception->new($obj->[0],
		sub { return 1; });
	$obj->[0]{NOTFOUND}[0] = $obj->[1];
	return $obj;
}

1;