File Coverage

blib/lib/Devel/StrictObjectHash.pm

Criterion	Covered	Total	%
statement	86	115	74.7
branch	44	88	50.0
condition	4	11	36.3
subroutine	14	23	60.8
pod	4	5	80.0
total	152	242	62.8

package Devel::StrictObjectHash;

use strict;
use warnings;

our $VERSION = '0.01';

## ----------------------------------------------------------------------------
## Debugging functions
## ----------------------------------------------------------------------------

# make a sub
sub DEBUG { 0 }

{
    # this should not be accessable
    # to anyone but the debug function
    my $debug_line_number = 1;
    # debuggin'
    sub debug {
        # otherwise debug
        my $formatted_debug_line_number = sprintf("%03d", $debug_line_number);
        print STDERR "debug=($formatted_debug_line_number) ", @_, "\n";
        $debug_line_number++;
    }
}

## ----------------------------------------------------------------------------
## package variables
## ----------------------------------------------------------------------------

my $KEY_CREATION_ACCESS_REGEX  = qr/^new$/;
my $PRIVATE_FIELD_ACCESS_REGEX = qr/^new$/;

my $PUBLIC_FIELD_IDENTIFIER    = undef;
my $PROTECTED_FIELD_IDENTIFIER = qr/^[a-zA-Z][a-zA-Z0-9_]+/;
my $PRIVATE_FIELD_IDENTIFIER   = qr/^_/;

my $INC_FILTER_REG_EX = undef;
my $INC_filter = sub {
        my ($code, $file_name) = @_;
        # we dont handle anything other than
        # .pm files for now
        return undef unless $file_name =~ /\.pm$/;
        # get the package name
        my $package_name = $file_name;
        $package_name =~ s/\.pm$//;
        $package_name =~ s/\//\:\:/g;
        # now create the package now, but
        # also create a bless routine in it
        if ($package_name =~ /$INC_FILTER_REG_EX/ || $file_name =~ /$INC_FILTER_REG_EX/) {
            debug("+ creating bless routine in ${file_name}") if DEBUG;
            no strict 'refs';
            *{"${package_name}::bless"} = \&Devel::StrictObjectHash::strict_bless;
        }
        # tell the world
        debug("^ loading $file_name package through INC filter") if DEBUG;
        # and let it be loaded normally
        return undef;
    };

my $ERROR_TYPE = 'die';
my %ERROR_HANDLERS = (
    "warn" => sub { warn "* ", __PACKAGE__, " [", (scalar localtime), "] ", @_ },
    "die"  => sub { die  @_ }
);

sub handleError {
    $ERROR_HANDLERS{$ERROR_TYPE}->(@_)
}

## ----------------------------------------------------------------------------
## import interface
## ----------------------------------------------------------------------------

sub import {
    shift;
    ((scalar(@_) % 2) == 0) || die "uneven parameter assignment for Devel::StrictObjectHash";
    my %params = @_;
    # change bless as nessecary
    if (exists $params{"strict_bless"}) {
        my $how_to_bless = $params{"strict_bless"};
        if (ref($how_to_bless) eq "ARRAY") {
            my @packages = @{$how_to_bless};
            no strict 'refs';
            *{"${_}::bless"} = \&Devel::StrictObjectHash::strict_bless foreach @packages;
        }
        elsif (ref($how_to_bless) eq "Regexp") {
            $INC_FILTER_REG_EX = $how_to_bless;
            unshift @INC => $INC_filter;
        }
        elsif ($how_to_bless eq "global") {
            *CORE::GLOBAL::bless = \&Devel::StrictObjectHash::strict_bless;
        }
        else {
            die "unrecognized parameter ($how_to_bless) for 'strict_bless'";
        }
    }
    # turn on debugging
    if (exists $params{"debug"}) {
        no warnings 'redefine';
        *Devel::StrictObjectHash::DEBUG = sub { 1 } if $params{"debug"};
    }
    # change $KEY_CREATION_ACCESS_REGEX
    if (exists $params{"allow_autovivification_in"}) {
        # if is this param is a reg-ex, we need to add 'new' to it
        # so we can handle strings and qr// stuff the same way
        $KEY_CREATION_ACCESS_REGEX = qr/$params{"allow_autovivification_in"}|new/;
    }
    # change $PUBLIC, $PROTECTED, $PRIVATE
    if (exists $params{"field_access_identifiers"}) {
        my %field_identifiers = %{$params{"field_access_identifiers"}};
        $PUBLIC_FIELD_IDENTIFIER    = $field_identifiers{"public"} if exists $field_identifiers{"public"};
        $PROTECTED_FIELD_IDENTIFIER = $field_identifiers{"protected"} if exists $field_identifiers{"protected"};
        $PRIVATE_FIELD_IDENTIFIER   = $field_identifiers{"private"} if exists $field_identifiers{"private"};
    }
    # change $ERROR_TYPE
    if (exists $params{"error_handling"}) {
        (exists $ERROR_HANDLERS{$params{"error_handling"}})
            || die "error handling style (" . $params{"error_handling"}. ") not available";
        $ERROR_TYPE = $params{"error_handling"};
    }
}

