File Coverage

blib/lib/Tie/HashObject.pm

Criterion	Covered	Total	%
statement	3	90	3.3
branch	0	40	0.0
condition	0	6	0.0
subroutine	1	15	6.6
pod	0	1	0.0
total	4	152	2.6

package Tie::HashObject;

sub new {
        my $class = shift;
        my %args  = @_;

        my %tied;
        #tie %tied, Tie::HashMethods, {keys=> $args{keys}};
        tie %tied, Tie::HashMethods;

        my $self = bless \%tied, $class;
	$tied{keys}   = $args{keys} if exists $args{keys};
        $tied{object} = $self;
        return $self;
}
1;

package Tie::HashMethods;

use strict;

our $VERSION = '0.01';

sub defined_public_keys {
	my $self = shift;
	my $keys = [];
	foreach my $key (@{$self->method_keys}) {
		push @$keys, $key if defined $self->{storage}->{$key};
	}
	return $keys;
}


sub DESTROY {
	my $self = shift;
	# Note: I don't know if this is neccessary.
	# but it gets rid of the self reference...
	$self->{object} = {};
	# I worried about having a reference inside a reference... but I'm not sure whether this is a problem.
}

sub object {
	my $self = shift;
	$self->{object} = shift if defined $_[0];
	return $self->{object};
}

sub method_keys {
	my $self = shift;
	$self->{keys} = shift if defined $_[0];
	return $self->{keys};
}

sub TIEHASH  {
	my $class = shift;
	my $args  = shift;

	my $self = bless {}, $class;

	if (exists $args->{keys}) {
		$self->method_keys($args->{keys});
	}

	return $self;
}

sub STORE {
	my $self  = shift;
	my $key   = shift;
	my $value = shift;

	if (!defined $self->object && $key eq 'object') {
		if (ref $value) {
			$self->object($value);
		} else {
			warn sprintf('First call to %s->{object} must be a reference to an object', __PACKAGE__);
		}
	}
	elsif (!defined $self->method_keys && $key eq 'keys') {
		$self->method_keys($value);
	}
        elsif ( $self->object->isa( (caller)[0] ) ) {
		return $self->{storage}->{$key} = $value;
	}
	elsif (grep /^$key$/, @{$self->method_keys}) {
		$self->object->$key($value);
	}
	else {
		warn "Invalid key: " . $key;
	}
}

sub FETCH {
	my $self = shift;
	my $key  = shift;
        if ( $self->object->isa((caller)[0]) ) {
		return $self->{storage}->{$key};
	}
	elsif (grep /^$key$/, @{$self->method_keys}) {
		return $self->object->$key;
	}
	else {
		warn "Invalid key: " . $key;
	}
}

sub FIRSTKEY {
	my $self = shift;
        if ( $self->object->isa((caller)[0]) ) {
		return (keys %{$self->{storage}})[0];
	}
	else {
		# we have to do this for data dumps...
		return (@{$self->defined_public_keys})[0];
	}
}

sub NEXTKEY {
	my $self        = shift;
	my $last_method = shift;

	my @keys;

        if ( $self->object->isa((caller)[0]) ) {
		@keys = keys %{$self->{storage}};
	}
	else {
		@keys = @{$self->defined_public_keys};
	}
	my $next_index  = 0;
	foreach my $key (@keys) {
		$next_index++;
		last if $last_method eq $key;
	}
	return $next_index > scalar @keys ? undef : $keys[$next_index];
}


sub EXISTS {
	my $self = shift;
	my $key  = shift;

        if ( $self->object->isa((caller)[0]) ) {
		return exists $self->{storage}->{$key};
	}
	else {
		return (grep /^$key$/, @{$self->defined_public_keys});
	}
}

sub DELETE {
	my $self = shift;
	my $key  = shift;

        if ( $self->object->isa((caller)[0]) ) {
		return delete $self->{storage}->{$key};
	}
	else {
		warn "Cannot delete methods. Please set the values instead.";
	}
}

# override this method if you have some default for clearing the method hash values...
sub CLEAR  {
	my $self = shift;
        if ( $self->object->isa((caller)[0]) ) {
		$self->{storage} = {};
	}
	else {
		warn "Cannot clear tied method calls";
	}
}

sub SCALAR {
	my $self = shift;
        if ( $self->object->isa((caller)[0]) ) {
		return scalar keys %{$self->{storage}};
	}
	else {
		return scalar @{$self->defined_public_keys};
	}
}

1;

__END__