#-----------------------------------------------------------
# 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 deni
+ed to foreign package ${str_package}!" ) unless $str_package->isa( __
+PACKAGE__ );

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

        # Allow Main
        #$err->new( 'CallerException' )->raise( "Unmediated access den
+ied 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__
[download]