## ----------------------------------------------------------------------------
## bless function
## ----------------------------------------------------------------------------

# you can use this to replace bless
# it is best done by importing this
# method into the module you wish to
# use Devel::StrictObjectHash in.
# NOTE:
# this explicity disallows it to tie
# itself so it will not create any
# deep-recusion.
sub strict_bless {
	my ($hash, $class) = @_;
	debug("* tying hash ($hash) with Devel::StictObjectHash for $class") if DEBUG;
	# do not allow it to tie itself
	tie(%{$_[0]}, "Devel::StrictObjectHash", $class, %{$hash}) unless ($class eq "Devel::StrictObjectHash");
	# since this may be used to override the
	# actual bless function, then we should
	# be explict here and use CORE::bless
	return CORE::bless($_[0], $class);
}

## ----------------------------------------------------------------------------
## class methods
## ----------------------------------------------------------------------------

use Data::Dumper ();

sub Dump {
    my ($object) = @_;
    my $tied_hash = tied(%{$object}) || die "not a Devel::StrictObjectHash object";
    if ($tied_hash->isa("Devel::StrictObjectHash")) {
        return "dumping: $tied_hash\n" . Data::Dumper::Dumper($tied_hash);
    }
}


## ----------------------------------------------------------------------------
## tie functions
## ----------------------------------------------------------------------------

sub TIEHASH {
	my ($class, $blessed_class, %_hash) = @_;
    debug("class=($class) blessed_class($blessed_class) hash-keys=(" . (join ", " => keys %_hash) . ")") if DEBUG;
	# we need to get the name of the class that
	# actually called us (it should be at least
	# one away since you should be using strict_bless)
	# this will tell is what class is doing the
	# actual initialization
	my ($actual_calling_class) = caller(1);
	my $hash = {
		# store the class this has is going to
		# be blessed into
		blessed_class => $blessed_class,
		# store the initial hash fields
		fields => \%_hash,
		# this stores a reference to what class
		# the fields were actually initialized int
		# this is important for private fields
		# and being able to check if they are being
		# stepped upon or not
		fields_init_in => { map { $_ => $actual_calling_class } keys %_hash }
		};
	bless($hash, $class);
	return $hash;
}

## HASH tie routines

sub STORE {
	my ($self, $key, $value) = @_;
    debug("^ calling STORE on key=($key) for object=($self) ") if DEBUG;
	# first we need to check to see if
	# the user has the right to access
	# this field
	$self->_check_access($key);
	# and log this activity
	debug("> storing value=(" .
            # this avoids unnessecary warnings
            ((defined($value)) ? $value : "undef") .
            ") at key=($key) in subroutine=(" .
            # this is the name of the subroutine
            # that called this function
            (caller(1))[3] . ")") if DEBUG;
    $self->{fields}->{$key} = $value;
}

