#-----------------------------------------------------------
# File: tB.pl
# Purpose:
#	To provide a test interface into TestB.pm
#	See TestB.pm for details.
# Created By:
#	Philip A. Reyniers
#	Hewlett-Packard
#-----------------------------------------------------------

use TestB;
use strict;

my $str_file = './object.dat';
#-----------------------------------------------------------
# Create new Object
#-----------------------------------------------------------
print STDOUT "\nTest Create New Object\n";
my $o = TestB->new();
print STDOUT "\nTest Print Object\n";
$o->print_object();
my $return = $o->store_object( \$str_file );
if ( defined $return ) {
	# This should not generate an Exception.
	print STDOUT "\t" . $$return . "\n";
}

print STDOUT "\nTest PRIVATE Check: This should raise an exception!\n";
my $return = $o->_caller_check();
if ( defined $return ) {
	# Exception Generated
	print STDOUT "\t" . $$return . "\n";
}

#-----------------------------------------------------------
# Destroy Object
#-----------------------------------------------------------
print STDOUT "\nTest DESTROY Object\n";
undef $o;

#-----------------------------------------------------------
# Load Object
#-----------------------------------------------------------
print STDOUT "\nTest Loading Object File from $str_file\n";
my $o = TestB->load_object( \$str_file );

print STDOUT "\nTest Print Loaded Object\n";
$o->print_object();
undef $o;

exit;


#-----------------------------------------------------------
# File: TestB.pl
# Purpose:
#	To demonstrate class creation, object persistence 
#	using storable, raising exceptions using Exception.pm,
#	and restricting access to private classes.
# Created By:
#	Philip A. Reyniers
#	Hewlett-Packard
#-----------------------------------------------------------

package TestB;
use strict;
use Storable;
use Exception qw( :all );
Exception->debugLevel( DEBUG_STACK );
my $err=new Exception 'TestB';

sub _caller_check {
	my ( $self ) = shift;
	my ( $str_package ) = caller( 0 );
	print STDOUT "\tCALLER: $str_package\n";
	try {
		# Allow only inherited classes
		$err->new( 'CallerException' )->raise( "Unmediated access denied to foreign package ${str_package}!" ) unless $str_package->isa( __PACKAGE__ );

		# Allow only from same class.
		#$err->new( 'CallerException' )->raise( "Unmediated access denied to foreign package ${str_package}!" ) unless $str_package eq ( __PACKAGE__ );

		# Allow Main
		#$err->new( 'CallerException' )->raise( "Unmediated access denied to foreign package ${str_package}!" ) if ( $str_package ne 'main' );

		print STDOUT "\tCaller $str_package Authorized\n";
		return undef;
	} when 'CallerException', except {
		return \( $_[0]->id . ': ' . $_[0]->text );
	} except {
		$_[0]->confess;
	}
}

sub store_object {
	my ( $self ) = shift;

	# Caller Check
	my $return = $self->_caller_check();
	if ( $return ) {
		print STDERR $$return . "\n";
		return $return;
	}
	Storable::store ( \%{ $self }, './object.dat' );
	return undef;
}

sub load_object {
	my ( $self, $sref_file ) = @_;
	return Storable::retrieve( $$sref_file )
}

sub print_object {
	my ( $self ) = shift;
	foreach ( keys %{ $self } ) {
		print STDOUT $_ . "\t" . $self->{ $_ } . "\n";
	}
}

sub new {
	my ( $class ) = @_;
	my $self =	{
				_testA => 1,
				_testB => 0
			};
	bless $self, $class;
	return $self;
}

sub DESTROY {
	my ( $self ) = @_;
	print STDOUT "\nDestroying Object...\n";
}

1;

__END__