sub FETCH {
	my ($self, $key) = @_;
    debug("^ calling FETCH on key=($key) for object=($self) ") if DEBUG;
	# first we need to check to see if
	# the user has the right to access
	# this field
	$self->_check_access($key);
	# and log the activity
	debug("< fetching value=(" .
            # this avoids unnessecary warnings
            # NOTE:
            # we say defined here, not exists because
            # we know the field exists, otherwise the
            # _check_access method would have failed
            # we just need to see if the value is not
            # undef, to avoid the warnings.
            ((defined($self->{fields}->{$key})) ?
                $self->{fields}->{$key}
                :
                "undef") .
            ") at key=($key) in subroutine=(" .
            # this is the name of the subroutine
            # that called this function
            (caller(1))[3] . ")") if DEBUG;
	return $self->{fields}->{$key};
}

# NOTE:
# the following 2 methods are rarely used, but
# in the interest in providing a complete interface
# to the object, we will implement.

# checking existence is rare, since an
# object should know its fields (its protected
# ones anyway). Good encapsulation dictates that
# the private fields should be hidden though, so
# we use _check_access.
# NOTE:
# it might make sense to catch the exception
# thrown by _check_access here and return something
# but then again, I would not want to give the
# false impression that the field is NOT there.
sub EXISTS {
	my ($self, $key) = @_;
    debug("^ calling EXISTS on key=($key) for object=($self) ") if DEBUG;
	# first we need to check to see if
	# the user has the right to access
	# this field
	$self->_check_access($key);
	return exists $self->{fields}->{$key};
}

# deletion too is something done rarely, usually
# only in the destructor method (DESTROY), so
# we will enforce access control here as usual
sub DELETE {
	my ($self, $key) = @_;
    debug("^ calling DELETE on key=($key) for object=($self) ") if DEBUG;
	# first we need to check to see if
	# the user has the right to access
	# this field
	$self->_check_access($key);
	delete $self->{fields}->{$key};
}


# NOTE:
# the following 2 methods (FIRSTKEY and NEXTKEY) are
# for supporting the keys, values and each functions
# on hashes. These are not common things done with
# the hashes used to form the basis of objects.

sub FIRSTKEY {
    my ($calling_package) = caller(0);
    handleError "Illegal Operation : calling FIRSTKEY not supported from $calling_package";
}

sub NEXTKEY {
    my ($calling_package) = caller(0);
    handleError "Illegal Operation : calling NEXTKEY not supported from $calling_package";
}

# NOTE:
# the following 2 methods are not allowed at all.
# a user should never clear all the fields of an
# object, that just doesnt make sense. And untie-ing
# of this object would violate the intent of this
# module (to provide a drop in bless replacement
# for debugging object field access issues)

sub CLEAR {
	handleError "Illegal Operation : Clearing of this hash is strictly forbidden";
}

sub UNTIE {
	handleError "Illegal Operation : Un-tie-ing of this hash is strictly forbidden";
}

## Private subroutine

# to check the access of our hash
sub _check_access {
	my ($self, $key) = @_;
    debug("  ? checking access for key=($key)") if DEBUG;
	my ($calling_package, undef, undef, $hash_action) = caller(1);
    ($calling_package ne "main") || handleError "Illegal Operation : hashes cannot be accessed directly";
	my (undef, undef, undef, $_calling_subroutine) = caller(2);
    my ($calling_subroutine) = ($_calling_subroutine =~ /\:\:([a-zA-Z0-9_]+)$/);
    # we do not handle DESTROY methods, they get funky
    return if $calling_subroutine =~ /DESTROY/;
	# check if our key ever exists ...
	unless (exists $self->{fields}->{$key}) {
		# if our field does not exist, then we should throw an exception
		# we want to do this to protect ourselves against mis-spellings
		# of field names. This means that we are only allowed to create
		# fields before the hash is blessed. We do however allow one repreise
		# which is for a field to be created inside of the "new" method.
		#
		# here we check to see if they are in a methos allowed by the
		# $KEY_CREATION_ACCESS_REGEX and if not throw an
		# IllegalOperation exception...
        debug("    ? attempting to autovivify key=($key) in method=($calling_subroutine) from package=($calling_package)") if DEBUG;
		($calling_subroutine =~ /$KEY_CREATION_ACCESS_REGEX/)
            || handleError "Illegal Operation : attempt to create non-existant key ($key) in method '$calling_subroutine'";
		# however, if they are in method allowed by $KEY_CREATION_ACCESS_REGEX
        # the then we allow the field to be created (this happens in STORE) and
        # we note which package asked for it to be created.
        debug("    + autovivified key=($key) in hash in method=($calling_subroutine) from package=($calling_package)") if DEBUG;
		$self->{fields_init_in}->{$key} = $calling_package;
	}
	# if our key does exist then,
	# check who is asking for it
	else {
		# first lets check the private fields ...
		if ($key =~ /$PRIVATE_FIELD_IDENTIFIER/) {
			# we need to check to see if this is
			# being called from an $KEY_CREATION_ACCESS_REGEX method and ...
			if ($calling_subroutine =~ /$KEY_CREATION_ACCESS_REGEX/ &&
				# if it is being asked to STORE a value
				$hash_action =~ /\:\:STORE$/ &&
				# and that the calling package is
				# not the same package who initialized
				# the field
				$calling_package ne $self->{fields_init_in}->{$key}) {
				# if all these conditions meet then we
				# have a problem ...

				# first lets check if the package which
				# initialized the field is actually a
				# descendant of the calling package.
				# Meaning that the child package may
				# have intialized a private field that
				# the parent had reserved, but not yet
				# intialized (this can happen if you
				# run your _init routines before you
				# run the parents).
				if ($self->{fields_init_in}->{$key}->isa($calling_package)) {
					handleError "Illegal Operation : It seems that " .
                            $self->{fields_init_in}->{$key} .
                            " maybe stepping on one of ${calling_package}'s private fields ($key)";
				}
				# next we check to see if maybe the
				# calling package is a descendent of the
				# package the field was intialized in.
				# Meaning that the child package is
				# stepping on a private field from the
				# parent.
				elsif ($calling_package->isa($self->{fields_init_in}->{$key})) {
					handleError "Illegal Operation : $calling_package is stepping on a private field ($key) that belongs to " . $self->{fields_init_in}->{$key};
				}
				# and lastly our fall through case, since
				# no-one should be doing this anyway.
				else {
					handleError "Illegal Operation : attempting to set a private field ($key) in $calling_subroutine, field was already set by " . $self->{fields_init_in}->{$key};
				}
			}
			# okay now we know that is all set
			#
			# For a private field we need to check
			# if the calling package is the same as
			# the package the field was intialized in.
			# If it is, then all is fine.
			# However, if it is not we need to check
			# on some things ...
            debug(">>> calling package=($calling_package) package init in=($self->{fields_init_in}->{$key})") if DEBUG;
			unless ($calling_package eq $self->{fields_init_in}->{$key}) {
				# ocasionally the calling package is
				# actually the derived class (because
				# its a dynamic method call), in which case
				# the call may actually still be valid,
				# so we check the calling subroutine.
				# That subroutine name will contain the
				# name of the package from where it originated,
				# and therefore tell us if the privacy is being
				# violated or not.
				($calling_subroutine =~ /^$self->{fields_init_in}->{$key}\:\:/)
					|| handleError "Illegal Operation : $calling_package ($calling_subroutine) attempted to access private field ($key) for " . $self->{fields_init_in}->{$key};
			}
		}
		# now we check the protected fields ....
		elsif ($key =~ /$PROTECTED_FIELD_IDENTIFIER/) {
			# a protected field is one that can only be accessed
			# if the calling package is a descendent of the
			# orginal class it was blessed into, or the actual
			# class itself
			($self->{blessed_class}->isa($calling_package))
				|| handleError "Illegal Operation : $calling_package attempted to access protected field ($key) for " . $self->{blessed_class};
		}
        elsif (defined($PUBLIC_FIELD_IDENTIFIER) && $key =~ /$PUBLIC_FIELD_IDENTIFIER/) {
            # if the field is public, then we dont
            # need to do anything, access is granted.
            # we do though, check to see if the public
            # reg-ex is even defined, as it may not be
            ;
        }
	}
	# if we return normally from this
	# subtroutine, meaning no exceptions
	# were thrown, then all is well in our
	# hash accessing world.
    debug("  + access granted for key=($key)") if DEBUG;
}


1;

__END__